"Fossies" - the Fresh Open Source Software Archive

Member "snd-20.9/examp.scm" (14 Apr 2018, 76343 Bytes) of package /linux/misc/snd-20.9.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ;;; examples of Scheme extensions to Snd
    2 ;;;
    3 ;;; documentation examples made harder to break
    4 ;;; 'info' from extsnd.html using format
    5 ;;; correlation
    6 ;;; XEmacs-like "Buffers" menu
    7 ;;; Reopen menu
    8 ;;; set transform-size based on current time domain window size
    9 ;;; superimpose spectra of sycn'd sounds
   10 ;;; translate mpeg input to 16-bit linear and read into Snd
   11 ;;; read and write OGG files
   12 ;;; make dot size dependent on number of samples being displayed
   13 ;;; move window left edge to mark upon 'm' key
   14 ;;; flash selected data red and green
   15 ;;; use loop info (if any) to set marks at loop points
   16 ;;; mapping extensions (map arbitrary single-channel function over various channel collections)
   17 ;;;     do-chans, do-all-chans, do-sound-chans
   18 ;;;     every-sample?
   19 ;;;     sort-samples
   20 ;;; mix mono sound into stereo sound panning according to env, also simple sound placement
   21 ;;; fft-edit, fft-squelch, squelch-vowels, fft-env-interp, fft-smoother -- FFT based editing, fft-smoothing
   22 ;;; comb-filter, notch-filter, formant-filter
   23 ;;; echo (delays)
   24 ;;; ring-modulation, am, vibro
   25 ;;; src-related sound effects (src, rand-interp, etc)
   26 ;;; compand (array-interp)
   27 ;;; shift pitch keeping duration constant (src+granulate)
   28 ;;; tempo change via envelope (granulate)
   29 ;;; cross-synthesis (using a formant bank)
   30 ;;; voiced->unvoiced (formants)
   31 ;;; convolution (convolve)
   32 ;;; time varying FIR filter, notch filter
   33 ;;; sound-interp, env-sound-interp
   34 ;;; filtered-env (low-pass and amplitude follow envelope)
   35 ;;; multi-colored rxvt printout
   36 ;;; lisp graph with draggable x axis
   37 ;;; pointer focus within Snd
   38 ;;; View: Files dialog chooses which sound is displayed
   39 ;;; remove-clicks
   40 ;;; searching examples (zero+, next-peak, find-pitch)
   41 ;;; file->floats and a sort of cue-list, I think, and region-play-list, region-play-sequence
   42 ;;; explode-sf2 -- turn soundfont file into a bunch of files of the form sample-name.aif
   43 ;;; open-next-file-in-directory -- middle button click closes current file and opens next
   44 ;;; chain-dsps
   45 ;;; scramble-channels -- reorder chans
   46 ;;; scramble-channel -- randomly reorder segments within a sound
   47 ;;; reverse-by-blocks and reverse-within-blocks -- reorder or reverse blocks within a channel
   48 ;;; sound segmentation
   49 ;;; sync-everything
   50 
   51 (provide 'snd-examp.scm)
   52 (if (provided? 'snd)
   53     (require snd-ws.scm)
   54     (require sndlib-ws.scm))
   55 (require snd-env.scm)
   56 
   57 
   58 ;;; -------- (ext)snd.html examples made harder to break --------
   59 ;;;
   60 ;;; this mainly involves keeping track of the current sound/channel
   61 
   62 (define selection-rms
   63   (let ((+documentation+ "(selection-rms) -> rms of selection data using samplers"))
   64     (lambda ()
   65       (if (selection?)
   66       (let ((data (samples (selection-position) (selection-framples))))
   67         (sqrt (/ (dot-product data data) (selection-framples))))
   68       (error 'no-active-selection (list "selection-rms-1"))))))
   69 
   70 
   71 (define region-rms
   72   (let ((+documentation+ "(region-rms n) -> rms of region n's data (chan 0)"))
   73     (lambda (reg)
   74       (if (region? reg)
   75       (let ((data (region->float-vector reg 0 0)))
   76         (sqrt (/ (dot-product data data) (length data))))
   77       (error 'no-such-region (list "region-rms" reg))))))
   78 
   79 
   80 (define window-samples
   81   (let ((+documentation+ "(window-samples snd chn) -> samples in snd channel chn in current graph window"))
   82     (lambda* (snd chn)
   83       (let ((wl (left-sample snd chn))
   84         (wr (right-sample snd chn)))
   85     (channel->float-vector wl (- (+ wr 1) wl) snd chn)))))
   86 
   87 
   88 (define display-energy 
   89   ;; in this version, the y-zoom-slider controls the graph amp
   90   (let ((+documentation+ "(display-energy hook) is a lisp-graph-hook function to display the time domain data as energy (squared)"))
   91     (lambda (hook)
   92       (let ((snd (hook 'snd))
   93         (chn (hook 'chn)))
   94     (let ((ls (left-sample snd chn))
   95           (rs (right-sample snd chn))
   96           (data (let ((datal (make-graph-data snd chn)))
   97               (if (float-vector? datal) datal (cadr datal))))
   98           (sr (srate snd))
   99           (y-max (y-zoom-slider snd chn)))
  100       (if (and data ls rs)
  101           (begin
  102         (float-vector-multiply! data data)
  103         (graph data "energy" (/ ls sr) (/ rs sr) 0.0 (* y-max y-max) snd chn #f))))))))
  104   
  105 ;; (hook-push lisp-graph-hook display-energy)
  106 
  107 
  108 (define display-db 
  109   (let ((+documentation+ "(display-db hook) is a lisp-graph-hook function to display the time domain data in dB")
  110     (dB (lambda (val)
  111           (if (< val .001)
  112           -60.0
  113           (* 20.0 (log val 10))))))
  114     (lambda (hook)
  115       (let ((snd (hook 'snd))
  116         (chn (hook 'chn)))
  117     (let ((datal (make-graph-data snd chn)))
  118     
  119       (if datal
  120           (let ((data (if (float-vector? datal) datal (cadr datal))))
  121         (let ((len (length data))
  122               (sr (srate snd)))
  123           (do ((i 0 (+ i 1)))
  124               ((= i len))
  125             (set! (data i) (+ 60.0 (dB (abs (data i))))))
  126           (graph data "dB" 
  127              (/ (left-sample snd chn) sr) (/ (right-sample snd chn) sr)  
  128              0.0 60.0
  129              snd chn)))))))))
  130 
  131 ;; (hook-push lisp-graph-hook display-db)
  132 
  133 
  134 (define window-rms
  135   (let ((+documentation+ "(window-rms) -> rms of data in currently selected graph window"))
  136     (lambda ()
  137       (let* ((data (channel->float-vector (left-sample) (- (+ (right-sample) 1) (left-sample))))
  138          (len (length data)))
  139     (sqrt (/ (dot-product data data) len))))))
  140 
  141 
  142 (define fft-peak 
  143   (let ((+documentation+ "(fft-peak hook) returns the peak spectral magnitude.  It is intended for use with after-transform-hook."))
  144     (lambda (hook)
  145       (let ((snd (hook 'snd))
  146         (chn (hook 'chn)))
  147     (if (and (transform-graph?) 
  148          (= *transform-graph-type* graph-once))
  149         (status-report 
  150          (number->string (/ (* 2.0 (float-vector-peak (transform->float-vector snd chn))) 
  151                 *transform-size*))
  152          snd))))))
  153 
  154                     ;(hook-push after-transform-hook fft-peak)
  155 
  156 
  157 ;;; -------- 'info' from extsnd.html using format --------
  158 
  159 (define finfo 
  160   (let ((+documentation+ "(finfo file) -> description (as a string) of file"))
  161     (lambda (file)
  162       (format #f "~A: chans: ~D, srate: ~D, ~A, ~A, len: ~1,3F"
  163           file
  164           (channels file)
  165           (srate file)
  166           (mus-header-type-name (mus-sound-header-type file))
  167           (mus-sample-type-name (mus-sound-sample-type file))
  168           (* 1.0 (/ (mus-sound-samples file) (channels file) (srate file)))))))
  169 
  170 
  171 ;;; -------- Correlation --------
  172 ;;;
  173 ;;; correlation of channels in a stereo sound
  174 
  175 (define display-correlation 
  176   (let ((+documentation+ "(display-correlation hook) returns the correlation of snd's 2 channels (intended for use with graph-hook).  y0 and y1 are ignored."))
  177     (lambda (hook)
  178       (let ((snd (hook 'snd)))
  179     (if (not (and (= (channels snd) 2)
  180               (> (framples snd 0) 1)
  181               (> (framples snd 1) 1)))
  182         (status-report "display-correlation wants stereo input")
  183         (let* ((ls (left-sample snd 0))
  184            (fftlen (floor (expt 2 (ceiling (log (- (+ (right-sample snd 0) 1) ls) 2))))))
  185           (let ((fftscale (/ 1.0 fftlen))
  186             (rl1 (channel->float-vector ls fftlen snd 0))
  187             (rl2 (channel->float-vector ls fftlen snd 1))
  188             (im1 (make-float-vector fftlen))
  189             (im2 (make-float-vector fftlen)))
  190         (fft rl1 im1 1)
  191         (fft rl2 im2 1)
  192         (let ((tmprl (copy rl1))
  193               (tmpim (copy im1)))
  194           (float-vector-multiply! tmprl rl2)     ; (* tempr1 tempr2)
  195           (float-vector-multiply! tmpim im2)     ; (* tempi1 tempi2)
  196           (float-vector-multiply! im2 rl1)       ; (* tempr1 tempi2)
  197           (float-vector-multiply! rl2 im1)       ; (* tempr2 tempi1)
  198           (float-vector-add! tmprl tmpim)        ; add the first two
  199           (float-vector-subtract! im2 rl2)       ; subtract the 4th from the 3rd
  200           (fft tmprl im2 -1)
  201           (float-vector-scale! tmprl fftscale)   ; scale by fftscale
  202           (graph tmprl "lag time" 0 fftlen)))))))))
  203 
  204 ;; (hook-push graph-hook display-correlation)
  205 
  206 
  207 ;;; -------- set transform-size based on current time domain window size
  208 ;;;
  209 ;;; also zoom spectrum based on y-axis zoom slider
  210 
  211 (define zoom-spectrum 
  212   (let ((+documentation+ "(zoom-spectrum hook) sets the transform size to correspond to the time-domain window size (use with graph-hook)"))
  213     (lambda (hook)
  214       (let ((snd (hook 'snd))
  215         (chn (hook 'chn)))
  216     (if (and (transform-graph? snd chn) 
  217          (= (transform-graph-type snd chn) graph-once))
  218         (begin
  219           (set! (transform-size snd chn)
  220             (expt 2 (ceiling (log (- (right-sample snd chn) (left-sample snd chn)) 2.0))))
  221           (set! (spectrum-end snd chn) (y-zoom-slider snd chn))))))))
  222 
  223 
  224                     ;(hook-push graph-hook zoom-spectrum)
  225 
  226 
  227 
  228 ;;; -------- superimpose spectra of sycn'd sounds
  229 
  230 (define superimpose-ffts 
  231   (let ((+documentation+ "(superimpose-ffts hook) superimposes ffts of multiple (syncd) sounds (use with graph-hook)"))
  232     (lambda (hook)
  233       (let ((maxsync (apply max (map sync (sounds))))
  234         (snd (hook 'snd))
  235         (chn (hook 'chn))
  236         (y0 (hook 'y0))
  237         (y1 (hook 'y1)))
  238     (if (and (> (sync snd) 0)
  239          (> (right-sample snd chn) (left-sample snd chn))
  240          (equal? snd (integer->sound (apply min (map (lambda (n) 
  241                                    (if (= (sync snd) (sync n))
  242                                    (sound->integer n)
  243                                    (+ 1 maxsync)))
  244                                  (sounds))))))
  245         (let* ((ls (left-sample snd chn))
  246            (pow2 (ceiling (log (max 1 (- (right-sample snd chn) ls)) 2)))
  247            (fftlen (floor (expt 2 pow2))))
  248           (if (> pow2 2)
  249           (let ((ffts ()))
  250             (for-each
  251              (lambda (n)
  252                (if (and (= (sync n) (sync snd))
  253                 (> (channels n) chn))
  254                (set! ffts (append ffts (let ((fdr (channel->float-vector ls fftlen n chn))
  255                              (fdi (make-float-vector fftlen))
  256                              (spectr (make-float-vector (/ fftlen 2))))
  257                              (list (float-vector-add! spectr (spectrum fdr fdi #f 2))))))))
  258              (sounds))
  259             (graph ffts "spectra" 0.0 0.5 y0 y1 snd chn)))))))))
  260 
  261 ;;(hook-push graph-hook superimpose-ffts)
  262 
  263 
  264 ;;; -------- translate mpeg input to 16-bit linear and read into Snd
  265 ;;;
  266 ;;; mpg123 with the -s switch sends the 16-bit (mono or stereo) representation of
  267 ;;;   an mpeg file to stdout.  There's also apparently a switch to write 'wave' output.
  268 
  269 (define mpg 
  270   (let ((+documentation+ "(mpg file tmpname) converts file from MPEG to raw 16-bit samples using mpg123"))
  271     (lambda (mpgfile rawfile)
  272       (let* ((fd (open-input-file mpgfile "r"))
  273          (b0 (read-byte fd))
  274          (b1 (read-byte fd))
  275          (b2 (read-byte fd))
  276          (b3 (read-byte fd)))
  277     (close-input-port fd)
  278     (if (not (and (= b0 255)
  279               (= (logand b1 #b11100000) #b11100000)))
  280         (snd-print (format #f "~S is not an MPEG file (first 11 bytes: #b~B #b~B)" mpgfile b0 (logand b1 #b11100000)))
  281         (let ((id (ash (logand b1 #b11000) -3))
  282           (layer (ash (logand b1 #b110) -1))
  283           ;; (protection (logand b1 1))
  284           ;; (bitrate-index (ash (logand b2 #b11110000) -4))
  285           (srate-index (ash (logand b2 #b1100) -2))
  286           ;; (padding (ash (logand b2 #b10) -1))
  287           (channel-mode (ash (logand b3 #b11000000) -6))
  288           ;; (mode-extension (ash (logand b3 #b110000) -4))
  289           ;; (copyright (ash (logand b3 #b1000) -3))
  290           ;; (original (ash (logand b3 #b100) -2))
  291           ;; (emphasis (logand b3 #b11))
  292           )
  293           (if (= id 1)
  294           (snd-print (format #f "odd: ~S is using a reserved Version ID" mpgfile)))
  295           (if (= layer 0)
  296           (snd-print (format #f "odd: ~S is using a reserved layer description" mpgfile)))
  297           (let ((chans (if (= channel-mode 3) 1 2))
  298             (mpeg-layer (case layer ((3) 1) ((2)) (else 3)))
  299             (srate (/ (#i(44100 48000 32000 0) srate-index)
  300                   (case id ((0) 4) ((2)) (else 1)))))
  301         (snd-print (format #f "~S: ~A Hz, ~A, MPEG-~A~%" 
  302                    mpgfile srate (if (= chans 1) "mono" "stereo") mpeg-layer))
  303         (system (format #f "mpg123 -s ~A > ~A" mpgfile rawfile))
  304         (open-raw-sound rawfile chans srate (if (little-endian?) mus-lshort mus-bshort)))))))))
  305 
  306 ;;; (mpg "mpeg.mpg" "mpeg.raw")
  307 
  308 
  309 ;;; -------- read and write OGG files
  310 
  311 (define read-ogg 
  312   (let ((+documentation+ "(read-ogg filename) tries to open an OGG file"))
  313     (lambda (filename)
  314       ;; check for "OggS" first word, if found, translate to something Snd can read
  315       ;; (open-sound (read-ogg "/home/bil/sf1/oboe.ogg"))
  316       (and (call-with-input-file filename 
  317          (lambda (fd)
  318            (string=? (read-string 4 fd) "OggS")))
  319        (let ((aufile (string-append filename ".au")))
  320          (if (file-exists? aufile) (delete-file aufile))
  321          (system (format #f "ogg123 -d au -f ~A ~A" aufile filename))
  322          aufile)))))
  323 
  324 #|  
  325 (hook-push open-hook
  326            (lambda (hook)
  327          (let ((filename (hook 'name)))
  328            (if (= (mus-sound-header-type filename) mus-raw)
  329            (read-ogg filename)))))
  330 ;; was returning #f?
  331 |#
  332 
  333 (define write-ogg 
  334   (let ((+documentation+ "(write-ogg snd) writes 'snd' in OGG format"))
  335     (lambda (snd)
  336       (if (or (> (car (edits snd)) 0)
  337           (not (= (header-type snd) mus-riff)))
  338       (let ((file (string-append (file-name snd) ".tmp")))
  339         (save-sound-as file snd :header-type mus-riff)
  340         (system (format #f "oggenc ~A" file))
  341         (delete-file file))
  342       (system (format #f "oggenc ~A" (file-name snd)))))))
  343 
  344 
  345 ;;; -------- read and write Speex files
  346 
  347 (define read-speex 
  348   (let ((+documentation+ "(read-speex filename) tries to open a SPEEX file"))
  349     (lambda (filename)
  350       (let ((wavfile (string-append filename ".wav")))
  351     (if (file-exists? wavfile) (delete-file wavfile))
  352     (system (format #f "speexdec ~A ~A" filename wavfile))
  353     wavfile))))
  354 
  355 (define write-speex 
  356   (let ((+documentation+ "(write-speex snd) writes 'snd' in Speex format"))
  357     (lambda (snd)
  358       ;; write snd data in Speex format
  359       (if (or (> (car (edits snd)) 0)
  360           (not (= (header-type snd) mus-riff)))
  361       (let ((file (string-append (file-name snd) ".wav"))
  362         (spxfile (string-append (file-name snd) ".spx")))
  363         (save-sound-as file snd :header-type mus-riff)
  364         (system (format #f "speexenc ~A ~A" file spxfile))
  365         (delete-file file))
  366       (system (format #f "speexenc ~A ~A.spx" (file-name snd) (file-name snd)))))))
  367 
  368 
  369 ;;; -------- read and write FLAC files
  370 
  371 (define read-flac 
  372   (let ((+documentation+ "(read-flac filename) tries to read a FLAC file"))
  373     (lambda (filename)
  374       (system (format #f "flac -d ~A" filename)))))
  375 
  376 (define write-flac 
  377   (let ((+documentation+ "(write-flac snd) writes 'snd' in a FLAC file"))
  378     (lambda (snd)
  379       ;; write snd data in FLAC format
  380       (if (or (> (car (edits snd)) 0)
  381           (not (= (header-type snd) mus-riff)))
  382       (let ((file (string-append (file-name snd) ".wav")))
  383         (save-sound-as file snd :header-type mus-riff)
  384         (system (format #f "flac ~A" file))
  385         (delete-file file))
  386       (system (format #f "flac ~A" (file-name snd)))))))
  387 
  388 
  389 ;;; -------- play AC3 via a52dec
  390 
  391 (define play-ac3 
  392   (let ((+documentation+ "(play-ac3 name) uses a52dec to play an AC3 sound"))
  393     (lambda (name)
  394       ;;   to turn an AC3 file into something Snd can edit, /usr/local/bin/a52dec test.ac3 -o wav > test.wav
  395       (system (format #f "a52dec ~A" name)))))
  396 
  397 
  398 ;;; -------- read ASCII files
  399 ;;;
  400 ;;; these are used by Octave (WaveLab) -- each line has one integer, apparently a signed short.
  401 
  402 (define read-ascii 
  403   (let ((+documentation+ "(read-ascii in-filename (out-filename \"test.snd\") (out-type mus-next) (out-format mus-bshort) (out-srate 44100)) tries to \
  404 read an ASCII sound file")
  405     (bufsize 8192)
  406     (bufsize1 8191))
  407     (lambda* (in-filename (out-filename "test.snd") (out-type mus-next) (out-format mus-bshort) (out-srate 44100))
  408       (let ((in-fd (open-input-file in-filename))
  409         (out-fd (new-sound out-filename 1 out-srate out-format out-type (format #f "created by read-ascii: ~A" in-filename))))
  410     (as-one-edit
  411      (lambda ()
  412        (do ((data (make-float-vector bufsize))
  413         (short->float (/ 1.0 32768.0))
  414         (fr 0 (+ fr bufsize)))
  415            ((eof-object? (peek-char in-fd)))
  416          (do ((loc 0 (+ loc 1))
  417           (val (read-line in-fd) (read-line in-fd)))
  418          ((or (eof-object? val)
  419               (= loc bufsize1)) ; bufsize-1 so that we don't throw away a sample at the buffer end
  420           (if (number? val)
  421               (begin
  422             (float-vector-set! data loc (* (string->number val) short->float))
  423             (float-vector->channel data fr (+ loc 1) out-fd 0))
  424               (float-vector->channel data fr loc out-fd 0)))
  425            (float-vector-set! data loc (* (string->number val) short->float))))))
  426     (close-input-port in-fd)
  427     out-fd))))
  428 
  429 
  430 
  431 ;;; -------- make dot size dependent on number of samples being displayed
  432 ;;; 
  433 ;;; this could be extended to set time-graph-style to graph-lines if many samples are displayed, etc
  434 
  435 (define auto-dot 
  436   (let ((+documentation+ "(auto-dot hook) sets the dot size depending on the number of samples being displayed (use with graph-hook)"))
  437     (lambda (hook)
  438       (let* ((snd (hook 'snd))
  439          (chn (hook 'chn))
  440          (dots (- (right-sample snd chn)
  441               (left-sample snd chn))))
  442     (set! (dot-size snd chn)
  443           (cond ((assoc dots '((100 . 1) (50 . 2) (25 . 3)) >) => cdr) 
  444             (else 5)))))))
  445 
  446 ;;; (hook-push graph-hook auto-dot)
  447 
  448 
  449 
  450 ;;; -------- move window left edge to mark upon 'm'
  451 ;;;
  452 ;;; in large sounds, it can be pain to get the left edge of the window
  453 ;;; aligned with a specific spot in the sound.  In this code, we assume
  454 ;;; the desired left edge has a mark, and the 'm' key (without control)
  455 ;;; will move the window left edge to that mark.
  456 
  457 (define first-mark-in-window-at-left
  458   (let ((+documentation+ "(first-mark-in-window-at-left) moves the graph so that the leftmost visible mark is at the left edge"))
  459     (lambda ()
  460       (let* ((keysnd (or (selected-sound) (car (sounds))))
  461          (keychn (or (selected-channel keysnd) 0))
  462          (chan-marks (marks keysnd keychn)))
  463     (letrec ((find-leftmost-mark (let ((current-left-sample (left-sample keysnd keychn)))
  464                        (lambda (samps)
  465                      (and (pair? samps)
  466                           (if (> (car samps) current-left-sample)
  467                           (car samps)
  468                           (find-leftmost-mark (cdr samps))))))))
  469       (if (null? chan-marks)
  470           (status-report "no marks!")
  471           (let ((leftmost (find-leftmost-mark (map mark-sample chan-marks))))
  472         (if (number? leftmost)
  473             (begin
  474               (set! (left-sample keysnd keychn) leftmost)
  475               keyboard-no-action)
  476             (status-report "no mark in window")))))))))
  477     
  478 ;; (bind-key #\m 0 (lambda () "align window left edge with mark" (first-mark-in-window-at-left)))
  479 
  480 
  481 ;;; -------- flash selected data red and green
  482 
  483 (define flash-selected-data
  484   (let ((data-red? #t)
  485     (red (make-color 1 0 0))
  486     (green (make-color 0 1 0))
  487     (+documentation+ "(flash-selected-data millisecs) causes the selected data to flash red and green"))
  488     (lambda (interval)
  489       (if (selected-sound)
  490       (begin
  491         (set! *selected-data-color* (if data-red? green red))
  492         (set! data-red? (not data-red?))
  493         (in interval (lambda () (flash-selected-data interval))))))))
  494 
  495 
  496 ;;; --------  use loop info (if any) to set marks at loop points
  497 
  498 (define mark-loops
  499   (let ((+documentation+ "(mark-loops) places marks at loop points found in the selected sound's header"))
  500     (lambda ()
  501       (let ((loops (or (sound-loop-info)
  502                (mus-sound-loop-info (file-name)))))
  503     (if (pair? loops)
  504         (if (not (= (car loops) 0 (cadr loops)))
  505         (begin
  506           (add-mark (car loops))
  507           (add-mark (cadr loops))
  508           (if (not (= (caddr loops) 0 (cadddr loops)))
  509               (begin
  510             (add-mark (caddr loops))
  511             (add-mark (cadddr loops))))))
  512         (snd-print (format #f "~S has no loop info" (short-file-name))))))))
  513 
  514 
  515 
  516 ;;; -------- mapping extensions (map arbitrary single-channel function over various channel collections)
  517 ;;;
  518 
  519 (define all-chans
  520   (let ((+documentation+ "(all-chans) -> two parallel lists, the first sound objects, the second channel numbers.  If we have 
  521 two 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))"))
  522     (lambda ()
  523       (let ((sndlist ())
  524         (chnlist ()))
  525     (for-each (lambda (snd)
  526             (do ((i (- (channels snd) 1) (- i 1)))
  527             ((< i 0))
  528               (set! sndlist (cons snd sndlist))
  529               (set! chnlist (cons i chnlist))))
  530           (sounds))
  531     (list sndlist chnlist)))))
  532 
  533 (define do-all-chans 
  534   (let ((+documentation+ "(do-all-chans func edhist) applies func to all active channels, using edhist as the edit history 
  535 indication: (do-all-chans (lambda (val) (* 2.0 val)) \"double all samples\")"))
  536     (lambda* (func origin)
  537       (apply for-each (lambda (snd chn)
  538             (map-channel func 0 #f snd chn #f origin))
  539          (all-chans)))))
  540 
  541 (define update-graphs
  542   (let ((+documentation+ "(update-graphs) updates (redraws) all graphs"))
  543     (lambda ()
  544       (apply for-each update-time-graph (all-chans)))))
  545 
  546 (define do-chans 
  547   (let ((+documentation+ "(do-chans func edhist) applies func to all sync'd channels using edhist as the edit history indication"))
  548     (lambda* (func origin)
  549       (let ((snc (sync)))
  550     (if (> snc 0)
  551         (apply for-each
  552            (lambda (snd chn)
  553              (if (= (sync snd) snc)
  554              (map-channel func 0 #f snd chn #f origin)))
  555            (all-chans))
  556         (snd-warning "sync not set"))))))
  557 
  558 (define do-sound-chans 
  559   (let ((+documentation+ "(do-sound-chans func edhist) applies func to all selected channels using edhist as the edit history indication"))
  560     (lambda* (proc origin)
  561       (let ((snd (selected-sound)))
  562     (if snd
  563         (do ((chn 0 (+ 1 chn)))
  564         ((= chn (channels snd)) #f)
  565           (map-channel proc 0 #f snd chn #f origin))
  566         (snd-warning "no selected sound"))))))
  567 
  568 (define every-sample? 
  569   (let ((+documentation+ "(every-sample func) -> #t if func is not #f for all samples in the current channel, 
  570 otherwise it moves the cursor to the first offending sample"))
  571     (lambda (proc)
  572       (let ((reader (make-sampler))
  573         (len (framples)))
  574     (call-with-exit
  575      (lambda (quit)
  576        (do ((i 0 (+ i 1)))
  577            ((= i len)) ; returns #t
  578          (if (not (proc (next-sample reader)))
  579          (begin
  580            (set! (cursor) i)
  581            (quit #f))))))))))
  582 
  583 (define sort-samples 
  584   (let ((+documentation+ "(sort-samples bins) provides a histogram in 'bins' bins"))
  585     (lambda (nbins)
  586       (let ((bins (make-vector nbins 0))
  587         (reader (make-sampler))
  588         (len (framples))
  589         (ops (make-vector nbins)))
  590     (do ((i 0 (+ i 1)))
  591         ((= i nbins))
  592       (set! (ops i) (make-one-pole 1.0 -1.0)))
  593     (do ((i 0 (+ i 1)))
  594         ((= i len))
  595       (one-pole (vector-ref ops (floor (* nbins (abs (next-sample reader))))) 1.0))
  596     (do ((i 0 (+ i 1)))
  597         ((= i nbins) bins)
  598       (set! (bins i) (floor (one-pole (ops i) 0.0))))))))
  599 
  600 
  601 ;;; -------- mix mono sound into stereo sound panning according to env
  602 
  603 (define place-sound 
  604   (let ((+documentation+ "(place-sound mono-snd stereo-snd pan-env) mixes a mono sound into a stereo sound, splitting 
  605 it into two copies whose amplitudes depend on the envelope 'pan-env'.  If 'pan-env' is 
  606 a number, the sound is split such that 0 is all in channel 0 and 90 is all in channel 1."))
  607     (lambda (mono-snd stereo-snd pan-env)
  608       (let ((len (framples mono-snd))
  609         (reader0 (make-sampler 0 mono-snd))
  610         (reader1 (make-sampler 0 mono-snd)))
  611     (if (number? pan-env)
  612         (let ((pos (/ pan-env 90.0)))
  613           (map-channel (lambda (y)
  614                  (+ y (* pos (read-sample reader1))))
  615                0 len stereo-snd 1)
  616           (map-channel (lambda (y)
  617                  (+ y (* (- 1.0 pos) (read-sample reader0))))
  618                0 len stereo-snd 0))
  619         (let ((e0 (make-env pan-env :length len))
  620           (e1 (make-env pan-env :length len)))
  621           (map-channel (lambda (y)
  622                  (+ y (* (env e1) (read-sample reader1))))
  623                0 len stereo-snd 1)
  624           (map-channel (lambda (y)
  625                  (+ y (* (- 1.0 (env e0)) (read-sample reader0))))
  626                0 len stereo-snd 0)))))))
  627 
  628 
  629 
  630 ;;; -------- FFT-based editing
  631 ;;;
  632 
  633 (define fft-edit 
  634   (let ((+documentation+ "(fft-edit low-Hz high-Hz snd chn) ffts an entire sound, removes all energy below low-Hz and all above high-Hz, 
  635 then inverse ffts."))
  636     (lambda* (bottom top snd chn)
  637       (let ((sr (srate snd))
  638         (len (framples snd chn)))
  639     (let ((fsize (expt 2 (ceiling (log len 2)))))
  640       (let ((fsize2 (/ fsize 2))
  641         (rdata (channel->float-vector 0 fsize snd chn))
  642         (idata (make-float-vector fsize)))
  643         (fft rdata idata 1)
  644         (let ((lo (round (/ (* bottom fsize) sr)))) 
  645           (if (> lo 0)
  646           (begin
  647             (fill! rdata 0.0 0 lo)
  648             (fill! idata 0.0 0 lo)
  649             (fill! rdata (- fsize lo) fsize)
  650             (fill! idata (- fsize lo) fsize))))
  651         (let ((hi (round (/ (* top fsize) sr))))
  652           (if (< hi fsize2)
  653           (begin 
  654             (fill! rdata 0.0 hi (- fsize hi))
  655             (fill! idata 0.0 hi (- fsize hi)))))
  656         (fft rdata idata -1)
  657         (float-vector-scale! rdata (/ 1.0 fsize))
  658         (float-vector->channel rdata 0 (- len 1) snd chn #f (format #f "fft-edit ~A ~A" bottom top))))))))
  659   
  660   
  661 (define fft-squelch 
  662   (let ((+documentation+ "(fft-squelch squelch snd chn) ffts an entire sound, sets all bins to 0.0 whose energy is below squelch, then inverse ffts"))
  663     (lambda* (squelch snd chn)
  664       (let* ((len (framples snd chn))
  665          (fsize (expt 2 (ceiling (log len 2)))))
  666     (let ((rdata (channel->float-vector 0 fsize snd chn))
  667           (idata (make-float-vector fsize))
  668           (scaler 1.0))
  669       (fft rdata idata 1)
  670       (let ((vr (copy rdata))
  671         (vi (copy idata)))
  672         (rectangular->polar vr vi)
  673         (set! scaler (float-vector-peak vr)))
  674       (let ((scl-squelch (* squelch scaler))
  675         (rd (copy rdata))
  676         (id (copy idata)))
  677         (float-vector-multiply! rd rd)
  678         (float-vector-multiply! id id)
  679         (float-vector-add! rd id)
  680         (do ((i 0 (+ i 1)))
  681         ((= i fsize))
  682           (if (< (sqrt (float-vector-ref rd i)) scl-squelch)
  683           (begin
  684             (set! (rdata i) 0.0)
  685             (set! (idata i) 0.0))))
  686         (fft rdata idata -1)
  687         (float-vector-scale! rdata (/ 1.0 fsize)))
  688       (float-vector->channel rdata 0 (- len 1) snd chn #f (format #f "fft-squelch ~A" squelch))
  689       scaler)))))
  690 
  691 
  692 (define fft-cancel 
  693   (let ((+documentation+ "(fft-cancel lo-freq hi-freq snd chn) ffts an entire sound, sets the bin(s) representing lo-freq to hi-freq to 0.0, then inverse ffts"))
  694     (lambda* (lo-freq hi-freq snd chn)
  695       (let* ((len (framples snd chn))
  696          (fsize (expt 2 (ceiling (log len 2)))))
  697     (let ((rdata (channel->float-vector 0 fsize snd chn))
  698           (idata (make-float-vector fsize)))
  699       (fft rdata idata 1)
  700       (let ((hz-bin (/ (srate snd) fsize)))
  701         (let ((lo-bin (round (/ lo-freq hz-bin)))
  702           (hi-bin (round (/ hi-freq hz-bin))))
  703           (fill! rdata 0.0 lo-bin hi-bin)
  704           (fill! idata 0.0 lo-bin hi-bin)
  705           (fill! rdata 0.0 (- fsize hi-bin) (- fsize lo-bin))))
  706       (fft rdata idata -1)
  707       (float-vector-scale! rdata (/ 1.0 fsize))
  708       (float-vector->channel rdata 0 (- len 1) snd chn #f (format #f "fft-cancel ~A ~A" lo-freq hi-freq)))))))
  709 
  710 
  711 ;;; same idea but used to distinguish vowels (steady-state) from consonants
  712 
  713 (define ramp 
  714   (let ((+documentation+ "(ramp gen up) is a kind of CLM generator that produces a ramp of a given length, then sticks at 0.0 or 1.0 until the 'up' argument changes"))
  715     (lambda (gen up)
  716       ;; gen is list: ctr size
  717       ;;  the idea here is that we want to ramp in or out a portion of a sound based on some
  718       ;;  factor of the sound data -- the ramp gen produces a ramp up when 'up' is #t, sticking
  719       ;;  at 1.0, and a ramp down when 'up' is #f, sticking at 0.0
  720       ;;
  721       ;; this could use the moving-average generator (or one-pole?)
  722       
  723       (let-set! gen 'up up)
  724       (with-let gen
  725     (set! val (min 1.0 (max 0.0 (+ val (if up incr (- incr))))))))))
  726 
  727 (define* (make-ramp (size 128))
  728   (inlet 'val 0.0 'incr (/ 1.0 size) 'up 1))
  729 
  730 ;;; (let ((r (make-ramp))) (map-channel (lambda (y) (* y (ramp r (> (random 1.0) 0.5))))))
  731 
  732 (define squelch-vowels 
  733   (let ((+documentation+ "(squelch-vowels snd chn) suppresses portions of a sound that look like steady-state"))
  734     (lambda* (snd chn)
  735       (let ((fft-size 32))
  736     (let ((rl (make-float-vector fft-size))
  737           (im (make-float-vector fft-size))
  738           (ramper (make-ramp 256)) ; 512 ok too
  739           (peak (/ (* 2 (maxamp)) fft-size))
  740           (read-ahead (make-sampler 0 snd chn))
  741           (ctr 0)
  742           (in-vowel #f))
  743       (do ((i 0 (+ i 1)))
  744           ((= i fft-size))
  745         (float-vector-set! rl i (read-sample read-ahead)))
  746       (set! ctr (- fft-size 1))
  747       (map-channel (lambda (y)
  748              (set! ctr (+ ctr 1))
  749              (if (= ctr fft-size)
  750                  (begin
  751                    (fft rl im 1)
  752                    (float-vector-multiply! rl rl)
  753                    (float-vector-multiply! im im)
  754                    (float-vector-add! rl im)
  755                    (set! in-vowel (> (+ (rl 0) (rl 1) (rl 2) (rl 3)) peak))
  756                    ;; fancier version checked here ratio of this sum and
  757                    ;;   sum of all rl vals, returned vowel if > 0.5
  758                    (set! ctr 0)
  759                    (do ((i 0 (+ i 1)))
  760                    ((= i fft-size))
  761                  (float-vector-set! rl i (read-sample read-ahead)))
  762                    (fill! im 0.0)))
  763              (* y (- 1.0 (ramp ramper in-vowel))))
  764                     ; squelch consonants if just ramp value (not 1.0-val)
  765                     ;(and (> rval 0.0) ; if this is included, the vowel-portions are omitted
  766                     ; squelch vowels 
  767                     ;(* y (+ (* 2 rval) .1)) ;accentuate consonants
  768                0 #f snd chn #f "squelch-vowels"))))))
  769 
  770 
  771 (define fft-env-data 
  772   (let ((+documentation+ "(fft-env-data fft-env snd chn) applies fft-env as spectral env to current sound, returning float-vector of new data"))
  773     (lambda* (fft-env snd chn)
  774       (let ((fsize (expt 2 (ceiling (log (framples snd chn) 2)))))
  775     (let ((rdata (channel->float-vector 0 fsize snd chn))
  776           (idata (make-float-vector fsize))
  777           (ve (make-float-vector fsize)))
  778       (fft rdata idata 1)
  779       (do ((e (make-env (concatenate-envelopes fft-env (reverse-envelope fft-env)) :length fsize))
  780            (i 0 (+ i 1)))
  781           ((= i fsize))
  782         (float-vector-set! ve i (env e)))
  783       (float-vector-multiply! rdata ve)
  784       (float-vector-multiply! idata ve)
  785       (fft rdata idata -1)
  786       (float-vector-scale! rdata (/ 1.0 fsize)))))))
  787 
  788 
  789 (define fft-env-edit 
  790   (let ((+documentation+ "(fft-env-edit fft-env snd chn) edits (filters) current chan using fft-env"))
  791     (lambda* (fft-env snd chn)
  792       (float-vector->channel (fft-env-data fft-env snd chn) 0 (- (framples) 1) snd chn #f (format #f "fft-env-edit '~A" fft-env)))))
  793 
  794 
  795 (define fft-env-interp 
  796   (let ((+documentation+ "(fft-env-interp env1 env2 interp snd chn) interpolates between two fft-filtered versions (env1 and env2 are the 
  797 spectral envelopes) following interp (an env between 0 and 1)"))
  798     (lambda* (env1 env2 interp snd chn)
  799       (let ((data1 (fft-env-data env1 snd chn))
  800          (data2 (fft-env-data env2 snd chn))
  801          (len (framples snd chn)))
  802     (let ((new-data (make-float-vector len))
  803           (e (make-env interp :length len))
  804           (erev (make-env (scale-envelope interp -1.0 1.0) :length len))) ; 1.0 - e
  805       (do ((i 0 (+ i 1)))
  806           ((= i len))
  807         (float-vector-set! new-data i
  808                    (+ (* (env erev) (float-vector-ref data1 i))
  809                   (* (env e) (float-vector-ref data2 i)))))
  810       (float-vector->channel new-data 0 (- len 1) snd chn #f (format #f "fft-env-interp '~A '~A '~A" env1 env2 interp)))))))
  811 
  812 
  813 (define filter-fft 
  814   (let ((+documentation+ "(filter-fft flt normalize snd chn) gets the spectrum of all the data in the given channel, \
  815 applies the function 'flt' to it, then inverse ffts.  'flt' should take one argument, the \
  816 current spectrum value.  (filter-fft (lambda (y) (if (< y .01) 0.0 y))) is like fft-squelch."))
  817     (lambda* (flt (normalize #t) snd chn)
  818       (let* ((len (framples snd chn))
  819          (fsize (expt 2 (ceiling (log len 2))))
  820          (fsize2 (/ fsize 2))
  821          (rdata (channel->float-vector 0 fsize snd chn)))
  822     (let ((mx (maxamp snd chn))
  823           (idata (make-float-vector fsize))
  824           (vf (make-float-vector fsize)))
  825       (let ((spect (snd-spectrum rdata rectangular-window fsize #t 1.0 #f normalize))) ; not in-place!
  826         (fft rdata idata 1)
  827         (flt (spect 0))
  828         (do ((i 1 (+ i 1))
  829          (j (- fsize 1) (- j 1)))
  830         ((= i fsize2))
  831           (float-vector-set! vf j (float-vector-set! vf i (/ (flt (spect i)) (max (spect i) 1e-5))))))
  832       (float-vector-multiply! rdata vf)
  833       (float-vector-multiply! idata vf)
  834       (fft rdata idata -1)
  835       (if (= mx 0.0)
  836           (float-vector->channel rdata 0 (- len 1) snd chn #f (format #f "filter-fft ~A" flt))
  837           (let ((pk (float-vector-peak rdata)))
  838         (float-vector->channel (float-vector-scale! rdata (/ mx pk)) 0 (- len 1) snd chn #f (format #f "filter-fft ~A" flt)))))))))
  839   
  840 
  841 ;; (let ((op (make-one-zero .5 .5))) (filter-fft op))
  842 ;; (let ((op (make-one-pole .05 .95))) (filter-fft op))
  843 ;; (filter-fft (lambda (y) (if (< y .1) 0.0 y)))
  844 ;; (let ((rd (make-sampler 0 0 0 1 0))) (scale-by 0) (filter-fft (lambda (y) (rd)))) ; treat original sound as spectrum
  845 ;; (filter-fft contrast-enhancement)
  846 ;; (filter-fft (lambda (y) (* y y y))) ; extreme low pass
  847 
  848 #|
  849 (let* ((ind (or (find-sound "now.snd")
  850         (open-sound "now.snd")))
  851        (mx (maxamp ind 0)))
  852   (do ((i 1 (+ i 1))
  853        (lo 0.0 (+ lo .1)))
  854       ((= i 8))
  855     (filter-fft (lambda (y) (contrast-enhancement y (+ 1.0 (* lo 30.0)))) #t ind 0))
  856   (let ((mixers (make-vector 8)))
  857     (do ((i 0 (+ i 1))
  858      (lo 0.001 (+ lo .12)))
  859     ((= i 8))
  860       (env-sound (list 0 0 lo 1 1 0) 0 #f 32.0 ind 0 (+ i 1))
  861       (set! (mixers i) (make-sampler 0 ind 0 1 (edit-position ind 0))))
  862     (scale-by 0.0)
  863     (map-channel
  864      (lambda (y)
  865        (let ((sum 0.0))
  866      (do ((i 0 (+ i 1)))
  867          ((= i 8) sum)
  868        (set! sum (+ sum (read-sample (mixers i)))))))))
  869   (scale-to mx))
  870 |#
  871 
  872 
  873 
  874 (define fft-smoother 
  875   (let ((+documentation+ "(fft-smoother cutoff start samps snd chn) uses fft-filtering to smooth a 
  876 section: (float-vector->channel (fft-smoother .1 (cursor) 400) (cursor) 400)"))
  877     (lambda* (cutoff start samps snd chn)
  878       (let ((fftpts (floor (expt 2 (ceiling (log (+ 1 samps) 2))))))
  879     (let ((rl (channel->float-vector start fftpts snd chn))
  880           (im (make-float-vector fftpts))
  881           (top (floor (* fftpts cutoff))))
  882       (let ((old0 (rl 0))
  883         (old1 (rl (- samps 1)))
  884         (oldmax (float-vector-peak rl)))
  885         (fft rl im 1)
  886         (do ((i top (+ i 1)))
  887         ((= i fftpts))
  888           (set! (rl i) 0.0)
  889           (set! (im i) 0.0))
  890         (fft rl im -1)
  891         (float-vector-scale! rl (/ 1.0 fftpts))
  892         (let ((newmax (float-vector-peak rl)))
  893           (if (= newmax 0.0)
  894           rl
  895           (begin
  896             (if (> (/ oldmax newmax) 1.5)
  897             (float-vector-scale! rl (/ oldmax newmax)))
  898             (let* ((new0 (rl 0))
  899                (new1 (rl (- samps 1)))
  900                (offset0 (- old0 new0)))
  901               (do ((incr (let ((offset1 (- old1 new1)))
  902                    (if (= offset1 offset0) 0.0 (/ (- offset1 offset0) samps))))
  903                (i 0 (+ i 1))
  904                (trend offset0))
  905               ((= i samps))
  906             (set! (rl i) (+ (rl i) trend))
  907             (set! trend (+ trend incr)))
  908               rl))))))))))
  909 
  910 
  911 
  912 ;;; -------- comb-filter
  913 
  914 (define comb-filter 
  915   (let ((+documentation+ "(comb-filter scaler size) returns a comb-filter ready for map-channel etc: (map-channel (comb-filter .8 32)).  If you're 
  916 in a hurry use: (clm-channel (make-comb .8 32)) instead"))
  917     (lambda (scaler size)
  918       (let ((cmb (make-comb scaler size)))
  919     (lambda (x) 
  920       (comb cmb x))))))
  921 
  922 
  923 ;;; by using filters at harmonically related sizes, we can get chords:
  924 
  925 (define comb-chord 
  926   (let ((+documentation+ "(comb-chord scaler size amp) returns a set of harmonically-related comb filters: (map-channel (comb-chord .95 100 .3))"))
  927     (lambda (scaler size amp)
  928       (let ((cs (make-comb-bank (vector (make-comb scaler (floor size))
  929                     (make-comb scaler (floor (* size .75)))
  930                     (make-comb scaler (floor (* size 1.2)))))))
  931     (lambda (x) 
  932       (* amp (comb-bank cs x)))))))
  933 
  934 
  935 ;;; or change the comb length via an envelope:
  936 
  937 (define zcomb 
  938   (letrec ((+documentation+ "(zcomb scaler size pm) returns a comb filter whose length varies according to an 
  939 envelope: (map-channel (zcomb .8 32 '(0 0 1 10)))")
  940        (max-envelope-1 
  941         (lambda (e mx)
  942           (if (null? e)
  943           mx
  944           (max-envelope-1 (cddr e) (max mx (abs (cadr e))))))))
  945     (lambda (scaler size pm)
  946       (let ((cmb (make-comb scaler size :max-size (floor (+ size 1 (max-envelope-1 pm 0.0)))))
  947         (penv (make-env pm :length (framples))))
  948     (lambda (x)
  949       (comb cmb x (env penv)))))))
  950 
  951 
  952 (define notch-filter 
  953   (let ((+documentation+ "(notch-filter scaler size) returns a notch-filter: (map-channel (notch-filter .8 32))"))
  954     (lambda (scaler size)
  955       (let ((cmb (make-notch scaler size)))
  956     (lambda (x) 
  957       (notch cmb x))))))
  958 
  959 
  960 (define formant-filter 
  961   (let ((+documentation+ "(formant-filter radius frequency) returns a formant generator: (map-channel (formant-filter .99 2400)). Faster 
  962 is: (filter-sound (make-formant 2400 .99))"))
  963     (lambda (radius frequency)
  964       (let ((frm (make-formant frequency radius)))
  965     (lambda (x) 
  966       (formant frm x))))))
  967 
  968 
  969 ;;; to impose several formants, just add them in parallel:
  970 
  971 (define formants 
  972   (let ((+documentation+ "(formants r1 f1 r2 f2 r3 f3) returns 3 formant filters in parallel: (map-channel (formants .99 900 .98 1800 .99 2700))"))
  973     (lambda (r1 f1 r2 f2 r3 f3)
  974       (let ((fr1 (make-formant f1 r1))
  975         (fr2 (make-formant f2 r2))
  976         (fr3 (make-formant f3 r3)))
  977     (lambda (x)
  978       (+ (formant fr1 x)
  979          (formant fr2 x)
  980          (formant fr3 x)))))))
  981 
  982 
  983 (define moving-formant 
  984   (let ((+documentation+ "(moving-formant radius move) returns a time-varying (in frequency) formant filter: (map-channel (moving-formant .99 '(0 1200 1 2400)))"))
  985     (lambda (radius move)
  986       (let ((frm (make-formant (cadr move) radius))
  987         (menv (make-env move :length (framples))))
  988     (lambda (x)
  989       (let ((val (formant frm x)))
  990         (mus-set-formant-frequency frm (env menv))
  991         val))))))
  992 
  993 
  994 (define osc-formants 
  995   (let ((+documentation+ "(osc-formants radius bases amounts freqs) set up any number of independently oscillating 
  996 formants, then calls map-channel: (osc-formants .99 (float-vector 400.0 800.0 1200.0) (float-vector 400.0 800.0 1200.0) (float-vector 4.0 2.0 3.0))"))
  997     (lambda (radius bases amounts freqs) ; changed to call map-channel itself, 21-Apr-05
  998       (let ((len (length bases)))
  999     (if (= len 3)
 1000         ;; this way is faster but verbose
 1001         (let ((fa1 (amounts 0))
 1002           (fa2 (amounts 1))
 1003           (fa3 (amounts 2))
 1004           (frq1 (bases 0))
 1005           (frq2 (bases 1))
 1006           (frq3 (bases 2))
 1007           (fr1 (make-formant (bases 0) radius))
 1008           (fr2 (make-formant (bases 1) radius))
 1009           (fr3 (make-formant (bases 2) radius))
 1010           (o1 (make-oscil (freqs 0)))
 1011           (o2 (make-oscil (freqs 1)))
 1012           (o3 (make-oscil (freqs 2))))
 1013           (map-channel
 1014            (lambda (y)
 1015          (+ (formant fr1 y (hz->radians (+ frq1 (* fa1 (oscil o1)))))
 1016             (formant fr2 y (hz->radians (+ frq2 (* fa2 (oscil o2)))))
 1017             (formant fr3 y (hz->radians (+ frq3 (* fa3 (oscil o3)))))))))
 1018         
 1019         (let ((frms (make-vector len))
 1020           (oscs (make-vector len))
 1021           (amps (make-float-vector len 1.0)))
 1022           (do ((i 0 (+ i 1)))
 1023           ((= i len))
 1024         (set! (frms i) (make-formant (bases i) radius))
 1025         (set! (oscs i) (make-oscil (freqs i))))
 1026           (let ((frms1 (make-formant-bank frms amps)))
 1027         (map-channel
 1028          (lambda (x)
 1029            (let ((val (formant-bank frms1 x)))
 1030              (do ((i 0 (+ i 1)))
 1031              ((= i len))
 1032                (mus-set-formant-frequency (vector-ref frms i)
 1033                           (+ (bases i)
 1034                              (* (amounts i) 
 1035                             (oscil (oscs i))))))
 1036              val))))))))))
 1037 
 1038 
 1039 
 1040 ;;; -------- echo
 1041 
 1042 (define echo 
 1043   (let ((+documentation+ "(echo scaler secs) returns an echo maker: (map-channel (echo .5 .5) 0 44100)"))
 1044     (lambda (scaler secs)
 1045       (let ((del (make-delay (round (* secs (srate))))))
 1046     (lambda (inval)
 1047       (+ inval (delay del (* scaler (+ (tap del) inval)))))))))
 1048 
 1049 
 1050 (define zecho 
 1051   (let ((+documentation+ "(zecho scaler secs freq amp) returns a modulated echo maker: (map-channel (zecho .5 .75 6 10.0) 0 65000)"))
 1052     (lambda (scaler secs frq amp)
 1053       (let ((os (make-oscil frq))
 1054         (del (let ((len (round (* secs (srate)))))
 1055            (make-delay len :max-size (floor (+ len amp 1))))))
 1056     (lambda (inval)
 1057       (+ inval 
 1058          (delay del 
 1059             (* scaler (+ (tap del) inval))
 1060             (* amp (oscil os)))))))))
 1061 
 1062 
 1063 (define flecho 
 1064   (let ((+documentation+ "(flecho scaler secs) returns a low-pass filtered echo maker: (map-channel (flecho .5 .9) 0 75000)"))
 1065     (lambda (scaler secs)
 1066       (let ((flt (make-fir-filter :order 4 :xcoeffs #r(.125 .25 .25 .125)))
 1067         (del (make-delay  (round (* secs (srate))))))
 1068     (lambda (inval)
 1069       (+ inval 
 1070          (delay del 
 1071             (fir-filter flt (* scaler (+ (tap del) inval))))))))))
 1072 
 1073 
 1074 ;;; -------- ring-mod and am
 1075 ;;;
 1076 ;;; CLM instrument is ring-modulate.ins
 1077 
 1078 (define ring-mod 
 1079   (let ((+documentation+ "(ring-mod freq gliss-env) returns a time-varying ring-modulation filter: (map-channel (ring-mod 10 (list 0 0 1 (hz->radians 100))))"))
 1080     (lambda (freq gliss-env)
 1081       (let ((os (make-oscil :frequency freq))
 1082         (genv (make-env gliss-env :length (framples))))
 1083     (lambda (inval)
 1084       (* (oscil os (env genv)) inval))))))
 1085 
 1086 
 1087 (define am 
 1088   (let ((+documentation+ "(am freq)returns an amplitude-modulator: (map-channel (am 440))"))
 1089     (lambda (freq)
 1090       (let ((os (make-oscil freq))) 
 1091     (lambda (inval) 
 1092       (amplitude-modulate 1.0 inval (oscil os)))))))
 1093 
 1094 
 1095 ;;; this taken from sox (vibro.c)
 1096 
 1097 (define vibro 
 1098   (let ((+documentation+ "(vibro speed depth) adds vibrato or tremolo"))
 1099     (lambda (speed depth)
 1100       (let ((sine (make-oscil speed))
 1101         (scl (* 0.5 depth)))
 1102     (let ((offset (- 1.0 scl)))
 1103       (lambda (y)
 1104         (* y (+ offset (* scl (oscil sine))))))))))
 1105 
 1106 
 1107 ;;; -------- hello-dentist
 1108 ;;;
 1109 ;;; CLM instrument version is in clm.html
 1110 
 1111 (define hello-dentist 
 1112   (let ((+documentation+ "(hello-dentist frq amp snd chn) varies the sampling rate randomly, making a voice sound quavery: (hello-dentist 40.0 .1)"))
 1113     (lambda* (frq amp snd chn)
 1114       (let ((rn (make-rand-interp :frequency frq :amplitude amp))
 1115         (len (framples))
 1116         (sr (make-src :srate 1.0 
 1117               :input (let ((rd (make-sampler 0 snd chn)))
 1118                    (lambda (dir) 
 1119                      (read-sample-with-direction rd dir))))))
 1120     (map-channel
 1121      (lambda (y)
 1122        (src sr (rand-interp rn)))
 1123      0 len snd chn #f (format #f "hello-dentist ~A ~A" frq amp))))))
 1124 
 1125 
 1126 ;;; a very similar function uses oscil instead of rand-interp, giving
 1127 ;;; various "Forbidden Planet" sound effects:
 1128 
 1129 (define fp 
 1130   (let ((+documentation+ "(fp sr osamp osfrq snd chn) varies the sampling rate via an oscil: (fp 1.0 .3 20)"))
 1131     (lambda* (sr osamp osfrq snd chn)
 1132       (let ((os (make-oscil osfrq))
 1133         (s (make-src :srate sr :input (let ((sf (make-sampler 0 snd chn)))
 1134                         (lambda (dir) 
 1135                           (read-sample-with-direction sf dir))))))
 1136     (map-channel
 1137      (lambda (y)
 1138        (src s (* osamp (oscil os))))
 1139      0 #f snd chn #f (format #f "fp ~A ~A ~A" sr osamp osfrq))))))
 1140 
 1141 
 1142 
 1143 ;;; -------- compand, compand-channel
 1144 
 1145 (define compand-table (float-vector -1.000 -0.960 -0.900 -0.820 -0.720 -0.600 -0.450 -0.250 
 1146                     0.000 0.250 0.450 0.600 0.720 0.820 0.900 0.960 1.000))
 1147 ;; (we're eye-balling the curve on p55 of Steiglitz's "a DSP Primer")
 1148 
 1149 (define compand
 1150   (let ((+documentation+ "(compand) returns a compander: (map-channel (compand))"))
 1151     (lambda ()
 1152       (lambda (inval)
 1153     (array-interp compand-table (+ 8.0 (* 8.0 inval)) 17)))))
 1154 
 1155 
 1156 ;;; -------- shift pitch keeping duration constant
 1157 ;;;
 1158 ;;; both src and granulate take a function argument to get input whenever it is needed.
 1159 ;;; in this case, src calls granulate which reads the currently selected file.
 1160 ;;; CLM version is in expsrc.ins
 1161 
 1162 (define expsrc 
 1163   (let ((+documentation+ "(expsrc rate snd chn) uses sampling-rate conversion and granular synthesis 
 1164 to produce a sound at a new pitch but at the original tempo.  It returns a function for map-channel."))
 1165     (lambda* (rate snd chn)
 1166       (let ((sr (make-src :srate rate
 1167               :input (let ((gr (make-granulate :expansion rate
 1168                                :input (make-sampler 0 snd chn))))
 1169                    (lambda (dir) 
 1170                      (granulate gr))))))
 1171     (lambda (inval)
 1172       (src sr 0.0))))))
 1173 
 1174 
 1175 ;;; the next (expsnd) changes the tempo according to an envelope; the new duration
 1176 ;;; will depend on the expansion envelope -- we integrate it to get
 1177 ;;; the overall expansion, then use that to decide the new length.
 1178 
 1179 (define expsnd 
 1180   (let ((+documentation+ "(expsnd gr-env snd chn) uses the granulate generator to change tempo according to an envelope: (expsnd '(0 .5 2 2.0))"))
 1181     (lambda* (gr-env snd chn)
 1182       (let* ((dur (/ (* (/ (framples snd chn) (srate snd)) 
 1183             (integrate-envelope gr-env)) ; in env.scm
 1184              (envelope-last-x gr-env)))
 1185          (len (max (round (* (srate snd) dur)) (framples snd chn))))
 1186     (do ((out-data (make-float-vector len))
 1187          (gr (make-granulate :expansion (cadr gr-env) 
 1188                  :jitter 0
 1189                  :input (make-sampler 0 snd chn)))
 1190          (ge (make-env gr-env :duration dur))
 1191          (i 0 (+ i 1)))
 1192         ((= i len)
 1193          (float-vector->channel out-data 0 len snd chn #f (format #f "expsnd '~A" gr-env)))
 1194       (float-vector-set! out-data i (granulate gr))
 1195       (set! (mus-increment gr) (env ge)))))))
 1196 
 1197 
 1198 ;;; -------- cross-synthesis
 1199 ;;;
 1200 ;;; CLM version is in clm.html
 1201 
 1202 (define cross-synthesis 
 1203   (let ((+documentation+ "(cross-synthesis cross-snd amp fftsize r) does cross-synthesis between 'cross-snd' (a sound object) and the currently 
 1204 selected sound: (map-channel (cross-synthesis (integer->sound 0) .5 128 6.0))"))
 1205     (lambda (cross-snd amp fftsize r)
 1206       (let ((freq-inc (/ fftsize 2)))
 1207     (let ((spectr (make-float-vector freq-inc))
 1208           (formants (make-vector freq-inc)))
 1209       (let-temporarily ((*clm-srate* (srate)))
 1210         ;; if mus-srate is 44.1k and srate is 48k, make-formant thinks we're trying to go past srate/2
 1211         ;;    and in any case it's setting its formants incorrectly for the actual output srate
 1212         (do ((radius (- 1.0 (/ r fftsize)))
 1213          (bin (/ (srate) fftsize))
 1214          (i 0 (+ i 1)))
 1215         ((= i freq-inc))
 1216           (set! (formants i) (make-formant (* i bin) radius)))
 1217         (set! formants (make-formant-bank formants spectr)))
 1218       (let ((fdr #f)
 1219         (ctr freq-inc)
 1220         (inctr 0))
 1221         (lambda (inval)
 1222           (if (= ctr freq-inc)
 1223           (let ((fdi (make-float-vector fftsize)))
 1224             (set! fdr (channel->float-vector inctr fftsize cross-snd 0))
 1225             (set! inctr (+ inctr freq-inc))
 1226             (spectrum fdr fdi #f 2)
 1227             (float-vector-subtract! fdr spectr)
 1228             (float-vector-scale! fdr (/ 1.0 freq-inc))
 1229             (set! ctr 0)))
 1230           (set! ctr (+ ctr 1))
 1231           (float-vector-add! spectr fdr)
 1232           (* amp (formant-bank formants inval)))))))))
 1233   
 1234   
 1235 ;;; similar ideas can be used for spectral cross-fades, etc -- for example:
 1236 
 1237 (define voiced->unvoiced 
 1238   (let ((+documentation+ "(voiced->unvoiced amp fftsize r tempo snd chn) turns a vocal sound into whispering: (voiced->unvoiced 1.0 256 2.0 2.0)"))
 1239     (lambda* (amp fftsize r tempo snd chn)
 1240       (let ((freq-inc (/ fftsize 2))
 1241         (len (framples snd chn)))
 1242     (let ((outlen (floor (/ len tempo)))
 1243           (fdr #f)
 1244           (fdi (make-float-vector fftsize))
 1245           (spectr (make-float-vector freq-inc))
 1246           (noi (make-rand (/ (srate snd) 3)))
 1247           (ctr 0)
 1248           (hop (floor (* freq-inc tempo)))
 1249           (formants (make-vector freq-inc))
 1250           (old-peak-amp 0.0))
 1251       (let ((out-data (make-float-vector (max len outlen))))
 1252         
 1253         (do ((bin (/ (srate snd) fftsize))
 1254          (radius (- 1.0 (/ r fftsize)))
 1255          
 1256          (i 0 (+ i 1)))
 1257         ((= i freq-inc))
 1258           (set! (formants i) (make-formant (* i bin) radius)))
 1259         (set! formants (make-formant-bank formants spectr))
 1260         
 1261         (do ((inctr 0)
 1262          (i 0 (+ i freq-inc)))
 1263         ((>= i outlen))
 1264           (set! ctr (min (- outlen i) freq-inc))
 1265           (if (odd? ctr) (set! ctr (- ctr 1)))
 1266           
 1267           (set! fdr (channel->float-vector inctr fftsize snd chn))
 1268           (set! old-peak-amp (max (float-vector-peak fdr) old-peak-amp))
 1269           (spectrum fdr fdi #f 2)
 1270           (float-vector-subtract! fdr spectr)
 1271           (float-vector-scale! fdr (/ 2.0 freq-inc))
 1272           (set! inctr (+ inctr hop))
 1273           
 1274           (do ((k 0 (+ k 2))
 1275            (j i (+ j 2)))
 1276           ((= k ctr))
 1277         (float-vector-add! spectr fdr)
 1278         (float-vector-set! out-data j (formant-bank formants (rand noi)))
 1279         (float-vector-set! out-data (+ j 1) (formant-bank formants (rand noi)))))
 1280       
 1281       (float-vector-scale! out-data (* amp (/ old-peak-amp (float-vector-peak out-data))))
 1282       (float-vector->channel out-data 0 (max len outlen) snd chn)))))))
 1283 
 1284 
 1285 ;;; very similar but use ncos (glottal pulse train?) instead of white noise
 1286 
 1287 (define pulse-voice 
 1288   (let ((+documentation+ "(pulse-voice cosines (freq 440) (amp 1.0) (fftsize 256) (r 2.0) snd chn) uses ncos to manipulate speech sounds"))
 1289     (lambda* (cosines (freq 440.0) (amp 1.0) (fftsize 256) (r 2.0) snd chn)
 1290       (let ((freq-inc (/ fftsize 2)))
 1291     (let ((spectr (make-float-vector freq-inc))
 1292           (formants (make-vector freq-inc))
 1293           (len (framples snd chn))) 
 1294 
 1295       (do ((radius (- 1.0 (/ r fftsize)))
 1296            (bin (/ (srate snd) fftsize))
 1297            (i 0 (+ i 1)))
 1298           ((= i freq-inc))
 1299         (set! (formants i) (make-formant (* i bin) radius)))
 1300       (set! formants (make-formant-bank formants spectr))
 1301       
 1302       (do ((old-peak-amp 0.0)
 1303            (pulse (make-ncos freq cosines)) 
 1304            (out-data (make-float-vector len)) 
 1305            (fdr #f)
 1306            (inctr 0)
 1307            (fdi (make-float-vector fftsize))
 1308            (ctr 0)
 1309            (i 0 (+ i freq-inc)))
 1310           ((>= i len)
 1311            (float-vector-scale! out-data (* amp (/ old-peak-amp (float-vector-peak out-data))))
 1312            (float-vector->channel out-data 0 len snd chn))
 1313         (set! ctr (min (- len i) freq-inc))
 1314         
 1315         (set! fdr (channel->float-vector inctr fftsize snd chn))
 1316         (set! old-peak-amp (max (float-vector-peak fdr) old-peak-amp))
 1317         (spectrum fdr fdi #f 2)
 1318         (float-vector-subtract! fdr spectr)
 1319         (float-vector-scale! fdr (/ 1.0 freq-inc))
 1320         (set! inctr (+ inctr freq-inc))
 1321         
 1322         (do ((k 0 (+ k 1))
 1323          (j i (+ j 1)))
 1324         ((= k ctr))
 1325           (float-vector-add! spectr fdr)
 1326           (float-vector-set! out-data j (formant-bank formants (ncos pulse))))))))))
 1327 
 1328 ;;; (pulse-voice 80 20.0 1.0 1024 0.01)
 1329 ;;; (pulse-voice 80 120.0 1.0 1024 0.2)
 1330 ;;; (pulse-voice 30 240.0 1.0 1024 0.1)
 1331 ;;; (pulse-voice 30 240.0 1.0 2048)
 1332 ;;; (pulse-voice 6 1000.0 1.0 512)
 1333 
 1334 
 1335 ;;; -------- convolution example
 1336 
 1337 (define cnvtest 
 1338   (let ((+documentation+ "(cnvtest snd0 snd1 amp) convolves snd0 and snd1, scaling by amp, returns new max amp: (cnvtest 0 1 .1)"))
 1339     (lambda (snd0 snd1 amp)
 1340       (let* ((flt-len (framples snd0))
 1341          (total-len (+ flt-len (framples snd1)))
 1342          (cnv (make-convolve :filter (channel->float-vector 0 flt-len snd0)
 1343                  :input (make-sampler 0 snd1)))
 1344          (out-data (make-float-vector total-len)))
 1345     (do ((i 0 (+ i 1)))
 1346         ((= i total-len))
 1347       (float-vector-set! out-data i (convolve cnv)))
 1348     (float-vector-scale! out-data amp)
 1349     (let ((max-samp (float-vector-peak out-data)))
 1350       (float-vector->channel out-data 0 total-len snd1)
 1351       (if (> max-samp 1.0) (set! (y-bounds snd1) (list (- max-samp) max-samp)))
 1352       max-samp)))))
 1353 
 1354 
 1355 
 1356 ;;; -------- locate-zero (Anders Vinjar)
 1357 
 1358 (define locate-zero 
 1359   (let ((+documentation+ "(locate-zero limit) looks for successive samples that sum to less than 'limit', moving the cursor if successful"))
 1360     (lambda (limit)
 1361       (let* ((start (cursor))
 1362          (sf (make-sampler start)))
 1363     (do ((n start (+ 1 n))
 1364          (val0 (abs (next-sample sf)))
 1365          (val1 (abs (next-sample sf)) (abs (next-sample sf))))
 1366         ((or (sampler-at-end? sf)
 1367          (< (+ val0 val1) limit))
 1368          (set! (cursor) n))
 1369       (set! val0 val1))))))
 1370 
 1371 
 1372 ;;; -------- sound interp
 1373 ;;;
 1374 ;;; make-sound-interp sets up a sound reader that reads a channel at an arbitary location,
 1375 ;;;   interpolating between samples if necessary, the corresponding "generator" is sound-interp
 1376 
 1377 (define make-sound-interp 
 1378   (let ((+documentation+ "(make-sound-interp start snd chn) -> an interpolating reader for snd's channel chn"))
 1379     (lambda* (start snd chn)
 1380       (let* ((data (channel->float-vector start #f snd chn))
 1381          (size (length data)))
 1382     (lambda (loc)
 1383       (array-interp data loc size))))))
 1384 
 1385 (define sound-interp 
 1386   (let ((+documentation+ "(sound-interp func loc) -> sample at loc (interpolated if necessary) from func created by make-sound-interp"))
 1387     (lambda (func loc) ;make it look like a clm generator
 1388       (func loc))))
 1389 
 1390 #|
 1391 (define test-interp
 1392   (lambda (freq)
 1393     ;; use a sine wave to lookup the current sound
 1394     (let ((osc (make-oscil :frequency freq :initial-phase (+ pi (/ pi 2))))
 1395       (reader (make-sound-interp 0 0 0)) 
 1396       (len (- (framples 0 0) 1)))
 1397       (map-channel (lambda (val) 
 1398              (sound-interp reader (* len (+ 0.5 (* 0.5 (oscil osc))))))))))
 1399 
 1400 ;;; (test-interp 0.5)
 1401 
 1402 ;;; our FM index is len * 0.5 * (hz->radians freq)
 1403 
 1404 (define (sound-via-sound snd1 snd2) ; "sound composition"??
 1405   (let* ((intrp (make-sound-interp 0 snd1 0))
 1406      (len (- (framples snd1 0) 1))
 1407      (rd (make-sampler 0 snd2 0))
 1408      (mx (maxamp snd2 0)))
 1409     (map-channel (lambda (val) 
 1410            (sound-interp intrp (floor (* len (* 0.5 (+ 1.0 (/ (read-sample rd) mx))))))))))
 1411 |#
 1412 
 1413 
 1414 ;; env-sound-interp takes an envelope that goes between 0 and 1 (y-axis), and a time-scaler
 1415 ;;   (1.0 = original length) and returns a new version of the data in the specified channel
 1416 ;;   that follows that envelope (that is, when the envelope is 0 we get sample 0, when the
 1417 ;;   envelope is 1 we get the last sample, envelope = .5 we get the middle sample of the 
 1418 ;;   sound and so on. (env-sound-interp '(0 0 1 1)) will return a copy of the
 1419 ;;   current sound; (env-sound-interp '(0 0 1 1 2 0) 2.0) will return a new sound 
 1420 ;;   with the sound copied first in normal order, then reversed.  src-sound with an
 1421 ;;   envelope could be used for this effect, but it is much more direct to apply the
 1422 ;;   envelope to sound sample positions.
 1423 
 1424 (define env-sound-interp 
 1425   (let ((+documentation+ "(env-sound-interp env (time-scale 1.0) snd chn) reads snd's channel chn according to env and time-scale"))
 1426     (lambda* (envelope (time-scale 1.0) snd chn)
 1427       ;; since the old/new sounds can be any length, we'll write a temp file rather than trying to use map-channel
 1428       
 1429       (let* ((len (framples snd chn))
 1430          (newlen (floor (* time-scale len)))
 1431          (new-snd (with-sound ((snd-tempnam) :to-snd #f :srate (srate snd))
 1432              (let ((data (channel->float-vector 0 #f snd chn))
 1433                    (read-env (make-env envelope :length (+ 1 newlen) :scaler len)))
 1434                (do ((i 0 (+ i 1)))
 1435                    ((= i newlen))
 1436                  (outa i (array-interp data (env read-env) len)))))))
 1437     (set-samples 0 newlen new-snd snd chn #t
 1438              (format #f "env-sound-interp '~A ~A" envelope time-scale)
 1439              0 current-edit-position #t)))))
 1440 
 1441 
 1442 ;;; (env-sound-interp '(0 0 1 1 2 0) 2.0)
 1443 
 1444 
 1445 
 1446 ;;; here's a very similar function that uses granular synthesis to move at a varying tempo through a sound
 1447 
 1448 (define granulated-sound-interp 
 1449   
 1450   (let ((+documentation+ "(granulated-sound-interp envelope (time-scale 1.0) (grain-length 0.10) (grain-envelope '(0 0 1 1 2 1 3 0)) (output-hop 0.05) snd chn) reads \
 1451 the given channel following 'envelope' (as in env-sound-interp), using grains to create the re-tempo'd read"))
 1452     (lambda* (envelope (time-scale 1.0) (grain-length 0.10) (grain-envelope '(0 0 1 1 2 1 3 0)) (output-hop 0.05) snd chn)
 1453       
 1454       (let* ((len (framples snd chn))
 1455          (newlen (floor (* time-scale len))))
 1456     (let ((read-env (make-env envelope :length newlen :scaler len))
 1457           (grain-frames (round (* grain-length (srate snd))))
 1458           (hop-frames (round (* output-hop (srate snd))))
 1459           (num-readers (ceiling (/ grain-length output-hop)))
 1460           (cur-readers 0)
 1461           (next-reader 0)
 1462           (jitter (* (srate snd) .005)))
 1463       
 1464       (let ((readers (make-vector num-readers #f))
 1465         (grain-envs (make-vector num-readers #f)))
 1466         (do ((i 0 (+ i 1)))
 1467         ((= i num-readers))
 1468           (set! (grain-envs i) (make-env grain-envelope :length grain-frames)))
 1469         
 1470         (let ((new-snd (with-sound ((snd-tempnam) :to-snd #f :srate (srate snd))
 1471                  
 1472                  (do ((i 0 (+ i hop-frames)))
 1473                  ((>= i newlen))
 1474                    (let ((start i)
 1475                      (stop (min newlen (+ i hop-frames))))
 1476                  (set! (mus-location read-env) i)
 1477                  (let ((position-in-original (env read-env)))
 1478                    (set! (readers next-reader)
 1479                      (make-sampler (max 0 (round (+ position-in-original (mus-random jitter)))) snd chn)))
 1480                  (mus-reset (grain-envs next-reader)) ; restart grain env
 1481                  (set! next-reader (modulo (+ next-reader 1) num-readers))
 1482                  (set! cur-readers (max cur-readers next-reader))
 1483                  
 1484                  (do ((e #f)
 1485                       (r #t)
 1486                       (k 0 (+ k 1)))
 1487                      ((= k cur-readers))
 1488                    (set! e (grain-envs k))
 1489                    (set! r (readers k))
 1490                    (do ((j start (+ j 1)))
 1491                        ((= j stop))
 1492                      (outa j (* (env e) (next-sample r))))))))))
 1493           
 1494           (set-samples 0 newlen new-snd snd chn #t
 1495                (format #f "granulated-sound-interp '~A ~A ~A ~A ~A" envelope time-scale grain-length grain-envelope output-hop)
 1496                0 current-edit-position #t))))))))
 1497 
 1498 ;;; (granulated-sound-interp '(0 0 1 .1 2 1) 1.0 0.2 '(0 0 1 1 2 0))
 1499 ;;; (granulated-sound-interp '(0 0 1 1) 2.0)
 1500 ;;; (granulated-sound-interp '(0 0 1 .1 2 1) 1.0 0.2 '(0 0 1 1 2 0) 0.02)
 1501 
 1502 
 1503 
 1504 ;;; -------- filtered-env 
 1505 
 1506 (define filtered-env 
 1507   (let ((+documentation+ "(filtered-env env snd chn) is a time-varying one-pole filter: when env is at 1.0, no filtering, 
 1508 as env moves to 0.0, low-pass gets more intense; amplitude and low-pass amount move together"))
 1509     (lambda* (e snd chn)
 1510       (let ((flt (make-one-pole 1.0 0.0)))
 1511     (let ((xc (mus-xcoeffs flt))
 1512           (yc (mus-ycoeffs flt))
 1513           (amp-env (make-env e :length (framples))))
 1514       (map-channel
 1515        (lambda (val)
 1516          (let ((env-val (env amp-env)))
 1517            (float-vector-set! xc 0 env-val)
 1518            (float-vector-set! yc 1 (- env-val 1.0))
 1519            (one-pole flt (* env-val val))))
 1520        0 #f snd chn #f (format #f "filtered-env '~A" e)))))))
 1521 
 1522 
 1523 
 1524 ;;; -------- multi-colored rxvt printout
 1525 ;;;
 1526 ;;; if you're using display to write to rxvt, you can use the latter's escape sequences
 1527 ;;;   for things like multi-colored text:
 1528 
 1529 #|
 1530 (define red-text (format #f "~C[31m" #\escape))
 1531 (define normal-text (format #f "~C[0m" #\escape))
 1532 
 1533 ;;; there are a bunch of these:
 1534 
 1535 (define black-on-red-text (format #f "~C[30m~C[41m" #\escape #\escape))
 1536 
 1537 ;;; or perhaps more convenient:
 1538 
 1539 (define black-fg (format #f "~C[30m" #\escape))  (define black-bg (format #f "~C[40m" #\escape))
 1540 (define red-fg (format #f "~C[31m" #\escape))    (define red-bg (format #f "~C[41m" #\escape))
 1541 (define green-fg (format #f "~C[32m" #\escape))  (define green-bg (format #f "~C[42m" #\escape))
 1542 (define yellow-fg (format #f "~C[33m" #\escape)) (define yellow-bg (format #f "~C[43m" #\escape))
 1543 (define blue-fg (format #f "~C[34m" #\escape))   (define blue-bg (format #f "~C[44m" #\escape))
 1544 ;;; etc (magenta: 35 cyan: 36 white: 37 default: 39)
 1545 
 1546 (define bold-text (format #f "~C[1m" #\escape))       (define unbold-text (format #f "~C[22m" #\escape))  
 1547 (define underline-text (format #f "~C[4m" #\escape))  (define ununderline-text (format #f "~C[24m" #\escape))  
 1548 (define blink-text (format #f "~C[5m" #\escape))      (define unblink-text (format #f "~C[25m" #\escape))  
 1549 |#
 1550 
 1551 
 1552 ;;; -------- remove-clicks 
 1553 
 1554 (define find-click 
 1555   (let ((+documentation+ "(find-click loc) finds the next click starting at 'loc'"))
 1556     (lambda (loc)
 1557       (let ((reader (make-sampler loc))
 1558         (mmax (make-moving-max 10))
 1559         (samp0 0.0)
 1560         (samp1 0.0)
 1561         (samp2 0.0)
 1562         (len (framples))
 1563         (local-max 0.0))
 1564     (call-with-exit
 1565      (lambda (return)
 1566        (do ((ctr loc (+ ctr 1)))
 1567            ((= ctr len) #f)
 1568          (set! samp0 samp1)
 1569          (set! samp1 samp2)
 1570          (set! samp2 (next-sample reader))
 1571          (set! local-max (max .1 (moving-max mmax samp0)))
 1572          (if (and (> (abs (- samp0 samp1)) local-max)
 1573               (> (abs (- samp1 samp2)) local-max)
 1574               (< (abs (- samp0 samp2)) (/ local-max 2)))
 1575          (return (- ctr 1))))))))))
 1576 
 1577 (define remove-clicks
 1578   (let ((+documentation+ "(remove-clicks) tries to find and smooth-over clicks"))
 1579     (lambda ()
 1580       ;; this is very conservative -- the click detection limits above could be set much tighter in many cases
 1581       (let remove-click ((loc 0))
 1582         (let ((click (find-click loc)))
 1583           (if click
 1584               (begin
 1585                 (smooth-sound (- click 2) 4)
 1586                 (remove-click (+ click 2)))))))))
 1587 
 1588 
 1589 ;;; -------- searching examples (zero+, next-peak)
 1590 
 1591 (define search-for-click
 1592   (let ((+documentation+ "(search-for-click) looks for the next click (use with C-s)"))
 1593     (lambda ()
 1594       (let ((samp0 0.0)
 1595         (samp1 0.0)
 1596         (samp2 0.0)
 1597         (mmax (make-moving-max 10))
 1598         (local-max 0.0))
 1599     (lambda (val)
 1600       (set! samp0 samp1)
 1601       (set! samp1 samp2)
 1602       (set! samp2 val)
 1603       (set! local-max (max .1 (moving-max mmax samp0)))
 1604       (and (>= (abs (- samp0 samp1)) local-max)
 1605            (>= (abs (- samp1 samp2)) local-max)
 1606            (<= (abs (- samp0 samp2)) (/ local-max 2))))))))
 1607 
 1608 
 1609 (define zero+
 1610   (let ((+documentation+ "(zero+) finds the next positive-going zero crossing (if searching forward) (for use with C-s)"))
 1611     (lambda ()
 1612       (let ((lastn 0.0))
 1613     (lambda (n)
 1614       (let ((rtn (and (< lastn 0.0)
 1615               (>= n 0.0))))
 1616         (set! lastn n)
 1617         rtn))))))
 1618 
 1619 
 1620 (define next-peak
 1621   (let ((+documentation+ "(next-peak) finds the next max or min point in the time-domain waveform (for use with C-s)"))
 1622     (lambda ()
 1623       (let ((last0 #f)
 1624         (last1 #f))
 1625     (lambda (n)
 1626       (let ((rtn (and (number? last0)
 1627               (or (and (< last0 last1) (> last1 n))
 1628                   (and (> last0 last1) (< last1 n))))))
 1629         (set! last0 last1)
 1630         (set! last1 n)
 1631         rtn))))))
 1632 
 1633 
 1634 (define find-pitch 
 1635   (let ((+documentation+ "(find-pitch pitch) finds the point in the current sound where 'pitch' (in Hz) predominates -- C-s (find-pitch 300) 
 1636 In most cases, this will be slightly offset from the true beginning of the note")
 1637 
 1638     (interpolated-peak-offset 
 1639      (lambda (la pk ra)
 1640        (let ((logla (log (/ (max la .0000001) pk) 10))
 1641          (logra (log (/ (max ra .0000001) pk) 10)))
 1642          (/ (* 0.5 (- logla logra))
 1643         (+ logla logra))))))
 1644       
 1645     (lambda (pitch)
 1646       (let ((data (make-float-vector *transform-size*))
 1647         (data-loc 0))
 1648     (lambda (n)
 1649       (set! (data data-loc) n)
 1650       (set! data-loc (+ data-loc 1))
 1651       (let ((rtn #f))
 1652         (if (= data-loc *transform-size*)
 1653         (begin
 1654           (set! data-loc 0)
 1655           (if (> (float-vector-peak data) .001) ;ignore noise sections??
 1656               (let ((spectr (snd-spectrum data rectangular-window *transform-size*))
 1657                 (pk 0.0)
 1658                 (pkloc 0))
 1659             (let ((pit 
 1660                    (do ((i 0 (+ i 1)))
 1661                    ((= i (/ *transform-size* 2)) 
 1662                     (if (or (= pk 0.0)
 1663                         (= pkloc 0))
 1664                     0.0
 1665                     (/ (* (+ pkloc
 1666                          (interpolated-peak-offset (spectr (- pkloc 1))
 1667                                        pk
 1668                                        (spectr (+ 1 pkloc))))
 1669                           (srate))
 1670                        *transform-size*)))
 1671                  (if (> (spectr i) pk)
 1672                      (begin
 1673                        (set! pk (spectr i))
 1674                        (set! pkloc i))))))
 1675               (if (< (abs (- pitch pit)) (/ (srate) 2 *transform-size*)) ; uh... why not do it direct?
 1676                   (set! rtn #t)))))
 1677           (fill! data 0.0)))
 1678         rtn))))))
 1679 
 1680 
 1681 ;;; -------- file->floats and a sort of cue-list, I think
 1682 
 1683 (define (file->floats file) (samples 0 (framples file) file))
 1684 
 1685 
 1686 (define add-notes 
 1687   (let ((+documentation+ "(add-notes notes snd chn) adds (mixes) 'notes' which is a list of lists of the form: file (offset 0.0) (amp 1.0) 
 1688 starting at the cursor in the currently selected channel: (add-notes '((\"oboe.snd\") (\"pistol.snd\" 1.0 2.0)))"))
 1689     (lambda* (notes snd chn)
 1690       (let ((start (cursor snd chn)))
 1691     (as-one-edit
 1692      (lambda ()
 1693        (for-each 
 1694         (lambda (note)
 1695           (let ((file (car note))
 1696             (amp (and (> (length note) 2) (caddr note)))
 1697             (beg (+ start (floor (* (srate snd) 
 1698                          (if (> (length note) 1) 
 1699                          (cadr note)
 1700                          0.0))))))    
 1701         (if (and (number? amp)
 1702              (not (= amp 1.0)))
 1703             (mix-float-vector (float-vector-scale! (file->floats file) amp) beg snd chn #f "add-notes")
 1704             (mix file beg 0 snd chn #f))))
 1705         notes))
 1706      (format #f "add-notes '~S" notes))))))
 1707 
 1708 
 1709 (define region-play-list 
 1710   (let ((+documentation+ "(region-play-list data): 'data' is list of lists (list (list reg time)...), time in secs, setting up 
 1711 a sort of play list: (region-play-list (list (list reg0 0.0) (list reg1 0.5) (list reg2 1.0) (list reg0 1.0)))"))
 1712     (lambda (data)
 1713       (for-each
 1714        (lambda (tone)
 1715      (let ((time (floor (* 1000 (cadr tone))))
 1716            (region (car tone)))
 1717        (if (region? region)
 1718            (in time (lambda () (play region))))))
 1719        data))))
 1720 
 1721 
 1722 (define region-play-sequence 
 1723   (let ((+documentation+ "(region-play-sequence data): 'data' is list of regions which will be played one after the other: (region-play-sequence (list reg0 reg2 reg1))"))
 1724     (lambda (data)
 1725       (let ((time 0.0))
 1726     (region-play-list
 1727      (map 
 1728       (lambda (id)
 1729         (let ((cur time))
 1730           (set! time (+ time (/ (framples id) (srate id))))
 1731           (list cur id)))
 1732       data))))))
 1733 
 1734 
 1735 ;;; -------- explode-sf2
 1736 
 1737 (define explode-sf2
 1738   (let ((+documentation+ "(explode-sf2) turns the currently selected soundfont file into a bunch of files of the form sample-name.aif"))
 1739     (lambda ()
 1740       (let sf2it ((lst (soundfont-info)))
 1741     (if (pair? lst)
 1742         (let* ((vals (car lst))
 1743            (start (cadr vals)))
 1744           (let ((end (if (null? (cdr lst))
 1745                  (framples)
 1746                  (cadadr lst)))
 1747             (loop-start (- (caddr vals) start))
 1748             (loop-end (- (cadddr vals) start))
 1749             (filename (string-append (car vals) ".aif")))
 1750         (if (selection?)
 1751             (set! (selection-member? #t) #f))
 1752         (set! (selection-member?) #t)
 1753         (set! (selection-position) start)
 1754         (set! (selection-framples) (- end start))
 1755         (save-selection filename (selection-srate) mus-bshort mus-aifc)
 1756         (let ((temp (open-sound filename)))
 1757           (set! (sound-loop-info temp) (list loop-start loop-end))
 1758           (close-sound temp))
 1759         (sf2it (cdr lst)))))))))
 1760 
 1761 
 1762 ;;; -------- open-next-file-in-directory
 1763 
 1764 (define open-next-file-in-directory
 1765   (let ((last-file-opened #f)
 1766     (current-directory #f)
 1767     (current-sorted-files #f)
 1768     (directory-from-path (lambda (curfile)
 1769                    (do ((last-slash 0)
 1770                     (i 0 (+ 1 i)))
 1771                    ((= i (length curfile))
 1772                     (substring curfile 0 last-slash))   
 1773                  (if (char=? (curfile i) #\/)
 1774                      (set! last-slash i))))))
 1775 
 1776     (define find-next-file
 1777       (let ((file-from-path (lambda (curfile)
 1778                   (do ((last-slash 0)
 1779                    (i 0 (+ 1 i)))
 1780                   ((= i (length curfile))
 1781                    (substring curfile (+ 1 last-slash)))   
 1782                 (if (char=? (curfile i) #\/)
 1783                     (set! last-slash i))))))
 1784     (lambda ()
 1785       ;; find the next file in the sorted list, with wrap-around
 1786       (let ((choose-next (not (string? last-file-opened)))
 1787         (just-filename (file-from-path last-file-opened)))
 1788         (call-with-exit
 1789          (lambda (return)
 1790            (for-each
 1791         (lambda (file)
 1792           (if choose-next
 1793               (return file)
 1794               (if (string=? file just-filename)
 1795               (set! choose-next #t))))
 1796         current-sorted-files)
 1797            ;; if we get here we wrapped around
 1798            (car current-sorted-files)))))))
 1799     
 1800     (define (get-current-files dir)
 1801       (set! current-directory dir)
 1802       (set! current-sorted-files (sort! (copy (sound-files-in-directory dir)) string<?)))
 1803     
 1804     (define (get-current-directory filename)
 1805       (set! last-file-opened filename)
 1806       (display last-file-opened)
 1807       (let ((new-path (directory-from-path (file-name filename))))
 1808     (if (not (equal? current-directory new-path))
 1809         (get-current-files new-path)))
 1810       #f)
 1811     
 1812     (lambda ()
 1813       (if (not (member get-current-files (hook-functions open-hook)))
 1814       (hook-push open-hook (lambda (hook) (get-current-directory (hook 'name)))))
 1815       (if (and (not (string? last-file-opened))
 1816            (pair? (sounds)))
 1817       (set! last-file-opened (file-name (or (selected-sound)
 1818                         (car (sounds))))))
 1819       (if (not current-directory)
 1820       (get-current-files 
 1821        (if (null? (sounds))
 1822            (getcwd)
 1823            (directory-from-path last-file-opened))))
 1824 
 1825       (if (null? current-sorted-files)
 1826       (error 'no-such-file (list "open-next-file-in-directory" current-directory))
 1827       (let ((next-file (find-next-file)))
 1828         (if (find-sound next-file)
 1829         (error 'file-already-open (list "open-next-file-in-directory" next-file))
 1830         (begin
 1831           (if (pair? (sounds))
 1832               (close-sound (or (selected-sound)
 1833                        (car (sounds)))))
 1834           (open-sound next-file)))))
 1835       #t)))
 1836 
 1837 
 1838 (define click-middle-button-to-open-next-file-in-directory
 1839   (let ((+documentation+ "(click-middle-button-to-open-next-file-in-directory) adds open-next-file-in-directory to the mouse-click-hook"))
 1840     (lambda ()
 1841       (hook-push mouse-click-hook
 1842          (lambda (hook)
 1843            (if (= (hook 'button) 2)
 1844                (set! (hook 'result) (open-next-file-in-directory))))))))
 1845 
 1846 
 1847 ;;; -------- chain-dsps
 1848 
 1849 (define chain-dsps 
 1850   (let ((+documentation+ "(chain-dsps beg dur :rest dsps) sets up a generator patch from its arguments"))
 1851     (lambda* (beg dur :rest dsps)
 1852       
 1853       ;; assume the dsps are already made, 
 1854       ;;        the envs are present as break-point lists
 1855       ;;        the calls are ordered out->in (or last first)
 1856       ;; we take this list and create and evaluate a new function
 1857       
 1858       (let ((dsp-chain (reverse (apply vector (map (lambda (gen)
 1859                              (if (pair? gen)
 1860                              (make-env gen :duration dur)
 1861                              gen))
 1862                            dsps))))
 1863         (start (seconds->samples beg))
 1864         (samps (seconds->samples dur))
 1865         (body 0.0)
 1866         (closure ()))
 1867     (let ((end (+ start samps))
 1868           (len (length dsp-chain)))
 1869       
 1870       ;; create the let variable list and lambda body of our new function
 1871       (do ((i 0 (+ i 1)))
 1872           ((= i len))
 1873         (let ((g (dsp-chain i))
 1874           (gname (string->symbol (format #f "g~D" i))))
 1875           (set! closure (cons (list gname (list 'dsp-chain i)) closure))
 1876           (set! body (cond ((env? g)
 1877                 (if (eqv? body 0.0)
 1878                     (list 'env gname)
 1879                     (list '* (list 'env gname) body)))
 1880                    ((readin? g)
 1881                 (if (eqv? body 0.0)
 1882                     (list 'readin gname)
 1883                     (list '+ body (list 'readin gname))))
 1884                    ((not (mus-generator? g))
 1885                 (list gname body))
 1886                    ((eqv? body 0.0)
 1887                 (list (string->symbol (mus-name g)) gname))
 1888                    (else
 1889                 (list (string->symbol (mus-name g)) gname body))))))
 1890       
 1891       ;; now patch the two together (the apply let below) and evaluate the resultant thunk
 1892       (apply define (list 'inner)
 1893          `((let ,closure
 1894              (do ((k ,start (+ k 1)))
 1895              ((= k ,end))
 1896                (outa k ,body)))))
 1897       (inner))))))
 1898 #|
 1899 (with-sound ()
 1900   (chain-dsps 0 1.0 '(0 0 1 .5 2 0) (make-oscil 440))
 1901   (chain-dsps 1 1.0 '(0 0 1 4 2 0) (make-one-zero .5) (make-readin "oboe.snd"))
 1902   (chain-dsps 2 1.0 '(0 0 1 .5 2 0) (let ((osc1 (make-oscil 220)) 
 1903                       (osc2 (make-oscil 440))) 
 1904                       (lambda (val) (+ (osc1 val) 
 1905                                (osc2 (* 2 val)))))))
 1906 |#
 1907 
 1908 
 1909 
 1910 ;;; amplitude-modulate-channel could be (lambda (y data forward) (* y 0.5 (+ 1.0 (sin angle))) etc ...)
 1911 
 1912 
 1913 ;;; -------- re-order channels 
 1914 
 1915 (define scramble-channels
 1916   
 1917   (letrec ((+documentation+ "scramble-channels can arbitrarily re-order a sound's channels. The new channel order is \
 1918 passed as the arguments so to end with channel 3 in channel 0, 2 in 1, 0 in 2, and 1 in 3, (scramble-channels 3 2 0 1)")
 1919       
 1920        (scramble-channels-1
 1921         (let ((find-chan (lambda (chans chan len)
 1922                    (do ((pos #f)
 1923                     (i 0 (+ i 1)))
 1924                    ((or pos (= i len)) pos)
 1925                  (if (= (chans i) chan)
 1926                      (set! pos i))))))
 1927           (lambda (cur-chans end-chans chans loc)
 1928         (if (> chans loc)
 1929             (let* ((end-chan (end-chans loc)) ; we want this channel at loc
 1930                (cur-chan (cur-chans loc)) ; this (original) channel is currently at loc
 1931                (end-loc (find-chan cur-chans end-chan chans))) ; where is end-chan currently?
 1932               ;; end-chan goes in cur-chan's slot
 1933               (if (not (= cur-chan end-chan))
 1934               (begin
 1935                 (swap-channels #f end-loc #f loc)
 1936                 (set! (cur-chans end-loc) cur-chan)
 1937                 (set! (cur-chans loc) end-chan)))
 1938               (scramble-channels-1 cur-chans end-chans chans (+ 1 loc))))))))
 1939       
 1940     (lambda new-order
 1941       (let ((len (length new-order)))
 1942     (if (> len 1)
 1943         (let ((end-chans (apply vector new-order))
 1944           (cur-chans (make-vector len)))
 1945           (do ((i 0 (+ i 1)))
 1946           ((= i len))
 1947         (set! (cur-chans i) i))
 1948           (scramble-channels-1 cur-chans end-chans len 0)))))))
 1949 
 1950 
 1951 (define (scramble-channel silence-1)
 1952   ;; (scramble-channel .01)
 1953   (let ((buffer (make-moving-average 128))
 1954     (silence (/ silence-1 128))
 1955     (edges ())
 1956     (in-silence #t)
 1957     (old-max *max-regions*)
 1958     (old-tags *with-mix-tags*))
 1959     (dynamic-wind
 1960     (lambda ()
 1961       (set! *max-regions* 1024)
 1962       (set! *with-mix-tags* #f))
 1963     (lambda ()
 1964       (let ((len (framples))
 1965         (reader (make-sampler)))
 1966         (do ((i 0 (+ i 1)))
 1967         ((= i len))
 1968           (let ((now-silent (let ((sum-of-squares (let ((y (next-sample reader)))
 1969                             (moving-average buffer (* y y)))))
 1970                   (< sum-of-squares silence))))
 1971         (if (not (eq? in-silence now-silent))
 1972             (set! edges (cons i edges)))
 1973         (set! in-silence now-silent))))
 1974       (set! edges (append (reverse edges) (list (framples))))
 1975       (let ((len (length edges)))
 1976         (let ((pieces (make-vector len #f))
 1977           (start 0)
 1978           (ctr 0))
 1979           (for-each
 1980            (lambda (end)
 1981          (set! (pieces ctr) (make-region start end))
 1982          (set! ctr (+ ctr 1))
 1983          (set! start end))
 1984            edges)
 1985           (set! start 0)
 1986           (as-one-edit
 1987            (lambda()
 1988          (scale-by 0.0)
 1989          (do ((i 0 (+ i 1)))
 1990              ((= i len))
 1991            (let* ((this (random len))
 1992               (reg (pieces this)))
 1993              (set! (pieces this) #f)
 1994              (if (not reg)
 1995              (begin
 1996                (do ((j (+ 1 this) (+ j 1)))
 1997                    ((or (= j len)
 1998                     reg))
 1999                  (set! reg (pieces j))
 2000                  (if reg (set! (pieces j) #f)))
 2001                (if (not reg)
 2002                    (do ((j (- this 1) (- j 1)))
 2003                    ((or (< j 0)
 2004                     reg))
 2005                  (set! reg (pieces j))
 2006                  (if reg (set! (pieces j) #f))))))
 2007              (mix-region reg start)
 2008              (set! start (+ start (framples reg)))
 2009              (forget-region reg))))))))
 2010     (lambda ()
 2011       (set! *with-mix-tags* old-tags)
 2012       (set! *max-regions* old-max)))))
 2013 
 2014 
 2015 ;; -------- reorder blocks within channel
 2016 
 2017 (define reverse-by-blocks 
 2018   (let ((+documentation+ "(reverse-by-blocks block-len snd chn): divide sound into block-len blocks, recombine blocks in reverse order"))
 2019     (lambda* (block-len snd chn)
 2020       (let* ((len (framples snd chn))
 2021          (num-blocks (floor (/ len (srate snd) block-len))))
 2022     (if (> num-blocks 1)
 2023         (let ((actual-block-len (ceiling (/ len num-blocks))))
 2024           (let ((rd (make-sampler (- len actual-block-len) snd chn))
 2025             (beg 0)
 2026             (ctr 1))
 2027         (map-channel
 2028          (lambda (y)
 2029            (let ((val (read-sample rd)))
 2030              (if (< beg 10) ; ramp start and end to avoid clicks (might want to mix with next section)
 2031              (set! val (* val beg .1))
 2032              (if (> beg (- actual-block-len 10))
 2033                  (set! val (* val (- actual-block-len beg) .1))))
 2034              (set! beg (+ beg 1))
 2035              (if (= beg actual-block-len)
 2036              (begin
 2037                (set! ctr (+ ctr 1))
 2038                (set! beg 0)
 2039                (set! rd (make-sampler (max 0 (- len (* ctr actual-block-len))) snd chn))))
 2040              val))
 2041          0 #f snd chn #f (format #f "reverse-by-blocks ~A" block-len)))))))))
 2042 
 2043 
 2044 (define reverse-within-blocks 
 2045   (let ((+documentation+ "(reverse-within-blocks block-len snd chn): divide sound into blocks, recombine in order, but each block internally reversed"))
 2046     (lambda* (block-len snd chn)
 2047       (let* ((len (framples snd chn))
 2048          (num-blocks (floor (/ len (srate snd) block-len))))
 2049     (if (> num-blocks 1)
 2050         (let ((actual-block-len (ceiling (/ len num-blocks)))
 2051           (no-clicks-env (list 0.0 0.0  .01 1.0  .99 1.0  1.0 0.0)))
 2052           (as-one-edit
 2053            (lambda ()
 2054          (do ((beg 0 (+ beg actual-block-len)))
 2055              ((>= beg len))
 2056            (reverse-channel beg actual-block-len snd chn)
 2057            (env-channel no-clicks-env beg actual-block-len snd chn)))
 2058            (format #f "reverse-within-blocks ~A" block-len)))
 2059         (reverse-channel 0 #f snd chn))))))
 2060 
 2061 
 2062 ;;; -------- channel-clipped?
 2063 
 2064 #|
 2065 (define channel-clipped? 
 2066   (let ((+documentation+ "(channel-clipped? snd chn) returns the sample number if it finds clipping"))
 2067     (lambda* (snd chn)
 2068       (let ((last-y 0.0)
 2069         (len (framples snd chn))
 2070         (reader (make-sampler 0 snd chn)))
 2071     (call-with-exit
 2072      (lambda (quit)
 2073        (do ((i 0 (+ i 1)))
 2074            ((= i len) #f)
 2075          (let ((y (next-sample reader)))
 2076            (if (and (>= (abs y) 0.9999)
 2077             (>= (abs last-y) 0.9999))
 2078            (quit i)
 2079            (set! last-y y))))))))))
 2080 |#
 2081 ;;; not pretty but faster:
 2082 
 2083 (define channel-clipped? 
 2084   (let ((+documentation+ "(channel-clipped? snd chn) returns the sample number if it finds clipping"))
 2085     (lambda* (snd chn)
 2086       (do ((pos (scan-channel (lambda (y) (>= (abs y) 0.9999)) 0 #f snd chn) 
 2087         (scan-channel (lambda (y) (>= (abs y) 0.9999)) (+ pos 1) #f snd chn)))
 2088       ((or (not pos)
 2089            (>= (abs (sample (+ pos 1) snd chn)) 0.9999))
 2090        pos))))) ; or (and pos (+ pos 1)) to mimic the old version
 2091 
 2092 
 2093 ;;; -------- sync-everything
 2094 
 2095 (define sync-everything
 2096   (let ((+documentation+ "(sync-everything) sets the sync fields of all currently open sounds to the same, unique value"))
 2097     (lambda ()
 2098       (let ((new-sync (+ 1 (sync-max))))
 2099     (for-each
 2100      (lambda (snd)
 2101        (set! (sync snd) new-sync))
 2102      (sounds))))))