Changeset 34132 in project


Ignore:
Timestamp:
05/30/17 19:13:11 (3 weeks ago)
Author:
kon
Message:

add fx-utils, extd fp-utils

Location:
release/4/mathh
Files:
2 added
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/mathh/tags/3.2.0/fp-utils.scm

    r34098 r34132  
    11;;;; fp-utils.scm
     2;;;; Kon Lovett, May '17
     3
     4;;;; Issues
     5;;;;
    26
    37(module fp-utils
    48
    59(;export
    6   fpzero?
    7   fppositive?
    8   fpnegative?
    9   fpeven?
    10   fpodd?
     10  ;
     11  fprandom
     12  ;
     13  fpzero? fppositive? fpcardinal? fpnegative? fpeven? fpodd?
     14  ;
     15  fpclosed-right? fpclosed? fpclosed-left? fpclosedr? fpclosedl?
     16  ;
     17  fpadd1 fpsub1
    1118  ;
    1219  fpmodulo
    13   fpquotient
    14   fpremainder
     20  fpquotient fpremainder
    1521  ;
    1622  fpfraction
    1723  ;
    18   fptruncate/precision
    19   fpround/precision
    20   fpceiling/precision
    21   fpfloor/precision
    22   ;
    23   fp~=
     24  fptruncate/precision fpround/precision fpceiling/precision fpfloor/precision
     25  ;
     26  fp~= fp~<= fp~>=
    2427  ;
    2528  fpsqr fpcub
    2629  ;
    27   fpprecision-factor
    28   ;
    2930  fpdegree->radian fpradian->degree
    3031  ;
    31   fpdistance fpdistance*)
    32 
    33 (import scheme chicken foreign)
     32  fpdistance fpdistance*
     33  ;
     34  fpmax-and-min
     35  ;
     36  fpprecision-factor)
     37
     38(import scheme)
     39
     40(import chicken foreign extras)
    3441
    3542(declare
     
    4047;;;
    4148
    42 ;;
    43 
    4449(define C_fmod
    4550  (foreign-lambda double "fmod" double double))
     
    5156  (fp= 0.0 (##sys#flonum-fraction (fp/ n 2.0))) )
    5257
     58;;;
     59
     60;;
     61
     62(define (fprandom #!optional (x most-positive-fixnum))
     63  (fp/ 1.0 (exact->inexact (random x))) )
     64
    5365;;
    5466
     
    5870(define (fppositive? n)
    5971  (fp< 0.0 n) )
     72
     73(define (fpcardinal? n)
     74  (fp<= 0.0 n) )
    6075
    6176(define (fpnegative? n)
     
    6883
    6984(define (fpodd? n)
    70   (not (fpeven? n)) )
     85  (and
     86    (fpinteger? n)
     87    (not (*fpeven? n))) )
     88
     89;;
     90
     91(define (fpclosed-right? l x h)
     92  (and (fp< l x) (fp<= x h)) )
     93
     94(define (fpclosed? l x h)
     95  (and (fp<= l x) (fp<= x h)) )
     96
     97(define (fpclosed-left? l x h)
     98  (and (fp<= l x) (fp< x h)) )
     99
     100(define fpclosedr? fpclosed-right?)
     101(define fpclosedl? fpclosed-left?)
     102
     103;;
     104
     105(define (fpadd1 n)
     106  (fp+ n 1.0) )
     107
     108(define (fpsub1 n)
     109  (fp- n 1.0) )
    71110
    72111;;
     
    99138      (fpzero? diff)
    100139      (fp<= (fpabs diff) eps) ) ) )
     140
     141(define (fp~<= x y #!optional (eps flonum-epsilon))
     142  (or
     143    (fp< x y)
     144    (fp~= x y eps) ) )
     145
     146(define (fp~>= x y #!optional (eps flonum-epsilon))
     147  (or
     148    (fp> x y)
     149    (fp~= x y eps) ) )
    101150
    102151;;;
     
    150199;;
    151200
     201(define (fpmax-and-min fp . fps)
     202  (let loop ((fps fps) (mx fp) (mn fp))
     203    (if (null? fps)
     204      (values mx mn)
     205      (let ((cur (car fps)))
     206        (loop (cdr fps) (fpmax mx cur) (fpmin mn cur)) ) ) ) )
     207
     208;;
     209
    152210(define (fpprecision-factor p #!optional (base 10.0))
    153211  (fpexpt base (exact->inexact p)) )
  • release/4/mathh/tags/3.2.0/mathh.meta

    r34098 r34132  
    99 (depends (setup-helper "1.5.2"))
    1010 (test-depends test)
    11  (files "mathh.scm" "mathh.meta" "mathh.setup" "mathh-constants.scm" "mathh-consts.scm" "fp-utils.scm" "tests/run.scm") )
     11 (files
     12  "mathh.scm" "mathh.meta" "mathh.setup"
     13  "mathh-constants.scm" "mathh-consts.scm"
     14  "fp-utils.scm" "fx-utils.scm"
     15  "tests/run.scm") )
  • release/4/mathh/tags/3.2.0/mathh.setup

    r34098 r34132  
    1111      (else     '() ) ) ) )
    1212
    13 (setup-shared+static-extension-module (extension-name) (extension-version "3.1.0")
     13(setup-shared+static-extension-module (extension-name) (extension-version "3.2.0")
    1414  #:inline? #t
    1515  #:types? #t
     
    1717  #:files '("mathh-constants.scm"))
    1818
    19 (setup-shared+static-extension-module 'fp-utils (extension-version "3.1.0")
     19(setup-shared+static-extension-module 'mathh-consts (extension-version "3.2.0")
     20  #:inline? #t
     21  #:types? #t
     22  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-bound-checks -no-argc-checks -no-procedure-checks))
     23
     24(setup-shared+static-extension-module 'fp-utils (extension-version "3.2.0")
    2025  #:inline? #t
    2126  #:types? #t
    2227  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    2328
    24 (setup-shared+static-extension-module 'mathh-consts (extension-version "3.1.0")
     29(setup-shared+static-extension-module 'fx-utils (extension-version "3.2.0")
    2530  #:inline? #t
    2631  #:types? #t
    27   #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-bound-checks -no-argc-checks -no-procedure-checks))
     32  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
  • release/4/mathh/tags/3.2.0/tests/run.scm

    r34098 r34132  
    11;;;; mathh-test
     2;;;; Kon Lovett, May '17
     3
     4;;;; Issues
     5;;;;
    26
    37(require-extension test)
    48
     9;;;
     10
    511(require-extension mathh)
     12
     13;;
    614
    715(test-group "ISO C Functions"
     
    4149)
    4250
     51;;
     52
    4353(test-group "BSD Functions"
    4454
     
    5565        (test 2.4662 (cbrt 15.0))
    5666)
     67
     68;;
    5769
    5870(test-group "Function fpclass"
     
    6577)
    6678
     79;;
     80
    6781(test-group "Function fpclassify"
    6882
     
    7488)
    7589
     90;;;
     91
     92(require-extension fp-utils)
     93
     94(define-constant 5eps (fp/ 9.0 1e06))
     95(define-constant 4eps (fp/ 9.0 1e05))
     96
     97(test-group "FP Utils"
     98
     99  (test-assert (fpzero? 0.0))
     100  (test-assert (not (fpzero? 1.0)))
     101  (test-assert (not (fpzero? maximum-flonum)))
     102  (test-assert (not (fpzero? minimum-flonum)))
     103
     104  (test-assert (not (fppositive? 0.0)))
     105  (test-assert (not (fppositive? (fpneg minimum-flonum))))
     106  (test-assert (fppositive? maximum-flonum))
     107
     108  (test-assert (fpcardinal? 0.0))
     109  (test-assert (not (fpcardinal? (fpneg minimum-flonum))))
     110  (test-assert (fpcardinal? maximum-flonum))
     111
     112  (test-assert (not (fpnegative? 0.0)))
     113  (test-assert (fpnegative? (fpneg minimum-flonum)))
     114  (test-assert (not (fpnegative? maximum-flonum)))
     115
     116        (test-assert (not (fpeven? 7.0)))
     117        (test-assert (fpeven? 6.0))
     118        (test-assert (not (fpodd? 6.0)))
     119        (test-assert (fpodd? 7.0))
     120
     121        (test-assert (flonum? (fprandom)))
     122        (test-assert (flonum? (fprandom 2456)))
     123
     124        (test 4.0 (fpadd1 3.0))
     125        (test 2.0 (fpsub1 3.0))
     126
     127        (test 27.0 (fpcub 3.0))
     128
     129        (test 1.0 (fpmodulo 5.0 2.0))
     130        (test 0.0 (fpmodulo 0.0 1.0))
     131
     132        (test 2.0 (fpquotient 5.0 2.0))
     133        (test 1.0 (fpremainder 5.0 2.0))
     134
     135        (test-assert (fp~= 0.123456 0.123457 5eps))
     136        (test-assert (fp~<= 0.123456 0.123457 5eps))
     137        (test-assert (fp~>= 0.123456 0.123457 5eps))
     138        (test-assert (fp~<= 0.123456 0.12346 5eps))
     139        (test-assert (fp~>= 0.123456 0.12344 5eps))
     140
     141  (parameterize ((current-test-epsilon 4eps))
     142          (test 5.6568 (fpdistance 1.0 1.0 5.0 5.0)) )
     143
     144        (receive (mx mn) (fpmax-and-min 1.0 -1.0 -16.0 13.0 2.0 16.0 7.0 -8.0)
     145          (test "fpmax-and-min max" 16.0 mx)
     146          (test "fpmax-and-min min" -16.0 mn) )
     147)
     148
     149;;;
     150
     151(require-extension fx-utils)
     152
     153(test-group "FX Utils"
     154
     155  (test-assert (fxzero? 0))
     156  (test-assert (not (fxzero? 1)))
     157  (test-assert (not (fxzero? most-positive-fixnum)))
     158  (test-assert (not (fxzero? most-negative-fixnum)))
     159
     160  (test-assert (not (fxpositive? 0)))
     161  (test-assert (not (fxpositive? most-negative-fixnum)))
     162  (test-assert (fxpositive? most-positive-fixnum))
     163
     164  (test-assert (fxcardinal? 0))
     165  (test-assert (not (fxcardinal? most-negative-fixnum)))
     166  (test-assert (fxcardinal? most-positive-fixnum))
     167
     168  (test-assert (not (fxnegative? 0)))
     169  (test-assert (fxnegative? most-negative-fixnum))
     170  (test-assert (not (fxnegative? most-positive-fixnum)))
     171
     172        (test-assert (fixnum? (fxrandom)))
     173        (test-assert (fixnum? (fxrandom 2456)))
     174
     175        (test 4 (fxadd1 3))
     176        (test 2 (fxsub1 3))
     177
     178        (test 27 (fxcub 3))
     179
     180        (test 8 (fxpow2log2 3))
     181
     182        (test 16 (fxdistance 1 1 5 5))
     183
     184        (receive (mx mn) (fxmax-and-min 1 -1 -16 13 2 16 7 -8)
     185          (test "fxmax-and-min max" 16 mx)
     186          (test "fxmax-and-min min" -16 mn) )
     187)
     188
     189;;;
     190
     191;(import (prefix mathh-consts C:))
     192;(require-library mathh-consts)
     193;=> C:sqrt2 C:degree C:ln2 C:log2e C:e
    76194(require-extension mathh-consts)
    77195
     
    85203)
    86204
    87 (require-extension fp-utils)
    88 
    89 (test-group "FP Utils"
    90 
    91         (test-assert (fpzero? 0.0))
    92         (test-assert (fppositive? 1.0))
    93         (test-assert (fpnegative? -1.0))
    94         (test-assert (fpeven? 6.0))
    95         (test-assert (not (fpodd? 6.0)))
    96         (test-assert (fpodd? 7.0))
    97 
    98         (test 27.0 (fpcub 3.0))
    99 
    100         (test 1.0 (fpmodulo 5.0 2.0))
    101         (test 0.0 (fpmodulo 0.0 1.0))
    102 
    103         (test 2.0 (fpquotient 5.0 2.0))
    104         (test 1.0 (fpremainder 5.0 2.0))
    105 )
     205;;;
    106206
    107207(test-exit)
  • release/4/mathh/trunk/fp-utils.scm

    r34098 r34132  
    11;;;; fp-utils.scm
     2;;;; Kon Lovett, May '17
     3
     4;;;; Issues
     5;;;;
    26
    37(module fp-utils
    48
    59(;export
    6   fpzero?
    7   fppositive?
    8   fpnegative?
    9   fpeven?
    10   fpodd?
     10  ;
     11  fprandom
     12  ;
     13  fpzero? fppositive? fpcardinal? fpnegative? fpeven? fpodd?
     14  ;
     15  fpclosed-right? fpclosed? fpclosed-left? fpclosedr? fpclosedl?
     16  ;
     17  fpadd1 fpsub1
    1118  ;
    1219  fpmodulo
    13   fpquotient
    14   fpremainder
     20  fpquotient fpremainder
    1521  ;
    1622  fpfraction
    1723  ;
    18   fptruncate/precision
    19   fpround/precision
    20   fpceiling/precision
    21   fpfloor/precision
    22   ;
    23   fp~=
     24  fptruncate/precision fpround/precision fpceiling/precision fpfloor/precision
     25  ;
     26  fp~= fp~<= fp~>=
    2427  ;
    2528  fpsqr fpcub
    2629  ;
    27   fpprecision-factor
    28   ;
    2930  fpdegree->radian fpradian->degree
    3031  ;
    31   fpdistance fpdistance*)
    32 
    33 (import scheme chicken foreign)
     32  fpdistance fpdistance*
     33  ;
     34  fpmax-and-min
     35  ;
     36  fpprecision-factor)
     37
     38(import scheme)
     39
     40(import chicken foreign extras)
    3441
    3542(declare
     
    4047;;;
    4148
    42 ;;
    43 
    4449(define C_fmod
    4550  (foreign-lambda double "fmod" double double))
     
    5156  (fp= 0.0 (##sys#flonum-fraction (fp/ n 2.0))) )
    5257
     58;;;
     59
     60;;
     61
     62(define (fprandom #!optional (x most-positive-fixnum))
     63  (fp/ 1.0 (exact->inexact (random x))) )
     64
    5365;;
    5466
     
    5870(define (fppositive? n)
    5971  (fp< 0.0 n) )
     72
     73(define (fpcardinal? n)
     74  (fp<= 0.0 n) )
    6075
    6176(define (fpnegative? n)
     
    6883
    6984(define (fpodd? n)
    70   (not (fpeven? n)) )
     85  (and
     86    (fpinteger? n)
     87    (not (*fpeven? n))) )
     88
     89;;
     90
     91(define (fpclosed-right? l x h)
     92  (and (fp< l x) (fp<= x h)) )
     93
     94(define (fpclosed? l x h)
     95  (and (fp<= l x) (fp<= x h)) )
     96
     97(define (fpclosed-left? l x h)
     98  (and (fp<= l x) (fp< x h)) )
     99
     100(define fpclosedr? fpclosed-right?)
     101(define fpclosedl? fpclosed-left?)
     102
     103;;
     104
     105(define (fpadd1 n)
     106  (fp+ n 1.0) )
     107
     108(define (fpsub1 n)
     109  (fp- n 1.0) )
    71110
    72111;;
     
    99138      (fpzero? diff)
    100139      (fp<= (fpabs diff) eps) ) ) )
     140
     141(define (fp~<= x y #!optional (eps flonum-epsilon))
     142  (or
     143    (fp< x y)
     144    (fp~= x y eps) ) )
     145
     146(define (fp~>= x y #!optional (eps flonum-epsilon))
     147  (or
     148    (fp> x y)
     149    (fp~= x y eps) ) )
    101150
    102151;;;
     
    150199;;
    151200
     201(define (fpmax-and-min fp . fps)
     202  (let loop ((fps fps) (mx fp) (mn fp))
     203    (if (null? fps)
     204      (values mx mn)
     205      (let ((cur (car fps)))
     206        (loop (cdr fps) (fpmax mx cur) (fpmin mn cur)) ) ) ) )
     207
     208;;
     209
    152210(define (fpprecision-factor p #!optional (base 10.0))
    153211  (fpexpt base (exact->inexact p)) )
  • release/4/mathh/trunk/mathh.meta

    r34098 r34132  
    99 (depends (setup-helper "1.5.2"))
    1010 (test-depends test)
    11  (files "mathh.scm" "mathh.meta" "mathh.setup" "mathh-constants.scm" "mathh-consts.scm" "fp-utils.scm" "tests/run.scm") )
     11 (files
     12  "mathh.scm" "mathh.meta" "mathh.setup"
     13  "mathh-constants.scm" "mathh-consts.scm"
     14  "fp-utils.scm" "fx-utils.scm"
     15  "tests/run.scm") )
  • release/4/mathh/trunk/mathh.setup

    r34098 r34132  
    1111      (else     '() ) ) ) )
    1212
    13 (setup-shared+static-extension-module (extension-name) (extension-version "3.1.0")
     13(setup-shared+static-extension-module (extension-name) (extension-version "3.2.0")
    1414  #:inline? #t
    1515  #:types? #t
     
    1717  #:files '("mathh-constants.scm"))
    1818
    19 (setup-shared+static-extension-module 'fp-utils (extension-version "3.1.0")
     19(setup-shared+static-extension-module 'mathh-consts (extension-version "3.2.0")
     20  #:inline? #t
     21  #:types? #t
     22  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-bound-checks -no-argc-checks -no-procedure-checks))
     23
     24(setup-shared+static-extension-module 'fp-utils (extension-version "3.2.0")
    2025  #:inline? #t
    2126  #:types? #t
    2227  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
    2328
    24 (setup-shared+static-extension-module 'mathh-consts (extension-version "3.1.0")
     29(setup-shared+static-extension-module 'fx-utils (extension-version "3.2.0")
    2530  #:inline? #t
    2631  #:types? #t
    27   #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-bound-checks -no-argc-checks -no-procedure-checks))
     32  #:compile-options `(-scrutinize -optimize-level 3 -debug-level 1 -no-procedure-checks))
  • release/4/mathh/trunk/tests/run.scm

    r34098 r34132  
    11;;;; mathh-test
     2;;;; Kon Lovett, May '17
     3
     4;;;; Issues
     5;;;;
    26
    37(require-extension test)
    48
     9;;;
     10
    511(require-extension mathh)
     12
     13;;
    614
    715(test-group "ISO C Functions"
     
    4149)
    4250
     51;;
     52
    4353(test-group "BSD Functions"
    4454
     
    5565        (test 2.4662 (cbrt 15.0))
    5666)
     67
     68;;
    5769
    5870(test-group "Function fpclass"
     
    6577)
    6678
     79;;
     80
    6781(test-group "Function fpclassify"
    6882
     
    7488)
    7589
     90;;;
     91
     92(require-extension fp-utils)
     93
     94(define-constant 5eps (fp/ 9.0 1e06))
     95(define-constant 4eps (fp/ 9.0 1e05))
     96
     97(test-group "FP Utils"
     98
     99  (test-assert (fpzero? 0.0))
     100  (test-assert (not (fpzero? 1.0)))
     101  (test-assert (not (fpzero? maximum-flonum)))
     102  (test-assert (not (fpzero? minimum-flonum)))
     103
     104  (test-assert (not (fppositive? 0.0)))
     105  (test-assert (not (fppositive? (fpneg minimum-flonum))))
     106  (test-assert (fppositive? maximum-flonum))
     107
     108  (test-assert (fpcardinal? 0.0))
     109  (test-assert (not (fpcardinal? (fpneg minimum-flonum))))
     110  (test-assert (fpcardinal? maximum-flonum))
     111
     112  (test-assert (not (fpnegative? 0.0)))
     113  (test-assert (fpnegative? (fpneg minimum-flonum)))
     114  (test-assert (not (fpnegative? maximum-flonum)))
     115
     116        (test-assert (not (fpeven? 7.0)))
     117        (test-assert (fpeven? 6.0))
     118        (test-assert (not (fpodd? 6.0)))
     119        (test-assert (fpodd? 7.0))
     120
     121        (test-assert (flonum? (fprandom)))
     122        (test-assert (flonum? (fprandom 2456)))
     123
     124        (test 4.0 (fpadd1 3.0))
     125        (test 2.0 (fpsub1 3.0))
     126
     127        (test 27.0 (fpcub 3.0))
     128
     129        (test 1.0 (fpmodulo 5.0 2.0))
     130        (test 0.0 (fpmodulo 0.0 1.0))
     131
     132        (test 2.0 (fpquotient 5.0 2.0))
     133        (test 1.0 (fpremainder 5.0 2.0))
     134
     135        (test-assert (fp~= 0.123456 0.123457 5eps))
     136        (test-assert (fp~<= 0.123456 0.123457 5eps))
     137        (test-assert (fp~>= 0.123456 0.123457 5eps))
     138        (test-assert (fp~<= 0.123456 0.12346 5eps))
     139        (test-assert (fp~>= 0.123456 0.12344 5eps))
     140
     141  (parameterize ((current-test-epsilon 4eps))
     142          (test 5.6568 (fpdistance 1.0 1.0 5.0 5.0)) )
     143
     144        (receive (mx mn) (fpmax-and-min 1.0 -1.0 -16.0 13.0 2.0 16.0 7.0 -8.0)
     145          (test "fpmax-and-min max" 16.0 mx)
     146          (test "fpmax-and-min min" -16.0 mn) )
     147)
     148
     149;;;
     150
     151(require-extension fx-utils)
     152
     153(test-group "FX Utils"
     154
     155  (test-assert (fxzero? 0))
     156  (test-assert (not (fxzero? 1)))
     157  (test-assert (not (fxzero? most-positive-fixnum)))
     158  (test-assert (not (fxzero? most-negative-fixnum)))
     159
     160  (test-assert (not (fxpositive? 0)))
     161  (test-assert (not (fxpositive? most-negative-fixnum)))
     162  (test-assert (fxpositive? most-positive-fixnum))
     163
     164  (test-assert (fxcardinal? 0))
     165  (test-assert (not (fxcardinal? most-negative-fixnum)))
     166  (test-assert (fxcardinal? most-positive-fixnum))
     167
     168  (test-assert (not (fxnegative? 0)))
     169  (test-assert (fxnegative? most-negative-fixnum))
     170  (test-assert (not (fxnegative? most-positive-fixnum)))
     171
     172        (test-assert (fixnum? (fxrandom)))
     173        (test-assert (fixnum? (fxrandom 2456)))
     174
     175        (test 4 (fxadd1 3))
     176        (test 2 (fxsub1 3))
     177
     178        (test 27 (fxcub 3))
     179
     180        (test 8 (fxpow2log2 3))
     181
     182        (test 16 (fxdistance 1 1 5 5))
     183
     184        (receive (mx mn) (fxmax-and-min 1 -1 -16 13 2 16 7 -8)
     185          (test "fxmax-and-min max" 16 mx)
     186          (test "fxmax-and-min min" -16 mn) )
     187)
     188
     189;;;
     190
     191;(import (prefix mathh-consts C:))
     192;(require-library mathh-consts)
     193;=> C:sqrt2 C:degree C:ln2 C:log2e C:e
    76194(require-extension mathh-consts)
    77195
     
    85203)
    86204
    87 (require-extension fp-utils)
    88 
    89 (test-group "FP Utils"
    90 
    91         (test-assert (fpzero? 0.0))
    92         (test-assert (fppositive? 1.0))
    93         (test-assert (fpnegative? -1.0))
    94         (test-assert (fpeven? 6.0))
    95         (test-assert (not (fpodd? 6.0)))
    96         (test-assert (fpodd? 7.0))
    97 
    98         (test 27.0 (fpcub 3.0))
    99 
    100         (test 1.0 (fpmodulo 5.0 2.0))
    101         (test 0.0 (fpmodulo 0.0 1.0))
    102 
    103         (test 2.0 (fpquotient 5.0 2.0))
    104         (test 1.0 (fpremainder 5.0 2.0))
    105 )
     205;;;
    106206
    107207(test-exit)
Note: See TracChangeset for help on using the changeset viewer.