1;;; mock data (method call) timing test 2 3(load "mockery.scm") 4 5(define mock-number (*mock-number* 'mock-number)) 6(define mock-string (*mock-string* 'mock-string)) 7(define make-mock-vector (*mock-vector* 'make-mock-vector)) 8(define make-mock-hash-table (*mock-hash-table* 'make-mock-hash-table)) 9 10 11(define dolph-1 12 (let ((+documentation+ "(dolph-1 n gamma) produces a Dolph-Chebyshev FFT data window of 'n' points using 'gamma' as the window parameter.")) 13 (lambda (N gamma) 14 (let ((vals (make-vector N))) 15 (let ((alpha (cosh (/ (acosh (expt 10.0 gamma)) N)))) 16 (do ((den (/ 1.0 (cosh (* N (acosh alpha))))) 17 (freq (/ pi N)) 18 (mult -1 (- mult)) 19 (i 0 (+ i 1)) 20 (phase (* -0.5 pi))) 21 ((= i N)) 22 (set! (vals i) (* mult den (cos (* N (acos (* alpha (cos phase))))))) 23 (set! phase (+ phase freq)))) 24 ;; now take the DFT 25 (let ((pk 0.0) 26 (w (make-vector N))) 27 (do ((i 0 (+ i 1)) 28 (sum 0.0 0.0)) 29 ((= i N)) 30 (do ((k 0 (+ k 1))) 31 ((= k N)) 32 (set! sum (+ sum (* (vals k) (exp (/ (* 2.0 0+1.0i pi k i) N)))))) 33 (set! (w i) (magnitude sum)) 34 (set! pk (max pk (w i)))) 35 ;; scale to 1.0 (it's usually pretty close already, that is pk is close to 1.0) 36 (do ((i 0 (+ i 1))) 37 ((= i N)) 38 (set! (w i) (/ (w i) pk))) 39 w))))) 40 41(display (dolph-1 (expt 2 8) 0.5)) (newline) 42(display (dolph-1 (mock-number (expt 2 8)) (mock-number 0.5))) (newline) 43 44 45(define src-duration 46 (let ((+documentation+ "(src-duration envelope) returns the new duration of a sound after using 'envelope' for time-varying sampling-rate conversion")) 47 (lambda (e) 48 (let ((len (- (length e) 2))) 49 (do ((all-x (- (e len) (e 0))) ; last x - first x 50 (dur 0.0) 51 (i 0 (+ i 2))) 52 ((>= i len) dur) 53 (let ((area (let ((x0 (e i)) 54 (x1 (e (+ i 2))) 55 (y0 (e (+ i 1))) ; 1/x x points 56 (y1 (e (+ i 3)))) 57 (if (< (abs (real-part (- y0 y1))) .0001) 58 (/ (- x1 x0) (* y0 all-x)) 59 (/ (* (log (/ y1 y0)) 60 (- x1 x0)) 61 (* (- y1 y0) all-x)))))) 62 (set! dur (+ dur (abs area))))))))) 63 64(display (src-duration (float-vector 0 1 .1 1 .2 .6 .5 .9 1 .5))) (newline) 65(display (src-duration (apply vector (map mock-number '(0 1 .1 1 .2 .6 .5 .9 1 .5))))) (newline) 66 67 68(define* (cfft data n (dir 1)) 69 (if (not n) (set! n (length data))) 70 (do ((i 0 (+ i 1)) 71 (j 0)) 72 ((= i n)) 73 (if (> j i) 74 (let ((temp (data j))) 75 (set! (data j) (data i)) 76 (set! (data i) temp))) 77 (do ((m (/ n 2) (/ m 2))) 78 ((or (< m 2) (< j m)) 79 (set! j (+ j m))) 80 (set! j (- j m)))) 81 82 (let ((ipow (floor (log n 2))) 83 (prev 1)) 84 (do ((lg 0 (+ lg 1)) 85 (mmax 2 (* mmax 2)) 86 (pow (/ n 2) (/ pow 2)) 87 (theta (complex 0.0 (* pi dir)) (* theta 0.5))) 88 ((= lg ipow)) 89 (let ((wpc (exp theta)) 90 (wc 1.0)) 91 (do ((ii 0 (+ ii 1))) 92 ((= ii prev)) 93 (do ((jj 0 (+ jj 1)) 94 (i ii (+ i mmax)) 95 (j (+ ii prev) (+ j mmax))) 96 ((>= jj pow)) 97 (let ((tc (* wc (data j)))) 98 (set! (data j) (- (data i) tc)) 99 (set! (data i) (+ (data i) tc)))) 100 (set! wc (* wc wpc))) 101 (set! prev mmax)))) 102 103 data) 104 105(define cfft-size 1024) 106(define cfft-data (make-vector cfft-size 0.0)) 107(do ((i 1 (+ i 1)) 108 (j (- cfft-size 1) (- j 1))) 109 ((= i (/ cfft-size 2))) 110 (set! (cfft-data i) (complex (- 1.0 (random 2.0)) (- 1.0 (random 2.0)))) 111 (set! (cfft-data j) (complex (real-part (cfft-data i)) (- (imag-part (cfft-data i)))))) 112(define cfft-mdata (copy cfft-data)) 113 114(display (cfft cfft-data cfft-size)) (newline) 115 116(let ((mockdata (make-mock-vector cfft-size))) 117 (do ((i 0 (+ i 1))) 118 ((= i cfft-size)) 119 (set! (mockdata i) (mock-number (cfft-mdata i)))) 120 (display (cfft mockdata cfft-size)) (newline)) 121 122 123(define (palindrome? str) 124 (or (< (string-length str) 2) 125 (and (char=? (string-ref str 0) 126 (string-ref str (- (string-length str) 1))) 127 (palindrome? (substring str 1 (- (string-length str) 1)))))) 128 129(display (palindrome? "abcdefgfedcba")) (newline) 130(display (palindrome? (mock-string "abcdefgfedcba"))) (newline) 131 132 133(let () 134 (define (walk p counts) 135 (if (pair? p) 136 (begin 137 (walk (car p) counts) 138 (if (pair? (cdr p)) 139 (walk (cdr p) counts))) 140 (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)))) 141 142 (define (lint-reader counts) 143 (let ((port (open-input-file "lint.scm"))) 144 (do ((expr (read port) (read port))) 145 ((eof-object? expr) 146 (close-input-port port) 147 counts) 148 (walk expr counts)))) 149 150 (define (sort-counts counts) 151 (let ((len (hash-table-entries counts))) 152 (do ((v (make-vector len)) 153 (h (make-iterator counts)) 154 (i 0 (+ i 1))) 155 ((= i len) 156 (sort! v (lambda (e1 e2) (> (cdr e1) (cdr e2)))) 157 v) 158 (vector-set! v i (iterate h))))) 159 160 (display (sort-counts (lint-reader (make-hash-table)))) (newline) 161 (display (sort-counts (lint-reader (make-mock-hash-table)))) (newline)) 162 163 164(exit) 165