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

svn: r16607
This commit is contained in:
Robby Findler 2009-11-07 14:26:39 +00:00
parent 5cd8db9be6
commit 667e967085
5 changed files with 125 additions and 2 deletions

View File

@ -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")

View File

@ -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)))))
|#

View File

@ -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]

View File

@ -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)

View File

@ -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")