1;;; various generally useful Snd extensions
2
3;;; mix then scale result to original peak amp
4;;; mix with envelope
5;;; map-sound-files, for-each-sound-file, match-sound-files, directory->list
6;;; mix-channel, insert-channel
7;;; redo-channel, undo-channel
8;;; sine-ramp, sine-env-channel, blackman4-ramp, blackman4-env-channel
9;;; ramp-squared, env-squared-channel
10;;; ramp-expt, env-expt-channel
11;;; offset-channel
12;;; channels-equal
13;;; mono->stereo, mono-files->stereo, stereo->mono
14
15
16(provide 'snd-extensions.scm)
17
18(define remove-if
19  (let ((+documentation+ "(remove-if func lst) removes any element from 'lst' that 'func' likes"))
20    (lambda (pred lst)
21      (map (lambda (x) (if (pred x) (values) x)) lst))))
22
23
24(if (not (defined? 'all-chans))
25    (define all-chans
26      (let ((+documentation+ "(all-chans) -> two parallel lists, the first sound objects, the second channel numbers.  If we have
27two sounds open (indices 0 and 1 for example), and the second has two channels, (all-chans) returns '((#<sound 0> #<sound 1> #<sound 1>) (0 0 1))"))
28	(lambda ()
29	  (let ((sndlist ())
30		(chnlist ()))
31	    (for-each (lambda (snd)
32			(do ((i (- (channels snd) 1) (- i 1)))
33			    ((< i 0))
34			  (set! sndlist (cons snd sndlist))
35			  (set! chnlist (cons i chnlist))))
36		      (sounds))
37	    (list sndlist chnlist))))))
38
39
40(define channel-sync
41  (dilambda
42   (let ((+documentation+ "(channel-sync snd chn) returns the sync property of that channel (it is not actually used anywhere)"))
43     (lambda (snd chn)
44       (channel-property 'sync snd chn)))
45   (lambda (snd chn val)
46     (set! (channel-property 'sync snd chn) val))))
47
48
49
50;;; -------- mix with result at original peak amp
51
52(define normalized-mix
53  (let ((+documentation+ "(normalized-mix filename beg in-chan snd chn) is like mix but the mix result has same peak amp as unmixed snd/chn (returns scaler)"))
54    (lambda* (filename beg in-chan snd chn)
55      (let ((original-maxamp (maxamp snd chn)))
56	(mix filename beg in-chan snd chn)
57	(let ((new-maxamp (maxamp snd chn)))
58	  (if (= original-maxamp new-maxamp)
59	      1.0
60	      (let ((scaler (/ original-maxamp new-maxamp)))
61		(let-temporarily (((sync snd) (+ (sync-max) 1)))
62		  (scale-by scaler snd chn))
63		scaler)))))))
64
65
66;;;-------- mix with envelope on mixed-in file
67
68(define enveloped-mix
69  (let ((+documentation+ "(enveloped-mix filename beg e) mixes filename starting at beg with amplitude envelope e. (enveloped-mix \"pistol.snd\" 0 '(0 0 1 1 2 0))"))
70    (lambda (filename beg e)
71      (let* ((len (framples filename))
72	     (amp-env (make-env e :length len))
73	     (rd (make-readin filename)))
74	(map-channel
75	 (lambda (y)
76	   (+ y (* (env amp-env) (readin rd))))
77	 beg len)))))
78
79
80;;; -------- map-sound-files, match-sound-files
81;;;
82;;; apply a function to each sound in dir
83;;;
84;;;   (map-sound-files (lambda (n) (if (> (mus-sound-duration n) 10.0) (snd-print n))))
85
86(define map-sound-files
87  (let ((+documentation+ "(map-sound-files func dir) applies func to each sound file in dir"))
88    (lambda* (func dir)
89      (map func (sound-files-in-directory (or dir "."))))))
90
91
92(define for-each-sound-file
93  (let ((+documentation+ "(for-each-sound-file func dir) applies func to each sound file in dir"))
94    (lambda* (func dir)
95      (for-each func (sound-files-in-directory (or dir "."))))))
96
97#|
98(for-each-sound-file
99 (lambda (n)
100   (catch #t
101     (lambda ()
102       (if (pair? (mus-sound-loop-info (string-append "/home/bil/sf/" n)))
103	   (snd-print (format #f "~%~A" n))))
104     (lambda args #f)))
105 "/home/bil/sf")
106|#
107
108
109(define match-sound-files
110  (let ((+documentation+ "(match-sound-files func dir) applies func to each sound file in dir and returns a list of files for which func does not return #f"))
111    (lambda* (func dir)
112      (let ((matches ()))
113	(for-each-sound-file (lambda (file)
114			       (if (func file)
115				   (set! matches (cons file matches))))
116			     dir)
117	matches))))
118
119
120;;; -------- mix-channel, insert-channel, c-channel
121
122(define mix-channel
123  (let ((+documentation+ "(mix-channel file beg dur snd chn edpos with-tag) mixes in file. file can be the file name, a sound object, or \
124a list (file-name-or-sound-object [beg [channel]])."))
125
126    (lambda* (input-data (beg 0) dur snd (chn 0) edpos with-tag)
127      (let ((input (if (not (pair? input-data))
128		       input-data
129		       (car input-data)))
130	    (input-beg (if (or (not (pair? input-data))
131			       (< (length input-data) 2))
132			   0
133			   (cadr input-data)))
134	    (input-channel (if (or (not (pair? input-data))
135				   (< (length input-data) 3))
136			       0
137			       (caddr input-data))))
138	(let ((len (or dur (- (if (string? input)
139				  (framples input)
140				  (framples input input-channel))
141			      input-beg)))
142	      (start (or beg 0)))
143	  (cond ((< start 0)
144		 (error 'no-such-sample "mix-channel: begin time < 0: ~A" beg))
145
146		((<= len 0))
147
148		((not with-tag)
149		 ;; not a virtual mix
150		 (let ((d1 (samples input-beg len input input-channel))
151		       (d2 (samples start len snd chn edpos)))
152		   (float-vector-add! d1 d2)
153		   (float-vector->channel d1 start len snd chn
154					  current-edit-position
155					  (format #f (if (string? input-data)
156							 "mix-channel ~S ~A ~A"
157							 "mix-channel '~A ~A ~A")
158						  input-data beg dur))))
159
160		;; a virtual mix -- use simplest method available
161		((sound? input)          ; sound object case
162		 (if (< len 1000000)
163		     (mix-float-vector (channel->float-vector input-beg len input input-channel) start snd chn #t)
164		     (let* ((output-name (snd-tempnam))
165			    (output (new-sound output-name :size len)))
166		       (float-vector->channel (samples input-beg len input input-channel) 0 len output 0)
167		       (save-sound output)
168		       (close-sound output)
169		       (mix output-name start 0 snd chn #t #t))))
170
171		((and (= start 0)        ; file input
172		      (= len (framples input)))
173		 (mix input start 0 snd chn #t #f)) ; mix entire file (don't delete it)
174
175		(else
176		 ;; mix part of file
177		 (let* ((output-name (snd-tempnam))
178			(output (new-sound output-name :size len)))
179		   (float-vector->channel (samples input-beg len input input-channel) 0 len output 0)
180		   (save-sound output)
181		   (close-sound output)
182		   (mix output-name start 0 snd chn #t #t)))))))))
183
184
185(define insert-channel
186  (let ((+documentation+ "(insert-channel file beg dur snd chn edpos) inserts the file. file can be the file name or a list (file-name [beg [channel]])"))
187    (lambda* (file-data beg dur snd chn edpos)
188      (let ((file-name (if (string? file-data) file-data (car file-data)))
189	    (file-beg (if (or (string? file-data)
190			      (< (length file-data) 2))
191			  0
192			  (cadr file-data))))
193	(let ((file-channel (if (or (string? file-data)
194				    (< (length file-data) 3))
195				0
196				(caddr file-data)))
197	      (len (or dur (- (framples file-name) file-beg)))
198	      (start (or beg 0)))
199	  (if (< start 0) (error 'no-such-sample "insert-channel: begin time < 0: ~A" beg))
200	  (if (> len 0)
201	      (insert-samples start len
202			      (samples file-beg len file-name file-channel)
203			      snd chn edpos #f
204			      (format #f (if (string? file-data)
205					     "insert-channel ~S ~A ~A"
206					     "insert-channel '~A ~A ~A")
207				      file-data beg dur))))))))
208
209
210;;; -------- redo-channel, undo-channel
211
212(define redo-channel
213  (let ((+documentation+ "(redo-channel (edits 1) snd chn) is the regularized version of redo"))
214    (lambda* ((edits 1) snd chn)
215      (if (and snd (not (= (sync snd) 0)) chn)
216	  (set! (edit-position snd chn) (+ (edit-position snd chn) edits))
217	  (redo edits snd)))))
218
219
220(define undo-channel
221  (let ((+documentation+ "(undo-channel (edits 1) snd chn) is the regularized version of undo"))
222    (lambda* ((edits 1) snd chn)
223      (if (and snd (not (= (sync snd) 0)) chn)
224	  (set! (edit-position snd chn) (max 0 (- (edit-position snd chn) edits)))
225	  (undo edits snd)))))
226
227
228;;; -------- any-env-channel
229
230(define any-env-channel
231  (let ((+documentation+ "(any-env-channel e func (beg 0) dur snd chn edpos origin) takes breakpoints in 'e', \
232connects them with 'func', and applies the result as an amplitude envelope to the given channel"))
233    (lambda* (e func (beg 0) dur snd chn edpos origin)
234      ;; handled as a sequence of funcs and scales
235      (when (pair? e)
236	(let ((pts (/ (length e) 2)))
237	  (if (= pts 1)
238	      (scale-channel (car e) beg dur snd chn edpos)
239	      (let ((x0 0)
240		    (y0 0)
241		    (x1 (car e))
242		    (y1 (cadr e))
243		    (xrange (- (e (- (length e) 2)) (car e)))
244		    (ramp-beg beg)
245		    (ramp-dur 0))
246		(if (not (number? dur)) (set! dur (framples snd chn)))
247		(as-one-edit
248		 (lambda ()
249		   (do ((i 1 (+ 1 i))
250			(j 2 (+ j 2)))
251		       ((= i pts))
252		     (set! x0 x1)
253		     (set! y0 y1)
254		     (set! x1 (e j))
255		     (set! y1 (e (+ 1 j)))
256		     (set! ramp-dur (round (* dur (/ (- x1 x0) xrange))))
257		     (if (= y0 y1)
258			 (scale-channel y0 ramp-beg ramp-dur snd chn edpos)
259			 (func y0 y1 ramp-beg ramp-dur snd chn edpos))
260		     (set! ramp-beg (+ ramp-beg ramp-dur))))
261		 origin))))))))
262
263;;; -------- sine-ramp sine-env-channel
264
265(define sine-ramp
266  (let ((+documentation+ "(sine-ramp rmp0 rmp1 (beg 0) dur snd chn edpos) produces a sinsusoidal connection from rmp0 to rmp1"))
267    (lambda* (rmp0 rmp1 (beg 0) dur snd chn edpos)
268      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
269	(let ((data (samples beg len snd chn edpos))
270	      (incr (/ pi len))
271	      (scl (* 0.5 (- rmp1 rmp0))))
272	  (do ((off (+ rmp0 scl))
273	       (i 0 (+ i 1))
274	       (angle (- pi) (+ angle incr)))
275	      ((= i len))
276	    (float-vector-set! data i (* (float-vector-ref data i)
277					 (+ off (* scl (cos angle))))))
278	  (float-vector->channel data
279				 beg len snd chn current-edit-position
280				 (format #f "sine-ramp ~A ~A ~A ~A" rmp0 rmp1 beg dur)))))))
281
282
283(define sine-env-channel
284  (let ((+documentation+ "(sine-env-channel e (beg 0) dur snd chn edpos) connects e's dots with sinusoids"))
285    (lambda* (e (beg 0) dur snd chn edpos)
286      (any-env-channel e sine-ramp beg dur snd chn edpos (format #f "sine-env-channel '~A ~A ~A" e beg dur)))))
287
288;;; (sine-env-channel '(0 0 1 1 2 -.5 3 1))
289
290;;; an obvious extension of this idea is to use the blackman fft window formulas
291;;;   to get sharper sinusoids (i.e. use the sum of n cosines, rather than just 1)
292
293
294;;; -------- blackman4-ramp, blackman4-env-channel
295
296(define blackman4-ramp
297  (let ((+documentation+ "(blackman4-ramp rmp0 rmp1 (beg 0) dur snd chn edpos) produces a blackman4-shaped envelope"))
298    (lambda* (rmp0 rmp1 (beg 0) dur snd chn edpos)
299      ;; float-vector: angle incr off scl
300      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
301	(let ((incr (/ pi len))
302	      (data (samples beg len snd chn edpos))
303	      (coeffs (float-vector-scale! (float-vector 0.084037 -.29145 .375696 -.20762 .041194) (- rmp1 rmp0))))
304	  (float-vector-set! coeffs 0 (+ (float-vector-ref coeffs 0) rmp0))
305	  (do ((i 0 (+ i 1))
306	       (angle 0.0 (+ angle incr)))
307	      ((= i len))
308	    (float-vector-set! data i (* (float-vector-ref data i)
309					 (polynomial coeffs (cos angle)))))
310	  (float-vector->channel data beg len snd chn current-edit-position
311				 (format #f "blackman4-ramp ~A ~A ~A ~A" rmp0 rmp1 beg dur)))))))
312
313
314(define blackman4-env-channel
315  (let ((+documentation+ "(blackman4-env-channel e (beg 0) dur snd chn edpos) uses the blackman4 window to connect the dots in 'e'"))
316    (lambda* (e (beg 0) dur snd chn edpos)
317      (any-env-channel e blackman4-ramp beg dur snd chn edpos (format #f "blackman4-env-channel '~A ~A ~A" e beg dur)))))
318
319
320
321;;; -------- ramp-squared, env-squared-channel
322
323(define ramp-squared
324  (let ((+documentation+ "(ramp-squared rmp0 rmp1 (symmetric #t) (beg 0) dur snd chn edpos) connects rmp0 and rmp1 with an x^2 curve"))
325    (lambda* (rmp0 rmp1 (symmetric #t) (beg 0) dur snd chn edpos)
326      ;; float-vector: start incr off scl
327      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
328	(let ((incr (/ 1.0 len))
329	      (data (samples beg len snd chn edpos))
330	      (scl (- rmp1 rmp0)))
331	  (if (and symmetric
332		   (< rmp1 rmp0))
333	      (begin
334		(set! scl (- scl))
335		(do ((i 0 (+ i 1))
336		     (angle 1.0 (- angle incr)))
337		    ((= i len))
338		  (float-vector-set! data i (* (float-vector-ref data i)
339					       (+ rmp1 (* scl angle angle))))))
340	      (do ((i 0 (+ i 1))
341		   (angle 0.0 (+ angle incr)))
342		  ((= i len))
343		(float-vector-set! data i (* (float-vector-ref data i)
344					     (+ rmp0 (* scl angle angle))))))
345	  (float-vector->channel data beg len snd chn current-edit-position
346				 (format #f "ramp-squared ~A ~A ~A ~A ~A" rmp0 rmp1 symmetric beg dur)))))))
347
348
349(define env-squared-channel
350  (let ((+documentation+ "(env-squared-channel e (symmetric #t) (beg 0) dur snd chn edpos) connects e's dots with x^2 curves"))
351    (lambda* (e (symmetric #t) (beg 0) dur snd chn edpos)
352      (any-env-channel e
353		       (lambda (r0 r1 b d s c e)
354			 (ramp-squared r0 r1 symmetric b d s c e))
355		       beg dur snd chn edpos
356		       (format #f "env-squared-channel '~A ~A ~A ~A" e symmetric beg dur)))))
357
358;;; (env-squared-channel '(0 0 1 1 2 -.5 3 1))
359
360
361;;; -------- ramp-expt, env-expt-channel
362
363(define ramp-expt
364  (let ((+documentation+ "(ramp-expt rmp0 rmp1 exponent (symmetric #t) (beg 0) dur snd chn edpos) connects rmp0 and rmp1 with an x^exponent curve"))
365    (lambda* (rmp0 rmp1 exponent (symmetric #t) (beg 0) dur snd chn edpos)
366      ;; float-vector: start incr off scl exponent
367      ;; a^x = exp(x * log(a))
368      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
369	(let ((incr (/ 1.0 len))
370	      (data (samples beg len snd chn edpos))
371	      (scl (- rmp1 rmp0)))
372	  (if (and symmetric
373		   (< rmp1 rmp0))
374	      (begin
375		(set! scl (- scl))
376		(do ((i 0 (+ i 1))
377		     (angle 1.0 (- angle incr)))
378		    ((= i len))
379		  (float-vector-set! data i (* (float-vector-ref data i)
380					       (+ rmp1 (* scl (expt angle exponent)))))))
381	      (do ((i 0 (+ i 1))
382		   (angle 0.0 (+ angle incr)))
383		  ((= i len))
384		(float-vector-set! data i (* (float-vector-ref data i)
385					     (+ rmp0 (* scl (expt angle exponent)))))))
386	  (float-vector->channel data beg len snd chn current-edit-position
387				 (format #f "ramp-expt ~A ~A ~A ~A ~A ~A" rmp0 rmp1 exponent symmetric beg dur)))))))
388
389
390(define env-expt-channel
391  (let ((+documentation+ "(env-expt-channel e exponent (symmetric #t) (beg 0) dur snd chn edpos) connects e's dots with x^exponent curves"))
392    (lambda* (e exponent (symmetric #t) (beg 0) dur snd chn edpos)
393      (if (= exponent 1.0)
394	  (env-channel e beg dur snd chn edpos)
395	  (any-env-channel e
396			   (lambda (r0 r1 b d s c e)
397			     (ramp-expt r0 r1 exponent symmetric b d s c e))
398			   beg dur snd chn edpos
399			   (format #f "env-expt-channel '~A ~A ~A ~A ~A" e exponent symmetric beg dur))))))
400
401
402;;; -------- offset-channel
403
404(define offset-channel
405  (let ((+documentation+ "(offset-channel amount (beg 0) dur snd chn edpos) adds amount to each sample"))
406    (lambda* (dc (beg 0) dur snd chn edpos)
407      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
408	(float-vector->channel (float-vector-offset! (samples beg len snd chn edpos) dc)
409			       beg len snd chn current-edit-position (format #f "offset-channel ~A ~A ~A" dc beg dur))))))
410
411
412(define offset-sound
413  (let ((+documentation+ "(offset-sound off beg dur snd) adds 'off' to every sample in 'snd'"))
414    (lambda* (off (beg 0) dur snd)
415      (let ((index (or snd (selected-sound) (car (sounds)))))
416	(if (sound? index)
417	    (do ((out-chans (channels index))
418		 (chn 0 (+ 1 chn)))
419		((= chn out-chans))
420	      (offset-channel off beg dur index chn))
421	    (error 'no-such-sound "offset-sound: no such sound: ~A" snd))))))
422
423
424;;; -------- pad-sound
425
426(define pad-sound
427  (let ((+documentation+ "(pad-sound beg dur snd) places a block of 'dur' zeros in every channel of 'snd' starting at 'beg'"))
428    (lambda* (beg dur snd)
429      (let ((index (or snd (selected-sound) (car (sounds)))))
430	(if (sound? index)
431	    (do ((out-chans (channels index))
432		 (chn 0 (+ 1 chn)))
433		((= chn out-chans))
434	      (pad-channel beg dur index chn))
435	    (error 'no-such-sound "pad-sound: no such sound: ~A" snd))))))
436
437
438;;; -------- dither-channel
439
440(define dither-channel
441  (let ((+documentation+ "(dither-channel (amount .00006) (beg 0) dur snd chn edpos) adds amount dither to each sample"))
442    (lambda* ((amount .00006) (beg 0) dur snd chn edpos)
443      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
444	(do ((dither (* .5 amount))
445	     (data (samples beg len snd chn edpos))
446	     (i 0 (+ i 1)))
447	    ((= i len)
448	     (float-vector->channel data beg len snd chn current-edit-position
449				    (format #f "dither-channel ~,8F ~A ~A" amount beg dur)))
450	  (float-vector-set! data i (+ (float-vector-ref data i) (mus-random dither) (mus-random dither))))))))
451
452(define dither-sound
453  (let ((+documentation+ "(dither-sound (amount .00006) beg dur snd) adds dithering to every channel of 'snd'"))
454    (lambda* ((amount .00006) (beg 0) dur snd)
455      (let ((index (or snd (selected-sound) (car (sounds)))))
456	(if (sound? index)
457	    (do ((out-chans (channels index))
458		 (chn 0 (+ 1 chn)))
459		((= chn out-chans))
460	      (dither-channel amount beg dur index chn))
461	    (error 'no-such-sound "dither-sound: no such sound: ~A" snd))))))
462
463
464;;; -------- contrast-channel
465
466(define contrast-channel
467  (let ((+documentation+ "(contrast-channel index (beg 0) dur snd chn edpos) applies contrast enhancement to the sound"))
468    (lambda* (index (beg 0) dur snd chn edpos)
469      (let ((len (if (number? dur) dur (- (framples snd chn) beg))))
470	(do ((data (samples beg len snd chn edpos))
471	     (i 0 (+ i 1)))
472	    ((= i len)
473	     (float-vector->channel data beg len snd chn current-edit-position
474				    (format #f "contrast-channel ~A ~A ~A" index beg dur)))
475	  (float-vector-set! data i (contrast-enhancement (float-vector-ref data i) index))))))) ; (sin (+ (* 0.5 pi y) (* index (sin (* 2.0 pi y))))))))
476
477(define contrast-sound
478  (let ((+documentation+ "(contrast-sound index beg dur snd) applies contrast-enhancement to every channel of 'snd'"))
479    (lambda* (index (beg 0) dur snd)
480      (let ((ind (or snd (selected-sound) (car (sounds)))))
481	(if (sound? ind)
482	    (do ((out-chans (channels ind))
483		 (chn 0 (+ 1 chn)))
484		((= chn out-chans))
485	      (contrast-channel index beg dur ind chn))
486	    (error 'no-such-sound "contrast-sound: no such sound: ~A" snd))))))
487
488
489;;; -------- scale-sound
490
491(define scale-sound
492  (let ((+documentation+ "(scale-sound scl beg dur snd) multiplies every sample in 'snd' by 'scl'"))
493    (lambda* (scl (beg 0) dur snd)
494      ;; the slow way:
495      ;; (map-sound (lambda (fr) (frame* fr scl)) beg dur snd))
496      (let ((index (or snd (selected-sound) (car (sounds)))))
497	(if (sound? index)
498	    (do ((out-chans (channels index))
499		 (chn 0 (+ 1 chn)))
500		((= chn out-chans))
501	      (scale-channel scl beg dur index chn))
502	    (error 'no-such-sound "scale-sound: no such sound: ~A" snd))))))
503
504
505;;; -------- normalize-sound
506
507(define normalize-sound
508  (let ((+documentation+ "(normalize-sound amp beg dur snd) scales 'snd' to peak amplitude 'amp'"))
509    (lambda* (amp (beg 0) dur snd)
510      (let ((index (or snd (selected-sound) (car (sounds)))))
511	(if (sound? index)
512	    (let ((out-chans (channels index))
513		  (mx (apply max (maxamp index #t))))
514	      (do ((chn 0 (+ 1 chn)))
515		  ((= chn out-chans))
516		(scale-channel (/ amp mx) beg dur index chn)))
517	    (error 'no-such-sound "normalize-sound: no such sound: ~A" snd))))))
518
519
520
521;;; -------- channels-equal
522
523(define channels=?
524  (let ((+documentation+ "(channels=? s1 c1 s2 c2 (diff 0.0)) -> #t if the two channels are the same (within diff) modulo trailing 0's"))
525    (lambda* (snd1 (chn1 0) snd2 (chn2 0) (allowable-difference 0.0))
526      (or (and (equal? snd1 snd2)
527	       (= chn1 chn2))
528	  (let ((mx1 (maxamp snd1 chn1))
529		(mx2 (maxamp snd1 chn1)))
530	    (and (<= (abs (- mx1 mx2)) allowable-difference)
531		 (let* ((len1 (framples snd1 chn1))
532			(len2 (framples snd2 chn2))
533			(first-longer (>= len1 len2)))
534		   (let ((len (if first-longer len1 len2))
535			 (s1 (if first-longer snd1 snd2))
536			 (s2 (if first-longer snd2 snd1))
537			 (c1 (if first-longer chn1 chn2))
538			 (c2 (if first-longer chn2 chn1)))
539		     (let ((v0 (channel->float-vector 0 len s1 c1))
540			   (v1 (channel->float-vector 0 len s2 c2)))
541		       (<= (float-vector-peak (float-vector-subtract! v0 v1)) allowable-difference))))))))))
542
543
544(define channels-equal?
545  (let ((+documentation+ "(channels-equal? s1 c1 s2 c2 (diff 0.0)) -> #t if the two channels are the same (within diff)"))
546    (lambda* (snd1 chn1 snd2 chn2 (allowable-difference 0.0))
547      (and (= (framples snd1 chn1) (framples snd2 chn2))
548	   (channels=? snd1 chn1 snd2 chn2 allowable-difference)))))
549
550
551;;; -------- mono->stereo, mono-files->stereo
552
553(define mono->stereo
554  (let ((+documentation+ "(mono->stereo new-name snd1 chn1 snd2 chn2) takes the two channels and combines them into a stereo sound 'new-name'"))
555    (lambda (new-name snd1 chn1 snd2 chn2)
556      ;; (mono->stereo "test.snd" 0 0 1 0)
557      (let ((old-ed1 (edit-position snd1 chn1))
558	    (old-ed2 (edit-position snd2 chn2))
559	    (ind (new-sound new-name :channels 2 :srate (srate snd1))))
560	(swap-channels ind 0 snd1 chn1)
561	(swap-channels ind 1 snd2 chn2)
562	(set! (edit-position snd1 chn1) old-ed1)
563	(set! (edit-position snd2 chn2) old-ed2)
564	ind))))
565
566
567(define mono-files->stereo
568  (let ((+documentation+ "(mono-files->stereo new-name file1 file2) combines two mono files into the stereo file 'new-name'"))
569    (lambda (new-name chan1-name chan2-name)
570      ;; (mono-files->stereo "test.snd" "oboe.snd" "pistol.snd")
571      (let* ((ind1 (open-sound chan1-name))
572	     (ind2 (open-sound chan2-name))
573	     (ind3 (mono->stereo new-name ind1 0 ind2 0)))
574	(close-sound ind1)
575	(close-sound ind2)
576	ind3))))
577
578
579(define stereo->mono
580  (let ((+documentation+ "(stereo->mono stereo-sound new-chan1 new-chan2) splits a stereo sound into two mono sounds named 'new-chan1' and 'new-chan2'"))
581    (lambda (orig-snd chan1-name chan2-name)
582      ;; (stereo->mono 0 "hi1.snd" "hi2.snd")
583      (let ((old-ed0 (edit-position orig-snd 0))
584	    (old-ed1 (edit-position orig-snd 1))
585	    (chan1 (new-sound chan1-name :srate (srate orig-snd)))
586	    (chan2 (new-sound chan2-name :srate (srate orig-snd))))
587	(swap-channels orig-snd 0 chan1 0)
588	(swap-channels orig-snd 1 chan2 0)
589	(set! (edit-position orig-snd 0) old-ed0)
590	(set! (edit-position orig-snd 1) old-ed1)
591	(list chan1 chan2)))))
592
593