Changeset 36573 in project
- Timestamp:
- 09/09/18 20:03:36 (2 years ago)
- Location:
- release/5/fp-utils/trunk
- Files:
-
- 3 edited
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
release/5/fp-utils/trunk/fp-utils.scm
r35993 r36573 1 ;;;; fp-utils.scm 1 ;;;; fp-utils.scm -*- Scheme -*- 2 ;;;; Kon Lovett, Sep '18 2 3 ;;;; Kon Lovett, May '17 3 ;;;; Kon Lovett, Mar '184 4 5 5 ;;;; Issues … … 7 7 ;; - all instances of (fl< -0.0 0.0) found ? 8 8 9 (declare10 (bound-to-procedure11 ##sys#flonum-fraction12 ##sys#check-inexact) )13 14 9 (module fp-utils 15 10 16 11 (;export 17 12 ; 18 ;check-inexact19 ;20 13 fprandom 21 14 ; 22 fpzero? fppositive? fpnatural? fpnegative? fpnon-positive?23 ;24 fpeven? fpodd?25 ;26 fpclosed-right? fpclosed? fpclosed-left? fpclosedr? fpclosedl?27 ;28 fpadd1 fpsub129 ;30 15 fpmodulo 31 fpquotient fpremainder 32 ; 33 fpfraction 16 fpremainder 34 17 ; 35 18 fptruncate-with-precision … … 38 21 fpfloor-with-precision 39 22 ; 40 fp~= fp~<= fp~>=41 ;42 fpsqr fpcub43 ;44 fpdegree->radian fpradian->degree45 ;46 23 fpdistance fpdistance* 47 24 ; 48 fpmax-and-min 49 ; 50 fpprecision-factor 51 ;DEPRECATED 52 fptruncate/precision fpround/precision fpceiling/precision fpfloor/precision 53 fpcardinal?) 25 fpmax-and-min) 54 26 55 (import scheme chicken foreign) 56 (use 57 (only extras random) 58 (only mathh log10)) 27 (import scheme 28 (chicken base) 29 (chicken foreign) 30 (chicken type) 31 (chicken flonum) 32 (chicken fixnum) 33 fx-utils) 59 34 60 35 ;;; 61 36 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 ) 37 (include "fp-inlines") 77 38 78 39 ;;; 79 40 80 ;; 41 (: C_fmod (float float --> float)) 42 ; 43 (define C_fmod (foreign-lambda double "fmod" double double)) 81 44 82 (: fprandom (#!optional (or float fixnum)-> float))45 (: C_remainder (float float --> float)) 83 46 ; 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) ) 47 (define C_remainder (foreign-lambda double "remainder" double double)) 184 48 185 49 ;; … … 187 51 (: fpmodulo (float float --> float)) 188 52 ; 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)) ) 53 (define (fpmodulo x y) (fptruncate (C_fmod x y))) 199 54 200 55 (: fpremainder (float float --> float)) 201 56 ; 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)) ) 57 (define (fpremainder x y) (fptruncate (C_remainder x y))) 255 58 256 59 ;;; … … 287 90 ;; 288 91 289 (define-constant DEGREE 0.0174532925199432957692369076848861271344) ;pi/180 92 (: fpdistance (float float float float --> float)) 93 ; 94 (define (fpdistance x1 y1 x2 y2) (fpsqrt (fpdistance* x1 y1 x2 y2))) 290 95 291 (: fpd egree->radian (float --> float))96 (: fpdistance* (float float float float --> float)) 292 97 ; 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) ) 98 (define (fpdistance* x1 y1 x2 y2) (fp+ (fpsqr (fp- x1 x2)) (fpsqr (fp- y1 y2)))) 300 99 301 100 ;; 302 101 303 (: fp distance (float float float float -->float))102 (: fpquo-and-rem (float float --> float float)) 304 103 ; 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))) ) 104 (define (fpquo-and-rem fpn fpd) (values (fpquotient fpn fpd) (fpremainder fpn fpd))) 312 105 313 106 ;; … … 324 117 ;; 325 118 326 (: fp precision-factor ((or float fixnum) #!optional float --> float))119 (: fprandom (#!optional (or float fixnum) -> float)) 327 120 ; 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) 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))) ) ) ) 337 135 338 136 ) ;fp-utils -
release/5/fp-utils/trunk/test/fp-utils-test.scm
r35993 r36573 1 ;;;; mathh-test2 ;;;; Kon Lovett, May '171 ;;;; fp-utils-test -*- Scheme -*- 2 ;;;; Kon Lovett, Sep '18 3 3 4 ;;;; Issues 5 ;;;; 4 (import test) 6 5 7 ( require-extension test)6 (test-begin "Fp Utils") 8 7 9 8 ;;; 10 9 11 ;;; 10 (import (chicken base) (chicken flonum)) 12 11 13 ( require-extension fp-utils)12 (include "fp-inlines") 14 13 15 (define-constant 5eps (fp/ 9.0 1e06)) 16 (define-constant 4eps (fp/ 9.0 1e05)) 17 18 (test-group "FP Utils" 14 (test-group "Fp Inlines" 19 15 20 16 (test-assert (fpzero? 0.0)) … … 40 36 (test-assert (fpodd? 7.0)) 41 37 42 (test-assert (flonum? (fprandom)))43 (test-assert (flonum? (fprandom 2456)))44 45 38 (test 4.0 (fpadd1 3.0)) 46 39 (test 2.0 (fpsub1 3.0)) … … 53 46 (test 2.0 (fpquotient 5.0 2.0)) 54 47 (test 1.0 (fpremainder 5.0 2.0)) 48 ) 49 50 ;; 51 52 (define-constant 5eps (fp/ 9.0 1e06)) 53 (define-constant 4eps (fp/ 9.0 1e05)) 54 55 (test-group "Fp Utils" 56 57 (test-assert (flonum? (fprandom))) 58 (test-assert (flonum? (fprandom 2456))) 55 59 56 60 (test-assert (fp~= 0.123456 0.123457 5eps)) … … 70 74 ;;; 71 75 72 (test-end "mathh") 73 74 ;;; 76 (test-end "Fp Utils") 75 77 76 78 (test-exit) -
release/5/fp-utils/trunk/test/run.scm
r35993 r36573 1 1 2 (define EGG-NAME " mathh")2 (define EGG-NAME "fp-utils") 3 3 4 4 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>" 5 5 6 (use files) 6 (import 7 (only (chicken pathname) make-pathname) 8 (only (chicken process) system) 9 (only (chicken process-context) argv) 10 (only (chicken format) format)) 11 12 (define *args* (argv)) 7 13 8 14 ;no -disable-interrupts 9 (define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2") 10 11 (define *args* (argv)) 15 (define *csc-options* "-inline-global \ 16 -specialize -optimize-leaf-routines -clustering -lfa2 \ 17 -local -inline \ 18 -no-trace -no-lambda-info \ 19 -unsafe") 12 20 13 21 (define (test-name #!optional (eggnam EGG-NAME)) … … 29 37 (define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*)) 30 38 (let ((tstnam (test-name eggnam))) 31 ( print "*** csi ***")39 (format #t "*** csi ***~%") 32 40 (system (string-append "csi -s " (make-pathname #f tstnam "scm"))) 33 41 (newline) 34 ( print "*** csc (" cscopts ") ***")42 (format #t "*** csc ~s ***~%" cscopts) 35 43 (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm"))) 36 44 (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
Note: See TracChangeset
for help on using the changeset viewer.