diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:36 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:36 -0800 |
commit | 5bea21e81ed516440e34e480f2c33ca41aa8c597 (patch) | |
tree | 653ace1b8fe0a9916d861d35ff8f611b46c80d37 /math-real.scm | |
parent | 237c6e380aebdcbc70bd1c9ecf7d3f6effca2752 (diff) | |
download | slib-5bea21e81ed516440e34e480f2c33ca41aa8c597.tar.gz slib-5bea21e81ed516440e34e480f2c33ca41aa8c597.zip |
Import Upstream version 3a4upstream/3a4
Diffstat (limited to 'math-real.scm')
-rw-r--r-- | math-real.scm | 91 |
1 files changed, 91 insertions, 0 deletions
diff --git a/math-real.scm b/math-real.scm new file mode 100644 index 0000000..06971d2 --- /dev/null +++ b/math-real.scm @@ -0,0 +1,91 @@ +; "math-real.scm": mathematical functions restricted to real numbers +; Copyright (C) 2006 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;@ +(define (quo x1 x2) (truncate (/ x1 x2))) +(define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) +(define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) + +(define (must-be-real name proc) + (and proc + (lambda (x1) + (if (real? x1) (proc x1) (slib:error name x1))))) +(define (must-be-real+ name proc) + (and proc + (lambda (x1) + (if (and (real? x1) (>= x1 0)) + (proc x1) + (slib:error name x1))))) +(define (must-be-real-1+1 name proc) + (and proc + (lambda (x1) + (if (and (real? x1) (<= -1 x1 1)) + (proc x1) + (slib:error name x1))))) +;@ +(define ln (and (provided? 'real) log)) +(define abs (must-be-real 'abs abs)) +(define real-sin (must-be-real 'real-sin (and (provided? 'real) sin))) +(define real-cos (must-be-real 'real-cos (and (provided? 'real) cos))) +(define real-tan (must-be-real 'real-tan (and (provided? 'real) tan))) +(define real-exp (must-be-real 'real-exp (and (provided? 'real) exp))) +(define real-ln (must-be-real+ 'ln ln)) +(define real-sqrt (must-be-real+ 'real-sqrt (and (provided? 'real) sqrt))) +(define real-asin (must-be-real-1+1 'real-asin (and (provided? 'real) asin))) +(define real-acos (must-be-real-1+1 'real-acos (and (provided? 'real) acos))) + +(define (must-be-real2 name proc) + (and proc + (lambda (x1 x2) + (if (and (real? x1) (real? x2)) + (proc x1 x2) + (slib:error name x1 x2))))) +;@ +(define make-rectangular + (must-be-real2 'make-rectangular + (and (provided? 'complex) make-rectangular))) +(define make-polar + (must-be-real2 'make-polar (and (provided? 'complex) make-polar))) + +;@ +(define real-log + (and ln + (lambda (base x) + (if (and (real? x) (positive? x) (real? base) (positive? base)) + (/ (ln x) (ln base)) + (slib:error 'real-log base x))))) + +;@ +(define (real-expt x1 x2) + (cond ((and (real? x1) + (real? x2) + (or (not (negative? x1)) (integer? x2))) + (expt x1 x2)) + (else (slib:error 'real-expt x1 x2)))) + +;@ +(define real-atan + (and (provided? 'real) + (lambda (y . x) + (if (and (real? y) + (or (null? x) + (and (= 1 (length x)) + (real? (car x))))) + (apply atan y x) + (apply slib:error 'real-atan y x))))) |