source: project/release/5/fp-utils/trunks/fp-utils.scm @ 35993

Last change on this file since 35993 was 35993, checked in by kon, 10 months ago

C5 initial

File size: 6.4 KB
Line 
1;;;; fp-utils.scm
2;;;; Kon Lovett, May '17
3;;;; Kon Lovett, Mar '18
4
5;;;; Issues
6;;
7;; - all instances of (fl< -0.0 0.0) found ?
8
9(declare
10  (bound-to-procedure
11    ##sys#flonum-fraction
12    ##sys#check-inexact) )
13
14(module fp-utils
15
16(;export
17  ;
18  ;check-inexact
19  ;
20  fprandom
21  ;
22  fpzero? fppositive? fpnatural? fpnegative? fpnon-positive?
23  ;
24  fpeven? fpodd?
25  ;
26  fpclosed-right? fpclosed? fpclosed-left? fpclosedr? fpclosedl?
27  ;
28  fpadd1 fpsub1
29  ;
30  fpmodulo
31  fpquotient fpremainder
32  ;
33  fpfraction
34  ;
35  fptruncate-with-precision
36  fpround-with-precision
37  fpceiling-with-precision
38  fpfloor-with-precision
39  ;
40  fp~= fp~<= fp~>=
41  ;
42  fpsqr fpcub
43  ;
44  fpdegree->radian fpradian->degree
45  ;
46  fpdistance fpdistance*
47  ;
48  fpmax-and-min
49  ;
50  fpprecision-factor
51  ;DEPRECATED
52  fptruncate/precision fpround/precision fpceiling/precision fpfloor/precision
53  fpcardinal?)
54
55(import scheme chicken foreign)
56(use
57  (only extras random)
58  (only mathh log10))
59
60;;;
61
62(define C_fmod
63  (foreign-lambda double "fmod" double double))
64
65(define C_remainder
66  (foreign-lambda double "remainder" double double))
67
68(: *fpeven? (float --> boolean))
69;
70(define (*fpeven? n)
71  (let ((r (##sys#flonum-fraction (fp/ n 2.0))))
72    (or (fp= 0.0 r) (fp= -0.0 r)) ) )
73
74(define (check-inexact loc obj)
75  (##sys#check-inexact obj loc)
76  obj )
77
78;;;
79
80;;
81
82(: fprandom (#!optional (or float fixnum) -> float))
83;
84(define (fprandom #!optional lim (low 0))
85  (let* (
86    (low (inexact->exact low))
87    (lim
88      (cond
89        ((not lim)
90          most-positive-fixnum )
91        ((flonum? lim)
92          (let (
93            (sign? (fpnegative? lim))
94            (lim (inexact->exact (expt 10 (round (log10 (abs lim)))))) )
95            (if sign? (fxneg lim) lim) ) )
96        (else
97          lim ) ) ) )
98    (if (fx>= low lim)
99      +nan.0
100      (let* (
101        (dif (fx- lim low))
102        (rnd (random dif))
103        (rnd (fx+ low rnd)) )
104        (fp/ 1.0 (exact->inexact rnd)) ) ) ) )
105
106;;
107
108(: fpzero? (float --> boolean))
109;
110(define (fpzero? n)
111  (or (fp= 0.0 n) (fp= -0.0 n)) )
112
113(: fppositive? (float --> boolean))
114;
115(define (fppositive? n)
116  (fp< 0.0 n) )
117
118(: fpnatural? (float --> boolean))
119;
120(define (fpnatural? n)
121  (fp<= 0.0 n) )
122
123(: fpcardinal? (depreacated fpnatural?))
124;
125(define fpcardinal fpnatural?)
126
127(: fpnegative? (float --> boolean))
128;
129(define (fpnegative? n)
130  (fp> 0.0 n) )
131
132(: fpnon-positive? (float --> boolean))
133;
134(define (fpnon-positive? n)
135  (fp>= 0.0 n) )
136
137;;
138
139(: fpeven? (float --> boolean))
140;
141(define (fpeven? n)
142  (and
143    (fpinteger? n)
144    (*fpeven? n)) )
145
146(: fpodd? (float --> boolean))
147;
148(define (fpodd? n)
149  (and
150    (fpinteger? n)
151    (not (*fpeven? n))) )
152
153;;
154
155(: fpclosed-right? (float float float --> boolean))
156;
157(define (fpclosed-right? l x h)
158  (and (fp< l x) (fp<= x h)) )
159
160(: fpclosed? (float float float --> boolean))
161;
162(define (fpclosed? l x h)
163  (and (fp<= l x) (fp<= x h)) )
164
165(: fpclosed-left? (float float float --> boolean))
166;
167(define (fpclosed-left? l x h)
168  (and (fp<= l x) (fp< x h)) )
169
170(define fpclosedr? fpclosed-right?)
171(define fpclosedl? fpclosed-left?)
172
173;;
174
175(: fpadd1 (float --> float))
176;
177(define (fpadd1 n)
178  (fp+ n 1.0) )
179
180(: fpsub1 (float --> float))
181;
182(define (fpsub1 n)
183  (fp- n 1.0) )
184
185;;
186
187(: fpmodulo (float float --> float))
188;
189(define (fpmodulo x y)
190  (fptruncate
191    (C_fmod
192      (check-inexact 'fpmodulo x)
193      (check-inexact 'fpmodulo y))) )
194
195(: fpquotient (float float --> float))
196;
197(define (fpquotient x y)
198  (fptruncate (fp/ x y)) )
199
200(: fpremainder (float float --> float))
201;
202(define (fpremainder x y)
203  (fptruncate
204    (C_remainder
205      (check-inexact 'fpremainder x)
206      (check-inexact 'fpremainder y))) )
207
208;;
209
210(: fpfraction (float --> float))
211;
212(define (fpfraction n)
213        (##sys#flonum-fraction n) )
214
215;;;
216
217;;
218
219(: fp~= (float float #!optional float --> boolean))
220;
221(define (fp~= x y #!optional (eps flonum-epsilon))
222  (let (
223    (diff (fp- x y)) )
224    (or
225      ;(fpzero? diff) ;really, how often is this true?
226      (fp<= (fpabs diff) eps) ) ) )
227
228(: fp~<= (float float #!optional float --> boolean))
229;
230(define (fp~<= x y #!optional (eps flonum-epsilon))
231  (or
232    (fp< x y)
233    (fp~= x y eps) ) )
234
235(: fp~>= (float float #!optional float --> boolean))
236;
237(define (fp~>= x y #!optional (eps flonum-epsilon))
238  (or
239    (fp> x y)
240    (fp~= x y eps) ) )
241
242;;;
243
244;;
245
246(: fpsqr (float --> float))
247;
248(define (fpsqr n)
249  (fp* n n) )
250
251(: fpcub (float --> float))
252;
253(define (fpcub n)
254  (fp* n (fp* n n)) )
255
256;;;
257
258(define-constant PRECISION-DEFAULT 4.0)
259
260(define-syntax make-unary-with-precision
261  (syntax-rules ()
262    ((_ ?op)
263      (lambda (n #!optional (p PRECISION-DEFAULT))
264        (if (fpzero? p)
265          (?op n)
266          (let ((precfact (fpprecision-factor p)))
267            (fp/ (?op (fp* n precfact)) precfact) ) ) ) ) ) )
268
269;;
270
271(: fptruncate-with-precision (float #!optional float --> float))
272;
273(define fptruncate-with-precision (make-unary-with-precision fptruncate))
274
275(: fpround-with-precision (float #!optional float --> float))
276;
277(define fpround-with-precision (make-unary-with-precision fpround))
278
279(: fpceiling-with-precision (float #!optional float --> float))
280;
281(define fpceiling-with-precision (make-unary-with-precision fpceiling))
282
283(: fpfloor-with-precision (float #!optional float --> float))
284;
285(define fpfloor-with-precision (make-unary-with-precision fpfloor))
286
287;;
288
289(define-constant DEGREE 0.0174532925199432957692369076848861271344) ;pi/180
290
291(: fpdegree->radian (float --> float))
292;
293(define (fpdegree->radian deg)
294  (fp* deg DEGREE) )
295
296(: fpradian->degree (float --> float))
297;
298(define (fpradian->degree rad)
299  (fp/ rad DEGREE) )
300
301;;
302
303(: fpdistance (float float float float --> float))
304;
305(define (fpdistance x1 y1 x2 y2)
306  (fpsqrt (fpdistance* x1 y1 x2 y2)) )
307
308(: fpdistance* (float float float float --> float))
309;
310(define (fpdistance* x1 y1 x2 y2)
311  (fp+ (fpsqr (fp- x1 x2)) (fpsqr (fp- y1 y2))) )
312
313;;
314
315(: fpmax-and-min (float #!rest float --> float float))
316;
317(define (fpmax-and-min fp . fps)
318  (let loop ((fps fps) (mx fp) (mn fp))
319    (if (null? fps)
320      (values mx mn)
321      (let ((cur (car fps)))
322        (loop (cdr fps) (fpmax mx cur) (fpmin mn cur)) ) ) ) )
323
324;;
325
326(: fpprecision-factor ((or float fixnum) #!optional float --> float))
327;
328(define (fpprecision-factor p #!optional (base 10.0))
329  (fpexpt base (exact->inexact p)) )
330
331;;DEPRECATED
332
333(define fptruncate/precision fptruncate-with-precision)
334(define fpround/precision fpround-with-precision)
335(define fpceiling/precision fpceiling-with-precision)
336(define fpfloor/precision fpfloor-with-precision)
337
338) ;fp-utils
Note: See TracBrowser for help on using the repository browser.