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