From a0a86a5f1e77126ea452edbdea9a609fde4a0366 Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Tue, 28 Aug 2007 15:03:39 +0200 Subject: [PATCH] added oct package for long-long arith --- external/oct/.cvsignore | 4 + external/oct/LICENSE | 19 + external/oct/branch-test.lisp | 132 +++ external/oct/oct-test.system | 44 + external/oct/oct.system | 72 ++ external/oct/qd-class.lisp | 256 ++++ external/oct/qd-complex.lisp | 693 +++++++++++ external/oct/qd-const.lisp | 2591 +++++++++++++++++++++++++++++++++++++++++ external/oct/qd-dd.lisp | 138 +++ external/oct/qd-extra.lisp | 863 ++++++++++++++ external/oct/qd-format.lisp | 130 +++ external/oct/qd-fun.lisp | 952 +++++++++++++++ external/oct/qd-io.lisp | 472 ++++++++ external/oct/qd-methods.lisp | 896 ++++++++++++++ external/oct/qd-package.lisp | 227 ++++ external/oct/qd-rep.lisp | 156 +++ external/oct/qd-test.lisp | 409 +++++++ external/oct/qd.lisp | 1149 ++++++++++++++++++ external/oct/rt-tests.lisp | 547 +++++++++ external/oct/tests.lisp | 304 +++++ external/oct/timing.lisp | 176 +++ 21 files changed, 10230 insertions(+) create mode 100644 external/oct/.cvsignore create mode 100644 external/oct/LICENSE create mode 100644 external/oct/branch-test.lisp create mode 100644 external/oct/oct-test.system create mode 100644 external/oct/oct.system create mode 100644 external/oct/qd-class.lisp create mode 100644 external/oct/qd-complex.lisp create mode 100644 external/oct/qd-const.lisp create mode 100644 external/oct/qd-dd.lisp create mode 100644 external/oct/qd-extra.lisp create mode 100644 external/oct/qd-format.lisp create mode 100644 external/oct/qd-fun.lisp create mode 100644 external/oct/qd-io.lisp create mode 100644 external/oct/qd-methods.lisp create mode 100644 external/oct/qd-package.lisp create mode 100644 external/oct/qd-rep.lisp create mode 100644 external/oct/qd-test.lisp create mode 100644 external/oct/qd.lisp create mode 100644 external/oct/rt-tests.lisp create mode 100644 external/oct/tests.lisp create mode 100644 external/oct/timing.lisp diff --git a/external/oct/.cvsignore b/external/oct/.cvsignore new file mode 100644 index 0000000..6509652 --- /dev/null +++ b/external/oct/.cvsignore @@ -0,0 +1,4 @@ +*.ppcf +*.sparcf +*.x86f +*.err diff --git a/external/oct/LICENSE b/external/oct/LICENSE new file mode 100644 index 0000000..d4bf97c --- /dev/null +++ b/external/oct/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2007 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. \ No newline at end of file diff --git a/external/oct/branch-test.lisp b/external/oct/branch-test.lisp new file mode 100644 index 0000000..a5c6ce5 --- /dev/null +++ b/external/oct/branch-test.lisp @@ -0,0 +1,132 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;;; Some simple tests to see that we're computing the branch cuts +;;; correctly. +;;; +;;; NOTE: the tests assume that the functions for double-float are +;;; computing the values correctly for the branch cuts. We need to +;;; fix this. + +(in-package #:qd) + +(defun check-signs (fun arg real-sign imag-sign) + (let* ((z (funcall fun arg)) + (x (realpart z)) + (y (imagpart z))) + (unless (and (= (float-sign x) real-sign) + (= (float-sign y) imag-sign)) + (format t "Sign of result doesn't match expected signs~%~ + ~& fun = ~A~ + ~& arg = ~A~ + ~& res = ~A~ + ~& expected = ~A ~A~%" + fun arg z real-sign imag-sign)))) + +(defun get-signs (z) + (values (float-sign (realpart z)) + (float-sign (imagpart z)))) + +;; asin branch cut is the real axis |x| > 1. For x < -1, it is +;; continuous with quadrant II; for x > 1, continuous with quadrant +;; IV. +(defun test-asin () + ;; Check x < -1 + (multiple-value-bind (tr ti) + (get-signs (asin #c(-2d0 +1d-20))) + (check-signs #'asin -2d0 tr ti) + (check-signs #'asin -2w0 tr ti) + (check-signs #'asin #q-2 tr ti) + (check-signs #'asin #c(-2d0 0d0) tr ti) + (check-signs #'asin #c(-2w0 0w0) tr ti) + (check-signs #'asin #q(-2 0) tr ti) + (check-signs #'asin #c(-2d0 -0d0) tr (- ti)) + (check-signs #'asin #c(-2w0 -0w0) tr (- ti)) + (check-signs #'asin #q(-2 #q-0q0) tr (- ti)) + ) + + ;; Check x > 1 + (multiple-value-bind (tr ti) + (get-signs (asin #c(2d0 -1d-20))) + (check-signs #'asin 2d0 tr ti) + (check-signs #'asin 2w0 tr ti) + (check-signs #'asin #q2 tr ti) + (check-signs #'asin #c(2d0 -0d0) tr ti) + (check-signs #'asin #c(2w0 -0w0) tr ti) + (check-signs #'asin #q(2 #q-0q0) tr ti))) + +;; acos branch cut is the real axis, |x| > 1. For x < -1, it is +;; continuous with quadrant II; for x > 1, quadrant IV. +(defun test-acos () + ;; Check x < -1 + (multiple-value-bind (tr ti) + (get-signs (acos #c(-2d0 +1d-20))) + (check-signs #'acos -2d0 tr ti) + (check-signs #'acos -2w0 tr ti) + (check-signs #'acos #q-2 tr ti)) + + ;; Check x > 1 + (multiple-value-bind (tr ti) + (get-signs (acos #c(2d0 -1d-20))) + (check-signs #'acos 2d0 tr ti) + (check-signs #'acos 2w0 tr ti) + (check-signs #'acos #q2 tr ti))) + + +;; atan branch cut is the imaginary axis, |y| > 1. For y < -1, it is +;; continuous with quadrant IV; for x > 1, quadrant II. +(defun test-atan () + ;; Check y < -1 + (multiple-value-bind (tr ti) + (get-signs (atan #c(1d-20 -2d0))) + (check-signs #'atan #c(0d0 -2d0) tr ti) + (check-signs #'atan #c(0w0 -2w0) tr ti) + (check-signs #'atan #q(#q0 #q-2) tr ti)) + + ;; Check y > 1 + (multiple-value-bind (tr ti) + (get-signs (atan #c(-1d-20 2d0))) + (check-signs #'atan #c(-0d0 2d0) tr ti) + (check-signs #'atan #c(-0w0 2w0) tr ti) + (check-signs #'atan #q(#q-0 2) tr ti))) + + +(defun test-atanh () + ;; Check x < -1 + (multiple-value-bind (tr ti) + (get-signs (atanh #c(-2d0 -1d-20))) + (check-signs #'atanh -2d0 tr ti) + (check-signs #'atanh -2w0 tr ti) + (check-signs #'atanh #q-2 tr ti)) + + ;; Check x > 1 + (multiple-value-bind (tr ti) + (get-signs (atanh #c(2d0 1d-20))) + (check-signs #'atanh 2d0 tr ti) + (check-signs #'atanh 2w0 tr ti) + (check-signs #'atanh #q2 tr ti))) + + + diff --git a/external/oct/oct-test.system b/external/oct/oct-test.system new file mode 100644 index 0000000..7efe796 --- /dev/null +++ b/external/oct/oct-test.system @@ -0,0 +1,44 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;; This requres the RT package. You can obtain a copy from +;; http://www.cliki.net/RT. +(require :rt) + +(mk:defsystem oct-extras + :source-pathname (make-pathname :directory (pathname-directory *load-pathname*)) + :depends-on ("oct") + :components + ((:file "qd-extra"))) + +(mk:defsystem oct-test + :source-pathname (make-pathname :directory (pathname-directory *load-pathname*)) + :depends-on ("oct" "oct-extras") + :components + ((:file "qd-test") + ;;(:file "tests") + (:file "branch-test") + (:file "rt-tests"))) + diff --git a/external/oct/oct.system b/external/oct/oct.system new file mode 100644 index 0000000..d7b70a5 --- /dev/null +++ b/external/oct/oct.system @@ -0,0 +1,72 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;; If you want all core functions to be inline (like the C++ code +;; does), add :qd-inline to *features* by enabling the following line. +;; This makes compilation much, much slower, but the resulting code +;; conses much less and is significantly faster. +#+(not (and cmu x86)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (pushnew :qd-inline *features*)) + +;; To be able to inline all the functions, we need to make +;; *inline-expansion-limit* much larger. +;; +;; Not sure we really want to inline everything, but the QD C++ code +;; inlines all of the functions so we do the same. This makes CMUCL +;; take a very long time to compile the code, and the resulting +;; functions are huge. (I think div-qd is 8 KB, and sqrt-qd is a +;; whopping 30 KB!) +;; +#+(and cmu qd-inline) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf ext:*inline-expansion-limit* 1600)) + +(mk:defsystem oct + :source-pathname (make-pathname :directory (pathname-directory *load-pathname*)) + :components + ((:file "qd-package") + (:file "qd-rep" :depends-on ("qd-package")) + #-cmu + (:file "qd-dd" :depends-on ("qd-package")) + (:file "qd" + :depends-on ("qd-rep")) + (:file "qd-io" + :depends-on ("qd")) + (:file "qd-const" + :depends-on ("qd-io")) + (:file "qd-fun" + :depends-on ("qd" "qd-const")) + (:file "qd-class" + :depends-on ("qd-fun")) + (:file "qd-methods" + :depends-on ("qd-class")) + (:file "qd-format" + :depends-on ("qd-methods")) + (:file "qd-complex" + :depends-on ("qd-methods")) + )) + + diff --git a/external/oct/qd-class.lisp b/external/oct/qd-class.lisp new file mode 100644 index 0000000..a97edca --- /dev/null +++ b/external/oct/qd-class.lisp @@ -0,0 +1,256 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qd) + +(define-symbol-macro * cl:*) +(define-symbol-macro - cl:-) +(define-symbol-macro / cl:/) + +(defclass qd-real () + ((qd :initform +qd-zero+ + :reader qd-value + :initarg :value + :type %quad-double))) + +(defclass qd-complex () + ((real :initform +qd-zero+ + :reader qd-real + :initarg :real + :type %quad-double) + (imag :initform +qd-zero+ + :reader qd-imag + :initarg :imag + :type %quad-double))) + +#-cmu +(defmethod print-object ((qd qd-real) stream) + (format stream "~/qdi::qd-format/" (qd-value qd))) + +#+cmu +(defun print-qd (q stream) + (declare (type %quad-double q)) + (if (or (ext:float-infinity-p (qd-0 q)) + (ext:float-nan-p (qd-0 q))) + (format stream "~/qdi::qd-format/" q) + (format stream "#q~/qdi::qd-format/" q))) +#+cmu +(defmethod print-object ((qd qd-real) stream) + (print-qd (qd-value qd) stream)) + +(defmethod make-qd ((x real)) + (make-instance 'qd-real :value (make-qd-d (float x 1d0)))) + +(defmethod make-qd ((x qd-real)) + (make-instance 'qd-real :value (qd-value x))) + +(defmethod print-object ((qd qd-complex) stream) + (format stream "#q(~/qdi::qd-format/ ~/qdi::qd-format/)" + (qd-real qd) + (qd-imag qd))) + +(defmethod print-object ((qd qd-complex) stream) + (write-string "#q(" stream) + (print-qd (qd-real qd) stream) + (write-char #\space stream) + (print-qd (qd-imag qd) stream) + (write-string ")" stream)) + +(defmethod qd-value ((x real)) + (make-qd-d (float x 1d0))) + +(defmethod make-load-form ((qd qd-real) &optional environment) + (declare (ignore environment)) + `(make-instance ',(class-of qd) + :value ',(qd-value qd))) + +(defmethod make-load-form ((qd qd-complex) &optional environment) + (declare (ignore environment)) + `(make-instance ',(class-of qd) + :real ',(qd-value (realpart qd)) + :imag ',(qd-value (imagpart qd)))) + +(defmethod describe-object ((q qd-real) stream) + (multiple-value-bind (q0 q1 q2 q3) + (qd-parts (qd-value q)) + (format stream "~&~S is a QD-REAL with components ~ + ~% ~A, ~A, ~A, ~A~%" + q q0 q1 q2 q3))) + +(defmethod describe-object ((q qd-complex) stream) + (format stream "~&~S is a QD-COMPLEX" q) + (format stream "~&It has components~&REAL: ") + (describe (realpart q)) + (format stream "~&IMAG: ") + (describe (imagpart q))) + + +(defgeneric add1 (a) + (:documentation "Add 1")) + +(defgeneric sub1 (a) + (:documentation "Subtract 1")) + + +(defgeneric two-arg-+ (a b) + (:documentation "A + B")) + +(defgeneric two-arg-- (a b) + (:documentation "A - B")) + +(defgeneric two-arg-* (a b) + (:documentation "A * B")) + +(defgeneric two-arg-/ (a b) + (:documentation "A / B")) + +(defgeneric two-arg-< (a b) + (:documentation "A < B")) + +(defgeneric two-arg-> (a b) + (:documentation "A > B")) + +(defgeneric two-arg-<= (a b) + (:documentation "A <= B")) + +(defgeneric two-arg->= (a b) + (:documentation "A >= B")) + +(defgeneric two-arg-= (a b) + (:documentation "A = B?")) + + +(defgeneric unary-minus (a) + (:documentation "-A")) + +(defgeneric unary-divide (a) + (:documentation "1 / A")) + +(defgeneric qzerop (a) + (:documentation "A = 0?")) + +(defgeneric qplusp (a) + (:documentation "A > 0")) + +(defgeneric qminusp (a) + (:documentation "A < 0")) + +(defgeneric qfloat (x ftype) + (:documentation "Convert X to a float of the same type a FLOAT")) + +(defgeneric qrealpart (x) + (:documentation "The real part of X")) + +(defgeneric qimagpart (x) + (:documentation "The imaginary part of X")) + +(defgeneric qconjugate (z) + (:documentation "The complex conjugate of Z")) + +(defgeneric qscale-float (x n) + (:documentation "Multiply the float X by 2^N")) + +(defgeneric qabs (x) + (:documentation "Absolute value of X")) + +(defgeneric qexp (x) + (:documentation "Exponential of X")) + +(defgeneric qsin (x) + (:documentation "Sine of X")) + +(defgeneric qcos (x) + (:documentation "Cosine of X")) + +(defgeneric qtan (x) + (:documentation "Tangent of X")) + +(defgeneric qsinh (x) + (:documentation "Hyperbolic sine of X")) + +(defgeneric qcosh (x) + (:documentation "Hyperbolic cosine of X")) + +(defgeneric qtanh (x) + (:documentation "Hyperbolic tangent of X")) + +(defgeneric qsqrt (x) + (:documentation "Square root of X")) + +(defgeneric qlog (a &optional b) + (:documentation "Log of A base B. If B not given, then natural log")) + +(defgeneric log1p (x) + (:documentation "log(1+x)")) + +(defgeneric qatan (y &optional x) + (:documentation "If X not given, atan(y). If X is given, atan(y/x), taking + the quadrant into account")) + +(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 qinteger-decode-float (f) + (:documentation "integer-decode-float")) + +(defgeneric qdecode-float (f) + (:documentation "decode-float")) + +(defgeneric qfloor (x &optional y)) + +(defgeneric qffloor (x &optional y)) + +(defgeneric %unary-round (x)) + +(defgeneric qfloat-sign (a &optional b) + (:documentation "Transfer sign of A to B. If B not given, assume 1")) + +(defgeneric qasin (x) + (:documentation "Inverse sine of X")) + +(defgeneric qacos (x) + (:documentation "Inverse cosine of X")) + +(defgeneric qacosh (x) + (:documentation "Inverse hyperbolic cosine of X")) + +(defgeneric qatanh (x) + (:documentation "Inverse hyperbolic tangent of X")) + +(defgeneric qcis (x) + (:documentation "(complex (cos x) (sin x))")) + +(defgeneric qphase (x) + (:documentation "Phase of X")) + +(defgeneric coerce (x type) + (:documentation "COERCE")) + +(defgeneric random (x &optional state) + (:documentation "RANDOM")) + diff --git a/external/oct/qd-complex.lisp b/external/oct/qd-complex.lisp new file mode 100644 index 0000000..ed57efd --- /dev/null +++ b/external/oct/qd-complex.lisp @@ -0,0 +1,693 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;; Most of this code taken from CMUCL and slightly modified to support +;; QD-COMPLEX. + +(in-package #:qd) + +(defmethod two-arg-/ ((a qd-real) (b rational)) + (make-instance 'qd-real :value (div-qd (qd-value a) + (qd-value (float b #q0))))) + +(defmethod two-arg-/ ((a rational) (b qd-real)) + (make-instance 'qd-real :value (div-qd (qd-value (float a #q0)) + (qd-value b)))) + +(defmethod two-arg-* ((a qd-real) (b rational)) + (make-instance 'qd-real :value (mul-qd (qd-value a) (qd-value (float b #q0))))) + +(defmethod two-arg-+ ((a qd-real) (b rational)) + (make-instance 'qd-real :value (add-qd (qd-value a) (qd-value (float b #q0))))) + +(defmethod two-arg-+ ((a rational) (b qd-real)) + (make-instance 'qd-real :value (add-qd (qd-value b) (qd-value (float a #q0))))) + +(defmethod two-arg-- ((a qd-real) (b rational)) + (make-instance 'qd-real :value (sub-qd (qd-value a) (qd-value (float b #q0))))) + +(defmethod two-arg-- ((a rational) (b qd-real)) + (make-instance 'qd-real :value (sub-qd (qd-value (float a #q0)) (qd-value b)))) + +(defmethod unary-minus ((z qd-complex)) + (complex (- (realpart z)) + (- (imagpart z)))) + +(defmethod qzerop ((z qd-complex)) + (and (zerop (realpart z)) + (zerop (imagpart z)))) + +(defmethod two-arg-+ ((a qd-complex) (b qd-complex)) + (complex (+ (realpart a) (realpart b)) + (+ (imagpart a) (imagpart b)))) + +(defmethod two-arg-+ ((a qd-complex) (b real)) + (complex (+ (realpart a) b) + (imagpart a))) + +(defmethod two-arg-+ ((a qd-complex) (b qd-real)) + (complex (+ (realpart a) b) + (imagpart a))) + +(defmethod two-arg-+ ((a qd-real) (b qd-complex)) + (complex (+ a (realpart b)) + (imagpart b))) + +(defmethod two-arg-+ ((a qd-complex) (b cl:complex)) + (complex (+ (realpart a) (imagpart b)) + (+ (imagpart a) (imagpart b)))) + +(defmethod two-arg-+ ((a number) (b qd-complex)) + (two-arg-+ b a)) + +(defmethod two-arg-- ((a qd-complex) (b qd-complex)) + (complex (- (realpart a) (realpart b)) + (- (imagpart a) (imagpart b)))) + +(defmethod two-arg-- ((a qd-complex) (b real)) + (complex (- (realpart a) b) + (imagpart a))) + +(defmethod two-arg-- ((a qd-complex) (b cl:complex)) + (complex (- (realpart a) (realpart b)) + (- (imagpart a) (imagpart b)))) + +(defmethod two-arg-- ((a qd-complex) (b qd-real)) + (complex (- (realpart a) b) + (imagpart a))) + +(defmethod two-arg-- ((a number) (b qd-complex)) + (complex (- (realpart a) (realpart b)) + (- (imagpart a) (imagpart b)))) + +(defmethod two-arg-- ((a qd-real) (b qd-complex)) + (complex (- a (realpart b)) + (- (imagpart b)))) + +(defmethod two-arg-* ((a qd-complex) (b qd-complex)) + (let* ((rx (realpart a)) + (ix (imagpart a)) + (ry (realpart b)) + (iy (imagpart b))) + (complex (- (* rx ry) (* ix iy)) + (+ (* rx iy) (* ix ry))))) + +(defmethod two-arg-* ((a qd-complex) (b real)) + (let* ((rx (realpart a)) + (ix (imagpart a))) + (complex (* rx b) + (* ix b)))) + +(defmethod two-arg-* ((a qd-complex) (b qd-real)) + (let* ((rx (realpart a)) + (ix (imagpart a))) + (complex (* rx b) + (* ix b)))) + +(defmethod two-arg-* ((a qd-real) (b qd-complex)) + (two-arg-* b a)) + + + +#+cmu +(defmethod two-arg-* ((a qd-complex) (b cl:complex)) + ;; For now, convert B into a qd-complex and use that. + (let ((re (coerce (realpart b) 'ext:double-double-float)) + (im (coerce (imagpart b) 'ext:double-double-float))) + (two-arg-* a (make-instance 'qd-complex + :real (make-qd-dd re 0w0) + :imag (make-qd-dd im 0w0))))) + +#-cmu +(defmethod two-arg-* ((a qd-complex) (b cl:complex)) + ;; For now, convert B into a qd-complex and use that. + (let ((re (coerce (realpart b) 'double-float)) + (im (coerce (imagpart b) 'double-float))) + (two-arg-* a (make-instance 'qd-complex + :real (make-qd-d re) + :imag (make-qd-d im))))) + +(defmethod two-arg-* ((a number) (b qd-complex)) + (two-arg-* b a)) + +(defmethod two-arg-/ ((x qd-complex) (y qd-complex)) + (let* ((rx (realpart x)) + (ix (imagpart x)) + (ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (complex (/ (+ rx (* ix r)) dn) + (/ (- ix (* rx r)) dn))) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (complex (/ (+ (* rx r) ix) dn) + (/ (- (* ix r) rx) dn)))))) + +(defmethod two-arg-/ ((x qd-complex) (y qd-real)) + (complex (/ (realpart x) y) + (/ (imagpart x) y))) + +(defmethod two-arg-/ ((x qd-complex) (y number)) + (complex (/ (realpart x) y) + (/ (imagpart x) y))) + +(defmethod two-arg-/ ((x number) (y qd-complex)) + (let* ((rx (realpart x)) + (ix (imagpart x)) + (ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (complex (/ (+ rx (* ix r)) dn) + (/ (- ix (* rx r)) dn))) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (complex (/ (+ (* rx r) ix) dn) + (/ (- (* ix r) rx) dn)))))) + +(defmethod two-arg-/ ((x qd-real) (y qd-complex)) + ;; This can be simplified since X is real. + (let* ((rx (realpart x)) + (ix (imagpart x)) + (ry (realpart y)) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (+ ry (* r iy)))) + (complex (/ (+ rx (* ix r)) dn) + (/ (- ix (* rx r)) dn))) + (let* ((r (/ ry iy)) + (dn (+ iy (* r ry)))) + (complex (/ (+ (* rx r) ix) dn) + (/ (- (* ix r) rx) dn)))))) + +(defmethod unary-divide ((a qd-complex)) + (two-arg-/ #q1 a)) + +(defmethod coerce ((obj t) (type t)) + (cl:coerce obj type)) + +(defmethod coerce ((number cl:real) (type (eql 'qd-real))) + (float number #q0)) + +(defmethod coerce ((number qd-real) (type (eql 'qd-real))) + number) + +(defmethod coerce ((number cl:number) (type (eql 'qd-complex))) + (complex (float (realpart number) #q0) + (float (imagpart number) #q0))) + +(defmethod coerce ((number qd-complex) (type (eql 'qd-complex))) + number) + +(declaim (inline square)) +(defun square (x) + (declare (type qd-real x)) + (make-instance 'qd-real :value (sqr-qd (qd-value x)))) + +(defun qd-complex-sqrt (z) + "Principle square root of Z + +Z may be any number, but the result is always a complex." + (declare (type qd-complex z)) + (multiple-value-bind (rho k) + (qd-cssqs z) + (declare (type qd-real rho) + (type fixnum k)) + (let ((x (realpart z)) + (y (imagpart z)) + (eta #q0.0) + (nu #q0.0)) + (declare (type qd-real x y eta nu)) + + (locally + ;; space 0 to get maybe-inline functions inlined. + (declare (optimize (speed 3) (space 0))) + + (setf rho (+ (scalb (abs x) (- k)) (sqrt rho))) + + (cond ((oddp k) + (setf k (ash k -1))) + (t + (setf k (1- (ash k -1))) + (setf rho (+ rho rho)))) + + (setf rho (scalb (sqrt rho) k)) + + (setf eta rho) + (setf nu y) + + (when (not (zerop rho)) + (setf nu (/ (/ nu rho) 2d0))) + (when (minusp x) + (setf eta (abs nu)) + (setf nu (float-sign y rho)))) + (complex eta nu)))) + +(defun qd-complex-log-scaled (z j) + "Compute log(2^j*z). + +This is for use with J /= 0 only when |z| is huge." + (declare (type qd-complex z) + (fixnum j)) + ;; The constants t0, t1, t2 should be evaluated to machine + ;; precision. In addition, Kahan says the accuracy of log1p + ;; influences the choices of these constants but doesn't say how to + ;; choose them. We'll just assume his choices matches our + ;; implementation of log1p. + (let ((t0 (/ 1 (sqrt #q2.0q0))) + (t1 #q1.2q0) + (t2 #q3q0) + (ln2 #.(log #q2.0)) + (x (realpart z)) + (y (imagpart z))) + (multiple-value-bind (rho k) + (qd-cssqs z) + (declare (optimize (speed 3))) + (let ((beta (max (abs x) (abs y))) + (theta (min (abs x) (abs y)))) + (complex (if (and (zerop k) + (< t0 beta) + (or (<= beta t1) + (< rho t2))) + (/ (log1p (+ (* (- beta 1.0d0) + (+ beta 1.0d0)) + (* theta theta))) + 2d0) + (+ (/ (log rho) 2d0) + (* (+ k j) ln2))) + (atan y x)))))) + +(defun qd-complex-log (z) + "Log of Z = log |Z| + i * arg Z + +Z may be any number, but the result is always a complex." + (declare (type qd-complex z)) + (qd-complex-log-scaled z 0)) + + +;; Let us note the following "strange" behavior. atanh 1.0d0 is +;; +infinity, but the following code returns approx 176 + i*pi/4. The +;; reason for the imaginary part is caused by the fact that arg i*y is +;; never 0 since we have positive and negative zeroes. + +;; +;; atanh(z) = (log(1+z) - log(1-z))/2 +;; +;; The branch cut is on the real axis for |x| >= 1. For x =< -1, +;; atanh is continuous with quadrant III; for x >= 1, continuous with +;; quadrant I. +(defun qd-complex-atanh (z) + "Compute atanh z = (log(1+z) - log(1-z))/2" + (declare (type (or qd-real qd-complex) z)) + (cond ((and (typep z 'qd-real) (< z -1)) + (qd-complex-atanh (complex z -0d0))) + (t + (flet ((careful-mul (a b) + ;; Carefully multiply a and b, taking care to handle + ;; signed zeroes. Only need to handle the case of b + ;; being zero. + (if (zerop b) + (if (minusp (* (float-sign a) (float-sign b))) + #q-0 + #q0) + (* a b)))) + (let* ( ;; Constants + (theta (/ (sqrt most-positive-double-float) 4.0d0)) + (rho (/ 4.0d0 (sqrt most-positive-double-float))) + (half-pi #.(/ +pi+ 2d0)) + (rp (realpart z)) + (beta (float-sign rp)) + (x (* beta rp)) + (y (careful-mul beta (- (imagpart z)))) + (eta #q0.0q0) + (nu #q0.0q0)) + ;; Shouldn't need this declare. + (declare (type qd-real x y)) + (locally + (declare (optimize (speed 3))) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x #q1.0q0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4d0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (atan (* 0.5d0 t2)))))) + )) + (t + (let ((t1 (+ (abs y) rho))) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (atan (careful-mul 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (complex (* beta eta) + (- (* beta nu))))))))) + + +;; tanh(z) = sinh(z)/cosh(z) +;; +(defun qd-complex-tanh (z) + "Compute tanh z = sinh z / cosh z" + (declare (type (or qd-real qd-complex) z)) + (let ((x (realpart z)) + (y (imagpart z))) + (locally + ;; space 0 to get maybe-inline functions inlined + (declare (optimize (speed 3) (space 0))) + (cond ((> (abs x) #.(/ (+ (log most-positive-double-float) + (log 2d0)) + 4d0)) + ;; The threshold above is + ;; asinh(most-positive-double-float)/4, but many Lisps + ;; cannot actually compute that. Hence use the + ;; (accurate) approximation + ;; asinh(most-positive-double-float) = + ;; log(most-positive-double-float) + log(2) + (complex (float-sign x) + (float-sign y))) + (t + ;; With quad-double's it happens that tan(pi/2) will + ;; actually produce a division by zero error. We need to + ;; handle that case carefully. + (let* ((tv (ignore-errors (tan y))) + (s (sinh x)) + (rho (sqrt (+ 1.0d0 (* s s))))) + (cond (tv + (let* ((beta (+ 1.0d0 (* tv tv))) + (den (+ 1.0d0 (* beta s s)))) + (complex (/ (* beta rho s) + den) + (/ tv den)))) + (t + ;; This means tan(y) produced some error. We'll + ;; assume it's an overflow error because y is + ;; pi/2 + 2*k*pi. But we need a value for tv to + ;; compute (/ tv). This would be a signed-zero. + ;; For now, just return +0. + (complex (/ rho s) + #q0))))))))) + +;; Kahan says we should only compute the parts needed. Thus, the +;; realpart's below should only compute the real part, not the whole +;; complex expression. Doing this can be important because we may get +;; spurious signals that occur in the part that we are not using. +;; +;; However, we take a pragmatic approach and just use the whole +;; expression. + +;; NOTE: The formula given by Kahan is somewhat ambiguous in whether +;; it's the conjugate of the square root or the square root of the +;; conjugate. This needs to be checked. + +;; I checked. It doesn't matter because (conjugate (sqrt z)) is the +;; same as (sqrt (conjugate z)) for all z. This follows because +;; +;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z). +;; +;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z) +;; +;; and these two expressions are equal if and only if arg conj z = +;; -arg z, which is clearly true for all z. + +;; NOTE: The rules of Common Lisp says that if you mix a real with a +;; complex, the real is converted to a complex before performing the +;; operation. However, Kahan says in this paper (pg 176): +;; +;; (iii) Careless handling can turn infinity or the sign of zero into +;; misinformation that subsequently disappears leaving behind +;; only a plausible but incorrect result. That is why compilers +;; must not transform z-1 into z-(1+i*0), as we have seen above, +;; nor -(-x-x^2) into (x+x^2), as we shall see below, lest a +;; subsequent logarithm or square root produce a non-zero +;; imaginary part whose sign is opposite to what was intended. +;; +;; The interesting examples are too long and complicated to reproduce +;; here. We refer the reader to his paper. +;; +;; The functions below are intended to handle the cases where a real +;; is mixed with a complex and we don't want CL complex contagion to +;; occur.. + +(declaim (inline 1+z 1-z z-1 z+1)) +(defun 1+z (z) + (complex (+ 1 (realpart z)) (imagpart z))) +(defun 1-z (z) + (complex (- 1 (realpart z)) (- (imagpart z)))) +(defun z-1 (z) + (complex (- (realpart z) 1) (imagpart z))) +(defun z+1 (z) + (complex (+ (realpart z) 1) (imagpart z))) + +(defun qd-complex-acos (z) + "Compute acos z = pi/2 - asin z + +Z may be any number, but the result is always a complex." + (declare (type (or qd-real qd-complex) z)) + (if (and (typep z 'qd-real) (> z 1)) + ;; acos is continuous in quadrant IV in this case. + (qd-complex-acos (complex z -0f0)) + (let ((sqrt-1+z (qd-complex-sqrt (1+z z))) + (sqrt-1-z (qd-complex-sqrt (1-z z)))) + (cond ((zerop (realpart sqrt-1+z)) + ;; Same as below, but we compute atan ourselves (because we + ;; have atan +/- infinity). + (complex + (if (minusp (float-sign (* (realpart sqrt-1-z) + (realpart sqrt-1+z)))) + (- +pi+) + +pi+) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))) + (t + (complex (* 2 (atan (/ (realpart sqrt-1-z) + (realpart sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))))))) + +(defun qd-complex-acosh (z) + "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) + +Z may be any number, but the result is always a complex." + (declare (type (or qd-real qd-complex) z)) + (let* ((sqrt-z-1 (qd-complex-sqrt (z-1 z))) + (sqrt-z+1 (qd-complex-sqrt (z+1 z)))) + ;; We need to handle the case where real part of sqrt-z+1 is zero, + ;; because division by zero with double-double-floats doesn't + ;; produce infinity. + (cond ((zerop (realpart sqrt-z+1)) + ;; Same as below, but we compute atan ourselves (because we + ;; have atan +/- infinity). + (complex (asinh (realpart (* (conjugate sqrt-z-1) + sqrt-z+1))) + (if (minusp (float-sign (* (imagpart sqrt-z-1) + (realpart sqrt-z+1)))) + (- +pi+) + +pi+))) + (t + (complex (asinh (realpart (* (conjugate sqrt-z-1) + sqrt-z+1))) + (* 2 (atan (/ (imagpart sqrt-z-1) + (realpart sqrt-z+1))))))))) + +;; asin(z) = asinh(i*z)/i +;; = -i log(i*z + sqrt(1-z^2)) +(defun qd-complex-asin (z) + "Compute asin z = asinh(i*z)/i + +Z may be any number, but the result is always a complex." + (declare (type (or qd-real qd-complex) z)) + (cond ((and (typep z 'qd-real) (> z 1)) + (qd-complex-asin (complex z -0d0))) + (t + (let* ((sqrt-1-z (qd-complex-sqrt (1-z z))) + (sqrt-1+z (qd-complex-sqrt (1+z z))) + (den (realpart (* sqrt-1-z sqrt-1+z)))) + (cond ((zerop den) + ;; Like below but we handle atan part ourselves. + ;; Must be sure to take into account the sign of + ;; (realpart z) and den! + (complex (if (minusp (* (float-sign (realpart z)) + (float-sign den))) + (- (/ +pi+ 2)) + (/ +pi+ 2)) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z))))) + (t + ;; We get a invalid operation here when z is real and |z| > 1. + (complex (atan (/ (realpart z) + (realpart (* sqrt-1-z sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z)))))))))) + +(defun qd-complex-asinh (z) + "Compute asinh z = log(z + sqrt(1 + z*z)) + +Z may be any number, but the result is always a complex." + (declare (type (or qd-real qd-complex) z)) + ;; asinh z = -i * asin (i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (qd-complex-asin iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defun qd-complex-atan (z) + "Compute atan z = atanh (i*z) / i + +Z may be any number, but the result is always a complex." + (declare (type (or qd-real qd-complex) z)) + ;; atan z = -i * atanh (i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (qd-complex-atanh iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defun qd-complex-tan (z) + "Compute tan z = -i * tanh(i * z) + +Z may be any number, but the result is always a complex." + (declare (type (or qd-real qd-complex) z)) + ;; tan z = -i * tanh(i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (qd-complex-tanh iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defmethod qasin ((x qd-complex)) + (qd-complex-asin x)) + +(defmethod qacos ((x qd-complex)) + (qd-complex-acos x)) + +(defmethod qacosh ((x qd-complex)) + (qd-complex-acosh x)) + +(defmethod qatanh ((x qd-complex)) + (qd-complex-atanh x)) + +(defmethod qsin ((z qd-complex)) + (let ((x (realpart z)) + (y (imagpart z))) + (complex (* (sin x) (cosh y)) + (* (cos x) (sinh y))))) + +(defmethod qcos ((z qd-complex)) + (let ((x (realpart z)) + (y (imagpart z))) + (complex (* (cos x) (cosh y)) + (- (* (sin x) (sinh y)))))) + +(defmethod qtan ((z qd-complex)) + (qd-complex-tan z)) + +(defmethod qsinh ((z qd-complex)) + (let ((x (realpart z)) + (y (imagpart z))) + (complex (* (sinh x) (cos y)) + (* (cosh x) (sin y))))) + +(defmethod qcosh ((z qd-complex)) + (let ((x (realpart z)) + (y (imagpart z))) + (complex (* (cosh x) (cos y)) + (* (sinh x) (sin y))))) + +(defmethod qtanh ((z qd-complex)) + (qd-complex-tanh z)) + +(defmethod qsqrt ((z qd-complex)) + (qd-complex-sqrt z)) + +(defmethod qatan ((y qd-complex) &optional x) + (if x + (error "First arg of 2-arg ATAN must be real") + (qd-complex-atan y))) + +(defmethod qatan ((y cl:complex) &optional x) + (if x + (error "First arg of 2-arg ATAN must be real") + (cl:atan y))) + +(defmethod qexp ((z qd-complex)) + (let* ((x (realpart z)) + (y (imagpart z)) + (ex (exp x))) + (complex (* ex (cos y)) + (* ex (sin y))))) + +(defmethod qlog ((a qd-complex) &optional b) + (if b + (/ (qlog a) (qlog b)) + (complex (log (abs a)) + (atan (imagpart a) (realpart a))))) + +(defmethod qexpt ((x qd-complex) (y number)) + (exp (* (float y #q0) (log x)))) + +(defmethod qexpt ((x number) (y qd-complex)) + (exp (* y (log (float x #q0))))) + +(defmethod qexpt ((x qd-complex) (y qd-complex)) + (exp (* y (log x)))) + +(defmethod qphase ((z qd-complex)) + (atan (imagpart z) (realpart z))) + +(defun realp (x) + (or (typep x 'qd-real) + (cl:realp x))) + +(defun complexp (x) + (or (typep x 'qd-complex) + (cl:complexp x))) + +(defun numberp (x) + (or (realp x) + (complexp x))) diff --git a/external/oct/qd-const.lisp b/external/oct/qd-const.lisp new file mode 100644 index 0000000..a9235ce --- /dev/null +++ b/external/oct/qd-const.lisp @@ -0,0 +1,2591 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qdi) + +(defconstant +qd-zero+ + (make-qd-d 0d0)) + +(defconstant +qd-one+ + (make-qd-d 1d0)) + +(defconstant +qd-2pi+ + (%make-qd-d (scale-float (float 7074237752028440 1.0d0) -50) + (scale-float (float 4967757600021511 1.0d0) -104) + (scale-float (float -8753721960665020 1.0d0) -160) + (scale-float (float 5857755168774013 1.0d0) -214))) + +;; 3.1415926535897932384626433832795028841971693993751058209749445923078L0 +(defconstant +qd-pi+ + (%make-qd-d (scale-float (float 7074237752028440 1.0d0) -51) + (scale-float (float 4967757600021511 1.0d0) -105) + (scale-float (float -8753721960665020 1.0d0) -161) + (scale-float (float 5857755168774013 1.0d0) -215))) + +(defconstant +qd-pi/2+ + (%make-qd-d (scale-float (float 7074237752028440 1.0d0) -52) + (scale-float (float 4967757600021511 1.0d0) -106) + (scale-float (float -8753721960665020 1.0d0) -162) + (scale-float (float 5857755168774013 1.0d0) -216))) + +(defconstant +qd-pi/4+ + (%make-qd-d (scale-float (float 7074237752028440 1.0d0) -53) + (scale-float (float 4967757600021511 1.0d0) -107) + (scale-float (float -8753721960665020 1.0d0) -163) + (scale-float (float 5857755168774013 1.0d0) -217))) + +(defconstant +qd-3pi/4+ + (%make-qd-d (scale-float (float 5305678314021330 1.0d0) -51) + (scale-float (float 7451636400032266 1.0d0) -106) + (scale-float (float 5724553519491610 1.0d0) -160) + (scale-float (float -6810541066450736 1.0d0) -214))) + +(defconstant +qd-pi/1024+ + (%make-qd-d (scale-float (float 7074237752028440 1.0d0) -61) + (scale-float (float 4967757600021511 1.0d0) -115) + (scale-float (float -8753721960665020 1.0d0) -171) + (scale-float (float 5857755168774013 1.0d0) -225))) + +(defconstant +qd-e+ + (%make-qd-d (scale-float (float 6121026514868073 1.0d0) -51) + (scale-float (float 5864240480059706 1.0d0) -105) + (scale-float (float -6219324074349538 1.0d0) -161) + (scale-float (float 7980724272743020 1.0d0) -215))) + +;; 0.6931471805599453094172321214581765680755001343602552541206800094934L0 +(defconstant +qd-log2+ + #+nil + (make-qd-d 6.931471805599452862d-01 + 2.319046813846299558d-17 + 5.707708438416212066d-34 + -3.582432210601811423d-50) + (%make-qd-d (scale-float (float 6243314768165359 1.0d0) -53) + (scale-float (float 7525737178955839 1.0d0) -108) + (scale-float (float 6673460182522164 1.0d0) -163) + (scale-float (float -7545482916914656 1.0d0) -217))) + +;; The rest of log(2) such that (+ +qd-log2+ +qd-log2-extra+) is +;; log(2) to twice the precision of a quad-double. +(defconstant +qd-log2-extra+ + #+nil + (make-qd-d (scale-float (float 4141960528156623 1d0) (- -53 212)) + (scale-float (float 3973120087747366 1d0) (- -106 212)) + (scale-float (float 752798645508048 1d0) (- -159 212)) + (scale-float (float 7618435247650241 1d0) (- -212 212))) + (%make-qd-d (scale-float (float 8283921056313247 1.0d0) -266) + (scale-float (float -8487672633970079 1.0d0) -322) + (scale-float (float 6075158146775579 1.0d0) -376) + (scale-float (float 4764384374407424 1.0d0) -432))) + +(defconstant +qd-log10+ + (%make-qd-d (scale-float (float 5184960683398422 1.0d0) -51) + (scale-float (float -8805633374462953 1.0d0) -105) + (scale-float (float -7296007962371596 1.0d0) -159) + (scale-float (float -5296362421624049 1.0d0) -213))) + +(defconstant +qd-eps+ + (scale-float 1d0 -209)) + +(defconstant +qd-sin-table+ + (make-array 256 + :initial-contents + (list + (%make-qd-d (scale-float (float 7074226654454970 1.0d0) -61) + (scale-float (float 5271335698347442 1.0d0) -115) + (scale-float (float 7913822574154586 1.0d0) -170) + (scale-float (float -4804352564403217 1.0d0) -224)) + (%make-qd-d (scale-float (float 7074193361797233 1.0d0) -60) + (scale-float (float 7522205695703707 1.0d0) -116) + (scale-float (float 7787047147324868 1.0d0) -175) + (scale-float (float -6728650631839117 1.0d0) -232)) + (%make-qd-d (scale-float (float 5305603405682435 1.0d0) -59) + (scale-float (float -5041342953893321 1.0d0) -115) + (scale-float (float 8335474310793984 1.0d0) -170) + (scale-float (float 6743025479788607 1.0d0) -225)) + (%make-qd-d (scale-float (float 7074060192106372 1.0d0) -59) + (scale-float (float 7185921569156509 1.0d0) -113) + (scale-float (float -6016799991653399 1.0d0) -170) + (scale-float (float -5577663458559350 1.0d0) -224)) + (%make-qd-d (scale-float (float 8842450394781643 1.0d0) -59) + (scale-float (float -8771095658131507 1.0d0) -113) + (scale-float (float 8705573170983202 1.0d0) -167) + (scale-float (float -4692271881407162 1.0d0) -221)) + (%make-qd-d (scale-float (float 5305378684473085 1.0d0) -58) + (scale-float (float 7704904742673764 1.0d0) -113) + (scale-float (float 7308626221243388 1.0d0) -167) + (scale-float (float 4905810005485122 1.0d0) -223)) + (%make-qd-d (scale-float (float 6189482235310630 1.0d0) -58) + (scale-float (float -4715432182777116 1.0d0) -113) + (scale-float (float -8243063834437948 1.0d0) -168) + (scale-float (float 8566398131092182 1.0d0) -222)) + (%make-qd-d (scale-float (float 7073527528384126 1.0d0) -58) + (scale-float (float -7632135562854704 1.0d0) -116) + (scale-float (float 7289253486557291 1.0d0) -170) + (scale-float (float -7590289326531904 1.0d0) -224)) + (%make-qd-d (scale-float (float 7957506242722589 1.0d0) -58) + (scale-float (float -8272553670927212 1.0d0) -112) + (scale-float (float -6591995918745221 1.0d0) -166) + (scale-float (float -4636857096009409 1.0d0) -220)) + (%make-qd-d (scale-float (float 8841410057981697 1.0d0) -58) + (scale-float (float -5627969559234246 1.0d0) -118) + (scale-float (float -5998146560009404 1.0d0) -171) + (scale-float (float -8771421402740511 1.0d0) -225)) + (%make-qd-d (scale-float (float 4862615327261055 1.0d0) -57) + (scale-float (float -5217239170857332 1.0d0) -111) + (scale-float (float -6336246586437174 1.0d0) -165) + (scale-float (float 5522987872330073 1.0d0) -219)) + (%make-qd-d (scale-float (float 5304479856743885 1.0d0) -57) + (scale-float (float 6340842145528512 1.0d0) -113) + (scale-float (float -7566831660699656 1.0d0) -167) + (scale-float (float -7114412056121165 1.0d0) -221)) + (%make-qd-d (scale-float (float 5746294458442105 1.0d0) -57) + (scale-float (float 4845186982751657 1.0d0) -113) + (scale-float (float 6382779118838290 1.0d0) -167) + (scale-float (float 8090523197847278 1.0d0) -221)) + (%make-qd-d (scale-float (float 6188054973828419 1.0d0) -57) + (scale-float (float 7360584602593505 1.0d0) -111) + (scale-float (float 7946504576809704 1.0d0) -165) + (scale-float (float 5731224328660037 1.0d0) -219)) + (%make-qd-d (scale-float (float 6629757244884614 1.0d0) -57) + (scale-float (float -5806448969106076 1.0d0) -112) + (scale-float (float 7037190739826080 1.0d0) -166) + (scale-float (float 5552037724818900 1.0d0) -223)) + (%make-qd-d (scale-float (float 7071397114140692 1.0d0) -57) + (scale-float (float -7057477599664784 1.0d0) -113) + (scale-float (float -8290828586102809 1.0d0) -167) + (scale-float (float -6697971486035361 1.0d0) -222)) + (%make-qd-d (scale-float (float 7512970424714007 1.0d0) -57) + (scale-float (float -6294023145184360 1.0d0) -111) + (scale-float (float -6395720725273163 1.0d0) -165) + (scale-float (float -7071774105018818 1.0d0) -219)) + (%make-qd-d (scale-float (float 7954473020348387 1.0d0) -57) + (scale-float (float -6926679705961747 1.0d0) -112) + (scale-float (float -6427721451859560 1.0d0) -167) + (scale-float (float 8028310015339695 1.0d0) -222)) + (%make-qd-d (scale-float (float 8395900745453257 1.0d0) -57) + (scale-float (float 4839201044457661 1.0d0) -114) + (scale-float (float 5799570435052711 1.0d0) -171) + (scale-float (float -5529353034270453 1.0d0) -226)) + (%make-qd-d (scale-float (float 8837249445142752 1.0d0) -57) + (scale-float (float -5314952832401406 1.0d0) -113) + (scale-float (float -7992910057771694 1.0d0) -167) + (scale-float (float 8886165424019995 1.0d0) -221)) + (%make-qd-d (scale-float (float 4639257482637412 1.0d0) -56) + (scale-float (float -5494228531443205 1.0d0) -110) + (scale-float (float 6222043711193090 1.0d0) -167) + (scale-float (float 4966112393074763 1.0d0) -221)) + (%make-qd-d (scale-float (float 4859846576245171 1.0d0) -56) + (scale-float (float -8985502920124077 1.0d0) -110) + (scale-float (float 7440463379940699 1.0d0) -165) + (scale-float (float -6641325637598524 1.0d0) -219)) + (%make-qd-d (scale-float (float 5080389927126093 1.0d0) -56) + (scale-float (float -8898661047761268 1.0d0) -110) + (scale-float (float -4667727006484474 1.0d0) -164) + (scale-float (float 8478536563323652 1.0d0) -218)) + (%make-qd-d (scale-float (float 5300885459442166 1.0d0) -56) + (scale-float (float -7213383224879916 1.0d0) -111) + (scale-float (float -8534269322822802 1.0d0) -166) + (scale-float (float -6601733372219099 1.0d0) -221)) + (%make-qd-d (scale-float (float 5521331097805465 1.0d0) -56) + (scale-float (float 4829604598179156 1.0d0) -114) + (scale-float (float -7893599535446481 1.0d0) -172) + (scale-float (float -5384211130874634 1.0d0) -226)) + (%make-qd-d (scale-float (float 5741724767297686 1.0d0) -56) + (scale-float (float -5824155811343436 1.0d0) -110) + (scale-float (float 6673985610265747 1.0d0) -164) + (scale-float (float 4800782739249759 1.0d0) -220)) + (%make-qd-d (scale-float (float 5962064393489674 1.0d0) -56) + (scale-float (float 7651360099479755 1.0d0) -112) + (scale-float (float 6974817744235260 1.0d0) -167) + (scale-float (float 7824970858345265 1.0d0) -224)) + (%make-qd-d (scale-float (float 6182347902460953 1.0d0) -56) + (scale-float (float -8796242544913562 1.0d0) -111) + (scale-float (float -7546272905440146 1.0d0) -165) + (scale-float (float 6512061516709508 1.0d0) -219)) + (%make-qd-d (scale-float (float 6402573220819241 1.0d0) -56) + (scale-float (float -4868008820827392 1.0d0) -110) + (scale-float (float 8779206749884591 1.0d0) -164) + (scale-float (float -8648470131210884 1.0d0) -218)) + (%make-qd-d (scale-float (float 6622738275719969 1.0d0) -56) + (scale-float (float 6182934508221337 1.0d0) -110) + (scale-float (float 7353282250945404 1.0d0) -165) + (scale-float (float -8166192353391047 1.0d0) -220)) + (%make-qd-d (scale-float (float 6842840994885793 1.0d0) -56) + (scale-float (float -8552477024466766 1.0d0) -110) + (scale-float (float -4997427595980002 1.0d0) -164) + (scale-float (float 5821398332046138 1.0d0) -218)) + (%make-qd-d (scale-float (float 7062879306626092 1.0d0) -56) + (scale-float (float -8487236864497288 1.0d0) -112) + (scale-float (float -4942162982072151 1.0d0) -168) + (scale-float (float -4811145377091453 1.0d0) -223)) + (%make-qd-d (scale-float (float 7282851139856476 1.0d0) -56) + (scale-float (float 8609951212389606 1.0d0) -111) + (scale-float (float -5614142183842944 1.0d0) -165) + (scale-float (float 6068416796043208 1.0d0) -219)) + (%make-qd-d (scale-float (float 7502754424118275 1.0d0) -56) + (scale-float (float 8536169017599928 1.0d0) -110) + (scale-float (float 7981550951145323 1.0d0) -165) + (scale-float (float -8340622458345952 1.0d0) -220)) + (%make-qd-d (scale-float (float 7722587089598028 1.0d0) -56) + (scale-float (float 8362719068102409 1.0d0) -110) + (scale-float (float -7853008551658302 1.0d0) -166) + (scale-float (float -6852498985157079 1.0d0) -220)) + (%make-qd-d (scale-float (float 7942347067146965 1.0d0) -56) + (scale-float (float -5897359216343841 1.0d0) -113) + (scale-float (float 7767443765766550 1.0d0) -169) + (scale-float (float 8203371449514667 1.0d0) -225)) + (%make-qd-d (scale-float (float 8162032288300481 1.0d0) -56) + (scale-float (float 7035687121204020 1.0d0) -111) + (scale-float (float 5733124558862890 1.0d0) -168) + (scale-float (float 6681272325774503 1.0d0) -223)) + (%make-qd-d (scale-float (float 8381640685297609 1.0d0) -56) + (scale-float (float 5345425417737710 1.0d0) -112) + (scale-float (float -8790124191829010 1.0d0) -166) + (scale-float (float 7297964455931531 1.0d0) -225)) + (%make-qd-d (scale-float (float 8601170191100479 1.0d0) -56) + (scale-float (float -5127404751534987 1.0d0) -110) + (scale-float (float 8258618371098839 1.0d0) -164) + (scale-float (float 6354475203379338 1.0d0) -221)) + (%make-qd-d (scale-float (float 8820618739413774 1.0d0) -56) + (scale-float (float 7361249450583405 1.0d0) -111) + (scale-float (float 8489175872343797 1.0d0) -165) + (scale-float (float -4838736209868180 1.0d0) -220)) + (%make-qd-d (scale-float (float 4519992132352091 1.0d0) -55) + (scale-float (float 6319901705801489 1.0d0) -110) + (scale-float (float 5600764727998866 1.0d0) -166) + (scale-float (float -5650573825026412 1.0d0) -220)) + (%make-qd-d (scale-float (float 4629632351109917 1.0d0) -55) + (scale-float (float 4958462282897610 1.0d0) -110) + (scale-float (float -8711719640720475 1.0d0) -165) + (scale-float (float -8191834096705166 1.0d0) -221)) + (%make-qd-d (scale-float (float 4739228994004870 1.0d0) -55) + (scale-float (float -6495525500297301 1.0d0) -110) + (scale-float (float -6071898187587615 1.0d0) -165) + (scale-float (float -7897922259441451 1.0d0) -220)) + (%make-qd-d (scale-float (float 4848781029471607 1.0d0) -55) + (scale-float (float -5949746474335482 1.0d0) -109) + (scale-float (float 7443833788929433 1.0d0) -165) + (scale-float (float 6779921506403360 1.0d0) -220)) + (%make-qd-d (scale-float (float 4958287426364647 1.0d0) -55) + (scale-float (float 8600164307618932 1.0d0) -110) + (scale-float (float -5552907197025195 1.0d0) -164) + (scale-float (float -6315628760329704 1.0d0) -222)) + (%make-qd-d (scale-float (float 5067747153968079 1.0d0) -55) + (scale-float (float -5139980116898898 1.0d0) -109) + (scale-float (float 7128908501078503 1.0d0) -163) + (scale-float (float 5174334784143035 1.0d0) -217)) + (%make-qd-d (scale-float (float 5177159182005257 1.0d0) -55) + (scale-float (float 7446222959753664 1.0d0) -109) + (scale-float (float -4853116546479197 1.0d0) -166) + (scale-float (float -7114171320789543 1.0d0) -220)) + (%make-qd-d (scale-float (float 5286522480648506 1.0d0) -55) + (scale-float (float 4837853990883808 1.0d0) -110) + (scale-float (float 8734494569006220 1.0d0) -164) + (scale-float (float -6888573428631769 1.0d0) -220)) + (%make-qd-d (scale-float (float 5395836020528807 1.0d0) -55) + (scale-float (float 5245006079192873 1.0d0) -109) + (scale-float (float 6070092190452118 1.0d0) -165) + (scale-float (float 8372804672547503 1.0d0) -219)) + (%make-qd-d (scale-float (float 5505098772745492 1.0d0) -55) + (scale-float (float -4953034127800088 1.0d0) -109) + (scale-float (float 6748009167290918 1.0d0) -163) + (scale-float (float -7947104079128991 1.0d0) -217)) + (%make-qd-d (scale-float (float 5614309708875923 1.0d0) -55) + (scale-float (float 7879649848150358 1.0d0) -111) + (scale-float (float -5133702133285397 1.0d0) -165) + (scale-float (float 6633380945160774 1.0d0) -219)) + (%make-qd-d (scale-float (float 5723467800985178 1.0d0) -55) + (scale-float (float -5213481504208817 1.0d0) -110) + (scale-float (float -8683946243665639 1.0d0) -166) + (scale-float (float -4813600752545885 1.0d0) -220)) + (%make-qd-d (scale-float (float 5832572021635720 1.0d0) -55) + (scale-float (float 7691426989666512 1.0d0) -109) + (scale-float (float -5897567218587937 1.0d0) -163) + (scale-float (float 6426162084210735 1.0d0) -217)) + (%make-qd-d (scale-float (float 5941621343897074 1.0d0) -55) + (scale-float (float -7311303147276965 1.0d0) -113) + (scale-float (float 6212875260931578 1.0d0) -167) + (scale-float (float 5841094814764128 1.0d0) -222)) + (%make-qd-d (scale-float (float 6050614741355486 1.0d0) -55) + (scale-float (float 7046535347736856 1.0d0) -110) + (scale-float (float -7778307984467600 1.0d0) -164) + (scale-float (float -7808429293088315 1.0d0) -218)) + (%make-qd-d (scale-float (float 6159551188123590 1.0d0) -55) + (scale-float (float 5965947804179142 1.0d0) -109) + (scale-float (float -7914176807889465 1.0d0) -163) + (scale-float (float -8743204545259556 1.0d0) -219)) + (%make-qd-d (scale-float (float 6268429658850061 1.0d0) -55) + (scale-float (float 7548560474328400 1.0d0) -110) + (scale-float (float -7834123143654772 1.0d0) -165) + (scale-float (float -5643244224302487 1.0d0) -219)) + (%make-qd-d (scale-float (float 6377249128729266 1.0d0) -55) + (scale-float (float 8739842904414420 1.0d0) -110) + (scale-float (float 6557520883328920 1.0d0) -164) + (scale-float (float 6198578405040918 1.0d0) -220)) + (%make-qd-d (scale-float (float 6486008573510911 1.0d0) -55) + (scale-float (float 5172944262567044 1.0d0) -109) + (scale-float (float -8273960648700810 1.0d0) -163) + (scale-float (float 8265967084369073 1.0d0) -218)) + (%make-qd-d (scale-float (float 6594706969509681 1.0d0) -55) + (scale-float (float 5020296747686703 1.0d0) -109) + (scale-float (float -5238462653363294 1.0d0) -163) + (scale-float (float 4718474594983838 1.0d0) -218)) + (%make-qd-d (scale-float (float 6703343293614876 1.0d0) -55) + (scale-float (float -8155081811450095 1.0d0) -109) + (scale-float (float 8880533418464333 1.0d0) -163) + (scale-float (float -6482467806029927 1.0d0) -220)) + (%make-qd-d (scale-float (float 6811916523300038 1.0d0) -55) + (scale-float (float -4946244022635960 1.0d0) -109) + (scale-float (float -5237121426122221 1.0d0) -163) + (scale-float (float 8718098324302620 1.0d0) -217)) + (%make-qd-d (scale-float (float 6920425636632580 1.0d0) -55) + (scale-float (float 5626936751711242 1.0d0) -110) + (scale-float (float -5472825984215756 1.0d0) -164) + (scale-float (float 6651512109810514 1.0d0) -218)) + (%make-qd-d (scale-float (float 7028869612283403 1.0d0) -55) + (scale-float (float -5186506842934658 1.0d0) -109) + (scale-float (float 7231073992256617 1.0d0) -163) + (scale-float (float -7548842128799985 1.0d0) -217)) + (%make-qd-d (scale-float (float 7137247429536506 1.0d0) -55) + (scale-float (float -4785846924082858 1.0d0) -111) + (scale-float (float 6612549575000546 1.0d0) -165) + (scale-float (float 8882300801909735 1.0d0) -219)) + (%make-qd-d (scale-float (float 7245558068298598 1.0d0) -55) + (scale-float (float 7145919755147006 1.0d0) -109) + (scale-float (float -4574333719136121 1.0d0) -163) + (scale-float (float 8116579236098782 1.0d0) -221)) + (%make-qd-d (scale-float (float 7353800509108698 1.0d0) -55) + (scale-float (float 7910632724668908 1.0d0) -110) + (scale-float (float -6611929274882350 1.0d0) -164) + (scale-float (float 7768004576091902 1.0d0) -220)) + (%make-qd-d (scale-float (float 7461973733147729 1.0d0) -55) + (scale-float (float -6888466114708653 1.0d0) -109) + (scale-float (float 5251305190626995 1.0d0) -164) + (scale-float (float 5680012606429775 1.0d0) -218)) + (%make-qd-d (scale-float (float 7570076722248107 1.0d0) -55) + (scale-float (float 7503873979299470 1.0d0) -109) + (scale-float (float 7056820389775269 1.0d0) -163) + (scale-float (float 7020098326040376 1.0d0) -217)) + (%make-qd-d (scale-float (float 7678108458903330 1.0d0) -55) + (scale-float (float 7809132580424664 1.0d0) -109) + (scale-float (float -7983937846917205 1.0d0) -164) + (scale-float (float -5238765332718576 1.0d0) -218)) + (%make-qd-d (scale-float (float 7786067926277549 1.0d0) -55) + (scale-float (float -6562541456970122 1.0d0) -109) + (scale-float (float 8510563175036132 1.0d0) -163) + (scale-float (float -6181313461401740 1.0d0) -217)) + (%make-qd-d (scale-float (float 7893954108215139 1.0d0) -55) + (scale-float (float -7583622115760437 1.0d0) -114) + (scale-float (float -8739826341766039 1.0d0) -168) + (scale-float (float 8569299442299246 1.0d0) -224)) + (%make-qd-d (scale-float (float 8001765989250269 1.0d0) -55) + (scale-float (float -7875990267513186 1.0d0) -111) + (scale-float (float 6234618013881755 1.0d0) -166) + (scale-float (float 6777347195615505 1.0d0) -221)) + (%make-qd-d (scale-float (float 8109502554616454 1.0d0) -55) + (scale-float (float 5128307098824184 1.0d0) -110) + (scale-float (float 4543608696005937 1.0d0) -167) + (scale-float (float 7638129994812919 1.0d0) -223)) + (%make-qd-d (scale-float (float 8217162790256110 1.0d0) -55) + (scale-float (float 5345588865997323 1.0d0) -109) + (scale-float (float 8159479612637540 1.0d0) -163) + (scale-float (float -5402348902098945 1.0d0) -219)) + (%make-qd-d (scale-float (float 8324745682830097 1.0d0) -55) + (scale-float (float 6574607749416877 1.0d0) -109) + (scale-float (float -8109490796402671 1.0d0) -163) + (scale-float (float -6082280992156331 1.0d0) -217)) + (%make-qd-d (scale-float (float 8432250219727258 1.0d0) -55) + (scale-float (float -4538223398252166 1.0d0) -109) + (scale-float (float -6702216400949692 1.0d0) -163) + (scale-float (float 8946082027051995 1.0d0) -220)) + (%make-qd-d (scale-float (float 8539675389073947 1.0d0) -55) + (scale-float (float 5746889479488039 1.0d0) -109) + (scale-float (float 6355067832497967 1.0d0) -165) + (scale-float (float 8745994171732987 1.0d0) -219)) + (%make-qd-d (scale-float (float 8647020179743560 1.0d0) -55) + (scale-float (float -7877855974853474 1.0d0) -109) + (scale-float (float -6184796128853677 1.0d0) -164) + (scale-float (float -6716307004457317 1.0d0) -221)) + (%make-qd-d (scale-float (float 8754283581366043 1.0d0) -55) + (scale-float (float -5680003804930756 1.0d0) -109) + (scale-float (float -7684372211678467 1.0d0) -163) + (scale-float (float -8705668463298701 1.0d0) -219)) + (%make-qd-d (scale-float (float 8861464584337410 1.0d0) -55) + (scale-float (float -7223162559193390 1.0d0) -109) + (scale-float (float 5121803047874294 1.0d0) -163) + (scale-float (float 5147411879671042 1.0d0) -218)) + (%make-qd-d (scale-float (float 8968562179829241 1.0d0) -55) + (scale-float (float -5308048479279035 1.0d0) -109) + (scale-float (float 6508578347136807 1.0d0) -163) + (scale-float (float 8020683771279042 1.0d0) -217)) + (%make-qd-d (scale-float (float 4537787679899090 1.0d0) -54) + (scale-float (float -5708747378047162 1.0d0) -108) + (scale-float (float -6407036826384189 1.0d0) -162) + (scale-float (float 5919543467564908 1.0d0) -216)) + (%make-qd-d (scale-float (float 4591251558497710 1.0d0) -54) + (scale-float (float -5650174284497868 1.0d0) -115) + (scale-float (float -8990517484150757 1.0d0) -170) + (scale-float (float -8107597715031434 1.0d0) -224)) + (%make-qd-d (scale-float (float 4644672222488094 1.0d0) -54) + (scale-float (float 5997115408045016 1.0d0) -108) + (scale-float (float 7763885974670757 1.0d0) -164) + (scale-float (float -4679894517345222 1.0d0) -219)) + (%make-qd-d (scale-float (float 4698049169054608 1.0d0) -54) + (scale-float (float 5545557499125773 1.0d0) -110) + (scale-float (float 5311178975123782 1.0d0) -166) + (scale-float (float 5295664491197940 1.0d0) -220)) + (%make-qd-d (scale-float (float 4751381895793102 1.0d0) -54) + (scale-float (float -6113263535019274 1.0d0) -108) + (scale-float (float 8020796425904764 1.0d0) -162) + (scale-float (float -8716004022289625 1.0d0) -216)) + (%make-qd-d (scale-float (float 4804669900715639 1.0d0) -54) + (scale-float (float 6795815263120026 1.0d0) -108) + (scale-float (float -6608013933362003 1.0d0) -162) + (scale-float (float 8405700252907754 1.0d0) -218)) + (%make-qd-d (scale-float (float 4857912682255224 1.0d0) -54) + (scale-float (float 5116248407710562 1.0d0) -108) + (scale-float (float -8148882072162222 1.0d0) -163) + (scale-float (float -8520890580178720 1.0d0) -217)) + (%make-qd-d (scale-float (float 4911109739270519 1.0d0) -54) + (scale-float (float 5107738102425278 1.0d0) -109) + (scale-float (float 6190162227247694 1.0d0) -166) + (scale-float (float -4657820058623469 1.0d0) -220)) + (%make-qd-d (scale-float (float 4964260571050563 1.0d0) -54) + (scale-float (float 6269805211133874 1.0d0) -108) + (scale-float (float 8144711382265961 1.0d0) -162) + (scale-float (float 5736256866199006 1.0d0) -218)) + (%make-qd-d (scale-float (float 5017364677319486 1.0d0) -54) + (scale-float (float -6510019840528798 1.0d0) -109) + (scale-float (float 8487479632464686 1.0d0) -163) + (scale-float (float -8482708199224338 1.0d0) -219)) + (%make-qd-d (scale-float (float 5070421558241214 1.0d0) -54) + (scale-float (float -7997629714663984 1.0d0) -109) + (scale-float (float -4940945917580418 1.0d0) -165) + (scale-float (float 6330315470378748 1.0d0) -219)) + (%make-qd-d (scale-float (float 5123430714424177 1.0d0) -54) + (scale-float (float 7207319694891503 1.0d0) -108) + (scale-float (float -5367984184293639 1.0d0) -162) + (scale-float (float -5496551307550694 1.0d0) -216)) + (%make-qd-d (scale-float (float 5176391646926010 1.0d0) -54) + (scale-float (float 5017419446091570 1.0d0) -108) + (scale-float (float -7396832087454611 1.0d0) -163) + (scale-float (float -4840687577999527 1.0d0) -217)) + (%make-qd-d (scale-float (float 5229303857258246 1.0d0) -54) + (scale-float (float -6142480273924397 1.0d0) -108) + (scale-float (float 6736325962420316 1.0d0) -162) + (scale-float (float 7870899103225375 1.0d0) -216)) + (%make-qd-d (scale-float (float 5282166847391008 1.0d0) -54) + (scale-float (float 7264487630099164 1.0d0) -108) + (scale-float (float 7987097472370426 1.0d0) -162) + (scale-float (float -8941292693731426 1.0d0) -217)) + (%make-qd-d (scale-float (float 5334980119757703 1.0d0) -54) + (scale-float (float -6562004117740143 1.0d0) -108) + (scale-float (float -7412943256346969 1.0d0) -166) + (scale-float (float -4884902683994743 1.0d0) -220)) + (%make-qd-d (scale-float (float 5387743177259695 1.0d0) -54) + (scale-float (float 8671749280336977 1.0d0) -112) + (scale-float (float 8052630932330237 1.0d0) -166) + (scale-float (float 5382726735559265 1.0d0) -223)) + (%make-qd-d (scale-float (float 5440455523270994 1.0d0) -54) + (scale-float (float -5571226216357986 1.0d0) -108) + (scale-float (float 5456938947172397 1.0d0) -164) + (scale-float (float 6994870598847095 1.0d0) -219)) + (%make-qd-d (scale-float (float 5493116661642923 1.0d0) -54) + (scale-float (float -7460368030645572 1.0d0) -108) + (scale-float (float -6827621715323733 1.0d0) -165) + (scale-float (float 6362629589576016 1.0d0) -220)) + (%make-qd-d (scale-float (float 5545726096708791 1.0d0) -54) + (scale-float (float 8786044050481812 1.0d0) -108) + (scale-float (float 7347762739505304 1.0d0) -162) + (scale-float (float 7680616584349999 1.0d0) -216)) + (%make-qd-d (scale-float (float 5598283333288561 1.0d0) -54) + (scale-float (float 6778243811814134 1.0d0) -108) + (scale-float (float -7045745243982448 1.0d0) -164) + (scale-float (float 4676451795272765 1.0d0) -221)) + (%make-qd-d (scale-float (float 5650787876693505 1.0d0) -54) + (scale-float (float 4725135298405656 1.0d0) -108) + (scale-float (float 8550179043058735 1.0d0) -164) + (scale-float (float 4909349307819338 1.0d0) -218)) + (%make-qd-d (scale-float (float 5703239232730864 1.0d0) -54) + (scale-float (float 6956150123475237 1.0d0) -108) + (scale-float (float 7212901813329486 1.0d0) -162) + (scale-float (float 7153556903673412 1.0d0) -217)) + (%make-qd-d (scale-float (float 5755636907708500 1.0d0) -54) + (scale-float (float -4537276437495587 1.0d0) -108) + (scale-float (float 4777941193532901 1.0d0) -162) + (scale-float (float -8179721144625040 1.0d0) -216)) + (%make-qd-d (scale-float (float 5807980408439539 1.0d0) -54) + (scale-float (float -5259672094517845 1.0d0) -110) + (scale-float (float 8754582529967018 1.0d0) -164) + (scale-float (float 7408654934690508 1.0d0) -219)) + (%make-qd-d (scale-float (float 5860269242247018 1.0d0) -54) + (scale-float (float 5138507873462360 1.0d0) -109) + (scale-float (float -6320854003064805 1.0d0) -166) + (scale-float (float 7758282409924483 1.0d0) -221)) + (%make-qd-d (scale-float (float 5912502916968520 1.0d0) -54) + (scale-float (float -8662419418939044 1.0d0) -108) + (scale-float (float 4614185824928788 1.0d0) -162) + (scale-float (float 8601963191388429 1.0d0) -221)) + (%make-qd-d (scale-float (float 5964680940960804 1.0d0) -54) + (scale-float (float -8914351205645270 1.0d0) -108) + (scale-float (float -7834377139759957 1.0d0) -162) + (scale-float (float 6901300084898985 1.0d0) -216)) + (%make-qd-d (scale-float (float 6016802823104436 1.0d0) -54) + (scale-float (float 7333790512522496 1.0d0) -108) + (scale-float (float 4563571436080821 1.0d0) -162) + (scale-float (float 8605109854377494 1.0d0) -218)) + (%make-qd-d (scale-float (float 6068868072808413 1.0d0) -54) + (scale-float (float -8723253959652896 1.0d0) -114) + (scale-float (float -8733624133784357 1.0d0) -171) + (scale-float (float -6253293004427605 1.0d0) -225)) + (%make-qd-d (scale-float (float 6120876200014774 1.0d0) -54) + (scale-float (float 8571012628450813 1.0d0) -110) + (scale-float (float 5881087260125824 1.0d0) -165) + (scale-float (float 8616758768675350 1.0d0) -221)) + (%make-qd-d (scale-float (float 6172826715203219 1.0d0) -54) + (scale-float (float 6250720108433989 1.0d0) -108) + (scale-float (float -5422415971662036 1.0d0) -162) + (scale-float (float 8997881851302993 1.0d0) -216)) + (%make-qd-d (scale-float (float 6224719129395714 1.0d0) -54) + (scale-float (float 8843501730272727 1.0d0) -108) + (scale-float (float 8200563275489647 1.0d0) -163) + (scale-float (float -5971751274707875 1.0d0) -218)) + (%make-qd-d (scale-float (float 6276552954161094 1.0d0) -54) + (scale-float (float 4799554187051297 1.0d0) -110) + (scale-float (float 8308846534529580 1.0d0) -164) + (scale-float (float 8241934792467017 1.0d0) -218)) + (%make-qd-d (scale-float (float 6328327701619659 1.0d0) -54) + (scale-float (float -7357066700707823 1.0d0) -108) + (scale-float (float -7947864157743905 1.0d0) -165) + (scale-float (float 7675632966777644 1.0d0) -219)) + (%make-qd-d (scale-float (float 6380042884447767 1.0d0) -54) + (scale-float (float -5501161709946803 1.0d0) -108) + (scale-float (float 7466713522323834 1.0d0) -162) + (scale-float (float -7098845764308001 1.0d0) -217)) + (%make-qd-d (scale-float (float 6431698015882422 1.0d0) -54) + (scale-float (float -5007263247392991 1.0d0) -113) + (scale-float (float -7795754867074493 1.0d0) -167) + (scale-float (float -4821191128464752 1.0d0) -222)) + (%make-qd-d (scale-float (float 6483292609725855 1.0d0) -54) + (scale-float (float -5712074047376477 1.0d0) -108) + (scale-float (float 7819107111345661 1.0d0) -162) + (scale-float (float 8368937774054671 1.0d0) -216)) + (%make-qd-d (scale-float (float 6534826180350098 1.0d0) -54) + (scale-float (float -5949616244538138 1.0d0) -109) + (scale-float (float -8689252050077247 1.0d0) -163) + (scale-float (float -8509057300264997 1.0d0) -218)) + (%make-qd-d (scale-float (float 6586298242701558 1.0d0) -54) + (scale-float (float 5263009052367660 1.0d0) -108) + (scale-float (float 6598370143038445 1.0d0) -162) + (scale-float (float -7564085607225777 1.0d0) -216)) + (%make-qd-d (scale-float (float 6637708312305582 1.0d0) -54) + (scale-float (float 6791291154341829 1.0d0) -109) + (scale-float (float 7690532825767619 1.0d0) -168) + (scale-float (float 7037800597631649 1.0d0) -222)) + (%make-qd-d (scale-float (float 6689055905271015 1.0d0) -54) + (scale-float (float 7217134714480857 1.0d0) -114) + (scale-float (float -8997551068716333 1.0d0) -173) + (scale-float (float -6072128060810686 1.0d0) -227)) + (%make-qd-d (scale-float (float 6740340538294756 1.0d0) -54) + (scale-float (float 5199702616094614 1.0d0) -109) + (scale-float (float 6246995808738228 1.0d0) -163) + (scale-float (float 8721019383942846 1.0d0) -219)) + (%make-qd-d (scale-float (float 6791561728666308 1.0d0) -54) + (scale-float (float -7075880958543542 1.0d0) -111) + (scale-float (float 5953253779194679 1.0d0) -166) + (scale-float (float 5597468420642533 1.0d0) -222)) + (%make-qd-d (scale-float (float 6842718994272319 1.0d0) -54) + (scale-float (float 6435287673892967 1.0d0) -109) + (scale-float (float 5701190408884571 1.0d0) -163) + (scale-float (float 5908054947863245 1.0d0) -218)) + (%make-qd-d (scale-float (float 6893811853601123 1.0d0) -54) + (scale-float (float -6523324437210640 1.0d0) -109) + (scale-float (float -4818352562283701 1.0d0) -164) + (scale-float (float -5357330931060650 1.0d0) -218)) + (%make-qd-d (scale-float (float 6944839825747268 1.0d0) -54) + (scale-float (float 4925434022374747 1.0d0) -108) + (scale-float (float 8300294859713104 1.0d0) -162) + (scale-float (float 6208703759312379 1.0d0) -216)) + (%make-qd-d (scale-float (float 6995802430416048 1.0d0) -54) + (scale-float (float -6525270186811934 1.0d0) -109) + (scale-float (float 8879265420406843 1.0d0) -163) + (scale-float (float -6733241213708231 1.0d0) -217)) + (%make-qd-d (scale-float (float 7046699187928017 1.0d0) -54) + (scale-float (float 5840616084808535 1.0d0) -108) + (scale-float (float -6204648763678812 1.0d0) -162) + (scale-float (float -5748171176195803 1.0d0) -216)) + (%make-qd-d (scale-float (float 7097529619223511 1.0d0) -54) + (scale-float (float 6337798132651441 1.0d0) -109) + (scale-float (float -4965270455978562 1.0d0) -164) + (scale-float (float -4678379495118649 1.0d0) -219)) + (%make-qd-d (scale-float (float 7148293245867151 1.0d0) -54) + (scale-float (float 6667254347281325 1.0d0) -108) + (scale-float (float 7172706150755633 1.0d0) -163) + (scale-float (float 4521599313713307 1.0d0) -218)) + (%make-qd-d (scale-float (float 7198989590052351 1.0d0) -54) + (scale-float (float -4889033451117653 1.0d0) -108) + (scale-float (float -5825736040848376 1.0d0) -162) + (scale-float (float -6058018356871033 1.0d0) -216)) + (%make-qd-d (scale-float (float 7249618174605810 1.0d0) -54) + (scale-float (float 7076204518174404 1.0d0) -109) + (scale-float (float 8651917601296873 1.0d0) -163) + (scale-float (float 4790821447612866 1.0d0) -217)) + (%make-qd-d (scale-float (float 7300178522992010 1.0d0) -54) + (scale-float (float 6432697761913771 1.0d0) -109) + (scale-float (float -5885542131804050 1.0d0) -164) + (scale-float (float 5002309445714852 1.0d0) -225)) + (%make-qd-d (scale-float (float 7350670159317696 1.0d0) -54) + (scale-float (float -4543650155952635 1.0d0) -109) + (scale-float (float -6598133798027798 1.0d0) -165) + (scale-float (float 8182638753990352 1.0d0) -225)) + (%make-qd-d (scale-float (float 7401092608336357 1.0d0) -54) + (scale-float (float -7859785885819633 1.0d0) -108) + (scale-float (float -6675498128747218 1.0d0) -162) + (scale-float (float -8844902686085099 1.0d0) -218)) + (%make-qd-d (scale-float (float 7451445395452699 1.0d0) -54) + (scale-float (float -6746081919340579 1.0d0) -109) + (scale-float (float -5369758667471624 1.0d0) -165) + (scale-float (float -6834701290217458 1.0d0) -221)) + (%make-qd-d (scale-float (float 7501728046727114 1.0d0) -54) + (scale-float (float -8267298509278455 1.0d0) -108) + (scale-float (float -8063438575398244 1.0d0) -164) + (scale-float (float 6048179215733349 1.0d0) -219)) + (%make-qd-d (scale-float (float 7551940088880137 1.0d0) -54) + (scale-float (float -5482087221447130 1.0d0) -110) + (scale-float (float -8430648353819219 1.0d0) -164) + (scale-float (float 8658592177651744 1.0d0) -218)) + (%make-qd-d (scale-float (float 7602081049296905 1.0d0) -54) + (scale-float (float 5652239210598920 1.0d0) -110) + (scale-float (float 7420759427593921 1.0d0) -164) + (scale-float (float -5717719400948822 1.0d0) -218)) + (%make-qd-d (scale-float (float 7652150456031602 1.0d0) -54) + (scale-float (float 8912029836648224 1.0d0) -108) + (scale-float (float -5442965062816235 1.0d0) -163) + (scale-float (float 5557269064076599 1.0d0) -219)) + (%make-qd-d (scale-float (float 7702147837811904 1.0d0) -54) + (scale-float (float 6108211414778243 1.0d0) -109) + (scale-float (float -8159473578389260 1.0d0) -165) + (scale-float (float -7432349312262155 1.0d0) -221)) + (%make-qd-d (scale-float (float 7752072724043411 1.0d0) -54) + (scale-float (float 7223681421721881 1.0d0) -108) + (scale-float (float 5025963318844636 1.0d0) -162) + (scale-float (float -6196764359275049 1.0d0) -217)) + (%make-qd-d (scale-float (float 7801924644814081 1.0d0) -54) + (scale-float (float 7284976384109012 1.0d0) -109) + (scale-float (float 4978342074042849 1.0d0) -166) + (scale-float (float -8927853027064514 1.0d0) -220)) + (%make-qd-d (scale-float (float 7851703130898649 1.0d0) -54) + (scale-float (float 5267103399173910 1.0d0) -108) + (scale-float (float -6021054605042187 1.0d0) -166) + (scale-float (float 6370660996304786 1.0d0) -220)) + (%make-qd-d (scale-float (float 7901407713763047 1.0d0) -54) + (scale-float (float -6777023449092614 1.0d0) -108) + (scale-float (float -6668929501654487 1.0d0) -165) + (scale-float (float 8608953101571494 1.0d0) -223)) + (%make-qd-d (scale-float (float 7951037925568809 1.0d0) -54) + (scale-float (float 7256489245666525 1.0d0) -108) + (scale-float (float 5548921664669512 1.0d0) -165) + (scale-float (float -6417647354800337 1.0d0) -220)) + (%make-qd-d (scale-float (float 8000593299177483 1.0d0) -54) + (scale-float (float -7859474098720372 1.0d0) -108) + (scale-float (float 5192476996492227 1.0d0) -164) + (scale-float (float 7762192920165123 1.0d0) -219)) + (%make-qd-d (scale-float (float 8050073368155017 1.0d0) -54) + (scale-float (float -6237939819127611 1.0d0) -108) + (scale-float (float -8310809855799018 1.0d0) -167) + (scale-float (float -4607997215797586 1.0d0) -221)) + (%make-qd-d (scale-float (float 8099477666776158 1.0d0) -54) + (scale-float (float 6338746169655183 1.0d0) -110) + (scale-float (float 6349016711906624 1.0d0) -164) + (scale-float (float -6594231578666108 1.0d0) -218)) + (%make-qd-d (scale-float (float 8148805730028833 1.0d0) -54) + (scale-float (float -4811953802956820 1.0d0) -108) + (scale-float (float -8996711906404359 1.0d0) -163) + (scale-float (float 7437936247641814 1.0d0) -218)) + (%make-qd-d (scale-float (float 8198057093618523 1.0d0) -54) + (scale-float (float -8035018871140280 1.0d0) -109) + (scale-float (float 6464477674883353 1.0d0) -163) + (scale-float (float -7193445626531301 1.0d0) -219)) + (%make-qd-d (scale-float (float 8247231293972637 1.0d0) -54) + (scale-float (float -5487884902609878 1.0d0) -109) + (scale-float (float -7456042848390653 1.0d0) -163) + (scale-float (float 6693281418534385 1.0d0) -217)) + (%make-qd-d (scale-float (float 8296327868244873 1.0d0) -54) + (scale-float (float 5999951330674037 1.0d0) -108) + (scale-float (float -6154519112303483 1.0d0) -162) + (scale-float (float 7000233030992444 1.0d0) -217)) + (%make-qd-d (scale-float (float 8345346354319577 1.0d0) -54) + (scale-float (float -4771391396366549 1.0d0) -109) + (scale-float (float 7854156202477445 1.0d0) -163) + (scale-float (float 8339496630900022 1.0d0) -217)) + (%make-qd-d (scale-float (float 8394286290816088 1.0d0) -54) + (scale-float (float -8573403169330254 1.0d0) -111) + (scale-float (float 6529695060451631 1.0d0) -167) + (scale-float (float -6393362274584590 1.0d0) -221)) + (%make-qd-d (scale-float (float 8443147217093086 1.0d0) -54) + (scale-float (float -7447457963335574 1.0d0) -108) + (scale-float (float -6643844760557667 1.0d0) -162) + (scale-float (float 7249753184337927 1.0d0) -216)) + (%make-qd-d (scale-float (float 8491928673252923 1.0d0) -54) + (scale-float (float 8459131853498433 1.0d0) -110) + (scale-float (float 6888360499664938 1.0d0) -164) + (scale-float (float -5236945859638041 1.0d0) -219)) + (%make-qd-d (scale-float (float 8540630200145957 1.0d0) -54) + (scale-float (float -5286511185567367 1.0d0) -109) + (scale-float (float -8135173764139151 1.0d0) -164) + (scale-float (float -4921009164459924 1.0d0) -218)) + (%make-qd-d (scale-float (float 8589251339374868 1.0d0) -54) + (scale-float (float -6680873419295655 1.0d0) -109) + (scale-float (float -8554354988263275 1.0d0) -164) + (scale-float (float 7339900865625287 1.0d0) -218)) + (%make-qd-d (scale-float (float 8637791633298976 1.0d0) -54) + (scale-float (float 5977631648923170 1.0d0) -108) + (scale-float (float -7623682798863608 1.0d0) -162) + (scale-float (float 4624107632594484 1.0d0) -218)) + (%make-qd-d (scale-float (float 8686250625038550 1.0d0) -54) + (scale-float (float -8392536875785958 1.0d0) -108) + (scale-float (float -4707724355155067 1.0d0) -169) + (scale-float (float 5500147221680155 1.0d0) -223)) + (%make-qd-d (scale-float (float 8734627858479102 1.0d0) -54) + (scale-float (float -5852368960712652 1.0d0) -108) + (scale-float (float -8241530944970066 1.0d0) -164) + (scale-float (float -7219502451510509 1.0d0) -218)) + (%make-qd-d (scale-float (float 8782922878275687 1.0d0) -54) + (scale-float (float 4618253045998479 1.0d0) -108) + (scale-float (float -8548139780246601 1.0d0) -165) + (scale-float (float -5125184194605572 1.0d0) -221)) + (%make-qd-d (scale-float (float 8831135229857187 1.0d0) -54) + (scale-float (float -6684581881277189 1.0d0) -110) + (scale-float (float -8629413596046384 1.0d0) -164) + (scale-float (float 6391588371080480 1.0d0) -218)) + (%make-qd-d (scale-float (float 8879264459430586 1.0d0) -54) + (scale-float (float -5326170718959288 1.0d0) -112) + (scale-float (float 6502706495111478 1.0d0) -166) + (scale-float (float -8175927755321089 1.0d0) -221)) + (%make-qd-d (scale-float (float 8927310113985246 1.0d0) -54) + (scale-float (float -6121928410302052 1.0d0) -109) + (scale-float (float 5839069660685259 1.0d0) -167) + (scale-float (float 5662811753865077 1.0d0) -223)) + (%make-qd-d (scale-float (float 8975271741297168 1.0d0) -54) + (scale-float (float -5233310756427739 1.0d0) -108) + (scale-float (float -8823317657688998 1.0d0) -162) + (scale-float (float 4654507950124385 1.0d0) -218)) + (%make-qd-d (scale-float (float 4511574444966625 1.0d0) -53) + (scale-float (float -6426118857297543 1.0d0) -107) + (scale-float (float -6491521190013141 1.0d0) -161) + (scale-float (float 7186617536341604 1.0d0) -215)) + (%make-qd-d (scale-float (float 4535470554627767 1.0d0) -53) + (scale-float (float -5429619939489420 1.0d0) -108) + (scale-float (float -5927987229493283 1.0d0) -162) + (scale-float (float 8625723713246926 1.0d0) -217)) + (%make-qd-d (scale-float (float 4559323974712726 1.0d0) -53) + (scale-float (float -7840626733224058 1.0d0) -107) + (scale-float (float 5428491030047448 1.0d0) -162) + (scale-float (float 8993628089295535 1.0d0) -217)) + (%make-qd-d (scale-float (float 4583134480704026 1.0d0) -53) + (scale-float (float 7761991876870000 1.0d0) -107) + (scale-float (float -6271024629654463 1.0d0) -162) + (scale-float (float 5752025628139535 1.0d0) -217)) + (%make-qd-d (scale-float (float 4606901848488119 1.0d0) -53) + (scale-float (float -8494598453042205 1.0d0) -109) + (scale-float (float 4785427941994550 1.0d0) -163) + (scale-float (float -7993664237807223 1.0d0) -217)) + (%make-qd-d (scale-float (float 4630625854357486 1.0d0) -53) + (scale-float (float -7417310864687212 1.0d0) -107) + (scale-float (float 4527229152853963 1.0d0) -161) + (scale-float (float -5445479406340099 1.0d0) -217)) + (%make-qd-d (scale-float (float 4654306275012748 1.0d0) -53) + (scale-float (float 5388216318289433 1.0d0) -109) + (scale-float (float 6810717761619515 1.0d0) -163) + (scale-float (float -4804851653177209 1.0d0) -217)) + (%make-qd-d (scale-float (float 4677942887564769 1.0d0) -53) + (scale-float (float -8978008309930964 1.0d0) -107) + (scale-float (float -5916790110693661 1.0d0) -167) + (scale-float (float -8118978520081596 1.0d0) -221)) + (%make-qd-d (scale-float (float 4701535469536748 1.0d0) -53) + (scale-float (float -7554109741206949 1.0d0) -107) + (scale-float (float 5422636526155651 1.0d0) -163) + (scale-float (float -5639775327748784 1.0d0) -220)) + (%make-qd-d (scale-float (float 4725083798866319 1.0d0) -53) + (scale-float (float -6988323544295858 1.0d0) -107) + (scale-float (float -4912183619887695 1.0d0) -163) + (scale-float (float -6359206876678376 1.0d0) -218)) + (%make-qd-d (scale-float (float 4748587653907638 1.0d0) -53) + (scale-float (float -6847825579591004 1.0d0) -107) + (scale-float (float 5003358265465959 1.0d0) -162) + (scale-float (float 8422280950230119 1.0d0) -216)) + (%make-qd-d (scale-float (float 4772046813433470 1.0d0) -53) + (scale-float (float -7799453234034926 1.0d0) -107) + (scale-float (float 6817580222556671 1.0d0) -163) + (scale-float (float -7560644201550137 1.0d0) -219)) + (%make-qd-d (scale-float (float 4795461056637271 1.0d0) -53) + (scale-float (float -6655925208907997 1.0d0) -107) + (scale-float (float -5623857240635796 1.0d0) -161) + (scale-float (float -8070601107899198 1.0d0) -215)) + (%make-qd-d (scale-float (float 4818830163135267 1.0d0) -53) + (scale-float (float -8710586291184881 1.0d0) -107) + (scale-float (float -8126282278485839 1.0d0) -162) + (scale-float (float 5719317781414307 1.0d0) -217)) + (%make-qd-d (scale-float (float 4842153912968527 1.0d0) -53) + (scale-float (float -7339754703408720 1.0d0) -108) + (scale-float (float -6990336495915397 1.0d0) -163) + (scale-float (float 5257934322964996 1.0d0) -220)) + (%make-qd-d (scale-float (float 4865432086605035 1.0d0) -53) + (scale-float (float 8785511657898515 1.0d0) -108) + (scale-float (float 6839125971928921 1.0d0) -162) + (scale-float (float -6223394966801216 1.0d0) -216)) + (%make-qd-d (scale-float (float 4888664464941756 1.0d0) -53) + (scale-float (float 5564928859020974 1.0d0) -108) + (scale-float (float -7907253462425933 1.0d0) -162) + (scale-float (float 5236591704896374 1.0d0) -216)) + (%make-qd-d (scale-float (float 4911850829306697 1.0d0) -53) + (scale-float (float -6736651049305461 1.0d0) -107) + (scale-float (float -8955456639116160 1.0d0) -162) + (scale-float (float 6701012809879390 1.0d0) -216)) + (%make-qd-d (scale-float (float 4934990961460965 1.0d0) -53) + (scale-float (float -7809824017498950 1.0d0) -108) + (scale-float (float -5333685159010237 1.0d0) -170) + (scale-float (float -7013163948693077 1.0d0) -224)) + (%make-qd-d (scale-float (float 4958084643600824 1.0d0) -53) + (scale-float (float -5407770883530058 1.0d0) -109) + (scale-float (float -5391994932415003 1.0d0) -164) + (scale-float (float 8910660424091806 1.0d0) -218)) + (%make-qd-d (scale-float (float 4981131658359743 1.0d0) -53) + (scale-float (float -7636170899049036 1.0d0) -107) + (scale-float (float -6206770363233629 1.0d0) -162) + (scale-float (float -6822684679023966 1.0d0) -218)) + (%make-qd-d (scale-float (float 5004131788810440 1.0d0) -53) + (scale-float (float 7641456135071232 1.0d0) -107) + (scale-float (float -6033230867222893 1.0d0) -161) + (scale-float (float 6471526251842736 1.0d0) -215)) + (%make-qd-d (scale-float (float 5027084818466930 1.0d0) -53) + (scale-float (float 8749783685054072 1.0d0) -109) + (scale-float (float -6432564900081691 1.0d0) -163) + (scale-float (float -4946481004218511 1.0d0) -217)) + (%make-qd-d (scale-float (float 5049990531286555 1.0d0) -53) + (scale-float (float -4800045970584779 1.0d0) -109) + (scale-float (float 4639463359548121 1.0d0) -163) + (scale-float (float 6739134100775357 1.0d0) -217)) + (%make-qd-d (scale-float (float 5072848711672022 1.0d0) -53) + (scale-float (float 7735151275984803 1.0d0) -108) + (scale-float (float 6319202510957152 1.0d0) -165) + (scale-float (float 7852194967309185 1.0d0) -219)) + (%make-qd-d (scale-float (float 5095659144473433 1.0d0) -53) + (scale-float (float -5532405218054066 1.0d0) -107) + (scale-float (float -4990528183184909 1.0d0) -161) + (scale-float (float 4694142170446455 1.0d0) -215)) + (%make-qd-d (scale-float (float 5118421614990306 1.0d0) -53) + (scale-float (float -8264785570084562 1.0d0) -107) + (scale-float (float -4756999690706873 1.0d0) -161) + (scale-float (float 8271914155363375 1.0d0) -219)) + (%make-qd-d (scale-float (float 5141135908973599 1.0d0) -53) + (scale-float (float 7972820976421517 1.0d0) -108) + (scale-float (float -7508892149590212 1.0d0) -162) + (scale-float (float -7598338450058821 1.0d0) -218)) + (%make-qd-d (scale-float (float 5163801812627728 1.0d0) -53) + (scale-float (float 5528278164889757 1.0d0) -109) + (scale-float (float -7534708412684668 1.0d0) -163) + (scale-float (float 4748764085926481 1.0d0) -217)) + (%make-qd-d (scale-float (float 5186419112612575 1.0d0) -53) + (scale-float (float -6151167318128396 1.0d0) -107) + (scale-float (float -8018890614716932 1.0d0) -161) + (scale-float (float 5861072145574034 1.0d0) -215)) + (%make-qd-d (scale-float (float 5208987596045498 1.0d0) -53) + (scale-float (float -8514617700931210 1.0d0) -108) + (scale-float (float 7996782571413148 1.0d0) -162) + (scale-float (float -6615677919703496 1.0d0) -217)) + (%make-qd-d (scale-float (float 5231507050503336 1.0d0) -53) + (scale-float (float 6031287197379932 1.0d0) -108) + (scale-float (float 6471258723704346 1.0d0) -164) + (scale-float (float 8258737189713217 1.0d0) -218)) + (%make-qd-d (scale-float (float 5253977264024408 1.0d0) -53) + (scale-float (float 8961021967501223 1.0d0) -111) + (scale-float (float 8449105812948238 1.0d0) -165) + (scale-float (float -5388110305851105 1.0d0) -219)) + (%make-qd-d (scale-float (float 5276398025110506 1.0d0) -53) + (scale-float (float -4865896352247366 1.0d0) -110) + (scale-float (float 6539437345050652 1.0d0) -164) + (scale-float (float -6050564890654524 1.0d0) -219)) + (%make-qd-d (scale-float (float 5298769122728888 1.0d0) -53) + (scale-float (float -4752925789560358 1.0d0) -107) + (scale-float (float -6940658006329329 1.0d0) -161) + (scale-float (float -4874539996486145 1.0d0) -218)) + (%make-qd-d (scale-float (float 5321090346314263 1.0d0) -53) + (scale-float (float -7628390168680570 1.0d0) -107) + (scale-float (float 7251508591837652 1.0d0) -161) + (scale-float (float 5307279358527743 1.0d0) -218)) + (%make-qd-d (scale-float (float 5343361485770773 1.0d0) -53) + (scale-float (float 8367594692216948 1.0d0) -109) + (scale-float (float 6203590959579987 1.0d0) -163) + (scale-float (float 8665448091350130 1.0d0) -217)) + (%make-qd-d (scale-float (float 5365582331473973 1.0d0) -53) + (scale-float (float -8722177288784495 1.0d0) -109) + (scale-float (float -6349014528983703 1.0d0) -166) + (scale-float (float 8570508217536058 1.0d0) -220)) + (%make-qd-d (scale-float (float 5387752674272799 1.0d0) -53) + (scale-float (float 6295965926759422 1.0d0) -107) + (scale-float (float -7064411274953418 1.0d0) -162) + (scale-float (float -8521156802129240 1.0d0) -217)) + (%make-qd-d (scale-float (float 5409872305491543 1.0d0) -53) + (scale-float (float -7528538090890981 1.0d0) -107) + (scale-float (float -4873667464989738 1.0d0) -161) + (scale-float (float 5474430362703076 1.0d0) -216)) + (%make-qd-d (scale-float (float 5431941016931809 1.0d0) -53) + (scale-float (float 6056061026085675 1.0d0) -107) + (scale-float (float 8117741563781443 1.0d0) -161) + (scale-float (float -8527257181106372 1.0d0) -215)) + (%make-qd-d (scale-float (float 5453958600874483 1.0d0) -53) + (scale-float (float -5062923073902567 1.0d0) -107) + (scale-float (float 7460245243959813 1.0d0) -162) + (scale-float (float -8605987486451288 1.0d0) -217)) + (%make-qd-d (scale-float (float 5475924850081677 1.0d0) -53) + (scale-float (float 5705171231787006 1.0d0) -107) + (scale-float (float -5973740103346300 1.0d0) -164) + (scale-float (float -5933426595796939 1.0d0) -218)) + (%make-qd-d (scale-float (float 5497839557798690 1.0d0) -53) + (scale-float (float -7322198333974194 1.0d0) -108) + (scale-float (float 7708295787222922 1.0d0) -162) + (scale-float (float 8668959416020342 1.0d0) -216)) + (%make-qd-d (scale-float (float 5519702517755945 1.0d0) -53) + (scale-float (float -5541930106652097 1.0d0) -110) + (scale-float (float 6042424392306259 1.0d0) -164) + (scale-float (float 7112544487152837 1.0d0) -218)) + (%make-qd-d (scale-float (float 5541513524170937 1.0d0) -53) + (scale-float (float 8512581754243428 1.0d0) -108) + (scale-float (float -8240160558210729 1.0d0) -162) + (scale-float (float 7588665830274554 1.0d0) -216)) + (%make-qd-d (scale-float (float 5563272371750168 1.0d0) -53) + (scale-float (float -7703842410206491 1.0d0) -107) + (scale-float (float -8533597952376245 1.0d0) -163) + (scale-float (float -6350821420004830 1.0d0) -217)) + (%make-qd-d (scale-float (float 5584978855691076 1.0d0) -53) + (scale-float (float -4540568005736910 1.0d0) -107) + (scale-float (float 6810569017348767 1.0d0) -162) + (scale-float (float -5743636460441176 1.0d0) -216)) + (%make-qd-d (scale-float (float 5606632771683968 1.0d0) -53) + (scale-float (float 6872099470811347 1.0d0) -110) + (scale-float (float -4535230040345874 1.0d0) -166) + (scale-float (float 6845954161715752 1.0d0) -225)) + (%make-qd-d (scale-float (float 5628233915913940 1.0d0) -53) + (scale-float (float 5463569387507809 1.0d0) -107) + (scale-float (float -8139410524833584 1.0d0) -161) + (scale-float (float 5908305814053563 1.0d0) -216)) + (%make-qd-d (scale-float (float 5649782085062796 1.0d0) -53) + (scale-float (float 4991677084184053 1.0d0) -107) + (scale-float (float 6329805746482172 1.0d0) -164) + (scale-float (float -4706296920171159 1.0d0) -218)) + (%make-qd-d (scale-float (float 5671277076310961 1.0d0) -53) + (scale-float (float 6671344369483978 1.0d0) -107) + (scale-float (float -5602658804200812 1.0d0) -161) + (scale-float (float 5854533570742313 1.0d0) -215)) + (%make-qd-d (scale-float (float 5692718687339392 1.0d0) -53) + (scale-float (float -6517134490911270 1.0d0) -107) + (scale-float (float -8442644072947353 1.0d0) -163) + (scale-float (float 7967700612201239 1.0d0) -217)) + (%make-qd-d (scale-float (float 5714106716331478 1.0d0) -53) + (scale-float (float 6763552043812531 1.0d0) -109) + (scale-float (float 4814134823321695 1.0d0) -163) + (scale-float (float -4874409913813393 1.0d0) -221)) + (%make-qd-d (scale-float (float 5735440961974946 1.0d0) -53) + (scale-float (float 5098032122654983 1.0d0) -107) + (scale-float (float -6633387170173303 1.0d0) -161) + (scale-float (float -8437401866493262 1.0d0) -215)) + (%make-qd-d (scale-float (float 5756721223463751 1.0d0) -53) + (scale-float (float 8058961560658971 1.0d0) -109) + (scale-float (float -7260204596373573 1.0d0) -163) + (scale-float (float 5847373583723548 1.0d0) -217)) + (%make-qd-d (scale-float (float 5777947300499967 1.0d0) -53) + (scale-float (float -6482805255133693 1.0d0) -109) + (scale-float (float 4907047913048716 1.0d0) -163) + (scale-float (float 4800601318416331 1.0d0) -219)) + (%make-qd-d (scale-float (float 5799118993295673 1.0d0) -53) + (scale-float (float -5206056249695124 1.0d0) -107) + (scale-float (float -7363227589940729 1.0d0) -162) + (scale-float (float -8468347824445839 1.0d0) -217)) + (%make-qd-d (scale-float (float 5820236102574833 1.0d0) -53) + (scale-float (float -4828209332879607 1.0d0) -107) + (scale-float (float -6006988076989561 1.0d0) -162) + (scale-float (float 6811807852310658 1.0d0) -219)) + (%make-qd-d (scale-float (float 5841298429575172 1.0d0) -53) + (scale-float (float 5175456982428321 1.0d0) -110) + (scale-float (float 4538462653543703 1.0d0) -164) + (scale-float (float -8728016611215022 1.0d0) -220)) + (%make-qd-d (scale-float (float 5862305776050047 1.0d0) -53) + (scale-float (float 6444073748996113 1.0d0) -107) + (scale-float (float 6823119024662590 1.0d0) -164) + (scale-float (float 6426684369717617 1.0d0) -220)) + (%make-qd-d (scale-float (float 5883257944270313 1.0d0) -53) + (scale-float (float 5561965163229991 1.0d0) -109) + (scale-float (float -8086818543630428 1.0d0) -163) + (scale-float (float 5028398904287973 1.0d0) -217)) + (%make-qd-d (scale-float (float 5904154737026182 1.0d0) -53) + (scale-float (float 5782715275133621 1.0d0) -107) + (scale-float (float 7421719155960077 1.0d0) -162) + (scale-float (float 4632156185190014 1.0d0) -216)) + (%make-qd-d (scale-float (float 5924995957629083 1.0d0) -53) + (scale-float (float 6354379320602223 1.0d0) -108) + (scale-float (float -6982629383914688 1.0d0) -162) + (scale-float (float 6014680402693896 1.0d0) -217)) + (%make-qd-d (scale-float (float 5945781409913510 1.0d0) -53) + (scale-float (float -5798779723014377 1.0d0) -115) + (scale-float (float 4603157000630414 1.0d0) -169) + (scale-float (float 7213200979097056 1.0d0) -223)) + (%make-qd-d (scale-float (float 5966510898238870 1.0d0) -53) + (scale-float (float -7339152233857623 1.0d0) -108) + (scale-float (float 5866707295710201 1.0d0) -163) + (scale-float (float 6142346235706265 1.0d0) -217)) + (%make-qd-d (scale-float (float 5987184227491324 1.0d0) -53) + (scale-float (float -5878295590335062 1.0d0) -107) + (scale-float (float -5296945800600359 1.0d0) -162) + (scale-float (float 6511887897632255 1.0d0) -217)) + (%make-qd-d (scale-float (float 6007801203085623 1.0d0) -53) + (scale-float (float 5725215547860703 1.0d0) -107) + (scale-float (float -6069357457640343 1.0d0) -162) + (scale-float (float 7773390546671458 1.0d0) -216)) + (%make-qd-d (scale-float (float 6028361630966943 1.0d0) -53) + (scale-float (float -8858164301443705 1.0d0) -107) + (scale-float (float -7360418845574603 1.0d0) -161) + (scale-float (float -8881973385408916 1.0d0) -215)) + (%make-qd-d (scale-float (float 6048865317612704 1.0d0) -53) + (scale-float (float -6569721984711602 1.0d0) -107) + (scale-float (float 7481914584676442 1.0d0) -164) + (scale-float (float -5916197970128717 1.0d0) -218)) + (%make-qd-d (scale-float (float 6069312070034399 1.0d0) -53) + (scale-float (float 7493750390382232 1.0d0) -108) + (scale-float (float 6714493630887683 1.0d0) -163) + (scale-float (float 4735122177247567 1.0d0) -218)) + (%make-qd-d (scale-float (float 6089701695779408 1.0d0) -53) + (scale-float (float 6045278015665200 1.0d0) -107) + (scale-float (float 4986473437314348 1.0d0) -161) + (scale-float (float 5124830363027070 1.0d0) -215)) + (%make-qd-d (scale-float (float 6110034002932808 1.0d0) -53) + (scale-float (float 5939368762867376 1.0d0) -108) + (scale-float (float 5567834601844250 1.0d0) -162) + (scale-float (float 5300167663866890 1.0d0) -216)) + (%make-qd-d (scale-float (float 6130308800119180 1.0d0) -53) + (scale-float (float 4620055988650794 1.0d0) -107) + (scale-float (float 4832520168769970 1.0d0) -163) + (scale-float (float 8968190560224699 1.0d0) -217)) + (%make-qd-d (scale-float (float 6150525896504412 1.0d0) -53) + (scale-float (float -8410260520695715 1.0d0) -109) + (scale-float (float 8554993117360727 1.0d0) -165) + (scale-float (float 5819339724088257 1.0d0) -220)) + (%make-qd-d (scale-float (float 6170685101797492 1.0d0) -53) + (scale-float (float 8420651303499559 1.0d0) -108) + (scale-float (float -4970902812289148 1.0d0) -162) + (scale-float (float -7326795827672023 1.0d0) -216)) + (%make-qd-d (scale-float (float 6190786226252304 1.0d0) -53) + (scale-float (float -8949598425759774 1.0d0) -107) + (scale-float (float 6954695760200578 1.0d0) -162) + (scale-float (float -6614108672187788 1.0d0) -219)) + (%make-qd-d (scale-float (float 6210829080669407 1.0d0) -53) + (scale-float (float -5156380214241847 1.0d0) -108) + (scale-float (float 5334034121559607 1.0d0) -162) + (scale-float (float 8070176566193680 1.0d0) -217)) + (%make-qd-d (scale-float (float 6230813476397823 1.0d0) -53) + (scale-float (float 8893780947316055 1.0d0) -108) + (scale-float (float 7767301829960617 1.0d0) -162) + (scale-float (float 7179345590973681 1.0d0) -222)) + (%make-qd-d (scale-float (float 6250739225336809 1.0d0) -53) + (scale-float (float 4825271369095292 1.0d0) -109) + (scale-float (float 8776203731192851 1.0d0) -163) + (scale-float (float -6709656828176138 1.0d0) -218)) + (%make-qd-d (scale-float (float 6270606139937627 1.0d0) -53) + (scale-float (float -6688989605664720 1.0d0) -107) + (scale-float (float -5956139094822349 1.0d0) -167) + (scale-float (float 4660601968416390 1.0d0) -221)) + (%make-qd-d (scale-float (float 6290414033205309 1.0d0) -53) + (scale-float (float 7948803281116707 1.0d0) -107) + (scale-float (float 5592877509532575 1.0d0) -161) + (scale-float (float 5510182001592507 1.0d0) -217)) + (%make-qd-d (scale-float (float 6310162718700422 1.0d0) -53) + (scale-float (float 5034574382400651 1.0d0) -107) + (scale-float (float 5591018388425185 1.0d0) -162) + (scale-float (float 7733615070437822 1.0d0) -220)) + (%make-qd-d (scale-float (float 6329852010540816 1.0d0) -53) + (scale-float (float 6562620425861985 1.0d0) -111) + (scale-float (float -8136290568547131 1.0d0) -166) + (scale-float (float 8426790677064152 1.0d0) -220)) + (%make-qd-d (scale-float (float 6349481723403377 1.0d0) -53) + (scale-float (float 8959543695439504 1.0d0) -108) + (scale-float (float 6972321431588115 1.0d0) -164) + (scale-float (float 4858285252195155 1.0d0) -218)) + (%make-qd-d (scale-float (float 6369051672525773 1.0d0) -53) + (scale-float (float -7843040109683798 1.0d0) -107) + (scale-float (float 6048680740045173 1.0d0) -161) + (scale-float (float 5197737643093849 1.0d0) -217)))) + "Table of sin(k/1024) for k = 1 to 256") + +(defconstant +qd-cos-table+ + (make-array 256 + :initial-contents + (list + (%make-qd-d (scale-float (float 9007156865146114 1.0d0) -53) + (scale-float (float -6382651775133715 1.0d0) -108) + (scale-float (float -7372276689025835 1.0d0) -163) + (scale-float (float 7180257539184632 1.0d0) -223)) + (%make-qd-d (scale-float (float 9007029696760466 1.0d0) -53) + (scale-float (float 5446736202153207 1.0d0) -107) + (scale-float (float -5514938334717690 1.0d0) -168) + (scale-float (float 6645835630926151 1.0d0) -222)) + (%make-qd-d (scale-float (float 9006817750781007 1.0d0) -53) + (scale-float (float -5115684009971601 1.0d0) -107) + (scale-float (float 7705986954927589 1.0d0) -161) + (scale-float (float 5269566330016024 1.0d0) -215)) + (%make-qd-d (scale-float (float 9006521029202651 1.0d0) -53) + (scale-float (float 6154670017854733 1.0d0) -107) + (scale-float (float -7959914909379173 1.0d0) -166) + (scale-float (float -8417733335951937 1.0d0) -220)) + (%make-qd-d (scale-float (float 9006139534818257 1.0d0) -53) + (scale-float (float -5756604584677720 1.0d0) -107) + (scale-float (float 4998920502946311 1.0d0) -161) + (scale-float (float -5647576219871589 1.0d0) -215)) + (%make-qd-d (scale-float (float 9005673271218593 1.0d0) -53) + (scale-float (float 6109107373172336 1.0d0) -108) + (scale-float (float -6007767124009731 1.0d0) -163) + (scale-float (float -8083524655498703 1.0d0) -217)) + (%make-qd-d (scale-float (float 9005122242792311 1.0d0) -53) + (scale-float (float 6925416919478846 1.0d0) -107) + (scale-float (float 5571917222010501 1.0d0) -161) + (scale-float (float -6342027657037425 1.0d0) -216)) + (%make-qd-d (scale-float (float 9004486454725901 1.0d0) -53) + (scale-float (float -4843680596157643 1.0d0) -107) + (scale-float (float -5578489598087899 1.0d0) -161) + (scale-float (float 4716327604025735 1.0d0) -219)) + (%make-qd-d (scale-float (float 9003765913003641 1.0d0) -53) + (scale-float (float -6682155943911976 1.0d0) -107) + (scale-float (float 6113568212113372 1.0d0) -161) + (scale-float (float 8572777647471794 1.0d0) -216)) + (%make-qd-d (scale-float (float 9002960624407544 1.0d0) -53) + (scale-float (float 6658445016247619 1.0d0) -108) + (scale-float (float -5574027242944025 1.0d0) -163) + (scale-float (float -6201546866284994 1.0d0) -217)) + (%make-qd-d (scale-float (float 9002070596517294 1.0d0) -53) + (scale-float (float 6432687535538725 1.0d0) -107) + (scale-float (float -5555395417668222 1.0d0) -164) + (scale-float (float -8665438431468013 1.0d0) -222)) + (%make-qd-d (scale-float (float 9001095837710173 1.0d0) -53) + (scale-float (float -6954195453368662 1.0d0) -107) + (scale-float (float 7771704866044900 1.0d0) -164) + (scale-float (float -7039433522181404 1.0d0) -219)) + (%make-qd-d (scale-float (float 9000036357160980 1.0d0) -53) + (scale-float (float 5957921611966531 1.0d0) -109) + (scale-float (float 6479270319865368 1.0d0) -163) + (scale-float (float 5409988246591494 1.0d0) -222)) + (%make-qd-d (scale-float (float 8998892164841951 1.0d0) -53) + (scale-float (float 6950865384540836 1.0d0) -108) + (scale-float (float -4621163143123886 1.0d0) -162) + (scale-float (float -5599064490362240 1.0d0) -216)) + (%make-qd-d (scale-float (float 8997663271522660 1.0d0) -53) + (scale-float (float -6688535702623983 1.0d0) -108) + (scale-float (float -7334707016190584 1.0d0) -162) + (scale-float (float -7916945128397036 1.0d0) -216)) + (%make-qd-d (scale-float (float 8996349688769918 1.0d0) -53) + (scale-float (float -7977765087521301 1.0d0) -109) + (scale-float (float 5721708006624170 1.0d0) -164) + (scale-float (float 4517430183150016 1.0d0) -218)) + (%make-qd-d (scale-float (float 8994951428947667 1.0d0) -53) + (scale-float (float -7900445453445422 1.0d0) -107) + (scale-float (float -6891478759949600 1.0d0) -164) + (scale-float (float -5476513299440062 1.0d0) -218)) + (%make-qd-d (scale-float (float 8993468505216860 1.0d0) -53) + (scale-float (float -7140359403681271 1.0d0) -108) + (scale-float (float -7232392529862741 1.0d0) -162) + (scale-float (float -5246916413682806 1.0d0) -217)) + (%make-qd-d (scale-float (float 8991900931535341 1.0d0) -53) + (scale-float (float -8416291772118320 1.0d0) -107) + (scale-float (float 6126729149397296 1.0d0) -162) + (scale-float (float -6107196519366287 1.0d0) -217)) + (%make-qd-d (scale-float (float 8990248722657709 1.0d0) -53) + (scale-float (float 4532792009051038 1.0d0) -107) + (scale-float (float 7138950646897488 1.0d0) -161) + (scale-float (float -7124028913967965 1.0d0) -216)) + (%make-qd-d (scale-float (float 8988511894135185 1.0d0) -53) + (scale-float (float 5563435675856346 1.0d0) -108) + (scale-float (float 6768020100627694 1.0d0) -163) + (scale-float (float -7801655263446071 1.0d0) -219)) + (%make-qd-d (scale-float (float 8986690462315460 1.0d0) -53) + (scale-float (float -8565496940783238 1.0d0) -108) + (scale-float (float -7565304489103248 1.0d0) -165) + (scale-float (float -8418659784422752 1.0d0) -219)) + (%make-qd-d (scale-float (float 8984784444342543 1.0d0) -53) + (scale-float (float 7270150983818169 1.0d0) -110) + (scale-float (float -5563309902486145 1.0d0) -166) + (scale-float (float -4888785479057611 1.0d0) -231)) + (%make-qd-d (scale-float (float 8982793858156602 1.0d0) -53) + (scale-float (float 5948275509591605 1.0d0) -109) + (scale-float (float 7930006667538804 1.0d0) -163) + (scale-float (float -5809288382338202 1.0d0) -222)) + (%make-qd-d (scale-float (float 8980718722493792 1.0d0) -53) + (scale-float (float 5430523834411255 1.0d0) -108) + (scale-float (float -7699162237707398 1.0d0) -162) + (scale-float (float 8687041402074628 1.0d0) -219)) + (%make-qd-d (scale-float (float 8978559056886080 1.0d0) -53) + (scale-float (float 7636379253722903 1.0d0) -107) + (scale-float (float 8304848910636198 1.0d0) -161) + (scale-float (float -8425631601226793 1.0d0) -216)) + (%make-qd-d (scale-float (float 8976314881661062 1.0d0) -53) + (scale-float (float 7598393650369643 1.0d0) -109) + (scale-float (float -8878261545093758 1.0d0) -163) + (scale-float (float 5997503087615023 1.0d0) -217)) + (%make-qd-d (scale-float (float 8973986217941769 1.0d0) -53) + (scale-float (float 7357807798683726 1.0d0) -109) + (scale-float (float 7951143844149272 1.0d0) -164) + (scale-float (float 5218035394662342 1.0d0) -222)) + (%make-qd-d (scale-float (float 8971573087646471 1.0d0) -53) + (scale-float (float 7421749611895653 1.0d0) -108) + (scale-float (float -4581496555918016 1.0d0) -163) + (scale-float (float -7810225024786925 1.0d0) -217)) + (%make-qd-d (scale-float (float 8969075513488470 1.0d0) -53) + (scale-float (float -7513223803443073 1.0d0) -108) + (scale-float (float -7626238511742260 1.0d0) -165) + (scale-float (float -5366856187311050 1.0d0) -221)) + (%make-qd-d (scale-float (float 8966493518975884 1.0d0) -53) + (scale-float (float 8329643948299160 1.0d0) -111) + (scale-float (float -7408252878990684 1.0d0) -170) + (scale-float (float -7497946385569394 1.0d0) -224)) + (%make-qd-d (scale-float (float 8963827128411430 1.0d0) -53) + (scale-float (float -6893895888146887 1.0d0) -107) + (scale-float (float 7784256318365108 1.0d0) -162) + (scale-float (float 7153652023322651 1.0d0) -216)) + (%make-qd-d (scale-float (float 8961076366892190 1.0d0) -53) + (scale-float (float 5468892236673259 1.0d0) -110) + (scale-float (float -7868743052739110 1.0d0) -167) + (scale-float (float 8477913984177349 1.0d0) -221)) + (%make-qd-d (scale-float (float 8958241260309380 1.0d0) -53) + (scale-float (float 5962228427073425 1.0d0) -107) + (scale-float (float -8945355811576285 1.0d0) -161) + (scale-float (float 5475118791675541 1.0d0) -215)) + (%make-qd-d (scale-float (float 8955321835348103 1.0d0) -53) + (scale-float (float 7160408339531907 1.0d0) -107) + (scale-float (float -8800353687418162 1.0d0) -161) + (scale-float (float 7814338741356067 1.0d0) -216)) + (%make-qd-d (scale-float (float 8952318119487099 1.0d0) -53) + (scale-float (float -6154445520718857 1.0d0) -108) + (scale-float (float -5979147254374853 1.0d0) -168) + (scale-float (float -5754250618745921 1.0d0) -222)) + (%make-qd-d (scale-float (float 8949230140998484 1.0d0) -53) + (scale-float (float 4827588292883036 1.0d0) -107) + (scale-float (float -5269205324285223 1.0d0) -163) + (scale-float (float -7066073884583852 1.0d0) -217)) + (%make-qd-d (scale-float (float 8946057928947489 1.0d0) -53) + (scale-float (float 5370280075238301 1.0d0) -107) + (scale-float (float 4557784045899430 1.0d0) -161) + (scale-float (float 6055026141926995 1.0d0) -218)) + (%make-qd-d (scale-float (float 8942801513192182 1.0d0) -53) + (scale-float (float -4573932509451197 1.0d0) -108) + (scale-float (float -6988642513170233 1.0d0) -162) + (scale-float (float 7903423679430231 1.0d0) -218)) + (%make-qd-d (scale-float (float 8939460924383187 1.0d0) -53) + (scale-float (float 5045136634195182 1.0d0) -107) + (scale-float (float -5372361566405903 1.0d0) -161) + (scale-float (float -6720737022123546 1.0d0) -220)) + (%make-qd-d (scale-float (float 8936036193963400 1.0d0) -53) + (scale-float (float -6398195821015223 1.0d0) -107) + (scale-float (float -7337680936016907 1.0d0) -163) + (scale-float (float -5459780776141598 1.0d0) -218)) + (%make-qd-d (scale-float (float 8932527354167686 1.0d0) -53) + (scale-float (float -6067949506678475 1.0d0) -111) + (scale-float (float 5064661831761972 1.0d0) -167) + (scale-float (float -8471798904647962 1.0d0) -222)) + (%make-qd-d (scale-float (float 8928934438022583 1.0d0) -53) + (scale-float (float -8175307614637614 1.0d0) -108) + (scale-float (float -7513563295790417 1.0d0) -162) + (scale-float (float 5516806786798278 1.0d0) -216)) + (%make-qd-d (scale-float (float 8925257479345985 1.0d0) -53) + (scale-float (float 4995821998689288 1.0d0) -108) + (scale-float (float -6313677797518807 1.0d0) -162) + (scale-float (float 4625503888993559 1.0d0) -220)) + (%make-qd-d (scale-float (float 8921496512746829 1.0d0) -53) + (scale-float (float -8991019785543599 1.0d0) -107) + (scale-float (float -8543364032599344 1.0d0) -162) + (scale-float (float -8075214757855398 1.0d0) -217)) + (%make-qd-d (scale-float (float 8917651573624763 1.0d0) -53) + (scale-float (float -5534821618232727 1.0d0) -108) + (scale-float (float 7865766552369999 1.0d0) -162) + (scale-float (float 7700180873329070 1.0d0) -216)) + (%make-qd-d (scale-float (float 8913722698169820 1.0d0) -53) + (scale-float (float -8502096954648678 1.0d0) -107) + (scale-float (float 7870589230495605 1.0d0) -162) + (scale-float (float 6110391933205275 1.0d0) -216)) + (%make-qd-d (scale-float (float 8909709923362071 1.0d0) -53) + (scale-float (float -6650571269560095 1.0d0) -107) + (scale-float (float -5244751855479113 1.0d0) -163) + (scale-float (float -8301663588356049 1.0d0) -217)) + (%make-qd-d (scale-float (float 8905613286971281 1.0d0) -53) + (scale-float (float -7123978755460638 1.0d0) -109) + (scale-float (float 7555692813056111 1.0d0) -164) + (scale-float (float 8118983438487515 1.0d0) -219)) + (%make-qd-d (scale-float (float 8901432827556552 1.0d0) -53) + (scale-float (float 8771933742692817 1.0d0) -108) + (scale-float (float 7250438674596944 1.0d0) -166) + (scale-float (float 7083606337494008 1.0d0) -221)) + (%make-qd-d (scale-float (float 8897168584465961 1.0d0) -53) + (scale-float (float -7658862886582027 1.0d0) -108) + (scale-float (float -7204199762688552 1.0d0) -162) + (scale-float (float 6346308409048664 1.0d0) -217)) + (%make-qd-d (scale-float (float 8892820597836187 1.0d0) -53) + (scale-float (float -8491394866189883 1.0d0) -107) + (scale-float (float -8166182587214152 1.0d0) -161) + (scale-float (float 6357787596929140 1.0d0) -215)) + (%make-qd-d (scale-float (float 8888388908592136 1.0d0) -53) + (scale-float (float -8159567034358810 1.0d0) -107) + (scale-float (float -6629817546842393 1.0d0) -161) + (scale-float (float 4634129890739685 1.0d0) -216)) + (%make-qd-d (scale-float (float 8883873558446555 1.0d0) -53) + (scale-float (float -6983923910930642 1.0d0) -108) + (scale-float (float 6937180072251376 1.0d0) -162) + (scale-float (float -8270405867504028 1.0d0) -216)) + (%make-qd-d (scale-float (float 8879274589899640 1.0d0) -53) + (scale-float (float -8346528441017500 1.0d0) -107) + (scale-float (float 7680611814957263 1.0d0) -161) + (scale-float (float 7943027189392270 1.0d0) -216)) + (%make-qd-d (scale-float (float 8874592046238633 1.0d0) -53) + (scale-float (float 7514433837333686 1.0d0) -108) + (scale-float (float -8801276453264781 1.0d0) -163) + (scale-float (float 8915512537041539 1.0d0) -219)) + (%make-qd-d (scale-float (float 8869825971537420 1.0d0) -53) + (scale-float (float 6846136909451560 1.0d0) -109) + (scale-float (float 6731359750255182 1.0d0) -164) + (scale-float (float -6197790138101606 1.0d0) -220)) + (%make-qd-d (scale-float (float 8864976410656110 1.0d0) -53) + (scale-float (float 7785836584894173 1.0d0) -107) + (scale-float (float 5284186529715868 1.0d0) -164) + (scale-float (float 7402980542247590 1.0d0) -218)) + (%make-qd-d (scale-float (float 8860043409240618 1.0d0) -53) + (scale-float (float 6446544258894238 1.0d0) -108) + (scale-float (float -8038901621714735 1.0d0) -169) + (scale-float (float 4846229103018903 1.0d0) -224)) + (%make-qd-d (scale-float (float 8855027013722231 1.0d0) -53) + (scale-float (float 6842474924546396 1.0d0) -107) + (scale-float (float 4816891086673617 1.0d0) -162) + (scale-float (float -8509622836947172 1.0d0) -216)) + (%make-qd-d (scale-float (float 8849927271317175 1.0d0) -53) + (scale-float (float 4916320054218436 1.0d0) -108) + (scale-float (float -4887585510279573 1.0d0) -163) + (scale-float (float -4665371238305833 1.0d0) -217)) + (%make-qd-d (scale-float (float 8844744230026167 1.0d0) -53) + (scale-float (float 6850081623240539 1.0d0) -108) + (scale-float (float -8916921648409142 1.0d0) -162) + (scale-float (float -7202105646592469 1.0d0) -216)) + (%make-qd-d (scale-float (float 8839477938633966 1.0d0) -53) + (scale-float (float 8715376239079668 1.0d0) -109) + (scale-float (float -7634216994416838 1.0d0) -163) + (scale-float (float 4712162648716876 1.0d0) -220)) + (%make-qd-d (scale-float (float 8834128446708912 1.0d0) -53) + (scale-float (float 6018826142883795 1.0d0) -108) + (scale-float (float -6253218580383489 1.0d0) -162) + (scale-float (float 7020978235349363 1.0d0) -216)) + (%make-qd-d (scale-float (float 8828695804602461 1.0d0) -53) + (scale-float (float -5971431338778072 1.0d0) -107) + (scale-float (float 7394633722946009 1.0d0) -163) + (scale-float (float 7835308697779253 1.0d0) -218)) + (%make-qd-d (scale-float (float 8823180063448708 1.0d0) -53) + (scale-float (float 5054049223849600 1.0d0) -108) + (scale-float (float -7834271977802953 1.0d0) -162) + (scale-float (float -7272320165403980 1.0d0) -218)) + (%make-qd-d (scale-float (float 8817581275163911 1.0d0) -53) + (scale-float (float -6183435703505308 1.0d0) -111) + (scale-float (float -5001726456690585 1.0d0) -165) + (scale-float (float -6933175510886964 1.0d0) -219)) + (%make-qd-d (scale-float (float 8811899492445997 1.0d0) -53) + (scale-float (float -7017091372002309 1.0d0) -108) + (scale-float (float 6413304785703535 1.0d0) -162) + (scale-float (float 8118727090730765 1.0d0) -216)) + (%make-qd-d (scale-float (float 8806134768774068 1.0d0) -53) + (scale-float (float 8196387204119507 1.0d0) -107) + (scale-float (float -7748736525621098 1.0d0) -162) + (scale-float (float 7388842477950275 1.0d0) -216)) + (%make-qd-d (scale-float (float 8800287158407901 1.0d0) -53) + (scale-float (float -7034568527191045 1.0d0) -107) + (scale-float (float 6424625550657811 1.0d0) -163) + (scale-float (float -7814615457557805 1.0d0) -219)) + (%make-qd-d (scale-float (float 8794356716387429 1.0d0) -53) + (scale-float (float 6042141602652702 1.0d0) -109) + (scale-float (float -4815349649953967 1.0d0) -163) + (scale-float (float -6721857373013784 1.0d0) -217)) + (%make-qd-d (scale-float (float 8788343498532233 1.0d0) -53) + (scale-float (float -8298768912839398 1.0d0) -108) + (scale-float (float -5446972436275558 1.0d0) -162) + (scale-float (float -7049677529730599 1.0d0) -219)) + (%make-qd-d (scale-float (float 8782247561441008 1.0d0) -53) + (scale-float (float 8646037700366584 1.0d0) -108) + (scale-float (float 8333782932738579 1.0d0) -165) + (scale-float (float -5587385824373688 1.0d0) -220)) + (%make-qd-d (scale-float (float 8776068962491037 1.0d0) -53) + (scale-float (float 5981843094371335 1.0d0) -111) + (scale-float (float 5031627907802402 1.0d0) -165) + (scale-float (float 8605971594377410 1.0d0) -220)) + (%make-qd-d (scale-float (float 8769807759837646 1.0d0) -53) + (scale-float (float -8393641348716169 1.0d0) -107) + (scale-float (float -4533131738151266 1.0d0) -161) + (scale-float (float -8690963173342472 1.0d0) -215)) + (%make-qd-d (scale-float (float 8763464012413658 1.0d0) -53) + (scale-float (float -5080534473348267 1.0d0) -107) + (scale-float (float -7855304661081380 1.0d0) -161) + (scale-float (float -7296856099117507 1.0d0) -221)) + (%make-qd-d (scale-float (float 8757037779928840 1.0d0) -53) + (scale-float (float 5916163041813500 1.0d0) -107) + (scale-float (float 8859516786540065 1.0d0) -161) + (scale-float (float -8561614259167781 1.0d0) -222)) + (%make-qd-d (scale-float (float 8750529122869341 1.0d0) -53) + (scale-float (float -5183562189985281 1.0d0) -109) + (scale-float (float -5101040255073374 1.0d0) -163) + (scale-float (float 5780805313355459 1.0d0) -220)) + (%make-qd-d (scale-float (float 8743938102497119 1.0d0) -53) + (scale-float (float -7787173714602643 1.0d0) -107) + (scale-float (float 8870592638467604 1.0d0) -161) + (scale-float (float 4527859829386072 1.0d0) -215)) + (%make-qd-d (scale-float (float 8737264780849367 1.0d0) -53) + (scale-float (float 5959880706574729 1.0d0) -108) + (scale-float (float -8366277013359923 1.0d0) -162) + (scale-float (float 7232577075726740 1.0d0) -219)) + (%make-qd-d (scale-float (float 8730509220737932 1.0d0) -53) + (scale-float (float -7409352491475308 1.0d0) -107) + (scale-float (float 5620790720594497 1.0d0) -162) + (scale-float (float 6846782194285202 1.0d0) -219)) + (%make-qd-d (scale-float (float 8723671485748716 1.0d0) -53) + (scale-float (float 8027789877305549 1.0d0) -107) + (scale-float (float 8347728572284626 1.0d0) -161) + (scale-float (float 6629242611071548 1.0d0) -216)) + (%make-qd-d (scale-float (float 8716751640241088 1.0d0) -53) + (scale-float (float -7384765759223300 1.0d0) -107) + (scale-float (float -8259014728839389 1.0d0) -162) + (scale-float (float -8911590265625930 1.0d0) -216)) + (%make-qd-d (scale-float (float 8709749749347266 1.0d0) -53) + (scale-float (float 6246370251798351 1.0d0) -107) + (scale-float (float -6299847417742655 1.0d0) -163) + (scale-float (float -7418590254845397 1.0d0) -217)) + (%make-qd-d (scale-float (float 8702665878971716 1.0d0) -53) + (scale-float (float 8323712745751476 1.0d0) -107) + (scale-float (float 6811334649930440 1.0d0) -165) + (scale-float (float 8505841244414894 1.0d0) -219)) + (%make-qd-d (scale-float (float 8695500095790524 1.0d0) -53) + (scale-float (float -7705819592372010 1.0d0) -108) + (scale-float (float 6924187360006505 1.0d0) -163) + (scale-float (float -8174591260972689 1.0d0) -217)) + (%make-qd-d (scale-float (float 8688252467250769 1.0d0) -53) + (scale-float (float -5547558796790388 1.0d0) -107) + (scale-float (float 6717667801494033 1.0d0) -161) + (scale-float (float -4752616405244403 1.0d0) -216)) + (%make-qd-d (scale-float (float 8680923061569891 1.0d0) -53) + (scale-float (float 8588042960215234 1.0d0) -108) + (scale-float (float -8702070775005543 1.0d0) -171) + (scale-float (float -6976332996211473 1.0d0) -225)) + (%make-qd-d (scale-float (float 8673511947735049 1.0d0) -53) + (scale-float (float 5798624754283258 1.0d0) -109) + (scale-float (float -4568215043570977 1.0d0) -163) + (scale-float (float 6829329873018631 1.0d0) -218)) + (%make-qd-d (scale-float (float 8666019195502468 1.0d0) -53) + (scale-float (float 4944614710107653 1.0d0) -108) + (scale-float (float -7629139990045050 1.0d0) -162) + (scale-float (float 8321368928085100 1.0d0) -216)) + (%make-qd-d (scale-float (float 8658444875396786 1.0d0) -53) + (scale-float (float 5434765495412269 1.0d0) -111) + (scale-float (float 5036267983276872 1.0d0) -165) + (scale-float (float -5008959202542514 1.0d0) -219)) + (%make-qd-d (scale-float (float 8650789058710388 1.0d0) -53) + (scale-float (float 8000649532699255 1.0d0) -108) + (scale-float (float -8062911270553914 1.0d0) -162) + (scale-float (float -8041915918056652 1.0d0) -220)) + (%make-qd-d (scale-float (float 8643051817502737 1.0d0) -53) + (scale-float (float 7139823619402846 1.0d0) -109) + (scale-float (float -4914858230587332 1.0d0) -163) + (scale-float (float 6743980924865325 1.0d0) -220)) + (%make-qd-d (scale-float (float 8635233224599694 1.0d0) -53) + (scale-float (float -7088298843580067 1.0d0) -107) + (scale-float (float 6431133538561354 1.0d0) -161) + (scale-float (float -5557182891497346 1.0d0) -215)) + (%make-qd-d (scale-float (float 8627333353592832 1.0d0) -53) + (scale-float (float -5742910758171990 1.0d0) -108) + (scale-float (float 8962645513660430 1.0d0) -165) + (scale-float (float 6865454473379410 1.0d0) -219)) + (%make-qd-d (scale-float (float 8619352278838746 1.0d0) -53) + (scale-float (float 6580241596413982 1.0d0) -107) + (scale-float (float -5012077621452493 1.0d0) -161) + (scale-float (float 5420791254282205 1.0d0) -217)) + (%make-qd-d (scale-float (float 8611290075458352 1.0d0) -53) + (scale-float (float 6117993379878867 1.0d0) -107) + (scale-float (float 5752090453333422 1.0d0) -161) + (scale-float (float 8961357552235688 1.0d0) -216)) + (%make-qd-d (scale-float (float 8603146819336178 1.0d0) -53) + (scale-float (float 8127348605830121 1.0d0) -107) + (scale-float (float -7887192887344204 1.0d0) -161) + (scale-float (float 5319494234616797 1.0d0) -215)) + (%make-qd-d (scale-float (float 8594922587119653 1.0d0) -53) + (scale-float (float -6092170856221856 1.0d0) -107) + (scale-float (float 8740726400738582 1.0d0) -162) + (scale-float (float -8711151914884922 1.0d0) -216)) + (%make-qd-d (scale-float (float 8586617456218381 1.0d0) -53) + (scale-float (float -8174862114446858 1.0d0) -108) + (scale-float (float -8343560746786883 1.0d0) -162) + (scale-float (float -4919904534422867 1.0d0) -216)) + (%make-qd-d (scale-float (float 8578231504803418 1.0d0) -53) + (scale-float (float -6577764069693440 1.0d0) -108) + (scale-float (float -6217787362116513 1.0d0) -162) + (scale-float (float -7480234698414209 1.0d0) -217)) + (%make-qd-d (scale-float (float 8569764811806532 1.0d0) -53) + (scale-float (float 5086923108014672 1.0d0) -107) + (scale-float (float -7256306947528657 1.0d0) -161) + (scale-float (float 8041674859768423 1.0d0) -219)) + (%make-qd-d (scale-float (float 8561217456919463 1.0d0) -53) + (scale-float (float 6298936787393783 1.0d0) -108) + (scale-float (float -4767967511894935 1.0d0) -162) + (scale-float (float -8847251687381265 1.0d0) -219)) + (%make-qd-d (scale-float (float 8552589520593170 1.0d0) -53) + (scale-float (float -4903095784208212 1.0d0) -109) + (scale-float (float -5993354562610200 1.0d0) -163) + (scale-float (float 7621932199733939 1.0d0) -218)) + (%make-qd-d (scale-float (float 8543881084037075 1.0d0) -53) + (scale-float (float 6707234576005423 1.0d0) -108) + (scale-float (float -6949817966021143 1.0d0) -163) + (scale-float (float 6010742482639225 1.0d0) -218)) + (%make-qd-d (scale-float (float 8535092229218300 1.0d0) -53) + (scale-float (float 7044972283821195 1.0d0) -107) + (scale-float (float -6484078963521046 1.0d0) -164) + (scale-float (float 4693487461781030 1.0d0) -219)) + (%make-qd-d (scale-float (float 8526223038860894 1.0d0) -53) + (scale-float (float 5688291050131270 1.0d0) -107) + (scale-float (float 5762907725758393 1.0d0) -162) + (scale-float (float 6954393126632499 1.0d0) -216)) + (%make-qd-d (scale-float (float 8517273596445054 1.0d0) -53) + (scale-float (float 7467026288494722 1.0d0) -107) + (scale-float (float -7311528458402789 1.0d0) -163) + (scale-float (float 6638440854815466 1.0d0) -218)) + (%make-qd-d (scale-float (float 8508243986206341 1.0d0) -53) + (scale-float (float 5718052318919608 1.0d0) -109) + (scale-float (float 6113951899379181 1.0d0) -163) + (scale-float (float -7053239345980276 1.0d0) -217)) + (%make-qd-d (scale-float (float 8499134293134885 1.0d0) -53) + (scale-float (float -7818667001173624 1.0d0) -108) + (scale-float (float 4809289711312272 1.0d0) -165) + (scale-float (float -7885188792416875 1.0d0) -221)) + (%make-qd-d (scale-float (float 8489944602974586 1.0d0) -53) + (scale-float (float 8590372695674546 1.0d0) -109) + (scale-float (float -5336072295288112 1.0d0) -166) + (scale-float (float 6731064684041358 1.0d0) -220)) + (%make-qd-d (scale-float (float 8480675002222309 1.0d0) -53) + (scale-float (float -4526446371562791 1.0d0) -107) + (scale-float (float 4756672316007874 1.0d0) -161) + (scale-float (float -8943278991556374 1.0d0) -220)) + (%make-qd-d (scale-float (float 8471325578127065 1.0d0) -53) + (scale-float (float 4642306313259215 1.0d0) -107) + (scale-float (float 8553146367577618 1.0d0) -161) + (scale-float (float -5655242195051814 1.0d0) -217)) + (%make-qd-d (scale-float (float 8461896418689196 1.0d0) -53) + (scale-float (float -4553181447976997 1.0d0) -109) + (scale-float (float -6593791908274853 1.0d0) -163) + (scale-float (float 7491525231836809 1.0d0) -217)) + (%make-qd-d (scale-float (float 8452387612659540 1.0d0) -53) + (scale-float (float 8801356132344547 1.0d0) -107) + (scale-float (float -5565388474422551 1.0d0) -161) + (scale-float (float -8228993466620115 1.0d0) -215)) + (%make-qd-d (scale-float (float 8442799249538603 1.0d0) -53) + (scale-float (float -5933972051875175 1.0d0) -107) + (scale-float (float -6958466561286986 1.0d0) -162) + (scale-float (float -4724344086362299 1.0d0) -218)) + (%make-qd-d (scale-float (float 8433131419575708 1.0d0) -53) + (scale-float (float -8446417134371795 1.0d0) -109) + (scale-float (float 6106723249054365 1.0d0) -163) + (scale-float (float -5724401613088084 1.0d0) -220)) + (%make-qd-d (scale-float (float 8423384213768154 1.0d0) -53) + (scale-float (float -5291176899619174 1.0d0) -107) + (scale-float (float -4782794227894570 1.0d0) -162) + (scale-float (float 5859801279367932 1.0d0) -216)) + (%make-qd-d (scale-float (float 8413557723860353 1.0d0) -53) + (scale-float (float 7246957581928310 1.0d0) -107) + (scale-float (float -7571526425190184 1.0d0) -161) + (scale-float (float 8583500343172088 1.0d0) -216)) + (%make-qd-d (scale-float (float 8403652042342972 1.0d0) -53) + (scale-float (float 6821609684893107 1.0d0) -107) + (scale-float (float 5278119422243711 1.0d0) -162) + (scale-float (float 5583656122229983 1.0d0) -216)) + (%make-qd-d (scale-float (float 8393667262452058 1.0d0) -53) + (scale-float (float -6617897839460155 1.0d0) -107) + (scale-float (float 5153678696029531 1.0d0) -161) + (scale-float (float 5429144206151925 1.0d0) -217)) + (%make-qd-d (scale-float (float 8383603478168160 1.0d0) -53) + (scale-float (float 6394240597984013 1.0d0) -108) + (scale-float (float 7676731287638925 1.0d0) -163) + (scale-float (float -6564864277848665 1.0d0) -221)) + (%make-qd-d (scale-float (float 8373460784215450 1.0d0) -53) + (scale-float (float 8321066234508797 1.0d0) -107) + (scale-float (float 5546630190255800 1.0d0) -164) + (scale-float (float -7258150702831279 1.0d0) -218)) + (%make-qd-d (scale-float (float 8363239276060827 1.0d0) -53) + (scale-float (float -7563437054268512 1.0d0) -108) + (scale-float (float -4548139565433169 1.0d0) -162) + (scale-float (float -6171043120140633 1.0d0) -216)) + (%make-qd-d (scale-float (float 8352939049913017 1.0d0) -53) + (scale-float (float -8981736255781014 1.0d0) -108) + (scale-float (float 5170276812693347 1.0d0) -164) + (scale-float (float 8572079675285324 1.0d0) -218)) + (%make-qd-d (scale-float (float 8342560202721672 1.0d0) -53) + (scale-float (float -6052880242154884 1.0d0) -107) + (scale-float (float 5981767719278909 1.0d0) -161) + (scale-float (float 7283292585326634 1.0d0) -215)) + (%make-qd-d (scale-float (float 8332102832176454 1.0d0) -53) + (scale-float (float 7857171491229206 1.0d0) -110) + (scale-float (float -8255170893553344 1.0d0) -166) + (scale-float (float 6162188545047406 1.0d0) -221)) + (%make-qd-d (scale-float (float 8321567036706118 1.0d0) -53) + (scale-float (float 5726145159043778 1.0d0) -108) + (scale-float (float -5897748070929945 1.0d0) -163) + (scale-float (float -8525804628143368 1.0d0) -217)) + (%make-qd-d (scale-float (float 8310952915477583 1.0d0) -53) + (scale-float (float 8593867710650143 1.0d0) -107) + (scale-float (float -6680313484611995 1.0d0) -163) + (scale-float (float 6353210804206738 1.0d0) -217)) + (%make-qd-d (scale-float (float 8300260568395001 1.0d0) -53) + (scale-float (float 6756450875854190 1.0d0) -107) + (scale-float (float 6951770272627742 1.0d0) -162) + (scale-float (float 8788284451425813 1.0d0) -218)) + (%make-qd-d (scale-float (float 8289490096098815 1.0d0) -53) + (scale-float (float -4511925664156885 1.0d0) -107) + (scale-float (float 7895328143001416 1.0d0) -161) + (scale-float (float 6317989146996191 1.0d0) -215)) + (%make-qd-d (scale-float (float 8278641599964811 1.0d0) -53) + (scale-float (float -8598600866676053 1.0d0) -108) + (scale-float (float 7646998035931427 1.0d0) -163) + (scale-float (float -6107518997826040 1.0d0) -217)) + (%make-qd-d (scale-float (float 8267715182103167 1.0d0) -53) + (scale-float (float -6340213041420117 1.0d0) -107) + (scale-float (float 6724262794318068 1.0d0) -161) + (scale-float (float 8393760923297867 1.0d0) -217)) + (%make-qd-d (scale-float (float 8256710945357489 1.0d0) -53) + (scale-float (float -6771725202789936 1.0d0) -107) + (scale-float (float 7070420353684526 1.0d0) -162) + (scale-float (float 5197890020650731 1.0d0) -216)) + (%make-qd-d (scale-float (float 8245628993303844 1.0d0) -53) + (scale-float (float -8821100121339757 1.0d0) -109) + (scale-float (float 7006208221552511 1.0d0) -163) + (scale-float (float 4508060286446889 1.0d0) -217)) + (%make-qd-d (scale-float (float 8234469430249786 1.0d0) -53) + (scale-float (float -5892637514160882 1.0d0) -107) + (scale-float (float -5681973386408990 1.0d0) -161) + (scale-float (float 5969243766468564 1.0d0) -217)) + (%make-qd-d (scale-float (float 8223232361233372 1.0d0) -53) + (scale-float (float -7777493634914173 1.0d0) -107) + (scale-float (float -5189369030967820 1.0d0) -161) + (scale-float (float 6842397883496982 1.0d0) -220)) + (%make-qd-d (scale-float (float 8211917892022175 1.0d0) -53) + (scale-float (float -8733856484976210 1.0d0) -108) + (scale-float (float -4857152382333282 1.0d0) -166) + (scale-float (float 7641915463494354 1.0d0) -222)) + (%make-qd-d (scale-float (float 8200526129112289 1.0d0) -53) + (scale-float (float -8183228870209481 1.0d0) -107) + (scale-float (float 6394798226217471 1.0d0) -162) + (scale-float (float 8035603526856955 1.0d0) -219)) + (%make-qd-d (scale-float (float 8189057179727324 1.0d0) -53) + (scale-float (float -4787111311971082 1.0d0) -110) + (scale-float (float 7003826926247311 1.0d0) -164) + (scale-float (float -5150051672214856 1.0d0) -218)) + (%make-qd-d (scale-float (float 8177511151817401 1.0d0) -53) + (scale-float (float -8025338039515614 1.0d0) -107) + (scale-float (float -4852092691112809 1.0d0) -161) + (scale-float (float -5468362093021944 1.0d0) -216)) + (%make-qd-d (scale-float (float 8165888154058130 1.0d0) -53) + (scale-float (float 4949998156142078 1.0d0) -107) + (scale-float (float -8464337333963361 1.0d0) -162) + (scale-float (float 7964294201530510 1.0d0) -218)) + (%make-qd-d (scale-float (float 8154188295849595 1.0d0) -53) + (scale-float (float -6677472217191581 1.0d0) -107) + (scale-float (float 8727903250458773 1.0d0) -161) + (scale-float (float 5386228110507442 1.0d0) -216)) + (%make-qd-d (scale-float (float 8142411687315315 1.0d0) -53) + (scale-float (float -8579951840942254 1.0d0) -110) + (scale-float (float 5952643804849413 1.0d0) -165) + (scale-float (float -7249883042029233 1.0d0) -220)) + (%make-qd-d (scale-float (float 8130558439301216 1.0d0) -53) + (scale-float (float -6247237565047575 1.0d0) -108) + (scale-float (float 7741357282149559 1.0d0) -162) + (scale-float (float -5578500633872854 1.0d0) -216)) + (%make-qd-d (scale-float (float 8118628663374582 1.0d0) -53) + (scale-float (float -8778090168280888 1.0d0) -109) + (scale-float (float 7436746217749520 1.0d0) -163) + (scale-float (float 7630381168256317 1.0d0) -217)) + (%make-qd-d (scale-float (float 8106622471823008 1.0d0) -53) + (scale-float (float -8216747803830756 1.0d0) -107) + (scale-float (float 6304056001984601 1.0d0) -162) + (scale-float (float 5924872968038470 1.0d0) -217)) + (%make-qd-d (scale-float (float 8094539977653340 1.0d0) -53) + (scale-float (float 8540324421498539 1.0d0) -108) + (scale-float (float 6922258608862064 1.0d0) -167) + (scale-float (float -7901865974785605 1.0d0) -221)) + (%make-qd-d (scale-float (float 8082381294590617 1.0d0) -53) + (scale-float (float -5905634609941531 1.0d0) -107) + (scale-float (float -6901692996464097 1.0d0) -161) + (scale-float (float 6233038068306105 1.0d0) -215)) + (%make-qd-d (scale-float (float 8070146537076992 1.0d0) -53) + (scale-float (float 7954777128849873 1.0d0) -107) + (scale-float (float -5682461538967622 1.0d0) -161) + (scale-float (float -8988660354400493 1.0d0) -215)) + (%make-qd-d (scale-float (float 8057835820270665 1.0d0) -53) + (scale-float (float -5684340455847933 1.0d0) -108) + (scale-float (float -7717120355166554 1.0d0) -162) + (scale-float (float -6720192119717512 1.0d0) -218)) + (%make-qd-d (scale-float (float 8045449260044789 1.0d0) -53) + (scale-float (float -5343034318546435 1.0d0) -110) + (scale-float (float 5934925198868450 1.0d0) -164) + (scale-float (float 7220118970499754 1.0d0) -220)) + (%make-qd-d (scale-float (float 8032986972986387 1.0d0) -53) + (scale-float (float 6060738122016655 1.0d0) -110) + (scale-float (float 7553159386729597 1.0d0) -165) + (scale-float (float -6675526920595727 1.0d0) -220)) + (%make-qd-d (scale-float (float 8020449076395251 1.0d0) -53) + (scale-float (float 7646910712788417 1.0d0) -109) + (scale-float (float -6241730781228944 1.0d0) -165) + (scale-float (float -8002249139712356 1.0d0) -219)) + (%make-qd-d (scale-float (float 8007835688282839 1.0d0) -53) + (scale-float (float -7246184498625959 1.0d0) -109) + (scale-float (float -8137088343486848 1.0d0) -164) + (scale-float (float -6573626944638042 1.0d0) -218)) + (%make-qd-d (scale-float (float 7995146927371163 1.0d0) -53) + (scale-float (float 8310979817766747 1.0d0) -109) + (scale-float (float 7473299446962253 1.0d0) -167) + (scale-float (float -4891403068085004 1.0d0) -221)) + (%make-qd-d (scale-float (float 7982382913091674 1.0d0) -53) + (scale-float (float -8736996093293672 1.0d0) -110) + (scale-float (float 5792500826087577 1.0d0) -165) + (scale-float (float 6862659397941285 1.0d0) -221)) + (%make-qd-d (scale-float (float 7969543765584135 1.0d0) -53) + (scale-float (float -6122462417693605 1.0d0) -109) + (scale-float (float -6676904309874182 1.0d0) -163) + (scale-float (float 7692066278000649 1.0d0) -218)) + (%make-qd-d (scale-float (float 7956629605695492 1.0d0) -53) + (scale-float (float 5134741344813474 1.0d0) -108) + (scale-float (float -4613745536456255 1.0d0) -162) + (scale-float (float -6227040409576694 1.0d0) -218)) + (%make-qd-d (scale-float (float 7943640554978737 1.0d0) -53) + (scale-float (float -6439502272564487 1.0d0) -108) + (scale-float (float -8232593592811641 1.0d0) -163) + (scale-float (float -8961461139920910 1.0d0) -219)) + (%make-qd-d (scale-float (float 7930576735691761 1.0d0) -53) + (scale-float (float 5293253478187253 1.0d0) -108) + (scale-float (float -6727743417874982 1.0d0) -163) + (scale-float (float -8452072153366346 1.0d0) -217)) + (%make-qd-d (scale-float (float 7917438270796208 1.0d0) -53) + (scale-float (float -7684086171775532 1.0d0) -107) + (scale-float (float 8411685124468258 1.0d0) -162) + (scale-float (float -6126132756509931 1.0d0) -217)) + (%make-qd-d (scale-float (float 7904225283956311 1.0d0) -53) + (scale-float (float 8131349739729868 1.0d0) -107) + (scale-float (float 6637034140521224 1.0d0) -164) + (scale-float (float 6550694306870995 1.0d0) -218)) + (%make-qd-d (scale-float (float 7890937899537737 1.0d0) -53) + (scale-float (float 7623463201024326 1.0d0) -110) + (scale-float (float 6533764524387989 1.0d0) -164) + (scale-float (float -7808305661254231 1.0d0) -218)) + (%make-qd-d (scale-float (float 7877576242606407 1.0d0) -53) + (scale-float (float -5941713289950576 1.0d0) -113) + (scale-float (float -5557131795313346 1.0d0) -167) + (scale-float (float 5890046981724174 1.0d0) -222)) + (%make-qd-d (scale-float (float 7864140438927325 1.0d0) -53) + (scale-float (float 5090052289978408 1.0d0) -109) + (scale-float (float -5692258429067560 1.0d0) -163) + (scale-float (float -4805520048585976 1.0d0) -217)) + (%make-qd-d (scale-float (float 7850630614963393 1.0d0) -53) + (scale-float (float -8968556689917822 1.0d0) -107) + (scale-float (float -6461032805259083 1.0d0) -161) + (scale-float (float -5147125785674736 1.0d0) -215)) + (%make-qd-d (scale-float (float 7837046897874218 1.0d0) -53) + (scale-float (float -6796799480983562 1.0d0) -107) + (scale-float (float 8289659017936051 1.0d0) -163) + (scale-float (float 7919537224500868 1.0d0) -217)) + (%make-qd-d (scale-float (float 7823389415514919 1.0d0) -53) + (scale-float (float 5647719797707326 1.0d0) -114) + (scale-float (float -6252005772837378 1.0d0) -168) + (scale-float (float -8509580097279105 1.0d0) -222)) + (%make-qd-d (scale-float (float 7809658296434922 1.0d0) -53) + (scale-float (float 7857985603043508 1.0d0) -111) + (scale-float (float -5406124386166429 1.0d0) -165) + (scale-float (float -7222644714405805 1.0d0) -223)) + (%make-qd-d (scale-float (float 7795853669876749 1.0d0) -53) + (scale-float (float -8271733057494906 1.0d0) -110) + (scale-float (float 5547981887481697 1.0d0) -164) + (scale-float (float 6702866336981504 1.0d0) -218)) + (%make-qd-d (scale-float (float 7781975665774802 1.0d0) -53) + (scale-float (float 6731546115920822 1.0d0) -107) + (scale-float (float 6638133694034468 1.0d0) -161) + (scale-float (float -8554347442337204 1.0d0) -216)) + (%make-qd-d (scale-float (float 7768024414754142 1.0d0) -53) + (scale-float (float 6005052363670948 1.0d0) -107) + (scale-float (float 6094860705689399 1.0d0) -163) + (scale-float (float 5675405789834798 1.0d0) -217)) + (%make-qd-d (scale-float (float 7754000048129257 1.0d0) -53) + (scale-float (float -4875899202965061 1.0d0) -107) + (scale-float (float -5185769273148547 1.0d0) -162) + (scale-float (float 6320978780778161 1.0d0) -218)) + (%make-qd-d (scale-float (float 7739902697902825 1.0d0) -53) + (scale-float (float 6885578824615594 1.0d0) -107) + (scale-float (float 8907187678671986 1.0d0) -163) + (scale-float (float -8339075431974752 1.0d0) -217)) + (%make-qd-d (scale-float (float 7725732496764478 1.0d0) -53) + (scale-float (float -7818211417288033 1.0d0) -107) + (scale-float (float -6456405933798609 1.0d0) -162) + (scale-float (float 8810079633059484 1.0d0) -216)) + (%make-qd-d (scale-float (float 7711489578089543 1.0d0) -53) + (scale-float (float 5958610143385566 1.0d0) -109) + (scale-float (float 6585953111264567 1.0d0) -163) + (scale-float (float 7861064189197966 1.0d0) -221)) + (%make-qd-d (scale-float (float 7697174075937797 1.0d0) -53) + (scale-float (float -8431721695184386 1.0d0) -109) + (scale-float (float 6029995679316329 1.0d0) -165) + (scale-float (float -4921123855682338 1.0d0) -223)) + (%make-qd-d (scale-float (float 7682786125052197 1.0d0) -53) + (scale-float (float 8811647176963032 1.0d0) -108) + (scale-float (float 8691431362536178 1.0d0) -163) + (scale-float (float 8880441644193018 1.0d0) -217)) + (%make-qd-d (scale-float (float 7668325860857618 1.0d0) -53) + (scale-float (float -8645153897161875 1.0d0) -107) + (scale-float (float 6512789306468078 1.0d0) -161) + (scale-float (float -8484355539904639 1.0d0) -217)) + (%make-qd-d (scale-float (float 7653793419459571 1.0d0) -53) + (scale-float (float 8407034062131169 1.0d0) -107) + (scale-float (float 9005956094764978 1.0d0) -161) + (scale-float (float -5461770985431486 1.0d0) -217)) + (%make-qd-d (scale-float (float 7639188937642932 1.0d0) -53) + (scale-float (float 6088799942438190 1.0d0) -108) + (scale-float (float 8212922076806082 1.0d0) -162) + (scale-float (float -5247758149286959 1.0d0) -217)) + (%make-qd-d (scale-float (float 7624512552870645 1.0d0) -53) + (scale-float (float -7783483392394296 1.0d0) -107) + (scale-float (float -8043598484014106 1.0d0) -161) + (scale-float (float -7742450129971733 1.0d0) -216)) + (%make-qd-d (scale-float (float 7609764403282432 1.0d0) -53) + (scale-float (float -7079592968846542 1.0d0) -107) + (scale-float (float -5935955209333083 1.0d0) -161) + (scale-float (float 4538668036895069 1.0d0) -216)) + (%make-qd-d (scale-float (float 7594944627693494 1.0d0) -53) + (scale-float (float 5012472405203384 1.0d0) -112) + (scale-float (float 8678696578736612 1.0d0) -171) + (scale-float (float 5214866625493772 1.0d0) -225)) + (%make-qd-d (scale-float (float 7580053365593204 1.0d0) -53) + (scale-float (float -5532305557551308 1.0d0) -107) + (scale-float (float -4918257505158720 1.0d0) -162) + (scale-float (float -5207406790673379 1.0d0) -216)) + (%make-qd-d (scale-float (float 7565090757143791 1.0d0) -53) + (scale-float (float -5410923347089996 1.0d0) -108) + (scale-float (float -8628228715534538 1.0d0) -162) + (scale-float (float -7982155484674416 1.0d0) -216)) + (%make-qd-d (scale-float (float 7550056943179025 1.0d0) -53) + (scale-float (float -5769953684661576 1.0d0) -107) + (scale-float (float 6833859811950236 1.0d0) -162) + (scale-float (float -6174180304901008 1.0d0) -216)) + (%make-qd-d (scale-float (float 7534952065202888 1.0d0) -53) + (scale-float (float -6782132408285718 1.0d0) -108) + (scale-float (float -4588137587016523 1.0d0) -165) + (scale-float (float -5326135934499720 1.0d0) -220)) + (%make-qd-d (scale-float (float 7519776265388244 1.0d0) -53) + (scale-float (float 7471785049762459 1.0d0) -107) + (scale-float (float -6059669116863189 1.0d0) -163) + (scale-float (float -5940063433657282 1.0d0) -219)) + (%make-qd-d (scale-float (float 7504529686575502 1.0d0) -53) + (scale-float (float 6892841323703210 1.0d0) -112) + (scale-float (float 4544841146313886 1.0d0) -166) + (scale-float (float 7653639258512367 1.0d0) -220)) + (%make-qd-d (scale-float (float 7489212472271267 1.0d0) -53) + (scale-float (float 7307564340927176 1.0d0) -112) + (scale-float (float 8783286311491533 1.0d0) -167) + (scale-float (float -5455043666319984 1.0d0) -224)) + (%make-qd-d (scale-float (float 7473824766646994 1.0d0) -53) + (scale-float (float -7619464420816061 1.0d0) -111) + (scale-float (float 5376884603206074 1.0d0) -165) + (scale-float (float 5928941415547088 1.0d0) -220)) + (%make-qd-d (scale-float (float 7458366714537629 1.0d0) -53) + (scale-float (float -7171307255144825 1.0d0) -107) + (scale-float (float 8175016055708132 1.0d0) -161) + (scale-float (float 5281820716761617 1.0d0) -215)) + (%make-qd-d (scale-float (float 7442838461440245 1.0d0) -53) + (scale-float (float -8755102569226029 1.0d0) -107) + (scale-float (float 8064787730576089 1.0d0) -163) + (scale-float (float 8026094972828839 1.0d0) -217)) + (%make-qd-d (scale-float (float 7427240153512674 1.0d0) -53) + (scale-float (float -8603752879918352 1.0d0) -108) + (scale-float (float 7911734751209565 1.0d0) -165) + (scale-float (float 5703206095815899 1.0d0) -219)) + (%make-qd-d (scale-float (float 7411571937572131 1.0d0) -53) + (scale-float (float 4930416562782670 1.0d0) -108) + (scale-float (float 5664227737707146 1.0d0) -162) + (scale-float (float 6002228034137708 1.0d0) -216)) + (%make-qd-d (scale-float (float 7395833961093832 1.0d0) -53) + (scale-float (float 4983815042703658 1.0d0) -107) + (scale-float (float -4979969880744113 1.0d0) -161) + (scale-float (float -5871087828457004 1.0d0) -215)) + (%make-qd-d (scale-float (float 7380026372209606 1.0d0) -53) + (scale-float (float -7821016727474824 1.0d0) -107) + (scale-float (float -5827108382516599 1.0d0) -168) + (scale-float (float -5157322064549901 1.0d0) -225)) + (%make-qd-d (scale-float (float 7364149319706498 1.0d0) -53) + (scale-float (float -4829858251010421 1.0d0) -108) + (scale-float (float -4575860067979415 1.0d0) -162) + (scale-float (float 8705566695469741 1.0d0) -217)) + (%make-qd-d (scale-float (float 7348202953025374 1.0d0) -53) + (scale-float (float 5364466528429990 1.0d0) -109) + (scale-float (float -5385055512047183 1.0d0) -164) + (scale-float (float 6361734986933710 1.0d0) -218)) + (%make-qd-d (scale-float (float 7332187422259511 1.0d0) -53) + (scale-float (float -8458146418590874 1.0d0) -107) + (scale-float (float -5567640357155716 1.0d0) -161) + (scale-float (float -8918513373518274 1.0d0) -215)) + (%make-qd-d (scale-float (float 7316102878153182 1.0d0) -53) + (scale-float (float 5038888112811017 1.0d0) -107) + (scale-float (float 5296374816773052 1.0d0) -164) + (scale-float (float -6253164519860774 1.0d0) -219)) + (%make-qd-d (scale-float (float 7299949472100244 1.0d0) -53) + (scale-float (float 7632795593885122 1.0d0) -108) + (scale-float (float -4532413022792557 1.0d0) -162) + (scale-float (float -7665957245126532 1.0d0) -216)) + (%make-qd-d (scale-float (float 7283727356142706 1.0d0) -53) + (scale-float (float 6052374734052898 1.0d0) -109) + (scale-float (float -8397589869895301 1.0d0) -163) + (scale-float (float 5039286009373352 1.0d0) -217)) + (%make-qd-d (scale-float (float 7267436682969301 1.0d0) -53) + (scale-float (float 7986499572183919 1.0d0) -107) + (scale-float (float 8709385497029640 1.0d0) -161) + (scale-float (float 8014662541064248 1.0d0) -215)) + (%make-qd-d (scale-float (float 7251077605914050 1.0d0) -53) + (scale-float (float 8334981517291728 1.0d0) -107) + (scale-float (float 7375650104466233 1.0d0) -163) + (scale-float (float 6173629469842000 1.0d0) -219)) + (%make-qd-d (scale-float (float 7234650278954817 1.0d0) -53) + (scale-float (float -5364390638462068 1.0d0) -107) + (scale-float (float -7157105785322597 1.0d0) -162) + (scale-float (float 5984618093282123 1.0d0) -217)) + (%make-qd-d (scale-float (float 7218154856711858 1.0d0) -53) + (scale-float (float -6801264200501575 1.0d0) -108) + (scale-float (float -5120886861157727 1.0d0) -163) + (scale-float (float 8524267759255856 1.0d0) -218)) + (%make-qd-d (scale-float (float 7201591494446370 1.0d0) -53) + (scale-float (float 6606134571941243 1.0d0) -108) + (scale-float (float -5696846492939078 1.0d0) -162) + (scale-float (float 7226358878672853 1.0d0) -223)) + (%make-qd-d (scale-float (float 7184960348059028 1.0d0) -53) + (scale-float (float -7582499304585468 1.0d0) -107) + (scale-float (float 6745092272239030 1.0d0) -161) + (scale-float (float 5325527634933226 1.0d0) -220)) + (%make-qd-d (scale-float (float 7168261574088514 1.0d0) -53) + (scale-float (float -4877955993986654 1.0d0) -107) + (scale-float (float -6575649792954184 1.0d0) -161) + (scale-float (float -6938160611470782 1.0d0) -216)) + (%make-qd-d (scale-float (float 7151495329710049 1.0d0) -53) + (scale-float (float -4815506917589854 1.0d0) -109) + (scale-float (float 5641242290599654 1.0d0) -164) + (scale-float (float -8417705599718850 1.0d0) -220)) + (%make-qd-d (scale-float (float 7134661772733911 1.0d0) -53) + (scale-float (float -6017847752979687 1.0d0) -107) + (scale-float (float -8695617460185062 1.0d0) -162) + (scale-float (float 6176165148681625 1.0d0) -217)) + (%make-qd-d (scale-float (float 7117761061603948 1.0d0) -53) + (scale-float (float 7482393772340198 1.0d0) -108) + (scale-float (float 8465649163872175 1.0d0) -162) + (scale-float (float -8080110543307406 1.0d0) -216)) + (%make-qd-d (scale-float (float 7100793355396091 1.0d0) -53) + (scale-float (float 5581231234277131 1.0d0) -107) + (scale-float (float 5176821120801589 1.0d0) -161) + (scale-float (float 8995859729422842 1.0d0) -215)) + (%make-qd-d (scale-float (float 7083758813816853 1.0d0) -53) + (scale-float (float -6350271866355127 1.0d0) -109) + (scale-float (float 7928602718099880 1.0d0) -164) + (scale-float (float 4824946278411294 1.0d0) -219)) + (%make-qd-d (scale-float (float 7066657597201826 1.0d0) -53) + (scale-float (float -5557572698368406 1.0d0) -109) + (scale-float (float -4935627699312564 1.0d0) -164) + (scale-float (float -7115034144224561 1.0d0) -218)) + (%make-qd-d (scale-float (float 7049489866514174 1.0d0) -53) + (scale-float (float 5889743500293894 1.0d0) -109) + (scale-float (float 7906589096317472 1.0d0) -163) + (scale-float (float -7234212083698060 1.0d0) -218)) + (%make-qd-d (scale-float (float 7032255783343117 1.0d0) -53) + (scale-float (float -6438369056191217 1.0d0) -109) + (scale-float (float -6365182518869508 1.0d0) -171) + (scale-float (float 5309542037636005 1.0d0) -230)) + (%make-qd-d (scale-float (float 7014955509902409 1.0d0) -53) + (scale-float (float -8077716446967319 1.0d0) -108) + (scale-float (float 6329167020324237 1.0d0) -166) + (scale-float (float -8791449117706018 1.0d0) -223)) + (%make-qd-d (scale-float (float 6997589209028812 1.0d0) -53) + (scale-float (float 5024754586498263 1.0d0) -109) + (scale-float (float -7013631527035059 1.0d0) -163) + (scale-float (float 6438066485620793 1.0d0) -217)) + (%make-qd-d (scale-float (float 6980157044180565 1.0d0) -53) + (scale-float (float -8471408082297477 1.0d0) -107) + (scale-float (float -5650375399951533 1.0d0) -162) + (scale-float (float 7798954431786796 1.0d0) -217)) + (%make-qd-d (scale-float (float 6962659179435841 1.0d0) -53) + (scale-float (float -5284120524567405 1.0d0) -107) + (scale-float (float 8103036997132110 1.0d0) -162) + (scale-float (float -8418944709321890 1.0d0) -217)) + (%make-qd-d (scale-float (float 6945095779491208 1.0d0) -53) + (scale-float (float -7230020631985237 1.0d0) -107) + (scale-float (float -8729130008304460 1.0d0) -161) + (scale-float (float -7244986705962520 1.0d0) -216)) + (%make-qd-d (scale-float (float 6927467009660074 1.0d0) -53) + (scale-float (float 8363890541356943 1.0d0) -107) + (scale-float (float 7641557639387694 1.0d0) -161) + (scale-float (float -8529781507802362 1.0d0) -215)) + (%make-qd-d (scale-float (float 6909773035871137 1.0d0) -53) + (scale-float (float -6128826147983157 1.0d0) -108) + (scale-float (float -7985270411148689 1.0d0) -162) + (scale-float (float -4747232722969418 1.0d0) -217)) + (%make-qd-d (scale-float (float 6892014024666815 1.0d0) -53) + (scale-float (float -5307050774979789 1.0d0) -107) + (scale-float (float 6534150355198809 1.0d0) -162) + (scale-float (float -7794201099075978 1.0d0) -217)) + (%make-qd-d (scale-float (float 6874190143201685 1.0d0) -53) + (scale-float (float 6831699276871462 1.0d0) -111) + (scale-float (float 6569994269441010 1.0d0) -165) + (scale-float (float 6039155211825079 1.0d0) -222)) + (%make-qd-d (scale-float (float 6856301559240908 1.0d0) -53) + (scale-float (float 5730269256517324 1.0d0) -107) + (scale-float (float 7502511311955837 1.0d0) -162) + (scale-float (float -8934221579630434 1.0d0) -216)) + (%make-qd-d (scale-float (float 6838348441158650 1.0d0) -53) + (scale-float (float -6256529846772154 1.0d0) -107) + (scale-float (float 6949788990055632 1.0d0) -164) + (scale-float (float -5274624651616658 1.0d0) -218)) + (%make-qd-d (scale-float (float 6820330957936494 1.0d0) -53) + (scale-float (float -6460871939863669 1.0d0) -108) + (scale-float (float 4607738561562238 1.0d0) -163) + (scale-float (float 8738499798315367 1.0d0) -218)) + (%make-qd-d (scale-float (float 6802249279161855 1.0d0) -53) + (scale-float (float -6296386214088169 1.0d0) -108) + (scale-float (float -8828921206139670 1.0d0) -164) + (scale-float (float -8935639395611922 1.0d0) -218)) + (%make-qd-d (scale-float (float 6784103575026380 1.0d0) -53) + (scale-float (float -6155758343732070 1.0d0) -107) + (scale-float (float -7834764184816714 1.0d0) -163) + (scale-float (float -5655570170200821 1.0d0) -219)) + (%make-qd-d (scale-float (float 6765894016324346 1.0d0) -53) + (scale-float (float 7058239787845383 1.0d0) -107) + (scale-float (float 7374070516477953 1.0d0) -161) + (scale-float (float -6947421257903780 1.0d0) -216)) + (%make-qd-d (scale-float (float 6747620774451057 1.0d0) -53) + (scale-float (float -7257707922049303 1.0d0) -107) + (scale-float (float -7075429107224891 1.0d0) -161) + (scale-float (float 5969459465011328 1.0d0) -215)) + (%make-qd-d (scale-float (float 6729284021401222 1.0d0) -53) + (scale-float (float 7707201987390816 1.0d0) -109) + (scale-float (float 5142737538491299 1.0d0) -164) + (scale-float (float 4644279882924390 1.0d0) -218)) + (%make-qd-d (scale-float (float 6710883929767346 1.0d0) -53) + (scale-float (float 4893313667710853 1.0d0) -108) + (scale-float (float 4729360090805088 1.0d0) -162) + (scale-float (float 8707005308054696 1.0d0) -216)) + (%make-qd-d (scale-float (float 6692420672738099 1.0d0) -53) + (scale-float (float -8159898852694060 1.0d0) -108) + (scale-float (float 8316410770739968 1.0d0) -163) + (scale-float (float 6356993048951430 1.0d0) -217)) + (%make-qd-d (scale-float (float 6673894424096687 1.0d0) -53) + (scale-float (float -4773219099675351 1.0d0) -108) + (scale-float (float -5793443213505971 1.0d0) -163) + (scale-float (float 6620801067481707 1.0d0) -217)) + (%make-qd-d (scale-float (float 6655305358219218 1.0d0) -53) + (scale-float (float 5569529363635887 1.0d0) -107) + (scale-float (float -8012910396303650 1.0d0) -162) + (scale-float (float -5648248265418359 1.0d0) -220)) + (%make-qd-d (scale-float (float 6636653650073061 1.0d0) -53) + (scale-float (float -4694561351059034 1.0d0) -107) + (scale-float (float -8102538682924120 1.0d0) -164) + (scale-float (float -7786569469548835 1.0d0) -218)) + (%make-qd-d (scale-float (float 6617939475215195 1.0d0) -53) + (scale-float (float -5599177568223260 1.0d0) -107) + (scale-float (float -6932779364632684 1.0d0) -161) + (scale-float (float -8360972497909144 1.0d0) -217)) + (%make-qd-d (scale-float (float 6599163009790561 1.0d0) -53) + (scale-float (float 6139460555376271 1.0d0) -108) + (scale-float (float -8841336350505836 1.0d0) -162) + (scale-float (float -8249924986768898 1.0d0) -219)) + (%make-qd-d (scale-float (float 6580324430530404 1.0d0) -53) + (scale-float (float -4817471423188767 1.0d0) -107) + (scale-float (float -6592466314970465 1.0d0) -162) + (scale-float (float -6430688881172527 1.0d0) -217)) + (%make-qd-d (scale-float (float 6561423914750605 1.0d0) -53) + (scale-float (float 4953302629983138 1.0d0) -115) + (scale-float (float 8830091491978098 1.0d0) -170) + (scale-float (float 6566412636432061 1.0d0) -225)) + (%make-qd-d (scale-float (float 6542461640350018 1.0d0) -53) + (scale-float (float -5178910864670558 1.0d0) -107) + (scale-float (float 4504226005724943 1.0d0) -162) + (scale-float (float 8731627485611706 1.0d0) -217)) + (%make-qd-d (scale-float (float 6523437785808790 1.0d0) -53) + (scale-float (float 4737722843238748 1.0d0) -107) + (scale-float (float 6730894629032702 1.0d0) -161) + (scale-float (float -8714007801572383 1.0d0) -222)) + (%make-qd-d (scale-float (float 6504352530186687 1.0d0) -53) + (scale-float (float -7746667435587544 1.0d0) -108) + (scale-float (float 6217885893994028 1.0d0) -162) + (scale-float (float -4696784861307301 1.0d0) -216)) + (%make-qd-d (scale-float (float 6485206053121402 1.0d0) -53) + (scale-float (float -8336770935428512 1.0d0) -108) + (scale-float (float -5348661455957571 1.0d0) -162) + (scale-float (float 4676263914929793 1.0d0) -216)) + (%make-qd-d (scale-float (float 6465998534826869 1.0d0) -53) + (scale-float (float 8764102551217140 1.0d0) -108) + (scale-float (float -5344409034097828 1.0d0) -164) + (scale-float (float 7727976365078167 1.0d0) -219)) + (%make-qd-d (scale-float (float 6446730156091567 1.0d0) -53) + (scale-float (float -8369498756096622 1.0d0) -107) + (scale-float (float -6424186581703649 1.0d0) -165) + (scale-float (float 7285509676227856 1.0d0) -219)) + (%make-qd-d (scale-float (float 6427401098276813 1.0d0) -53) + (scale-float (float -6870464143590238 1.0d0) -107) + (scale-float (float -4991363196461545 1.0d0) -163) + (scale-float (float -5550457137190991 1.0d0) -217)) + (%make-qd-d (scale-float (float 6408011543315061 1.0d0) -53) + (scale-float (float 5169145614950999 1.0d0) -109) + (scale-float (float 6895537652308040 1.0d0) -164) + (scale-float (float 7155016695131698 1.0d0) -218)) + (%make-qd-d (scale-float (float 6388561673708188 1.0d0) -53) + (scale-float (float -6100520299916709 1.0d0) -107) + (scale-float (float 4963552307172142 1.0d0) -165) + (scale-float (float 7537451794849143 1.0d0) -219)) + (%make-qd-d (scale-float (float 6369051672525773 1.0d0) -53) + (scale-float (float -7843040109683798 1.0d0) -107) + (scale-float (float 6048680740045173 1.0d0) -161) + (scale-float (float 5197737643093849 1.0d0) -217)))) + "A table of cos(k/1024) for k = 1 to 256") + + +#|| +;; Here is a function for clisp that can be used to create the atan2 table +;; that we need. + +(defun make-atan-table-data () + (let ((scale 1l0)) + (dotimes (k 67) + (let* ((x (scale-float 1L0 (- 2 k))) + (p (atan x))) + (setf scale (* scale (cos p))) + (multiple-value-bind (int exp sign) + (integer-decode-float p) + (let* ((len (integer-length int)) + (wanted (ldb (byte 212 (- len 212)) int)) + (bit (ldb (byte 1 (- len (* 4 53) 1)) int)) + (roundp (not (zerop (ldb (byte (- len (* 4 53) 2) 0) int))))) + ;;(format t "~&~v,'0b~%" len int) + ;;(format t "~b~a~%" wanted (make-string (- len 212) :initial-element #\-)) + ;;(format t "~v,'-b~%" len (ash bit (- len 212 1))) + ;;(format t "~v,'-b~%" len (ldb (byte (- len (* 4 53) 2) 0) int)) + ;; See if we need to round up the answer. + (when (= bit 1) + ;; Round to even + (cond (roundp + (incf wanted)) + (t + ;; Round to even + (when (oddp wanted) + (incf wanted))))) + ;;(format t "~b~a~%" wanted (make-string (- len 212) :initial-element #\-)) + + (let* ((i0 (ldb (byte 53 (* 3 53)) wanted)) + (i1 (ldb (byte 53 (* 2 53)) wanted)) + (i2 (ldb (byte 53 (* 1 53)) wanted)) + (i3 (ldb (byte 53 0) wanted))) + (write `(make-qd-d + (scale-float (float ,i0 1d0) ,(+ exp (- len (* 1 53)))) + (scale-float (float ,i1 1d0) ,(+ exp (- len (* 2 53)))) + (scale-float (float ,i2 1d0) ,(+ exp (- len (* 3 53)))) + (scale-float (float ,i3 1d0) ,(+ exp (- len (* 4 53))))) + :case :downcase)))))) + scale)) +||# + + +#+nil +(defconstant +atan-table+ + (make-array 66 + :initial-contents + (list + +qd-pi/4+ + +qd-pi/4+ + +qd-pi/4+ + ;; Do we need to make these values more accurate? (The + ;; reader has quite a bit of roundoff.) + #.(qd-from-string "0.46364760900080611621425623146121440202853705428612026381093308872018q0") + #.(qd-from-string "0.24497866312686415417208248121127581091414409838118406712737591466738q0") + #.(qd-from-string "0.12435499454676143503135484916387102557317019176980408991511411911572q0") + #.(qd-from-string "0.062418809995957348473979112985505113606273887797499194607527816898697q0") + #.(qd-from-string "0.031239833430268276253711744892490977032495663725400040255315586255793q0") + #.(qd-from-string "0.0156237286204768308028015212565703189111141398009054178814105073966645q0") + #.(qd-from-string "0.0078123410601011112964633918421992816212228117250147235574539022483893q0") + #.(qd-from-string "0.003906230131966971827628665311424387140357490115202856215213095149011q0") + #.(qd-from-string "0.00195312251647881868512148262507671393161074677723351033905753396043094q0") + #.(qd-from-string "9.7656218955931943040343019971729085163419701581008759004900725226773q-4") + #.(qd-from-string "4.8828121119489827546923962564484866619236113313500303710940335348752q-4") + #.(qd-from-string "2.4414062014936176401672294325965998621241779097061761180790046091019q-4") + #.(qd-from-string "1.22070311893670204239058646117956300930829409015787498451939837846645q-4") + #.(qd-from-string "6.1035156174208775021662569173829153785143536833346179337671134316588q-5") + #.(qd-from-string "3.0517578115526096861825953438536019750949675119437837531021156883611q-5") + #.(qd-from-string "1.5258789061315762107231935812697885137429238144575874846241186407446q-5") + #.(qd-from-string "7.6293945311019702633884823401050905863507439184680771577638306965336q-6") + #.(qd-from-string "3.8146972656064962829230756163729937228052573039688663101874392503939q-6") + #.(qd-from-string "1.9073486328101870353653693059172441687143421654501533666700577234671q-6") + #.(qd-from-string "9.53674316405960879420670689923112390019634124498790160133611802076q-7") + #.(qd-from-string "4.7683715820308885992758382144924707587049404378664196740053215887142q-7") + #.(qd-from-string "2.3841857910155798249094797721893269783096898769063155913766911372218q-7") + #.(qd-from-string "1.19209289550780685311368497137922112645967587664586735576738225215437q-7") + #.(qd-from-string "5.9604644775390554413921062141788874250030195782366297314294565710003q-8") + #.(qd-from-string "2.9802322387695303676740132767709503349043907067445107249258477840843q-8") + #.(qd-from-string "1.4901161193847655147092516595963247108248930025964720012170057805491q-8") + #.(qd-from-string "7.4505805969238279871365645744953921132066925545665870075947601416172q-9") + #.(qd-from-string "3.725290298461914045267070571811923583671948328737040524231998269239q-9") + #.(qd-from-string "1.8626451492309570290958838214764904345065282835738863513491050124951q-9") + #.(qd-from-string "9.3132257461547851535573547768456130389292649614929067394376854242196q-10") + #.(qd-from-string "4.6566128730773925777884193471057016297347863891561617421323492554414q-10") + #.(qd-from-string "2.32830643653869628902042741838821270371274293204981860525486662280605q-10") + #.(qd-from-string "1.16415321826934814452599092729852658796396457380014290026584979170883q-10") + #.(qd-from-string "5.8207660913467407226496761591231582349549156257795272423976206167147q-11") + #.(qd-from-string "2.9103830456733703613273032698903947793693632003639830495829934525029q-11") + #.(qd-from-string "1.4551915228366851806639597837362993474211703608936710732067270213307q-11") + #.(qd-from-string "7.2759576141834259033201841046703741842764629388821429640111752890838q-12") + #.(qd-from-string "3.6379788070917129516601402005837967730345578669779258118296083646486q-12") + #.(qd-from-string "1.81898940354585647583007611882297459662931973336029253714520765350336q-12") + #.(qd-from-string "9.094947017729282379150388117278718245786649666696631862264792881855q-13") + #.(qd-from-string "4.5474735088646411895751949990348397807233312083369623012466392138249q-13") + #.(qd-from-string "2.2737367544323205947875976170668549725904164010421166413578155299654q-13") + #.(qd-from-string "1.1368683772161602973937988232271068715738020501302644662229139921281q-13") + #.(qd-from-string "5.6843418860808014869689941345026335894672525626628305471702634435609q-14") + #.(qd-from-string "2.8421709430404007434844970695472041986834065703328538172835210852389q-14") + #.(qd-from-string "1.42108547152020037174224853506058802483542582129160672712566632799217q-14") + #.(qd-from-string "7.1054273576010018587112426756616725310442822766145084088962160950957q-15") + #.(qd-from-string "3.5527136788005009293556213378756778163805352845768135511116874239215q-15") + #.(qd-from-string "1.7763568394002504646778106689434441020475669105721016938889503158663q-15") + #.(qd-from-string "8.881784197001252323389053344724227002559458638215127117361184578544q-16") + #.(qd-from-string "4.440892098500626161694526672362989312819932329776890889670147968684q-16") + #.(qd-from-string "2.22044604925031308084726333618160413285249154122211136120876849284695q-16") + #.(qd-from-string "1.11022302462515654042363166809081575098156144265276392015109606150467q-16") + #.(qd-from-string "5.5511151231257827021181583404540958606019518033159549001888700768492q-17") + #.(qd-from-string "2.7755575615628913510590791702270500685127439754144943625236087596052q-17") + #.(qd-from-string "1.3877787807814456755295395851135253015328429969268117953154510949506q-17") + #.(qd-from-string "6.9388939039072283776476979255676268417598037461585147441443138686883q-18") + #.(qd-from-string "3.4694469519536141888238489627838134626418504682698143430180392335861q-18") + #.(qd-from-string "1.7347234759768070944119244813919067365411688085337267928772549041983q-18") + #.(qd-from-string "8.673617379884035472059622406959533689231148510667158491096568630248q-19") + #.(qd-from-string "4.336808689942017736029811203479766845431237313833394811387071078781q-19") + #.(qd-from-string "2.16840434497100886801490560173988342281757653922917435142338388484765q-19") + #.(qd-from-string "1.08420217248550443400745280086994171142153300490364679392792298560597q-19") + + )) + "Table of atan(2^(-k)) for k = 1 to 64. But the first three entries are 1") + +(defconstant +atan-table+ + (make-array 67 + :initial-contents + (list + (%make-qd-d (scale-float (float 5970951936056572 1.0d0) -52) + (scale-float (float 5427585433121543 1.0d0) -105) + (scale-float (float 5608515294538868 1.0d0) -158) + (scale-float (float 445395631680583 1.0d0) -211)) + (%make-qd-d (scale-float (float 4986154552901188 1.0d0) -52) + (scale-float (float 3814906810089799 1.0d0) -105) + (scale-float (float 1896417689773139 1.0d0) -158) + (scale-float (float 3393132800284032 1.0d0) -211)) + (%make-qd-d (scale-float (float 7074237752028440 1.0d0) -53) + (scale-float (float 2483878800010755 1.0d0) -106) + (scale-float (float 3956492004828932 1.0d0) -159) + (scale-float (float 2434854662709436 1.0d0) -212)) + (%make-qd-d (scale-float (float 8352332796509007 1.0d0) -54) + (scale-float (float 3683087214424816 1.0d0) -107) + (scale-float (float 8240297260223171 1.0d0) -160) + (scale-float (float 5174086704442609 1.0d0) -213)) + (%make-qd-d (scale-float (float 8826286527774941 1.0d0) -55) + (scale-float (float 3471944699336670 1.0d0) -108) + (scale-float (float 4798212191802497 1.0d0) -161) + (scale-float (float 6908472993489831 1.0d0) -214)) + (%make-qd-d (scale-float (float 8960721713639277 1.0d0) -56) + (scale-float (float 6978747913895162 1.0d0) -109) + (scale-float (float 1204496828771308 1.0d0) -162) + (scale-float (float 6150314016033077 1.0d0) -215)) + (%make-qd-d (scale-float (float 8995498542038505 1.0d0) -57) + (scale-float (float 6996384121843768 1.0d0) -110) + (scale-float (float 6481245652257127 1.0d0) -163) + (scale-float (float 6083920726820778 1.0d0) -216)) + (%make-qd-d (scale-float (float 9004268940523044 1.0d0) -58) + (scale-float (float 5921825575778154 1.0d0) -111) + (scale-float (float 1742767809528138 1.0d0) -164) + (scale-float (float 3392785816514584 1.0d0) -217)) + (%make-qd-d (scale-float (float 9006466354344602 1.0d0) -59) + (scale-float (float 6455912199422039 1.0d0) -112) + (scale-float (float 7793493312778976 1.0d0) -165) + (scale-float (float 4748718880757240 1.0d0) -218)) + (%make-qd-d (scale-float (float 9007016009513623 1.0d0) -60) + (scale-float (float 1583402193514233 1.0d0) -113) + (scale-float (float 4599960241393675 1.0d0) -166) + (scale-float (float 4964226307734805 1.0d0) -219)) + (%make-qd-d (scale-float (float 9007153442175927 1.0d0) -61) + (scale-float (float 1458797116501429 1.0d0) -114) + (scale-float (float 2180379843517813 1.0d0) -167) + (scale-float (float 7244224576758923 1.0d0) -220)) + (%make-qd-d (scale-float (float 9007187801521083 1.0d0) -62) + (scale-float (float 5961909987006481 1.0d0) -115) + (scale-float (float 1439161705865198 1.0d0) -168) + (scale-float (float 1250151122136839 1.0d0) -221)) + (%make-qd-d (scale-float (float 9007196391431099 1.0d0) -63) + (scale-float (float 6595226783193595 1.0d0) -116) + (scale-float (float 7270788700276565 1.0d0) -169) + (scale-float (float 5212528258452836 1.0d0) -222)) + (%make-qd-d (scale-float (float 9007198538913211 1.0d0) -64) + (scale-float (float 6605122380416172 1.0d0) -117) + (scale-float (float 2579496809882929 1.0d0) -170) + (scale-float (float 2545695100421145 1.0d0) -223)) + (%make-qd-d (scale-float (float 9007199075784027 1.0d0) -65) + (scale-float (float 6605276999209814 1.0d0) -118) + (scale-float (float 8635423593413256 1.0d0) -171) + (scale-float (float 6747877897971029 1.0d0) -224)) + (%make-qd-d (scale-float (float 9007199210001749 1.0d0) -66) + (scale-float (float 6605279415128805 1.0d0) -119) + (scale-float (float 5633073770825222 1.0d0) -172) + (scale-float (float 744251135568860 1.0d0) -225)) + (%make-qd-d (scale-float (float 9007199243556181 1.0d0) -67) + (scale-float (float 3227579732349669 1.0d0) -120) + (scale-float (float 1645511649516378 1.0d0) -173) + (scale-float (float 7212311609477561 1.0d0) -226)) + (%make-qd-d (scale-float (float 9007199251944789 1.0d0) -68) + (scale-float (float 3016473500406501 1.0d0) -121) + (scale-float (float 1629935234837168 1.0d0) -174) + (scale-float (float 1206159191623029 1.0d0) -227)) + (%make-qd-d (scale-float (float 9007199254041941 1.0d0) -69) + (scale-float (float 3003279360882405 1.0d0) -122) + (scale-float (float 1629874389467187 1.0d0) -175) + (scale-float (float 8712158240272416 1.0d0) -228)) + (%make-qd-d (scale-float (float 9007199254566229 1.0d0) -70) + (scale-float (float 3002454727161717 1.0d0) -123) + (scale-float (float 1629874151789961 1.0d0) -176) + (scale-float (float 3116377062563786 1.0d0) -229)) + (%make-qd-d (scale-float (float 9007199254697301 1.0d0) -71) + (scale-float (float 3002403187554167 1.0d0) -124) + (scale-float (float 3881673964546782 1.0d0) -177) + (scale-float (float 6119176246102625 1.0d0) -230)) + (%make-qd-d (scale-float (float 9007199254730069 1.0d0) -72) + (scale-float (float 3002399966328695 1.0d0) -125) + (scale-float (float 4198333313342644 1.0d0) -178) + (scale-float (float 114377133012236 1.0d0) -231)) + (%make-qd-d (scale-float (float 9007199254738261 1.0d0) -73) + (scale-float (float 3002399765002103 1.0d0) -126) + (scale-float (float 4203281115667621 1.0d0) -179) + (scale-float (float 7620376512343991 1.0d0) -232)) + (%make-qd-d (scale-float (float 9007199254740309 1.0d0) -74) + (scale-float (float 3002399752419191 1.0d0) -127) + (scale-float (float 4203358425078949 1.0d0) -180) + (scale-float (float 7121931241085909 1.0d0) -233)) + (%make-qd-d (scale-float (float 9007199254740821 1.0d0) -75) + (scale-float (float 3002399751632759 1.0d0) -128) + (scale-float (float 4203359633038501 1.0d0) -181) + (scale-float (float 7119984189245056 1.0d0) -234)) + (%make-qd-d (scale-float (float 9007199254740949 1.0d0) -76) + (scale-float (float 3002399751583607 1.0d0) -129) + (scale-float (float 4203359651912869 1.0d0) -182) + (scale-float (float 7119976583573803 1.0d0) -235)) + (%make-qd-d (scale-float (float 9007199254740981 1.0d0) -77) + (scale-float (float 3002399751580535 1.0d0) -130) + (scale-float (float 4203359652207781 1.0d0) -183) + (scale-float (float 7119976553864150 1.0d0) -236)) + (%make-qd-d (scale-float (float 9007199254740989 1.0d0) -78) + (scale-float (float 3002399751580343 1.0d0) -131) + (scale-float (float 4203359652212389 1.0d0) -184) + (scale-float (float 7119976553748096 1.0d0) -237)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -79) + (scale-float (float 3002399751580331 1.0d0) -132) + (scale-float (float 4203359652212461 1.0d0) -185) + (scale-float (float 7119976553747643 1.0d0) -238)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -80) + (scale-float (float 7505999378950826 1.0d0) -133) + (scale-float (float 6455159465897710 1.0d0) -186) + (scale-float (float 8245876460590265 1.0d0) -239)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -81) + (scale-float (float 8631899285793450 1.0d0) -134) + (scale-float (float 6032947000831726 1.0d0) -187) + (scale-float (float 8404206134990009 1.0d0) -240)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -82) + (scale-float (float 8913374262504106 1.0d0) -135) + (scale-float (float 6006558721765102 1.0d0) -188) + (scale-float (float 8406680036152505 1.0d0) -241)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -83) + (scale-float (float 8983743006681770 1.0d0) -136) + (scale-float (float 6004909454323438 1.0d0) -189) + (scale-float (float 8406718690858169 1.0d0) -242)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -84) + (scale-float (float 9001335192726186 1.0d0) -137) + (scale-float (float 6004806375108334 1.0d0) -190) + (scale-float (float 8406719294837945 1.0d0) -243)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -85) + (scale-float (float 9005733239237290 1.0d0) -138) + (scale-float (float 6004799932657390 1.0d0) -191) + (scale-float (float 8406719304275129 1.0d0) -244)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -86) + (scale-float (float 9006832750865066 1.0d0) -139) + (scale-float (float 6004799530004206 1.0d0) -192) + (scale-float (float 8406719304422585 1.0d0) -245)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -87) + (scale-float (float 9007107628772010 1.0d0) -140) + (scale-float (float 6004799504838382 1.0d0) -193) + (scale-float (float 8406719304424889 1.0d0) -246)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -88) + (scale-float (float 9007176348248746 1.0d0) -141) + (scale-float (float 6004799503265518 1.0d0) -194) + (scale-float (float 8406719304424925 1.0d0) -247)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -89) + (scale-float (float 9007193528117930 1.0d0) -142) + (scale-float (float 6004799503167214 1.0d0) -195) + (scale-float (float 8406719304424926 1.0d0) -248)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -90) + (scale-float (float 9007197823085226 1.0d0) -143) + (scale-float (float 6004799503161070 1.0d0) -196) + (scale-float (float 8406719304424926 1.0d0) -249)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -91) + (scale-float (float 9007198896827050 1.0d0) -144) + (scale-float (float 6004799503160686 1.0d0) -197) + (scale-float (float 8406719304424926 1.0d0) -250)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -92) + (scale-float (float 9007199165262506 1.0d0) -145) + (scale-float (float 6004799503160662 1.0d0) -198) + (scale-float (float 8406719304424926 1.0d0) -251)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -93) + (scale-float (float 9007199232371370 1.0d0) -146) + (scale-float (float 6004799503160661 1.0d0) -199) + (scale-float (float 3903119677054430 1.0d0) -252)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -94) + (scale-float (float 9007199249148586 1.0d0) -147) + (scale-float (float 6004799503160661 1.0d0) -200) + (scale-float (float 3058694746922462 1.0d0) -253)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -95) + (scale-float (float 9007199253342890 1.0d0) -148) + (scale-float (float 6004799503160661 1.0d0) -201) + (scale-float (float 3005918188789214 1.0d0) -254)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -96) + (scale-float (float 9007199254391466 1.0d0) -149) + (scale-float (float 6004799503160661 1.0d0) -202) + (scale-float (float 3002619653905886 1.0d0) -255)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -97) + (scale-float (float 9007199254653610 1.0d0) -150) + (scale-float (float 6004799503160661 1.0d0) -203) + (scale-float (float 3002413495475678 1.0d0) -256)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -98) + (scale-float (float 9007199254719146 1.0d0) -151) + (scale-float (float 6004799503160661 1.0d0) -204) + (scale-float (float 3002400610573790 1.0d0) -257)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -99) + (scale-float (float 9007199254735530 1.0d0) -152) + (scale-float (float 6004799503160661 1.0d0) -205) + (scale-float (float 3002399805267422 1.0d0) -258)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -100) + (scale-float (float 9007199254739626 1.0d0) -153) + (scale-float (float 6004799503160661 1.0d0) -206) + (scale-float (float 3002399754935774 1.0d0) -259)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -101) + (scale-float (float 9007199254740650 1.0d0) -154) + (scale-float (float 6004799503160661 1.0d0) -207) + (scale-float (float 3002399751790046 1.0d0) -260)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -102) + (scale-float (float 9007199254740906 1.0d0) -155) + (scale-float (float 6004799503160661 1.0d0) -208) + (scale-float (float 3002399751593438 1.0d0) -261)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -103) + (scale-float (float 9007199254740970 1.0d0) -156) + (scale-float (float 6004799503160661 1.0d0) -209) + (scale-float (float 3002399751581150 1.0d0) -262)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -104) + (scale-float (float 9007199254740986 1.0d0) -157) + (scale-float (float 6004799503160661 1.0d0) -210) + (scale-float (float 3002399751580382 1.0d0) -263)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -105) + (scale-float (float 9007199254740990 1.0d0) -158) + (scale-float (float 6004799503160661 1.0d0) -211) + (scale-float (float 3002399751580334 1.0d0) -264)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -106) + (scale-float (float 9007199254740991 1.0d0) -159) + (scale-float (float 6004799503160661 1.0d0) -212) + (scale-float (float 3002399751580331 1.0d0) -265)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -107) + (scale-float (float 9007199254740991 1.0d0) -160) + (scale-float (float 8256599316845909 1.0d0) -213) + (scale-float (float 3002399751580331 1.0d0) -266)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -108) + (scale-float (float 9007199254740991 1.0d0) -161) + (scale-float (float 8819549270267221 1.0d0) -214) + (scale-float (float 3002399751580331 1.0d0) -267)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -109) + (scale-float (float 9007199254740991 1.0d0) -162) + (scale-float (float 8960286758622549 1.0d0) -215) + (scale-float (float 3002399751580331 1.0d0) -268)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -110) + (scale-float (float 9007199254740991 1.0d0) -163) + (scale-float (float 8995471130711381 1.0d0) -216) + (scale-float (float 3002399751580331 1.0d0) -269)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -111) + (scale-float (float 9007199254740991 1.0d0) -164) + (scale-float (float 9004267223733589 1.0d0) -217) + (scale-float (float 3002399751580331 1.0d0) -270)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -112) + (scale-float (float 9007199254740991 1.0d0) -165) + (scale-float (float 9006466246989141 1.0d0) -218) + (scale-float (float 3002399751580331 1.0d0) -271)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -113) + (scale-float (float 9007199254740991 1.0d0) -166) + (scale-float (float 9007016002803029 1.0d0) -219) + (scale-float (float 3002399751580331 1.0d0) -272)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -114) + (scale-float (float 9007199254740991 1.0d0) -167) + (scale-float (float 9007153441756501 1.0d0) -220) + (scale-float (float 3002399751580331 1.0d0) -273)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -115) + (scale-float (float 9007199254740991 1.0d0) -168) + (scale-float (float 9007187801494869 1.0d0) -221) + (scale-float (float 3002399751580331 1.0d0) -274)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -116) + (scale-float (float 9007199254740991 1.0d0) -169) + (scale-float (float 9007196391429461 1.0d0) -222) + (scale-float (float 3002399751580331 1.0d0) -275)) + (%make-qd-d (scale-float (float 9007199254740991 1.0d0) -117) + (scale-float (float 9007199254740991 1.0d0) -170) + (scale-float (float 9007198538913109 1.0d0) -223) + (scale-float (float 3002399751580331 1.0d0) -276)) + )) + "Table of atan(2^(-k)) for k = -2 to 64. But the first three entries are 1") + +(defconstant +atan-power-table+ + (make-array 67 + :element-type 'double-float + :initial-contents + (loop for k from 0 below 67 + collect (scale-float 1d0 (- 2 k))) + ) +"Table of (2^(-k)) for k = -2 to 64. But the first three entries are 1") + +(defconstant +cordic-scale+ + #.(qd-from-string "0.065865828601599636584870082133151126045971796871364763285694473524426q0")) + +(defun dump-qd (qd) + (flet ((dump-d (d) + (multiple-value-bind (int exp sign) + (integer-decode-float d) + `(scale-float (float ,(* sign int) 1d0) ,exp)))) + (multiple-value-bind (q0 q1 q2 q3) + (qd-parts qd) + `(%make-qd-d ,(dump-d q0) + ,(dump-d q1) + ,(dump-d q2) + ,(dump-d q3))))) diff --git a/external/oct/qd-dd.lisp b/external/oct/qd-dd.lisp new file mode 100644 index 0000000..a36d18d --- /dev/null +++ b/external/oct/qd-dd.lisp @@ -0,0 +1,138 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qdi) + +;;; double-double float routines needed for quad-double. +;;; +;;; Not needed for CMUCL. +;;; +;;; These routines were taken directly from CMUCL. + +(declaim (inline quick-two-sum)) +(defun quick-two-sum (a b) + "Computes fl(a+b) and err(a+b), assuming |a| >= |b|" + (declare (double-float a b)) + (let* ((s (+ a b)) + (e (- b (- s a)))) + (values s e))) + +(declaim (inline two-sum)) +(defun two-sum (a b) + "Computes fl(a+b) and err(a+b)" + (declare (double-float a b)) + (let* ((s (+ a b)) + (v (- s a)) + (e (+ (- a (- s v)) + (- b v)))) + (values s e))) + +(declaim (inline two-prod)) +(declaim (inline split)) +;; This algorithm is the version given by Yozo Hida. It has problems +;; with overflow because we multiply by 1+2^27. +;; +;; But be very careful about replacing this with a new algorithm. The +;; values computed here are very important to get the rounding right. +;; If you change this, the rounding may be different, which will +;; affect other parts of the algorithm. +;; +;; I (rtoy) tried a different algorithm that split the number in two +;; as described, but without overflow. However, that caused +;; -9.4294948327242751340284975915175w0/1w14 to return a value that +;; wasn't really close to -9.4294948327242751340284975915175w-14. +;; +;; This also means we can't print numbers like 1w308 with the current +;; printing algorithm, or even divide 1w308 by 10. +#+nil +(defun split (a) + "Split the double-float number a into a-hi and a-lo such that a = + a-hi + a-lo and a-hi contains the upper 26 significant bits of a and + a-lo contains the lower 26 bits." + (declare (double-float a)) + (let* ((tmp (* a (+ 1 (expt 2 27)))) + (a-hi (- tmp (- tmp a))) + (a-lo (- a a-hi))) + (values a-hi a-lo))) + + +(defun split (a) + "Split the double-float number a into a-hi and a-lo such that a = + a-hi + a-lo and a-hi contains the upper 26 significant bits of a and + a-lo contains the lower 26 bits." + (declare (double-float a) + (optimize (speed 3))) + ;; This splits the number a into 2 halves of 26 bits each, but the + ;; halves are, I think, supposed to be properly rounded in an IEEE + ;; fashion. + ;; + ;; For numbers that are very large, we use a different algorithm. + ;; For smaller numbers, we can use the original algorithm of Yozo + ;; Hida. + (if (> (abs a) (scale-float 1d0 (- 1023 27))) + ;; I've tested this algorithm against Yozo's method for 1 + ;; billion randomly generated double-floats between 2^(-995) and + ;; 2^996, and identical results are obtained. For numbers that + ;; are very small, this algorithm produces different numbers + ;; because of underflow. For very large numbers, we, of course + ;; produce different results because Yozo's method causes + ;; overflow. + (let* ((tmp (* a (+ 1 (scale-float 1d0 -27)))) + (as (* a (scale-float 1d0 -27))) + (a-hi (* (- tmp (- tmp as)) (expt 2 27))) + (a-lo (- a a-hi))) + (values a-hi a-lo)) + ;; Yozo's algorithm. + (let* ((tmp (* a (+ 1 (expt 2 27)))) + (a-hi (- tmp (- tmp a))) + (a-lo (- a a-hi))) + (values a-hi a-lo)))) + + +(defun two-prod (a b) + "Compute fl(a*b) and err(a*b)" + (declare (double-float a b)) + (let ((p (* a b))) + (multiple-value-bind (a-hi a-lo) + (split a) + (multiple-value-bind (b-hi b-lo) + (split b) + (let ((e (+ (+ (- (* a-hi b-hi) p) + (* a-hi b-lo) + (* a-lo b-hi)) + (* a-lo b-lo)))) + (values p e)))))) + +(declaim (inline two-sqr)) +(defun two-sqr (a) + "Compute fl(a*a) and err(a*b). This is a more efficient + implementation of two-prod" + (declare (double-float a)) + (let ((q (* a a))) + (multiple-value-bind (a-hi a-lo) + (split a) + (values q (+ (+ (- (* a-hi a-hi) q) + (* 2 a-hi a-lo)) + (* a-lo a-lo)))))) diff --git a/external/oct/qd-extra.lisp b/external/oct/qd-extra.lisp new file mode 100644 index 0000000..2a77e88 --- /dev/null +++ b/external/oct/qd-extra.lisp @@ -0,0 +1,863 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;;; This file contains various possible implementations of some of the +;;; core routines. These were experiments on faster and/or more +;;; accurate implementations. The routines inf qd-fun.lisp are the +;;; default, but you can select a different implementation from here +;;; if you want. +;;; +;;; The end of the file also includes some tests of the different +;;; implementations for speed. + +(in-package #:qdi) + +;; This works but seems rather slow, so we don't even compile it. +#+(or) +(defun exp-qd/newton (a) + (declare (type %quad-double a)) + ;; Newton iteration + ;; + ;; f(x) = log(x) - a + ;; + ;; x' = x - (log(x) - a)/(1/x) + ;; = x - x*(log(x) - a) + ;; = x*(1 + a - log(x)) + (let ((a1 (add-qd-d a 1d0)) + (x (make-qd-d (exp (qd-0 a))))) + (setf x (mul-qd x (sub-qd a1 (log-qd/agm x)))) + (setf x (mul-qd x (sub-qd a1 (log-qd/agm x)))) + (setf x (mul-qd x (sub-qd a1 (log-qd/agm x)))) + x)) + +(defun expm1-qd/series (a) + (declare (type %quad-double a)) + ;; Compute exp(x) - 1. + ;; + ;; D(x) = exp(x) - 1 + ;; + ;; First, write x = s*log(2) + r*k where s is an integer and |r*k| < + ;; log(2)/2. + ;; + ;; Then D(x) = D(s*log(2)+r*k) = 2^s*exp(r*k) - 1 + ;; = 2^s*(exp(r*k)-1) - 1 + 2^s + ;; = 2^s*D(r*k)+2^s-1 + ;; But + ;; exp(r*k) = exp(r)^k + ;; = (D(r) + 1)^k + ;; + ;; So + ;; D(r*k) = (D(r) + 1)^k - 1 + ;; + ;; For small r, D(r) can be computed using the Taylor series around + ;; zero. To compute D(r*k) = (D(r) + 1)^k - 1, we use the binomial + ;; theorem to expand out the power and to exactly cancel out the -1 + ;; term, which is the source of inaccuracy. + ;; + ;; We want to have small r so the Taylor series converges quickly, + ;; but that means k is large, which means the binomial expansion is + ;; long. We need to compromise. Let use choose k = 8. Then |r| < + ;; log(2)/16 = 0.0433. For this range, the Taylor series converges + ;; to 212 bits of accuracy with about 28 terms. + ;; + ;; + (flet ((taylor (x) + (declare (type %quad-double x)) + ;; Taylor series for exp(x)-1 + ;; = x+x^2/2!+x^3/3!+x^4/4!+... + ;; = x*(1+x/2!+x^2/3!+x^3/4!+...) + (let ((sum +qd-one+) + (term +qd-one+)) + (dotimes (k 28) + (setf term (div-qd-d (mul-qd term x) (float (cl:+ k 2) 1d0))) + (setf sum (add-qd sum term))) + (mul-qd x sum))) + (binom (x) + (declare (type %quad-double x)) + ;; (1+x)^8-1 + ;; = x*(8 + 28*x + 56*x^2 + 70*x^3 + 56*x^4 + 28*x^5 + 8*x^6 + x^7) + ;; = x (x (x (x (x (x (x (x + 8) + 28) + 56) + 70) + 56) + 28) + 8) + (mul-qd + x + (add-qd-d + (mul-qd x + (add-qd-d + (mul-qd x + (add-qd-d + (mul-qd x + (add-qd-d + (mul-qd x + (add-qd-d + (mul-qd x + (add-qd-d + (mul-qd x + (add-qd-d x 8d0)) + 28d0)) + 56d0)) + 70d0)) + 56d0)) + 28d0)) + 8d0))) + (arg-reduce (x) + (declare (type %quad-double x)) + ;; Write x = s*log(2) + r*k where s is an integer and |r*k| + ;; < log(2)/2, and k = 8. + (let* ((s (truncate (qd-0 (nint-qd (div-qd a +qd-log2+))))) + (r*k (sub-qd x (mul-qd-d +qd-log2+ (float s 1d0)))) + (r (div-qd-d r*k 8d0))) + (values s r)))) + (multiple-value-bind (s r) + (arg-reduce a) + (let* ((d (taylor r)) + (dr (binom d))) + (add-qd-d (scale-float-qd dr s) + (cl:- (scale-float 1d0 s) 1)))))) + +(defun log-qd/newton (a) + (declare (type %quad-double a)) + ;; The Taylor series for log converges rather slowly. Hence, this + ;; routine tries to determine the root of the function + ;; + ;; f(x) = exp(x) - a + ;; + ;; using Newton iteration. The iteration is + ;; + ;; x' = x - f(x) / f'(x) + ;; = x - (1 - a * exp(-x)) + ;; = x + a * exp(-x) - 1 + ;; + ;; Two iterations are needed. + (let ((x (make-qd-d (log (qd-0 a))))) + (dotimes (k 3) + (setf x (sub-qd-d (add-qd x (mul-qd a (exp-qd (neg-qd x)))) + 1d0))) + x)) + + +;;(declaim (inline agm-qd)) + +(defun agm-qd (x y) + (declare (type %quad-double x y) + (optimize (speed 3))) + (let ((diff (qd-0 (abs-qd (sub-qd x y))))) + (cond ((< diff +qd-eps+) + x) + (t + (let ((a-mean (div-qd-d (add-qd x y) 2d0)) + (g-mean (sqrt-qd (mul-qd x y)))) + (agm-qd a-mean g-mean)))))) + +#+(or) +(defun agm-qd (x y) + (declare (type %quad-double x y) + (optimize (speed 3) (space 0) (safety 0))) + (let ((diff (qd-0 (abs-qd (sub-qd x y)))) + (x x) + (y y)) + (declare (double-float diff)) + (loop while (> diff +qd-eps+) + do + (let ((a-mean (scale-float-qd (add-qd x y) -1)) + (g-mean (sqrt-qd (mul-qd x y)))) + (setf x a-mean) + (setf y g-mean) + (setf diff (qd-0 (abs-qd (sub-qd x y)))))) + x)) + +(defun log-qd/agm (x) + (declare (type %quad-double x)) + ;; log(x) ~ pi/2/agm(1,4/x)*(1+O(1/x^2)) + ;; + ;; Need to make x >= 2^(d/2) to get d bits of precision. We use + ;; + ;; log(2^k*x) = k*log(2)+log(x) + ;; + ;; to compute log(x). log(2^k*x) is computed using AGM. + ;; + (multiple-value-bind (frac exp) + (decode-float (qd-0 x)) + (declare (ignore frac)) + (cond ((>= exp 106) + ;; Big enough to use AGM + (div-qd +qd-pi/2+ + (agm-qd +qd-one+ + (div-qd (make-qd-d 4d0) + x)))) + (t + ;; log(x) = log(2^k*x) - k * log(2) + (let* ((k (cl:- 107 exp)) + (big-x (scale-float-qd x k))) + ;; Compute k*log(2) using extra precision by writing + ;; log(2) = a + b, where a is the quad-double + ;; approximation and b the rest. + (sub-qd (log-qd/agm big-x) + (add-qd (mul-qd-d +qd-log2+ (float k 1d0)) + (mul-qd-d +qd-log2-extra+ (float k 1d0))))))))) + +(defun log-qd/agm2 (x) + (declare (type %quad-double x)) + ;; log(x) ~ pi/4/agm(theta2(q^4)^2,theta3(q^4)^2) + ;; + ;; where q = 1/x + ;; + ;; Need to make x >= 2^(d/36) to get d bits of precision. We use + ;; + ;; log(2^k*x) = k*log(2)+log(x) + ;; + ;; to compute log(x). log(2^k*x) is computed using AGM. + ;; + (multiple-value-bind (frac exp) + (decode-float (qd-0 x)) + (declare (ignore frac)) + (cond ((>= exp 7) + ;; Big enough to use AGM (because d = 212 so x >= 2^5.8888) + (let* ((q (div-qd +qd-one+ + x)) + (q^4 (npow q 4)) + (q^8 (sqr-qd q^4)) + ;; theta2(q^4) = 2*q*(1+q^8+q^24) + ;; = 2*q*(1+q^8+(q^8)^3) + (theta2 (mul-qd-d + (mul-qd + q + (add-qd-d + (add-qd q^8 + (npow q^8 3)) + 1d0)) + 2d0)) + ;; theta3(q^4) = 1+2*(q^4+q^16) + ;; = 1+2*(q^4+(q^4)^4) + (theta3 (add-qd-d + (mul-qd-d + (add-qd q^4 + (npow q^4 4)) + 2d0) + 1d0))) + (div-qd +qd-pi/4+ + (agm-qd (sqr-qd theta2) + (sqr-qd theta3))))) + (t + ;; log(x) = log(2^k*x) - k * log(2) + (let* ((k (cl:- 7 exp)) + (big-x (scale-float-qd x k))) + (sub-qd (log-qd/agm2 big-x) + (add-qd (mul-qd-d +qd-log2+ (float k 1d0)) + (mul-qd-d +qd-log2-extra+ (float k 1d0))))))))) + +(defun log-qd/agm3 (x) + (declare (type %quad-double x)) + ;; log(x) ~ pi/4/agm(theta2(q^4)^2,theta3(q^4)^2) + ;; + ;; where q = 1/x + ;; + ;; Need to make x >= 2^(d/36) to get d bits of precision. We use + ;; + ;; log(2^k*x) = k*log(2)+log(x) + ;; + ;; to compute log(x). log(2^k*x) is computed using AGM. + ;; + (multiple-value-bind (frac exp) + (decode-float (qd-0 x)) + (declare (ignore frac)) + (cond ((>= exp 7) + ;; Big enough to use AGM (because d = 212 so x >= 2^5.8888) + (let* ((q (div-qd +qd-one+ + x)) + (q^4 (npow q 4)) + (q^8 (sqr-qd q^4)) + ;; theta2(q^4) = 2*q*(1+q^8+q^24) + ;; = 2*q*(1+q^8+(q^8)^3) + (theta2 (mul-qd-d + (mul-qd + q + (add-qd-d + (add-qd q^8 + (npow q^8 3)) + 1d0)) + 2d0)) + ;; theta3(q^4) = 1+2*(q^4+q^16) + ;; = 1+2*(q^4+(q^4)^4) + (theta3 (add-qd-d + (mul-qd-d + (add-qd q^4 + (npow q^4 4)) + 2d0) + 1d0))) + ;; Note that agm(theta2^2,theta3^2) = agm(2*theta2*theta3,theta2^2+theta3^2)/2 + (div-qd +qd-pi/4+ + (scale-float-qd + (agm-qd (scale-float-qd (mul-qd theta2 theta3) 1) + (add-qd (sqr-qd theta2) + (sqr-qd theta3))) + -1)))) + (t + ;; log(x) = log(2^k*x) - k * log(2) + (let* ((k (cl:- 7 exp)) + (big-x (scale-float-qd x k))) + (sub-qd (log-qd/agm3 big-x) + (add-qd + (mul-qd-d +qd-log2+ (float k 1d0)) + (mul-qd-d +qd-log2-extra+ (float k 1d0))))))))) + +#+(or) +(defun atan-d (y x) + (let* ((r (abs (complex x y))) + (xx (cl:/ x r)) + (yy (cl:/ y r))) + (let ((z (atan (float y 1f0) (float x 1f0))) + (sinz 0d0) + (cosz 0d0)) + (format t "z = ~A~%" z) + (cond ((> xx yy) + (format t "xx > yy~%") + (dotimes (k 5) + (let* ((sinz (sin z)) + (cosz (cos z)) + (delta (cl:/ (cl:- yy sinz) + cosz))) + (format t "sz, dz = ~A ~A~%" sinz cosz) + (format t "delta = ~A~%" delta) + (setf z (cl:+ z delta)) + (format t "z = ~A~%" z)))) + (t + (dotimes (k 20) + (let ((sinz (sin z)) + (cosz (cos z))) + (format t "sz, dz = ~A ~A~%" sinz cosz) + + (setf z (cl:- z (cl:/ (cl:- xx cosz) + sinz))) + (format t "z = ~A~%" z))))) + z))) + +#|| +(defvar *table*) +(defvar *ttable*) +(defvar *cordic-scale*) + +#+nil +(defun setup-cordic () + (let ((table (make-array 34)) + (ttable (make-array 34))) + (setf (aref table 0) 1d0) + (setf (aref table 1) 1d0) + (setf (aref table 2) 1d0) + (setf (aref ttable 0) (cl:/ pi 4)) + (setf (aref ttable 1) (cl:/ pi 4)) + (setf (aref ttable 2) (cl:/ pi 4)) + (loop for k from 3 below 34 do + (setf (aref table k) (cl:* 0.5d0 (aref table (cl:1- k)))) + (setf (aref ttable k) (atan (aref table k)))) + (setf *table* table) + (setf *ttable* ttable))) + +(defun setup-cordic () + (let ((table (make-array 34)) + (ttable (make-array 34))) + (setf (aref table 0) 4d0) + (setf (aref table 1) 2d0) + (setf (aref table 2) 1d0) + (setf (aref ttable 0) (atan 4d0)) + (setf (aref ttable 1) (atan 2d0)) + (setf (aref ttable 2) (cl:/ pi 4)) + (loop for k from 3 below 34 do + (setf (aref table k) (cl:* 0.5d0 (aref table (cl:1- k)))) + (setf (aref ttable k) (atan (aref table k)))) + (setf *table* table) + (setf *ttable* ttable))) + +(defun setup-cordic () + (let ((table (make-array 34)) + (ttable (make-array 34)) + (scale 1d0)) + (loop for k from 0 below 34 do + (setf (aref table k) (scale-float 1d0 (cl:- 2 k))) + (setf (aref ttable k) (atan (aref table k))) + (setf scale (cl:* scale (cos (aref ttable k))))) + (setf *table* table) + (setf *ttable* ttable) + (setf *cordic-scale* scale))) + + +(defun cordic-rot (x y) + (let ((z 0)) + (dotimes (k (length *table*)) + (cond ((plusp y) + (psetq x (cl:+ x (cl:* y (aref *table* k))) + y (cl:- y (cl:* x (aref *table* k)))) + (incf z (aref *ttable* k))) + (t + (psetq x (cl:- x (cl:* y (aref *table* k))) + y (cl:+ y (cl:* x (aref *table* k)))) + (decf z (aref *ttable* k))) + )) + (values z x y))) + +(defun cordic-vec (z) + (let ((x 1d0) + (y 0d0) + (scale 1d0)) + (dotimes (k 12 (length *table*)) + (setf scale (cl:* scale (cos (aref *ttable* k)))) + (cond ((minusp z) + (psetq x (cl:+ x (cl:* y (aref *table* k))) + y (cl:- y (cl:* x (aref *table* k)))) + (incf z (aref *ttable* k))) + (t + (psetq x (cl:- x (cl:* y (aref *table* k))) + y (cl:+ y (cl:* x (aref *table* k)))) + (decf z (aref *ttable* k))) + )) + (values x y z scale))) + +(defun atan2-d (y x) + (multiple-value-bind (z dx dy) + (cordic-rot x y) + (let ((theta (cl:/ dy dx))) + (format t "theta = ~A~%" theta) + (let ((corr (cl:+ theta + (cl:- (cl:/ (expt theta 3) + 3)) + (cl:/ (expt theta 5) + 5)))) + (format t "corr = ~A~%" corr) + (cl:+ z corr))))) + +(defun tan-d (r) + (multiple-value-bind (x y z) + (cordic-vec r) + (setf x (cl:* x *cordic-scale*)) + (setf y (cl:* y *cordic-scale*)) + (format t "x = ~A~%" x) + (format t "y = ~A~%" y) + (format t "z = ~A~%" z) + ;; Need to finish of the rotation + (let ((st (sin z)) + (ct (cos z))) + (format t "st, ct = ~A ~A~%" st ct) + (psetq x (cl:- (cl:* x ct) (cl:* y st)) + y (cl:+ (cl:* y ct) (cl:* x st))) + (format t "x = ~A~%" x) + (format t "y = ~A~%" y) + (cl:/ y x) + ))) + +(defun sin-d (r) + (declare (type double-float r)) + (multiple-value-bind (x y z s) + (cordic-vec r) + + ;; Need to finish the rotation + (let ((st (sin z)) + (ct (cos z))) + (psetq x (cl:- (cl:* x ct) (cl:* y st)) + y (cl:+ (cl:* y ct) (cl:* x st))) + (cl:* s y)))) +||# + +;; This is the basic CORDIC rotation. Based on code from +;; http://www.voidware.com/cordic.htm and +;; http://www.dspcsp.com/progs/cordic.c.txt. +;; +;; The only difference between this version and the typical CORDIC +;; implementation is that the first 3 rotations are all by pi/4. This +;; makes sense. If the angle is greater than pi/4, the rotations will +;; reduce it to at most pi/4. If the angle is less than pi/4, the 3 +;; rotations by pi/4 will cause us to end back at the same place. +;; (Should we try to be smarter?) +(defun cordic-rot-qd (x y) + (declare (type %quad-double y x) + (optimize (speed 3))) + (let* ((zero +qd-zero+) + (z zero)) + (declare (type %quad-double zero z)) + (dotimes (k (length +atan-table+)) + (declare (fixnum k)) + (cond ((qd-> y zero) + (psetq x (add-qd x (mul-qd-d y (aref +atan-power-table+ k))) + y (sub-qd y (mul-qd-d x (aref +atan-power-table+ k)))) + (setf z (add-qd z (aref +atan-table+ k)))) + (t + (psetq x (sub-qd x (mul-qd-d y (aref +atan-power-table+ k))) + y (add-qd y (mul-qd-d x (aref +atan-power-table+ k)))) + (setf z (sub-qd z (aref +atan-table+ k)))))) + (values z x y))) + +(defun atan2-qd/cordic (y x) + (declare (type %quad-double y x)) + ;; Use the CORDIC rotation to get us to a small angle. Then use the + ;; Taylor series for atan to finish the computation. + (multiple-value-bind (z dx dy) + (cordic-rot-qd x y) + ;; Use Taylor series to finish off the computation + (let* ((arg (div-qd dy dx)) + (sq (neg-qd (sqr-qd arg))) + (sum +qd-one+)) + ;; atan(x) = x - x^3/3 + x^5/5 - ... + ;; = x*(1-x^2/3+x^4/5-x^6/7+...) + (do ((k 3d0 (cl:+ k 2d0)) + (term sq)) + ((< (abs (qd-0 term)) +qd-eps+)) + (setf sum (add-qd sum (div-qd-d term k))) + (setf term (mul-qd term sq))) + (setf sum (mul-qd arg sum)) + (add-qd z sum)))) + +(defun atan-qd/cordic (y) + (declare (type %quad-double y)) + (atan2-qd/cordic y +qd-one+)) + +(defun atan-qd/duplication (y) + (declare (type %quad-double y) + (optimize (speed 3) (space 0))) + (cond ((< (abs (qd-0 y)) 1d-4) + ;; Series + (let* ((arg y) + (sq (neg-qd (sqr-qd arg))) + (sum +qd-one+)) + ;; atan(x) = x - x^3/3 + x^5/5 - ... + ;; = x*(1-x^2/3+x^4/5-x^6/7+...) + (do ((k 3d0 (cl:+ k 2d0)) + (term sq)) + ((< (abs (qd-0 term)) +qd-eps+)) + (setf sum (add-qd sum (div-qd-d term k))) + (setf term (mul-qd term sq))) + (mul-qd arg sum))) + (t + ;; atan(x) = 2*atan(x/(1 + sqrt(1 + x^2))) + (let ((x (div-qd y + (add-qd-d (sqrt-qd (add-qd-d (sqr-qd y) 1d0)) + 1d0)))) + (scale-float-qd (atan-qd/duplication x) 1))))) + +(defun cordic-vec-qd (z) + (declare (type %quad-double z) + (optimize (speed 3))) + (let* ((x +qd-one+) + (y +qd-zero+) + (zero +qd-zero+)) + (declare (type %quad-double zero x y)) + (dotimes (k 30 (length +atan-table+)) + (declare (fixnum k) + (inline mul-qd-d sub-qd add-qd)) + (cond ((qd-> z zero) + (psetq x (sub-qd x (mul-qd-d y (aref +atan-power-table+ k))) + y (add-qd y (mul-qd-d x (aref +atan-power-table+ k)))) + (setf z (sub-qd z (aref +atan-table+ k)))) + (t + (psetq x (add-qd x (mul-qd-d y (aref +atan-power-table+ k))) + y (sub-qd y (mul-qd-d x (aref +atan-power-table+ k)))) + (setf z (add-qd z (aref +atan-table+ k)))))) + (values z x y))) + +(defun tan-qd/cordic (r) + (declare (type %quad-double r)) + (multiple-value-bind (z x y) + (cordic-vec-qd r) + ;; Need to finish the rotation + (multiple-value-bind (st ct) + (sincos-taylor z) + (psetq x (sub-qd (mul-qd x ct) (mul-qd y st)) + y (add-qd (mul-qd y ct) (mul-qd x st))) + (div-qd y x)))) + + +(defun sin-qd/cordic (r) + (declare (type %quad-double r)) + (multiple-value-bind (z x y) + (cordic-vec-qd r) + #+nil + (progn + (format t "~&x = ~/qd::qd-format/~%" x) + (format t "~&y = ~/qd::qd-format/~%" y) + (format t "~&z = ~/qd::qd-format/~%" z) + (format t "~&s = ~/qd::qd-format/~%" s)) + ;; Need to finish the rotation + (multiple-value-bind (st ct) + (sincos-taylor z) + #+nil + (progn + (format t "~&st = ~/qd::qd-format/~%" st) + (format t "~&ct = ~/qd::qd-format/~%" ct) + (format t "~&y = ~/qd::qd-format/~%" (mul-qd +cordic-scale+ y))) + + (psetq x (sub-qd (mul-qd x ct) (mul-qd y st)) + y (add-qd (mul-qd y ct) (mul-qd x st))) + (mul-qd +cordic-scale+ y)))) + + +;; Some timing and consing tests. +;; +;; The tests are run using the following: +;; +;; Sparc: 1.5 GHz Ultrasparc IIIi +;; Sparc2: 450 MHz Ultrasparc II +;; PPC: 1.42 GHz +;; x86: 866 MHz Pentium 3 +;; PPC(fma): 1.42 GHz with cmucl with fused-multiply-add double-double. +;; + +;; (time-exp #c(2w0 0) 50000) +;; +;; Time Sparc PPC x86 PPC (fma) Sparc2 +;; exp-qd/reduce 2.06 3.18 10.46 2.76 6.12 +;; expm1-qd/series 8.81 12.24 18.87 3.26 29.0 +;; expm1-qd/dup 5.68 4.34 18.47 3.64 18.78 +;; +;; Consing (MB) Sparc +;; exp-qd/reduce 45 45 638 44.4 45 +;; expm1-qd/series 519 519 1201 14.8 519 +;; expm1-qd/dup 32 32 1224 32.0 32 +;; +;; Speeds seem to vary quite a bit between architectures. +;; +;; Timing without inlining all the basic functions everywhere. (That +;; is, :qd-inline is not a feature.) +;; +;; (time-exp #c(2w0 0) 50000) +;; +;; Time Sparc PPC x86 PPC (fma) +;; exp-qd/reduce 5.83 0.67 10.67 0.98 +;; expm1-qd/series 10.65 1.45 21.06 1.35 +;; expm1-qd/dup 11.17 1.36 24.01 1.25 +;; +;; Consing Sparc +;; exp-qd/reduce 638 93 638 93 +;; expm1-qd/series 1203 120 1201 120 +;; expm1-qd/dup 1224 122 1224 122 +;; +;; So inlining speeds things up by a factor of about 3 for sparc, +;; 1.5-4 for ppc. Strangely, x86 slows down on some but speeds up on +;; others. +(defun time-exp (x n) + (declare (type %quad-double x) + (fixnum n)) + (let ((y +qd-zero+)) + (declare (type %quad-double y)) + #+cmu (gc :full t) + (format t "exp-qd/reduce~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (exp-qd/reduce x)))) + #+cmu (gc :full t) + (format t "expm1-qd/series~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (expm1-qd/series x)))) + #+cmu (gc :full t) + (format t "expm1-qd/duplication~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (expm1-qd/duplication x)))) + + )) + +;; (time-log #c(3w0 0) 50000) +;; +;; Time (s) Sparc PPC x86 PPC (fma) Sparc2 +;; log-qd/newton 7.08 10.23 35.74 8.82 21.77 +;; log1p-qd/dup 5.87 8.41 27.32 6.65 20.73 +;; log-qd/agm 6.58 8.0 27.2 6.87 24.62 +;; log-qd/agm2 5.8 6.93 22.89 6.07 18.44 +;; log-qd/agm3 5.45 6.57 20.97 6.18 20.34 +;; log-qd/halley 4.96 6.8 25.11 7.01 16.13 +;; +;; Consing (MB) Sparc PPC x86 PPC (fma) +;; log-qd/newton 150 150 2194 148 150 +;; log1p-qd/dup 56 56 1564 56 56 +;; log-qd/agm 81 11 1434 81 81 +;; log-qd/agm2 87 35 1184 87 87 +;; log-qd/agm3 82 36 1091 81 82 +;; log-qd/halley 101 101 1568 100 101 +;; +;; Based on these results, it's not really clear what is the fastest. +;; But Halley's iteration is probably a good tradeoff for log. +;; +;; However, consider log(1+2^(-100)). Use log1p as a reference: +;; 7.88860905221011805411728565282475078909313378023665801567590088088481830649115711502410110281q-31 +;; +;; We have +;; log-qd +;; 7.88860905221011805411728565282475078909313378023665801567590088088481830649133878797727478488q-31 +;; log-agm +;; 7.88860905221011805411728565282514580471135738786455290255431302193794546609432q-31 +;; log-agm2 +;; 7.88860905221011805411728565282474926980229445866885841995713611460718519856111q-31 +;; log-agm3 +;; 7.88860905221011805411728565282474926980229445866885841995713611460718519856111q-31 +;; log-halley +;; 7.88860905221011805411728565282475078909313378023665801567590088088481830649120253326239452326q-31 +;; +;; We can see that the AGM methods are grossly inaccurate, but log-qd +;; and log-halley are quite good. +;; +;; Timing results without inlining everything: +;; +;; Time Sparc PPC x86 PPC (fma) +;; log-qd/newton 21.37 0.87 41.49 0.62 +;; log1p-qd/dup 12.58 0.41 31.86 0.28 +;; log-qd/agm 7.17 0.23 34.86 0.16 +;; log-qd/agm2 6.35 0.22 27.53 0.15 +;; log-qd/agm3 7.49 0.17 24.92 0.14 +;; log-qd/halley 14.38 0.56 30.2 0.65 +;; +;; Consing +;; Sparc PPC x86 PPC (fma) +;; log-qd/newton 2194 60.7 2194 61 +;; log1p-qd/dup 1114 22.6 1564 23 +;; log-qd/agm 371 7.9 1434 7.9 +;; log-qd/agm2 371 7.8 1185 7.8 +;; log-qd/agm3 373 7.8 1091 7.8 +;; log-qd/halley 1554 42.3 1567 42.3 + +(defun time-log (x n) + (declare (type %quad-double x) + (fixnum n)) + (let ((y +qd-zero+)) + (declare (type %quad-double y)) + #+cmu (gc :full t) + (format t "log-qd/newton~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (log-qd/newton x)))) + #+cmu (gc :full t) + (format t "log1p-qd/duplication~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (log1p-qd/duplication x)))) + #+cmu (gc :full t) + (format t "log-qd/agm~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (log-qd/agm x)))) + + #+cmu (gc :full t) + (format t "log-qd/agm2~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (log-qd/agm2 x)))) + #+cmu (gc :full t) + (format t "log-qd/agm3~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (log-qd/agm3 x)))) + #+cmu (gc :full t) + (format t "log-qd/halley~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (log-qd/halley x)))) + )) + + +;; (time-atan2 #c(10w0 0) 10000) +;; +;; Time +;; PPC Sparc x86 PPC (fma) Sparc2 +;; atan2-qd/newton 2.91 1.91 8.06 2.16 7.55 +;; atan2-qd/cordic 1.22 0.89 6.68 1.43 2.47 +;; atan-qd/duplication 2.51 2.14 5.63 1.76 5.94 +;; +;; Consing +;; atan2-qd/newton 44.4 44.4 481 44.4 44.4 +;; atan2-qd/cordic 1.6 1.6 482 1.6 1.6 +;; atan-qd/duplication 17.2 6.0 281 6.0 6.0 +;; +;; Don't know why x86 is 10 times slower than sparc/ppc for +;; atan2-qd/newton. Consing is much more too. Not enough registers? +;; +;; atan2-qd/cordic is by far the fastest on all archs. +;; +;; Timing results without inlining everything: +;; Time +;; PPC Sparc x86 PPC (fma) +;; atan2-qd/newton 6.56 4.48 9.75 6.15 +;; atan2-qd/cordic 6.02 4.24 7.06 5.01 +;; atan-qd/duplication 3.28 1.94 5.72 2.46 +;; +;; Consing +;; atan2-qd/newton 443 441 482 443 +;; atan2-qd/cordic 482 482 482 482 +;; atan-qd/duplication 87 81 281 87 +;; + +(defun time-atan2 (x n) + (declare (type %quad-double x) + (fixnum n)) + (let ((y +qd-zero+) + (one +qd-one+)) + #+cmu (gc :full t) + (format t "atan2-qd/newton~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (atan2-qd/newton x one)))) + #+cmu (gc :full t) + (format t "atan2-qd/cordic~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (atan2-qd/cordic x one)))) + #+cmu (gc :full t) + (format t "atan-qd/duplication~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (atan-qd/duplication x)))) + )) + +;; (time-tan #c(10w0 0) 10000) +;; +;; Time +;; PPC Sparc x86 PPC (fma) Sparc2 +;; tan-qd/cordic 2.12 1.51 8.26 1.77 4.61 +;; tan-qd/sincos 0.68 0.57 2.39 0.54 2.56 +;; +;; Consing +;; tan-qd/cordic 23.0 23.0 473 23.0 23.0 +;; tan-qd/sincos 14.8 14.8 147 14.8 14.8 +;; +;; Don't know why x86 is so much slower for tan-qd/cordic. +;; +;; Without inlining everything +;; PPC Sparc x86 PPC (fma) +;; tan-qd/cordic 7.72 4.56 17.08 5.96 +;; tan-qd/sincos 2.32 1.4 4.91 1.87 +;; +;; Consing +;; tan-qd/cordic 463 463 472 463 +;; tan-qd/sincos 137 136 146 137 + +(defun time-tan (x n) + (declare (type %quad-double x) + (fixnum n)) + (let ((y +qd-zero+)) + #+cmu (gc :full t) + (format t "tan-qd/cordic~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (tan-qd/cordic x)))) + #+cmu (gc :full t) + (format t "tan-qd/sincos~%") + (time (dotimes (k n) + (declare (fixnum k)) + (setf y (tan-qd/sincos x)))))) + diff --git a/external/oct/qd-format.lisp b/external/oct/qd-format.lisp new file mode 100644 index 0000000..1610dca --- /dev/null +++ b/external/oct/qd-format.lisp @@ -0,0 +1,130 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qd) + +(defun qd-scale-exponent (original-x) + (let* ((x original-x)) + (multiple-value-bind (sig exponent) + (decode-float x) + (declare (ignore sig)) + (if (= x #q0) + (values #q0 1) + (let* ((ex (round (* exponent (log #q2 10)))) + (x (if (minusp ex) + + (* x #q10.0q0 (expt #q10.0q0 (- (- ex) 1))) + (/ x #q10.0q0 (expt #q10.0q0 (1- ex)))))) + (do ((d #q10.0q0 (* d #q10.0q0)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y #q1.0q0) + (do ((m #q10.0q0 (* m #q10.0q0)) + (z y (* y m)) + (ex ex (1- ex))) + ((>= z #q0.1q0) + (values z ex)))))))))) + +(defun decimal-string (n) + (cl:write-to-string n :base 10 :radix nil :escape nil)) + +(defun qd-format-exp-aux (stream number w d e k ovf pad marker atsign) + (multiple-value-bind (num expt) + (qd-scale-exponent (abs number)) + (let* ((expt (- expt k)) + (estr (decimal-string (abs expt))) + (elen (if e (max (length estr) e) (length estr))) + (add-zero-p nil)) + (if (and w ovf e (> elen e)) ;exponent overflow + (dotimes (i w) + (write-char ovf stream)) + (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (minusp k) + 1 + fdig)) + (spaceleft (if w + (- w 2 elen + (if (or atsign (minusp (float-sign number))) + 1 0)) + nil))) + (multiple-value-bind (fstr flen lpoint tpoint) + (qdi::qd-to-string (qd-value num) spaceleft fdig k fmin) + (when (and d (zerop d)) (setq tpoint nil)) + (when w + (decf spaceleft flen) + ;; See CLHS 22.3.3.2. "If the parameter d is + ;; omitted, ... [and] if the fraction to be + ;; printed is zero then a single zero digit should + ;; appear after the decimal point." So we need to + ;; subtract one from here because we're going to + ;; add an extra 0 digit later. + (when (and (null d) (char= (aref fstr (1- flen)) #\.)) + (setf add-zero-p t) + (decf spaceleft)) + (when lpoint + (if (or (> spaceleft 0) tpoint) + (decf spaceleft) + (setq lpoint nil))) + (when (and tpoint (<= spaceleft 0)) + (setq tpoint nil))) + (cond ((and w (< spaceleft 0) ovf) + ;;significand overflow + (dotimes (i w) (write-char ovf stream))) + (t (when w + (dotimes (i spaceleft) + (write-char pad stream))) + (if (minusp (float-sign number)) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + ;; Add a zero if we need it. Which means + ;; we figured out we need one above, or + ;; another condition. Basically, append a + ;; zero if there are no width constraints + ;; and if the last char to print was a + ;; decimal (so the trailing fraction is + ;; zero.) + (when (or add-zero-p + (and (null w) + (char= (aref fstr (1- flen)) #\.))) + ;; It's later and we're adding the zero + ;; digit. + (write-char #\0 stream)) + (write-char (if marker + marker + #\q) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream))))))))) + +(defun qd-format-exp (stream arg colon-p at-sign-p + &optional w d e (k 1) ovf (pad #\space) exp-marker) + (declare (ignore colon-p)) + (qd-format-exp-aux stream arg w d e k ovf pad exp-marker at-sign-p)) diff --git a/external/oct/qd-fun.lisp b/external/oct/qd-fun.lisp new file mode 100644 index 0000000..2cd9e0f --- /dev/null +++ b/external/oct/qd-fun.lisp @@ -0,0 +1,952 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;;; Basic special functions operating on %quad-double numbers. This +;;; includes sqrt, rounding to the nearest integer, floor, exp, log, +;;; log1p, sin, cos, tan, asin, acos, atan, atan2, sinh, cosh, tanh, +;;; asinh, acosh, atanh, and random. +;;; +;;; These special functions only work on the main domains where the +;;; argument is real and the result is real. Behavior is undefined if +;;; this doesn't hold. + +(in-package #:qdi) + +#+cmu +(declaim (maybe-inline sqrt-qd)) +(defun sqrt-qd (a) + "Square root of the (non-negative) quad-float" + (declare (type %quad-double a) + (optimize (speed 3) (space 0))) + ;; Perform the following Newton iteration: + ;; + ;; x' = x + (1 - a * x^2) * x / 2 + ;; + ;; which converges to 1/sqrt(a). + ;; + ;; However, there appear to be round-off errors when x is either + ;; very large or very small. So let x = f*2^(2*k). Then sqrt(x) = + ;; 2^k*sqrt(f), and sqrt(f) doesn't have round-off problems. + (when (zerop-qd a) + (return-from sqrt-qd a)) + #+cmu + (when (float-infinity-p (qd-0 a)) + (return-from sqrt-qd a)) + + (let* ((k (logandc2 (logb-finite (qd-0 a)) 1)) + (new-a (scale-float-qd a (- k)))) + (assert (evenp k)) + (let* ((r (make-qd-d (cl:/ (sqrt (the (double-float (0d0)) + (qd-0 new-a)))))) + (half 0.5d0) + (h (mul-qd-d new-a half))) + (declare (type %quad-double r)) + ;; Since we start with double-float precision, three more + ;; iterations should give us full accuracy. + (dotimes (k 3) + (setf r (add-qd r (mul-qd r (sub-d-qd half (mul-qd h (sqr-qd r))))))) + (scale-float-qd (mul-qd r new-a) (ash k -1))))) + +(defun logb-finite (x) + "Same as logb but X is not infinity and non-zero and not a NaN, so +that we can always return an integer" + (declare (type cl:float x)) + (multiple-value-bind (signif expon sign) + (cl:decode-float x) + (declare (ignore signif sign)) + ;; decode-float is almost right, except that the exponent + ;; is off by one + (1- expon))) + +(defun hypot-aux-qd (x y) + (declare (type %quad-double x y)) + (let ((k (- (logb-finite (max (cl:abs (qd-0 x)) + (cl:abs (qd-0 y))))))) + (values (add-qd (sqr-qd (scale-float-qd x k)) + (sqr-qd (scale-float-qd y k))) + (- k)))) + +(defun hypot-qd (x y) + "sqrt(x^2+y^2) computed carefully without unnecessary overflow" + (multiple-value-bind (abs^2 rho) + (hypot-aux-qd x y) + (scale-float-qd (sqrt-qd abs^2) rho))) + +(defun nint-qd (a) + "Round the quad-float to the nearest integer, which is returned as a + quad-float" + (let ((x0 (fround (qd-0 a))) + (x1 0d0) + (x2 0d0) + (x3 0d0)) + (cond ((= x0 (qd-0 a)) + ;; First double is already an integer + (setf x1 (fround (qd-1 a))) + (cond ((= x1 (qd-1 a)) + ;; Second is an integer + (setf x2 (fround (qd-2 a))) + (cond ((= x2 (qd-2 a)) + ;; Third is an integer + (setf x3 (fround (qd-3 a)))) + (t + (when (and (zerop (abs (cl:- x2 (qd-2 a)))) + (minusp (qd-3 a))) + (decf x2))))) + (t + (when (and (zerop (abs (cl:- x1 (qd-1 a)))) + (minusp (qd-2 a))) + (decf x1))))) + (t + (when (and (zerop (abs (cl:- x0 (qd-0 a)))) + (minusp (qd-1 a))) + (decf x0)))) + (multiple-value-bind (s0 s1 s2 s3) + (renorm-4 x0 x1 x2 x3) + (make-qd-d s0 s1 s2 s3)))) + +(defun ffloor-qd (a) + "The floor of A, returned as a quad-float" + (let ((x0 (ffloor (qd-0 a))) + (x1 0d0) + (x2 0d0) + (x3 0d0)) + (cond ((= x0 (qd-0 a)) + (setf x1 (ffloor (qd-1 a))) + (when (= x1 (qd-1 a)) + (setf x2 (ffloor (qd-2 a))) + (when (= x2 (qd-2 a)) + (setf x3 (ffloor (qd-3 a))))) + (make-qd-d x0 x1 x2 x3)) + (t + (%make-qd-d x0 x1 x2 x3))))) + + +(defun exp-qd/reduce (a) + ;; Strategy: Reduce the size of x by noting that + ;; + ;; exp(k*r+m) = exp(m) * exp(r)^k + ;; + ;; Thus, by choosing m to be a multiple of log(2) closest to x, we + ;; can make |kr| < log(2)/2 = 0.3466. Now we can set k = 256, so + ;; that |r| <= 0.00136. + ;; + ;; Then + ;; + ;; exp(x) = exp(k*r+s*log(2)) = 2^s*(exp(r))^256 + ;; + ;; We can use Taylor series to evaluate exp(r). + + (let* ((k 256) + (z (truncate (qd-0 (nint-qd (div-qd a +qd-log2+))))) + (r1 (sub-qd a (mul-qd-d +qd-log2+ (float z 1d0)))) + ;; r as above + (r (div-qd-d (sub-qd a (mul-qd-d +qd-log2+ (float z 1d0))) + (float k 1d0))) + ;; For Taylor series. p = r^2/2, the first term + (p (div-qd-d (sqr-qd r) 2d0)) + ;; s = 1+r+p, the sum of the first 3 terms + (s (add-qd-d (add-qd r p) 1d0)) + ;; Denominator of term + (m 2d0)) + ;; Taylor series until the term is small enough. + ;; + ;; Note that exp(x) = sinh(x) + sqrt(1+sinh(x)^2). The Taylor + ;; series for sinh has half as many terms as for exp, so it should + ;; be less work to compute sinh. Then a few additional operations + ;; and a square root gives us exp. + (loop + (incf m) + (setf p (mul-qd p r)) + (setf p (div-qd-d p m)) + (setf s (add-qd s p)) + (unless (> (abs (qd-0 p)) +qd-eps+) + (return))) + + (setf r (npow s k)) + (setf r (scale-float-qd r z)) + r)) + +(defun expm1-qd/duplication (a) + (declare (type %quad-double a)) + ;; Brent gives expm1(2*x) = expm1(x)*(2+expm1(x)) + ;; + ;; Hence + ;; + ;; expm1(x) = expm1(x/2)*(2+expm1(x/2)) + ;; + ;; Keep applying this formula until x is small enough. Then use + ;; Taylor series to compute expm1(x). + (cond ((< (abs (qd-0 a)) .0001d0) + ;; What is the right threshold? + ;; + ;; Taylor series for exp(x)-1 + ;; = x+x^2/2!+x^3/3!+x^4/4!+... + ;; = x*(1+x/2!+x^2/3!+x^3/4!+...) + (let ((sum +qd-one+) + (term +qd-one+)) + (dotimes (k 28) + (setf term (div-qd-d (mul-qd term a) (float (cl:+ k 2) 1d0))) + (setf sum (add-qd sum term))) + (mul-qd a sum))) + (t + (let ((d (expm1-qd/duplication (scale-float-qd a -1)))) + (mul-qd d (add-qd-d d 2d0)))))) + +(defun expm1-qd (a) + "exp(a) - 1, done accurately" + (declare (type %quad-double a)) + #+cmu + (when (float-infinity-p (qd-0 a)) + (return-from expm1-qd + (if (minusp (float-sign (qd-0 a))) + +qd-zero+ + a))) + (expm1-qd/duplication a)) + +(defun exp-qd (a) + "exp(a)" + (declare (type %quad-double a)) + ;; Should we try to be more accurate than just 709? + (when (< (qd-0 a) (log least-positive-normalized-double-float)) + (return-from exp-qd +qd-zero+)) + + (when (> (qd-0 a) (log most-positive-double-float)) + #-cmu + (error 'floating-point-overflow + :operation 'exp + :operands (list a)) + #+cmu + (return-from exp-qd (%make-qd-d (/ 1d0 0d0) 0d0 0d0 0d0))) + + (when (zerop-qd a) + (return-from exp-qd +qd-one+)) + + ;; Default for now is exp-qd/reduce + (exp-qd/reduce a)) + +(defun log-qd/halley (a) + (declare (type %quad-double a)) + ;; Halley iteration: + ;; + ;; x' = x - 2*(exp(x)-a)/(exp(x)+a) + ;; + ;; But the above has problems if a is near + ;; most-positive-double-float. Rearrange the computation: + ;; + ;; x' = x - 2*(exp(x)/a-1)/(exp(x)/a+1) + ;; + ;; I think this works better, but it's also probably a little bit + ;; more expensive because each iteration has two divisions. + (let ((x (make-qd-d (log (qd-0 a))))) + (flet ((iter (est) + (let ((exp (div-qd (exp-qd est) + a))) + (sub-qd est + (scale-float-qd + (div-qd (sub-qd-d exp 1d0) + (add-qd-d exp 1d0)) + 1))))) + ;; Two iterations should be enough + (setf x (iter x)) + (setf x (iter x)) + x))) + + +(defun log1p-qd/duplication (x) + (declare (type %quad-double x) + (optimize (speed 3))) + ;; Brent gives the following duplication formula for log1p(x) = + ;; log(1+x): + ;; + ;; log1p(x) = 2*log1p(x/(1+sqrt(1+x))) + ;; + ;; So we apply the duplication formula until x is small enough, and + ;; then use the series + ;; + ;; log(1+x) = 2*sum((x/(2+x))^(2*k+1)/(2*k+1),k,0,inf) + ;; + ;; Currently "small enough" means x < 0.005. What is the right + ;; cutoff? + (cond ((> (abs (qd-0 x)) .005d0) + ;; log1p(x) = 2*log1p(x/(1+sqrt(1+x))) + (mul-qd-d (log1p-qd/duplication + (div-qd x + (add-d-qd 1d0 + (sqrt-qd (add-d-qd 1d0 x))))) + 2d0)) + (t + ;; Use the series + (let* ((term (div-qd x (add-qd-d x 2d0))) + (mult (sqr-qd term)) + (sum term)) + (loop for k of-type double-float from 3d0 by 2d0 + while (> (abs (qd-0 term)) +qd-eps+) + do + (setf term (mul-qd term mult)) + (setf sum (add-qd sum (div-qd-d term k)))) + (mul-qd-d sum 2d0))))) + +(defun log1p-qd (x) + "log1p(x) = log(1+x), done more accurately than just evaluating + log(1+x)" + (declare (type %quad-double x)) + #+cmu + (when (float-infinity-p (qd-0 x)) + x) + (log1p-qd/duplication x)) + +(defun log-qd (a) + "Log(a)" + (declare (type %quad-double a)) + (cond ((onep-qd a) + +qd-zero+) + ((and (zerop-qd a) + (plusp (float-sign (qd-0 a)))) + (%make-qd-d (/ -1d0 (qd-0 a)) 0d0 0d0 0d0)) + #+cmu + ((float-infinity-p (qd-0 a)) + a) + ((minusp (float-sign (qd-0 a))) + (error "log of negative")) + (t + ;; Default is Halley's method + (log-qd/halley a)))) + + +;; sin(a) and cos(a) using Taylor series +;; +;; Assumes |a| <= pi/2048 +(defun sincos-taylor (a) + (declare (type %quad-double a)) + (let ((thresh (cl:* +qd-eps+ (abs (qd-0 a))))) + (when (zerop-qd a) + (return-from sincos-taylor + (values +qd-zero+ + +qd-one+))) + (let* ((x (neg-qd (sqr-qd a))) + (s a) + (p a) + (m 1d0)) + (loop + (setf p (mul-qd p x)) + (incf m 2) + (setf p (div-qd-d p (cl:* m (cl:1- m)))) + (setf s (add-qd s p)) + ;;(format t "p = ~A~%" (qd-0 p)) + (when (<= (abs (qd-0 p)) thresh) + (return))) + ;; cos(c) = sqrt(1-sin(c)^2). This seems to work ok, even + ;; though I would have expected some round-off errors in + ;; computing this. sqrt(1-x^2) is normally better computed as + ;; sqrt(1-x)*sqrt(1+x) for small x. + (values s (sqrt-qd (add-qd-d (neg-qd (sqr-qd s)) 1d0)))))) + +(defun drem-qd (a b) + (declare (type %quad-double a b)) + (let ((n (nint-qd (div-qd a b)))) + (sub-qd a (mul-qd n b)))) + +(defun divrem-qd (a b) + (declare (type %quad-double a b)) + (let ((n (nint-qd (div-qd a b)))) + (values n (sub-qd a (mul-qd n b))))) + +(defun sin-qd (a) + "Sin(a)" + (declare (type %quad-double a)) + ;; To compute sin(x), choose integers a, b so that + ;; + ;; x = s + a * (pi/2) + b*(pi/1024) + ;; + ;; with |x| <= pi/2048. Using a precomputed table of sin(k*pi/1024) + ;; and cos(k*pi/1024), we can compute sin(x) from sin(s) and cos(s). + ;; + ;; sin(x) = sin(s+k*(pi/1024) + j*pi/2) + ;; = sin(s+k*(pi/1024))*cos(j*pi/2) + ;; + cos(s+k*(pi/1024))*sin(j*pi/2) + ;; + ;; sin(s+k*pi/1024) = sin(s)*cos(k*pi/1024) + ;; + cos(s)*sin(k*pi/1024) + ;; + ;; cos(s+k*pi/1024) = cos(s)*cos(k*pi/1024) + ;; - sin(s)*sin(k*pi/1024) + (when (zerop-qd a) + (return-from sin-qd a)) + + ;; Reduce modulo 2*pi + (let ((r (drem-qd a +qd-2pi+))) + ;; Now reduce by pi/2 and then by pi/1024 so that we obtain + ;; numbers a, b, t + (multiple-value-bind (j tmp) + (divrem-qd r +qd-pi/2+) + (let* ((j (truncate (qd-0 j))) + (abs-j (abs j))) + (multiple-value-bind (k tmp) + (divrem-qd tmp +qd-pi/1024+) + (let* ((k (truncate (qd-0 k))) + (abs-k (abs k))) + (assert (<= abs-j 2)) + (assert (<= abs-k 256)) + ;; Compute sin(s) and cos(s) + (multiple-value-bind (sin-t cos-t) + (sincos-taylor tmp) + (multiple-value-bind (s c) + (cond ((zerop abs-k) + (values sin-t cos-t)) + (t + ;; Compute sin(s+k*pi/1024), cos(s+k*pi/1024) + (let ((u (aref +qd-cos-table+ (cl:1- abs-k))) + (v (aref +qd-sin-table+ (cl:1- abs-k)))) + (cond ((plusp k) + ;; sin(s) * cos(k*pi/1024) + ;; + cos(s) * sin(k*pi/1024) + ;; + ;; cos(s) * cos(k*pi/1024) + ;; - sin(s) * sin(k*pi/1024) + (values (add-qd (mul-qd u sin-t) + (mul-qd v cos-t)) + (sub-qd (mul-qd u cos-t) + (mul-qd v sin-t)))) + (t + ;; sin(s) * cos(k*pi/1024) + ;; - cos(s) * sin(|k|*pi/1024) + ;; + ;; cos(s) * cos(k*pi/1024) + ;; + sin(s) * sin(|k|*pi/1024) + (values (sub-qd (mul-qd u sin-t) + (mul-qd v cos-t)) + (add-qd (mul-qd u cos-t) + (mul-qd v sin-t)))))))) + ;;(format t "s = ~/qd::qd-format/~%" s) + ;;(format t "c = ~/qd::qd-format/~%" c) + ;; sin(x) = sin(s+k*pi/1024) * cos(j*pi/2) + ;; + cos(s+k*pi/1024) * sin(j*pi/2) + (cond ((zerop abs-j) + ;; cos(j*pi/2) = 1, sin(j*pi/2) = 0 + s) + ((= j 1) + ;; cos(j*pi/2) = 0, sin(j*pi/2) = 1 + c) + ((= j -1) + ;; cos(j*pi/2) = 0, sin(j*pi/2) = -1 + (neg-qd c)) + (t + ;; cos(j*pi/2) = -1, sin(j*pi/2) = 0 + (neg-qd s))))))))))) + +(defun cos-qd (a) + "Cos(a)" + ;; Just like sin-qd, but for cos. + (declare (type %quad-double a)) + ;; To compute sin(x), choose integers a, b so that + ;; + ;; x = s + a * (pi/2) + b*(pi/1024) + ;; + ;; with |x| <= pi/2048. Using a precomputed table of sin(k*pi/1024) + ;; and cos(k*pi/1024), we can compute sin(x) from sin(s) and cos(s). + ;; + ;; sin(x) = sin(s+k*(pi/1024) + j*pi/2) + ;; = sin(s+k*(pi/1024))*cos(j*pi/2) + ;; + cos(s+k*(pi/1024))*sin(j*pi/2) + ;; + ;; sin(s+k*pi/1024) = sin(s)*cos(k*pi/1024) + ;; + cos(s)*sin(k*pi/1024) + ;; + ;; cos(s+k*pi/1024) = cos(s)*cos(k*pi/1024) + ;; - sin(s)*sin(k*pi/1024) + (when (zerop-qd a) + (return-from cos-qd +qd-one+)) + + ;; Reduce modulo 2*pi + (let ((r (drem-qd a +qd-2pi+))) + ;; Now reduce by pi/2 and then by pi/1024 so that we obtain + ;; numbers a, b, t + (multiple-value-bind (j tmp) + (divrem-qd r +qd-pi/2+) + (let* ((j (truncate (qd-0 j))) + (abs-j (abs j))) + (multiple-value-bind (k tmp) + (divrem-qd tmp +qd-pi/1024+) + (let* ((k (truncate (qd-0 k))) + (abs-k (abs k))) + (assert (<= abs-j 2)) + (assert (<= abs-k 256)) + ;; Compute sin(s) and cos(s) + (multiple-value-bind (sin-t cos-t) + (sincos-taylor tmp) + (multiple-value-bind (s c) + (cond ((zerop abs-k) + (values sin-t cos-t)) + (t + ;; Compute sin(s+k*pi/1024), cos(s+k*pi/1024) + (let ((u (aref +qd-cos-table+ (cl:1- abs-k))) + (v (aref +qd-sin-table+ (cl:1- abs-k)))) + (cond ((plusp k) + ;; sin(s) * cos(k*pi/1024) + ;; + cos(s) * sin(k*pi/1024) + ;; + ;; cos(s) * cos(k*pi/1024) + ;; - sin(s) * sin(k*pi/1024) + (values (add-qd (mul-qd u sin-t) + (mul-qd v cos-t)) + (sub-qd (mul-qd u cos-t) + (mul-qd v sin-t)))) + (t + ;; sin(s) * cos(k*pi/1024) + ;; - cos(s) * sin(|k|*pi/1024) + ;; + ;; cos(s) * cos(k*pi/1024) + ;; + sin(s) * sin(|k|*pi/1024) + (values (sub-qd (mul-qd u sin-t) + (mul-qd v cos-t)) + (add-qd (mul-qd u cos-t) + (mul-qd v sin-t)))))))) + #+nil + (progn + (format t "s = ~/qd::qd-format/~%" s) + (format t "c = ~/qd::qd-format/~%" c)) + ;; sin(x) = sin(s+k*pi/1024) * cos(j*pi/2) + ;; + cos(s+k*pi/1024) * sin(j*pi/2) + (cond ((zerop abs-j) + ;; cos(j*pi/2) = 1, sin(j*pi/2) = 0 + c) + ((= j 1) + ;; cos(j*pi/2) = 0, sin(j*pi/2) = 1 + (neg-qd s)) + ((= j -1) + ;; cos(j*pi/2) = 0, sin(j*pi/2) = -1 + s) + (t + ;; cos(j*pi/2) = -1, sin(j*pi/2) = 0 + (neg-qd c))))))))))) + +;; Compute sin and cos of a +(defun sincos-qd (a) + (declare (type %quad-double a)) + (when (zerop-qd a) + (return-from sincos-qd + (values +qd-zero+ + +qd-one+))) + + ;; Reduce modulo 2*pi + (let ((r (drem-qd a +qd-2pi+))) + ;; Now reduce by pi/2 and then by pi/1024 so that we obtain + ;; numbers a, b, t + (multiple-value-bind (j tmp) + (divrem-qd r +qd-pi/2+) + (let* ((j (truncate (qd-0 j))) + (abs-j (abs j))) + (multiple-value-bind (k tmp) + (divrem-qd tmp +qd-pi/1024+) + (let* ((k (truncate (qd-0 k))) + (abs-k (abs k))) + (assert (<= abs-j 2)) + (assert (<= abs-k 256)) + ;; Compute sin(s) and cos(s) + (multiple-value-bind (sin-t cos-t) + (sincos-taylor tmp) + (multiple-value-bind (s c) + (cond ((zerop abs-k) + (values sin-t cos-t)) + (t + ;; Compute sin(s+k*pi/1024), cos(s+k*pi/1024) + (let ((u (aref +qd-cos-table+ (cl:1- abs-k))) + (v (aref +qd-sin-table+ (cl:1- abs-k)))) + (cond ((plusp k) + ;; sin(s) * cos(k*pi/1024) + ;; + cos(s) * sin(k*pi/1024) + ;; + ;; cos(s) * cos(k*pi/1024) + ;; - sin(s) * sin(k*pi/1024) + (values (add-qd (mul-qd u sin-t) + (mul-qd v cos-t)) + (sub-qd (mul-qd u cos-t) + (mul-qd v sin-t)))) + (t + ;; sin(s) * cos(k*pi/1024) + ;; - cos(s) * sin(|k|*pi/1024) + ;; + ;; cos(s) * cos(k*pi/1024) + ;; + sin(s) * sin(|k|*pi/1024) + (values (sub-qd (mul-qd u sin-t) + (mul-qd v cos-t)) + (add-qd (mul-qd u cos-t) + (mul-qd v sin-t)))))))) + #+nil + (progn + (format t "s = ~/qd::qd-format/~%" s) + (format t "c = ~/qd::qd-format/~%" c)) + ;; sin(x) = sin(s+k*pi/1024) * cos(j*pi/2) + ;; + cos(s+k*pi/1024) * sin(j*pi/2) + (cond ((zerop abs-j) + ;; cos(j*pi/2) = 1, sin(j*pi/2) = 0 + (values s c)) + ((= j 1) + ;; cos(j*pi/2) = 0, sin(j*pi/2) = 1 + (values c (neg-qd s))) + ((= j -1) + ;; cos(j*pi/2) = 0, sin(j*pi/2) = -1 + (values (neg-qd c) s)) + (t + ;; cos(j*pi/2) = -1, sin(j*pi/2) = 0 + (values (neg-qd s) + (neg-qd c)))))))))))) + + +(defun atan2-qd/newton (y x) + (declare (type %quad-double y x) + #+nil + (optimize (speed 3) (space 0))) + ;; Instead of using Taylor series to compute atan, we instead use + ;; Newton's iteration to solve the equation + ;; + ;; sin(z) = y/r or cos(z) = x/r + ;; + ;; where r = sqrt(x^2+y^2) + ;; + ;; The iteration is + ;; + ;; z' = z + (y - sin(z))/cos(z) (for sin) + ;; z' = z + (x - cos(z))/sin(z) (for cos) + ;; + ;; Here, x and y are normalized so that x^2 + y^2 = 1. + ;; + ;; If |x| > |y|, then the first iteration is used since the + ;; denominator is larger. Otherwise the second is used. + (cond ((zerop-qd x) + ;; x = 0 + (cond ((zerop-qd y) + ;; Both x and y are zero. Use the signs of x and y to + ;; determine the result + (error "atan2(0,0)")) + (t + ;; x = 0, but y is not. Use the sign of y. + (return-from atan2-qd/newton + (cond ((plusp (float-sign (qd-0 y))) + +qd-pi/2+) + (t + (neg-qd +qd-pi/2+))))))) + ((zerop-qd y) + ;; y = 0. + (return-from atan2-qd/newton + ;; Use the sign of x and y to figure out the result. + (cond ((plusp (float-sign (qd-0 x))) + +qd-zero+) + ((plusp (float-sign (qd-0 y))) + +qd-pi+) + (t + (neg-qd +qd-pi+)))))) + + (when (qd-= x y) + (return-from atan2-qd/newton + (if (plusp-qd y) + +qd-pi/4+ + +qd-3pi/4+))) + + (when (qd-= x (neg-qd y)) + (return-from atan2-qd/newton + (if (plusp-qd y) + +qd-3pi/4+ + (neg-qd +qd-pi/4+)))) + + (let* ((r (hypot-qd x y)) + (xx (div-qd x r)) + (yy (div-qd y r))) + #+nil + (progn + (format t "r = ~/qdi::qd-format/~%" r) + (format t "xx = ~/qdi::qd-format/~%" xx) + (format t "yy = ~/qdi::qd-format/~%" yy)) + + ;; Compute double-precision approximation to atan + (let ((z (make-qd-d (atan (qd-0 y) (qd-0 x)))) + (sinz +qd-zero+) + (cosz +qd-zero+)) + (cond ((> (abs (qd-0 xx)) + (abs (qd-0 yy))) + ;; Newton iteration z' = z + (y - sin(z))/cos(z) + (dotimes (k 3) + (multiple-value-setq (sinz cosz) (sincos-qd z)) + (setf z (add-qd z (div-qd (sub-qd yy sinz) + cosz))))) + (t + ;; Newton iteration z' = z - (x - cos(z))/sin(z) + (dotimes (k 3) + (multiple-value-setq (sinz cosz) (sincos-qd z)) + (setf z (sub-qd z (div-qd (sub-qd xx cosz) + sinz)))))) + z))) + +(defun atan-qd/newton (y) + (declare (type %quad-double y) + #+nil (optimize (speed 3) (space 0))) + (atan2-qd/newton y +qd-one+)) + +(defun atan2-qd (y x) + "atan2(y, x) = atan(y/x), but carefully handling the quadrant" + (declare (type %quad-double y x)) + (atan2-qd/newton y x)) + +(defun atan-qd (y) + "Atan4b*(y)" + (declare (type %quad-double y)) + (atan-qd/newton y)) + +(defun asin-qd (a) + "Asin(a)" + (declare (type %quad-double a)) + (atan2-qd a (sqrt-qd (sub-d-qd 1d0 + (sqr-qd a))))) + +(defun acos-qd (a) + "Acos(a)" + (declare (type %quad-double a)) + (atan2-qd (sqrt-qd (sub-d-qd 1d0 + (sqr-qd a))) + a)) + + +(defun tan-qd/sincos (r) + (declare (type %quad-double r)) + (multiple-value-bind (s c) + (sincos-qd r) + ;; What to do, what do? If C is zero, we get divide by zero + ;; error. We could return infinity, but quad-double stuff doesn't + ;; handle infinities very well. + (div-qd s c))) + +(defun tan-qd (r) + "Tan(r)" + (declare (type %quad-double r)) + (if (zerop r) + r + (tan-qd/sincos r))) + + +(defun sinh-qd (a) + "Sinh(a)" + (declare (type %quad-double a)) + ;; Hart et al. suggests sinh(x) = 1/2*(D(x) + D(x)/(D(x)+1)) + ;; where D(x) = exp(x) - 1. This helps for x near 0. + (cond ((zerop a) + a) + #+cmu + ((float-infinity-p (qd-0 a)) + a) + (t + (let ((d (expm1-qd a))) + #+cmu + (when (float-infinity-p (qd-0 d)) + (return-from sinh-qd d)) + (scale-float-qd (add-qd d + (div-qd d (add-qd-d d 1d0))) + -1))))) + +(defun cosh-qd (a) + "Cosh(a)" + (declare (type %quad-double a)) + ;; cosh(x) = 1/2*(exp(x)+exp(-x)) + (let ((e (exp-qd a))) + #+cmu + (when (float-infinity-p (qd-0 e)) + (return-from cosh-qd e)) + (scale-float-qd (add-qd e (div-qd +qd-one+ e)) + -1))) + +(defun tanh-qd (a) + "Tanh(a)" + (declare (type %quad-double a)) + ;; Hart et al. suggests tanh(x) = D(2*x)/(2+D(2*x)) + (cond ((zerop a) + a) + ((> (abs (qd-0 a)) (/ (+ (log most-positive-double-float) + (log 2d0)) + 4d0)) + ;; For this range of A, we know the answer is +/- 1. + ;; + ;; However, we could do better if we wanted. Assume x > 0 + ;; and very large. + ;; + ;; tanh(x) = sinh(x)/cosh(x) + ;; = (1-exp(-2*x))/(1+exp(-2*x)) + ;; = 1 - 2*exp(-2*x)/(1+exp(-2*x)) + ;; + ;; So tanh(x) is 1 if the other term is small enough, say, + ;; eps. So for x large enough we can compute tanh(x) very + ;; accurately, thanks to how quad-double addition works. + ;; (The first component is, basically 1d0, and the second is + ;; some very small double-float.) + #+nil + (let* ((e (exp (* -2 a))) + (res (- 1 (/ (* 2 e) (1+ e))))) + (if (minusp (float-sign (qd-0 a))) + (neg-qd res) + res)) + (make-qd-d (float-sign (qd-0 a)))) + (t + (let* ((a2 (mul-qd-d a 2d0)) + (d (expm1-qd a2))) + (div-qd d (add-qd-d d 2d0)))))) + +(defun asinh-qd (a) + "Asinh(a)" + (declare (type %quad-double a)) + ;; asinh(x) = log(x + sqrt(1+x^2)) + ;; + ;; But this doesn't work well when x is small. + ;; + ;; log(x + sqrt(1+x^2)) = log(sqrt(1+x^2)*(1+x/sqrt(1+x^2))) + ;; = log(sqrt(1+x^2)) + log(1+x/sqrt(1+x^2)) + ;; = 1/2*log(1+x^2) + log(1+x/sqrt(1+x^2)) + ;; + ;; However that doesn't work well when x is large because x^2 + ;; overflows. + ;; + ;; log(x + sqrt(1+x^2)) = log(x + x*sqrt(1+1/x^2)) + ;; = log(x) + log(1+sqrt(1+1/x^2)) + ;; = log(x) + log1p(sqrt(1+1/x^2)) + #+nil + (log-qd (add-qd a + (sqrt-qd (add-qd-d (sqr-qd a) + 1d0)))) + (if (< (abs (qd-0 a)) (sqrt most-positive-double-float)) + (let ((a^2 (sqr-qd a))) + (add-qd (scale-float-qd (log1p-qd a^2) -1) + (log1p-qd (div-qd a + (sqrt-qd (add-qd-d a^2 1d0)))))) + (if (minusp-qd a) + (neg-qd (asinh-qd (neg-qd a))) + (let ((1/a (div-qd (make-qd-d 1d0) a))) + (+ (log-qd a) + (log1p-qd (sqrt-qd (add-qd-d (sqr-qd 1/a) 1d0)))))))) + +(defun asinh-qd (a) + "Asinh(a)" + (declare (type %quad-double a)) + ;; asinh(x) = log(x + sqrt(1+x^2)) + ;; + ;; But this doesn't work well when x is small. + ;; + ;; log(x + sqrt(1+x^2)) = log(sqrt(1+x^2)*(1+x/sqrt(1+x^2))) + ;; = log(sqrt(1+x^2)) + log(1+x/sqrt(1+x^2)) + ;; = 1/2*log(1+x^2) + log(1+x/sqrt(1+x^2)) + ;; + ;; However that doesn't work well when x is large because x^2 + ;; overflows. + ;; + ;; log(x + sqrt(1+x^2)) = log(x + x*sqrt(1+1/x^2)) + ;; = log(x) + log(1+sqrt(1+1/x^2)) + ;; = log(x) + log1p(sqrt(1+1/x^2)) + #+nil + (log-qd (add-qd a + (sqrt-qd (add-qd-d (sqr-qd a) + 1d0)))) + (cond ((< (abs (qd-0 a)) (sqrt most-positive-double-float)) + (let ((a^2 (sqr-qd a))) + (add-qd (scale-float-qd (log1p-qd a^2) -1) + (log1p-qd (div-qd a + (sqrt-qd (add-qd-d a^2 1d0))))))) + #+cmu + ((float-infinity-p (qd-0 a)) + a) + (t + (if (minusp-qd a) + (neg-qd (asinh-qd (neg-qd a))) + (let ((1/a (div-qd (make-qd-d 1d0) a))) + (+ (log-qd a) + (log1p-qd (sqrt-qd (add-qd-d (sqr-qd 1/a) 1d0))))))))) + +(defun acosh-qd (a) + "Acosh(a)" + (declare (type %quad-double a)) + ;; acosh(x) = log(x + sqrt(x^2-1)) + #+nil + (log-qd (add-qd a + (sqrt-qd (sub-qd-d (sqr-qd a) + 1d0)))) + ;; log(x+sqrt(x^2-1)) = log(x+sqrt((x-1)*(x+1))) + ;; = log(x+sqrt(x-1)*sqrt(x+1)) + #+nil + (log-qd (add-qd a + (mul-qd + (sqrt-qd (sub-qd-d a 1d0)) + (sqrt-qd (add-qd-d a 1d0))))) + ;; Let x = 1 + y + ;; log(1 + y + sqrt(y)*sqrt(y + 2)) + ;; = log1p(y + sqrt(y)*sqrt(y + 2)) + ;; + ;; However, that doesn't work well if x is large. + ;; + ;; log(x+sqrt(x^2-1)) = log(x+x*sqrt(1-1/x^2)) + ;; = log(x) + log(1+sqrt(1-1/x^2)) + ;; = log(x) + log1p(sqrt(1-1/x)*sqrt(1+1/x)) + ;; + (cond ((< (abs (qd-0 a)) (sqrt most-positive-double-float)) + (let ((y (sub-qd-d a 1d0))) + (log1p-qd (add-qd y (sqrt-qd (mul-qd y (add-qd-d y 2d0))))))) + #+cmu + ((float-infinity-p (qd-0 a)) + a) + (t + (let ((1/a (div-qd (make-qd-d 1d0) a))) + (+ (log-qd a) + (log1p-qd (mul-qd (sqrt-qd (sub-d-qd 1d0 1/a)) + (sqrt-qd (add-d-qd 1d0 1/a))))))))) + +(defun atanh-qd (a) + "Atanh(a)" + (declare (type %quad-double a)) + ;; atanh(x) = 1/2*log((1+x)/(1-x)) + ;; = 1/2*log(1+(2*x)/(1-x)) + ;; This latter expression works better for small x + #+nil + (scale-float-qd (log-qd (div-qd (add-d-qd 1d0 a) + (sub-d-qd 1d0 a))) + -1) + ;; atanh(+/-1) = +/- infinity. Signal a division by zero or return + ;; infinity if the division-by-zero trap is disabled. + (if (qd-= (abs-qd a) +qd-one+) + (div-qd (make-qd-d (float-sign (qd-0 a))) + +qd-zero+) + (scale-float-qd (log1p-qd (div-qd (scale-float-qd a 1) + (sub-d-qd 1d0 a))) + -1))) + + +(defun random-qd (&optional (state *random-state*)) + "Generate a quad-double random number in the range [0,1)" + (declare (optimize (speed 3))) + ;; Strategy: Generate 31 bits at a time, shift the bits and repeat 7 times. + (let* ((r +qd-zero+) + (m-const (scale-float 1d0 -31)) + (m m-const)) + (declare (type %quad-double r) + (double-float m-const m)) + (dotimes (k 7) + (let ((d (cl:* m (random #x7fffffff state)))) + (setf r (add-qd-d r d)) + (setf m (cl:* m m-const)))) + r)) + diff --git a/external/oct/qd-io.lisp b/external/oct/qd-io.lisp new file mode 100644 index 0000000..052128f --- /dev/null +++ b/external/oct/qd-io.lisp @@ -0,0 +1,472 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qdi) + +;; Smallest exponent for a double-float. +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant +double-float-min-e+ + -1073) + +(defconstant +digits+ + "0123456789") +) ; eval-when + +(defun qd-to-digits (v &optional position relativep) + ;; V is the number to be printed. If RELATIVEP is NIL, POSITION is + ;; the number of digits to the left of the decimal point where we + ;; want to stop printing. If RELATIVEP is non-NIL, POSITION is the + ;; total number of digits we want printed. + ;; + ;; Two values are returned: k, and the digit string, without a + ;; decimal point. k is the index into the string, before which the + ;; decimal point would go. + (let ((print-base 10) ; B + (float-radix 2) ; b + (float-digits (cl:* 4 53)) ; p + (min-e +double-float-min-e+)) + (multiple-value-bind (f e) + (integer-decode-qd v) + (let ( ;; FIXME: these even tests assume normal IEEE rounding + ;; mode. I wonder if we should cater for non-normal? + (high-ok (evenp f)) + (low-ok (evenp f)) + (result (make-array 50 :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (labels ((scale (r s m+ m-) + ;; Keep increasing k until it's big enough + (do ((k 0 (1+ k)) + (s s (cl:* s print-base))) + ((not (let ((test (cl:+ r m+))) + (or (> test s) + (and high-ok (= test s))))) + ;; k is too big. Decrease until + (do ((k k (1- k)) + (r r (cl:* r print-base)) + (m+ m+ (cl:* m+ print-base)) + (m- m- (cl:* m- print-base))) + ((not (let ((test (cl:* (cl:+ r m+) print-base))) + (or (< test s) + (and (not high-ok) (= test s))))) + ;; k is correct. Generate the digits. + (values k (generate r s m+ m-))))))) + (generate (r s m+ m-) + (multiple-value-bind (d r) + (truncate (cl:* r print-base) s) + (let ((m+ (cl:* m+ print-base)) + (m- (cl:* m- print-base))) + (let ((tc1 (or (< r m-) (and low-ok (= r m-)))) + (tc2 (let ((test (cl:+ r m+))) + (or (> test s) + (and high-ok (= test s)))))) + (cond + ((and (not tc1) (not tc2)) + (vector-push-extend (char +digits+ d) result) + ;; FIXME sucky tail recursion. This whole + ;; kaboodle should be DO*/LOOPified. + (generate r s m+ m-)) + ;; pedantically keeping all the conditions + ;; in so that we can move them around. + ((and (not tc1) tc2) + (vector-push-extend (char +digits+ (1+ d)) result) + result) + ((and tc1 (not tc2)) + (vector-push-extend (char +digits+ d) result) + result) + ((and tc1 tc2) + (vector-push-extend (char +digits+ + (if (< (cl:* r 2) s) d (1+ d))) + result) + result))))))) + (let (r s m+ m-) + (if (>= e 0) + (let* ((be (expt float-radix e)) + (be1 (cl:* be float-radix))) + (if (/= f (expt float-radix (1- + float-digits))) + (setf r (cl:* f be 2) + s 2 + m+ be + m- be) + (setf r (cl:* f be1 2) + s (cl:* float-radix 2) + m+ be1 + m- be))) + (if (or (= e min-e) + (/= f (expt float-radix (1- + float-digits)))) + (setf r (cl:* f 2) + s (cl:* (expt float-radix (cl:- e)) 2) + m+ 1 + m- 1) + (setf r (cl:* f float-radix 2) + s (cl:* (expt float-radix (cl:- 1 e)) 2) + m+ float-radix + m- 1))) + (when position + (when relativep + ;;(aver (> position 0)) + (do ((k 0 (1+ k)) + ;; running out of letters here + (l 1 (cl:* l print-base))) + ((>= (cl:* s l) (cl:+ r m+)) + ;; k is now \hat{k} + (if (< (cl:+ r (cl:* s (cl:/ (expt print-base (cl:- k + position)) 2))) + (cl:* s (expt print-base k))) + (setf position (cl:- k position)) + (setf position (cl:- k position 1)))))) + (let ((low (max m- (cl:/ (cl:* s (expt print-base + position)) 2))) + (high (max m+ (cl:/ (cl:* s (expt print-base + position)) 2)))) + (when (<= m- low) + (setf m- low) + (setf low-ok t)) + (when (<= m+ high) + (setf m+ high) + (setf high-ok t)))) + (scale r s m+ m-))))))) + +(defun qd-print-exponent (x exp stream) + (let ((*print-radix* nil)) + (format stream "q~D" exp))) + +(defun qd-to-string (x &optional width fdigits scale fmin) + (setf x (abs-qd x)) + (cond ((zerop-qd x) + ;;zero is a special case which float-string cannot handle + (if fdigits + (let ((s (make-string (1+ fdigits) :initial-element #\0))) + (setf (schar s 0) #\.) + (values s (length s) t (zerop fdigits) 0)) + (values "." 1 t t 0))) + (t + (multiple-value-bind (e string) + (if fdigits + (qd-to-digits x (min (- (+ fdigits (or scale 0))) + (- (or fmin 0)))) + (if (and width (> width 1)) + (let ((w (multiple-value-list + (qd-to-digits x + (max 0 + (+ (1- width) + (if (and scale (minusp scale)) + scale 0))) + t))) + (f (multiple-value-list + (qd-to-digits x (- (+ (or fmin 0) + (if scale scale 0))))))) + (cond + ((>= (length (cadr w)) (length (cadr f))) + (values-list w)) + (t (values-list f)))) + (qd-to-digits x))) + (let ((e (+ e (or scale 0))) + (stream (make-string-output-stream))) + (if (plusp e) + (progn + (write-string string stream :end (min (length string) + e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) + e)) + (when fdigits + (dotimes (i (- fdigits + (- (length string) + (min (length string) e)))) + (write-char #\0 stream)))) + (progn + (write-string "." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + ;; If we're out of room (because fdigits is too + ;; small), don't print out our string. This fixes + ;; things like (format nil "~,2f" 0.001). We should + ;; print ".00", not ".001". + (when (or (null fdigits) + (plusp (+ e fdigits))) + (write-string string stream)) + (when fdigits + (dotimes (i (+ fdigits e (- (length string)))) + (write-char #\0 stream))))) + (let ((string (get-output-stream-string stream))) + (values string (length string) + (char= (char string 0) #\.) + (char= (char string (1- (length string))) #\.) + (position #\. string)))))))) + + +(defun qd-output-aux (x &optional (stream *standard-output*)) + (if (zerop-qd x) + (write-string (if (minusp (float-sign (qd-0 x))) + "-0.0q0" + "0.0q0") + stream) + (multiple-value-bind (e string) + (qd-to-digits x) + (when (minusp (float-sign (qd-0 x))) + (write-char #\- stream)) + (cond ((< -3 e 8) + ;; Free format + (cond ((plusp e) + (write-string string stream :end (min (length string) e)) + (dotimes (i (cl:- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) e)) + (when (<= (length string) e) + (write-char #\0 stream)) + (qd-print-exponent x 0 stream)) + (t + (write-string "0." stream) + (dotimes (i (cl:- e)) + (write-char #\0 stream)) + (write-string string stream) + (qd-print-exponent x 0 stream)))) + (t + ;; Exponential format + (write-string string stream :end 1) + (write-char #\. stream) + (write-string string stream :start 1) + ;; CLHS 22.1.3.1.3 says at least one digit must be printed + ;; after the decimal point. + (when (= (length string) 1) + (write-char #\0 stream)) + (qd-print-exponent x (1- e) stream)))))) + +;; Function that can be used with FORMAT ~/ +#-cmu +(defun qd-format (stream arg colon-p at-sign-p &rest par) + ;; We should do something with colon-p and at-sign-p + (declare (ignore colon-p at-sign-p par)) + (write-string "#q" stream) + (qd-output-aux arg stream)) + +#+cmu +(defun qd-output-infinity (x stream) + (cond (*read-eval* + (write-string "#." stream)) + (*print-readably* + (error 'print-not-readable :object x)) + (t + (write-string "#<" stream))) + (write-string "QD:+QUAD-DOUBLE-FLOAT" stream) + (write-string (if (plusp (qd-0 x)) + "-POSITIVE-" + "-NEGATIVE-") + stream) + (write-string "INFINITY+" stream) + (unless *read-eval* + (write-string ">" stream))) + +#+cmu +(defun qd-output-nan (x stream) + (print-unreadable-object (x stream) + (write-string "QUAD-DOUBLE-FLOAT" stream) + (write-string (if (float-trapping-nan-p (qd-0 x)) " Trapping" " Quiet") stream) + (write-string " NaN" stream))) + +#+cmu +(defun qd-format (stream arg colon-p at-sign-p &rest par) + (declare (type %quad-double arg) + (stream stream)) + ;; We should do something with colon-p and at-sign-p + (declare (ignore colon-p at-sign-p par)) + (cond ((ext:float-infinity-p (qd-0 arg)) + (qd-output-infinity arg stream)) + ((ext:float-nan-p (qd-0 arg)) + (qd-output-nan arg stream)) + (t + (qd-output-aux arg stream)))) + +(defun make-float (sign int-part frac-part scale exp) + (declare (type (member -1 1) sign) + (type unsigned-byte int-part frac-part) + (fixnum scale exp)) + #+(or) + (progn + (format t "sign = ~A~%" sign) + (format t "int-part = ~A~%" int-part) + (format t "frac-part = ~A~%" frac-part) + (format t "scale = ~A~%" scale) + (format t "exp = ~A~%" exp)) + (let ((int (cl:+ (cl:* int-part (expt 10 scale)) + frac-part)) + (power (cl:- exp scale))) + #+(or) + (format t "~A * ~A * 10^(~A)~%" sign int power) + (let* ((len (integer-length int))) + #+(or) + (format t "len = ~A~%" len) + (cond ((<= len 53) + (let ((xx (make-qd-d (float int 1d0))) + (yy (npow (make-qd-d 10d0) + power))) + #+(or) + (progn + (format t "int = ~A~%" int) + (format t "fl = ~A~%" (float int 1w0)) + (format t "s = ~A~%" sign) + (format t "sint = ~A~%" (cl:* sign (float int 1w0))) + (format t "~A~%" xx) + (format t "npow = ~A~%" yy)) + (if (minusp sign) + (neg-qd (mul-qd xx yy)) + (mul-qd xx yy)))) + (t + (let* #+nil + ((hi (ldb (byte 106 (cl:- len 106)) int)) + (lo (ldb (byte 106 (cl:- len 212)) int)) + (xx (make-qd-dd (cl:* sign (scale-float (float hi 1w0) + (cl:- len 106))) + (cl:* sign (scale-float (float lo 1w0) + (cl:- len 106 106))))) + (yy (npow (make-qd-d 10d0) + power))) + ((q0 (ldb (byte 53 (cl:- len 53)) int)) + (q1 (ldb (byte 53 (cl:- len (* 2 53))) int)) + (q2 (ldb (byte 53 (cl:- len (* 3 53))) int)) + (q3 (ldb (byte 53 (cl:- len (* 4 53))) int)) + (xx (make-qd-d (scale-float (float q0 1d0) + (cl:- len 53)) + (scale-float (float q1 1d0) + (cl:- len (* 2 53))) + (scale-float (float q2 1d0) + (cl:- len (* 3 53))) + (scale-float (float q3 1d0) + (cl:- len (* 4 53))))) + (yy (npow (make-qd-d 10d0) + power))) + #+(or) + (progn + (format t "xx = ~A~%" xx) + #+(or) + (format t " = ~/qd::qd-format/~%" xx) + (format t "yy = ~A~%" yy) + #+(or) + (format t " = ~/qd::qd-format/~%" yy) + (format t "q0 = ~X (~A)~%" q0 + (scale-float (float q0 1d0) + (cl:- len 53))) + (format t "q1 = ~X (~A)~%" q1 + (scale-float (float q1 1d0) + (cl:- len (* 2 53)))) + #+(or) + (format t "~/qdi::qd-format/~%" (mul-qd xx yy))) + (if (minusp sign) + (neg-qd (mul-qd xx yy)) + (mul-qd xx yy)))))))) + +;; This seems to work, but really needs to be rewritten! +(defun read-qd (stream) + (labels ((read-digits (s) + ;; Read a sequence of digits and return the decimal + ;; value, the character that terminated the sequence, and + ;; how many characters were read. + (let ((val 0) + (ch nil) + (count 0)) + (loop + (setf ch (peek-char nil s nil :eof)) + (cond ((eq ch :eof) + (return)) + ((digit-char-p ch) + (read-char s) + (incf count) + (setf val (cl:+ (digit-char-p ch) + (cl:* 10 val)))) + (t + (return)))) + (values ch val count))) + (read-sign (s) + (let ((maybe-sign (peek-char t s nil :eof))) + (cond ((eql maybe-sign #\-) + (read-char s) + -1 + ) + ((eql maybe-sign #\+) + (read-char s) + +1) + ((and (characterp maybe-sign) + (digit-char-p maybe-sign)) + +1) + ((eql maybe-sign #\.) + +1) + (t + maybe-sign)))) + (read-exp (s) + (let ((exp-sign (read-sign s))) + (when (eq :eof exp-sign) + (return-from read-exp 0)) + (when (eq :eof (peek-char t s nil :eof)) + (error "Sign of exponent, but no value")) + (multiple-value-bind (char expo) + (read-digits s) + (declare (ignore char)) + (cl:* exp-sign expo))))) + (let ((sign (read-sign stream)) + (int-part 0) + (frac-part 0) + (exp 0) + (scale 0)) + (when (eq :eof (peek-char t stream nil :eof)) + (error "Sign, but no value")) + (multiple-value-bind (char int) + (read-digits stream) + (setf int-part int) + (cond ((eql :eof char) + ) + ((eql char #\.) + (read-char stream) + (multiple-value-bind (char val scale-val) + (read-digits stream) + (declare (ignore char)) + (setf frac-part val) + (setf scale scale-val) + (let ((next (peek-char nil stream nil :eof))) + (when (equalp next #\q) + (read-char stream) + (let ((exp-sign (read-sign stream))) + (setf exp (read-exp stream)) + (setf exp (cl:* exp exp-sign))))))) + ((equalp char #\q) + (read-char stream) + (setf exp (read-exp stream)) + )) + (make-float sign int-part frac-part scale exp))))) + +(defun qd-reader (stream subchar arg) + (read-qd stream)) + +(defun qd-from-string (string) + (cl::with-input-from-string (s string) + (read-qd s))) + +#+nil +(set-dispatch-macro-character #\# #\Q #'qd-reader) + diff --git a/external/oct/qd-methods.lisp b/external/oct/qd-methods.lisp new file mode 100644 index 0000000..980a3c1 --- /dev/null +++ b/external/oct/qd-methods.lisp @@ -0,0 +1,896 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qd) + +(defconstant +pi+ + (make-instance 'qd-real :value qdi:+qd-pi+)) + +#+cmu +(defconstant +quad-double-float-positive-infinity+ + (make-instance 'qd-real :value (make-qd-d ext:double-float-positive-infinity)) + "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)) + "Negative infinity for qd-real") + +(defconstant +most-positive-quad-double-float+ + (make-instance 'qd-real + :value (qdi::%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))))) + +(defconstant +least-positive-quad-double-float+ + (make-instance 'qd-real + :value (make-qd-d least-positive-double-float))) + +;; 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))))) + +(defconstant +qd-real-one+ + (make-instance 'qd-real :value (make-qd-d 1d0))) + +(defmethod add1 ((a number)) + (cl::1+ a)) + +(defmethod add1 ((a qd-real)) + (make-instance 'qd-real :value (add-qd-d (qd-value a) 1d0))) + +(defmethod sub1 ((a number)) + (cl::1- a)) + +(defmethod sub1 ((a qd-real)) + (make-instance 'qd-real :value (sub-qd-d (qd-value a) 1d0))) + +(declaim (inline 1+ 1-)) + +(defun 1+ (x) + (add1 x)) + +(defun 1- (x) + (sub1 x)) + +(defmethod two-arg-+ ((a qd-real) (b qd-real)) + (make-instance 'qd-real :value (add-qd (qd-value a) (qd-value b)))) + +(defmethod two-arg-+ ((a qd-real) (b cl:float)) + (make-instance 'qd-real :value (add-qd-d (qd-value a) (cl:float b 1d0)))) + +#+cmu +(defmethod two-arg-+ ((a qd-real) (b ext:double-double-float)) + (make-instance 'qd-real :value (add-qd-dd (qd-value a) b))) + +(defmethod two-arg-+ ((a real) (b qd-real)) + (+ b a)) + +(defmethod two-arg-+ ((a number) (b number)) + (cl:+ a b)) + +(defun + (&rest args) + (if (null args) + 0 + (do ((args (cdr args) (cdr args)) + (res (car args) + (two-arg-+ res (car args)))) + ((null args) res)))) + +(defmethod two-arg-- ((a qd-real) (b qd-real)) + (make-instance 'qd-real :value (sub-qd (qd-value a) (qd-value b)))) + +(defmethod two-arg-- ((a qd-real) (b cl:float)) + (make-instance 'qd-real :value (sub-qd-d (qd-value a) (cl:float b 1d0)))) + +#+cmu +(defmethod two-arg-- ((a qd-real) (b ext:double-double-float)) + (make-instance 'qd-real :value (sub-qd-dd (qd-value a) b))) + +(defmethod two-arg-- ((a cl:float) (b qd-real)) + (make-instance 'qd-real :value (sub-d-qd (cl:float a 1d0) (qd-value b)))) + +(defmethod two-arg-- ((a number) (b number)) + (cl:- a b)) + +(defmethod unary-minus ((a number)) + (cl:- a)) + +(defmethod unary-minus ((a qd-real)) + (make-instance 'qd-real :value (neg-qd (qd-value a)))) + +(defun - (number &rest more-numbers) + (if more-numbers + (do ((nlist more-numbers (cdr nlist)) + (result number)) + ((atom nlist) result) + (declare (list nlist)) + (setq result (two-arg-- result (car nlist)))) + (unary-minus number))) + + +(defmethod two-arg-* ((a qd-real) (b qd-real)) + (make-instance 'qd-real :value (mul-qd (qd-value a) (qd-value b)))) + +(defmethod two-arg-* ((a qd-real) (b cl:float)) + (make-instance 'qd-real :value (mul-qd-d (qd-value a) (cl:float b 1d0)))) + +#+cmu +(defmethod two-arg-* ((a qd-real) (b ext:double-double-float)) + ;; We'd normally want to use mul-qd-dd, but mul-qd-dd is broken. + (make-instance 'qd-real :value (mul-qd (qd-value a) + (make-qd-dd b 0w0)))) + +(defmethod two-arg-* ((a real) (b qd-real)) + (* b a)) + +(defmethod two-arg-* ((a number) (b number)) + (cl:* a b)) + +(defun * (&rest args) + (if (null args) + 1 + (do ((args (cdr args) (cdr args)) + (res (car args) + (two-arg-* res (car args)))) + ((null args) res)))) + +(defmethod two-arg-/ ((a qd-real) (b qd-real)) + (make-instance 'qd-real :value (div-qd (qd-value a) (qd-value b)))) + +(defmethod two-arg-/ ((a qd-real) (b cl:float)) + (make-instance 'qd-real :value (div-qd-d (qd-value a) (cl:float b 1d0)))) + +#+cmu +(defmethod two-arg-/ ((a qd-real) (b ext:double-double-float)) + (make-instance 'qd-real :value (div-qd-dd (qd-value a) + b))) + +(defmethod two-arg-/ ((a cl:float) (b qd-real)) + (make-instance 'qd-real :value (div-qd (make-qd-d (cl:float a 1d0)) + (qd-value b)))) + +#+cmu +(defmethod two-arg-/ ((a ext:double-double-float) (b qd-real)) + (make-instance 'qd-real :value (div-qd (make-qd-dd a 0w0) + (qd-value b)))) + +(defmethod two-arg-/ ((a number) (b number)) + (cl:/ a b)) + +(defmethod unary-divide ((a number)) + (cl:/ a)) + +(defmethod unary-divide ((a qd-real)) + (make-instance 'qd-real :value (div-qd +qd-one+ (qd-value a)))) + +(defun / (number &rest more-numbers) + (if more-numbers + (do ((nlist more-numbers (cdr nlist)) + (result number)) + ((atom nlist) result) + (declare (list nlist)) + (setq result (two-arg-/ result (car nlist)))) + (unary-divide number))) + +(macrolet ((frob (name &optional (type 'real)) + (let ((method-name (intern (concatenate 'string "Q" (symbol-name name)))) + (cl-name (intern (symbol-name name) :cl)) + (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) + `(progn + (defmethod ,method-name ((x ,type)) + (,cl-name x)) + (defmethod ,method-name ((x qd-real)) + (,qd-name (qd-value x))) + (declaim (inline ,name)) + (defun ,name (x) + (,method-name x)))))) + (frob zerop number) + (frob plusp) + (frob minusp)) + +(defun bignum-to-qd (bignum) + (make-instance 'qd-real + :value (qdi::make-float (if (minusp bignum) -1 1) + (abs bignum) + 0 + 0 + 0))) + +(defmethod qfloat ((x real) (num-type cl:float)) + (cl:float x num-type)) + +(defmethod qfloat ((x cl:float) (num-type qd-real)) + (make-instance 'qd-real :value (make-qd-d (cl:float x 1d0)))) + +(defmethod qfloat ((x integer) (num-type qd-real)) + (cond ((typep x 'fixnum) + (make-instance 'qd-real :value (make-qd-d (cl:float x 1d0)))) + (t + ;; A bignum + (bignum-to-qd x)))) + +#+nil +(defmethod qfloat ((x ratio) (num-type qd-real)) + ;; This probably has some issues with roundoff + (two-arg-/ (qfloat (numerator x) num-type) + (qfloat (denominator x) num-type))) + +(defmethod qfloat ((x ratio) (num-type qd-real)) + ;; This probably has some issues with roundoff + (let ((top (qd-value (qfloat (numerator x) num-type))) + (bot (qd-value (qfloat (denominator x) num-type)))) + (make-instance 'qd-real :value (div-qd top bot)))) + +#+cmu +(defmethod qfloat ((x ext:double-double-float) (num-type qd-real)) + (make-instance 'qd-real :value (make-qd-dd x 0w0))) + +(defmethod qfloat ((x qd-real) (num-type cl:float)) + (multiple-value-bind (q0 q1 q2 q3) + (qd-parts (qd-value x)) + (cl:float (cl:+ q0 q1 q2 q3) num-type))) + +#+cmu +(defmethod qfloat ((x qd-real) (num-type ext:double-double-float)) + (multiple-value-bind (q0 q1 q2 q3) + (qd-parts (qd-value x)) + (cl:+ (cl:float q0 1w0) + (cl:float q1 1w0) + (cl:float q2 1w0) + (cl:float q3 1w0)))) + +(defmethod qfloat ((x qd-real) (num-type qd-real)) + x) + +(declaim (inline float)) +(defun float (x num-type) + (qfloat x num-type)) + +(defmethod qrealpart ((x number)) + (cl:realpart x)) +(defmethod qrealpart ((x qd-real)) + x) +(defmethod qrealpart ((x qd-complex)) + (make-instance 'qd-real :value (qd-real x))) +(defun realpart (x) + (qrealpart x)) + +(defmethod qimagpart ((x number)) + (cl:imagpart x)) +(defmethod qimagpart ((x qd-real)) + (make-qd 0d0)) +(defmethod qimagpart ((x qd-complex)) + (make-instance 'qd-real :value (qd-imag x))) + +(defun imagpart (x) + (qimagpart x)) + +(defmethod qconjugate ((a number)) + (cl:conjugate a)) + +(defmethod qconjugate ((a qd-real)) + (make-instance 'qd-real :value (qd-value a))) + +(defmethod qconjugate ((a qd-complex)) + (make-instance 'qd-complex + :real (qd-real a) + :imag (neg-qd (qd-imag a)))) + +(defun conjugate (z) + (qconjugate z)) + +(defmethod qscale-float ((f cl:float) (n integer)) + (cl:scale-float f n)) + +(defmethod qscale-float ((f qd-real) (n integer)) + (make-instance 'qd-real :value (scale-float-qd (qd-value f) n))) + +(declaim (inline scale-float)) +(defun scale-float (f n) + (qscale-float f n)) + +(macrolet + ((frob (op) + (let ((method (intern (concatenate 'string "TWO-ARG-" (symbol-name op)))) + (cl-fun (find-symbol (symbol-name op) :cl)) + (qd-fun (intern (concatenate 'string "QD-" (symbol-name op)) + (find-package :qdi)))) + `(progn + (defmethod ,method ((a real) (b real)) + (,cl-fun a b)) + (defmethod ,method ((a qd-real) (b real)) + (,qd-fun (qd-value a) (make-qd-d (cl:float b 1d0)))) + (defmethod ,method ((a real) (b qd-real)) + (,qd-fun (make-qd-d (cl:float a 1d0)) (qd-value b))) + (defmethod ,method ((a qd-real) (b qd-real)) + (,qd-fun (qd-value a) (qd-value b))) + (defun ,op (number &rest more-numbers) + "Returns T if its arguments are in strictly increasing order, NIL otherwise." + (declare (optimize (safety 2)) + (dynamic-extent more-numbers)) + (do* ((n number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (if (not (,method n (car nlist))) (return nil)))))))) + (frob <) + (frob >) + (frob <=) + (frob >=)) + +(macrolet ((frob (name) + (let ((method-name (intern (concatenate 'string "Q" (symbol-name name)))) + (cl-name (intern (symbol-name name) :cl)) + (qd-name (intern (concatenate 'string (symbol-name name) "-QD")))) + `(progn + (defmethod ,method-name ((x number)) + (,cl-name x)) + (defmethod ,method-name ((x qd-real)) + (make-instance 'qd-real :value (,qd-name (qd-value x)))) + (declaim (inline ,name)) + (defun ,name (x) + (,method-name x)))))) + (frob abs) + (frob exp) + (frob sin) + (frob cos) + (frob tan) + ;;(frob asin) + ;;(frob acos) + (frob sinh) + (frob cosh) + (frob tanh) + (frob asinh) + ;;(frob acosh) + ;;(frob atanh) + ) + +(defmethod qsqrt ((x number)) + (cl:sqrt x)) + +(defmethod qsqrt ((x qd-real)) + (if (minusp x) + (make-instance 'qd-complex + :real +qd-zero+ + :imag (sqrt-qd (neg-qd (qd-value x)))) + (make-instance 'qd-real :value (sqrt-qd (qd-value x))))) + +(defun sqrt (x) + (qsqrt x)) + +(defun scalb (x n) + "Compute 2^N * X without compute 2^N first (use properties of the +underlying floating-point format" + (declare (type qd-real x)) + (scale-float x n)) + +(declaim (inline qd-cssqs)) +(defun qd-cssqs (z) + (multiple-value-bind (rho k) + (qdi::hypot-aux-qd (qd-value (realpart z)) + (qd-value (imagpart z))) + (values (make-instance 'qd-real :value rho) + k))) + +#+nil +(defmethod qabs ((z qd-complex)) + ;; sqrt(x^2+y^2) + ;; If |x| > |y| then sqrt(x^2+y^2) = |x|*sqrt(1+(y/x)^2) + (multiple-value-bind (abs^2 rho) + (hypot-qd (qd-value (realpart z)) + (qd-value (imagpart z))) + (scale-float (make-instance 'qd-real :value (sqrt abs^2)) + rho))) + +(defmethod qabs ((z qd-complex)) + ;; sqrt(x^2+y^2) + ;; If |x| > |y| then sqrt(x^2+y^2) = |x|*sqrt(1+(y/x)^2) + (make-instance 'qd-real + :value (hypot-qd (qd-value (realpart z)) + (qd-value (imagpart z))))) + +(defmethod qlog ((a number) &optional b) + (if b + (cl:log a b) + (cl:log a))) + +(defmethod qlog ((a qd-real) &optional b) + (if b + (/ (qlog a) (qlog b)) + (if (minusp (float-sign a)) + (make-instance 'qd-complex + :real (log-qd (abs-qd (qd-value a))) + :imag +qd-pi+) + (make-instance 'qd-real :value (log-qd (qd-value a)))))) + +(declaim (inline log)) +(defun log (a &optional b) + (qlog a b)) + + +(defmethod log1p ((a qd-real)) + (make-instance 'qd-real :value (log1p-qd (qd-value a)))) + +(defmethod qatan ((y real) &optional x) + (cond (x + (cond ((typep x 'qd-real) + (make-instance 'qd-real + :value (atan2-qd (qd-value y) (qd-value x)))) + (t + (cl:atan y x)))) + (t + (cl:atan y)))) + +(defmethod qatan ((y qd-real) &optional x) + (make-instance 'qd-real + :value + (if x + (atan2-qd (qd-value y) (qd-value x)) + (atan-qd (qd-value y))))) + +(defun atan (y &optional x) + (qatan y x)) + + +(defmethod qexpt ((x number) (y number)) + (cl:expt x y)) + +(defmethod qexpt ((x qd-real) (y real)) + (exp (* y (log x)))) + +(defmethod qexpt ((x real) (y qd-real)) + (exp (* y (log x)))) + +(defmethod qexpt ((x qd-real) (y cl:complex)) + (exp (* (make-instance 'qd-complex + :real (qd-value (realpart y)) + :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)))) + +(defmethod qexpt ((x qd-real) (y integer)) + (make-instance 'qd-real + :value (npow (qd-value x) y))) + +(declaim (inline expt)) +(defun expt (x y) + (qexpt x y)) + + + +(defmethod two-arg-= ((a number) (b number)) + (cl:= a b)) +(defmethod two-arg-= ((a qd-real) (b number)) + (if (realp b) + (qd-= (qd-value a) (make-qd-d (cl:float b 1d0))) + nil)) +(defmethod two-arg-= ((a number) (b qd-real)) + (if (realp a) + (qd-= (make-qd-d (cl:float a 1d0)) (qd-value b)) + nil)) + +(defmethod two-arg-= ((a qd-real) (b qd-real)) + (qd-= (qd-value a) (qd-value b))) + +(defun = (number &rest more-numbers) + "Returns T if all of its arguments are numerically equal, NIL otherwise." + (declare (optimize (safety 2)) + (dynamic-extent more-numbers)) + (do ((nlist more-numbers (cdr nlist))) + ((atom nlist) T) + (declare (list nlist)) + (if (not (two-arg-= (car nlist) number)) + (return nil)))) + +(defun /= (number &rest more-numbers) + "Returns T if no two of its arguments are numerically equal, NIL otherwise." + (declare (optimize (safety 2)) + (dynamic-extent more-numbers)) + (do* ((head number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (unless (do* ((nl nlist (cdr nl))) + ((atom nl) T) + (declare (list nl)) + (if (two-arg-= head (car nl)) + (return nil))) + (return nil)))) + +(defmethod qcomplex ((x real) &optional y) + (cl:complex x (if y y 0))) + +(defmethod qcomplex ((x qd-real) &optional y) + (make-instance 'qd-complex + :real (qd-value x) + :imag (if y (qd-value y) +qd-zero+))) + +(defun complex (x &optional (y 0)) + (qcomplex x y)) + +(defmethod qinteger-decode-float ((f cl:float)) + (cl:integer-decode-float f)) + +(defmethod qinteger-decode-float ((f qd-real)) + (integer-decode-qd (qd-value f))) + +(declaim (inline integer-decode-float)) +(defun integer-decode-float (f) + (qinteger-decode-float f)) + +(defmethod qdecode-float ((f cl:float)) + (cl:decode-float f)) + +(defmethod qdecode-float ((f qd-real)) + (multiple-value-bind (frac exp s) + (decode-float-qd (qd-value f)) + (values (make-instance 'qd-real :value frac) + exp + (make-instance 'qd-real :value s)))) + +(declaim (inline decode-float)) +(defun decode-float (f) + (qdecode-float f)) + +(defmethod qfloor ((x real) &optional y) + (if y + (cl:floor x y) + (cl:floor x))) + +(defmethod qfloor ((x qd-real) &optional y) + (if (and y (/= y 1)) + (let ((f (qfloor (/ x y)))) + (values f + (- x (* f y)))) + (let ((f (ffloor-qd (qd-value x)))) + (multiple-value-bind (int exp sign) + (integer-decode-qd f) + (values (ash (* sign int) exp) + (make-instance 'qd-real + :value (qd-value + (- x (make-instance 'qd-real + :value f))))))))) + +(defun floor (x &optional y) + (qfloor x y)) + +(defmethod qffloor ((x real) &optional y) + (if y + (cl:ffloor x y) + (cl:ffloor x))) + +(defmethod qffloor ((x qd-real) &optional y) + (if (and y (/= y 1)) + (let ((f (qffloor (/ x y)))) + (values f + (- x (* f y)))) + (let ((f (make-instance 'qd-real :value (ffloor-qd (qd-value x))))) + (values f + (- x f))))) + +(defun ffloor (x &optional y) + (qffloor x y)) + +(defun ceiling (x &optional y) + (multiple-value-bind (f rem) + (floor x y) + (if (zerop rem) + (values (+ f 1) + rem) + (values (+ f 1) + (- rem 1))))) + +(defun fceiling (x &optional y) + (multiple-value-bind (f rem) + (ffloor x y) + (if (zerop rem) + (values (+ f 1) + rem) + (values (+ f 1) + (- rem 1))))) + +(defun truncate (x &optional (y 1)) + (if (minusp x) + (ceiling x y) + (floor x y))) + +(defun ftruncate (x &optional (y 1)) + (if (minusp x) + (fceiling x y) + (ffloor x y))) + +(defmethod %unary-round ((x real)) + (cl::round x)) + +(defmethod %unary-round ((number qd-real)) + (multiple-value-bind (bits exp) + (integer-decode-float number) + (let* ((shifted (ash bits exp)) + (rounded (if (and (minusp exp) + (oddp shifted) + (not (zerop (logand bits + (ash 1 (- -1 exp)))))) + (1+ shifted) + shifted))) + (if (minusp number) + (- rounded) + rounded)))) + +(defun round (number &optional (divisor 1)) + (if (eql divisor 1) + (let ((r (%unary-round number))) + (values r + (- number r))) + (multiple-value-bind (tru rem) + (truncate number divisor) + (if (zerop rem) + (values tru rem) + (let ((thresh (/ (abs divisor) 2))) + (cond ((or (> rem thresh) + (and (= rem thresh) (oddp tru))) + (if (minusp divisor) + (values (- tru 1) (+ rem divisor)) + (values (+ tru 1) (- rem divisor)))) + ((let ((-thresh (- thresh))) + (or (< rem -thresh) + (and (= rem -thresh) (oddp tru)))) + (if (minusp divisor) + (values (+ tru 1) (- rem divisor)) + (values (- tru 1) (+ rem divisor)))) + (t (values tru rem)))))))) + +(defun fround (number &optional (divisor 1)) + "Same as ROUND, but returns first value as a float." + (multiple-value-bind (res rem) + (round number divisor) + (values (float res (if (floatp rem) rem 1.0)) rem))) + +(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 + :value (mul-qd-d (abs-qd (qd-value f)) + (cl:float-sign (qd-0 (qd-value a))))) + (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 max (number &rest more-numbers) + "Returns the greatest of its arguments." + (declare (optimize (safety 2)) (type (or real qd-real) number) + (dynamic-extent more-numbers)) + (dolist (real more-numbers) + (when (> real number) + (setq number real))) + number) + +(defun min (number &rest more-numbers) + "Returns the least of its arguments." + (declare (optimize (safety 2)) (type (or real qd-real) number) + (dynamic-extent more-numbers)) + (do ((nlist more-numbers (cdr nlist)) + (result (the (or real qd-real) number))) + ((null nlist) (return result)) + (declare (list nlist)) + (if (< (car nlist) result) + (setq result (car nlist))))) + +(defmethod qasin ((x number)) + (cl:asin x)) + +(defmethod qasin ((x qd-real)) + (if (<= -1 x 1) + (make-instance 'qd-real :value (asin-qd (qd-value x))) + (qd-complex-asin x))) + +(declaim (inline asin)) +(defun asin (x) + (qasin x)) + +(defmethod qacos ((x number)) + (cl:acos x)) + +(defmethod qacos ((x qd-real)) + (cond ((> (abs x) 1) + (qd-complex-acos x)) + (t + (make-instance 'qd-real :value (acos-qd (qd-value x)))))) + +(declaim (inline acos)) +(defun acos (x) + (qacos x)) + +(defmethod qacosh ((x number)) + (cl:acosh x)) + +(defmethod qacosh ((x qd-real)) + (if (< x 1) + (qd-complex-acosh x) + (make-instance 'qd-real :value (acosh-qd (qd-value x))))) + + +(declaim (inline acosh)) +(defun acosh (x) + (qacosh x)) + +(defmethod qatanh ((x number)) + (cl:atanh x)) + +(defmethod qatanh ((x qd-real)) + (if (> (abs x) 1) + (qd-complex-atanh x) + (make-instance 'qd-real :value (atanh-qd (qd-value x))))) + + +(declaim (inline atanh)) +(defun atanh (x) + (qatanh x)) + +(defmethod qcis ((x real)) + (cl:cis x)) + +(defmethod qcis ((x qd-real)) + (multiple-value-bind (s c) + (sincos-qd (qd-value x)) + (make-instance 'qd-complex + :real c + :imag s))) + +(declaim (inline cis)) +(defun cis (x) + (qcis x)) + +(defmethod qphase ((x number)) + (cl:phase x)) + +(defmethod qphase ((x qd-real)) + (if (minusp x) + (- +pi+) + (make-instance 'qd-real :value (make-qd-d 0d0)))) + +(declaim (inline phase)) +(defun phase (x) + (qphase x)) + +(defun signum (number) + "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." + (if (zerop number) + number + (if (rationalp number) + (if (plusp number) 1 -1) + (/ number (abs number))))) + +(defmethod random ((x cl:real) &optional (state *random-state*)) + (cl:random x state)) + +(defmethod random ((x qd-real) &optional (state *random-state*)) + (* x (make-instance 'qd-real + :value (qdi:random-qd state)))) + +(define-compiler-macro + (&whole form &rest args) + (if (null args) + 0 + (do ((args (cdr args) (cdr args)) + (res (car args) + `(two-arg-+ ,res ,(car args)))) + ((null args) res)))) + +(define-compiler-macro - (&whole form number &rest more-numbers) + (if more-numbers + (do ((nlist more-numbers (cdr nlist)) + (result number)) + ((atom nlist) result) + (declare (list nlist)) + (setq result `(two-arg-- ,result ,(car nlist)))) + `(unary-minus ,number))) + +(define-compiler-macro * (&whole form &rest args) + (if (null args) + 1 + (do ((args (cdr args) (cdr args)) + (res (car args) + `(two-arg-* ,res ,(car args)))) + ((null args) res)))) + +(define-compiler-macro / (number &rest more-numbers) + (if more-numbers + (do ((nlist more-numbers (cdr nlist)) + (result number)) + ((atom nlist) result) + (declare (list nlist)) + (setq result `(two-arg-/ ,result ,(car nlist)))) + `(unary-divide ,number))) + +;; Compiler macros to convert <, >, <=, and >= into multiple calls of +;; the corresponding two-arg- function. +(macrolet + ((frob (op) + (let ((method (intern (concatenate 'string "TWO-ARG-" (symbol-name op))))) + `(define-compiler-macro ,op (number &rest more-numbers) + (do* ((n number (car nlist)) + (nlist more-numbers (cdr nlist)) + (res nil)) + ((atom nlist) + `(and ,@(nreverse res))) + (push `(,',method ,n ,(car nlist)) res)))))) + (frob <) + (frob >) + (frob <=) + (frob >=)) + +(define-compiler-macro /= (&whole form number &rest more-numbers) + ;; Convert (/= x y) to (not (two-arg-= x y)). Should we try to + ;; handle a few more cases? + (if (cdr more-numbers) + form + `(not (two-arg-= ,number ,(car more-numbers))))) + + +(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) + diff --git a/external/oct/qd-package.lisp b/external/oct/qd-package.lisp new file mode 100644 index 0000000..18406f7 --- /dev/null +++ b/external/oct/qd-package.lisp @@ -0,0 +1,227 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +(defpackage #:quad-double-internal + (:use #:cl #+cmu #:extensions) + (:nicknames #:qdi) + (:export #:%quad-double + #:read-qd + #:add-qd + #:add-qd-d + #:cmu #:add-qd-dd + #:add-d-qd + #:sub-qd + #:sub-qd-d + #:cmu #:sub-qd-dd + #:sub-d-qd + #:neg-qd + #:mul-qd + #:mul-qd-d + #:sqr-qd + #:div-qd + #:div-qd-d + #+cmu #:div-qd-dd + #:make-qd-d + #+cmu #:make-qd-dd + #:integer-decode-qd + #:npow + #:qd-0 + #:qd-1 + #:qd-2 + #:qd-3 + #:qd-parts + #:+qd-one+ + #:+qd-zero+ + #:+qd-pi+ + ;; Functions + #:hypot-qd + #:abs-qd + #:sqrt-qd + #:log-qd + #:log1p-qd + #:exp-qd + #:sin-qd + #:cos-qd + #:tan-qd + #:sincos-qd + #:asin-qd + #:acos-qd + #:atan-qd + #:atan2-qd + #:sinh-qd + #:cosh-qd + #:tanh-qd + #:asinh-qd + #:acosh-qd + #:atanh-qd + #:qd-= + #:qd-> + #:qd-< + #:qd->= + #:qd-<= + #:zerop-qd + #:plusp-qd + #:minusp-qd + #:integer-decode-qd + #:decode-float-qd + #:scale-float-qd + #:ffloor-qd + #:random-qd + ) + #+cmu + (:import-from #:c + #:two-sum + #:quick-two-sum + #:two-prod + #:two-sqr)) + +(defpackage #:quad-double + (:use #:cl #:quad-double-internal) + (:nicknames #:oct #:qd) + (:shadow #:+ + #:- + #:* + #:/ + #:1+ + #:1- + #:zerop + #:plusp + #:minusp + #:abs + #:sqrt + #:log + #:exp + #:sin + #:cos + #:tan + #:asin + #:acos + #:atan + #:sinh + #:cosh + #:tanh + #:asinh + #:acosh + #:atanh + #:expt + #:= + #:/= + #:< + #:> + #:<= + #:>= + #:complex + #:integer-decode-float + #:decode-float + #:scale-float + #:float + #:floor + #:ffloor + #:ceiling + #:fceiling + #:truncate + #:ftruncate + #:round + #:fround + #:realpart + #:imagpart + #:conjugate + #:float-sign + #:qd-format-exp + #:max + #:min + #:cis + #:phase + #:signum + #:coerce + #:random + ) + (:export #:+ + #:- + #:* + #:/ + #:1+ + #:1- + #:zerop + #:plusp + #:minusp + #:abs + #:sqrt + #:log + #:exp + #:sin + #:cos + #:tan + #:asin + #:acos + #:atan + #:sinh + #:cosh + #:tanh + #:asinh + #:acosh + #:atanh + #:expt + #:= + #:/= + #:< + #:> + #:<= + #:>= + #:complex + #:integer-decode-float + #:decode-float + #:scale-float + #:float + #:floor + #:ffloor + #:ceiling + #:fceiling + #:truncate + #:ftruncate + #:round + #:fround + #:realpart + #:imagpart + #:conjugate + #:float-sign + #:qd-format-exp + #:max + #:min + #:cis + #:phase + #:signum + #:coerce + #:random + #:realp + #:complexp + #:numberp + ) + ;; Constants + (:export #:+pi+) + ;; CMUCL supports infinities. + #+cmu + (:export #:+quad-double-float-positive-infinity+ + #:+quad-double-float-negative-infinity+)) diff --git a/external/oct/qd-rep.lisp b/external/oct/qd-rep.lisp new file mode 100644 index 0000000..39e4e77 --- /dev/null +++ b/external/oct/qd-rep.lisp @@ -0,0 +1,156 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qdi) + +;;; This file contains the actual representation of a %quad-double +;;; number. The only real requirement for a %quad-double number is an +;;; object that can hold four double-float values. +;;; +;;; This object is created by %MAKE-QD-D. The four double-float +;;; elements of a %quad-double are accessed via QD-0, QD-1, QD-2, and +;;; QD-3. A convenience function, QD-PARTS, is also provided to +;;; return all four values at once. + +;; All of the following functions should be inline to reduce consing. +(declaim (inline + qd-0 qd-1 qd-2 qd-3 + %make-qd-d + qd-parts)) +#+cmu +(progn +;; For CMUCL (at least recent enough versions that support +;; double-double-float), we can use a (complex double-double-float) to +;; hold our 4 double-float values. This has a nice advantage: Much of +;; the arithmetic can be done without consing, provided the key +;; functions are inline. +(deftype %quad-double () + '(complex double-double-float)) + +;; QD-0, QD-1, QD-2, and QD-3 extract the various parts of a +;; quad-double. QD-0 is the most significant part and QD-3 is the +;; least. +(defun qd-0 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (kernel:double-double-hi (realpart q))) +(defun qd-1 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (kernel:double-double-lo (realpart q))) +(defun qd-2 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (kernel:double-double-hi (imagpart q))) +(defun qd-3 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (kernel:double-double-lo (imagpart q))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun %make-qd-d (a0 a1 a2 a3) + "Make a %quad-double from 4 double-floats, exactly using the given + values. No check is made to see if the values make sense. A0 is + the most significant part and A3 is the least. +" + (declare (double-float a0 a1 + a2 a3)) + (complex (kernel:%make-double-double-float a0 a1) + (kernel:%make-double-double-float a2 a3))) +) + + +(defun qd-parts (qd) + "Extract the four doubles comprising a quad-double and return them + as multiple values. The most significant double is the first value." + (declare (type %quad-double qd)) + (let ((re (realpart qd)) + (im (imagpart qd))) + (values (kernel:double-double-hi re) + (kernel:double-double-lo re) + (kernel:double-double-hi im) + (kernel:double-double-lo im)))) + +) ; end progn + +#-cmu +(progn +;; For Lisp's without a double-double-float type, I think the best we +;; can do is a simple-array of four double-floats. Even with +;; inlining, I think there will lots of consing when working with this +;; type. +;; +;; A defstruct would also work but I think a simple-array is the +;; simplest and smallest representation. +(deftype %quad-double () + '(simple-array double-float (4))) + +(defun qd-0 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (aref q 0)) + +(defun qd-1 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (aref q 1)) + +(defun qd-2 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (aref q 2)) + +(defun qd-3 (q) + (declare (type %quad-double q) + (optimize (speed 3))) + (aref q 3)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun %make-qd-d (a0 a1 a2 a3) + "Make a %quad-double from 4 double-floats, exactly using the given + values. No check is made to see if the values make sense. A0 is + the most significant part and A3 is the least. +" + (declare (double-float a0 a1 + a2 a3) + (optimize (speed 3))) + (let ((a (make-array 4 :element-type 'double-float))) + (setf (aref a 0) a0) + (setf (aref a 1) a1) + (setf (aref a 2) a2) + (setf (aref a 3) a3) + a)) +) + +(defun qd-parts (qd) + "Extract the four doubles comprising a quad-double and return them + as multiple values. The most significant double is the first value." + (declare (type %quad-double qd)) + (values (aref qd 0) + (aref qd 1) + (aref qd 2) + (aref qd 3))) + +) ; end progn diff --git a/external/oct/qd-test.lisp b/external/oct/qd-test.lisp new file mode 100644 index 0000000..2ce6530 --- /dev/null +++ b/external/oct/qd-test.lisp @@ -0,0 +1,409 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qdi) + +;; Compute to how many bits EST and TRUE are equal. If they are +;; identical, return T. +(defun bit-accuracy (est true) + (let* ((diff (abs-qd (sub-qd est true))) + (err (if (zerop-qd true) + (qd-0 diff) + (cl:/ (qd-0 diff) (abs (qd-0 true)))))) + (if (zerop (qd-0 diff)) + t + (cl:- (log err 2d0))))) + +(defun print-result (est true) + (format t "est: ~/qdi::qd-format/~%" est) + (format t "tru: ~/qdi::qd-format/~%" true) + (format t "err: ~A~%" (qd-0 (sub-qd est true))) + (format t "bits: ~,1f~%" (bit-accuracy est true))) + +;; Machin's formula for pi +#+nil +(defun atan-series (x) + (let* ((d 1d0) + (eps (make-qd-d (scale-float 1d0 -212) + 0d0 0d0 0d0)) + (tmp x) + (r (sqr-qd tmp)) + (s1 (make-qd-dd 0w0 0w0)) + (k 0) + (sign 1)) + (loop while (qd-> tmp eps) do + (incf k) + (setf s1 + (if (minusp sign) + (sub-qd s1 (div-qd tmp (make-qd-d d 0d0 0d0 0d0))) + (add-qd s1 (div-qd tmp (make-qd-d d 0d0 0d0 0d0))))) + (incf d 2d0) + (setf tmp (mul-qd tmp r)) + (setf sign (cl:- sign))) + s1)) + +;; pi = +;; 3.1415926535897932384626433832795028841971693993751058209749445923078L0 +(defun test2 () + ;; pi/4 = 4 * arctan(1/5) - arctan(1/239) + ;; + ;; Arctan is computed using the Taylor series + ;; + ;; arctan(x) = x - x^3/3 + x^5/5 - x^7/7 + (flet ((atan-series (x) + (let* ((d 1d0) + (eps (make-qd-d (scale-float 1d0 -212))) + (tmp x) + (r (sqr-qd tmp)) + (s1 (make-qd-d 0d0)) + (k 0) + (sign 1)) + (loop while (qd-> tmp eps) do + (incf k) + (setf s1 + (if (minusp sign) + (sub-qd s1 (div-qd tmp (make-qd-d d))) + (add-qd s1 (div-qd tmp (make-qd-d d))))) + (incf d 2d0) + (setf tmp (mul-qd tmp r)) + (setf sign (cl:- sign))) + s1))) + (let* ((x1 (div-qd +qd-one+ + (make-qd-d 5d0))) + (s1 (atan-series x1)) + (x2 (div-qd +qd-one+ + (make-qd-d 239d0))) + (s2 (atan-series x2)) + (p (mul-qd-d (sub-qd (mul-qd-d s1 4d0) + s2) + 4d0))) + (format t "~2&pi via Machin's atan formula~%") + (print-result p +qd-pi+) + p))) + +(defun test3 () + (declare (optimize (speed 3))) + ;; Salamin-Brent Quadratic formula for pi + (let* ((a +qd-one+) + (b (sqrt-qd (make-qd-d 0.5d0))) + (s (make-qd-d 0.5d0)) + (m 1d0) + (p (div-qd (mul-qd-d (sqr-qd a) 2d0) + s))) + (declare (double-float m)) + (dotimes (k 9) + (setf m (cl:* 2 m)) + (let* ((a-new (mul-qd-d (add-qd a b) .5d0)) + (b-new (sqrt-qd (mul-qd a b))) + (s-new (sub-qd s + (mul-qd-d (sub-qd (sqr-qd a-new) + (sqr-qd b-new)) + m)))) + (setf a a-new) + (setf b b-new) + (setf s s-new) + (setf p (div-qd (mul-qd-d (sqr-qd a) 2d0) + s)))) + (format t "~2&Salamin-Brent Quadratic formula for pi~%") + (print-result p +qd-pi+) + p)) + +(defun test4 () + (declare (optimize (speed 3))) + ;; Borwein Quartic formula for pi + (let* ((a (sub-qd (make-qd-d 6d0) + (mul-qd-d (sqrt-qd (make-qd-d 2d0)) + 4d0))) + (y (sub-qd-d (sqrt-qd (make-qd-d 2d0)) + 1d0)) + (m 2d0) + (p (div-qd +qd-one+ + a))) + (declare (double-float m)) + (dotimes (k 9) + (setf m (cl:* 4 m)) + (let ((r (nroot-qd (sub-qd +qd-one+ + (sqr-qd (sqr-qd y))) + 4))) + (setf y (div-qd (sub-d-qd 1d0 + r) + (add-d-qd 1d0 + r))) + (setf a (sub-qd (mul-qd a + (sqr-qd (sqr-qd (add-qd-d y 1d0)))) + (mul-qd-d (mul-qd y + (add-qd-d (add-qd y (sqr-qd y)) + 1d0)) + m))) + (setf p (div-qd +qd-one+ + a)))) + (format t "~2&Borwein's Quartic formula for pi~%") + (print-result p +qd-pi+) + p)) + +;; e = +;; 2.718281828459045235360287471352662497757247093699959574966967627724L0 +(defun test5 () + ;; Taylor series for e + (let ((s (make-qd-d 2d0)) + (tmp +qd-one+) + (n 1d0) + (delta 0d0) + (i 0)) + (loop while (qd-> tmp (make-qd-d 1d-100)) do + (incf i) + (incf n) + (setf tmp (div-qd tmp + (make-qd-d (float n 1d0)))) + (setf s (add-qd s tmp))) + (format t "~2&e via Taylor series~%") + (print-result s +qd-e+) + s)) + +;; log(2) = +;; 0.6931471805599453094172321214581765680755001343602552541206800094934L0 +(defun test6 () + ;; Taylor series for log 2 + ;; + ;; -log(1-x) = x + x^2/2 + x^3/3 + x^4/4 + ... + ;; + ;; with x = 1/2 to get log(1/2) = -log(2) + (let ((s (make-qd-d .5d0)) + (tt (make-qd-d .5d0)) + (n 1d0) + (i 0)) + (loop while (qd-> tt (make-qd-d 1d-100)) do + (incf i) + (incf n) + (setf tt (mul-qd-d tt .5d0)) + (setf s (add-qd s + (div-qd tt (make-qd-d (float n 1d0)))))) + (format t "~2&log(2) via Taylor series~%") + (print-result s +qd-log2+) + s)) + +(defun test-atan (&optional (fun #'atan-qd)) + ;; Compute atan for known values + + (format t "~2&atan via ~S~%" fun) + ;; atan(1/sqrt(3)) = pi/6 + (let* ((arg (div-qd +qd-one+ (sqrt-qd (make-qd-d 3d0)))) + (y (div-qd (funcall fun arg) +qd-pi+)) + (true (div-qd +qd-one+ (make-qd-d 6d0)))) + (format t "atan(1/sqrt(3))/pi = ~/qdi::qd-format/~%" y) + (format t "1/6 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ;; atan(sqrt(3)) = %pi/3 + (let* ((arg (sqrt-qd (make-qd-d 3d0))) + (y (div-qd (funcall fun arg) +qd-pi+)) + (true (div-qd +qd-one+ (make-qd-d 3d0)))) + (format t "atan(sqrt(3))/pi = ~/qdi::qd-format/~%" y) + (format t "1/3 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ;; atan(1) = %pi/4 + (let* ((arg +qd-one+) + (y (div-qd (funcall fun arg) +qd-pi+)) + (true (div-qd +qd-one+ (make-qd-d 4d0)))) + (format t "atan(1)/pi = ~/qdi::qd-format/~%" y) + (format t "1/4 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true)))) + +(defun test-sin () + (format t "~2&sin~%") + (let* ((arg (div-qd +qd-pi+ (make-qd-d 6d0))) + (y (sin-qd arg)) + (true (make-qd-d 0.5d0))) + (format t "sin(pi/6) = ~/qdi::qd-format/~%" y) + (format t "1/2 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (div-qd +qd-pi+ (make-qd-d 4d0))) + (y (sin-qd arg)) + (true (sqrt-qd (make-qd-d 0.5d0)))) + (format t "sin(pi/4) = ~/qdi::qd-format/~%" y) + (format t "1/sqrt(2) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (div-qd +qd-pi+ (make-qd-d 3d0))) + (y (sin-qd arg)) + (true (div-qd (sqrt-qd (make-qd-d 3d0)) (make-qd-d 2d0)))) + (format t "sin(pi/3) = ~/qdi::qd-format/~%" y) + (format t "sqrt(3)/2 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ) + +(defun test-tan (&optional (f #'tan-qd)) + (format t "~2&tan via ~S~%" f) + (let* ((arg (div-qd +qd-pi+ (make-qd-d 6d0))) + (y (funcall f arg)) + (true (div-qd +qd-one+ (sqrt-qd (make-qd-d 3d0))))) + (format t "tan(pi/6) = ~/qdi::qd-format/~%" y) + (format t "1/sqrt(3) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (div-qd +qd-pi+ (make-qd-d 4d0))) + (y (funcall f arg)) + (true +qd-one+)) + (format t "tan(pi/4) = ~/qdi::qd-format/~%" y) + (format t "1 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (div-qd +qd-pi+ (make-qd-d 3d0))) + (y (funcall f arg)) + (true (sqrt-qd (make-qd-d 3d0)))) + (format t "tan(pi/3) = ~/qdi::qd-format/~%" y) + (format t "sqrt(3) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ) + +(defun test-asin () + (format t "~2&asin~%") + (let* ((arg (make-qd-d 0.5d0)) + (y (asin-qd arg)) + (true (div-qd +qd-pi+ (make-qd-d 6d0)))) + (format t "asin(1/2) = ~/qdi::qd-format/~%" y) + (format t "pi/6 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (sqrt-qd (make-qd-d 0.5d0))) + (y (asin-qd arg)) + (true (div-qd +qd-pi+ (make-qd-d 4d0)))) + (format t "asin(1/sqrt(2))= ~/qdi::qd-format/~%" y) + (format t "pi/4 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (div-qd (sqrt-qd (make-qd-d 3d0)) (make-qd-d 2d0))) + (y (asin-qd arg)) + (true (div-qd +qd-pi+ (make-qd-d 3d0)))) + (format t "asin(sqrt(3)/2)= ~/qdi::qd-format/~%" y) + (format t "pi/3 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ) + +(defun test-log (f) + (format t "~2&Log via ~A~%" f) + (let* ((arg (make-qd-d 2d0)) + (y (funcall f arg)) + (true +qd-log2+)) + (format t "log(2) = ~/qdi::qd-format/~%" y) + (format t "log(2) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (make-qd-d 10d0)) + (y (funcall f arg)) + (true +qd-log10+)) + (format t "log(10) = ~/qdi::qd-format/~%" y) + (format t "log(10) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (add-d-qd 1d0 (scale-float-qd (make-qd-d 1d0) -80))) + (y (funcall f arg)) + (true (qd-from-string "8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25"))) + (format t "log(1+2^-80) = ~/qdi::qd-format/~%" y) + (format t "log(1+2^-80) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ) + +(defun test-log1p (f) + (format t "~2&Log1p via ~A~%" f) + (let* ((arg (make-qd-d 1d0)) + (y (funcall f arg)) + (true +qd-log2+)) + (format t "log1p(1) = ~/qdi::qd-format/~%" y) + (format t "log(2) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (make-qd-d 9d0)) + (y (funcall f arg)) + (true (qd-from-string "2.3025850929940456840179914546843642076011014886287729760333279009675726096773525q0"))) + (format t "log1p(9) = ~/qdi::qd-format/~%" y) + (format t "log(10) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg (scale-float-qd (make-qd-d 1d0) -80)) + (y (funcall f arg)) + (true (qd-from-string "8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25"))) + (format t "log1p(2^-80) = ~/qdi::qd-format/~%" y) + (format t "log(1+2^-80) = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + ) + +(defun test-exp (f) + (format t "~2&Exp via ~A~%" f) + (let* ((arg +qd-zero+) + (y (funcall f arg)) + (true +qd-zero+)) + (format t "exp(0)-1 = ~/qdi::qd-format/~%" y) + (format t "0 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + (let* ((arg +qd-one+) + (y (funcall f arg)) + (true (qd-from-string "1.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952q0"))) + (format t "exp(1)-1 = ~/qdi::qd-format/~%" y) + (format t "e-1 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + + (let* ((arg (scale-float-qd +qd-one+ -100)) + (y (funcall f arg)) + (true (qd-from-string "7.888609052210118054117285652830973804370994921943802079729680186943164342372119432861876389514693341738324702996270767390039172777809233288470357147q-31"))) + (format t "exp(2^-80)-1 = ~/qdi::qd-format/~%" y) + (format t "exp(2^-80)-1 = ~/qdi::qd-format/~%" true) + (format t "bits = ~,1f~%" + (bit-accuracy y true))) + + ) +(defun all-tests () + (test2) + (test3) + (test4) + (test5) + (test6) + (test-sin) + (test-asin) + (dolist (f '(atan-qd/newton atan-qd/cordic atan-qd/duplication)) + (test-atan f)) + (dolist (f '(tan-qd/sincos tan-qd/cordic)) + (test-tan f)) + (dolist (f '(log-qd/newton log-qd/agm log-qd/agm2 log-qd/agm3 log-qd/halley)) + (test-log f)) + (dolist (f '(log1p-qd/duplication)) + (test-log1p f)) + (dolist (f (list #'(lambda (x) + (sub-qd-d (exp-qd/reduce x) 1d0)) + #'expm1-qd/series + #'expm1-qd/duplication)) + (test-exp f)) + ) diff --git a/external/oct/qd.lisp b/external/oct/qd.lisp new file mode 100644 index 0000000..15a67a9 --- /dev/null +++ b/external/oct/qd.lisp @@ -0,0 +1,1149 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + +;;; This file contains the core routines for basic arithmetic +;;; operations on a %quad-double. This includes addition, +;;; subtraction, multiplication, division, negation. and absolute +;;; value. Some additional helper functions are included such as +;;; raising to an integer power. and the n'th root of a (non-negative) +;;; %quad-double. The basic comparison operators are included, and +;;; some simple tests for zerop, onep, plusp, and minusp. +;;; +;;; The basic algorithms are based on Yozo Hida's double-double +;;; implementation. However, some were copied from CMUCL and modified +;;; to support quad-doubles. + + +(in-package #:qdi) + +#+cmu +(eval-when (:compile-toplevel) + (setf *inline-expansion-limit* 1600)) + +;; All of the following functions should be inline. +(declaim (inline three-sum three-sum2)) + +;; Internal routines for implementing quad-double. +(defun three-sum (a b c) + (declare (double-float a b c) + (optimize (speed 3))) + (multiple-value-bind (t1 t2) + (two-sum a b) + (multiple-value-bind (a t3) + (two-sum c t1) + (multiple-value-bind (b c) + (two-sum t2 t3) + (values a b c))))) + +(defun three-sum2 (a b c) + (declare (double-float a b c) + (optimize (speed 3))) + (multiple-value-bind (t1 t2) + (two-sum a b) + (multiple-value-bind (a t3) + (two-sum c t1) + (values a (cl:+ t2 t3) c)))) + +;; Not needed???? +#+nil +(declaim (inline quick-three-accum)) +#+nil +(defun quick-three-accum (a b c) + (declare (double-float a b c) + (optimize (speed 3) (space 0))) + (multiple-value-bind (s b) + (two-sum b c) + (multiple-value-bind (s a) + (two-sum a s) + (let ((za (/= a 0)) + (zb (/= b 0))) + (when (and za zb) + (return-from quick-three-accum (values (cl:+ s 0d0) (cl:+ a 0d0) (cl:+ b 0d0)))) + (when (not za) + (setf a s) + (setf s 0d0)) + (when (not zb) + (setf b a) + (setf a s)) + (values 0d0 a b))))) + + +;; These functions are quite short, so we inline them to minimize +;; consing. +(declaim (inline make-qd-d + add-d-qd + add-dd-qd + neg-qd + sub-qd + sub-qd-dd + sub-qd-d + sub-d-qd + make-qd-dd + abs-qd + qd-> + qd-< + qd->= + qd-<= + zerop-qd + onep-qd + plusp-qd + minusp-qd + qd-= + scale-float-qd)) + +;; Should these functions be inline? The QD C++ source has these as +;; inline functions, but these are fairly large functions. However, +;; inlining makes quite a big difference in speed and consing. +#+cmu +(declaim (#+qd-inline inline + #-qd-inline maybe-inline + renorm-4 + renorm-5 + add-qd-d + add-qd-dd + add-qd + mul-qd-d + mul-qd-dd + mul-qd + sqr-qd + div-qd + div-qd-d + div-qd-dd)) + +#-(or qd-inline (not cmu)) +(declaim (ext:start-block renorm-4 renorm-5 + make-qd-d + add-qd-d add-d-qd add-qd-dd + add-dd-qd + add-qd + neg-qd + sub-qd sub-qd-dd sub-qd-d sub-d-qd + mul-qd-d mul-qd-dd mul-qd + sqr-qd + div-qd div-qd-d div-qd-dd + make-qd-dd + )) + +#+(or) +(defun quick-renorm (c0 c1 c2 c3 c4) + (declare (double-float c0 c1 c2 c3 c4) + (optimize (speed 3))) + (multiple-value-bind (s t3) + (quick-two-sum c3 c4) + (multiple-value-bind (s t2) + (quick-two-sum c2 s) + (multiple-value-bind (s t1) + (quick-two-sum c1 s) + (multiple-value-bind (c0 t0) + (quick-two-sum c0 s) + (multiple-value-bind (s t2) + (quick-two-sum t2 t3) + (multiple-value-bind (s t1) + (quick-two-sum t1 s) + (multiple-value-bind (c1 t0) + (quick-two-sum t0 s) + (multiple-value-bind (s t1) + (quick-two-sum t1 t2) + (multiple-value-bind (c2 t0) + (quick-two-sum t0 s) + (values c0 c1 c2 (cl:+ t0 t1)))))))))))) + +(defun renorm-4 (c0 c1 c2 c3) + (declare (double-float c0 c1 c2 c3) + (optimize (speed 3) (safety 0))) + (let ((s2 0d0) + (s3 0d0)) + (multiple-value-bind (s0 c3) + (quick-two-sum c2 c3) + (multiple-value-bind (s0 c2) + (quick-two-sum c1 s0) + (multiple-value-bind (c0 c1) + (quick-two-sum c0 s0) + (let ((s0 c0) + (s1 c1)) + (cond ((/= s1 0) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c2)) + (if (/= s2 0) + (multiple-value-setq (s2 s3) + (quick-two-sum s2 c3)) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c3)))) + (t + (multiple-value-setq (s0 s1) + (quick-two-sum s0 c2)) + (if (/= s1 0) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c3)) + (multiple-value-setq (s0 s1) + (quick-two-sum s0 c3))))) + (values s0 s1 s2 s3))))))) + +(defun renorm-5 (c0 c1 c2 c3 c4) + (declare (double-float c0 c1 c2 c3) + (optimize (speed 3) (safety 0))) + (let ((s2 0d0) + (s3 0d0)) + (declare (double-float s2 s3)) + (multiple-value-bind (s0 c4) + (quick-two-sum c3 c4) + (multiple-value-bind (s0 c3) + (quick-two-sum c2 s0) + (multiple-value-bind (s0 c2) + (quick-two-sum c1 s0) + (multiple-value-bind (c0 c1) + (quick-two-sum c0 s0) + (let ((s0 c0) + (s1 c1)) + (declare (double-float s0 s1)) + (multiple-value-setq (s0 s1) + (quick-two-sum c0 c1)) + (cond ((/= s1 0) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c2)) + (cond ((/= s2 0) + (multiple-value-setq (s2 s3) + (quick-two-sum s2 c3)) + (if (/= s3 0) + (incf s3 c4) + (incf s2 c4))) + (t + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c3)) + (if (/= s2 0) + (multiple-value-setq (s2 s3) + (quick-two-sum s2 c4)) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c4)))))) + (t + (multiple-value-setq (s0 s1) + (quick-two-sum s0 c2)) + (cond ((/= s1 0) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c3)) + (if (/= s2 0) + (multiple-value-setq (s2 s3) + (quick-two-sum s2 c4)) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c4)))) + (t + (multiple-value-setq (s0 s1) + (quick-two-sum s0 c3)) + (if (/= s1 0) + (multiple-value-setq (s1 s2) + (quick-two-sum s1 c4)) + (multiple-value-setq (s0 s1) + (quick-two-sum s0 c4))))))) + (values s0 s1 s2 s3)))))))) + +(defun make-qd-d (a0 &optional (a1 0d0 a1-p) (a2 0d0) (a3 0d0)) + "Create a %quad-double from four double-floats, appropriately + normalizing the result from the four double-floats. +" + (declare (double-float a0 a1 a2 a3) + (optimize (speed 3) + #+cmu + (ext:inhibit-warnings 3))) + (if a1-p + (multiple-value-bind (s0 s1 s2 s3) + (renorm-4 a0 a1 a2 a3) + (%make-qd-d s0 s1 s2 s3)) + (%make-qd-d a0 0d0 0d0 0d0))) + +;;;; Addition + +;; Quad-double + double +(defun add-qd-d (a b) + "Add a quad-double A and a double-float B" + (declare (type %quad-double a) + (double-float b) + (optimize (speed 3) + (space 0))) + (multiple-value-bind (c0 e) + (two-sum (qd-0 a) b) + #+cmu + (when (float-infinity-p c0) + (return-from add-qd-d (%make-qd-d c0 0d0 0d0 0d0))) + (multiple-value-bind (c1 e) + (two-sum (qd-1 a) e) + (multiple-value-bind (c2 e) + (two-sum (qd-2 a) e) + (multiple-value-bind (c3 e) + (two-sum (qd-3 a) e) + (multiple-value-bind (r0 r1 r2 r3) + (renorm-5 c0 c1 c2 c3 e) + (if (and (zerop (qd-0 a)) (zerop b)) + (%make-qd-d c0 0d0 0d0 0d0) + (%make-qd-d r0 r1 r2 r3)))))))) + +(defun add-d-qd (a b) + (declare (double-float a) + (type %quad-double b) + (optimize (speed 3))) + (add-qd-d b a)) + +#+cmu +(defun add-qd-dd (a b) + "Add a quad-double A and a double-double B" + (declare (type %quad-double a) + (double-double-float b) + (optimize (speed 3) + (space 0))) + (multiple-value-bind (s0 t0) + (two-sum (qd-0 a) (kernel:double-double-hi b)) + (multiple-value-bind (s1 t1) + (two-sum (qd-1 a) (kernel:double-double-lo b)) + (multiple-value-bind (s1 t0) + (two-sum s1 t0) + (multiple-value-bind (s2 t0 t1) + (three-sum (qd-2 a) t0 t1) + (multiple-value-bind (s3 t0) + (two-sum t0 (qd-3 a)) + (let ((t0 (cl:+ t0 t1))) + (multiple-value-call #'%make-qd-d + (renorm-5 s0 s1 s2 s3 t0))))))))) + +#+cmu +(defun add-dd-qd (a b) + (declare (double-double-float a) + (type %quad-double b) + (optimize (speed 3) + (space 0))) + (add-qd-dd b a)) + + +#+(or) +(defun add-qd-1 (a b) + (declare (type %quad-double a b) + (optimize (speed 3))) + (multiple-value-bind (s0 t0) + (two-sum (qd-0 a) (qd-0 b)) + (multiple-value-bind (s1 t1) + (two-sum (qd-1 a) (qd-1 b)) + (multiple-value-bind (s2 t2) + (two-sum (qd-2 a) (qd-2 b)) + (multiple-value-bind (s3 t3) + (two-sum (qd-3 a) (qd-3 b)) + (multiple-value-bind (s1 t0) + (two-sum s1 t0) + (multiple-value-bind (s2 t0 t1) + (three-sum s2 t0 t1) + (multiple-value-bind (s3 t0) + (three-sum2 s3 t0 t2) + (let ((t0 (cl:+ t0 t1 t3))) + (multiple-value-call #'%make-qd-d + (renorm-5 s0 s1 s2 s3 t0))))))))))) + +;; Same as above, except that everything is expanded out for compilers +;; which don't do a very good job with dataflow. CMUCL is one of +;; those compilers. + +(defun add-qd (a b) + (declare (type %quad-double a b) + (optimize (speed 3) + (space 0))) + ;; This is the version that is NOT IEEE. Should we use the IEEE + ;; version? It's quite a bit more complicated. + ;; + ;; In addition, this is reorganized to minimize data dependency. + (multiple-value-bind (a0 a1 a2 a3) + (qd-parts a) + (multiple-value-bind (b0 b1 b2 b3) + (qd-parts b) + (let ((s0 (cl:+ a0 b0)) + (s1 (cl:+ a1 b1)) + (s2 (cl:+ a2 b2)) + (s3 (cl:+ a3 b3))) + (declare (double-float s0 s1 s2 s3)) + #+cmu + (when (float-infinity-p s0) + (return-from add-qd (%make-qd-d s0 0d0 0d0 0d0))) + (let ((v0 (cl:- s0 a0)) + (v1 (cl:- s1 a1)) + (v2 (cl:- s2 a2)) + (v3 (cl:- s3 a3))) + (let ((u0 (cl:- s0 v0)) + (u1 (cl:- s1 v1)) + (u2 (cl:- s2 v2)) + (u3 (cl:- s3 v3))) + (let ((w0 (cl:- a0 u0)) + (w1 (cl:- a1 u1)) + (w2 (cl:- a2 u2)) + (w3 (cl:- a3 u3))) + (let ((u0 (cl:- b0 v0)) + (u1 (cl:- b1 v1)) + (u2 (cl:- b2 v2)) + (u3 (cl:- b3 v3))) + (let ((t0 (cl:+ w0 u0)) + (t1 (cl:+ w1 u1)) + (t2 (cl:+ w2 u2)) + (t3 (cl:+ w3 u3))) + (multiple-value-bind (s1 t0) + (two-sum s1 t0) + (multiple-value-bind (s2 t0 t1) + (three-sum s2 t0 t1) + (multiple-value-bind (s3 t0) + (three-sum2 s3 t0 t2) + (declare (double-float t0)) + (setf t0 (cl:+ t0 t1 t3)) + ;; Renormalize + (multiple-value-setq (s0 s1 s2 s3) + (renorm-5 s0 s1 s2 s3 t0)) + (if (and (zerop a0) (zerop b0)) + (%make-qd-d (+ a0 b0) 0d0 0d0 0d0) + (%make-qd-d s0 s1 s2 s3)))))))))))))) + +(defun neg-qd (a) + (declare (type %quad-double a)) + (multiple-value-bind (a0 a1 a2 a3) + (qd-parts a) + (%make-qd-d (cl:- a0) (cl:- a1) (cl:- a2) (cl:- a3)))) + +(defun sub-qd (a b) + (declare (type %quad-double a b)) + (add-qd a (neg-qd b))) + +#+cmu +(defun sub-qd-dd (a b) + (declare (type %quad-double a) + (type double-double-float b)) + (add-qd-dd a (cl:- b))) + +(defun sub-qd-d (a b) + (declare (type %quad-double a) + (type double-float b)) + (add-qd-d a (cl:- b))) + +(defun sub-d-qd (a b) + (declare (type double-float a) + (type %quad-double b)) + ;; a - b = a + (-b) + (add-d-qd a (neg-qd b))) + + +;; Works +;; (mul-qd-d (sqrt-qd (make-qd-dd 2w0 0w0)) 10d0) -> +;; 14.1421356237309504880168872420969807856967187537694807317667973799q0 +;; +;; Clisp says +;; 14.142135623730950488016887242096980785696718753769480731766797379908L0 +;; +(defun mul-qd-d (a b) + "Multiply quad-double A with B" + (declare (type %quad-double a) + (double-float b) + (optimize (speed 3) + (space 0))) + (multiple-value-bind (p0 q0) + (two-prod (qd-0 a) b) + #+cmu + (when (float-infinity-p p0) + (return-from mul-qd-d (%make-qd-d p0 0d0 0d0 0d0))) + (multiple-value-bind (p1 q1) + (two-prod (qd-1 a) b) + (multiple-value-bind (p2 q2) + (two-prod (qd-2 a) b) + (let ((p3 (cl:* (qd-3 a) b)) + (s0 p0)) + #+nil + (format t "q0 p1 = ~A ~A~%" q0 p1) + (multiple-value-bind (s1 s2) + (two-sum q0 p1) + #+nil + (format t "s1 s2 = ~A ~A~%" s1 s2) + #+nil + (format t "s2 q1 p2 = ~A ~A ~A~%" + s2 q1 p2) + (multiple-value-bind (s2 q1 p2) + (three-sum s2 q1 p2) + #+nil + (format t "s2,q1,p2 = ~A ~A ~A~%" + s2 q1 p2) + #+nil + (format t "q1 q2 p3 = ~A ~A ~A~%" + q1 q2 p3) + (multiple-value-bind (q1 q2) + (three-sum2 q1 q2 p3) + #+nil + (format t "q1 q2, p3 = ~A ~A ~A~%" q1 q2 p3) + (let ((s3 q1) + (s4 (cl:+ q2 p2))) + #+nil + (progn + (format t "~a~%" s0) + (format t "~a~%" s1) + (format t "~a~%" s2) + (format t "~a~%" s3) + (format t "~a~%" s4)) + (multiple-value-bind (s0 s1 s2 s3) + (renorm-5 s0 s1 s2 s3 s4) + #+nil + (progn + (format t "~a~%" s0) + (format t "~a~%" s1) + (format t "~a~%" s2) + (format t "~a~%" s3) + (format t "~a~%" s4)) + (if (zerop s0) + (%make-qd-d (float-sign p0 0d0) 0d0 0d0 0d0) + (%make-qd-d s0 s1 s2 s3)))))))))))) + +;; a0 * b0 0 +;; a0 * b1 1 +;; a1 * b0 2 +;; a1 * b1 3 +;; a2 * b0 4 +;; a2 * b1 5 +;; a3 * b0 6 +;; a3 * b1 7 + +;; Not working. +;; (mul-qd-dd (sqrt-qd (make-qd-dd 2w0 0w0)) 10w0) -> +;; 14.142135623730950488016887242097022172449805747901877456053837224q0 +;; +;; But clisp says +;; 14.142135623730950488016887242096980785696718753769480731766797379908L0 +;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +;; +;; Running a test program using qd (2.1.210) shows that we get the +;; same wrong answer. +#+(or) +(defun mul-qd-dd (a b) + (declare (type %quad-double a) + (double-double-float b) + (optimize (speed 3))) + (multiple-value-bind (p0 q0) + (two-prod (qd-0 a) (kernel:double-double-hi b)) + (multiple-value-bind (p1 q1) + (two-prod (qd-0 a) (kernel:double-double-lo b)) + (multiple-value-bind (p2 q2) + (two-prod (qd-1 a) (kernel:double-double-hi b)) + (multiple-value-bind (p3 q3) + (two-prod (qd-1 a) (kernel:double-double-lo b)) + (multiple-value-bind (p4 q4) + (two-prod (qd-2 a) (kernel:double-double-hi b)) + (format t "p0, q0 = ~A ~A~%" p0 q0) + (format t "p1, q1 = ~A ~A~%" p1 q1) + (format t "p2, q2 = ~A ~A~%" p2 q2) + (format t "p3, q3 = ~A ~A~%" p3 q3) + (format t "p4, q4 = ~A ~A~%" p4 q4) + (multiple-value-setq (p1 p2 q0) + (three-sum p1 p2 q0)) + (format t "p1 = ~A~%" p1) + (format t "p2 = ~A~%" p2) + (format t "q0 = ~A~%" q0) + ;; five-three-sum + (multiple-value-setq (p2 p3 p4) + (three-sum p2 p3 p4)) + (format t "p2 = ~A~%" p2) + (format t "p3 = ~A~%" p3) + (format t "p4 = ~A~%" p4) + (multiple-value-setq (q1 q2) + (two-sum q1 q2)) + (multiple-value-bind (s0 t0) + (two-sum p2 q1) + (multiple-value-bind (s1 t1) + (two-sum p3 q2) + (multiple-value-setq (s1 t0) + (two-sum s1 t0)) + (let ((s2 (cl:+ t0 t1 p4)) + (p2 s0) + (p3 (cl:+ (cl:* (qd-2 a) + (kernel:double-double-hi b)) + (cl:* (qd-3 a) + (kernel:double-double-lo b)) + q3 q4))) + (multiple-value-setq (p3 q0 s1) + (three-sum2 p3 q0 s1)) + (let ((p4 (cl:+ q0 s2))) + (multiple-value-call #'%make-qd-d + (renorm-5 p0 p1 p2 p3 p4)))))))))))) + +;; a0 * b0 0 +;; a0 * b1 1 +;; a1 * b0 2 +;; a0 * b2 3 +;; a1 * b1 4 +;; a2 * b0 5 +;; a0 * b3 6 +;; a1 * b2 7 +;; a2 * b1 8 +;; a3 * b0 9 + +;; Works +;; (mul-qd (sqrt-qd (make-qd-dd 2w0 0w0)) (make-qd-dd 10w0 0w0)) -> +;; 14.1421356237309504880168872420969807856967187537694807317667973799q0 +;; +;; Clisp says +;; 14.142135623730950488016887242096980785696718753769480731766797379908L0 +(defun mul-qd (a b) + (declare (type %quad-double a b) + (optimize (speed 3) + (space 0))) + (multiple-value-bind (a0 a1 a2 a3) + (qd-parts a) + (multiple-value-bind (b0 b1 b2 b3) + (qd-parts b) + (multiple-value-bind (p0 q0) + (two-prod a0 b0) + #+cmu + (when (float-infinity-p p0) + (return-from mul-qd (%make-qd-d p0 0d0 0d0 0d0))) + (multiple-value-bind (p1 q1) + (two-prod a0 b1) + (multiple-value-bind (p2 q2) + (two-prod a1 b0) + (multiple-value-bind (p3 q3) + (two-prod a0 b2) + (multiple-value-bind (p4 q4) + (two-prod a1 b1) + (multiple-value-bind (p5 q5) + (two-prod a2 b0) + ;; Start accumulation + (multiple-value-setq (p1 p2 q0) + (three-sum p1 p2 q0)) + + ;; six-three-sum of p2, q1, q2, p3, p4, p5 + (multiple-value-setq (p2 q1 q2) + (three-sum p2 q1 q2)) + (multiple-value-setq (p3 p4 p5) + (three-sum p3 p4 p5)) + ;; Compute (s0,s1,s2) = (p2,q1,q2) + (p3,p4,p5) + (multiple-value-bind (s0 t0) + (two-sum p2 p3) + (multiple-value-bind (s1 t1) + (two-sum q1 p4) + (let ((s2 (cl:+ q2 p5))) + (declare (double-float s2)) + (multiple-value-bind (s1 t0) + (two-sum s1 t0) + (declare (double-float s1)) + (incf s2 (cl:+ t0 t1)) + ;; O(eps^3) order terms. This is the sloppy + ;; multiplication version. Should we use + ;; the precise version? It's significantly + ;; more complex. + + (incf s1 (cl:+ (cl:* a0 b3) + (cl:* a1 b2) + (cl:* a2 b1) + (cl:* a3 b0) + q0 q3 q4 q5)) + #+nil + (format t "p0,p1,s0,s1,s2 = ~a ~a ~a ~a ~a~%" + p0 p1 s0 s1 s2) + (multiple-value-bind (r0 r1 s0 s1) + (renorm-5 p0 p1 s0 s1 s2) + (if (zerop r0) + (%make-qd-d p0 0d0 0d0 0d0) + (%make-qd-d r0 r1 s0 s1)))))))))))))))) + +;; This is the non-sloppy version. I think this works just fine, but +;; since qd defaults to the sloppy multiplication version, we do the +;; same. +#+nil +(defun mul-qd (a b) + (declare (type %quad-double a b) + (optimize (speed 3))) + (multiple-value-bind (a0 a1 a2 a3) + (qd-parts a) + (multiple-value-bind (b0 b1 b2 b3) + (qd-parts b) + (multiple-value-bind (p0 q0) + (two-prod a0 b0) + (multiple-value-bind (p1 q1) + (two-prod a0 b1) + (multiple-value-bind (p2 q2) + (two-prod a1 b0) + (multiple-value-bind (p3 q3) + (two-prod a0 b2) + (multiple-value-bind (p4 q4) + (two-prod a1 b1) + (declare (double-float q4)) + #+nil + (progn + (format t"p0, q0 = ~a ~a~%" p0 q0) + (format t"p1, q1 = ~a ~a~%" p1 q1) + (format t"p2, q2 = ~a ~a~%" p2 q2) + (format t"p3, q3 = ~a ~a~%" p3 q3) + (format t"p4, q4 = ~a ~a~%" p4 q4)) + (multiple-value-bind (p5 q5) + (two-prod a2 b0) + #+nil + (format t"p5, q5 = ~a ~a~%" p5 q5) + ;; Start accumulation + (multiple-value-setq (p1 p2 q0) + (three-sum p1 p2 q0)) + #+nil + (format t "p1 p2 q0 = ~a ~a ~a~%" p1 p2 q0) + ;; six-three-sum of p2, q1, q2, p3, p4, p5 + (multiple-value-setq (p2 q1 q2) + (three-sum p2 q1 q2)) + (multiple-value-setq (p3 p4 p5) + (three-sum p3 p4 p5)) + ;; Compute (s0,s1,s2) = (p2,q1,q2) + (p3,p4,p5) + (multiple-value-bind (s0 t0) + (two-sum p2 p3) + (multiple-value-bind (s1 t1) + (two-sum q1 p4) + (declare (double-float t1)) + (let ((s2 (cl:+ q2 p5))) + (declare (double-float s2)) + (multiple-value-bind (s1 t0) + (two-sum s1 t0) + (declare (double-float s1)) + (incf s2 (cl:+ t0 t1)) + (multiple-value-bind (p6 q6) + (two-prod a0 b3) + (multiple-value-bind (p7 q7) + (two-prod a1 b2) + (multiple-value-bind (p8 q8) + (two-prod a2 b1) + (multiple-value-bind (p9 q9) + (two-prod a3 b0) + (multiple-value-setq (q0 q3) + (two-sum q0 q3)) + (multiple-value-setq (q4 q5) + (two-sum q4 q5)) + (multiple-value-setq (p6 p7) + (two-sum p6 p7)) + (multiple-value-setq (p8 p9) + (two-sum p8 p9)) + ;; (t0,t1) = (q0,q3)+(q4,q5) + (multiple-value-setq (t0 t1) + (two-sum q0 q4)) + (setf t1 (cl:+ q3 q5)) + ;; (r0,r1) = (p6,p7)+(p8,p9) + (multiple-value-bind (r0 r1) + (two-sum p6 p8) + (declare (double-float r1)) + (incf r1 (cl:+ p7 p9)) + ;; (q3,q4) = (t0,t1)+(r0,r1) + (multiple-value-setq (q3 q4) + (two-sum t0 r0)) + (incf q4 (cl:+ t1 r1)) + ;; (t0,t1)=(q3,q4)+s1 + (multiple-value-setq (t0 t1) + (two-sum q3 s1)) + (incf t1 q4) + ;; O(eps^4) terms + (incf t1 + (cl:+ (cl:* a1 b3) + (cl:* a2 b2) + (cl:* a3 b1) + q6 q7 q8 q9 + s2)) + #+nil + (format t "p0,p1,s0,t0,t1 = ~a ~a ~a ~a ~a~%" + p0 p1 s0 t0 t1) + (multiple-value-call #'%make-qd-d + (renorm-5 p0 p1 s0 t0 t1)))))))))))))))))))) + +(defun sqr-qd (a) + "Square A" + (declare (type %quad-double a) + (optimize (speed 3) + (space 0))) + (multiple-value-bind (p0 q0) + (two-sqr (qd-0 a)) + (multiple-value-bind (p1 q1) + (two-prod (cl:* 2 (qd-0 a)) (qd-1 a)) + (multiple-value-bind (p2 q2) + (two-prod (cl:* 2 (qd-0 a)) (qd-2 a)) + (multiple-value-bind (p3 q3) + (two-sqr (qd-1 a)) + (multiple-value-setq (p1 q0) + (two-sum q0 p1)) + (multiple-value-setq (q0 q1) + (two-sum q0 q1)) + (multiple-value-setq (p2 p3) + (two-sum p2 p3)) + + (multiple-value-bind (s0 t0) + (two-sum q0 p2) + (declare (double-float t0)) + (multiple-value-bind (s1 t1) + (two-sum q1 p3) + (declare (double-float t1)) + (multiple-value-setq (s1 t0) + (two-sum s1 t0)) + (incf t0 t1) + + (multiple-value-setq (s1 t0) + (quick-two-sum s1 t0)) + (multiple-value-setq (p2 t1) + (quick-two-sum s0 s1)) + (multiple-value-setq (p3 q0) + (quick-two-sum t1 t0)) + + (let ((p4 (cl:* 2 (qd-0 a) (qd-3 a))) + (p5 (cl:* 2 (qd-1 a) (qd-2 a)))) + (declare (double-float p4)) + (multiple-value-setq (p4 p5) + (two-sum p4 p5)) + (multiple-value-setq (q2 q3) + (two-sum q2 q3)) + + (multiple-value-setq (t0 t1) + (two-sum p4 q2)) + + (incf t1 (cl:+ p5 q3)) + + (multiple-value-setq (p3 p4) + (two-sum p3 t0)) + (incf p4 (cl:+ q0 t1)) + + (multiple-value-call #'%make-qd-d + (renorm-5 p0 p1 p2 p3 p4)))))))))) + + +#-cmu +(defun div-qd (a b) + (declare (type %quad-double a b) + (optimize (speed 3) + (space 0))) + (let ((a0 (qd-0 a)) + (b0 (qd-0 b))) + (let* ((q0 (cl:/ a0 b0)) + (r (sub-qd a (mul-qd-d b q0))) + (q1 (cl:/ (qd-0 r) b0))) + #+cmu + (when (float-infinity-p q0) + (return-from div-qd (%make-qd-d q0 0d0 0d0 0d0))) + (setf r (sub-qd r (mul-qd-d b q1))) + (let ((q2 (cl:/ (qd-0 r) b0))) + (setf r (sub-qd r (mul-qd-d b q2))) + (let ((q3 (cl:/ (qd-0 r) b0))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-4 q0 q1 q2 q3) + (%make-qd-d q0 q1 q2 q3))))))) + +(defun div-qd (a b) + (declare (type %quad-double a b) + (optimize (speed 3) + (space 0))) + (let ((a0 (qd-0 a)) + (b0 (qd-0 b))) + (let* ((q0 (cl:/ a0 b0)) + (r (sub-qd a (mul-qd-d b q0))) + (q1 (cl:/ (qd-0 r) b0))) + (when (float-infinity-p q0) + (return-from div-qd (%make-qd-d q0 0d0 0d0 0d0))) + (setf r (sub-qd r (mul-qd-d b q1))) + (let ((q2 (cl:/ (qd-0 r) b0))) + (setf r (sub-qd r (mul-qd-d b q2))) + (let ((q3 (cl:/ (qd-0 r) b0))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-4 q0 q1 q2 q3) + (%make-qd-d q0 q1 q2 q3))))))) + +;; Non-sloppy divide +#+(or) +(defun div-qd (a b) + (declare (type %quad-double a b)) + (let ((a0 (qd-0 a)) + (b0 (qd-0 b))) + (let* ((q0 (cl:/ a0 b0)) + (r (sub-qd a (mul-qd-d b q0))) + (q1 (cl:/ (qd-0 r) b0))) + (setf r (sub-qd r (mul-qd-d b q1))) + (let ((q2 (cl:/ (qd-0 r) b0))) + (setf r (sub-qd r (mul-qd-d b q2))) + (let ((q3 (cl:/ (qd-0 r) b0))) + (setf r (sub-qd r (mul-qd-d b q3))) + (let ((q4 (cl:/ (qd-0 r) b0))) + (multiple-value-bind (q0 q1 q2 q3) + (renorm-5 q0 q1 q2 q3 q4) + (%make-qd-d q0 q1 q2 q3)))))))) + +;; quad-double / double +(defun div-qd-d (a b) + (declare (type %quad-double a) + (double-float b) + (optimize (speed 3) + (space 0))) + ;; Compute approximate quotient using high order doubles, then + ;; correct it 3 times using the remainder. Analogous to long + ;; division. + (let ((q0 (cl:/ (qd-0 a) b))) + #+cmu + (when (float-infinity-p q0) + (return-from div-qd-d (%make-qd-d q0 0d0 0d0 0d0))) + + ;; Compute remainder a - q0 * b + (multiple-value-bind (t0 t1) + (two-prod q0 b) + (let ((r #+cmu (sub-qd-dd a (kernel:make-double-double-float t0 t1)) + #-cmu (sub-qd a (make-qd-d t0 t1 0d0 0d0)))) + ;; First correction + (let ((q1 (cl:/ (qd-0 r) b))) + (multiple-value-bind (t0 t1) + (two-prod q1 b) + (setf r #+cmu (sub-qd-dd r (kernel:make-double-double-float t0 t1)) + #-cmu (sub-qd r (make-qd-d t0 t1 0d0 0d0))) + ;; Second correction + (let ((q2 (cl:/ (qd-0 r) b))) + (multiple-value-bind (t0 t1) + (two-prod q2 b) + (setf r #+cmu (sub-qd-dd r (kernel:make-double-double-float t0 t1)) + #-cmu (sub-qd r (make-qd-d t0 t1 0d0 0d0))) + ;; Final correction + (let ((q3 (cl:/ (qd-0 r) b))) + (make-qd-d q0 q1 q2 q3)))))))))) + +;; Sloppy version +#+cmu +(defun div-qd-dd (a b) + (declare (type %quad-double a) + (double-double-float b) + (optimize (speed 3) + (space 0))) + (let* ((q0 (cl:/ (qd-0 a) (kernel:double-double-hi b))) + (r (sub-qd-dd a (cl:* b q0)))) + (when (float-infinity-p q0) + (return-from div-qd-dd (%make-qd-d q0 0d0 0d0 0d0))) + (let ((q1 (cl:/ (qd-0 r) (kernel:double-double-hi b)))) + (setf r (sub-qd-dd r (cl:* b q1))) + (let ((q2 (cl:/ (qd-0 r) (kernel:double-double-hi b)))) + (setf r (sub-qd-dd r (cl:* b q2))) + (let ((q3 (cl:/ (qd-0 r) (kernel:double-double-hi b)))) + (make-qd-d q0 q1 q2 q3)))))) + +#+cmu +(defun make-qd-dd (a0 a1) + "Create a %quad-double from two double-double-floats" + (declare (double-double-float a0 a1) + (optimize (speed 3) (space 0))) + (make-qd-d (kernel:double-double-hi a0) + (kernel:double-double-lo a0) + (kernel:double-double-hi a1) + (kernel:double-double-lo a1))) + + +#-(or qd-inline (not cmu)) +(declaim (ext:end-block)) + +(defun abs-qd (a) + (declare (type %quad-double a)) + (if (minusp (float-sign (qd-0 a))) + (neg-qd a) + a)) + +;; a^n for an integer n +(defun npow (a n) + (declare (type %quad-double a) + (fixnum n) + (optimize (speed 3) + (space 0))) + (when (= n 0) + (return-from npow (make-qd-d 1d0))) + + (let ((r a) + (s (make-qd-d 1d0)) + (abs-n (abs n))) + (declare (type (and fixnum unsigned-byte) abs-n) + (type %quad-double r s)) + (cond ((> abs-n 1) + ;; Binary exponentiation + (loop while (plusp abs-n) + do + (when (= 1 (logand abs-n 1)) + (setf s (mul-qd s r))) + (setf abs-n (ash abs-n -1)) + (when (plusp abs-n) + (setf r (sqr-qd r))))) + (t + (setf s r))) + (if (minusp n) + (div-qd (make-qd-d 1d0) s) + s))) + +;; The n'th root of a. n is an positive integer and a should be +;; positive too. +(defun nroot-qd (a n) + (declare (type %quad-double a) + (type (and fixnum unsigned-byte) n) + (optimize (speed 3) + (space 0))) + ;; Use Newton's iteration to solve + ;; + ;; 1/(x^n) - a = 0 + ;; + ;; The iteration becomes + ;; + ;; x' = x + x * (1 - a * x^n)/n + ;; + ;; Since Newton's iteration converges quadratically, we only need to + ;; perform it twice. + (let ((r (make-qd-d (expt (the (double-float (0d0)) (qd-0 a)) + (cl:- (cl:/ (float n 1d0))))))) + (declare (type %quad-double r)) + (flet ((term () + (div-qd-d (mul-qd r + (add-qd-d (neg-qd (mul-qd a (npow r n))) + 1d0)) + (float n 1d0)))) + (dotimes (k 3) + (setf r (add-qd r (term)))) + (div-qd (make-qd-d 1d0) r)))) + +(defun qd-< (a b) + "A < B" + (or (< (qd-0 a) (qd-0 b)) + (and (= (qd-0 a) (qd-0 b)) + (or (< (qd-1 a) (qd-1 b)) + (and (= (qd-1 a) (qd-1 b)) + (or (< (qd-2 a) (qd-2 b)) + (and (= (qd-2 a) (qd-2 b)) + (< (qd-3 a) (qd-3 b))))))))) + +(defun qd-> (a b) + "A > B" + (or (> (qd-0 a) (qd-0 b)) + (and (= (qd-0 a) (qd-0 b)) + (or (> (qd-1 a) (qd-1 b)) + (and (= (qd-1 a) (qd-1 b)) + (or (> (qd-2 a) (qd-2 b)) + (and (= (qd-2 a) (qd-2 b)) + (> (qd-3 a) (qd-3 b))))))))) + +(defun qd-<= (a b) + "A > B" + (not (qd-> a b))) + +(defun qd->= (a b) + "A > B" + (not (qd-< a b))) + +(defun zerop-qd (a) + "Is A zero?" + (declare (type %quad-double a)) + (zerop (qd-0 a))) + +(defun onep-qd (a) + "Is A equal to 1?" + (declare (type %quad-double a)) + (and (= (qd-0 a) 1d0) + (zerop (qd-1 a)) + (zerop (qd-2 a)) + (zerop (qd-3 a)))) + +(defun plusp-qd (a) + "Is A positive?" + (declare (type %quad-double a)) + (plusp (qd-0 a))) + +(defun minusp-qd (a) + "Is A negative?" + (declare (type %quad-double a)) + (minusp (qd-0 a))) + +(defun qd-= (a b) + (and (= (qd-0 a) (qd-0 b)) + (= (qd-1 a) (qd-1 b)) + (= (qd-2 a) (qd-2 b)) + (= (qd-3 a) (qd-3 b)))) + + +#+nil +(defun integer-decode-qd (q) + (declare (type %quad-double q)) + (multiple-value-bind (hi-int hi-exp sign) + (integer-decode-float (realpart q)) + (if (zerop (imagpart q)) + (values (ash hi-int 106) (cl:- hi-exp 106) sign) + (multiple-value-bind (lo-int lo-exp lo-sign) + (integer-decode-float (imagpart q)) + (values (cl:+ (cl:* (cl:* sign lo-sign) lo-int) + (ash hi-int (cl:- hi-exp lo-exp))) + lo-exp + sign))))) + +(defun integer-decode-qd (q) + (declare (type %quad-double q)) + ;; Integer decode each component and then create the appropriate + ;; integer by shifting and add all the parts together. + (multiple-value-bind (q0-int q0-exp q0-sign) + (integer-decode-float (qd-0 q)) + (multiple-value-bind (q1-int q1-exp q1-sign) + (integer-decode-float (qd-1 q)) + ;; Note: Some systems return an exponent of 0 if the number is + ;; zero. If so, everything is easier if we pretend the exponent + ;; is -1075. + (when (zerop (qd-1 q)) + (setf q1-exp -1075)) + (multiple-value-bind (q2-int q2-exp q2-sign) + (integer-decode-float (qd-2 q)) + (when (zerop (qd-2 q)) + (setf q2-exp -1075)) + (multiple-value-bind (q3-int q3-exp q3-sign) + (integer-decode-float (qd-3 q)) + (when (zerop (qd-3 q)) + (setf q3-exp -1075)) + ;; Combine all the parts together. + (values (+ (* q0-sign q3-sign q3-int) + (ash (* q0-sign q2-sign q2-int) (- q2-exp q3-exp)) + (ash (* q0-sign q1-sign q1-int) (- q1-exp q3-exp)) + (ash q0-int (- q0-exp q3-exp))) + q3-exp + q0-sign)))))) + +(declaim (inline scale-float-qd)) +(defun scale-float-qd (qd k) + (declare (type %quad-double qd) + (type fixnum k) + (optimize (speed 3) (space 0))) + ;; (space 0) to get scale-double-float inlined + (multiple-value-bind (a0 a1 a2 a3) + (qd-parts qd) + (make-qd-d (scale-float a0 k) + (scale-float a1 k) + (scale-float a2 k) + (scale-float a3 k)))) + +;; The following method, which is faster doesn't work if QD is very +;; large and k is very negative because we get zero as the answer, +;; when it shouldn't be. +#+(or) +(defun scale-float-qd (qd k) + (declare (type %quad-double qd) + ;;(type (integer -1022 1022) k) + (optimize (speed 3) (space 0))) + ;; (space 0) to get scale-double-float inlined + (let ((scale (scale-float 1d0 k))) + (%make-qd-d (cl:* (qd-0 qd) scale) + (cl:* (qd-1 qd) scale) + (cl:* (qd-2 qd) scale) + (cl:* (qd-3 qd) scale)))) + +(defun decode-float-qd (q) + (declare (type %quad-double q)) + (multiple-value-bind (frac exp sign) + (decode-float (qd-0 q)) + (declare (ignore frac)) + ;; Got the exponent. Scale the quad-double appropriately. + (values (scale-float-qd q (- exp)) + exp + (make-qd-d sign)))) diff --git a/external/oct/rt-tests.lisp b/external/oct/rt-tests.lisp new file mode 100644 index 0000000..c99360b --- /dev/null +++ b/external/oct/rt-tests.lisp @@ -0,0 +1,547 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qd) + +;; Compute how many bits are the same for two numbers EST and TRUE. +;; Return T if they are identical. +(defun bit-accuracy (est true) + (let* ((diff (abs (- est true))) + (err (float (if (zerop true) + diff + (/ diff (abs true))) + 1d0))) + (if (zerop diff) + t + (- (log err 2))))) + +(defun check-accuracy (limit est true) + (let ((bits (bit-accuracy est true))) + (if (numberp bits) + (if (< bits limit) + (list bits limit est true))))) + +(defvar *null* (make-broadcast-stream)) + +;;; Some simple tests from the Yozo Hida's qd package. + +;; Pi via Machin's formula +(rt:deftest oct.pi.machin + (let* ((*standard-output* *null*) + (val (make-instance 'qd-real :value (qdi::test2))) + (true qd:+pi+)) + (check-accuracy 213 val true)) + nil) + +;; Pi via Salamin-Brent algorithm +(rt:deftest oct.pi.salamin-brent + (let* ((*standard-output* *null*) + (val (make-instance 'qd-real :value (qdi::test3))) + (true qd:+pi+)) + (check-accuracy 202 val true)) + nil) + +;; Pi via Borweign's Quartic formula +(rt:deftest oct.pi.borweign + (let* ((*standard-output* *null*) + (val (make-instance 'qd-real :value (qdi::test4))) + (true qd:+pi+)) + (check-accuracy 211 val true)) + nil) + +;; e via Taylor series +(rt:deftest oct.e.taylor + (let* ((*standard-output* *null*) + (val (make-instance 'qd-real :value (qdi::test5))) + (true (make-instance 'qd-real :value qdi::+qd-e+))) + (check-accuracy 212 val true)) + nil) + +;; log(2) via Taylor series +(rt:deftest oct.log2.taylor + (let* ((*standard-output* *null*) + (val (make-instance 'qd-real :value (qdi::test6))) + (true (make-instance 'qd-real :value qdi::+qd-log2+))) + (check-accuracy 212 val true)) + nil) + +;;; Tests of atan where we know the analytical result +(rt:deftest oct.atan.1 + (let* ((arg (/ (sqrt #q3))) + (y (/ (atan arg) +pi+)) + (true (/ #q6))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan.2 + (let* ((arg (sqrt #q3)) + (y (/ (atan arg) +pi+)) + (true (/ #q3))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan.3 + (let* ((arg #q1) + (y (/ (atan arg) +pi+)) + (true (/ #q4))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan.4 + (let* ((arg #q1q100) + (y (/ (atan arg) +pi+)) + (true #q.5)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan.5 + (let* ((arg #q-1q100) + (y (/ (atan arg) +pi+)) + (true #q-.5)) + (check-accuracy 212 y true)) + nil) + + +(defun atan-qd/duplication (arg) + (make-instance 'qd-real + :value (qdi::atan-qd/duplication (qd-value arg)))) + +;;; Tests of atan where we know the analytical result. Same tests, +;;; but using the atan duplication formula. +(rt:deftest oct.atan/dup.1 + (let* ((arg (/ (sqrt #q3))) + (y (/ (atan-qd/duplication arg) +pi+)) + (true (/ #q6))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/dup.2 + (let* ((arg (sqrt #q3)) + (y (/ (atan-qd/duplication arg) +pi+)) + (true (/ #q3))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/dup.3 + (let* ((arg #q1) + (y (/ (atan-qd/duplication arg) +pi+)) + (true (/ #q4))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/dup.4 + (let* ((arg #q1q100) + (y (/ (atan-qd/duplication arg) +pi+)) + (true #q.5)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/dup.5 + (let* ((arg #q-1q100) + (y (/ (atan-qd/duplication arg) +pi+)) + (true #q-.5)) + (check-accuracy 212 y true)) + nil) + +;;; Tests of atan where we know the analytical result. Same tests, +;;; but using a CORDIC implementation. +(defun atan-qd/cordic (arg) + (make-instance 'qd-real + :value (qdi::atan-qd/cordic (qd-value arg)))) + +(rt:deftest oct.atan/cordic.1 + (let* ((arg (/ (sqrt #q3))) + (y (/ (atan-qd/cordic arg) +pi+)) + (true (/ #q6))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/cordic.2 + (let* ((arg (sqrt #q3)) + (y (/ (atan-qd/cordic arg) +pi+)) + (true (/ #q3))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/cordic.3 + (let* ((arg #q1) + (y (/ (atan-qd/cordic arg) +pi+)) + (true (/ #q4))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/cordic.4 + (let* ((arg #q1q100) + (y (/ (atan-qd/cordic arg) +pi+)) + (true #q.5)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.atan/cordic.5 + (let* ((arg #q-1q100) + (y (/ (atan-qd/cordic arg) +pi+)) + (true #q-.5)) + (check-accuracy 212 y true)) + nil) + + +;;; Tests of sin where we know the analytical result. +(rt:deftest oct.sin.1 + (let* ((arg (/ +pi+ 6)) + (y (sin arg)) + (true #q.5)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.sin.2 + (let* ((arg (/ +pi+ 4)) + (y (sin arg)) + (true (sqrt #q.5))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.sin.3 + (let* ((arg (/ +pi+ 3)) + (y (sin arg)) + (true (/ (sqrt #q3) 2))) + (check-accuracy 212 y true)) + nil) + +;;; Tests of tan where we know the analytical result. +(rt:deftest oct.tan.1 + (let* ((arg (/ +pi+ 6)) + (y (tan arg)) + (true (/ (sqrt #q3)))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.tan.2 + (let* ((arg (/ +pi+ 4)) + (y (tan arg)) + (true #q1)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.tan.3 + (let* ((arg (/ +pi+ 3)) + (y (tan arg)) + (true (sqrt #q3))) + (check-accuracy 212 y true)) + nil) + +;;; Tests of tan where we know the analytical result. Uses CORDIC +;;; algorithm. + +(defun tan/cordic (arg) + (make-instance 'qd-real + :value (qdi::tan-qd/cordic (qd-value arg)))) + +(rt:deftest oct.tan/cordic.1 + (let* ((arg (/ +pi+ 6)) + (y (tan/cordic arg)) + (true (/ (sqrt #q3)))) + (check-accuracy 211 y true)) + nil) + +(rt:deftest oct.tan/cordic.2 + (let* ((arg (/ +pi+ 4)) + (y (tan/cordic arg)) + (true #q1)) + (check-accuracy 211 y true)) + nil) + +(rt:deftest oct.tan/cordic.3 + (let* ((arg (/ +pi+ 3)) + (y (tan/cordic arg)) + (true (sqrt #q3))) + (check-accuracy 210 y true)) + nil) + +;;; Tests of asin where we know the analytical result. + +(rt:deftest oct.asin.1 + (let* ((arg #q.5) + (y (asin arg)) + (true (/ +pi+ 6))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.asin.2 + (let* ((arg (sqrt #q.5)) + (y (asin arg)) + (true (/ +pi+ 4))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.asin.3 + (let* ((arg (/ (sqrt #q3) 2)) + (y (asin arg)) + (true (/ +pi+ 3))) + (check-accuracy 212 y true)) + nil) + +;;; Tests of log. + +(rt:deftest oct.log.1 + (let* ((arg #q2) + (y (log arg)) + (true (make-instance 'qd-real :value qdi::+qd-log2+))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.log.2 + (let* ((arg #q10) + (y (log arg)) + (true (make-instance 'qd-real :value qdi::+qd-log10+))) + (check-accuracy 207 y true)) + nil) + +(rt:deftest oct.log.3 + (let* ((arg (+ 1 (scale-float #q1 -80))) + (y (log arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (check-accuracy 212 y true)) + nil) + +;;; Tests of log using Newton iteration. + +(defun log/newton (arg) + (make-instance 'qd-real + :value (qdi::log-qd/newton (qd-value arg)))) + +(rt:deftest oct.log/newton.1 + (let* ((arg #q2) + (y (log/newton arg)) + (true (make-instance 'qd-real :value qdi::+qd-log2+))) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.log/newton.2 + (let* ((arg #q10) + (y (log/newton arg)) + (true (make-instance 'qd-real :value qdi::+qd-log10+))) + (check-accuracy 207 y true)) + nil) + +(rt:deftest oct.log/newton.3 + (let* ((arg (+ 1 (scale-float #q1 -80))) + (y (log/newton arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (check-accuracy 212 y true)) + nil) + +;;; Tests of log using AGM. + +(defun log/agm (arg) + (make-instance 'qd-real + :value (qdi::log-qd/agm (qd-value arg)))) + +(rt:deftest oct.log/agm.1 + (let* ((arg #q2) + (y (log/agm arg)) + (true (make-instance 'qd-real :value qdi::+qd-log2+))) + (check-accuracy 203 y true)) + nil) + +(rt:deftest oct.log/agm.2 + (let* ((arg #q10) + (y (log/agm arg)) + (true (make-instance 'qd-real :value qdi::+qd-log10+))) + (check-accuracy 205 y true)) + nil) + +(rt:deftest oct.log/agm.3 + (let* ((arg (+ 1 (scale-float #q1 -80))) + (y (log/agm arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (check-accuracy 123 y true)) + nil) + +;;; Tests of log using AGM2, a faster variaton of AGM. + +(defun log/agm2 (arg) + (make-instance 'qd-real + :value (qdi::log-qd/agm2 (qd-value arg)))) + +(rt:deftest oct.log/agm2.1 + (let* ((arg #q2) + (y (log/agm2 arg)) + (true (make-instance 'qd-real :value qdi::+qd-log2+))) + (check-accuracy 203 y true)) + nil) + +(rt:deftest oct.log/agm2.2 + (let* ((arg #q10) + (y (log/agm2 arg)) + (true (make-instance 'qd-real :value qdi::+qd-log10+))) + (check-accuracy 205 y true)) + nil) + +(rt:deftest oct.log/agm2.3 + (let* ((arg (+ 1 (scale-float #q1 -80))) + (y (log/agm2 arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (check-accuracy 123 y true)) + nil) + +;;; Tests of log using AGM3, a faster variation of AGM2. +(defun log/agm3 (arg) + (make-instance 'qd-real + :value (qdi::log-qd/agm3 (qd-value arg)))) + +(rt:deftest oct.log/agm3.1 + (let* ((arg #q2) + (y (log/agm3 arg)) + (true (make-instance 'qd-real :value qdi::+qd-log2+))) + (check-accuracy 203 y true)) + nil) + +(rt:deftest oct.log/agm3.2 + (let* ((arg #q10) + (y (log/agm3 arg)) + (true (make-instance 'qd-real :value qdi::+qd-log10+))) + (check-accuracy 205 y true)) + nil) + +(rt:deftest oct.log/agm3.3 + (let* ((arg (+ 1 (scale-float #q1 -80))) + (y (log/agm3 arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (check-accuracy 123 y true)) + nil) + +;;; Tests of sqrt to make sure we overflow or underflow where we +;;; shouldn't. + +(rt:deftest oct.sqrt.1 + (let* ((arg #q1q200) + (y (sqrt arg)) + (true #q1q100)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.sqrt.2 + (let* ((arg #q1q200) + (y (sqrt arg)) + (true #q1q100)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.sqrt.3 + (let* ((arg #q1q300) + (y (sqrt arg)) + (true #q1q150)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.sqrt.4 + (let* ((arg #q1q-200) + (y (sqrt arg)) + (true #q1q-100)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.sqrt.5 + (let* ((arg #q1q-250) + (y (sqrt arg)) + (true #q1q-125)) + (check-accuracy 212 y true)) + nil) + +;;; Tests of log1p(x) = log(1+x), using the duplication formula. + +(defun log1p/dup (arg) + (make-instance 'qd-real + :value (qdi::log1p-qd/duplication (qd-value arg)))) + +(rt:deftest oct.log1p.1 + (let* ((arg #q9) + (y (log1p/dup arg)) + (true #q2.3025850929940456840179914546843642076011014886287729760333279009675726096773525q0)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.log1p.2 + (let* ((arg (scale-float #q1 -80)) + (y (log1p/dup arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (check-accuracy 212 y true)) + nil) + +;;; Tests of expm1(x) = exp(x) - 1, using a Taylor series with +;;; argument reduction. + +(defun expm1/series (arg) + (make-instance 'qd-real + :value (qdi::expm1-qd/series (qd-value arg)))) + +(rt:deftest oct.expm1/series.1 + (let* ((arg #q0) + (y (expm1/series arg)) + (true #q0)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.expm1/series.2 + (let* ((arg #q1) + (y (expm1/series arg)) + (true #q1.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952q0)) + (check-accuracy 211 y true)) + nil) + +(rt:deftest oct.expm1/series.3 + (let* ((arg (scale-float #q1 -100)) + (y (expm1/series arg)) + (true #q7.888609052210118054117285652830973804370994921943802079729680186943164342372119432861876389514693341738324702996270767390039172777809233288470357147q-31)) + (check-accuracy 211 y true)) + nil) + +;;; Tests of expm1(x) = exp(x) - 1, using duplication formula. + +(defun expm1/dup (arg) + (make-instance 'qd-real + :value (qdi::expm1-qd/duplication (qd-value arg)))) + + +(rt:deftest oct.expm1/dup.1 + (let* ((arg #q0) + (y (expm1/dup arg)) + (true #q0)) + (check-accuracy 212 y true)) + nil) + +(rt:deftest oct.expm1/dup.2 + (let* ((arg #q1) + (y (expm1/dup arg)) + (true #q1.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952q0)) + (check-accuracy 211 y true)) + nil) + +(rt:deftest oct.expm1/dup.3 + (let* ((arg (scale-float #q1 -100)) + (y (expm1/dup arg)) + (true #q7.888609052210118054117285652830973804370994921943802079729680186943164342372119432861876389514693341738324702996270767390039172777809233288470357147q-31)) + (check-accuracy 211 y true)) + nil) diff --git a/external/oct/tests.lisp b/external/oct/tests.lisp new file mode 100644 index 0000000..8aba323 --- /dev/null +++ b/external/oct/tests.lisp @@ -0,0 +1,304 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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 #:qd) + +(defun bit-accuracy (est true) + (let* ((diff (abs (- est true))) + (err (float (if (zerop true) + diff + (/ diff (abs true))) + 1d0))) + (if (zerop diff) + t + (- (log err 2))))) + +(defun print-result (est true) + (format t "est: ~A~%" est) + (format t "tru: ~A~%" true) + (format t "err: ~A~%" (float (- est true) 1d0)) + (format t "bits: ~,1f~%" (bit-accuracy est true))) + +(defconstant +e+ + (make-instance 'qd-real :value qdi::+qd-e+)) + +(defconstant +log2+ + (make-instance 'qd-real :value qdi::+qd-log2+)) + +(defun test2 () + ;; pi/4 = 4 * arctan(1/5) - arctan(1/239) + ;; + ;; Arctan is computed using the Taylor series + ;; + ;; arctan(x) = x - x^3/3 + x^5/5 - x^7/7 + (flet ((atan-series (x) + (let* ((d 1d0) + (eps (float (scale-float 1d0 -212) #q1)) + (tmp x) + (r (* tmp tmp)) + (s1 #q0) + (k 0) + (sign 1)) + (loop while (> tmp eps) do + (incf k) + (setf s1 + (if (minusp sign) + (- s1 (/ tmp d)) + (+ s1 (/ tmp d)))) + (incf d 2d0) + (setf tmp (* tmp r)) + (setf sign (- sign))) + s1))) + (let* ((x1 (/ #q1 5)) + (s1 (atan-series x1)) + (x2 (/ #q1 239)) + (s2 (atan-series x2)) + (p (* (- (* s1 4) + s2) + 4))) + (format t "~2&pi via Machin's atan formula~%") + (print-result p +pi+) + p))) + +(defun test3 () + (declare (optimize (speed 3))) + ;; Salamin-Brent Quadratic formula for pi + (let* ((a #q1) + (b (sqrt #q.5)) + (s #q.5) + (m 1d0) + (p (/ (* (* a a) + 2d0) + s))) + (declare (double-float m)) + (dotimes (k 9) + (setf m (* 2 m)) + (let* ((a-new (* (+ a b) .5d0)) + (b-new (sqrt (* a b))) + (s-new (- s + (* (- (* a-new a-new) + (* b-new b-new)) + m)))) + (setf a a-new) + (setf b b-new) + (setf s s-new) + (setf p (/ (* (* a a) 2d0) + s)))) + (format t "~2&Salamin-Brent Quadratic formula for pi~%") + (print-result p +pi+) + p)) + +(defun test4 () + (declare (optimize (speed 3))) + ;; Borwein Quartic formula for pi + (let* ((a (- 6 + (* (sqrt #q2) + 4))) + (y (- (sqrt #q2) + 1)) + (m 2d0) + (p (/ a))) + (declare (double-float m)) + (dotimes (k 9) + (setf m (* 4 m)) + (let ((r (expt (- 1 (expt y 4)) + 1/4))) + (setf y (/ (- 1d0 r) + (+ 1d0 r))) + (setf a (- (* a + (expt (+ y 1d0) 4)) + (* (* y + (+ (+ y (expt y 2)) + 1d0)) + m))) + (setf p (/ a)))) + (format t "~2&Borwein's Quartic formula for pi~%") + (print-result p +pi+) + p)) + +(defun test5 () + ;; Taylor series for e + (let ((s #q2) + (tmp #q1) + (n 1d0) + (delta 0d0) + (i 0)) + (loop while (> tmp 1d-100) do + (incf i) + (incf n) + (setf tmp (/ tmp n)) + (setf s (+ s tmp))) + (format t "~2&e via Taylor series~%") + (print-result s +e+) + s)) + +(defun test6 () + ;; Taylor series for log 2 + ;; + ;; -log(1-x) = x + x^2/2 + x^3/3 + x^4/4 + ... + ;; + ;; with x = 1/2 to get log(1/2) = -log(2) + (let ((s #q.5) + (tt #q.5) + (n 1d0) + (i 0)) + (loop while (> tt 1d-100) do + (incf i) + (incf n) + (setf tt (* tt .5d0)) + (setf s (+ s + (/ tt n)))) + (format t "~2&log(2) via Taylor series~%") + (print-result s +log2+) + s)) + +(defun test-atan () + (let* ((arg (/ (sqrt #q3))) + (y (/ (atan arg) +pi+)) + (true (/ #q6))) + (format t "~2&atan for special args~%") + (format t "atan(1/sqrt(3))/pi = 1/6~%") + (print-result y true)) + ;; atan(sqrt(3)) = %pi/3 + (let* ((arg (sqrt #q3)) + (y (/ (atan arg) +pi+)) + (true (/ #q3))) + (format t "atan(sqrt(3))/pi = 1/3~%") + (print-result y true)) + ;; atan(1) = %pi/4 + (let* ((arg #q1) + (y (/ (atan arg) +pi+)) + (true (/ #q4))) + (format t "atan(1)/pi = 1/4~%") + (print-result y true)) + (let* ((arg #q1q100) + (y (/ (atan arg) +pi+)) + (true #q.5)) + (format t "atan(1q100)/pi = 1/2~%") + (print-result y true)) + (let* ((arg #q-1q100) + (y (/ (atan arg) +pi+)) + (true #q-.5)) + (format t "atan(-1q100)/pi = -1/2~%") + (print-result y true))) + +(defun test-sin () + (format t "~2&sin for special args~%") + (let* ((arg (/ +pi+ 6)) + (y (sin arg)) + (true #q.5)) + (format t "sin(pi/6) = 1/2~%") + (print-result y true)) + (let* ((arg (/ +pi+ 4)) + (y (sin arg)) + (true (sqrt #q.5))) + (format t "sin(pi/4) = 1/sqrt(2)~%") + (print-result y true)) + (let* ((arg (/ +pi+ 3)) + (y (sin arg)) + (true (/ (sqrt #q3) 2))) + (format t "sin(pi/3) = sqrt(3)/2~%") + (print-result y true))) + +(defun test-tan () + (format t "~2&tan for special args~%") + (let* ((arg (/ +pi+ 6)) + (y (tan arg)) + (true (/ (sqrt #q3)))) + (format t"tan(pi/6) = 1/sqrt(3)~%") + (print-result y true)) + (let* ((arg (/ +pi+ 4)) + (y (tan arg)) + (true #q1)) + (format t "tan(pi/4) = 1~%") + (print-result y true)) + (let* ((arg (/ +pi+ 3)) + (y (tan arg)) + (true (sqrt #q3))) + (format t "tan(pi/3) = sqrt(3)~%") + (print-result y true))) + +(defun test-asin () + (format t "~2&asin for special args~%") + (let* ((arg #q.5) + (y (asin arg)) + (true (/ +pi+ 6))) + (format t "asin(1/2) = pi/6~%") + (print-result y true)) + (let* ((arg (sqrt #q.5)) + (y (asin arg)) + (true (/ +pi+ 4))) + (format t "asin(1/sqrt(2) = pi/4~%") + (print-result y true)) + (let* ((arg (/ (sqrt #q3) 2)) + (y (asin arg)) + (true (/ +pi+ 3))) + (format t "asin(sqrt(3)/2) = pi/3~%") + (print-result y true))) + +(defun test-log () + (format t "~2&Log for special args~%") + (let* ((arg #q2) + (y (log arg)) + (true +log2+)) + (format t "log(2)~%") + (print-result y true)) + (let* ((arg #q10) + (y (log arg)) + (true (make-instance 'qd-real :value qdi::+qd-log10+))) + (format t "log(10)~%") + (print-result y true)) + (let* ((arg (+ 1 (scale-float #q1 -80))) + (y (log arg)) + (true #q8.2718061255302767487140834995607996176476940491239977084112840149578911975528492q-25)) + (format t "log(1+2^-80)~%") + (print-result y true))) + +(defun test-sqrt () + (format t "~2&Sqrt for special args~%") + (dolist (f '((#q1q200 #q1q100) + (#q1q300 #q1q150) + (#q1q308 #q1q154) + (#q1q-200 #q1q-100) + (#q1q-250 #q1q-125))) + (destructuring-bind (arg true) + f + (let ((y (sqrt arg))) + (format t "sqrt(~/qdi::qd-format/)~%" (qd-value arg)) + (print-result y true))))) + +(defun all-tests () + (test2) + (test3) + (test4) + (test5) + (test6) + (test-atan) + (test-sin) + (test-tan) + (test-asin) + (test-log) + (test-sqrt)) diff --git a/external/oct/timing.lisp b/external/oct/timing.lisp new file mode 100644 index 0000000..89a7551 --- /dev/null +++ b/external/oct/timing.lisp @@ -0,0 +1,176 @@ +;;;; -*- Mode: lisp -*- +;;;; +;;;; Copyright (c) 2007 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. + + +;;; Some simple timing tests +(in-package #:oct) + +(defun time-add (&optional (n 100000)) + (declare (fixnum n)) + (flet ((sum-double () + (let ((sum 0d0)) + (declare (double-float sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (cl:+ sum 1d0))) + sum)) + (sum-%qd () + (let ((sum (qdi::make-qd-d 0d0)) + (one (qdi::make-qd-d 1d0))) + (declare (type qdi::%quad-double sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (add-qd sum one))) + sum)) + (sum-qd () + (let ((sum #q0)) + (declare (type qd-real sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (+ sum #q1))) + sum))) + (format t "Add double-floats ~d times~%" n) + #+cmu (ext:gc :full t) + (time (sum-double)) + (format t "Add %quad-double (internal) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (sum-%qd)) + (format t "Add QD-REAL (method) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (sum-qd)))) + + +(defun time-mul (&optional (n 100000)) + (declare (fixnum n)) + (flet ((mul-double () + (let ((sum 0d0)) + (declare (double-float sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (cl:* sum 1d0))) + sum)) + (mul-%qd () + (let ((sum (qdi::make-qd-d 0d0)) + (one (qdi::make-qd-d 1d0))) + (declare (type qdi::%quad-double sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (mul-qd sum one))) + sum)) + (mul-qd () + (let ((sum #q0)) + (declare (type qd-real sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (* sum #q1))) + sum))) + (format t "Multiply double-floats ~d times~%" n) + #+cmu (ext:gc :full t) + (time (mul-double)) + (format t "Multiply %quad-double (internal) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (mul-%qd)) + (format t "Multiply QD-REAL (method) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (mul-qd)))) + +(defun time-div (&optional (n 100000)) + (declare (fixnum n)) + (flet ((div-double () + (let ((sum 7d0)) + (declare (double-float sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (cl:/ sum 1d0))) + sum)) + (div-%qd () + (let ((sum (qdi::make-qd-d 7d0)) + (one (qdi::make-qd-d 1d0))) + (declare (type qdi::%quad-double sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (div-qd sum one))) + sum)) + (div-qd () + (let ((sum #q7)) + (declare (type qd-real sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (/ sum #q1))) + sum))) + (format t "Divide double-floats ~d times~%" n) + #+cmu (ext:gc :full t) + (time (div-double)) + (format t "Divide %quad-double (internal) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (div-%qd)) + (format t "Divide QD-REAL (method) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (div-qd)))) + +(defun time-sqrt (&optional (n 100000)) + (declare (fixnum n)) + (flet ((sqrt-double () + (let ((sum 7d0)) + (declare (double-float sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (cl:sqrt sum))) + sum)) + (sqrt-%qd () + (let ((sum (qdi::make-qd-d 7d0))) + (declare (type qdi::%quad-double sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (sqrt-qd sum))) + sum)) + (sqrt-qd-real () + (let ((sum #q7)) + (declare (type qd-real sum) + (optimize (speed 3))) + (dotimes (k n) + (declare (fixnum k)) + (setf sum (sqrt sum))) + sum))) + (format t "Sqrt double-floats ~d times~%" n) + #+cmu (ext:gc :full t) + (time (sqrt-double)) + (format t "Sqrt %quad-double (internal) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (sqrt-%qd)) + (format t "Sqrt QD-REAL (method) ~d times~%" n) + #+cmu (ext:gc :full t) + (time (sqrt-qd-real)))) -- 2.11.4.GIT