suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some style things.

Browse Source
This commit is contained in:
Eli Barzilay 2012-06-14 17:27:32 -04:00
parent 2d902e8bf1
commit fac76a56f8
1 changed files with 90 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

186
collects/racket/math.rkt
View File

@ -17,111 +17,110 @@
exact-round exact-floor exact-ceiling exact-truncate exact-round exact-floor exact-ceiling exact-truncate
order-of-magnitude) order-of-magnitude)
(define pi (atan 0 -1)) (define pi (atan 0 -1))
(define pi.f (atan 0.0f0 -1.0f0)) (define pi.f (atan 0.0f0 -1.0f0))
(begin-encourage-inline (begin-encourage-inline
;; real predicates ;; real predicates
(define (nan? x) (define (nan? x)
(unless (real? x) (raise-argument-error 'nan? "real?" x)) (unless (real? x) (raise-argument-error 'nan? "real?" x))
(or (eqv? x +nan.0) (eqv? x +nan.f))) (or (eqv? x +nan.0) (eqv? x +nan.f)))
(define (infinite? x) (define (infinite? x)
(unless (real? x) (raise-argument-error 'infinite? "real?" x)) (unless (real? x) (raise-argument-error 'infinite? "real?" x))
(or (= x +inf.0) (= x -inf.0))) (or (= x +inf.0) (= x -inf.0)))
;; z^2 ;; z^2
(define (sqr z) (define (sqr z)
(unless (number? z) (raise-argument-error 'sqr "number?" z)) (unless (number? z) (raise-argument-error 'sqr "number?" z))
(* z z)) (* z z))
;; sgn function ;; sgn function
(define (sgn x) (define (sgn x)
(unless (real? x) (raise-argument-error 'sgn "real?" x)) (unless (real? x) (raise-argument-error 'sgn "real?" x))
(cond [(= 0 x) x] ; preserve 0, 0.0 and 0.0f0 (cond [(= 0 x) x] ; preserve 0, 0.0 and 0.0f0
[(double-flonum? x) (cond [(unsafe-fl> x 0.0) 1.0] [(double-flonum? x) (cond [(unsafe-fl> x 0.0) 1.0]
[(unsafe-fl< x 0.0) -1.0] [(unsafe-fl< x 0.0) -1.0]
[else +nan.0])] [else +nan.0])]
[(single-flonum? x) (cond [(> x 0.0f0) 1.0f0] [(single-flonum? x) (cond [(> x 0.0f0) 1.0f0]
[(< x 0.0f0) -1.0f0] [(< x 0.0f0) -1.0f0]
[else +nan.f])] [else +nan.f])]
[else (if (> x 0) 1 -1)])) [else (if (> x 0) 1 -1)]))
;; complex conjugate ;; complex conjugate
(define (conjugate z) (define (conjugate z)
(unless (number? z) (raise-argument-error 'conjugate "number?" z)) (unless (number? z) (raise-argument-error 'conjugate "number?" z))
(make-rectangular (real-part z) (- (imag-part z)))) (make-rectangular (real-part z) (- (imag-part z))))
;; complex hyperbolic functions ;; complex hyperbolic functions
(define (sinh z) (define (sinh z)
(unless (number? z) (raise-argument-error 'sinh "number?" z)) (unless (number? z) (raise-argument-error 'sinh "number?" z))
(cond [(= z 0) z] ; preserve 0, 0.0, -0.0, 0.0f0, 0.0+0.0i, etc. (cond [(= z 0) z] ; preserve 0, 0.0, -0.0, 0.0f0, 0.0+0.0i, etc.
[(real? z) [(real? z)
(let loop ([z z]) (let loop ([z z])
(cond [(z . < . 0) (- (loop (- z)))] (cond [(z . < . 0) (- (loop (- z)))]
[else (/ (- (exp z) (exp (- z))) 2)]))] [else (/ (- (exp z) (exp (- z))) 2)]))]
[else (/ (- (exp z) (exp (- z))) 2)])) [else (/ (- (exp z) (exp (- z))) 2)]))
(define (cosh z) (define (cosh z)
(unless (number? z) (raise-argument-error 'cosh "number?" z)) (unless (number? z) (raise-argument-error 'cosh "number?" z))
(cond [(and (real? z) (= z 0)) (if (single-flonum? z) 1.0f0 1.0)] (cond [(and (real? z) (= z 0)) (if (single-flonum? z) 1.0f0 1.0)]
[else (/ (+ (exp z) (exp (- z))) 2)])) [else (/ (+ (exp z) (exp (- z))) 2)]))
(define (tanh z) (define (tanh z)
(unless (number? z) (raise-argument-error 'tanh "number?" z)) (unless (number? z) (raise-argument-error 'tanh "number?" z))
(cond [(= z 0) z] ; preserve 0, 0.0, -0.0, 0.0f0, 0.0+0.0i, etc. (cond [(= z 0) z] ; preserve 0, 0.0, -0.0, 0.0f0, 0.0+0.0i, etc.
[(real? z) [(real? z)
(let loop ([z z]) (let loop ([z z])
(cond [(z . < . 0) (- (loop (- z)))] (cond [(z . < . 0) (- (loop (- z)))]
[(z . < . 20) (define exp2z (exp (* 2 z))) [(z . < . 20) (define exp2z (exp (* 2 z)))
(/ (- exp2z 1) (+ exp2z 1))] (/ (- exp2z 1) (+ exp2z 1))]
[(z . >= . 20) (if (single-flonum? z) 1.0f0 1.0)] [(z . >= . 20) (if (single-flonum? z) 1.0f0 1.0)]
[else z]))] ; +nan.0 or +nan.f [else z]))] ; +nan.0 or +nan.f
[else [else
(define exp2z (exp (* 2 z))) (define exp2z (exp (* 2 z)))
(/ (- exp2z 1) (+ exp2z 1))])) (/ (- exp2z 1) (+ exp2z 1))]))
;; angle conversion ;; angle conversion
(define (degrees->radians x) (define (degrees->radians x)
(unless (real? x) (raise-argument-error 'degrees->radians "real?" x)) (unless (real? x) (raise-argument-error 'degrees->radians "real?" x))
(cond [(single-flonum? x) (* x (/ pi.f 180f0))] (cond [(single-flonum? x) (* x (/ pi.f 180f0))]
[else (* x (/ pi 180.0))])) [else (* x (/ pi 180.0))]))
(define (radians->degrees x) (define (radians->degrees x)
(unless (real? x) (raise-argument-error 'radians->degrees "real?" x)) (unless (real? x) (raise-argument-error 'radians->degrees "real?" x))
(cond [(single-flonum? x) (* x (/ 180f0 pi.f))] (cond [(single-flonum? x) (* x (/ 180f0 pi.f))]
[else (* x (/ 180.0 pi))])) [else (* x (/ 180.0 pi))]))
;; inexact->exact composed with round, floor, ceiling, truncate ;; inexact->exact composed with round, floor, ceiling, truncate
(define-syntax-rule (define-integer-conversion name convert) (define-syntax-rule (define-integer-conversion name convert)
(define (name x) (define (name x)
(unless (rational? x) (raise-argument-error 'name "rational?" x)) (unless (rational? x) (raise-argument-error 'name "rational?" x))
(inexact->exact (convert x)))) (inexact->exact (convert x))))
(define-integer-conversion exact-round round) (define-integer-conversion exact-round round)
(define-integer-conversion exact-floor floor) (define-integer-conversion exact-floor floor)
(define-integer-conversion exact-ceiling ceiling) (define-integer-conversion exact-ceiling ceiling)
(define-integer-conversion exact-truncate truncate) (define-integer-conversion exact-truncate truncate)
) ; begin-encourage-inline )
(define order-of-magnitude (define order-of-magnitude
(let* ([exact-log (λ (x) (inexact->exact (log x)))] (let* ([exact-log (λ (x) (inexact->exact (log x)))]
[inverse-exact-log10 (/ (exact-log 10))]) [inverse-exact-log10 (/ (exact-log 10))])
(λ (r) (λ (r)
(unless (and (real? r) (positive? r) (unless (and (real? r) (positive? r) (not (= r +inf.0)))
(not (= r +inf.0)))
(raise-argument-error 'order-of-magnitude "(and/c (>/c 0.0) (not/c +inf.0))" r)) (raise-argument-error 'order-of-magnitude "(and/c (>/c 0.0) (not/c +inf.0))" r))
(let* ([q (inexact->exact r)] (define q (inexact->exact r))
[m (define m
(floor (floor (* (- (exact-log (numerator q)) (exact-log (denominator q)))
(* (- (exact-log (numerator q)) (exact-log (denominator q))) inverse-exact-log10)))
inverse-exact-log10))]) (let loop ([m m] [p (expt 10 m)])
(let loop ((m m) (p (expt 10 m))) (if (< q p)
(if (< q p) (loop (sub1 m) (* p 1/10)) (loop (sub1 m) (* p 1/10))
(let ((u (* p 10))) (let ([u (* p 10)])
(if (>= q u) (loop (add1 m) u) m)))))))) (if (>= q u) (loop (add1 m) u) m)))))))
#| #|
;; Timing tests below provided by Jos Koot for the order-of-magnitude function ;; Timing tests below provided by Jos Koot for the order-of-magnitude function
@ -134,54 +133,49 @@
(require (planet joskoot/planet-fmt:1:1/fmt)) (require (planet joskoot/planet-fmt:1:1/fmt))
(define-syntax timer (define-syntax timer
(syntax-rules () (syntax-rules ()
((_ type iter k expr) ((_ type iter k expr)
(let* (let* ([output-string (open-output-string)]
((output-string (open-output-string)) [result expr]
(result expr) [dummy (parameterize ([current-output-port output-string])
(dummy (time (for ([k (in-range iter)]) expr)))]
(parameterize ((current-output-port output-string)) [input-string (open-input-string (get-output-string output-string))])
(time (for ((k (in-range iter))) expr)))) (parameterize ([current-input-port input-string])
(input-string (open-input-string (get-output-string output-string)))) (let ([cpu (begin (read) (read) (read))]
(parameterize ((current-input-port input-string)) [real (begin (read) (read) (read))]
(let [gc (begin (read) (read) (read))]
((cpu (begin (read) (read) (read))) [micro (/ iter 1000)])
(real (begin (read) (read) (read))) (if (and (>= cpu 0) (>= real 0) (>= gc 0))
(gc (begin (read) (read) (read))) ((fmt
(micro (/ iter 1000))) "'test type : ' d/
(if (and (>= cpu 0) (>= real 0) (>= gc 0)) 'exponent : ' i6/
((fmt 'n-obs : ' i6/
"'test type : ' d/ 'mean cpu : ' i6 x 'microseconds'/
'exponent : ' i6/ 'mean real : ' i6 x 'microseconds'/
'n-obs : ' i6/ 'mean gc : ' i6 x 'microseconds'/
'mean cpu : ' i6 x 'microseconds'/ 'real - gc : ' i6 x 'microseconds'//" 'current)
'mean real : ' i6 x 'microseconds'/ type
'mean gc : ' i6 x 'microseconds'/ k
'real - gc : ' i6 x 'microseconds'//" 'current) iter
type (/ cpu micro)
k (/ real micro)
iter (/ gc micro)
(/ cpu micro) (/ (- cpu gc) micro))
(/ real micro) ((fmt "'incorrect times for k='i//" 'current) k))))
(/ gc micro) result))))
(/ (- cpu gc) micro))
((fmt "'incorrect times for k='i//" 'current) k))))
result))))
(let* ((max-expt 10000) (small (expt 10 (- (* 2 max-expt)))) (iter 1000)) (let* ([max-expt 10000] [small (expt 10 (- (* 2 max-expt)))] [iter 1000])
(for ((k (in-range (- max-expt) (add1 max-expt) (/ max-expt 10)))) (for ([k (in-range (- max-expt) (add1 max-expt) (/ max-expt 10))])
(let* ((q (expt 10 k)) (qq (- q small)) (qqq (+ q small))) (let* ([q (expt 10 k)] [qq (- q small)] [qqq (+ q small)])
(unless (unless (= k (timer "exact power of 10" iter k (order-of-magnitude q)))
(= k (timer "exact power of 10" iter k (order-of-magnitude q))) (error 'test-1 "~s" k))
(error 'test-1 "~s" k)) (unless (= (sub1 k)
(unless (timer "slightly less than power of 10"
(= (sub1 k) iter k (order-of-magnitude qq)))
(timer "slightly less than power of 10" iter k (order-of-magnitude qq))) (error 'test-2 "~s" k))
(error 'test-2 "~s" k)) (unless (= k
(unless (timer "slightly more than power of 10"
(= k iter k (order-of-magnitude qqq)))
(timer "slightly more than power of 10" iter k (order-of-magnitude qqq))) (error 'test-3 "~s" k)))))
(error 'test-3 "~s" k)))))
|# |#