nyquist.lsp

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

            (snd-inverse warp-fn (local-to-global 0) wrate)))
    (t
     (snd-compose control
              (snd-inverse warp-fn (local-to-global 0) *control-srate*)))))


;; (cue sound)
;;    Cues the given sound; that is, it applies the current *WARP*, *LOUD*,
;; *START*, and *STOP* values to the argument.  The logical start time is at
;; local time 0.
(defun cue (sound)
  (cond ((arrayp sound)
     (let* ((len (length sound))
        (result (make-array len)))
        (dotimes (i len)
        (setf (aref result i)
              (cue-sound (aref sound i))))
        result))
    (t
     (cue-sound sound))))

(defun cue-sound (sound)
  (snd-xform sound
         (snd-srate sound)
         (local-to-global 0) *START* *STOP* (db-to-linear (get-loud))))

;; (sound sound)
;;    Same as (cue sound), except also warps the sound.
;; Note that the *WARP* can change the pitch of the
;; sound as a result of resampling.
;; Here's the derivation for the warping code:
;; *WARP* is a triple: (d s f) which denotes that the warp from local to
;; global time is: f(st+d)
;; We need to compose sound with the inverse of this to get a function
;; of global time
;; Let f-1 be the inverse of f.  Then the inverse of f(st+d) is 
;; (f-1(t) - d)/s
;; The composition gives us: (snd-compose sound (f-1(t) - d)/s)
;; Eliminate the 1/s term by changing the sample rate of sound:
;;  = (snd-compose (snd-scale-srate sound s) (f-1(t) - d))
;; Eliminate the -d term by shifting f before taking the inverse:
;;  = (snd-compose (scale-srate sound s) ((inverse f) - d))
;;  = (snd-compose (scale-srate sound s) (inverse f(t + d)))
;;  = (snd-compose (scale-srate sound s) (inverse (shift f -d)))
;; snd-inverse takes a time and sample rate.  For time, use zero.
;; The sample rate of inverse determines the final sample rate of
;; this function, so use *SOUND-SRATE*:
;;  = (snd-compose (scale-srate sound s) (snd-inverse (shift-time f (- d))
;;                                              0 *SOUND-SRATE*))
;;
(defun sound (sound)
   (cond ((null (warp-function *WARP*))
      (snd-xform sound (/ (snd-srate sound) (warp-stretch *WARP*))
             (local-to-global 0)
             *START* *STOP* (db-to-linear (get-loud))))
     (t
      (snd-compose (scale-srate sound (warp-stretch *WARP*))
               (snd-inverse (shift-time (warp-function *WARP*)
                        (- (warp-time *WARP*)))
                    0 *SOUND-SRATE*)))))


;; (SCALE-SRATE SOUND SCALE)
;; multiplies the sample rate by scale
(defun scale-srate (sound scale)
  (let ((new-srate (* scale (snd-srate sound))))
    (snd-xform sound new-srate (snd-time sound) 
           MIN-START-TIME MAX-STOP-TIME 1.0)))


;; (SHIFT-TIME SOUND SHIFT)
;; shift the time of a function by SHIFT, i.e. if SOUND is f(t),
;; then (shift-time SOUND SHIFT) is f(t - SHIFT).  Note that if
;; you look at plots, the shifted sound will move *right* when SHIFT
;; is positive.  
(defun shift-time (sound shift)
  (snd-xform sound (snd-srate sound) (+ (snd-t0 sound) shift)
         MIN-START-TIME MAX-STOP-TIME 1.0))


;; (NYQ:SOUND-TO-ARRAY SOUND N) - duplicate SOUND to N channels
;;
(defun nyq:sound-to-array (sound n)
  (let ((result (make-array n)))
    (dotimes (i n)
      (setf (aref result i) sound))
    result))


;; (control sound)
;;    Same as (sound sound), except this is used for control signals.  
;;    This code is identical to sound.
(setfn control sound)


;; (env t1 t2 t4 l1 l2 l3 &optional duration)
;; Creates a 4-phase envelope.
;;	tN is the duration of phase N, and lN is the final level of
;;	phase N.  t3 is implied by the duration, and l4 is 0.0.
;;	If dur is not supplied, then 1.0 is assumed.  The envelope
;;	duration is the product of dur, *STRETCH*, and *SUSTAIN*.  If 
;;	t1 + t2 + 2ms + t4 > duration, then a two-phase envelope is
;;	substituted that has an attack/release time ratio = t1/t4.
;;	The sample rate of the returned sound is *CONTROL-SRATE*.
;;
;; Time transformation: the envelope is not warped; the start time and
;; stop times are warped to global time.  Then the value of *SUSTAIN* at
;; the begining of the envelope is used to determing absolute duration.
;; Since PWL is ultimately called to create the envelope, we must use
;; ABS-ENV to prevent any further transforms inside PWL.  We use
;; (AT global-start ...) inside ABS-ENV so that the final result has 
;; the proper starting time.
;;
(defun env (t1 t2 t4 l1 l2 l3 &optional (duration 1.0))
  (let (actual-dur min-dur ratio t3
    (actual-dur (get-duration duration)))
    (setf min-dur (+ t1 t2 t4 0.002))
    (cond ((< actual-dur min-dur)
       (setf ratio (/ t1 (+ t1 t4)))
       (setf t1 (* ratio actual-dur))
       (setf t2 (- actual-dur t1))
       (setf t3 0.0)
       (setf t4 0.0)
       (setf l2 0.0)
       (setf l3 0.0))
      (t
       (setf t3 (- actual-dur t1 t2 t4))))
    (set-logical-stop
     (abs-env (at *rslt*
          (pwl t1 l1 (+ t1 t2) l2 (- actual-dur t4) l3 actual-dur)))
     duration)))


(defun gate (sound lookahead risetime falltime floor threshold)
    (cond ((< lookahead risetime)
           (break "lookahead must be greater than risetime in GATE function"))
          ((or (< risetime 0) (< falltime 0) (< floor 0))
           (break "risetime, falltime, and floor must all be positive in GATE function"))
          (t
           (let ((s
              (snd-gate (seq (cue sound) (abs-env (s-rest lookahead)))
                    lookahead risetime falltime floor threshold)))
             (snd-xform s (snd-srate s) (snd-t0 sound) 
            (+ (snd-t0 sound) lookahead) MAX-STOP-TIME 1.0)))))


;; (osc-note step &optional duration env sust volume sound)
;;   Creates a note using table-lookup osc, but with an envelope.
;; The ENV parameter may be a parameter list for the env function,
;; or it may be a sound.
;;
(defun osc-note (pitch &optional (duration 1.0) 
               (env-spec '(0.02 0.1 0.3 1.0 .8 .7))
               (volume 0.0)
               (table *TABLE*))
  (set-logical-stop
   (mult (loud volume (osc pitch duration table))
     (if (listp env-spec)
       (apply 'env env-spec)
       env-spec))
   duration))


;; force-srate -- resample snd if necessary to get sample rate
;
(defun force-srate (sr snd)
  (cond ((not (numberp sr))
     (error "force-srate: SR should be a number")))
  (cond ((arrayp snd)
     (let* ((len (length snd))
        (result (make-array len)))
       (dotimes (i len)
            (setf (aref result i) 
              (force-srate sr (aref snd i))))
       result))
    (t
     (let ((snd-sr (snd-srate snd)))
       (cond ((> sr snd-sr) (snd-up sr snd))
         ((< sr snd-sr) (snd-down sr snd))
         (t snd))))))


(defun force-srates (srs snd)
  (cond ((and (numberp srs) (soundp snd))
     (force-srate srs snd))
    ((and (arrayp srs) (arrayp snd))
     (let* ((len (length snd))
        (result (make-array len)))
       (dotimes (i len)
            (setf (aref result i) 
              (force-srate (aref srs i) (aref snd i))))
       result))
    (t (error "arguments not compatible"))))


;; (breakpoints-convert (t1 x1 t2 x2 ... tn) t0)
;;   converts times to sample numbers and scales amplitudes
;;   t0 is the global (after warping) start time
;;
;; NOTE: there were some stack overflow problems with the original
;; recursive version (in comments now), so it was rewritten as an
;; iteration.
;;
(defun breakpoints-convert (list t0)
  (prog (sample-count result sust (last-count 0))
    (setf sust (get-sustain))
 loop
    (setf sample-count 
      (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0)
                 *control-srate*))))
    ; now we have a new sample count to put into result list
    ; make sure result is non-decreasing
    (cond ((< sample-count last-count)
       (setf sample-count last-count)))
    (setf last-count sample-count)
    (push sample-count result)
    (cond ((cdr list)
       (setf list (cdr list))
       (push (float (car list)) result)))
    (setf list (cdr list))
    (cond (list
       (go loop)))
    (return (reverse result))))

      
 
;; (pwl t1 l1 t2 l2 ... tn)
;;   Creates a piece-wise linear envelope from breakpoint data.
;;
(defun pwl (&rest breakpoints) (pwl-list breakpoints))

(defun pwlr (&rest breakpoints) (pwlr-list breakpoints))

;; (breakpoints-relative list)
;;  converts list, which has the form (value dur value dur value ...)
;;  into the form (value time value time value ...)
;;  the list may have an even or odd length
;;
(defun breakpoints-relative (breakpoints)
  (prog (result (sum 0.0))
 loop
     (cond (breakpoints
        (push (car breakpoints) result)
        (setf breakpoints (cdr breakpoints))
        (cond (breakpoints
           (setf sum (+ sum (car breakpoints)))
           (push sum result)
           (setf breakpoints (cdr breakpoints))
           (go loop)))))
     (return (reverse result))))


(defun breakpoints-relative (breakpoints)
  (prog (result (sum 0.0))
 loop
    (setf sum (+ sum (car breakpoints)))
    (push sum result)
    (cond ((cdr breakpoints)
       (setf breakpoints (cdr breakpoints))
       (push (car breakpoints) result)))
    (setf breakpoints (cdr breakpoints))
    (cond (breakpoints
       (go loop)))
    (return (reverse result))))


(defun pwlr-list (breakpoints)
  (pwl-list (breakpoints-relative breakpoints)))

(defun pwl-list (breakpoints)
  (let ((t0 (local-to-global 0)))
    (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0))))

;; (pwlv l1 t1 l2 t2 ... ln)
;; Creates a piece-wise linear envelope from breakpoint data;
;; the function initial and final values are explicit
;;
(defun pwlv (&rest breakpoints)
  ;use pwl, modify breakpoints with initial and final changes
  ;need to put initial time of 0, and final time of 0
  (pwlv-list breakpoints))

(defun pwlv-list (breakpoints)
    (pwl-list (cons 0.0 (append breakpoints '(0.0)))))

(defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints))

(defun pwlvr-list (breakpoints)
  (pwlr-list (cons 0.0 (append breakpoints '(0.0)))))

(defun pwe (&rest breakpoints)
  (pwe-list breakpoints))

(defun pwe-list (breakpoints)
  (pwev-list (cons 1.0 (append breakpoints '(1.0)))))

(defun pwer (&rest breakpoints) (pwer-list breakpoints))

(defun pwer-list (breakpoints)
  (pwe-list (breakpoints-relative breakpoints)))

(defun pwev (&rest breakpoints)
  (pwev-list breakpoints))

(defun pwev-list (breakpoints)
  (let ((lis (breakpoints-log breakpoints)))
    (s-exp (pwl-list lis))))

(defun pwevr (&rest breakpoints) (pwevr-list breakpoints))

(defun pwevr-list (breakpoints)
  (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints)))))


(defun breakpoints-log (breakpoints)
  (prog ((result '(0.0)) val tim)
loop
    (cond (breakpoints
       (setf val (float (car breakpoints)))
       (setf breakpoints (cdr breakpoints))
       (cond (breakpoints
          (setf tim (car breakpoints))
          (setf breakpoints (cdr breakpoints))))
       (setf result (cons tim (cons (log val) result)))
       (cond ((null breakpoints)
          (return (reverse result))))
       (go loop))
      (t
       (error "Expected odd number of elements in breakpoint list")))))


;; SOUND-WARP -- apply warp function to a sound
;; 
(defun sound-warp (warp-fn signal &optional wrate)
  (cond (wrate
     (snd-resamplev signal *sound-srate*
            (snd-inverse warp-fn (local-to-global 0) wrate)))
    (t
     (snd-compose signal 
              (snd-inverse warp-fn (local-to-global 0) *sound-srate*)))))

(defun snd-extent (sound maxsamples) 
    (list (snd-t0 sound)
      (+ (snd-t0 sound) (/ (snd-length sound maxsamples)
                   (snd-srate sound)))))

(setfn snd-flatten snd-length)

;; (maketable sound)
;;   Creates a table for osc, lfo, etc. by assuming that the samples
;;   in sound represent one period.  The sound must start at time 0.

(defun maketable (sound)
  (list sound
    (hz-to-step 
     (/ 1.0
        (cadr (snd-extent sound 1000000))))
    T))


;(defmacro endTime (sound)
;   `(get-logical-stop ,sound))


;(defmacro beginTime (sound)
;   `(car (snd-extent ,sound)))


; simple stereo pan: as where goes from 0 to 1, sound
; is linearly panned from left to right
;
(defun pan (sound where)
  (vector (mult sound (sum 1 (mult -1 where)))
      (mult sound where)))


(defun prod (&rest snds)
  (cond ((null snds)
     (snd-zero (local-to-global 0) *sound-srate*))
    ((null (cdr snds))
     (car snds))
    ((null (cddr snds))
     (nyq:prod2 (car snds) (cadr snds)))
    (t