193 lines
6.6 KiB
Common Lisp
193 lines
6.6 KiB
Common Lisp
;nyquist plug-in
|
|
;version 4
|
|
;type process
|
|
;name "Grainimogrifier..."
|
|
;action "Milling..."
|
|
;author "dm"
|
|
;preview disabled
|
|
;release 1.3.1
|
|
;copyright "Released under terms of the GNU General Public License version 2"
|
|
|
|
;control grain-number "Number of Grains" int "" 50 2 1750
|
|
;control min-grain-gap "Minimum Grain Separation (ms)" float "" 1 0 50
|
|
;control grain-length "Grain Length (ms)" float "" 500 0 1000
|
|
;control grain-type "Grain Envelope" choice "Triangle,Sine,Exponential,Rectangular" 0
|
|
;control normal-places "Normalize Sample Start Control Envelope" choice "No,Yes" 0
|
|
|
|
; 'input' raw sample to granulate
|
|
; 'gaps-env' t: grain number x: absolute time in seconds until next grain
|
|
; 'starts' processed gaps - list of absolute start times of grains
|
|
; 'place-env' t: relative time in output x: relative input time where grain starts
|
|
; 'places' processed places - list of relative input times where grains start
|
|
; where gaps-env or place-env is negative, grains are reversed.
|
|
|
|
(defun scratch-cleanup ()
|
|
(remprop '*SCRATCH* '*DM-GRAN-STARTS*)
|
|
(remprop '*SCRATCH* '*DM-GRAN-PLACES*)
|
|
(remprop '*SCRATCH* '*DM-GRAN-SIGN*))
|
|
|
|
(defun get-r-grain-length ()
|
|
(/ grain-length (get-duration 1) 1000.0))
|
|
|
|
;;;FUNCTIONS CALLED BY FIRST RUN
|
|
(defun array-to-list (arr)
|
|
(do (lst
|
|
(ind 0 (1+ ind))
|
|
(end (- (length arr) 1)))
|
|
((> ind end) (reverse lst))
|
|
(push (aref arr ind) lst)))
|
|
|
|
(defun downsample-and-list (sig)
|
|
(array-to-list (snd-fetch-array
|
|
(force-srate (/ grain-number (get-duration 1)) sig)
|
|
grain-number 1)))
|
|
|
|
(defun gaps-to-starts (lst)
|
|
(do ((rslt (list 0)))
|
|
((null lst) (cdr (reverse rslt)))
|
|
(push
|
|
(+ (car rslt)
|
|
(max min-grain-gap (abs (pop lst))))
|
|
rslt)))
|
|
|
|
(defun first-invocation ()
|
|
;;;resample first track so that we have one sample per grain
|
|
;;;cast sound to list, take cumulative sum and store for future invocations
|
|
;;;also record when list is negative so we know when to reverse grains
|
|
;;mono error
|
|
(if (arrayp *TRACK*)
|
|
(throw 'err (format nil "First two tracks should be mono.")))
|
|
(let ((gaps-list (downsample-and-list *TRACK*)))
|
|
(putprop '*SCRATCH*
|
|
(gaps-to-starts gaps-list)
|
|
'*DM-GRAN-STARTS*)
|
|
(putprop '*SCRATCH*
|
|
(mapcar #'minusp gaps-list)
|
|
'*DM-GRAN-SIGN*)))
|
|
|
|
;;;FUNCTIONS CALLED BY SECOND RUN
|
|
(defun rev-time (len tim)
|
|
;;;grain starts at local time tim, local duration is len.
|
|
;;;find local start time such that reversing track plays same grain up to reversal.
|
|
(- 1.0 tim len))
|
|
|
|
(defun normalize-places (lst)
|
|
;;;ensure elements span from 0 to 1 (or if it's constant, 0)
|
|
(if (and lst normal-places)
|
|
(let* ((hi (apply #'max lst))
|
|
(lo (apply #'min lst))
|
|
(spread (- hi lo)))
|
|
(if (= spread 0)
|
|
(mapc (lambda (y) 0) lst)
|
|
(mapc (lambda (y) (/ (- y lo) spread)) lst)))
|
|
lst))
|
|
|
|
(defun get-final-duration (starts)
|
|
;;;duration of processed track
|
|
(+ (/ grain-length 1000.0) (car (last starts))))
|
|
|
|
(defun process-place-env (starts reverses)
|
|
;;;convert times to relative start times, look up values of track
|
|
;;;reverse grains whenever first or second track is negative
|
|
(do ((dur-out (get-final-duration starts))
|
|
rev reverses-out
|
|
place places)
|
|
((null starts)
|
|
(cons
|
|
(reverse (normalize-places places))
|
|
(reverse reverses-out)))
|
|
(setf place (sref *TRACK* (/ (pop starts) dur-out)))
|
|
(setf rev (or (pop reverses) (minusp place)))
|
|
;;Reversing grains is accomplished by graining a reversed copy of the whole track.
|
|
;;Thus we need to adjust the start times.
|
|
(push
|
|
(if rev
|
|
(rev-time (get-r-grain-length) (abs place))
|
|
place) places)
|
|
(push rev reverses-out)))
|
|
|
|
(defun second-invocation ()
|
|
;;;get list of absolute start times of grains from previous invocation
|
|
;;;convert to relative start times
|
|
;;;look up values of current (i.e. second) track at rel. times, store for later
|
|
(if (arrayp *TRACK*)
|
|
(throw 'err (format nil "First two tracks should be mono."
|
|
(scratch-cleanup))))
|
|
(let ((results (process-place-env
|
|
(get '*SCRATCH* '*DM-GRAN-STARTS*)
|
|
(get '*SCRATCH* '*DM-GRAN-SIGN*))))
|
|
(putprop '*SCRATCH* (car results) '*DM-GRAN-PLACES*)
|
|
(putprop '*SCRATCH* (cdr results) '*DM-GRAN-SIGN*)))
|
|
|
|
;;;FUNCTIONS CALLED BY THIRD RUN
|
|
(defun array-reverse (a length)
|
|
(do ((left 0 (1+ left))
|
|
(right (- length 1) (1- right))
|
|
(middle (/ length 2))
|
|
temp)
|
|
((= left middle) a)
|
|
(setf temp (aref a left))
|
|
(setf (aref a left) (aref a right))
|
|
(setf (aref a right) temp)))
|
|
|
|
(defun snd-reverse (sig)
|
|
(let* ((len (snd-length sig NY:ALL))
|
|
(arr (snd-samples sig len)))
|
|
(snd-from-array
|
|
(snd-t0 sig)
|
|
*sound-srate*
|
|
(array-reverse arr len))))
|
|
|
|
(defun grain-envelope (len)
|
|
(case grain-type
|
|
(0 (pwl (/ len 2.0) 1 len 0)) ;triangle
|
|
(1 (lfo (/ 0.5 (get-duration 1) len) len)) ;sine
|
|
(2 (scale (/ (- 1 len)) (diff (pwev 1 len len) len))) ;exp
|
|
(3 1))) ;rect
|
|
|
|
(defun any (lst)
|
|
(do ((rslt nil (pop lst)))
|
|
((or rslt (null lst)) rslt)))
|
|
|
|
(defun granulate (sample)
|
|
;;;extract grains from sample at relative times specified by places
|
|
;;;apply envelope to each grain, cue grains at absolute times specified by starts
|
|
(do* ((starts (get '*SCRATCH* '*DM-GRAN-STARTS*))
|
|
(places (get '*SCRATCH* '*DM-GRAN-PLACES*))
|
|
(revers (get '*SCRATCH* '*DM-GRAN-SIGN*))
|
|
;;optimization - only reverse the sample if we need to.
|
|
(rev-sample (if (any revers) (snd-reverse sample) nil))
|
|
(throw 'err (format nil "AAA"))
|
|
place
|
|
r-grain-length
|
|
(grain (s-rest 1))
|
|
(out (s-rest 0)))
|
|
((null starts) out)
|
|
(setq place (pop places))
|
|
(setq r-grain-length (get-r-grain-length))
|
|
(setf grain (mult (grain-envelope r-grain-length)
|
|
(extract place (+ place r-grain-length)
|
|
(if (pop revers) rev-sample sample))))
|
|
(setf out (sim (at 0 (cue out))
|
|
(at-abs (pop starts) (cue grain))))))
|
|
|
|
(defun process-sample-track ()
|
|
(prog1
|
|
(multichan-expand #'granulate *TRACK*)
|
|
(if (= index tracks) (scratch-cleanup))))
|
|
|
|
;;;GLOBALS
|
|
(setq index (get '*TRACK* 'INDEX))
|
|
(setq tracks (length (get '*SELECTION* 'TRACKS)))
|
|
(setq min-grain-gap (/ min-grain-gap 1000.0))
|
|
|
|
;;;MAIN
|
|
(catch 'err
|
|
(if (< tracks 3)
|
|
(throw 'err (format nil
|
|
"Select three or more audio tracks. The top two should be mono."))
|
|
(cond
|
|
((= index 1) (first-invocation) *TRACK*)
|
|
((= index 2) (second-invocation) *TRACK*)
|
|
(T (process-sample-track)))))
|