nyquist.lsp

一个音频的可执行程序。可以导入MP3/WAV格式的文件后

     (nyq:prod2 (car snds) (apply #'prod (cdr snds))))))

(setfn mult prod)


;; (NYQ:PROD-OF-ARRAYS S1 S2) - form pairwise products
;
(defun nyq:prod-of-arrays (s1 s2)
  (let* ((n (length s1))
     (p (make-array n)))
    (cond ((/= n (length s2))
       (error "unequal number of channels in prod")))
    (dotimes (i n)
      (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i))))
    p))


; nyq:prod2 - multiply two arguments
; 
(defun nyq:prod2 (s1 s2)
  (setf s1 (nyq:coerce-to s1 s2))
  (setf s2 (nyq:coerce-to s2 s1))
  (cond ((arrayp s1)
     (nyq:prod-of-arrays s1 s2))
    (t
     (nyq:prod-2-sounds s1 s2))))


; (PROD-2-SOUNDS S1 S2) - multiply two sound arguments
; 
(defun nyq:prod-2-sounds (s1 s2)
  (cond ((numberp s1)
     (cond ((numberp s2)
        (* s1 s2))
           (t
        (scale s1 s2))))
    ((numberp s2)
     (scale s2 s1))
    (t
     (let ((s1sr (snd-srate s1))
           (s2sr (snd-srate s2)))
;    (display "nyq:prod-2-sounds" s1sr s2sr)
        (cond ((> s1sr s2sr)
           (snd-prod s1 (snd-up s1sr s2)))
          ((< s1sr s2sr)
           (snd-prod (snd-up s2sr s1) s2))
          (t
           (snd-prod s1 s2)))))))


;; RAMP -- linear ramp from 0 to x
;;
(defun ramp (&optional (x 1))
  (let* ((duration (get-duration x)))
    (warp-abs nil 
    (at *rslt*
        (sustain-abs 1
        (pwl duration 1 (+ duration (/ *control-srate*))))))))


(defun resample (snd rate)
  (cond ((arrayp snd)
     (let* ((len (length snd))
        (result (make-array len)))
        (dotimes (i len)
        (setf (aref result i)
              (snd-resample (aref snd i) rate)))
        result))
    (t
     (snd-resample snd rate))))


(defun scale (amt snd)
  (cond ((arrayp snd)
     (let* ((len (length snd))
        (result (make-array len)))
        (dotimes (i len)
        (setf (aref result i) (snd-scale amt (aref snd i))))
        result))
    (t
     (snd-scale amt snd))))


(setfn s-print-tree snd-print-tree)

;; (PEAK sound-expression number-of-samples) - find peak amplitude
;
; NOTE: this used to be called s-max
;
(defmacro peak (expression maxlen)
   `(snd-max ',expression ,maxlen))

;; (S-MAX S1 S2) - return maximum of S1, S2
;
(defun s-max (s1 s2)
  (setf s1 (nyq:coerce-to s1 s2))
  (setf s2 (nyq:coerce-to s2 s1))
  (cond ((arrayp s1)
     (nyq:max-of-arrays s1 s2))
    (t
     (nyq:max-2-sounds s1 s2))))

(defun nyq:max-of-arrays (s1 s2)
  (let* ((n (length s1))
     (p (make-array n)))
    (cond ((/= n (length s2))
       (error "unequal number of channels in max")))
    (dotimes (i n)
      (setf (aref p i) (s-max (aref s1 i) (aref s2 i))))
    p))

(defun nyq:max-2-sounds (s1 s2)
  (cond ((numberp s1)
         (cond ((numberp s2)
                (max s1 s2))
               (t
                (snd-maxv s2
                          (snd-const s1 (local-to-global 0.0)
                                     (snd-srate s2) (get-duration 1.0))))))
        ((numberp s2)
         (snd-maxv s1 (snd-const s2 (local-to-global 0.0)
                   (snd-srate s1) (get-duration 1.0))))
        (t
         (let ((s1sr (snd-srate s1))
               (s2sr (snd-srate s2)))
            (cond ((> s1sr s2sr)
                   (snd-maxv s1 (snd-up s1sr s2)))
                  ((< s1sr s2sr)
                   (snd-maxv (snd-up s2sr s1) s2))
                  (t
                   (snd-maxv s1 s2)))))))

(defun s-min (s1 s2)
  (setf s1 (nyq:coerce-to s1 s2))
  (setf s2 (nyq:coerce-to s2 s1))
  (cond ((arrayp s1)
         (nyq:min-of-arrays s1 s2))
        (t
         (nyq:min-2-sounds s1 s2))))

(defun nyq:min-of-arrays (s1 s2)
  (let* ((n (length s1))
     (p (make-array n)))
    (cond ((/= n (length s2))
       (error "unequal number of channels in max")))
    (dotimes (i n)
      (setf (aref p i) (s-min (aref s1 i) (aref s2 i))))
    p))

(defun nyq:min-2-sounds (s1 s2)
  (cond ((numberp s1)
     (cond ((numberp s2)
        (min s1 s2))
           (t
        (snd-minv
         (snd-const s1 (local-to-global 0.0)
                (snd-srate s2) (get-duration 1.0))))))
    ((numberp s2)
     (snd-minv (snd-const s2 (local-to-global 0.0)
                (snd-srate s1) (get-duration 1.0))))
    (t
     (let ((s1sr (snd-srate s1))
           (s2sr (snd-srate s2)))
        (cond ((> s1sr s2sr)
           (snd-minv s1 (snd-up s1sr s2)))
          ((< s1sr s2sr)
           (snd-minv (snd-up s2sr s1) s2))
          (t
           (snd-minv s1 s2)))))))

(defun snd-minv (s1 s2)
  (scale -1.0 (snd-maxv (scale -1.0 s1) (scale -1.0 s2))))

; sequence macros SEQ and SEQREP are now in seq.lsp:
; 
(load "seq" :verbose NIL)

; set-logical-stop - modify the sound and return it, time is shifted and
;			 stretched
(defun set-logical-stop (snd tim)
  (let ((d (local-to-global tim)))
    (multichan-expand #'set-logical-stop-abs snd d)))


; set-logical-stop-abs - modify the sound and return it
; 
(defun set-logical-stop-abs (snd tim) (snd-set-logical-stop snd tim) snd)


(defmacro simrep (pair sound)
  `(let (_snds)
     (dotimes ,pair (push ,sound _snds))
     (sim-list _snds)))

(defun sim (&rest snds)
  (sim-list snds))

(setfn sum sim)

(defun sim-list (snds)
  (cond ((null snds)
     (snd-zero (local-to-global 0) *sound-srate*))
    ((null (cdr snds))
     (car snds))
    ((null (cddr snds))
     (nyq:add2 (car snds) (cadr snds)))
    (t
     (nyq:add2 (car snds) (sim-list (cdr snds))))))


;(defun rest (&optional (dur 1.0))
;  (cue (set-Logical-stop (* dur *stretch*) (s-create))))
(defun s-rest (&optional (dur 1.0))
  (let ((d (get-duration dur)))
    (snd-const 0.0 *rslt* *SOUND-SRATE* d)))


(defun tempo (warpfn)
  (slope (snd-inverse warpfn (local-to-global 0) *control-srate*)))



;; (SUM-OF-ARRAYS S1 S2) - add multichannel sounds
; 
; result has as many channels the largest of s1, s2
; corresponding channels are added, extras are copied
; 
(defun sum-of-arrays (s1 s2)
  (let* ((n1 (length s1))
     (n2 (length s2))
     (n (min n1 n2))
     (m (max n1 n2))
     (result (make-array m))
     (big-s (if (> n1 n2) s1 s2)))
    
    (dotimes (i n)
      (setf (aref result i) (nyq:add-2-sounds (aref s1 i) (aref s2 i))))
    (dotimes (i (- m n))
      (setf (aref result (+ n i)) (aref big-s (+ n i))))
    result))


;; (WARP fn behavior) - warp behavior according to fn
;;
;; fn is a map from behavior time to local time, and *WARP* expresses
;; a map from local to global time.
;; To produce a new *WARP* for the environment, we want to compose the
;; effect of the current *WARP* with fn.  Note that fn is also a behavior.
;; It is evaluated in the current environment first, then it is used to
;; modify the environment seen by behavior.
;; *WARP* is a triple: (d s f) denoting the function f(st+d).
;; Letting g represent the new warp function fn, we want f(st+d) o g, or
;; f(s*g(t) + d) in the form (d' s' f').
;; Let's do this one step at a time:
;; f(s*g(t) + d) = f(scale(s, g) + d)
;;               = (shift f -d)(scale(s, g))
;;               = (snd-compose (shift-time f (- d)) (scale s g))
;;
;; If f in NIL, it denotes the identity mapping f(t)=t, so we can
;; simplify:
;; f(scale(s, g) + d) = scale(s, g) + d
;;                    = (snd-offset (scale s g) d)

(defmacro warp (x s)
 `(progv '(*WARP*) (list 
            (list 0.0 1.0
              (if (warp-function *WARP*)
                  (snd-compose (shift-time (warp-function *WARP*) 
                               (- (warp-time *WARP*)))
                       (scale (warp-stretch *WARP*) 
                          (must-be-sound ,x)))
                  (snd-offset (scale (warp-stretch *WARP*) 
                         (must-be-sound ,x))
                      (warp-time *WARP*)))))
     ,s))


(defmacro warp-abs (x s)
 `(progv '(*WARP*) (list (list 0.0 1.0 ,x))
     ,s))


;; MULTICHAN-EXPAND -- construct and return array according to args
;;
;; arrays are used in Nyquist to represent multiple channels
;; if any argument is an array, make sure all array arguments
;; have the same length.  Then, construct a multichannel result
;; by calling fn once for each channel.  The arguments passed to
;; fn for the i'th channel are either the i'th element of an array
;; argument, or just a copy of a non-array argument.
;;
(defun multichan-expand (fn &rest args)
  (let (len newlen result) ; len is a flag as well as a count
    (dolist (a args)
        (cond ((arrayp a)
           (setf newlen (length a))
           (cond ((and len (/= len newlen))
              (error (format nil "In ~A, two arguments are vectors of differing length." fn))))
           (setf len newlen))))
    (cond (len
       (setf result (make-array len))
       ; for each channel, call fn with args
       (dotimes (i len)
           (setf (aref result i)
             (apply fn
            (mapcar
                #'(lambda (a)
                ; take i'th entry or replicate:
                (cond ((arrayp a) (aref a i))
                      (t a)))
                args))))
       result)
      (t
       (apply fn args)))))


;; SELECT-IMPLEMENTATION-? -- apply an implementation according to args
;;
;; There is a different Nyquist primitive for each combination of 
;; constant (NUMBERP) and time-variable (SOUNDP) arguments.  E.g.
;; a filter with fixed parameters differs from one with varying
;; parameters.  In most cases, the user just calls one function,
;; and the arguments are decoded here:


;; SELECT-IMPLEMENTATION-1-1 -- 1 sound arg, 1 selector
;;
(defun select-implementation-1-1 (fns snd sel1 &rest others)
  (if (numberp sel1)
    (apply (aref fns 0) (cons snd (cons sel1 others)))
    (apply (aref fns 1) (cons snd (cons sel1 others)))))


;; SELECT-IMPLEMENTATION-1-2 -- 1 sound arg, 2 selectors
;;
;; choose implemenation according to args 2 and 3
;;
(defun select-implementation-1-2 (fns snd sel1 sel2 &rest others)
  (if (numberp sel2)
    (if (numberp sel1)
      (apply (aref fns 0) (cons snd (cons sel1 (cons sel2 others))))
      (apply (aref fns 1) (cons snd (cons sel1 (cons sel2 others)))))
    (if (numberp sel1)
      (apply (aref fns 2) (cons snd (cons sel1 (cons sel2 others))))
      (apply (aref fns 3) (cons snd (cons sel1 (cons sel2 others)))))))

;; some waveforms

(setf *saw-table* (pwlvr -1 1 1))		; eh, creepy way to get 2205 samples.
(setf *saw-table* (list *saw-table* (hz-to-step 1) T))

(setf *tri-table* (pwlvr -1 0.5 1 0.5 -1))
(setf *tri-table* (list *tri-table* (hz-to-step 1) T))

(setf *id-shape*  (pwlvr -1 2 1 .01 1))	            ; identity
(setf *step-shape* (seq (const -1) (const 1 1.01)))  ; hard step at zero

(defun exp-dec (hold halfdec length)
  (let* ((target (expt 0.5 (/ length halfdec)))
     (expenv (pwev 1 hold 1 length target)))
    expenv)
)

;;; operations on sounds

(defun diff (x y) (sum x (prod -1 y)))

; compare-shape is a shape table -- origin 1.
(defun compare (x y &optional (compare-shape *step-shape*))
  (let ((xydiff (diff x y)))
    (shape xydiff compare-shape 1)))

;;; oscs

(defun osc-saw (hz) (hzosc hz *saw-table*))
(defun osc-tri (hz) (hzosc hz *tri-table*))

; bias is [-1, 1] pulse width.  sound or scalar.
; hz is a sound or scalar
(defun osc-pulse (hz bias &optional (compare-shape *step-shape*))
  (compare bias (osc-tri hz) compare-shape))

(setf NY:ALL 1000000000)