blob: 06971d2843b0be31ae125588080efea144716b80 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
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)))))
|
