;;; various mix and track related utilities
;;;
;;; (pan-mix file frame envelope) mixes file into current sound starting at frame using envelope to pan (0: all chan 0, 1: all chan 1)
;;; (mix->vct id) return mix data in vct
;;; (snap-mix-to-beat (at-tag-position)) forces dragged mix to end up on a beat
;;; (delete-all-mixes) removes all mixes
;;; (find-mix sample snd chn) returns the id of the mix at the given sample, or #f
;;; (save-mix mix filename) saves mix data in file filename
;;; (mix-maxamp id) maxamp of mix
;;;
;;; (track->vct track (chan 0)) place track data in vct
;;; (save-track track filename (chan 0)) save track data in file
;;; (filter-track track coeffs) filter track data
;;; (reverse-track track) reverses the mix order
;;; (delete-all-tracks) removes all mixes that have an associated track (sets all amps to 0)
;;; (set-all-tracks new-id) places all mixes in track new-id
;;;
;;; (transpose-track track semitones) transposes each mix in track by semitones
;;; (retempo-track track tempo) changes the inter-mix begin times of mixes in track by tempo (> 1.0 is faster)
;;; (track-maxamp id) maxamp of track
;;;
;;; mix-property associates a property list with a mix
;;; track-property associates a property list with a track
;;; mix-click-sets-amp sets up hook functions so that mix click zeros amps, then subsequent click resets to the before-zero value
(provide 'snd-mix.scm)
(define (tree-for-each func tree)
"(tree-for-each func tree) applies func to every leaf of 'tree'"
(cond ((null? tree) '())
((not (pair? tree)) (func tree))
(else (tree-for-each func (car tree))
(tree-for-each func (cdr tree)))))
(define (tree-for-each-reversed func tree)
"(tree-for-each-reversed func tree) applies func to every leaf of 'tree' moving in reverse through all the lists"
(define (flatten lst)
;; there's probably a more elegant way to do this
(define (list-p val)
(and (list? val)
(not (null? val))))
(cond ((null? lst) '())
((list-p lst)
(if (list-p (car lst))
(append (flatten (car lst)) (flatten (cdr lst)))
(cons (car lst) (flatten (cdr lst)))))
(#t lst)))
(for-each func (reverse (flatten tree))))
;;; ---------------- mixes ----------------
(define (mix-sound file start)
"(mix-sound file start) mixes file (all chans) at start in the currently selected sound."
(mix file start #t))
(define (delete-all-mixes)
"(delete-all-mixes) removes all mixes (sets all amps to 0)"
(as-one-edit
(lambda ()
(tree-for-each
(lambda (id)
(delete-mix id))
(mixes)))))
(define* (find-mix sample #:optional (snd #f) (chn #f))
"(find-mix sample snd chn) returns the id of the mix at the given sample, or #f"
(let ((mix-list (mixes (or snd (selected-sound) (car (sounds))) (or chn (selected-channel snd) 0))))
(call-with-current-continuation
(lambda (found-it)
(for-each
(lambda (n)
(if (= (mix-position n) sample)
(found-it n)))
mix-list)
#f))))
;;; -------- pan-mix --------
(define* (pan-mix name #:optional (beg 0) (envelope 1.0) snd (chn 0) (auto-delete #f))
"(pan-mix file (start 0) (envelope 1.0) snd (chn 0) (auto-delete #f)) mixes 'file' into the sound 'snd'
starting at start (in samples) using 'envelope' to pan (0: all chan 0, 1: all chan 1).
So, (pan-mix \"oboe.snd\" .1 '(0 0 1 1)) goes from all chan 0 to all chan 1. If
the variable with-tags is #t, the resultant mixes are placed in their own track, and
the track envelope controls the panning.
If 'envelope' is a scaler, it is turned into an evelope at that value. 'auto-delete' determines
whether the in-coming file should be treated as a temporary file and deleted when the mix
is no longer accessible."
(let ((index (or snd (selected-sound) (and (sounds) (car (sounds)))))
(old-with-mix-tags (with-mix-tags)))
(if (not (sound? index))
(throw 'no-such-sound (list "pan-mix" snd)))
(if (not (file-exists? name))
(throw 'no-such-file (list "pan-mix" name)))
(let ((new-mix
(dynamic-wind
(lambda () (set! (with-mix-tags) #t))
(lambda ()
(let ((incoming-chans (mus-sound-chans name))
(receiving-chans (chans index))
(old-sync (sync index))
(track-func (if (list? envelope) envelope (list 0 envelope 1 envelope))))
(if (= receiving-chans 1)
(if (= incoming-chans 1)
(let ((id (mix name beg 0 index 0 #t auto-delete)))
(if (list? envelope)
(set! (mix-amp-env id 0) envelope)
(set! (mix-amp id 0) envelope))
id)
(as-one-edit
;; incoming chans > 2 ignored
(lambda ()
(let* ((trk (make-track))
(mix0 (mix name beg 0 index 0 #t auto-delete trk))
(mix1 (mix name beg 1 index 0 #t auto-delete trk)))
(set! (mix-inverted? mix1) #t)
(set! (track-amp-env trk) track-func)
mix0))))
(let* ((chan0 chn)
(chan1 (modulo (1+ chn) receiving-chans)))
;; receiving-chans >= 2, so start-chan comes into play
(if (= incoming-chans 1)
(dynamic-wind
(lambda ()
(set! (sync index) #f))
(lambda ()
(as-one-edit
(lambda ()
(let* ((trk (make-track))
(mix0 (mix name beg 0 index chan0 #t auto-delete trk))
(mix1 (mix name beg 0 index chan1 #t auto-delete trk)))
(set! (mix-inverted? mix1) #t)
(set! (track-amp-env trk) track-func)
mix0))))
(lambda ()
(set! (sync index) old-sync)))
(let ((new-sync 0))
;; incoming chans > 2 ignored
(for-each (lambda (s) (if (>= (sync s) new-sync) (set! new-sync (1+ (sync s))))) (sounds))
(dynamic-wind
(lambda ()
(set! (sync index) new-sync))
(lambda ()
(as-one-edit
(lambda ()
(let* ((trk (make-track))
(mix0 (mix name beg 0 index chan0 #t auto-delete trk))
(mix1 (mix name beg 1 index chan1 #t auto-delete trk)))
(set! (mix-inverted? mix1) #t)
(set! (track-amp-env trk) track-func)
mix0))))
(lambda ()
(set! (sync index) old-sync)))))))))
(lambda ()
(set! (with-mix-tags) old-with-mix-tags)))))
(if (and (mix? new-mix)
(not old-with-mix-tags))
(if (track? (mix-track new-mix))
(lock-track (mix-track new-mix))
(set! (mix-locked? new-mix) #t)))
new-mix)))
(define* (pan-mix-selection #:optional (beg 0) (envelope 1.0) snd (chn 0))
"(pan-mix-selection (start 0) (envelope 1.0) snd (chn 0)) mixes the current selection into the sound 'snd'
starting at 'start' (in samples) using 'envelope' to pan (0: all chan 0, 1: all chan 1)."
(if (not (selection?))
(throw 'no-active-selection (list "pan-mix-selection"))
(pan-mix (save-selection (snd-tempnam)) beg envelope snd chn #t)))
(define* (pan-mix-region reg #:optional (beg 0) (envelope 1.0) snd (chn 0))
"(pan-mix-region reg (start 0) (envelope 1.0) snd (chn 0)) mixes the given region into the sound 'snd'
starting at 'start' (in samples) using 'envelope' to pan (0: all chan 0, 1: all chan 1)."
(if (not (region? reg))
(throw 'no-such-region (list "pan-mix-region" reg))
(pan-mix (save-region reg (snd-tempnam)) beg envelope snd chn #t)))
(define* (pan-mix-vct v #:optional (beg 0) (envelope 1.0) snd (chn 0))
"(pan-mix-vct v (start 0) (envelope 1.0) snd (chn 0)) mixes the vct data into the sound 'snd'
starting at 'start' (in samples) using 'envelope' to pan (0: all chan 0, 1: all chan 1)."
(let* ((temp-file (snd-tempnam))
(fd (open-sound-file temp-file 1 (srate snd) "")))
(vct->sound-file fd v (vct-length v))
(close-sound-file fd (* 4 (vct-length v)))
(pan-mix temp-file beg envelope snd chn #t)))
(define (mix->vct id)
"(mix->vct id) returns mix's data in vct"
(if (mix? id)
(let* ((len (mix-frames id))
(v (make-vct len))
(reader (make-mix-sample-reader id)))
(do ((i 0 (1+ i)))
((= i len))
(vct-set! v i (read-mix-sample reader)))
(free-sample-reader reader)
v)
(throw 'no-such-mix (list "mix->vct" id))))
(define (save-mix id filename)
"(save-mix id filename) saves mix data (as floats) in file filename"
(let ((v (mix->vct id))
(fd (open-sound-file filename 1 (srate) "")))
(vct->sound-file fd v (vct-length v))
(close-sound-file fd (* 4 (vct-length v)))))
(define (mix-maxamp id)
"(mix-maxamp id) returns the max amp in the given mix"
(if (mix? id)
(let* ((len (mix-frames id))
(peak 0.0)
(reader (make-mix-sample-reader id)))
(set! peak (abs (read-mix-sample reader)))
(do ((i 1 (1+ i)))
((= i len))
(let ((val (abs (read-mix-sample reader))))
(if (> val peak)
(set! peak val))))
(free-sample-reader reader)
peak)
(throw 'no-such-mix (list "mix-maxamp" id))))
(define* (snap-mix-to-beat #:optional (at-tag-position #f))
"(snap-mix-to-beat) forces a dragged mix to end up on a beat (see beats-per-minute). reset mix-release-hook to cancel"
(add-hook! mix-release-hook
(lambda (id samps-moved)
(let* ((offset (if at-tag-position (mix-tag-position id) 0))
(samp (+ samps-moved (mix-position id) offset))
(snd (car (mix-home id)))
(chn (cadr (mix-home id)))
(bps (/ (beats-per-minute snd chn) 60.0))
(sr (srate snd))
(beat (floor (/ (* samp bps) sr)))
(lower (inexact->exact (floor (/ (* beat sr) bps))))
(higher (inexact->exact (floor (/ (* (1+ beat) sr) bps)))))
(set! (mix-position id)
(if (< (- samp lower) (- higher samp))
(max 0 (- lower offset))
(- higher offset)))
#t))))
;;; --------------------------------------------------------------------------------
(define all-mix-properties '())
(define mix-properties
(make-procedure-with-setter
(lambda (id)
(let ((data (assoc id all-mix-properties)))
(if data
(cdr data)
'())))
(lambda (id new-val)
(let ((old-val (assoc id all-mix-properties)))
(if old-val
(set-cdr! old-val new-val)
(set! all-mix-properties (cons (cons id new-val) all-mix-properties)))
new-val))))
(define mix-property
(make-procedure-with-setter
(lambda (key id)
"(mix-property key id) returns the value associated with 'key' in the given mix's property list, or #f"
(if (mix? id)
(let ((data (assoc key (mix-properties id))))
(if data
(cdr data)
#f))
(throw 'no-such-mix (list "mix-property" id))))
(lambda (key id new-val)
(if (mix? id)
(let ((old-val (assoc key (mix-properties id))))
(if old-val
(set-cdr! old-val new-val)
(set! (mix-properties id) (cons (cons key new-val) (mix-properties id))))
new-val)
(throw 'no-such-mix (list "set! mix-property" id))))))
(add-hook! close-hook
(lambda (snd)
(if (not (null? all-mix-properties))
;; prune out inactive mix properties
(set! all-mix-properties (remove-if (lambda (val)
(not (mix? (car val))))
all-mix-properties)))))
(define (mix-click-sets-amp)
(add-hook! mix-click-hook
(lambda (n)
(let ((zeroed (mix-property :zero n)))
(if (not zeroed)
(let ((amps '()))
(do ((i (1- (mix-chans n)) (1- i)))
((< i 0))
(set! amps (cons (mix-amp n i) amps)))
(set! (mix-property :amps n) amps)
(do ((i 0 (1+ i)))
((= i (mix-chans n)))
(set! (mix-amp n i) 0.0))
(set! (mix-property :zero n) #t))
(let ((amps (mix-property :amps n)))
(do ((i 0 (1+ i)))
((= i (mix-chans n)))
(set! (mix-amp n i) (list-ref amps i)))
(set! (mix-property :zero n) #f)))
#t))))
;;; --------------------------------------------------------------------------------
(define (delete-all-tracks)
"(delete-all-tracks) removes all mixes that have an associated track (sets all amps to 0)"
(as-one-edit
(lambda ()
(tree-for-each
(lambda (id)
(if (not (= (mix-track id) 0))
(delete-mix id)))
(mixes)))))
(define (reverse-track trk)
"(reverse-track) reverses the order of its mixes (it changes various mix begin times)"
(if (some mix? (track trk))
(let* ((ids-in-order (sort (track trk)
(lambda (a b)
(> (mix-position a)
(mix-position b))))))
(as-one-edit
(lambda ()
(for-each (lambda (id pos)
(set! (mix-position id) pos))
ids-in-order
(reverse (map mix-position ids-in-order))))))
(throw 'no-such-track (list "reverse-track" trk))))
(define* (track->vct trk #:optional (chan 0))
"(track->vct track (chan 0)) places track data in vct"
(if (track? trk)
(if (< chan (track-chans trk))
(let* ((len (track-frames trk chan))
(v (make-vct len))
(rd (make-track-sample-reader trk chan)))
(run
(lambda ()
(do ((i 0 (1+ i)))
((= i len) v)
(vct-set! v i (read-track-sample rd))))))
(throw 'no-such-channel (list "track->vct" chan)))
(throw 'no-such-track (list "track->vct" trk))))
(define* (save-track trk filename #:optional (chan #t))
"(save-track track filename (chan #t)) saves track data (as floats) in file filename"
(if (track? trk)
(let ((chans (track-chans trk)))
(if (or (and (eq? chan #t)
(= chans 1))
(and (integer? chan)
(< chan chans)))
(let* ((current-chan (if (eq? chan #t) 0 chan))
(v (track->vct trk current-chan))
(fd (open-sound-file filename 1 (srate) "written by save-track")))
(vct->sound-file fd v (vct-length v))
(close-sound-file fd (* 4 (vct-length v))))
(if (and (eq? chan #t)
(> chans 0))
(let* ((fd (open-sound-file filename chans (srate) "written by save-track"))
(len (track-frames trk))
(pos (track-position trk))
(v (make-vct (* chans len))))
(do ((i 0 (1+ i)))
((= i chans))
(let ((chan-len (track-frames trk i))
(chan-pos (- (track-position trk i) pos))
(reader (make-track-sample-reader trk i))) ; beg is next arg if it's needed
(do ((j 0 (1+ j)))
((= j chan-len))
(vct-set! v (+ i (* chans (+ chan-pos j))) (read-track-sample reader)))))
(vct->sound-file fd v (vct-length v))
(close-sound-file fd (* 4 (vct-length v))))
(throw 'no-such-channel (list "save-track" chan)))))
(throw 'no-such-track (list "save-track" trk))))
(define (track-maxamp id chan)
"(track-maxamp id chan) returns the max amp in the given track"
(if (track? id)
(let* ((len (track-frames id chan))
(peak 0.0)
(reader (make-track-sample-reader id)))
(set! peak (abs (read-track-sample reader)))
(do ((i 1 (1+ i)))
((= i len))
(let ((val (abs (read-track-sample reader))))
(if (> val peak)
(set! peak val))))
(free-sample-reader reader)
peak)
(throw 'no-such-track (list "track-maxamp" id))))
(define (transpose-track trk semitones)
"(transpose-track track semitones) transposes each mix in track by semitones"
(let ((mult (expt 2.0 (/ semitones 12.0))))
(set! (track-speed trk) (* (track-speed trk) mult))))
(define (retempo-track trk tempo)
"(retempo-track track tempo) changes the inter-mix begin times of mixes in track by tempo (> 1.0 is faster)"
(set! (track-tempo trk) (* (track-tempo trk) tempo)))
;;; (retempo-track 1 2.0)
(define (filter-track track-id fir-filter-coeffs)
"(filter-track track coeffs) filters track data using FIR filter coeffs: (filter-track track-id '(.1 .2 .3 .3 .2 .1))"
(if (track? track-id)
(let ((order (length fir-filter-coeffs))
(chans (track-chans track-id)))
(do ((chan 0 (1+ chan)))
((= chan chans))
(let ((beg (track-position track-id chan))
(dur (track-frames track-id chan))
(flt (make-fir-filter order (list->vct fir-filter-coeffs)))
(reader (make-track-sample-reader track-id chan 0)))
(map-channel (lambda (y)
(let ((val (read-track-sample reader)))
(+ y (- (fir-filter flt val) val))))
beg (+ dur order) #f #f #f "filter-track"))))
(throw 'no-such-track (list "filter-track" track-id))))
;;; --------------------------------------------------------------------------------
(define all-track-properties '())
(define track-properties
(make-procedure-with-setter
(lambda (id)
(let ((data (assoc id all-track-properties)))
(if data
(cdr data)
'())))
(lambda (id new-val)
(let ((old-val (assoc id all-track-properties)))
(if old-val
(set-cdr! old-val new-val)
(set! all-track-properties (cons (cons id new-val) all-track-properties)))
new-val))))
(define track-property
(make-procedure-with-setter
(lambda (key id)
"(track-property key id) returns the value associated with 'key' in the given track's property list, or #f"
(if (track? id)
(let ((data (assoc key (track-properties id))))
(if data
(cdr data)
#f))
(throw 'no-such-track (list "track-property" id))))
(lambda (key id new-val)
(if (track? id)
(let ((old-val (assoc key (track-properties id))))
(if old-val
(set-cdr! old-val new-val)
(set! (track-properties id) (cons (cons key new-val) (track-properties id))))
new-val)
(throw 'no-such-track (list "set! track-property" id))))))
;;; --------------------------------------------------------------------------------
(define (mix-click-info n)
"(mix-click-info n) is a mix-click-hook function that describes a mix and its properties"
(help-dialog "Mix Help"
(format #f "Mix ~D:~% position: ~D = ~,3F secs~% length: ~D (~,3F secs)
~% in: ~A[~D]~A~A~A~% scalers: ~A~% speed: ~A~% envs: ~{~A~^~% ~}~A~A"
n
(mix-position n)
(exact->inexact (/ (mix-position n) (srate (car (mix-home n)))))
(mix-frames n)
(exact->inexact (/ (mix-frames n) (srate (car (mix-home n)))))
(short-file-name (car (mix-home n))) (cadr (mix-home n))
(if (mix-locked? n) ", (locked)" "")
(if (mix-inverted? n) ", (inverted)" "")
(if (not (= (mix-track n) 0))
(format #f "~% track: ~A" (mix-track n))
"")
(let ((scls '()))
(do ((i (1- (mix-chans n)) (1- i)))
((< i 0) scls)
(set! scls (cons (mix-amp n i) scls))))
(mix-speed n)
(let ((es '()))
(do ((i (1- (mix-chans n)) (1- i)))
((< i 0) es)
(set! es (cons (mix-amp-env n i) es))))
(if (not (= (mix-tag-position n) 0))
(format #f "~% tag-position: ~A" (mix-tag-position n))
"")
(let ((props (mix-properties n)))
(if (and (list? props)
(not (null? props)))
(format #f "~% properties: '~A" props)
""))))
#t)
