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