Changeset 36573 in project


Ignore:
Timestamp:
09/09/18 20:03:36 (2 months ago)
Author:
kon
Message:

fix dir, split

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
    23;;;; Kon Lovett, May '17
    3 ;;;; Kon Lovett, Mar '18
    44
    55;;;; Issues
     
    77;; - all instances of (fl< -0.0 0.0) found ?
    88
    9 (declare
    10   (bound-to-procedure
    11     ##sys#flonum-fraction
    12     ##sys#check-inexact) )
    13 
    149(module fp-utils
    1510
    1611(;export
    1712  ;
    18   ;check-inexact
    19   ;
    2013  fprandom
    2114  ;
    22   fpzero? fppositive? fpnatural? fpnegative? fpnon-positive?
    23   ;
    24   fpeven? fpodd?
    25   ;
    26   fpclosed-right? fpclosed? fpclosed-left? fpclosedr? fpclosedl?
    27   ;
    28   fpadd1 fpsub1
    29   ;
    3015  fpmodulo
    31   fpquotient fpremainder
    32   ;
    33   fpfraction
     16  fpremainder
    3417  ;
    3518  fptruncate-with-precision
     
    3821  fpfloor-with-precision
    3922  ;
    40   fp~= fp~<= fp~>=
    41   ;
    42   fpsqr fpcub
    43   ;
    44   fpdegree->radian fpradian->degree
    45   ;
    4623  fpdistance fpdistance*
    4724  ;
    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)
    5426
    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)
    5934
    6035;;;
    6136
    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")
    7738
    7839;;;
    7940
    80 ;;
     41(: C_fmod (float float --> float))
     42;
     43(define C_fmod (foreign-lambda double "fmod" double double))
    8144
    82 (: fprandom (#!optional (or float fixnum) -> float))
     45(: C_remainder (float float --> float))
    8346;
    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))
    18448
    18549;;
     
    18751(: fpmodulo (float float --> float))
    18852;
    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)))
    19954
    20055(: fpremainder (float float --> float))
    20156;
    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)))
    25558
    25659;;;
     
    28790;;
    28891
    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)))
    29095
    291 (: fpdegree->radian (float --> float))
     96(: fpdistance* (float float float float --> float))
    29297;
    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))))
    30099
    301100;;
    302101
    303 (: fpdistance (float float float float --> float))
     102(: fpquo-and-rem (float float --> float float))
    304103;
    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)))
    312105
    313106;;
     
    324117;;
    325118
    326 (: fpprecision-factor ((or float fixnum) #!optional float --> float))
     119(: fprandom (#!optional (or float fixnum) -> float))
    327120;
    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))) ) ) )
    337135
    338136) ;fp-utils
  • release/5/fp-utils/trunk/test/fp-utils-test.scm

    r35993 r36573  
    1 ;;;; mathh-test
    2 ;;;; Kon Lovett, May '17
     1;;;; fp-utils-test  -*- Scheme -*-
     2;;;; Kon Lovett, Sep '18
    33
    4 ;;;; Issues
    5 ;;;;
     4(import test)
    65
    7 (require-extension test)
     6(test-begin "Fp Utils")
    87
    98;;;
    109
    11 ;;;
     10(import (chicken base) (chicken flonum))
    1211
    13 (require-extension fp-utils)
     12(include "fp-inlines")
    1413
    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"
    1915
    2016  (test-assert (fpzero? 0.0))
     
    4036        (test-assert (fpodd? 7.0))
    4137
    42         (test-assert (flonum? (fprandom)))
    43         (test-assert (flonum? (fprandom 2456)))
    44 
    4538        (test 4.0 (fpadd1 3.0))
    4639        (test 2.0 (fpsub1 3.0))
     
    5346        (test 2.0 (fpquotient 5.0 2.0))
    5447        (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)))
    5559
    5660        (test-assert (fp~= 0.123456 0.123457 5eps))
     
    7074;;;
    7175
    72 (test-end "mathh")
    73 
    74 ;;;
     76(test-end "Fp Utils")
    7577
    7678(test-exit)
  • release/5/fp-utils/trunk/test/run.scm

    r35993 r36573  
    11
    2 (define EGG-NAME "mathh")
     2(define EGG-NAME "fp-utils")
    33
    44;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    55
    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))
    713
    814;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")
    1220
    1321(define (test-name #!optional (eggnam EGG-NAME))
     
    2937(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    3038  (let ((tstnam (test-name eggnam)))
    31     (print "*** csi ***")
     39    (format #t "*** csi ***~%")
    3240    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
    3341    (newline)
    34     (print "*** csc (" cscopts ") ***")
     42    (format #t "*** csc ~s ***~%" cscopts)
    3543    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
    3644    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
Note: See TracChangeset for help on using the changeset viewer.