source: project/release/5/fp-utils/trunk/fp-utils.scm @ 36573

Last change on this file since 36573 was 36573, checked in by kon, 8 months ago

fix dir, split

File size: 3.0 KB
Line 
1;;;; fp-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Sep '18
3;;;; Kon Lovett, May '17
4
5;;;; Issues
6;;
7;; - all instances of (fl< -0.0 0.0) found ?
8
9(module fp-utils
10
11(;export
12  ;
13  fprandom
14  ;
15  fpmodulo
16  fpremainder
17  ;
18  fptruncate-with-precision
19  fpround-with-precision
20  fpceiling-with-precision
21  fpfloor-with-precision
22  ;
23  fpdistance fpdistance*
24  ;
25  fpmax-and-min)
26
27(import scheme
28  (chicken base)
29  (chicken foreign)
30  (chicken type)
31  (chicken flonum)
32  (chicken fixnum)
33  fx-utils)
34
35;;;
36
37(include "fp-inlines")
38
39;;;
40
41(: C_fmod (float float --> float))
42;
43(define C_fmod (foreign-lambda double "fmod" double double))
44
45(: C_remainder (float float --> float))
46;
47(define C_remainder (foreign-lambda double "remainder" double double))
48
49;;
50
51(: fpmodulo (float float --> float))
52;
53(define (fpmodulo x y) (fptruncate (C_fmod x y)))
54
55(: fpremainder (float float --> float))
56;
57(define (fpremainder x y) (fptruncate (C_remainder x y)))
58
59;;;
60
61(define-constant PRECISION-DEFAULT 4.0)
62
63(define-syntax make-unary-with-precision
64  (syntax-rules ()
65    ((_ ?op)
66      (lambda (n #!optional (p PRECISION-DEFAULT))
67        (if (fpzero? p)
68          (?op n)
69          (let ((precfact (fpprecision-factor p)))
70            (fp/ (?op (fp* n precfact)) precfact) ) ) ) ) ) )
71
72;;
73
74(: fptruncate-with-precision (float #!optional float --> float))
75;
76(define fptruncate-with-precision (make-unary-with-precision fptruncate))
77
78(: fpround-with-precision (float #!optional float --> float))
79;
80(define fpround-with-precision (make-unary-with-precision fpround))
81
82(: fpceiling-with-precision (float #!optional float --> float))
83;
84(define fpceiling-with-precision (make-unary-with-precision fpceiling))
85
86(: fpfloor-with-precision (float #!optional float --> float))
87;
88(define fpfloor-with-precision (make-unary-with-precision fpfloor))
89
90;;
91
92(: fpdistance (float float float float --> float))
93;
94(define (fpdistance x1 y1 x2 y2) (fpsqrt (fpdistance* x1 y1 x2 y2)))
95
96(: fpdistance* (float float float float --> float))
97;
98(define (fpdistance* x1 y1 x2 y2) (fp+ (fpsqr (fp- x1 x2)) (fpsqr (fp- y1 y2))))
99
100;;
101
102(: fpquo-and-rem (float float --> float float))
103;
104(define (fpquo-and-rem fpn fpd) (values (fpquotient fpn fpd) (fpremainder fpn fpd)))
105
106;;
107
108(: fpmax-and-min (float #!rest float --> float float))
109;
110(define (fpmax-and-min fp . fps)
111  (let loop ((fps fps) (mx fp) (mn fp))
112    (if (null? fps)
113      (values mx mn)
114      (let ((cur (car fps)))
115        (loop (cdr fps) (fpmax mx cur) (fpmin mn cur)) ) ) ) )
116
117;;
118
119(: fprandom (#!optional (or float fixnum) -> float))
120;
121(define (fprandom #!optional (lim most-positive-fixnum) (low 0.0))
122  (let* (
123    (low (inexact->exact (fptruncate low)))
124    (lim
125      (if (not (flonum? lim))
126        lim
127        (let* (
128          (neg? (fpnegative? lim))
129          (lim (inexact->exact (fpexpt 10.0 (fpround (fplog10 (fpabs lim))))))
130          (lim (fxmax most-positive-fixnum lim)) )
131          (if neg? (fxneg lim) lim)))) )
132    (if (fx>= low lim)
133      +nan.0
134      (fp/ 1.0 (exact->inexact (fxrandom lim low))) ) ) )
135
136) ;fp-utils
Note: See TracBrowser for help on using the repository browser.