Changeset 36573 in project

Timestamp:

09/09/18 20:03:36 (18 months ago)

Author:

Kon Lovett

Message:

fix dir, split

Location:

release/5/fp-utils/trunk

Files:

• . (moved) (moved from release/5/fp-utils/trunks)
• fp-utils.scm (modified) (6 diffs)
• test/fp-utils-test.scm (modified) (4 diffs)
• test/run.scm (modified) (2 diffs)

release/5/fp-utils/trunk/fp-utils.scm

@@ -1 @@
-;;;; fp-utils.scm
+;;;; fp-utils.scm  -*- Scheme -*-
+;;;; Kon Lovett, Sep '18
 ;;;; Kon Lovett, May '17
-;;;; Kon Lovett, Mar '18
 
 ;;;; Issues
@@ -7 +7 @@
 ;; - all instances of (fl< -0.0 0.0) found ?
 
-(declare
-  (bound-to-procedure
-    ##sys#flonum-fraction
-    ##sys#check-inexact) )
-
 (module fp-utils
 
 (;export
   ;
-  ;check-inexact
-  ;
   fprandom
   ;
-  fpzero? fppositive? fpnatural? fpnegative? fpnon-positive?
-  ;
-  fpeven? fpodd?
-  ;
-  fpclosed-right? fpclosed? fpclosed-left? fpclosedr? fpclosedl?
-  ;
-  fpadd1 fpsub1
-  ;
   fpmodulo
-  fpquotient fpremainder
-  ;
-  fpfraction
+  fpremainder
   ;
   fptruncate-with-precision
@@ -38 +21 @@
   fpfloor-with-precision
   ;
-  fp~= fp~<= fp~>=
-  ;
-  fpsqr fpcub
-  ;
-  fpdegree->radian fpradian->degree
-  ;
   fpdistance fpdistance*
   ;
-  fpmax-and-min
-  ;
-  fpprecision-factor
-  ;DEPRECATED
-  fptruncate/precision fpround/precision fpceiling/precision fpfloor/precision
-  fpcardinal?)
+  fpmax-and-min)
 
-(import scheme chicken foreign)
-(use
-  (only extras random)
-  (only mathh log10))
+(import scheme
+  (chicken base)
+  (chicken foreign)
+  (chicken type)
+  (chicken flonum)
+  (chicken fixnum)
+  fx-utils)
 
 ;;;
 
-(define C_fmod
-  (foreign-lambda double "fmod" double double))
-
-(define C_remainder
-  (foreign-lambda double "remainder" double double))
-
-(: *fpeven? (float --> boolean))
-;
-(define (*fpeven? n)
-  (let ((r (##sys#flonum-fraction (fp/ n 2.0))))
-    (or (fp= 0.0 r) (fp= -0.0 r)) ) )
-
-(define (check-inexact loc obj)
-  (##sys#check-inexact obj loc)
-  obj )
+(include "fp-inlines")
 
 ;;;
 
-;;
+(: C_fmod (float float --> float))
+;
+(define C_fmod (foreign-lambda double "fmod" double double))
 
-(: fprandom (#!optional (or float fixnum) -> float))
+(: C_remainder (float float --> float))
 ;
-(define (fprandom #!optional lim (low 0))
-  (let* (
-    (low (inexact->exact low))
-    (lim
-      (cond
-        ((not lim)
-          most-positive-fixnum )
-        ((flonum? lim)
-          (let (
-            (sign? (fpnegative? lim))
-            (lim (inexact->exact (expt 10 (round (log10 (abs lim)))))) )
-            (if sign? (fxneg lim) lim) ) )
-        (else
-          lim ) ) ) )
-    (if (fx>= low lim)
-      +nan.0
-      (let* (
-        (dif (fx- lim low))
-        (rnd (random dif))
-        (rnd (fx+ low rnd)) )
-        (fp/ 1.0 (exact->inexact rnd)) ) ) ) )
-
-;;
-
-(: fpzero? (float --> boolean))
-;
-(define (fpzero? n)
-  (or (fp= 0.0 n) (fp= -0.0 n)) )
-
-(: fppositive? (float --> boolean))
-;
-(define (fppositive? n)
-  (fp< 0.0 n) )
-
-(: fpnatural? (float --> boolean))
-;
-(define (fpnatural? n)
-  (fp<= 0.0 n) )
-
-(: fpcardinal? (depreacated fpnatural?))
-;
-(define fpcardinal fpnatural?)
-
-(: fpnegative? (float --> boolean))
-;
-(define (fpnegative? n)
-  (fp> 0.0 n) )
-
-(: fpnon-positive? (float --> boolean))
-;
-(define (fpnon-positive? n)
-  (fp>= 0.0 n) )
-
-;;
-
-(: fpeven? (float --> boolean))
-;
-(define (fpeven? n)
-  (and
-    (fpinteger? n)
-    (*fpeven? n)) )
-
-(: fpodd? (float --> boolean))
-;
-(define (fpodd? n)
-  (and
-    (fpinteger? n)
-    (not (*fpeven? n))) )
-
-;;
-
-(: fpclosed-right? (float float float --> boolean))
-;
-(define (fpclosed-right? l x h)
-  (and (fp< l x) (fp<= x h)) )
-
-(: fpclosed? (float float float --> boolean))
-;
-(define (fpclosed? l x h)
-  (and (fp<= l x) (fp<= x h)) )
-
-(: fpclosed-left? (float float float --> boolean))
-;
-(define (fpclosed-left? l x h)
-  (and (fp<= l x) (fp< x h)) )
-
-(define fpclosedr? fpclosed-right?)
-(define fpclosedl? fpclosed-left?)
-
-;;
-
-(: fpadd1 (float --> float))
-;
-(define (fpadd1 n)
-  (fp+ n 1.0) )
-
-(: fpsub1 (float --> float))
-;
-(define (fpsub1 n)
-  (fp- n 1.0) )
+(define C_remainder (foreign-lambda double "remainder" double double))
 
 ;;
@@ -187 +51 @@
 (: fpmodulo (float float --> float))
 ;
-(define (fpmodulo x y)
-  (fptruncate
-    (C_fmod
-      (check-inexact 'fpmodulo x)
-      (check-inexact 'fpmodulo y))) )
-
-(: fpquotient (float float --> float))
-;
-(define (fpquotient x y)
-  (fptruncate (fp/ x y)) )
+(define (fpmodulo x y) (fptruncate (C_fmod x y)))
 
 (: fpremainder (float float --> float))
 ;
-(define (fpremainder x y)
-  (fptruncate
-    (C_remainder
-      (check-inexact 'fpremainder x)
-      (check-inexact 'fpremainder y))) )
-
-;;
-
-(: fpfraction (float --> float))
-;
-(define (fpfraction n)
-        (##sys#flonum-fraction n) )
-
-;;;
-
-;;
-
-(: fp~= (float float #!optional float --> boolean))
-;
-(define (fp~= x y #!optional (eps flonum-epsilon))
-  (let (
-    (diff (fp- x y)) )
-    (or
-      ;(fpzero? diff) ;really, how often is this true?
-      (fp<= (fpabs diff) eps) ) ) )
-
-(: fp~<= (float float #!optional float --> boolean))
-;
-(define (fp~<= x y #!optional (eps flonum-epsilon))
-  (or
-    (fp< x y)
-    (fp~= x y eps) ) )
-
-(: fp~>= (float float #!optional float --> boolean))
-;
-(define (fp~>= x y #!optional (eps flonum-epsilon))
-  (or
-    (fp> x y)
-    (fp~= x y eps) ) )
-
-;;;
-
-;;
-
-(: fpsqr (float --> float))
-;
-(define (fpsqr n)
-  (fp* n n) )
-
-(: fpcub (float --> float))
-;
-(define (fpcub n)
-  (fp* n (fp* n n)) )
+(define (fpremainder x y) (fptruncate (C_remainder x y)))
 
 ;;;
@@ -287 +90 @@
 ;;
 
-(define-constant DEGREE 0.0174532925199432957692369076848861271344) ;pi/180
+(: fpdistance (float float float float --> float))
+;
+(define (fpdistance x1 y1 x2 y2) (fpsqrt (fpdistance* x1 y1 x2 y2)))
 
-(: fpdegree->radian (float --> float))
+(: fpdistance* (float float float float --> float))
 ;
-(define (fpdegree->radian deg)
-  (fp* deg DEGREE) )
-
-(: fpradian->degree (float --> float))
-;
-(define (fpradian->degree rad)
-  (fp/ rad DEGREE) )
+(define (fpdistance* x1 y1 x2 y2) (fp+ (fpsqr (fp- x1 x2)) (fpsqr (fp- y1 y2))))
 
 ;;
 
-(: fpdistance (float float float float --> float))
+(: fpquo-and-rem (float float --> float float))
 ;
-(define (fpdistance x1 y1 x2 y2)
-  (fpsqrt (fpdistance* x1 y1 x2 y2)) )
-
-(: fpdistance* (float float float float --> float))
-;
-(define (fpdistance* x1 y1 x2 y2)
-  (fp+ (fpsqr (fp- x1 x2)) (fpsqr (fp- y1 y2))) )
+(define (fpquo-and-rem fpn fpd) (values (fpquotient fpn fpd) (fpremainder fpn fpd)))
 
 ;;
@@ -324 +117 @@
 ;;
 
-(: fpprecision-factor ((or float fixnum) #!optional float --> float))
+(: fprandom (#!optional (or float fixnum) -> float))
 ;
-(define (fpprecision-factor p #!optional (base 10.0))
-  (fpexpt base (exact->inexact p)) )
-
-;;DEPRECATED
-
-(define fptruncate/precision fptruncate-with-precision)
-(define fpround/precision fpround-with-precision)
-(define fpceiling/precision fpceiling-with-precision)
-(define fpfloor/precision fpfloor-with-precision)
+(define (fprandom #!optional (lim most-positive-fixnum) (low 0.0))
+  (let* (
+    (low (inexact->exact (fptruncate low)))
+    (lim
+      (if (not (flonum? lim))
+        lim
+        (let* (
+          (neg? (fpnegative? lim))
+          (lim (inexact->exact (fpexpt 10.0 (fpround (fplog10 (fpabs lim))))))
+          (lim (fxmax most-positive-fixnum lim)) )
+          (if neg? (fxneg lim) lim)))) )
+    (if (fx>= low lim)
+      +nan.0
+      (fp/ 1.0 (exact->inexact (fxrandom lim low))) ) ) )
 
 ) ;fp-utils

release/5/fp-utils/trunk/test/fp-utils-test.scm

@@ -1 @@
-;;;; mathh-test
-;;;; Kon Lovett, May '17
+;;;; fp-utils-test  -*- Scheme -*-
+;;;; Kon Lovett, Sep '18
 
-;;;; Issues
-;;;;
+(import test)
 
-(require-extension test)
+(test-begin "Fp Utils")
 
 ;;;
 
-;;;
+(import (chicken base) (chicken flonum))
 
-(require-extension fp-utils)
+(include "fp-inlines")
 
-(define-constant 5eps (fp/ 9.0 1e06))
-(define-constant 4eps (fp/ 9.0 1e05))
-
-(test-group "FP Utils"
+(test-group "Fp Inlines"
 
   (test-assert (fpzero? 0.0))
@@ -40 +36 @@
         (test-assert (fpodd? 7.0))
 
-        (test-assert (flonum? (fprandom)))
-        (test-assert (flonum? (fprandom 2456)))
-
         (test 4.0 (fpadd1 3.0))
         (test 2.0 (fpsub1 3.0))
@@ -53 +46 @@
         (test 2.0 (fpquotient 5.0 2.0))
         (test 1.0 (fpremainder 5.0 2.0))
+)
+
+;;
+
+(define-constant 5eps (fp/ 9.0 1e06))
+(define-constant 4eps (fp/ 9.0 1e05))
+
+(test-group "Fp Utils"
+
+        (test-assert (flonum? (fprandom)))
+        (test-assert (flonum? (fprandom 2456)))
 
         (test-assert (fp~= 0.123456 0.123457 5eps))
@@ -70 +74 @@
 ;;;
 
-(test-end "mathh")
-
-;;;
+(test-end "Fp Utils")
 
 (test-exit)

release/5/fp-utils/trunk/test/run.scm

@@ -1 +1 @@
 
-(define EGG-NAME "mathh")
+(define EGG-NAME "fp-utils")
 
 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
 
-(use files)
+(import
+  (only (chicken pathname) make-pathname)
+  (only (chicken process) system)
+  (only (chicken process-context) argv)
+  (only (chicken format) format))
+
+(define *args* (argv))
 
 ;no -disable-interrupts
-(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
-
-(define *args* (argv))
+(define *csc-options* "-inline-global \
+  -specialize -optimize-leaf-routines -clustering -lfa2 \
+  -local -inline \
+  -no-trace -no-lambda-info \
+  -unsafe")
 
 (define (test-name #!optional (eggnam EGG-NAME))
@@ -29 +37 @@
 (define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
   (let ((tstnam (test-name eggnam)))
-    (print "*** csi ***")
+    (format #t "*** csi ***~%")
     (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     (newline)
-    (print "*** csc (" cscopts ") ***")
+    (format #t "*** csc ~s ***~%" cscopts)
     (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )