├── constants.lisp ├── computable-reals.asd ├── realstst.lisp ├── get-approximations.lisp ├── package.lisp ├── LICENSE ├── README.md └── reals.lisp /constants.lisp: -------------------------------------------------------------------------------- 1 | ;;;; constants.lisp 2 | 3 | ;;;; Definition of basic constants. 4 | 5 | (in-package #:computable-reals) 6 | 7 | ;; Unfortunately these can only be forward referenced, and are only 8 | ;; calculated in get-approximations.lisp. 9 | 10 | (defvar +LOG2-R+ nil "log(2) as CREAL") 11 | (defvar +PI-R+ nil "pi as CREAL") 12 | (defvar +2PI-R+ nil "2*pi as CREAL") 13 | (defvar +PI/2-R+ nil "pi/2 as CREAL") 14 | (defvar +PI/4-R+ nil "pi/4 as CREAL") 15 | 16 | 17 | -------------------------------------------------------------------------------- /computable-reals.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:computable-reals 2 | :version "1.1.0" 3 | :author "Michael Stoll" 4 | :license "BSD 3-clause" 5 | :maintainer "Robert Smith " 6 | :description "Computable real numbers." 7 | :long-description "Arbitrary-precision, re-computing real-numbers." 8 | :serial t 9 | :components ((:file "package") 10 | (:file "constants") 11 | (:file "reals") 12 | (:file "get-approximations"))) 13 | -------------------------------------------------------------------------------- /realstst.lisp: -------------------------------------------------------------------------------- 1 | ;;;; realstst.lisp 2 | 3 | ;;;; Tests for Reals 4 | 5 | (in-package #:cr) 6 | 7 | (print-r +pi-r+ 20) 8 | (print-r (sqrt-r 2) 20) 9 | (print-r +pi-r+ 50) 10 | 11 | (defvar e163 (exp-r (*r +pi-r+ (sqrt-r 163)))) 12 | (print-r e163 20) 13 | 14 | (defvar e58 (exp-r (*r +pi-r+ (sqrt-r 58)))) 15 | (print-r e58 20) 16 | 17 | (defun get-koeffs (x n &aux (y x) q r) 18 | (dotimes (i n) 19 | (multiple-value-setq (q r) (round-r y)) 20 | (print q) 21 | (setq y (*r x r)))) 22 | 23 | (get-koeffs e163 10) 24 | (get-koeffs e58 10) 25 | (print-r (sin-r +pi-r+) 20) 26 | (print-r (cos-r +pi-r+) 20) 27 | (print-r (sin-r +pi/2-r+) 20) 28 | 29 | -------------------------------------------------------------------------------- /get-approximations.lisp: -------------------------------------------------------------------------------- 1 | ;;;; get-approximations.lisp 2 | ;;;; 3 | ;;;; Author: Robert Smith 4 | 5 | ;;;; Here we compute the constants to around 60 decimal digits after 6 | ;;;; everything has been loaded. 7 | 8 | (in-package #:computable-reals) 9 | 10 | (setf +LOG2-R+ (+r (ash-r (log-r2 1/7) 1) (log-r2 1/17)) 11 | +PI-R+ (-r (ash-r (atan-r1 1/10) 5) 12 | (ash-r (atan-r1 1/515) 4) 13 | (ash-r (atan-r1 1/239) 2)) 14 | +2PI-R+ (ash-r +pi-r+ 1) 15 | +PI/2-R+ (ash-r +pi-r+ -1) 16 | +PI/4-R+ (ash-r +pi-r+ -2)) 17 | 18 | (get-approx +log2-r+ 200) 19 | 20 | (get-approx +2pi-r+ 200) 21 | (get-approx +pi-r+ 200) 22 | (get-approx +pi/2-r+ 200) 23 | (get-approx +pi/4-r+ 200) 24 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:computable-reals 2 | (:use #:cl) 3 | (:nicknames #:cr) 4 | (:export 5 | ;; reals.lisp 6 | #:creal 7 | #:approx-r 8 | #:rational-approx-r 9 | #:rationalize-r 10 | #:make-real 11 | #:creal-p 12 | #:print-r 13 | #:+r 14 | #:-r 15 | #:*r 16 | #:/r 17 | #:sqrt-r 18 | #:log-r 19 | #:exp-r 20 | #:sin-r 21 | #:cos-r 22 | #:*print-prec* 23 | #:round-r 24 | #:*creal-tolerance* 25 | #:ash-r 26 | #:raw-approx-r 27 | #:floor-r 28 | #:ceiling-r 29 | #:truncate-r 30 | #:atan-r 31 | #:expt-r 32 | #:tan-r 33 | 34 | ;; constants.lisp 35 | #:+log2-r+ 36 | #:+pi-r+ 37 | #:+2pi-r+ 38 | #:+pi/2-r+ 39 | #:+pi/4-r+)) 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 1989/2009/2021 Michael Stoll 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Computable Reals 2 | 3 | ## Introduction 4 | 5 | Computable real numbers `x` are interpreted as (potentially) infinite 6 | fractions in base 2 that are specified through a rule for computation 7 | of an integer `a` with `|(2^k)*x - a| <= 1` for any `k>=0`. 8 | 9 | The internal data structure should not be accessed. 10 | 11 | The interface for the outside world is as follows: 12 | 13 | The type `CREAL` is a supertype of the type `RATIONAL`. `(CREAL-P x)`, for 14 | an object `x`, returns `T` if `x` is of type `CREAL`, otherwise `NIL`. 15 | 16 | `(RATIONAL-APPROX-R x k)`, for a `CREAL` `x` and an integer `k>=0`, returns a rational `a` with `|x - a| < 1/2^k`. 17 | 18 | `(MAKE-REAL fun)` returns the real number given by `fun`. Here `fun` is a 19 | function taking an argument `k`, that computes `a` as above. 20 | 21 | `CREAL`s are displayed by `PRINT` (etc.) as a decimal fraction. The 22 | error hereby is at most one unit in the last digit that was 23 | output. The number of decimal digits after the decimal point is 24 | defined through the dynamic variable `*PRINT-PREC*`. 25 | 26 | For *internal* comparison operations etc. a precision threshold is used. It is 27 | defined through the dynamic variable `*CREAL-TOLERANCE*`. Its value should 28 | be a nonnegative integer `n`, meaning that numbers are considered equal 29 | if they differ by at most `2^(-n)`. 30 | 31 | **N.B.** There are *no* external comparison functions, since 32 | comparison is in general not decidable in finite time. Instead, we 33 | recommend using ordinary Common Lisp comparison functions after 34 | producing a `k`-bit approximation using the `RATIONAL-APPROX-R` to 35 | convert a `CREAL` to a rational number. 36 | 37 | ## Exported Functions and Constants 38 | 39 | The following functions, constants and variables are exported. (The 40 | package is named `"COMPUTABLE-REALS"` or `"CR"` for short.) 41 | 42 | ``` 43 | CREAL type type of the computable real numbers 44 | CREAL-P object function tests for type CREAL 45 | *PRINT-PREC* variable specifies precision of output 46 | *CREAL-TOLERANCE* variable precision threshold for comparison 47 | APPROX-R x:creal k:int>=0 48 | function returns approximation of x to k digits 49 | MAKE-REAL function function creates object of type CREAL 50 | RATIONAL-APPROX-R x:creal k:int>0 51 | function returns a rational approximation that 52 | differs by less than 2^(-k). 53 | RATIONALIZE-R x:creal k:int>0 54 | function returns the simplest rational approximation 55 | that differs by less than 2^(-k) 56 | RAW-APPROX-R x:creal function returns 3 values a,n,s with: 57 | if a = 0: |x| <= 2^(-n), s = 0 58 | and n >= *CREAL-TOLERANCE* 59 | else: a0 integer > 4, n0 integer >=0, 60 | s = +1 or -1, and sign(x) = s, 61 | (a-1)*2^(-n) <= |x| <= (a+1)*2^(-n) 62 | PRINT-R x:creal k:int>=0 &optional (flag t) 63 | function outputs x with k decimal digits. 64 | If flag is true, first a newline. 65 | +R {creal}* function computes the sum of the arguments 66 | -R creal {creal}* function computes negative or difference 67 | *R {creal}* function computes the product of the arguments 68 | /R creal {creal}* function computes reciprocal or quotient 69 | SQRT-R creal function computes the square root 70 | +LOG2-R+ constant log(2) 71 | +PI-R+ constant pi 72 | +2PI-R+ constant 2*pi 73 | +PI/2-R+ constant pi/2 74 | +PI/4-R+ constant pi/4 75 | LOG-R x:creal &optional b:creal 76 | function computes the logarithm of n in base b; 77 | default is the natural logarithm 78 | EXP-R creal function computes the exponential function 79 | EXPT-R x:creal y:creal function computes x^y 80 | SIN-R creal function computes the sine 81 | COS-R creal function computes the cosine 82 | TAN-R creal function computes the tangent 83 | ATAN-R x:creal &optional y:creal 84 | function computes the arctangent of x or 85 | the phase angle of (x,y) 86 | ASH-R x:creal n:int function computes x * 2^n 87 | ROUND-R x:creal &optional y:creal 88 | function computes two values q (integer) and r 89 | (creal) with x = q*y + r and |r|<=|y|/2 90 | according to the precision specified by 91 | *CREAL-TOLERANCE* 92 | FLOOR-R x:creal &optional y:creal 93 | function like ROUND-R, corresponding to floor 94 | CEILING-R x:creal &optional y:creal 95 | function like ROUND-R, corresponding to ceiling 96 | TRUNCATE-R x:creal &optional y:creal 97 | function like ROUND-R, corresponding to truncate 98 | ``` 99 | 100 | 101 | 102 | 103 | -------------------------------------------------------------------------------- /reals.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Computable real numbers 2 | 3 | ;;;; Michael Stoll 4 | ;;;; 1989-06-11, 1989-06-12, 1989-06-13, 1989-06-14, 1989-06-17, 1989-06-30 5 | 6 | ;;;; Robert Smith 7 | ;;;; 2011-12-07, 2012-05-26, 2013-02-21, 2018-03-06, 2021-03-05 8 | 9 | ;;;; I N T E R N A L S T R U C T U R E S A N D I N T E R F A C E 10 | ;;;; ----------------------------------------------------------------- 11 | 12 | (in-package #:computable-reals) 13 | 14 | ;;; Computable real numbers are rational numbers or structures: 15 | 16 | (defstruct (c-real (:copier nil) 17 | (:print-function print-c-real)) 18 | (value 0 :type integer) 19 | (precision -1 :type (integer -1 *)) 20 | (compute nil :type (function ((integer 0 *)) integer) 21 | :read-only t)) 22 | 23 | #+sbcl (declaim (sb-ext:freeze-type c-real)) 24 | 25 | (deftype CREAL () 26 | "The type of the computable real numbers." 27 | '(or rational c-real)) 28 | 29 | (defun creal-p (x) 30 | "Is X a CREAL?" 31 | (typep x 'creal)) 32 | 33 | ;; If r is a c-real with (c-real-value r) = a and (c-real-precision r) = k, 34 | ;; then a*2^(-k) is an approximation of the value of the number represented 35 | ;; by r that deviates from the actual value by at most 2^(-k). 36 | ;; (c-real-compute r) is a function taking an argument k, that returns an 37 | ;; approximation of precision 2^(-k) and returns the corresponding value a. 38 | 39 | ;;; make-real creates a c-real from a computation function. 40 | 41 | (defun make-real (comp) 42 | "Create a C-REAL from a computation function COMP." 43 | (declare (type (function ((integer 0 *)) integer) comp)) 44 | (make-c-real :compute comp)) 45 | 46 | ;;; Approximating CREALs as rationals 47 | 48 | (defun APPROX-R (x k) 49 | "Computes an approximation of the bits of a given CREAL. Specifically, given an object of type creal X and a non-negative integer K, return an integer A with 50 | 51 | |A*2^(-k) - X| <= 2^(-K). 52 | 53 | See RATIONAL-APPROX-R to produce a rational approximation of CREAL." 54 | (check-type x creal) 55 | (check-type k unsigned-byte) 56 | (get-approx x k)) 57 | 58 | (defun get-approx (x k) 59 | (declare (type creal x) 60 | (type (integer 0 *) k)) 61 | (etypecase x 62 | (integer (ash x k)) 63 | (rational (round (ash (numerator x) k) (denominator x))) 64 | (c-real 65 | (if (>= (c-real-precision x) k) 66 | (ash (c-real-value x) (- k (c-real-precision x))) 67 | (let ((a (funcall (c-real-compute x) k))) 68 | (setf (c-real-value x) a (c-real-precision x) k) 69 | a))))) 70 | 71 | (defun RATIONAL-APPROX-R (x k) 72 | "Produce a rational approximation of X called R such that 73 | 74 | |R - X| < 2^(-K)." 75 | (/ (APPROX-R x k) (expt 2 k))) 76 | 77 | (defun RATIONALIZE-R (x k) 78 | "Produce a rational approximation of X called R such that 79 | 80 | |R - X| < 2^(-K), 81 | 82 | taking into account the maximum precision specified by K to return 83 | the simplest possible such approximation." 84 | (let* ((x (RATIONAL-APPROX-R x k)) 85 | i1 f1 i2 f2 86 | continued-frac) 87 | ;; See https://en.wikipedia.org/wiki/Continued_fraction#Best_rational_within_an_interval 88 | ;; 89 | ;; The simplest rational between A and B can be found by 90 | ;; constructing an continued fraction consisting of the shared 91 | ;; portion of A and B's continued fractions, then the minimum of 92 | ;; the unmatched terms plus one (if positive) or their maximum 93 | ;; minus one (if negative). Therefore, the simplest rational which 94 | ;; satisfies the equation is the simplest one between r - 1/2^(k+1) 95 | ;; and r + 1/2^(k+1) 96 | (loop 97 | :initially 98 | (setf (values i1 f1) (truncate (- x (expt 2 (- -1 k)))) 99 | (values i2 f2) (truncate (+ x (expt 2 (- -1 k))))) 100 | :do (cond 101 | ((= i1 i2) 102 | (push i1 continued-frac)) 103 | (t 104 | (push 105 | (if (plusp x) 106 | (+ (min i1 i2) 1) 107 | (- (max i1 i2) 1)) 108 | continued-frac) 109 | (loop-finish))) 110 | :until (or (eq f1 0) (eq f2 0)) 111 | :do 112 | (setf (values i1 f1) (truncate (/ f1)) 113 | (values i2 f2) (truncate (/ f2)))) 114 | (reduce 115 | (lambda (acc x) (+ x (/ acc))) 116 | continued-frac))) 117 | 118 | ;;;; ========================================================================== 119 | 120 | ;;;; V A R I A B L E S 121 | ;;;; ----------------- 122 | 123 | ;;; *print-prec* specifies how many digits after the decimal point are output 124 | ;;; (by print etc.) 125 | 126 | (defvar *PRINT-PREC* 20 127 | "number of decimal digits after the decimal point during output of CREALs") 128 | 129 | ;;; *creal-tolerance* specifies the precision of comparison operations 130 | 131 | (defvar *CREAL-TOLERANCE* 100 132 | "precision threshold for the comparison of CREALs, 133 | denoting the number of binary digits after the decimal point") 134 | 135 | ;;;; A U X I L I A R Y F U N C T I O N S 136 | ;;;; ------------------------------------- 137 | 138 | ;;; The following functions perform rounding, when less precision is needed. 139 | 140 | (defun round-cr (a k) 141 | (declare (type integer a) (type (integer 0 *) k)) 142 | (if (eql k 0) 143 | a 144 | (if (logbitp (1- k) a) (1+ (ash a (- k))) (ash a (- k))))) 145 | 146 | ;;; Auxiliary function for approximating. 147 | 148 | (defun raw-approx-cr (x) 149 | (declare (type creal x)) 150 | (do* ((k 0 (+ k 4)) 151 | (a (get-approx x 0) (get-approx x k)) 152 | (crt (+ 2 *creal-tolerance*))) 153 | ((> (abs a) 4) (values (abs a) k (signum a))) 154 | (when (> k crt) (return (values 0 (- k 3) 0))))) 155 | 156 | (defun RAW-APPROX-R (x) 157 | "Returns an approximation for CREALs" 158 | (check-type x creal) 159 | (raw-approx-cr x)) 160 | 161 | ;;;; P R I N T F U N C T I O N 162 | ;;;; --------------------------- 163 | 164 | ;;; Small auxiliary function for avoiding repeated computation: 165 | 166 | (let* ((pp *print-prec*) (tenpowerpp (expt 10 pp))) 167 | (declare (type (integer 0 *) pp tenpowerpp)) 168 | (defun tenpower (k) 169 | (declare (type (integer 0 *) k)) 170 | (if (eql k pp) 171 | tenpowerpp 172 | (let ((zhk (expt 10 k))) 173 | (when (eql k *print-prec*) (setq pp k tenpowerpp zhk)) 174 | zhk)))) 175 | 176 | ;;; The next function performs output to k digits after the decimal point, 177 | ;;; ensuring an error of at most one unit on the last digit. 178 | 179 | (defun PRINT-R (x k &optional (flag t) (stream *standard-output*)) 180 | "output function for CREALs" 181 | ;; flag /= NIL: the value is printed in a new line 182 | ;; flag = NIL: no linefeed 183 | (check-type x creal) 184 | (check-type k unsigned-byte) 185 | (check-type stream stream) 186 | (creal-print x k flag stream)) 187 | 188 | (defun creal-print (x k flag stream) 189 | (declare (type creal x) 190 | (type unsigned-byte k) 191 | (type stream stream)) 192 | (let* ((k1 (tenpower k)) 193 | (n (1+ (integer-length k1))) 194 | (x1 (get-approx x n)) 195 | (sign (signum x1)) 196 | (x2 (round-cr (* (abs x1) k1) n)) 197 | (*print-base* 10.)) 198 | (multiple-value-bind (vor nach) (floor x2 k1) 199 | (when flag (terpri stream)) 200 | (write-char (if (minusp sign) #\- #\+) stream) 201 | (prin1 vor stream) 202 | (write-char #\. stream) 203 | (let ((s (prin1-to-string nach))) 204 | (write-string (make-string (- k (length s)) :initial-element #\0) 205 | stream) 206 | (write-string s stream) 207 | (write-string "..." stream) 208 | (values))))) 209 | 210 | (defun print-c-real (x stream d) 211 | (declare (ignore d)) 212 | (creal-print x *print-prec* nil stream)) 213 | 214 | ;;;; A R I T H M E T I C 215 | ;;;; ------------------- 216 | 217 | ;;; Now comes the addition. 218 | 219 | (defun +R (&rest args &aux (sn 0) (rl nil)) 220 | "addition of CREALs" 221 | (declare (type rational sn) (type list #|(list creal)|# rl)) 222 | (dolist (x args) 223 | (etypecase x 224 | (rational (setq sn (+ x sn))) 225 | (c-real (setq rl (cons x rl)))) ) 226 | ;; sn = exact partial sum 227 | ;; rl = list of the "real" real arguments 228 | (let* ((n (length rl)) ; n = how many of them 229 | (k1 (integer-length (if (integerp sn) n (1+ n)))) 230 | ;; k1 = number of additional binary digits for the summands 231 | ) 232 | (if (eql n 0) 233 | sn ; sum is exact 234 | (make-real 235 | #'(lambda (k &aux (k2 (+ k k1))) 236 | (do ((sum (get-approx sn k2) (+ sum (get-approx (first l) k2))) 237 | (l rl (rest l))) 238 | ((null l) (round-cr sum k1)))))))) 239 | 240 | ;;; Negation: 241 | 242 | (defun minus-r (x) 243 | (etypecase x 244 | (rational (- x)) 245 | (c-real (make-real #'(lambda (k) (- (get-approx x k))))))) 246 | 247 | ;;; Subtraction: 248 | 249 | (defun -R (x1 &rest args) 250 | "subtraction and negation of CREALs" 251 | (if (null args) 252 | (minus-r x1) 253 | (+r x1 (minus-r (apply #'+r args))))) 254 | 255 | ;;; Now comes the multiplication. 256 | 257 | (defun *R (&rest args &aux (pn 1) (rl nil)) 258 | "Multiplication for CREALs" 259 | (declare (type rational pn) (type list #|(list creal)|# rl)) 260 | (dolist (x args) 261 | (etypecase x 262 | (rational (setq pn (* x pn))) 263 | (c-real (setq rl (cons x rl))))) 264 | ;; pn = product of the rational factors 265 | ;; rl = list of the c-real factors 266 | (when (or (eql pn 0) (null rl)) (return-from *r pn)) 267 | ;; If pn is a true fraction, handle it like a c-real. 268 | (unless (integerp pn) (setq rl (cons pn rl) pn 1)) 269 | (let ((y (* (length rl) (abs pn))) (al nil) (nl nil) (ns 1) ll) 270 | (dolist (x rl) 271 | (multiple-value-bind (a0 n0) (raw-approx-cr x) 272 | (setq al (cons (1+ a0) al) 273 | nl (cons n0 nl) 274 | y (* y (1+ a0)) 275 | ns (- ns n0)))) 276 | (setq ll (mapcar #'(lambda (z m) 277 | (+ m ns (integer-length (1- (ceiling y z))))) 278 | al nl) 279 | rl (nreverse rl)) 280 | ;; rl = list of the factors (not including the integer pn) 281 | ;; ll = list of the corresponding precision differences 282 | ;; nl = list of the correspodning minimum precisions 283 | (make-real 284 | #'(lambda (k) 285 | (let ((erg pn) (s (- k)) (rl rl) (ll ll) (nl nl) k1) 286 | (loop (setq k1 (max (first nl) (+ k (first ll))) 287 | s (+ s k1) 288 | erg (* erg (get-approx (first rl) k1)) 289 | rl (rest rl) 290 | ll (rest ll) 291 | nl (rest nl)) 292 | (when (null rl) 293 | (return (if (minusp s) 294 | 0 295 | (round-cr erg s)))))))))) 296 | 297 | ;;; Reciprocal: 298 | 299 | (defun invert-r (x) 300 | (etypecase x 301 | (rational (/ x)) 302 | (c-real x 303 | (multiple-value-bind (a0 n0) (raw-approx-cr x) 304 | (when (eql a0 0) (error "division by 0")) 305 | (let ((k1 (+ 4 (* 2 (- n0 (integer-length (1- a0)))))) 306 | (k2 (1+ n0))) 307 | (make-real #'(lambda (k &aux (k0 (max k2 (+ k k1)))) 308 | (round (ash 1 (+ k k0)) (get-approx x k0))))))))) 309 | 310 | ;;; Division: 311 | 312 | (defun /R (x1 &rest args) 313 | "division for CREALs" 314 | (if (null args) 315 | (invert-r x1) 316 | (*r x1 (invert-r (apply #'*r args))))) 317 | 318 | ;;; Square root: 319 | (defun rational-sqrt (x) 320 | (typecase x 321 | ((integer 0) 322 | (let ((sqrt (isqrt x))) 323 | (and (= x (* sqrt sqrt)) 324 | sqrt))) 325 | ((rational 0) 326 | (let ((numerator (rational-sqrt (numerator x))) 327 | (denominator (rational-sqrt (denominator x)))) 328 | (and numerator denominator 329 | (/ numerator denominator)))))) 330 | 331 | (defun SQRT-R (x) 332 | "square root for CREALs" 333 | (assert (creal-p x)) 334 | (or (and (rationalp x) (>= x 0) 335 | (rational-sqrt x)) 336 | (multiple-value-bind (a0 n0 s) (raw-approx-cr x) 337 | (unless (plusp s) 338 | (error "~S: attempting to compute the square root of a negative number" 339 | 'sqrt-r)) 340 | (let ((k1 (1+ (ceiling (- n0 (integer-length (1- a0))) 2))) 341 | (n1 (ceiling n0 2))) 342 | (make-real 343 | #'(lambda (k &aux (k2 (max n1 (ceiling (+ k k1) 2))) 344 | (k3 (max 0 (- k -2 k1)))) 345 | (round-cr (isqrt (ash (get-approx x (* 2 k2)) (* 2 k3))) 346 | (+ k3 k2 (- k))))))))) 347 | 348 | ;;; Now comes a round function. 349 | ;;; (round-r x y l) (x, y creal, l int>=0) returns two values q and r, 350 | ;;; where q is an integer and r a creal, so that x = q*y + r and 351 | ;;; |r| <= (1/2+2^(-l))*|y|. The default value of l is such that |r| exceeds 352 | ;;; |y|/2 by at most 2^(- *CREAL-TOLERANCE*). 353 | ;;; The third argument is specified only for internal purposes. 354 | 355 | (defun ROUND-R (x &optional (y 1) (l nil)) 356 | "round for CREALs" 357 | (divide-r 'round #'round x y l)) 358 | 359 | (defun FLOOR-R (x &optional (y 1) (l nil)) 360 | "floor for CREALs" 361 | (divide-r 'floor #'floor x y l)) 362 | 363 | (defun CEILING-R (x &optional (y 1) (l nil)) 364 | "ceiling for CREALs" 365 | (divide-r 'ceiling #'ceiling x y l)) 366 | 367 | (defun TRUNCATE-R (x &optional (y 1) (l nil)) 368 | "truncate for CREALs" 369 | (divide-r 'truncate #'truncate x y l)) 370 | 371 | (defun divide-r (name what x y l) 372 | ;; name = name of the calling function 373 | ;; 374 | ;; what = #'round, #'floor, #'ceiling or #'truncate 375 | (check-type x creal) 376 | (check-type y creal) 377 | (if (and (rationalp x) (rationalp y)) 378 | (funcall what x y) ; for rational numbers use the common function 379 | (multiple-value-bind (a0 n0) (raw-approx-cr y) 380 | (when (eql a0 0) (error "~S: division by 0" name)) 381 | (when (null l) 382 | (setq l (+ (integer-length a0) *creal-tolerance* (- n0)))) 383 | (let* ((x1 (abs (get-approx x n0))) 384 | (m (max n0 (+ l 2 n0 (integer-length (+ x1 a0 -1)) 385 | (* -2 (integer-length (1- a0)))))) 386 | (q (funcall what (get-approx x m) (get-approx y m)))) 387 | (values q (rest-help-r x y (- q))))))) 388 | 389 | ;; (rest-help-r x y q), with x,y creal, q integer, computes x + q*y. 390 | 391 | (defun rest-help-r (x y q) 392 | (declare (type creal x y) (type integer q)) 393 | (if (eql q 0) 394 | x 395 | (let ((k1 (1+ (integer-length (1- (abs q)))))) 396 | (make-real 397 | #'(lambda (k) 398 | (round-cr (+ (ash (get-approx x (+ k 2)) (- k1 2)) 399 | (* q (get-approx y (+ k k1)))) 400 | k1)))))) 401 | 402 | ;;; Now comes the arithmetic shift function for infinite binary fractions: 403 | 404 | (defun ASH-R (x n) 405 | "shift function for CREALs" 406 | (check-type x creal) 407 | (check-type n integer) 408 | (cond ((eql n 0) x) 409 | ((integerp x) 410 | (if (plusp n) (ash x n) (/ x (ash 1 (- n))))) 411 | ((rationalp x) 412 | (if (plusp n) 413 | (/ (ash (numerator x) n) (denominator x)) 414 | (/ (numerator x) (ash (denominator x) (- n))))) 415 | ((plusp n) (make-real #'(lambda (k) (get-approx x (+ k n))))) 416 | (t (make-real #'(lambda (k) 417 | (if (minusp (+ k n)) 418 | (round-cr (get-approx x 0) (- (+ k n))) 419 | (get-approx x (+ k n)))))))) 420 | 421 | ;;; Now we look at the most important transcendental functions. 422 | 423 | ;;; (log-r2 x) takes a creal x |x|<=1/2 and returns log((1+x)/(1-x)) as creal. 424 | ;;; log((1+x)/(1-x)) = 2*(x + x^3/3 + x^5/5 + ... ) 425 | 426 | (defun log-r2 (x) 427 | (declare (type creal x)) 428 | (if (eql x 0) 429 | 0 430 | (make-real 431 | #'(lambda (k) 432 | (let* ((k0 (integer-length (1- (integer-length k)))) 433 | ; k0 = extra precision needed for partial sums 434 | (k1 (+ k k0 1)) ; k1 = total precision needed 435 | ; (+1 because of factor 2) 436 | (ax (get-approx x (1+ k1))) 437 | (fx (round ax 2)) ; fx = k1-approximation of x 438 | (fx2 (round-cr (* ax ax) (+ k1 2))) ; fx2 = ditto of x^2 439 | ) 440 | (do ((n 1 (+ n 2)) 441 | (y fx (round-cr (* y fx2) k1)) 442 | (erg 0 (+ erg (round y n)))) 443 | ((< (abs y) n) (round-cr erg k0)))))))) 444 | 445 | ;;; (log-r1 x) takes a creal x from [1,2] and returns log(x) as creal 446 | 447 | (defun log-r1 (x) 448 | (declare (type creal x)) 449 | (log-r2 (transf x))) 450 | 451 | ;;; (transf x) takes a creal x from [1,2] and returns (x-1)/(x+1) as creal 452 | 453 | (defun transf (x) 454 | (declare (type creal x)) 455 | (if (rationalp x) 456 | (/ (1- x) (1+ x)) 457 | (make-real #'(lambda (k) 458 | (let ((a (get-approx x k)) (e (ash 1 k))) 459 | (round (ash (- a e) k) (+ a e))))))) 460 | 461 | ;;; Now the logarithm. 462 | 463 | (defun LOG-R (x &optional (b nil)) 464 | "logarithm for CREALs" 465 | (check-type x creal) 466 | (check-type b (or null creal)) 467 | (if b 468 | (/r (log-r x) (log-r b)) 469 | ;; remember log(2^n * a) = n*log(2) + log(a) 470 | (multiple-value-bind (a0 n0 s) (raw-approx-cr x) 471 | (unless (plusp s) 472 | (error "~S: attempt to compute the logarithm of a nonpositive number" 473 | 'log-r)) 474 | (let ((shift (- (integer-length a0) 1 n0))) 475 | (rest-help-r (log-r1 (ash-r x (- shift))) +log2-r+ shift))))) 476 | 477 | ;;; Now the exponential function. 478 | 479 | ;;; (exp-r1 x) takes a creal x with |x| <= 1/2*log(2) 480 | ;;; and returns exp(x) as creal 481 | 482 | (defun exp-r1 (x) 483 | (declare (type creal x)) 484 | (make-real 485 | #'(lambda (k) 486 | (let ((m 3) (k2 (+ k 3))) 487 | (loop (when (<= k2 (ash (- m 2) m)) (return)) 488 | (incf m)) 489 | (setq m (+ m 3) k2 (+ k m)) 490 | (do ((x1 (get-approx x k2)) 491 | (n 1 (1+ n)) 492 | (y (ash 1 k2) (round-cr (round (* y x1) n) k2)) 493 | (erg 0 (+ erg y))) 494 | ((eql y 0) (round-cr erg m))))))) 495 | 496 | (defun EXP-R (x) "exponential function for CREALs" 497 | (check-type x creal) 498 | ;; remember exp(a*log2 + b) = exp(b) * 2^a 499 | (if (eql x 0) 500 | 1 501 | (multiple-value-bind (q r) (round-r x +log2-r+ 10) 502 | (ash-r (exp-r1 r) q)))) 503 | 504 | ;;; (expt-r x y) takes creals x,y and computes x^y 505 | 506 | (defun EXPT-R (x y &aux s) 507 | "exponentiation function for CREALs" 508 | (check-type x creal) 509 | (check-type y creal) 510 | (cond ((eql y 0) 1) 511 | ((integerp y) 512 | (if (rationalp x) (expt x y) (expt-r1 x y))) 513 | ((and (rationalp y) 514 | (eql 2 (denominator y)) 515 | (rationalp x) 516 | (setq s (rational-sqrt x))) 517 | (expt s (* 2 y))) 518 | (t (exp-r (*r y (log-r x)))))) 519 | 520 | (defun expt-r1 (x y) 521 | (declare (type creal x) (integer y)) 522 | (cond ((minusp y) (expt-r1 (invert-r x) (- y))) 523 | ((eql y 1) x) 524 | ((evenp y) (expt-r1 (*r x x) (floor y 2))) 525 | (t (*r x (expt-r1 (*r x x) (floor y 2)))))) 526 | 527 | ;;; Now the trigonometric functions. 528 | 529 | ;;; (atan-r1 x) takes a creal x with |x| <= 1/2 and returns atan(x) as creal 530 | 531 | (defun atan-r1 (x) 532 | (declare (type creal x)) 533 | (if (eql x 0) 534 | 0 535 | (make-real 536 | #'(lambda (k) 537 | (let* ((k0 (integer-length (1- (integer-length k)))) 538 | ;; k0 = extra precision needed for partial sums 539 | (k1 (+ k k0)) ; k1 = total precision needed 540 | (ax (get-approx x (1+ k1))) 541 | (fx (round ax 2)) ; fx = k1-approximation of x 542 | (fx2 (- (round-cr (* ax ax) (+ k1 2)))) ; fx2 = dito of -x^2 543 | ) 544 | (do ((n 1 (+ n 2)) 545 | (y fx (round-cr (* y fx2) k1)) 546 | (erg 0 (+ erg (round y n)))) 547 | ((< (abs y) n) (round-cr erg k0)))))))) 548 | 549 | ;;; (atan-r0 x) takes a creal x and returns atan(x) as creal. 550 | 551 | (defun atan-r0 (x) 552 | (declare (type creal x)) 553 | (let ((a (get-approx x 3))) 554 | (cond ((<= -3 a 3) (atan-r1 x)) 555 | 556 | ;; atan(x) = -atan(-x) 557 | ((< a -3) (minus-r (atan-r0 (minus-r x)))) 558 | 559 | ;; atan(x) = pi/4 + atan((x-1)/(x+1)) 560 | ((< 3 a 17) (+r +pi/4-r+ (atan-r1 (transf x)))) 561 | 562 | ;; atan(x) = pi/2 - atan(1/x) 563 | (t (-r +pi/2-r+ (atan-r1 (invert-r x))))))) 564 | 565 | ;;; (atan-r x [y]) computes the arctangent of the creals x (and y if given) 566 | 567 | (defun ATAN-R (x &optional (y nil)) 568 | "arctangent for CREALs" 569 | (check-type x creal) 570 | (check-type y (or null creal)) 571 | (if (null y) 572 | (atan-r0 x) 573 | (multiple-value-bind (ay ny sy) (raw-approx-cr y) 574 | (multiple-value-bind (ax nx sx) (raw-approx-cr x) 575 | (when (and (eql 0 sy) (eql 0 sx)) 576 | (error "~S: both arguments should not be zero" 577 | 'atan)) 578 | (let ((my-mx (+ (integer-length ay) nx 579 | (- (integer-length ax)) (- ny)))) 580 | (cond ((and (plusp sy) (>= my-mx 0)) (atan-r0 (/r x y))) 581 | ((and (plusp sx) (<= my-mx 0)) 582 | (-r +pi/2-r+ (atan-r0 (/r y x)))) 583 | ((and (minusp sx) (<= my-mx 0)) 584 | (minus-r (+r (atan-r0 (/r y x)) +pi/2-r+))) 585 | ((and (minusp sy) (minusp sx) (>= my-mx 0)) 586 | (-r (atan-r0 (/r x y)) +pi-r+)) 587 | (t (+r (atan-r0 (/r x y)) +pi-r+)))))))) 588 | 589 | ;;; (sin-r1 x) takes a creal x with |x|<4 and returns sin(x) as creal. 590 | 591 | (defun sin-r1 (x) 592 | (declare (type creal x)) 593 | (make-real 594 | #'(lambda (k) 595 | (let ((m 3) (k2 (+ k 3))) 596 | (loop (when (<= k2 (ash (- m 2) m)) (return)) 597 | (incf m)) 598 | (setq m (+ m 4) k2 (+ k m)) 599 | (let ((x0 (get-approx x k2))) 600 | (do ((x1 (- (round-cr (* x0 x0) k2))) 601 | (n 2 (+ n 2)) 602 | (y x0 (round-cr (round (* y x1) (* n (1+ n))) k2)) 603 | (erg 0 (+ erg y))) 604 | ((eql y 0) (round-cr erg m)))))))) 605 | 606 | (defun SIN-R (x) 607 | "sine for CREALs" 608 | (check-type x creal) 609 | ;; remember sin(k*2pi + y) = sin(y) 610 | (if (eql x 0) 611 | 0 612 | (multiple-value-bind (q r) (round-r x +2pi-r+ 10) 613 | (declare (ignore q)) 614 | (sin-r1 r)))) 615 | 616 | ;;; (cos-r1 x) takes a creal x with |x|<4 and returns cos(x) as creal. 617 | 618 | (defun cos-r1 (x) 619 | (declare (type creal x)) 620 | (make-real 621 | #'(lambda (k) 622 | (let ((m 3) (k2 (+ k 3))) 623 | (loop (when (<= k2 (ash (- m 2) m)) (return)) 624 | (incf m)) 625 | (setq m (+ m 4) k2 (+ k m)) 626 | (let ((x0 (get-approx x k2))) 627 | (do ((x1 (- (round-cr (* x0 x0) k2))) 628 | (n 1 (+ n 2)) 629 | (y (ash 1 k2) (round-cr (round (* y x1) (* n (1+ n))) k2)) 630 | (erg 0 (+ erg y))) 631 | ((eql y 0) (round-cr erg m)))))))) 632 | 633 | (defun COS-R (x) 634 | "cosine for CREALs" 635 | (check-type x creal) 636 | ;; remember cos(k*2pi + y) = cos(y) 637 | (if (eql x 0) 638 | 1 639 | (multiple-value-bind (q r) (round-r x +2pi-r+ 10) 640 | (declare (ignore q)) 641 | (cos-r1 r)))) 642 | 643 | (defun TAN-R (x) 644 | "tangent for CREALs" 645 | (check-type x creal) 646 | (/r (sin-r x) (cos-r x))) 647 | --------------------------------------------------------------------------------