added order-of-magnitude from Jos Koot and some tests for other scheme/math stuff
svn: r16607
This commit is contained in:
parent
5cd8db9be6
commit
667e967085
|
@ -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")
|
||||
|
|
|
@ -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)))))
|
||||
|
||||
|#
|
|
@ -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]
|
||||
|
|
27
collects/tests/mzscheme/math.ss
Normal file
27
collects/tests/mzscheme/math.ss
Normal 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)
|
|
@ -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")
|
||||
|
|
Loading…
Reference in New Issue
Block a user