;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)))))