nyquist.lsp

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

;; PARTIAL -- sine osc with built-in envelope scaling
;;
(defun partial (steps env)
  (let ((hz (step-to-hz (+ steps (get-transpose)))))
    (cond ((> hz (/ *SOUND-SRATE* 2))
       (format t "Warning: partial frequency (~A hz) will alias at current sample rate (~A hz).\n"
           hz *SOUND-SRATE*)))
    (snd-partial *sound-srate*
         hz
         env)))


;; SAMPLER -- simple attack + sustain sampler
;;
(defun sampler (pitch modulation 
        &optional (sample *table*) (npoints 2))
  (let ((samp (car sample))
    (samp-pitch (cadr sample))
    (samp-loop-start (caddr sample))
    (hz (step-to-hz (+ pitch (get-transpose)))))
    ; make a waveform table look like a sample with no attack:
    (cond ((not (numberp samp-loop-start))
       (setf samp-loop-start 0.0)))
    (cond ((> hz (/ *SOUND-SRATE* 2))
       (format t "Warning: sampler nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
           hz *SOUND-SRATE*)))
    (scale-db (get-loud)
       (snd-sampler 
    samp		; samples for table
    samp-pitch		; step represented by table
    samp-loop-start         ; time to start loop
    *SOUND-SRATE*		; output sample rate
    hz			;  output hz
    (local-to-global 0)	; starting time
    modulation		; modulation
    npoints))))		; number of interpolation points


;; SINE -- simple sine oscillator
;;
(defun sine (steps &optional (duration 1.0))
  (let ((hz (step-to-hz (+ steps (get-transpose))))
    (d (get-duration duration)))
    (cond ((> hz (/ *SOUND-SRATE* 2))
       (format t "Warning: sine frequency (~A hz) will alias at current sample rate (~A hz).\n"
           hz *SOUND-SRATE*)))
    (snd-sine *rslt* hz *sound-srate* d)))


;; PLUCK
;;
;; (ARGUMENTS ("double" "sr") ("double" "hz") ("time_type" "t0") 
;;            ("time_type" "d") ("double" "final_amp"))
;;
(defun pluck (steps &optional (duration 1.0) (final-amp 0.001))
  (let ((hz (step-to-hz (+ steps (get-transpose))))
        (d (get-duration duration)))
    (cond ((> hz (/ *SOUND-SRATE* 2))
       (format t "Warning: pluck frequency (~A hz) will alias at current sample rate (~A hz).\n"
           hz *SOUND-SRATE*)))
    (snd-pluck *SOUND-SRATE* hz *rslt* d final-amp)))




;; abs-env -- restore the standard environment
;;
(defmacro abs-env (s)
  `(progv '(*WARP* *LOUD* *TRANSPOSE* *SUSTAIN* 
        *START* *STOP* *CONTROL-SRATE* *SOUND-SRATE*)
      (list '(0.0 1.0 NIL) 0.0 0.0 1.0
        -1e+9 1e+9 *DEFAULT-CONTROL-SRATE* *DEFAULT-SOUND-SRATE*)
      ,s))


; nyq:add2 - add two arguments
; 
(defun nyq:add2 (s1 s2)
    (cond ((and (arrayp s1) (not (arrayp s2)))
       (setf s2 (vector s2)))
      ((and (arrayp s2) (not (arrayp s1)))
       (setf s1 (vector s1))))
    (cond ((arrayp s1)
       (sum-of-arrays s1 s2))
      (t
       (nyq:add-2-sounds s1 s2))))


; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound (or number) arguments
; 
(defun nyq:add-2-sounds (s1 s2)
  (cond ((numberp s1)
     (cond ((numberp s2)
        (+ s1 s2))
           (t
        (snd-offset s2 s1))))
    ((numberp s2)
     (snd-offset s1 s2))
    (t
     (let ((s1sr (snd-srate s1))
           (s2sr (snd-srate s2)))
;    (display "nyq:add-2-sounds" s1sr s2sr)
       (cond ((> s1sr s2sr)
          (snd-add s1 (snd-up s1sr s2)))
         ((< s1sr s2sr)
          (snd-add (snd-up s2sr s1) s2))
         (t
          (snd-add s1 s2)))))))




(defmacro at (x s)
 `(progv '(*WARP*) (list (list (+ (warp-time *WARP*) 
                  (* (warp-stretch *WARP*) ,x))
                   (warp-stretch *WARP*)
                   (warp-function *WARP*)))
      ,s))


;; (AT-ABS t behavior) evaluate behavior at global time t
;;
;; *WARP* is the triple (d s f) denoting the function f(st+d),
;; a mapping from local to global time.
;; We want (d' s f) such that f(s*0 + d') = t
;; (Note that we keep the same s and f, and only change the offset.
;; To eliminate the warp and stretch use "(abs-env (at t behavior))")
;; Applying the inverse of f, d' = f-1(t), or (sref (snd-inverse f ...) t)
;; Rather than invert the entire function just to evaluate at one point,
;; we use SREF-INVERSE to find d'.
;;
(defmacro at-abs (x s)
 `(progv '(*WARP*)
     (if (warp-function *WARP*)
               (list (list (sref-inverse (warp-function *WARP*) ,x)
                   (warp-stretch *WARP*)
                   (warp-function *WARP*)))
               (list (list ,x (warp-stretch *WARP*) NIL)))
     ,s))

;; (CLIP S1 VALUE) - clip maximum amplitude to value
;
(defun clip (x v)
  (cond ((numberp x)
     (max (min x v) (- v)))
    ((arrayp x)
     (let* ((len (length x))
        (result (make-array len)))
        (dotimes (i len)
        (setf (aref result i) 
              (snd-clip (aref x i) v)))
        result))
    (t
     (snd-clip x v))))

;; (NYQ:COERCE-TO S1 S2) - expand sound s1 to type of s2
; 
(defun nyq:coerce-to (s1 s2)
  (cond ((soundp s1)
     (cond ((arrayp s2)
        (nyq:sound-to-array s1 (length s2)))
           (t s1)))
    (t s1)))


(defmacro continuous-control-warp (beh)
  `(snd-compose (warp-abs nil ,beh)
        (snd-inverse (get-warp)
         (local-to-global 0) *control-srate*)))

(defmacro continuous-sound-warp (beh)
  `(snd-compose (warp-abs nil ,beh)
        (snd-inverse (get-warp)
         (local-to-global 0) *sound-srate*)))


(defmacro control-srate-abs (r s)
  `(progv '(*CONTROL-SRATE*) (list ,r)
      ,s))

; db = 20log(ratio)
; db = 20 ln(ratio)/ln(10)
; db/20 = ln(ratio)/ln(10)
; db ln(10)/20 = ln(ratio)
; e^(db ln(10)/20) = ratio
;
(setf ln10over20 (/ (log 10.0) 20))

(defun db-to-linear (x) 
  (cond ((numberp x)
     (exp (* ln10over20 x)))
    ((arrayp x)
     (let* ((len (length x))
        (result (make-array len)))
        (dotimes (i len)
        (setf (aref result i) 
              (snd-exp (snd-scale ln10over20 (aref snd i)))))
        result))
    (t
     (snd-exp (snd-scale ln10over20 x)))))


(defun linear-to-db (x) 
  (cond ((numberp x)
     (/ (log (float x)) ln10over20))
    ((arrayp x)
     (let* ((len (length x))
        (result (make-array len)))
        (dotimes (i len)
        (setf (aref result i) 
              (snd-scale (/ 1.0 ln10over20) (snd-log (aref snd i)))))
        result))
    (t
     (snd-scale (/ 1.0 ln10over20) (snd-log x)))))

; sref - access a sound at a given time point
;    note that the time is transformed to global
(defun sref (sound point)
  (snd-sref sound (local-to-global point)))


; extract - start is stretched and shifted as is stop
;  result is shifted to start at local time zero
(defun extract (start stop sound)
  (snd-xform sound (snd-srate sound) (local-to-global 0) 
         (local-to-global start) (local-to-global stop) 1.0))

(defun extract-abs (start stop sound)
  (snd-xform sound (snd-srate sound) 0 start stop 1.0))
     

;(defmacro extract (start stop sound)
;  `(let ($newsound)
;     (progv '(*START* *STOP*)
;            (list (local-to-global ,start)
;		  (local-to-global ,stop))
;            (setf $newsound ,sound)
;            (setf $newsound 
;                  (loud-abs 0 (cue (set-logical-stop-abs $newsound *STOP*)))))
;     $newsound))


;(defmacro extract-abs (start stop sound)
;  `(let ($newsound $newstart)
;     (progv '(*START* *STOP*)
;            (list ,start ,stop)
;	    (setf $newstart *START*)
;            (setf $newsound ,sound)            
;            (setf $newsound (set-logical-stop-abs $newsound *STOP*)))
;     (snd-xform $newsound (snd-srate $newsound) ,start ,stop 1.0)))


(defun local-to-global (local-time)
  (let ((d (warp-time *WARP*))
    (s (warp-stretch *WARP*))
    (w (warp-function *WARP*))
    global-time)
    (setf global-time (+ (* s local-time) d))
    (if w (snd-sref w global-time) global-time)))


(defmacro loud (x s)
 `(progv '(*LOUD*) (list (sum *LOUD* ,x))
     ,s))


(defmacro loud-abs (x s)
 `(progv '(*LOUD*) (list ,x)
     ,s))

(defun must-be-sound (x)
 (cond ((soundp x) x)
       (t
    (error "SOUND type expected" x))))

;; SCALE-DB -- same as scale, but argument is in db
;;
(defun scale-db (factor sound)
  (scale (db-to-linear factor) sound))

(defun set-control-srate (rate)
  (setf *default-control-srate* (float rate))
  (nyq:environment-init))

(defun set-sound-srate (rate) 
  (setf *default-sound-srate* (float rate))
  (nyq:environment-init))


; s-plot -- compute and write n data points for plotting
; 
(defun s-plot (snd &optional (n 1000))
  (prog ((points (snd-samples snd (1+ n)))
     (filename (soundfilename *default-plot-file*))
     outf
     (period (/ 1.0 (snd-srate snd)))
     len 
     (maximum 1.0))
    (setf outf (open filename :direction :output))
    (cond ((null outf)
       (format t "s-plot: could not open ~A!~%" filename)
       (return nil)))
    (format t "s-plot: writing ~A ... ~%" filename)
    (setf len (length points))
    (cond ((> len n)
       (setf len n)
       (format t "WARNING: SOUND TRUNCATED TO ~A POINTS~%" len)))
    (dotimes (i len)
      (cond ((< (abs maximum) (abs (aref points i)))
         (setf maximum (aref points i))))
      (format outf "~A ~A~%" (* i period) (aref points i)))
    (close outf)
    (cond ((> (abs maximum) 1.0)
       (format t "WARNING: MAXIMUM AMPLITUDE IS ~A~%" maximum)))
    (format t "~A points from ~A to ~A~%"
     len (snd-t0 snd) (+ (snd-t0 snd) (* len period)))))

; run something like this to plot the points:
; graph < points.dat | plot -Ttek


(defmacro sound-srate-abs (r s)
  `(progv '(*SOUND-SRATE*) (list ,r)
      ,s))


(defmacro stretch (x s)
 `(progv '(*WARP*) (list (list (warp-time *WARP*) 
                   (* (warp-stretch *WARP*) ,x)
                   (warp-function *WARP*)))
     (if (minusp (warp-stretch *WARP*))
         (break "Negative stretch factor is not allowed"))
             ,s))

         
(defmacro stretch-abs (x s)
 `(progv '(*WARP*) (list (list (local-to-global 0)
                   ,x
                   nil))
     (if (minusp (warp-stretch *WARP*))
         (break "Negative stretch factor is not allowed"))
             ,s))


(defmacro sustain (x s)
 `(progv '(*SUSTAIN*) (list (prod *SUSTAIN* ,x))
      ,s))


(defmacro sustain-abs (x s)
 `(progv '(*SUSTAIN*) (list ,x)
      ,s))


;; (WARP-FUNCTION *WARP*) - extracts function field of warp triple
;;
(setfn warp-function caddr)


;; (WARP-STRETCH *WARP*) - extracts stretch field of warp triple
;;
(setfn warp-stretch cadr)


;; (WARP-TIME *WARP*) - extracts time field of warp triple
;;
(setfn warp-time car)


(defmacro transpose (x s)
 `(progv '(*TRANSPOSE*) (list (sum *TRANSPOSE* ,x))
      ,s))


(defmacro transpose-abs (x s)
 `(progv '(*TRANSPOSE*) (list ,x)
      ,s))


;; CONTROL-WARP -- apply a warp function to a control function
;; 
(defun control-warp (warp-fn control &optional wrate)
  (cond (wrate
     (snd-resamplev control *control-srate*