/[scm]/scm/Transcen.scm
ViewVC logotype

Contents of /scm/Transcen.scm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations) (download)
Wed Jan 10 20:50:01 2018 UTC (6 years, 2 months ago) by jaffer
Branch: MAIN
CVS Tags: scm-5f3, scm-5f4, HEAD
Branch point for: devel
Changes since 1.29: +1 -1 lines
* Transcen.scm (real-log): Permit second argument to be 0.

1 ;;;; "Transcen.scm", Complex transcendental functions for SCM.
2 ;; Copyright (C) 1992, 1993, 1995, 1997, 2005, 2006, 2018 Free Software Foundation, Inc.
3 ;;
4 ;; This program is free software: you can redistribute it and/or modify
5 ;; it under the terms of the GNU Lesser General Public License as
6 ;; published by the Free Software Foundation, either version 3 of the
7 ;; License, or (at your option) any later version.
8 ;;
9 ;; This program is distributed in the hope that it will be useful, but
10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;; Lesser General Public License for more details.
13 ;;
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this program. If not, see
16 ;; <http://www.gnu.org/licenses/>.
17
18 ;;; Author: Jerry D. Hedden.
19
20 ;;;; 2005-05 SRFI-70 extensions.
21 ;;; Author: Aubrey Jaffer
22
23 (define compile-allnumbers #t) ;for HOBBIT compiler
24
25 ;;;; Legacy real function names
26 (cond
27 ((defined? $exp)
28 (define real-sqrt $sqrt)
29 (define real-exp $exp)
30 (define real-expt $expt)
31 (define real-ln $log)
32 (define real-log10 $log10)
33
34 (define real-sin $sin)
35 (define real-cos $cos)
36 (define real-tan $tan)
37 (define real-asin $asin)
38 (define real-acos $acos)
39 (define real-atan $atan)
40
41 (define real-sinh $sinh)
42 (define real-cosh $cosh)
43 (define real-tanh $tanh)
44 (define real-asinh $asinh)
45 (define real-acosh $acosh)
46 (define real-atanh $atanh))
47
48 (else
49 (define $sqrt real-sqrt)
50 (define $exp real-exp)
51 (define $expt real-expt)
52 (define $log real-ln)
53 (define $log10 real-log10)
54
55 (define $sin real-sin)
56 (define $cos real-cos)
57 (define $tan real-tan)
58 (define $asin real-asin)
59 (define $acos real-acos)
60 (define $atan real-atan)
61
62 (define $sinh real-sinh)
63 (define $cosh real-cosh)
64 (define $tanh real-tanh)
65 (define $asinh real-asinh)
66 (define $acosh real-acosh)
67 (define $atanh real-atanh)))
68
69 (define (real-log base x)
70 (if (and (real? x) (not (negative? x)) (real? base) (positive? base))
71 (/ (real-ln x) (real-ln base))
72 (slib:error 'real-log base x)))
73
74 (define $pi (* 4 (real-atan 1)))
75 (define pi $pi)
76 (define (pi* z) (* $pi z))
77 (define (pi/ z) (/ $pi z))
78
79 ;;;; Complex functions
80
81 (define (exp z)
82 (if (real? z) (real-exp z)
83 (make-polar (real-exp (real-part z)) (imag-part z))))
84
85 (define (ln z)
86 (if (and (real? z) (>= z 0))
87 (real-ln z)
88 (make-rectangular (real-ln (magnitude z)) (angle z))))
89 (define log ln)
90
91 (define (sqrt z)
92 (if (real? z)
93 (if (negative? z) (make-rectangular 0 (real-sqrt (- z)))
94 (real-sqrt z))
95 (make-polar (real-sqrt (magnitude z)) (/ (angle z) 2))))
96
97 (define (sinh z)
98 (if (real? z) (real-sinh z)
99 (let ((x (real-part z)) (y (imag-part z)))
100 (make-rectangular (* (real-sinh x) (real-cos y))
101 (* (real-cosh x) (real-sin y))))))
102 (define (cosh z)
103 (if (real? z) (real-cosh z)
104 (let ((x (real-part z)) (y (imag-part z)))
105 (make-rectangular (* (real-cosh x) (real-cos y))
106 (* (real-sinh x) (real-sin y))))))
107 (define (tanh z)
108 (if (real? z) (real-tanh z)
109 (let* ((x (* 2 (real-part z)))
110 (y (* 2 (imag-part z)))
111 (w (+ (real-cosh x) (real-cos y))))
112 (make-rectangular (/ (real-sinh x) w) (/ (real-sin y) w)))))
113
114 (define (asinh z)
115 (if (real? z) (real-asinh z)
116 (log (+ z (sqrt (+ (* z z) 1))))))
117
118 (define (acosh z)
119 (if (and (real? z) (>= z 1))
120 (real-acosh z)
121 (log (+ z (sqrt (- (* z z) 1))))))
122
123 (define (atanh z)
124 (if (and (real? z) (> z -1) (< z 1))
125 (real-atanh z)
126 (/ (log (/ (+ 1 z) (- 1 z))) 2)))
127
128 (define (sin z)
129 (if (real? z) (real-sin z)
130 (let ((x (real-part z)) (y (imag-part z)))
131 (make-rectangular (* (real-sin x) (real-cosh y))
132 (* (real-cos x) (real-sinh y))))))
133 (define (cos z)
134 (if (real? z) (real-cos z)
135 (let ((x (real-part z)) (y (imag-part z)))
136 (make-rectangular (* (real-cos x) (real-cosh y))
137 (- (* (real-sin x) (real-sinh y)))))))
138 (define (tan z)
139 (if (real? z) (real-tan z)
140 (let* ((x (* 2 (real-part z)))
141 (y (* 2 (imag-part z)))
142 (w (+ (real-cos x) (real-cosh y))))
143 (make-rectangular (/ (real-sin x) w) (/ (real-sinh y) w)))))
144
145 (define (asin z)
146 (if (and (real? z) (>= z -1) (<= z 1))
147 (real-asin z)
148 (* -i (asinh (* +i z)))))
149
150 (define (acos z)
151 (if (and (real? z) (>= z -1) (<= z 1))
152 (real-acos z)
153 (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
154
155 (define (atan z . y)
156 (if (null? y)
157 (if (real? z)
158 (real-atan z)
159 (/ (log (/ (- +i z) (+ +i z))) +2i))
160 ($atan2 z (car y))))
161
162 ;;;; SRFI-70
163 (define (expt z1 z2)
164 (cond ((and (exact? z2) (not (and (zero? z1) (negative? z2))))
165 (integer-expt z1 z2))
166 ((zero? z2) (+ 1 (* z1 z2)))
167 ((and (real? z2) (real? z1) (positive? z1))
168 (real-expt z1 z2))
169 (else
170 (exp (* (if (zero? z1) (real-part z2) z2) (log z1))))))
171
172 (define (quo x1 x2)
173 (if (and (exact? x1) (exact? x2))
174 (quotient x1 x2)
175 (truncate (/ x1 x2))))
176
177 (define (rem x1 x2)
178 (if (and (exact? x1) (exact? x2))
179 (remainder x1 x2)
180 (- x1 (* x2 (quo x1 x2)))))
181
182 (define (mod x1 x2)
183 (if (and (exact? x1) (exact? x2))
184 (modulo x1 x2)
185 (- x1 (* x2 (floor (/ x1 x2))))))
186
187 (define (exact-round x) (inexact->exact (round x)))
188 (define (exact-floor x) (inexact->exact (floor x)))
189 (define (exact-ceiling x) (inexact->exact (ceiling x)))
190 (define (exact-truncate x) (inexact->exact (truncate x)))
191
192 (define (infinite? z) (and (= z (* 2 z)) (not (zero? z))))
193 (define (finite? z) (not (infinite? z)))
194
195 (provide 'math-real)
196 (provide 'srfi-94)

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26