Changeset 36573 in project
 Timestamp:
 09/09/18 20:03:36 (8 months ago)
 Location:
 release/5/fputils/trunk
 Files:

 3 edited
 1 moved
Legend:
 Unmodified
 Added
 Removed

release/5/fputils/trunk/fputils.scm
r35993 r36573 1 ;;;; fputils.scm 1 ;;;; fputils.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 (boundtoprocedure11 ##sys#flonumfraction12 ##sys#checkinexact) )13 14 9 (module fputils 15 10 16 11 (;export 17 12 ; 18 ;checkinexact19 ;20 13 fprandom 21 14 ; 22 fpzero? fppositive? fpnatural? fpnegative? fpnonpositive?23 ;24 fpeven? fpodd?25 ;26 fpclosedright? fpclosed? fpclosedleft? fpclosedr? fpclosedl?27 ;28 fpadd1 fpsub129 ;30 15 fpmodulo 31 fpquotient fpremainder 32 ; 33 fpfraction 16 fpremainder 34 17 ; 35 18 fptruncatewithprecision … … 38 21 fpfloorwithprecision 39 22 ; 40 fp~= fp~<= fp~>=41 ;42 fpsqr fpcub43 ;44 fpdegree>radian fpradian>degree45 ;46 23 fpdistance fpdistance* 47 24 ; 48 fpmaxandmin 49 ; 50 fpprecisionfactor 51 ;DEPRECATED 52 fptruncate/precision fpround/precision fpceiling/precision fpfloor/precision 53 fpcardinal?) 25 fpmaxandmin) 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 fxutils) 59 34 60 35 ;;; 61 36 62 (define C_fmod 63 (foreignlambda double "fmod" double double)) 64 65 (define C_remainder 66 (foreignlambda double "remainder" double double)) 67 68 (: *fpeven? (float > boolean)) 69 ; 70 (define (*fpeven? n) 71 (let ((r (##sys#flonumfraction (fp/ n 2.0)))) 72 (or (fp= 0.0 r) (fp= 0.0 r)) ) ) 73 74 (define (checkinexact loc obj) 75 (##sys#checkinexact obj loc) 76 obj ) 37 (include "fpinlines") 77 38 78 39 ;;; 79 40 80 ;; 41 (: C_fmod (float float > float)) 42 ; 43 (define C_fmod (foreignlambda 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 mostpositivefixnum ) 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 (: fpnonpositive? (float > boolean)) 133 ; 134 (define (fpnonpositive? 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 (: fpclosedright? (float float float > boolean)) 156 ; 157 (define (fpclosedright? 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 (: fpclosedleft? (float float float > boolean)) 166 ; 167 (define (fpclosedleft? l x h) 168 (and (fp<= l x) (fp< x h)) ) 169 170 (define fpclosedr? fpclosedright?) 171 (define fpclosedl? fpclosedleft?) 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 (foreignlambda 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 (checkinexact 'fpmodulo x) 193 (checkinexact '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 (checkinexact 'fpremainder x) 206 (checkinexact 'fpremainder y))) ) 207 208 ;; 209 210 (: fpfraction (float > float)) 211 ; 212 (define (fpfraction n) 213 (##sys#flonumfraction n) ) 214 215 ;;; 216 217 ;; 218 219 (: fp~= (float float #!optional float > boolean)) 220 ; 221 (define (fp~= x y #!optional (eps flonumepsilon)) 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 flonumepsilon)) 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 flonumepsilon)) 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 (defineconstant 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 (: fpquoandrem (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 (fpquoandrem fpn fpd) (values (fpquotient fpn fpd) (fpremainder fpn fpd))) 312 105 313 106 ;; … … 324 117 ;; 325 118 326 (: fp precisionfactor ((or float fixnum) #!optional float > float))119 (: fprandom (#!optional (or float fixnum) > float)) 327 120 ; 328 (define (fpprecisionfactor p #!optional (base 10.0)) 329 (fpexpt base (exact>inexact p)) ) 330 331 ;;DEPRECATED 332 333 (define fptruncate/precision fptruncatewithprecision) 334 (define fpround/precision fproundwithprecision) 335 (define fpceiling/precision fpceilingwithprecision) 336 (define fpfloor/precision fpfloorwithprecision) 121 (define (fprandom #!optional (lim mostpositivefixnum) (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 mostpositivefixnum 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 ) ;fputils 
release/5/fputils/trunk/test/fputilstest.scm
r35993 r36573 1 ;;;; mathhtest2 ;;;; Kon Lovett, May '171 ;;;; fputilstest * Scheme * 2 ;;;; Kon Lovett, Sep '18 3 3 4 ;;;; Issues 5 ;;;; 4 (import test) 6 5 7 ( requireextension test)6 (testbegin "Fp Utils") 8 7 9 8 ;;; 10 9 11 ;;; 10 (import (chicken base) (chicken flonum)) 12 11 13 ( requireextension fputils)12 (include "fpinlines") 14 13 15 (defineconstant 5eps (fp/ 9.0 1e06)) 16 (defineconstant 4eps (fp/ 9.0 1e05)) 17 18 (testgroup "FP Utils" 14 (testgroup "Fp Inlines" 19 15 20 16 (testassert (fpzero? 0.0)) … … 40 36 (testassert (fpodd? 7.0)) 41 37 42 (testassert (flonum? (fprandom)))43 (testassert (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 (defineconstant 5eps (fp/ 9.0 1e06)) 53 (defineconstant 4eps (fp/ 9.0 1e05)) 54 55 (testgroup "Fp Utils" 56 57 (testassert (flonum? (fprandom))) 58 (testassert (flonum? (fprandom 2456))) 55 59 56 60 (testassert (fp~= 0.123456 0.123457 5eps)) … … 70 74 ;;; 71 75 72 (testend "mathh") 73 74 ;;; 76 (testend "Fp Utils") 75 77 76 78 (testexit) 
release/5/fputils/trunk/test/run.scm
r35993 r36573 1 1 2 (define EGGNAME " mathh")2 (define EGGNAME "fputils") 3 3 4 4 ;chickeninstall invokes as "<csi> s run.scm <eggnam> <eggdir>" 5 5 6 (use files) 6 (import 7 (only (chicken pathname) makepathname) 8 (only (chicken process) system) 9 (only (chicken processcontext) argv) 10 (only (chicken format) format)) 11 12 (define *args* (argv)) 7 13 8 14 ;no disableinterrupts 9 (define *cscoptions* "inlineglobal scrutinize optimizeleafroutines local inline specialize unsafe notrace nolambdainfo clustering lfa2") 10 11 (define *args* (argv)) 15 (define *cscoptions* "inlineglobal \ 16 specialize optimizeleafroutines clustering lfa2 \ 17 local inline \ 18 notrace nolambdainfo \ 19 unsafe") 12 20 13 21 (define (testname #!optional (eggnam EGGNAME)) … … 29 37 (define (runtest #!optional (eggnam EGGNAME) (cscopts *cscoptions*)) 30 38 (let ((tstnam (testname eggnam))) 31 ( print "*** csi ***")39 (format #t "*** csi ***~%") 32 40 (system (stringappend "csi s " (makepathname #f tstnam "scm"))) 33 41 (newline) 34 ( print "*** csc (" cscopts ") ***")42 (format #t "*** csc ~s ***~%" cscopts) 35 43 (system (stringappend "csc" " " cscopts " " (makepathname #f tstnam "scm"))) 36 44 (system (makepathname (condexpand (unix "./") (else #f)) tstnam)) ) )
Note: See TracChangeset
for help on using the changeset viewer.