added order-of-magnitude from Jos Koot and some tests for other scheme/math stuff

svn: r16607

collects/framework/splash.ss

@@ -200,6 +200,7 @@
               (if (or (getenv "PLTDRCM")
                       (getenv "PLTDRDEBUG"))
                   (parameterize ([current-namespace (make-base-namespace)])
+                    (printf "hello?\n")
                     (values
                      (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
                      (dynamic-require 'compiler/cm 'manager-trace-handler)))
@@ -209,7 +210,8 @@
    (let ([old-load (current-load)])
      (λ (f expected)
        (splash-load-handler old-load f expected))))
-  
+  (printf ">> ~s\n" (list  make-compilation-manager-load/use-compiled-handler
+                           manager-trace-handler))
   (when (and make-compilation-manager-load/use-compiled-handler
              manager-trace-handler)
     (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")

collects/scheme/math.ss

@@ -7,7 +7,8 @@
 (provide pi
          sqr
          sgn conjugate
-         sinh cosh tanh)
+         sinh cosh tanh
+         order-of-magnitude)
 
 (define (sqr z) (* z z))
 
@@ -31,3 +32,82 @@
   (/ (+ (exp x) (exp (- x))) 2.0))
 
 (define (tanh x) (/ (sinh x) (cosh x)))
+
+(define order-of-magnitude
+  (let* ([exact-log (λ (x) (inexact->exact (log x)))]
+         [inverse-exact-log10 (/ (exact-log 10))])
+    (λ (r)
+      (unless (and (real? r) (positive? r))
+        (raise-type-error 'order-of-magnitude "positive real number" r))
+      (let* ([q (inexact->exact r)]
+             [m
+              (floor
+               (* (- (exact-log (numerator q)) (exact-log (denominator q)))
+                  inverse-exact-log10))])
+        (let loop ((m m) (p (expt 10 m)))
+          (if (< q p) (loop (sub1 m) (* p 1/10))
+              (let ((u (* p 10)))
+                (if (>= q u) (loop (add1 m) u) m))))))))
+
+#|
+;; Timing tests below provided by Jos Koot for the order-of-magnitude function
+
+#lang scheme
+
+;;; Tests and timings of order-of-magnitude
+
+(require "order-of-magnitude.ss")
+(require (planet joskoot/planet-fmt:1:1/fmt))
+
+(define-syntax timer
+ (syntax-rules ()
+  ((_ type iter k expr)
+   (let*
+    ((output-string (open-output-string))
+     (result expr)
+    (dummy
+     (parameterize ((current-output-port output-string))
+      (time (for ((k (in-range iter))) expr))))
+    (input-string (open-input-string (get-output-string output-string))))
+    (parameterize ((current-input-port input-string))
+     (let
+      ((cpu (begin (read) (read) (read)))
+       (real (begin (read) (read) (read)))
+       (gc (begin (read) (read) (read)))
+       (micro (/ iter 1000)))
+      (if (and (>= cpu 0) (>= real 0) (>= gc 0))
+       ((fmt
+         "'test type : ' d/
+          'exponent  : ' i6/
+          'n-obs     : ' i6/
+          'mean cpu  : ' i6 x 'microseconds'/
+          'mean real : ' i6 x 'microseconds'/
+          'mean gc   : ' i6 x 'microseconds'/
+          'real - gc : ' i6 x 'microseconds'//" 'current)
+        type
+        k
+        iter
+        (/ cpu micro)
+        (/ real micro)
+        (/ gc micro)
+        (/ (- cpu gc) micro))
+       ((fmt "'incorrect times for k='i//" 'current) k))))
+    result))))
+    
+
+(let* ((max-expt 10000) (small (expt 10 (- (* 2 max-expt)))) (iter 1000))
+ (for ((k (in-range (- max-expt) (add1 max-expt) (/ max-expt 10))))
+  (let* ((q (expt 10 k)) (qq (- q small)) (qqq (+ q small)))
+   (unless
+    (= k (timer "exact power of 10" iter k (order-of-magnitude q)))
+    (error 'test-1 "~s" k))
+   (unless
+    (= (sub1 k)
+     (timer "slightly less than power of 10" iter k (order-of-magnitude qq)))
+    (error 'test-2 "~s" k))
+   (unless
+    (= k
+     (timer "slightly more than power of 10" iter k (order-of-magnitude qqq)))
+    (error 'test-3 "~s" k)))))
+
+|#

collects/scribblings/reference/numbers.scrbl

@@ -897,6 +897,19 @@ Returns the hyperbolic cosine of @scheme[z].}
 
 Returns the hyperbolic tangent of @scheme[z].}
 
+@defproc[(order-of-magnitude [r (and/c real? positive?)]) (and/c exact? integer?)]{
+Computes the greatest exact integer @scheme[m] such that:
+@schemeblock[(<= (expt 10 m)
+                 (inexact->exact r))]
+Hence also
+@schemeblock[(< (inexact->exact r)
+                (expt 10 (add1 m)))].
+
+@mz-examples[#:eval math-eval 
+                    (order-of-magnitude 999)
+                    (order-of-magnitude 1000)]
+}
+
 @; ----------------------------------------------------------------------
 
 @close-eval[math-eval]

collects/tests/mzscheme/math.ss

@@ -0,0 +1,27 @@
+(load-relative "loadtest.ss")
+(Section 'math)
+(require scheme/math)
+
+(test 0 order-of-magnitude 1)
+(test 0 order-of-magnitude 9)
+(test 1 order-of-magnitude 10)
+(test 1 order-of-magnitude 17)
+(test 1 order-of-magnitude 99)
+(test 2 order-of-magnitude 100)
+(test 2 order-of-magnitude 200)
+(test 2 order-of-magnitude 999)
+(test 3 order-of-magnitude 1000)
+(test 3 order-of-magnitude 5000)
+(test 3 order-of-magnitude 9999)
+(test 4 order-of-magnitude 10000)
+
+(test 25 sqr 5)
+(test 25 sqr -5)
+
+(test #t <= (abs (sin pi)) 0.0001)
+
+(test 1 sgn 1)
+(test -1 sgn -1)
+(test 0 sgn 0)
+(test 1 sgn 999)
+(test -1 sgn -999)

collects/tests/mzscheme/scheme-tests.ss

@@ -3,6 +3,7 @@
 
 (load-in-sandbox "for.ss")
 (load-in-sandbox "list.ss")
+(load-in-sandbox "math.ss")
 (load-in-sandbox "vector.ss")
 (load-in-sandbox "function.ss")
 (load-in-sandbox "dict.ss")