source: project/release/4/mathh/trunk/fp-utils.scm @ 34818

Last change on this file since 34818 was 34818, checked in by Kon Lovett, 2 years ago

compiler can follow alias type , drop .../... as synonym for -with- in identifiers

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