real functions is real functions
[software/python-on-guile.git] / modules / language / python / module / math.scm
1 (define-module (language python module math)
2 #:use-module (language python for)
3 #:use-module (language python try)
4 #:use-module (language python exceptions)
5 #:use-module (language python number)
6 #:use-module (system foreign)
7 #:use-module (rnrs bytevectors)
8
9 #:export (ceil copysign fabs factorial floor fmod frexp fsum gcd isclose
10 isfinite isinf isnan modf trunc exp expm1 log log1p log2 log10
11 pow sqrt acos asin atan cos sin tan atan2 hypot pi
12 degrees radians acosh asinh atanh cosh sinh tanh
13 erf erfc gamma lgamma e tau inf nan))
14
15 (define (real! s x)
16 (if (= (imag-part x) 0)
17 (real-part x)
18 (raise ValueError "real math fkn result in complex number" s)))
19
20 (define ceil
21 (lambda (x)
22 ((@ (guile) inexac->exact)
23 ((@ (guile) ceiling)
24 x))))
25
26 (define (copysign x y)
27 (let ((x ((@ (guile) abs) x)))
28 (if (< y 0) (- x) x)))
29
30 (define (fabs x) ((@ (guile) abs) x))
31
32 (define (factorial x)
33 (if (not (and (number? x) (integer? x)))
34 (raise ValueError "Not an integer"))
35 (if (< x 0)
36 (raise ValueError "Negative integer"))
37
38 (let lp ((x x))
39 (if (= x 0)
40 1
41 (* x (lp (- x 1))))))
42
43 (define (floor x)
44 ((@ (guile) inexac->exact)
45 ((@ (guile) floor)
46 x)))
47
48 (define (fmod x y) ((@ (guile) truncate-remainder) x y))
49
50 (define frexp
51 (let ((f (pointer->procedure double
52 (dynamic-func "frexp" (dynamic-link))
53 (list double '*))))
54 (lambda (x)
55 (let* ((v (make-bytevector 4))
56 (vp (bytevector->pointer v)))
57 (list (f x) (bytevector-s32-ref v 0 (native-endianness)))))))
58
59 (define (fsum it)
60 (for ((x : it)) ((s 0))
61 (+ s x)
62 #:final s))
63
64
65 (define gcd (@ (guile) gcd))
66
67 (define* (isclose a b #:key (rel_tol 1e-9) (abs_tol 0.0))
68 (define e-abs (abs (- a b)))
69 (if (< e-abs (max (* rel_tol (max (abs a) (abs b))) abs_tol))
70 #t
71 #f))
72
73 (define (isfinite x)
74 (if (or (inf? x) (nan? x))
75 #f
76 #t))
77
78 (define isinf inf?)
79 (define isnan nan?)
80
81 (define (ldexp x i) (* x ((@ (guile) expt) 2 i)))
82
83 (define (modf x)
84 (let* ((x1 (floor x))
85 (x2 (- x x1)))
86 (values x2 x1)))
87
88 (define trunc py-trunc)
89
90 ;; Power and logarithms
91 (define (exp x) (real! 'exp ((@ (guile) exp)) x))
92
93 (define expm1
94 (let ((f (pointer->procedure double
95 (dynamic-func "expm1" (dynamic-link))
96 (list double))))
97 (lambda (x) (f x))))
98
99 (define (log x) (real! 'log ((@ (guile) log)) x))
100
101 (define log1p
102 (let ((f (pointer->procedure double
103 (dynamic-func "log1p" (dynamic-link))
104 (list double))))
105
106 (lambda (x) (f x))))
107
108 (define log2
109 (let ((f (pointer->procedure double
110 (dynamic-func "log2" (dynamic-link))
111 (list double))))
112 (lambda (x) (f x))))
113
114 (define (log10 x) (real! 'log10 (@ (guile) log10)))
115
116 (define (pow x y) (real! 'pow ((@ (guile) expt) x y)))
117
118 (define (sqrt x) (real! 'sqrt (@ (guile) sqrt)))
119
120 ;; Trigs
121 (define (acos x) (real! 'acos ((@ (guile) acos) x)))
122 (define (asin x) (real! 'asin ((@ (guile) asin) x)))
123 (define (atan x) (real! 'atan ((@ (guile) atan) x)))
124 (define (cos x) (real! 'cos ( (@ (guile) cos) x)))
125 (define (sin x) (real! 'sin ( (@ (guile) sin) x)))
126 (define (tan x) (real! 'tan ( (@ (guile) tan) x)))
127
128 (define atan2
129 (let ((f (pointer->procedure double
130 (dynamic-func "atan2" (dynamic-link))
131 (list double double))))
132 (lambda (x y) (f x y))))
133
134 (define hypot
135 (let ((f (pointer->procedure double
136 (dynamic-func "hypot" (dynamic-link))
137 (list double double))))
138
139 (lambda (x y) (f x y))))
140
141
142 ;; angular conversion
143 (define pi (* 4 (atan 1)))
144
145 (define degrees
146 (let ((f (/ 360 (* 2 pi))))
147 (lambda (x) (* f x))))
148
149 (define radians
150 (let ((f (/ (* 2 pi) 360)))
151 (lambda (x) (* f x))))
152
153 ;; Hyperbolic funcitons
154 (define (acosh x) (real! 'acosh ((@ (guile) acosh) x)))
155 (define (asinh x) (real! 'asinh ((@ (guile) asinh) x)))
156 (define (atanh x) (real! 'atanh ((@ (guile) atanh) x)))
157 (define (cosh x) (real! 'cosh ( (@ (guile) cosh) x)))
158 (define (sinh x) (real! 'sinh ( (@ (guile) sinh) x)))
159 (define (tanh x) (real! 'tanh ( (@ (guile) tanh) x)))
160
161
162 ;; Special functions
163 (define erf
164 (let ((f (pointer->procedure double
165 (dynamic-func "erf" (dynamic-link))
166 (list double))))
167 (lambda (x) (f x))))
168
169 (define erfc
170 (let ((f (pointer->procedure double
171 (dynamic-func "erfc" (dynamic-link))
172 (list double))))
173 (lambda (x) (f x))))
174
175 (define gamma
176 (let ((f (pointer->procedure double
177 (dynamic-func "tgamma" (dynamic-link))
178 (list double))))
179
180 (lambda (x)
181 (if (integer? x)
182 (factorial (- x 1))
183 (f x)))))
184
185 (define lgamma
186 (let ((f (pointer->procedure double
187 (dynamic-func "lgamma" (dynamic-link))
188 (list double))))
189 (lambda (x)
190 (f x))))
191
192 ;; constants
193 (define e (exp 1))
194 (define tau (* 2 pi))
195 (define inf ((@ (guile) inf)))
196 (define nan ((@ (guile) nan)))