Autres/audacity
1
0
Fork 0
mirror of https://github.com/cookiengineer/audacity synced 2025-10-10 16:43:33 +02:00
Code Issues Releases Wiki Activity

Locate and position the current Audacity source code, and clear a variety of old junk out of the way into junk-branches

Browse Source
This commit is contained in:
ra
2010-01-23 19:44:49 +00:00
commit e74978ba77
1011 changed files with 781704 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

55
nyquist/bug.lsp Normal file
View File

@@ -0,0 +1,55 @@
; 6 -32 8 -32 pumped too much noise, picked up student answer too
; 3 -30 4 -30 pumped too much noise too
(setf m (compress-map 2 -12 2 -24 :limit t :transition 2))
(s-save (scale 0.005 m) ny:all "map.wav")
(defun t1 () (print (s-save (clip (let (y)
(setf y (compress (s-read "c:\\rbd\\garlan.aif") m 0.1 0.1))
(setf y (agc y 6.0 2.0 2.0))
y) 1.0) ny:all "compress.wav" :bits 8)))
(defun t2 () (print (s-save (clip (let (y)
(setf y (compress (s-read "denoise.wav") m 0.1 0.1))
(setf y (agc y 6.0 2.0 2.0))
y) 1.0) ny:all "compden8.wav" :bits 8)))
;(print (play (clip (scale 1.0 (compress (s-read "c:\\rbd\\garlan.aif") m 0.1 0.1)) 1.0)))
;(print (play (clip (agc (s-read "c:\\rbd\\garlan.aif") 6.0 2.0 2.0) 1.0)))
;(setf sil (s-read "..\\..\\garlan.aif" :time-offset 7.655 :dur 1.165))
;(setf soft (s-read "..\\..\\garlan.aif" :time-offset 15.64 :dur .11))
; (play (compress sil m 0.1 0.1))
; (s-save (snd-oneshot (s-read ".\\orig.wav") 0.990 0.1) ny:all "oneshot.wav")
(defun square (x) (* x x))
;; region for low-pass will be *soften-width* wide, with
;; *soften-crossfade* seconds of cross-fade
(setf *soften-width* 0.02)
(setf *soften-crossfade* 0.002)
(defun soften-clipping (snd)
(let (clip-region)
(setf clip-region (snd-oneshot (prod snd snd)
(square (/ 126.0 127.0)) *soften-width*))
(setf clip-region (snd-chase clip-region
*soften-crossfade* *soften-crossfade*))
(setf snd (seq (s-rest 0.01) (cue (scale 0.99 snd))))
; (vector (prod snd clip-region) snd)
(prod snd clip-region)
))
(sound-off)
(defun tes ()
(let (snd)
(setf snd (s-read "..\\..\\intro.aif"))
(play (soften-clipping snd))))
(tes)

577
nyquist/dspprims.lsp Normal file
View File

@@ -0,0 +1,577 @@
;; dspprims.lsp -- interface to dsp primitives
;; ARESON - notch filter
;;
(defun areson (s c b &optional (n 0))
(multichan-expand #'nyq:areson s c b n))
(setf areson-implementations
(vector #'snd-areson #'snd-aresonvc #'snd-aresoncv #'snd-aresonvv))
;; NYQ:ARESON - notch filter, single channel
;;
(defun nyq:areson (signal center bandwidth normalize)
(select-implementation-1-2 areson-implementations
signal center bandwidth normalize))
;; hp - highpass filter
;;
(defun hp (s c)
(multichan-expand #'nyq:hp s c))
(setf hp-implementations
(vector #'snd-atone #'snd-atonev))
;; NYQ:hp - highpass filter, single channel
;;
(defun nyq:hp (s c)
(select-implementation-1-1 hp-implementations s c))
;; comb-delay-from-hz -- compute the delay argument
;;
(defun comb-delay-from-hz (hz caller)
(recip hz))
;; comb-feedback-from-decay -- compute the feedback argument
;;
(defun comb-feedback (decay delay)
(s-exp (mult -6.9087 delay (recip decay))))
;; COMB - comb filter
;;
;; this is just a feedback-delay with different arguments
;;
(defun comb (snd decay hz)
(multichan-expand #'nyq:comb snd decay hz))
(defun nyq:comb (snd decay hz)
(let (delay feedback len d)
; convert decay to feedback, iterate over array if necessary
(setf delay (comb-delay-from-hz hz "comb"))
(setf feedback (comb-feedback decay delay))
(nyq:feedback-delay snd delay feedback)))
;; ALPASS - all-pass filter
;;
(defun alpass (snd decay hz &optional min-hz)
(multichan-expand #'nyq:alpass snd decay hz min-hz))
(defun nyq:alpass (snd decay hz min-hz)
(let (delay feedback len d)
; convert decay to feedback, iterate over array if necessary
(setf delay (comb-delay-from-hz hz "alpass"))
(setf feedback (comb-feedback decay delay))
(nyq:alpass1 snd delay feedback min-hz)))
;; CONST -- a constant at control-srate
;;
(defun const (value &optional (dur 1.0))
(let ((d (get-duration dur)))
(snd-const value *rslt* *CONTROL-SRATE* d)))
;; CONVOLVE - slow convolution
;;
(defun convolve (s r)
(multichan-expand #'snd-convolve s r))
;; FEEDBACK-DELAY -- (delay is quantized to sample period)
;;
(defun feedback-delay (snd delay feedback)
(multichan-expand #'nyq:feedback-delay snd delay feedback))
;; SND-DELAY-ERROR -- report type error
;;
(defun snd-delay-error (snd delay feedback)
(error "feedback-delay with variable delay is not implemented"))
;; NYQ::DELAYCV -- coerce sample rates and call snd-delaycv
;;
(defun nyq:delaycv (the-snd delay feedback)
(display "delaycv" the-snd delay feedback)
(let ((the-snd-srate (snd-srate the-snd))
(feedback-srate (snd-srate feedback)))
(cond ((> the-snd-srate feedback-srate)
(setf feedback (snd-up the-snd-srate feedback)))
((< the-snd-srate feedback-srate)
(format t "Warning: down-sampling feedback in feedback-delay/comb~%")
(setf feedback (snd-down the-snd-srate feedback))))
(snd-delaycv the-snd delay feedback)))
(setf feedback-delay-implementations
(vector #'snd-delay #'snd-delay-error #'nyq:delaycv #'snd-delay-error))
;; NYQ:FEEDBACK-DELAY -- single channel delay
;;
(defun nyq:feedback-delay (snd delay feedback)
(select-implementation-1-2 feedback-delay-implementations
snd delay feedback))
;; SND-ALPASS-ERROR -- report type error
;;
(defun snd-alpass-error (snd delay feedback)
(error "alpass with constant decay and variable hz is not implemented"))
(if (not (fboundp 'snd-alpasscv))
(defun snd-alpasscv (snd delay feedback min-hz)
(error "snd-alpasscv (ALPASS with variable decay) is not implemented")))
(if (not (fboundp 'snd-alpassvv))
(defun snd-alpassvv (snd delay feedback min-hz)
(error "snd-alpassvv (ALPASS with variable decay and feedback) is not implemented")))
(defun snd-alpass-4 (snd delay feedback min-hz)
(snd-alpass snd delay feedback))
(defun snd-alpasscv-4 (the-snd delay feedback min-hz)
(display "snd-alpasscv-4" (snd-srate the-snd) (snd-srate feedback))
(let ((the-snd-srate (snd-srate the-snd))
(feedback-srate (snd-srate feedback)))
(cond ((> the-snd-srate feedback-srate)
(setf feedback (snd-up the-snd-srate feedback)))
((< the-snd-srate feedback-srate)
(format t "Warning: down-sampling feedback in alpass~%")
(setf feedback (snd-down the-snd-srate feedback))))
;(display "snd-alpasscv-4 after cond" (snd-srate the-snd) (snd-srate feedback))
(snd-alpasscv the-snd delay feedback)))
(defun snd-alpassvv-4 (the-snd delay feedback min-hz)
;(display "snd-alpassvv-4" (snd-srate the-snd) (snd-srate feedback))
(let ((the-snd-srate (snd-srate the-snd))
(delay-srate (snd-srate delay))
(feedback-srate (snd-srate feedback))
max-delay)
(cond ((or (not (numberp min-hz))
(<= min-hz 0))
(error "alpass needs numeric (>0) 4th parameter (min-hz) when delay is variable")))
(setf max-delay (/ 1.0 min-hz))
; make sure delay is between 0 and max-delay
; use clip function, which is symetric, with an offset
(setf delay (snd-offset (clip (snd-offset delay (* max-delay -0.5))
(* max-delay 0.5))
(* max-delay 0.5)))
; now delay is between 0 and max-delay, so we won't crash nyquist when
; we call snd-alpassvv, which doesn't test for out-of-range data
(cond ((> the-snd-srate feedback-srate)
(setf feedback (snd-up the-snd-srate feedback)))
((< the-snd-srate feedback-srate)
(format t "Warning: down-sampling feedback in alpass~%")
(setf feedback (snd-down the-snd-srate feedback))))
(cond ((> the-snd-srate delay-srate)
(setf delay (snd-up the-snd-srate delay)))
((< the-snd-srate delay-srate)
(format t "Warning: down-sampling delay in alpass~%")
(setf delay (snd-down the-snd-srate delay))))
(display "snd-alpassvv-4 after cond" (snd-srate the-snd) (snd-srate feedback))
(snd-alpassvv the-snd delay feedback max-delay)))
(setf alpass-implementations
(vector #'snd-alpass-4 #'snd-alpass-error
#'snd-alpasscv-4 #'snd-alpassvv-4))
;; NYQ:ALPASS1 -- single channel alpass
;;
(defun nyq:alpass1 (snd delay feedback min-hz)
(select-implementation-1-2 alpass-implementations
snd delay feedback min-hz))
;; CONGEN -- contour generator, patterned after gated analog env gen
;;
(defun congen (gate rise fall) (multichan-expand #'snd-congen gate rise fall))
;; S-EXP -- exponentiate a sound
;;
(defun s-exp (s) (multichan-expand #'nyq:exp s))
;; NYQ:EXP -- exponentiate number or sound
;;
(defun nyq:exp (s) (if (soundp s) (snd-exp s) (exp s)))
;; S-ABS -- absolute value of a sound
;;
(defun s-abs (s) (multichan-expand #'nyq:abs s))
;; NYQ:ABS -- absolute value of number or sound
;;
(defun nyq:abs (s) (if (soundp s) (snd-abs s) (abs s)))
;; S-SQRT -- square root of a sound
;;
(defun s-sqrt (s) (multichan-expand #'nyq:sqrt s))
;; NYQ:SQRT -- square root of a number or sound
;;
(defun nyq:sqrt (s) (if (soundp s) (snd-sqrt s) (sqrt s)))
;; INTEGRATE -- integration
;;
(defun integrate (s) (multichan-expand #'snd-integrate s))
;; S-LOG -- natural log of a sound
;;
(defun s-log (s) (multichan-expand #'nyq:log s))
;; NYQ:LOG -- log of a number or sound
;;
(defun nyq:log (s) (if (soundp s) (snd-log s) (log s)))
;; NOISE -- white noise
;;
(defun noise (&optional (dur 1.0))
(let ((d (get-duration dur)))
(snd-white *rslt* *SOUND-SRATE* d)))
(defun noise-gate (snd &optional (lookahead 0.5) (risetime 0.02) (falltime 0.5)
(floor 0.01) (threshold 0.01))
(let ((rms (lp (mult snd snd) (/ *control-srate* 10.0))))
(setf threshold (* threshold threshold))
(mult snd (gate rms lookahead risetime falltime floor threshold))))
;; QUANTIZE -- quantize a sound
;;
(defun quantize (s f) (multichan-expand #'snd-quantize s f))
;; RECIP -- reciprocal of a sound
;;
(defun recip (s) (multichan-expand #'nyq:recip s))
;; NYQ:RECIP -- reciprocal of a number or sound
;;
(defun nyq:recip (s) (if (soundp s) (snd-recip s) (/ (float s))))
;; RMS -- compute the RMS of a sound
;;
(defun rms (s &optional (rate 100.0) window-size)
(let (rslt step-size)
(cond ((not (eq (type-of s) 'SOUND))
(break "in RMS, first parameter must be a monophonic SOUND")))
(setf step-size (round (/ (snd-srate s) rate)))
(cond ((null window-size)
(setf window-size step-size)))
(setf s (prod s s))
(setf result (snd-avg s window-size step-size OP-AVERAGE))
;; compute square root of average
(s-exp (scale 0.5 (s-log result)))))
;; RESON - bandpass filter
;;
(defun reson (s c b &optional (n 0))
(multichan-expand #'nyq:reson s c b n))
(setf reson-implementations
(vector #'snd-reson #'snd-resonvc #'snd-resoncv #'snd-resonvv))
;; NYQ:RESON - bandpass filter, single channel
;;
(defun nyq:reson (signal center bandwidth normalize)
(select-implementation-1-2 reson-implementations
signal center bandwidth normalize))
;; SHAPE -- waveshaper
;;
(defun shape (snd shape origin)
(multichan-expand #'snd-shape snd shape origin))
;; SLOPE -- calculate the first derivative of a signal
;;
(defun slope (s) (multichan-expand #'nyq:slope s))
;; NYQ:SLOPE -- first derivative of single channel
;;
(defun nyq:slope (s)
(let* ((sr (snd-srate s))
(sr-inverse (/ sr)))
(snd-xform (snd-slope s) sr 0 sr-inverse MAX-STOP-TIME 1.0)))
;; lp - lowpass filter
;;
(defun lp (s c)
(multichan-expand #'nyq:lp s c))
(setf lp-implementations
(vector #'snd-tone #'snd-tonev))
;; NYQ:lp - lowpass filter, single channel
;;
(defun nyq:lp (s c)
(select-implementation-1-1 lp-implementations s c))
;;; fixed-parameter filters based on snd-biquad
;;; note: snd-biquad is implemented in biquadfilt.[ch],
;;; while BiQuad.{cpp,h} is part of STK
(setf Pi 3.14159265358979)
(defun square (x) (* x x))
(defun sinh (x) (* 0.5 (- (exp x) (exp (- x)))))
; remember that snd-biquad uses the opposite sign convention for a_i's
; than Matlab does.
; convenient biquad: normalize a0, and use zero initial conditions.
(defun nyq:biquad (x b0 b1 b2 a0 a1 a2)
(let ((a0r (/ 1.0 a0)))
(snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2)
(* a0r a1) (* a0r a2) 0 0)))
(defun biquad (x b0 b1 b2 a0 a1 a2)
(multichan-expand #'nyq:biquad x b0 b1 b2 a0 a1 a2))
; biquad with Matlab sign conventions for a_i's.
(defun biquad-m (x b0 b1 b2 a0 a1 a2)
(multichan-expand #'nyq:biquad-m x b0 b1 b2 a0 a1 a2))
(defun nyq:biquad-m (x b0 b1 b2 a0 a1 a2)
(nyq:biquad x b0 b1 b2 a0 (- a1) (- a2)))
; two-pole lowpass
(defun lowpass2 (x hz &optional (q 0.7071))
(multichan-expand #'nyq:lowpass2 x hz q))
;; NYQ:LOWPASS2 -- operates on single channel
(defun nyq:lowpass2 (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
(alpha (* sw (sinh (/ 0.5 q))))
(a0 (+ 1.0 alpha))
(a1 (* -2.0 cw))
(a2 (- 1.0 alpha))
(b1 (- 1.0 cw))
(b0 (* 0.5 b1))
(b2 b0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
; two-pole highpass
(defun highpass2 (x hz &optional (q 0.7071))
(multichan-expand #'nyq:highpass2 x hz q))
(defun nyq:highpass2 (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
(alpha (* sw (sinh (/ 0.5 q))))
(a0 (+ 1.0 alpha))
(a1 (* -2.0 cw))
(a2 (- 1.0 alpha))
(b1 (- -1.0 cw))
(b0 (* -0.5 b1))
(b2 b0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
; two-pole bandpass. max gain is unity.
(defun bandpass2 (x hz q)
(multichan-expand #'nyq:bandpass2 x hz q))
(defun nyq:bandpass2 (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
(alpha (* sw (sinh (/ 0.5 q))))
(a0 (+ 1.0 alpha))
(a1 (* -2.0 cw))
(a2 (- 1.0 alpha))
(b0 alpha)
(b1 0.0)
(b2 (- alpha)))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
; two-pole notch.
(defun notch2 (x hz q)
(multichan-expand #'nyq:notch2 x hz q))
(defun nyq:notch2 (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
(alpha (* sw (sinh (/ 0.5 q))))
(a0 (+ 1.0 alpha))
(a1 (* -2.0 cw))
(a2 (- 1.0 alpha))
(b0 1.0)
(b1 (* -2.0 cw))
(b2 1.0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
; two-pole allpass.
(defun allpass2 (x hz q)
(multichan-expand #'nyq:allpass x hz q))
(defun nyq:allpass (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
(k (exp (* -0.5 w (/ 1.0 q))))
(a0 1.0)
(a1 (* -2.0 cw k))
(a2 (* k k))
(b0 a2)
(b1 a1)
(b2 1.0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
; bass shelving EQ. gain in dB; Fc is halfway point.
; response becomes peaky at slope > 1.
(defun eq-lowshelf (x hz gain &optional (slope 1.0))
(multichan-expand #'nyq:eq-lowshelf x hz gain slope))
(defun nyq:eq-lowshelf (x hz gain slope)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(sw (sin w))
(cw (cos w))
(A (expt 10.0 (/ gain (* 2.0 20.0))))
(b (sqrt (- (/ (+ 1.0 (square A)) slope) (square (- A 1.0)))))
(apc (* cw (+ A 1.0)))
(amc (* cw (- A 1.0)))
(bs (* b sw))
(b0 (* A (+ A 1.0 (- amc) bs )))
(b1 (* 2.0 A (+ A -1.0 (- apc) )))
(b2 (* A (+ A 1.0 (- amc) (- bs) )))
(a0 (+ A 1.0 amc bs ))
(a1 (* -2.0 (+ A -1.0 apc )))
(a2 (+ A 1.0 amc (- bs) )))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
; treble shelving EQ. gain in dB; Fc is halfway point.
; response becomes peaky at slope > 1.
(defun eq-highshelf (x hz gain &optional (slope 1.0))
(multichan-expand #'nyq:eq-highshelf x hz gain slope))
(defun nyq:eq-highshelf (x hz gain slope)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(sw (sin w))
(cw (cos w))
(A (expt 10.0 (/ gain (* 2.0 20.0))))
(b (sqrt (- (/ (+ 1.0 (square A)) slope) (square (- A 1.0)))))
(apc (* cw (+ A 1.0)))
(amc (* cw (- A 1.0)))
(bs (* b sw))
(b0 (* A (+ A 1.0 amc bs )))
(b1 (* -2.0 A (+ A -1.0 apc )))
(b2 (* A (+ A 1.0 amc (- bs) )))
(a0 (+ A 1.0 (- amc) bs ))
(a1 (* 2.0 (+ A -1.0 (- apc) )))
(a2 (+ A 1.0 (- amc) (- bs) )))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
(defun nyq:eq-band (x hz gain width)
(cond ((and (numberp hz) (numberp gain) (numberp width))
(eq-band-ccc x hz gain width))
((and (soundp hz) (soundp gain) (soundp width))
(snd-eqbandvvv x hz (db-to-linear gain) width))
(t
(error "eq-band hz, gain, and width must be all numbers or all sounds"))))
; midrange EQ. gain in dB, width in octaves (half-gain width).
(defun eq-band (x hz gain width)
(multichan-expand #'nyq:eq-band x hz gain width))
(defun eq-band-ccc (x hz gain width)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(sw (sin w))
(cw (cos w))
(J (sqrt (expt 10.0 (/ gain 20.0))))
;(dummy (display "eq-band-ccc" gain J))
(g (* sw (sinh (* 0.5 (log 2.0) width (/ w sw)))))
;(dummy2 (display "eq-band-ccc" width w sw g))
(b0 (+ 1.0 (* g J)))
(b1 (* -2.0 cw))
(b2 (- 1.0 (* g J)))
(a0 (+ 1.0 (/ g J)))
(a1 (- b1))
(a2 (- (/ g J) 1.0)))
(biquad x b0 b1 b2 a0 a1 a2)))
; see failed attempt in eub-reject.lsp to do these with higher-order fns:
; four-pole Butterworth lowpass
(defun lowpass4 (x hz)
(lowpass2 (lowpass2 x hz 0.60492333) hz 1.33722126))
; six-pole Butterworth lowpass
(defun lowpass6 (x hz)
(lowpass2 (lowpass2 (lowpass2 x hz 0.58338080)
hz 0.75932572)
hz 1.95302407))
; eight-pole Butterworth lowpass
(defun lowpass8 (x hz)
(lowpass2 (lowpass2 (lowpass2 (lowpass2 x hz 0.57622191)
hz 0.66045510)
hz 0.94276399)
hz 2.57900101))
; four-pole Butterworth highpass
(defun highpass4 (x hz)
(highpass2 (highpass2 x hz 0.60492333) hz 1.33722126))
; six-pole Butterworth highpass
(defun highpass6 (x hz)
(highpass2 (highpass2 (highpass2 x hz 0.58338080)
hz 0.75932572)
hz 1.95302407))
; eight-pole Butterworth highpass
(defun highpass8 (x hz)
(highpass2 (highpass2 (highpass2 (highpass2 x hz 0.57622191)
hz 0.66045510)
hz 0.94276399)
hz 2.57900101))
; YIN
; maybe this should handle multiple channels, etc.
(setfn yin snd-yin)
; FOLLOW
(defun follow (sound floor risetime falltime lookahead)
;; use 10000s as "infinite" -- that's about 2^30 samples at 96K
(setf lookahead (round (* lookahead (snd-srate sound))))
(extract (/ lookahead (snd-srate sound)) 10000
(snd-follow sound floor risetime falltime lookahead)))
(defun gate (sound floor risetime falltime lookahead threshold)
(setf lookahead (round (* lookahead (snd-srate sound))))
(setf lookahead (/ lookahead (snd-srate sound)))
(extract lookahead 10000
(snd-gate sound lookahead risetime falltime floor threshold)))

163
nyquist/envelopes.lsp Normal file
View File

@@ -0,0 +1,163 @@
;; envelopes.lsp -- support functions for envelope editor in jNyqIDE
#| In Nyquist, editable envelopes are saved as one entry in the workspace
named *envelopes*. The entry is an association list where each element
looks like this:
(name type parameters... )
where name is a symbol, e.g. MY-ENVELOPE-1,
type is a function name, e.g. PWL, PWLV, PWE, etc., and
parameters are breakpoint data, e.g. 0.1 1 0.2 0.5 1
Example of two envelopes named FOO and BAR:
((FOO PWL 0.1 1 1) (BAR PWE 0.2 1 1))
To convert envelope data into functions, call (MAKE-ENV-FUNCTIONS).
This function should be on the workspace's list of functions to call.
(See ADD-ACTION-TO-WORKSPACE in Nyquist Manual.)
When the jNyqIDE wants to get the envelope data from the workspace, it
should call (GET-ENV-DATA), which will dump formatted data to Nyquist's
standard output as follows:
get-env-data: begin
name (type parameters...) newline
name (type parameters...) newline
...
get-env-data: end
When the IDE wants to save a definition, it should call
(DEFINE-ENV 'NAME 'EXPRESSION)
To delete a definition, call:
(DELETE-ENV 'NAME)
Envelope data will be loaded when the editor window is opened and saved
whenever the user issues a "save" command. If the user switches envelopes
without saving, there is a prompt to save or ignore.
The user will also be prompted to save when the editor window is closed
or when Nyquist is exited.
Saving the workspace automatically is something that Nyquist should do
(or prompt the user to do) when it exits.
|#
;; WORKSPACE -- the workspace is just a set of variables, typically
;; with scores as values. These are stored in the file workspace.lsp
;; so that you can work on some data and then store it for use later.
(cond ((not (boundp '*workspace*))
(setf *workspace* nil)))
(cond ((not (boundp '*workspace-actions*))
(setf *workspace-actions* nil)))
;; one of the variables in the workspace is *envelopes*
(cond ((not (boundp '*envelopes*))
(setf *envelopes* nil)))
;; DESCRIBE -- add a description to a global variable
;;
(defun describe (symbol &optional description)
(add-to-workspace symbol)
(cond (description
(putprop symbol description 'description))
(t
(get symbol 'description))))
;; ADD-TO-WORKSPACE -- add a global symbol to workspace
;;
(defun add-to-workspace (symbol)
(cond ((not (symbolp symbol))
(format t "add-to-workspace expects a (quoted) symbol~%"))
((not (member symbol *workspace*))
(push symbol *workspace*))))
;; ADD-ACTION-TO-WORKSPACE -- call function when workspace is loaded
;;
(defun add-action-to-workspace (symbol)
(cond ((not (symbolp symbol))
(format t "add-action-to-workspace expects a (quoted) symbol~%"))
((not (member symbol *workspace-actions*))
(push symbol *workspace-actions*))))
;; SAVE-WORKSPACE -- write data to file
;;
(defun save-workspace ()
(let (val (outf (open "workspace.lsp" :direction :output)))
(dolist (sym *workspace*)
(format outf "(add-to-workspace '~A)~%" sym)
(cond ((get sym 'description)
(format outf "(putprop '~A \"~A\" 'description)~%"
sym (get sym 'description))))
(format outf "(setf ~A '" sym)
(setf val (symbol-value sym))
(cond ((listp val)
(format outf "(~%")
(dolist (elem val)
(format outf " ~A~%" elem))
(format outf " ))~%~%"))
(t
(format outf "~A)~%~%" val))))
(dolist (sym *workspace-actions*) ;; call hooks after reading data
(format outf "(add-action-to-workspace '~A)~%" sym)
(format outf "(if (fboundp '~A) (~A))~%" sym sym))
(format outf "(princ \"workspace loaded\\n\")~%")
(close outf)
(princ "workspace saved\n")
nil))
;; DEFINE-ENV -- save the env data and make corresponding function
;;
(defun define-env (name expression)
(delete-env name)
(push (cons name expression) *envelopes*)
(make-env-function name expression)
; make sure envelopes are redefined when workspace is loaded
(add-to-workspace '*envelopes*) ; so *envelopes* will be saved
(describe '*envelopes* "data for envelope editor in jNyqIDE")
(add-action-to-workspace 'make-env-functions)
nil)
;; DELETE-ENV -- delete an envelope definition from workspace
;;
;; note that this will not undefine the corresponding envelope function
;;
(defun delete-env (name)
(setf *envelopes*
(remove name *envelopes*
:test #'(lambda (key item) (eql key (car item))))))
;; MAKE-ENV-FUNCTION -- convert data to a defined function
;;
(defun make-env-function (name expression)
(setf (symbol-function name)
(eval (list 'lambda '() expression))))
;; MAKE-ENV-FUNCTIONS -- convert data to defined functions
;;
(defun make-env-functions ()
(let (name type parameters)
(dolist (env *envelopes*)
(setf name (car env))
(setf type (cadr env))
(setf parameters (cddr env))
(make-env-function name (cons type parameters)))))
;; GET-ENV-DATA -- print env data for IDE
;;
(defun get-env-data ()
(princ "get-env-data: begin\n")
(dolist (env *envelopes*)
(format t "~A ~A~%" (car env) (cdr env)))
(princ "get-env-data: end\n")
nil)

75
nyquist/equalizer.lsp Normal file
View File

@@ -0,0 +1,75 @@
;; equalizer.lsp -- support functions for equalizer editor in jNyqIDE
#| This is modeled after envelopes.lsp, which details how envelope data is
exchanged between Nyquist and jNyqIDE.
The jNyqIDE code needs some work to make it look like the envelope
editor (which also needs work, but that's another matter). For consistency,
both should support named envelopes and equalizers.
However, for now, we have equalizers numbered from 0 to 9. The format for
exchange will be:
get-eq-data: begin
name parameters newline
name parameters newline
...
get-eq-data: end
and when the IDE wants to save a definition, it should call
(DEFINE-EQ 'NAME 'PARAMETER-LIST)
|#
(cond ((not (boundp '*equalizers*))
(setf *equalizers* nil)))
;; DEFINE-EQ -- save the eq data and make corresponding function
;;
(defun define-eq (name expression)
(setf *equalizers* (remove name *equalizers*
:test #'(lambda (key item) (eql key (car item)))))
(push (list name expression) *equalizers*)
(make-eq-function name expression)
; make sure equalizers are redefined when workspace is loaded
(add-to-workspace '*equalizers*)
(describe '*equalizers* "data for equalizers in jNyqIDE")
(add-action-to-workspace 'make-eq-functions)
nil)
;; MAKE-EQ-FUNCTION -- convert data to a defined function
;;
(defun make-eq-function (name parameters)
(cond ((numberp name)
(setf name (intern (format nil "EQ-~A" name)))))
(if (not (boundp '*grapheq-loaded*)) (load "grapheq.lsp"))
(setf (symbol-function name)
(eval `(lambda (s) (nband-range s ',parameters 60 14000)))))
;; MAKE-EQ-FUNCTIONS -- convert data to defined functions
;;
(defun make-eq-functions ()
(let (name type parameters)
(dolist (eq *equalizers*)
(setf name (car eq))
(setf parameters (second parameters))
(make-eq-function name parameters))))
;; GET-EQ-DATA -- print env data for IDE
;;
(defun get-eq-data ()
(let (parameters)
(princ "get-eq-data: begin\n")
(dolist (env *equalizers*)
(format t "~A" (car env))
(setf parameters (second env))
(dotimes (i (length parameters))
(format t " ~A" (aref parameters i)))
(format t "~%"))
(princ "get-eq-data: end\n")
nil))

36
nyquist/evalenv.lsp Normal file
View File

@@ -0,0 +1,36 @@
;;
;; The EVAL function in the original XLISP evaluated in the current lexical
;; context. This was changed to evaluate in the NIL (global) context to
;; match Common Lisp. But this created a problem: how do you EVAL an
;; expression in the current lexical context?
;;
;; The answer is you can use the evalhook facility. The evalhook function
;; will evaluate an expression using an environment given to it as an
;; argument. But then the problem is "how do you get the current
;; environment?" Well the getenv macro, below obtains the environent by
;; using an *evalhook* form.
;;
;; The following two macros do the job. Insteading of executing (eval <expr>)
;; just execute (eval-env <expr>). If you want, you can dispense with the
;; macros and execute:
;;
;;(evalhook <expr> nil nil (let ((*evalhook* (lambda (x env) env)))
;; (eval nil)))
;;
;; Tom Almy 10/91
;;
(defmacro getenv ()
'(progv '(*evalhook*)
(list #'(lambda (exp env) env))
(eval nil)))
; this didn't work, may be for a later (Almy) version of xlisp?
;(defmacro getenv ()
; '(let ((*evalhook* (lambda (x env) env)))
; (eval nil))) ; hook function evaluates by returning
; environment
(defmacro eval-env (arg) ; evaluate in current environment
`(evalhook ,arg nil nil (getenv)))

304
nyquist/fileio.lsp Normal file
View File

@@ -0,0 +1,304 @@
;; fileio.lsp
;; if *default-sf-dir* undefined, set it to user's tmp directory
;;
(cond ((not (boundp '*default-sf-dir*))
;; it would be nice to use get-temp-path, but when running
;; the Java-based IDE, Nyquist does not get environment
;; variables to tell TMP or TEMP or USERPROFILE
;; We want to avoid the current directory because it may
;; be read-only. Search for some likely paths...
;; Note that since these paths don't work for Unix or OS X,
;; they will not be used, so no system-dependent code is
;; needed
(let ((current (setdir ".")))
(setf *default-sf-dir*
(or (setdir "c:\\tmp\\")
(setdir "c:\\temp\\")
(setdir "d:\\tmp\\")
(setdir "d:\\temp\\")
(setdir "e:\\tmp\\")
(setdir "e:\\temp\\")
(get-temp-path)))
(format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%"
*default-sf-dir*)
(setdir current))))
;; s-save -- saves a file
(setf NY:ALL 1000000000) ; 1GIG constant for maxlen
(defmacro s-save (expression &optional (maxlen NY:ALL) filename
&key (format '*default-sf-format*)
(mode '*default-sf-mode*) (bits '*default-sf-bits*)
(endian NIL) ; nil, :big, or :little -- specifies file format
(play nil))
`(let ((ny:fname ,filename)
(ny:maxlen ,maxlen)
(ny:endian ,endian)
(ny:swap 0))
; allow caller to omit maxlen, in which case the filename will
; be a string in the maxlen parameter position and filename will be null
(cond ((null ny:fname)
(cond ((stringp ny:maxlen)
(setf ny:fname ny:maxlen)
(setf ny:maxlen NY:ALL))
(t
(setf ny:fname *default-sound-file*)))))
(cond ((equal ny:fname "")
(cond ((not ,play)
(format t "s-save: no file to write! play option is off!\n"))))
(t
(setf ny:fname (soundfilename ny:fname))
(format t "Saving sound file to ~A~%" ny:fname)))
(cond ((eq ny:endian :big)
(setf ny:swap (if (bigendianp) 0 1)))
((eq ny:endian :little)
(setf ny:swap (if (bigendianp) 1 0))))
(snd-save ',expression ny:maxlen ny:fname ,format ,mode ,bits ny:swap ,play)))
;; MULTICHANNEL-MAX -- find peak over all channels
;;
(defun multichannel-max (snd samples)
(cond ((soundp snd)
(snd-max snd samples))
((arrayp snd) ;; assume it is multichannel sound
(let ((peak 0.0) (chans (length snd)))
(dotimes (i chans)
(setf peak (max peak (snd-max (aref snd i) (/ samples chans)))))
peak))
(t (error "unexpected value in multichannel-max" snd))))
;; AUTONORM -- look ahead to find peak and normalize sound to 80%
;;
(defun autonorm (snd)
(let (peak)
(cond (*autonormflag*
(cond ((and (not (soundp snd))
(not (eq (type-of snd) 'ARRAY)))
(error "AUTONORM (or PLAY?) got unexpected value" snd))
((eq *autonorm-type* 'previous)
(scale *autonorm* snd))
((eq *autonorm-type* 'lookahead)
(setf peak (multichannel-max snd *autonorm-max-samples*))
(setf peak (max 0.001 peak))
(setf *autonorm* (/ *autonorm-target* peak))
(scale *autonorm* snd))
(t
(error "unknown *autonorm-type*"))))
(t snd))))
(defmacro s-save-autonorm (expression &rest arglist)
`(let ((peak (s-save (autonorm ,expression) ,@arglist)))
(autonorm-update peak)))
;; The "AutoNorm" facility: when you play something, the Nyquist play
;; command will automatically compute what normalization factor you
;; should have used. If you play the same thing again, the normalization
;; factor is automatically applied.
;;
;; Call AUTONORM-OFF to turn off this feature, and AUTONORM-ON to turn
;; it back on.
;;
;; *autonorm-target* is the peak value we're aiming for (it's set below 1
;; so allow the next signal to get slightly louder without clipping)
;;
(init-global *autonorm-target* 0.9)
;;
;; *autonorm-type* selects the autonorm algorithm to use
;; 'previous means normalize according to the last computed sound
;; 'precompute means precompute *autonorm-max-samples* samples in
;; memory and normalize according to the peak
;;
(init-global *autonorm-type* 'lookahead)
(init-global *autonorm-max-samples* 1000000) ; default is 4MB buffer
;;
(defun autonorm-on ()
(setf *autonorm* 1.0)
(setf *autonorm-previous-peak* 1.0)
(setf *autonormflag* t)
(format t "AutoNorm feature is on.~%"))
(if (not (boundp '*autonormflag*)) (autonorm-on))
(defun autonorm-off ()
(setf *autonormflag* nil)
(setf *autonorm* 1.0)
(format t "AutoNorm feature is off.~%"))
;; AUTONORM-UPDATE -- called with true peak to report and prepare
;;
;; after saving/playing a file, we have the true peak. This along
;; with the autonorm state is printed in a summary and the autonorm
;; state is updated for next time.
;;
;; There are currently two types: PREVIOUS and LOOKAHEAD
;; With PREVIOUS:
;; compute the true peak and print the before and after peak
;; along with the scale factor to be used next time
;; With LOOKAHEAD:
;; compute the true peak and print the before and after peak
;; along with the "suggested scale factor" that would achieve
;; the *autonorm-target*
;;
(defun autonorm-update (peak)
(cond ((> peak 1.0)
(format t "*** CLIPPING DETECTED! ***~%")))
(cond ((and *autonormflag* (> peak 0.0))
(setf *autonorm-previous-peak* (/ peak *autonorm*))
(setf *autonorm* (/ *autonorm-target* *autonorm-previous-peak*))
(format t "AutoNorm: peak was ~A,~%" *autonorm-previous-peak*)
(format t " peak after normalization was ~A,~%" peak)
(format t (if (eq *autonorm-type* 'PREVIOUS)
" new normalization factor is ~A~%"
" suggested normalization factor is ~A~%")
*autonorm*))
(t
(format t "Peak was ~A,~%" peak)
(format t " suggested normalization factor is ~A~%"
(/ *autonorm-target* peak)))
peak
))
;; s-read -- reads a file
(defun s-read (filename &key (time-offset 0) (srate *sound-srate*)
(dur 10000.0) (nchans 1) (format *default-sf-format*)
(mode *default-sf-mode*) (bits *default-sf-bits*) (endian NIL))
(let ((swap 0))
(cond ((eq endian :big)
(setf swap (if (bigendianp) 0 1)))
((eq endian :little)
(setf swap (if (bigendianp) 1 0))))
(if (minusp dur) (error "s-read :dur is negative" dur))
(snd-read (soundfilename filename) time-offset
(local-to-global 0) format nchans mode bits swap srate
dur)))
;; SF-INFO -- print sound file info
;;
(defun sf-info (filename)
(let (s format channels mode bits swap srate dur flags)
(format t "~A:~%" (soundfilename filename))
(setf s (s-read filename))
(setf format (car *rslt*))
(setf channels (cadr *rslt*))
(setf mode (caddr *rslt*))
(setf bits (cadddr *rslt*))
(setf *rslt* (cddddr *rslt*))
(setf swap (car *rslt*))
(setf srate (cadr *rslt*))
(setf dur (caddr *rslt*))
(setf flags (cadddr *rslt*))
(format t "Format: ~A~%"
(nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX"
"NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK"
"SDS" "AVR" "SD2" "FLAC" "CAF")))
(cond ((setp (logand flags snd-head-channels))
(format t "Channels: ~A~%" channels)))
(cond ((setp (logand flags snd-head-mode))
(format t "Mode: ~A~%"
(nth mode '("ADPCM" "PCM" "uLaw" "aLaw" "Float" "UPCM"
"unknown" "double" "GSM610" "DWVW" "DPCM"
"msadpcm")))))
(cond ((setp (logand flags snd-head-bits))
(format t "Bits/Sample: ~A~%" bits)))
(cond ((setp (logand flags snd-head-srate))
(format t "SampleRate: ~A~%" srate)))
(cond ((setp (logand flags snd-head-dur))
(format t "Duration: ~A~%" dur)))
))
;; SETP -- tests whether a bit is set (non-zero)
;
(defun setp (bits) (not (zerop bits)))
;; IS-FILE-SEPARATOR -- is this a file path separation character, e.g. "/"?
;;
(defun is-file-separator (c)
(or (eq c *file-separator*)
(and (eq *file-separator* #\\) ;; if this is windows (indicated by "\")
(eq c #\/)))) ;; then "/" is also a file separator
;; SOUNDFILENAME -- add default directory to name to get filename
;;
(defun soundfilename (filename)
(cond ((= 0 (length filename))
(break "filename must be at least one character long" filename))
((full-name-p filename))
(t
; if sf-dir nonempty and does not end with filename separator,
; append one
(cond ((and (< 0 (length *default-sf-dir*))
(not (is-file-separator
(char *default-sf-dir*
(1- (length *default-sf-dir*))))))
(setf *default-sf-dir* (strcat *default-sf-dir* (string *file-separator*)))
(format t "Warning: appending \"~A\" to *default-sf-dir*~%"
*file-separator*)))
(setf filename (strcat *default-sf-dir* (string filename)))))
;; now we have a file name, but it may be relative to current directory, so
;; expand it with the current directory
(cond ((relative-path-p filename)
;; get current working directory and build full name
(let ((path (setdir ".")))
(cond (path
(setf filename (strcat path (string *file-separator*)
(string filename))))))))
filename)
(setfn s-read-format car)
(setfn s-read-channels cadr)
(setfn s-read-mode caddr)
(setfn s-read-bits cadddr)
(defun s-read-swap (rslt) (car (cddddr rslt)))
(defun s-read-srate (rslt) (cadr (cddddr rslt)))
(defun s-read-dur (rslt) (caddr (cddddr rslt)))
(defun s-read-byte-offset (rslt) (car (cddddr (cddddr rslt))))
;; round is tricky because truncate rounds toward zero as does C
;; in other words, rounding is down for positive numbers and up
;; for negative numbers. You can convert rounding up to rounding
;; down by subtracting one, but this fails on the integers, so
;; we need a special test if (- x 0.5) is an integer
(defun round (x)
(cond ((> x 0) (truncate (+ x 0.5)))
((= (- x 0.5) (truncate (- x 0.5))) (truncate x))
(t (truncate (- x 0.5)))))
;; change defaults for PLAY macro:
(init-global *soundenable* t)
(defun sound-on () (setf *soundenable* t))
(defun sound-off () (setf *soundenable* nil))
(defmacro s-add-to (expr maxlen filename &optional (time-offset 0.0))
`(let ((ny:fname (soundfilename ,filename))
ny:peak ny:input (ny:offset ,time-offset))
(format t "Adding sound to ~A at offset ~A~%"
ny:fname ,time-offset)
(setf ny:peak (snd-overwrite '(let ((ny:addend ,expr))
(sum (snd-coterm
(s-read ny:fname
:time-offset ny:offset)
ny:addend)
ny:addend))
,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0))
(format t "Duration written: ~A~%" (car *rslt*))
ny:peak))
(defmacro s-overwrite (expr maxlen filename &optional (time-offset 0.0))
`(let ((ny:fname (soundfilename ,filename))
(ny:peak 0.0)
ny:input ny:rslt ny:offset)
(format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset)
(setf ny:offset (s-read-byte-offset ny:rslt))
(setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname time-offset
0, 0, 0, 0.0, 0))
(format t "Duration written: ~A~%" (car *rslt*))
ny:peak))

70
nyquist/follow.lsp Normal file
View File

@@ -0,0 +1,70 @@
;(set-control-srate 100)
;(set-sound-srate 100)
;(setf xx (pwl 0 1 1 0 1.1 1 1.8 0 2 1 3 0 5))
;(setf xx (pwl 0 1 1 .2 1.1 1 1.8 .2 2 1 3 0 5))
;(setf yy (snd-follow xx 0.1 0.25 1.0 30))
;(setf db-factor (/ 1.0 (log 0.00001)))
; COMPRESS-MAP -- constructs a map for the compress function
;
; The map consists of two parts: a compression part and an expansion part.
; The intended use is to compress everything above compress-threshold by
; compress-ratio, and to downward expand everything below expand-ratio
; by expand-ratio. Thresholds are in dB and ratios are dB-per-dB.
; 0dB corresponds to an amplitude of 1.0
; If the input goes above 0dB, the output can optionally be limited
; by seting limit-flag to T. This effectively changes the compression
; ratio to infinity at 0dB. If limit-flag is NIL, then the compression-ratio
; continues to apply above 0dB.
; It is assumed that expand-threshold <= compress-threshold <= 0
; The gain is unity at 0dB so if compression-ratio > 1, then gain
; will be greater than unity below 0dB
;(defun compress-map (compress-ratio compress-threshold expand-ratio
; expand-threshold limit-flag)
; (let ()
; (
;; I'm not sure if the rest of this function was lost due to version
;; problems, or it never existed. Email to rbd@cs.cmu.edu if you would
;; like some help with dynamics compression.
;;
;; Also, I had a really great 2-stage compressor for speech -- it did
;; something like a noise gate with a short time constant, and an automatic
;; gain control with a long time constant. Each one varied the gain by
;; about 12 dB -- any more would cause really ugly noise pumping, but
;; without the combined actions of both, there was not enough control.
;; Again, email me if you are interested. Lately, I've been using
;; more sophisticated multiple band noise reduction in Cool Edit. They
;; obviously put a lot of work into that, and I don't plan to redo the
;; work for Nyquist. -RBD
(defun compress (input map rise-time fall-time)
; take the square of the input to get power
(let ((in-squared (mult input input)))
; compute the time-average (sort of a low-pass) of the square
(setf avg (snd-avg in-squared 1000 500 OP-AVERAGE))
; use follower to anticipate rise and trail off smoothly
(setf env (snd-follow avg 0.001 0.2 1.0 20))
; take logarithm to get dB instead of linear
(setf logenv (snd-log env))
; tricky part: map converts dB of input to desired gain in dB
; this defines the character of the compressor
(setf shaped-env (shape logenv map 1.0))
; go back to linear
(setf gain (snd-exp shaped-env))
; return the scaled input sound,
; another trick: avg signal will be delayed. Also, snd-follow
; has a delayed response because it's looking ahead in sound
; 20 = the number of samples of lookahead from snd-follow
; 88.2 = 44,100 (sample rate) / 500 (the step-size in avg)
; in other words, 44100/500 is the sample rate of the control
; signal looked at by follow
; "44100" should be replace by the signal's sample rate
; = (snd-srate input)
(mult (seq (s-rest (/ 20.0 88.2)) (cue input)) gain)))

8
nyquist/init.lsp Normal file
View File

@@ -0,0 +1,8 @@
; init.lsp -- default Nyquist startup file
(load "nyinit.lsp" :verbose nil)
; add your customizations here:
; e.g. (setf *default-sf-dir* "...")
; (load "test.lsp")

154
nyquist/misc.lsp Normal file
View File

@@ -0,0 +1,154 @@
;## misc.lsp -- a collection of useful support functions
;; Garbage collection "improvement" -- XLISP will GC without allocation
;; as long as it does not run out of cells. This can make it very slow
;; since GC does work proportional to the heap size. If there were
;; always at least, say, 1/3 of the heap free after GC, then allocating
;; cells would be more-or-less a constant time operation (amortized).
;;
;; So, after GC, we'll expand until we have 1/3 of the heap free.
;;
(defun ny:gc-hook (heap-size free-cells)
(cond ((< (* free-cells 2) heap-size) ;; free cells is < 1/3 heap
;; expand. Each expansion unit is 2000 cons cells
(let* ((how-many-not-free (- heap-size free-cells))
(should-be-free (/ how-many-not-free 2))
(how-many-more (- should-be-free free-cells))
(expand-amount (/ how-many-more 2000)))
(cond ((> expand-amount 0)
(if *gc-flag*
(format t
"[ny:gc-hook allocating ~A more cells] "
(* expand-amount 2000)))
(expand expand-amount)))))))
(setf *gc-hook* 'ny:gc-hook)
; set global if not already set
;
(defmacro init-global (symb expr)
`(if (boundp ',symb) ,symb (setf ,symb ,expr)))
; enable or disable breaks
(defun bkon () (setq *breakenable* T))
(defun bkoff () (setq *breakenable* NIL))
(bkon)
;; (grindef 'name) - pretty print a function
;;
(defun grindef (e) (pprint (get-lambda-expression (symbol-function e))))
;; (args 'name) - print function and its formal arguments
;;
(defun args (e)
(pprint (cons e (second (get-lambda-expression (symbol-function e))))))
;; (incf <place>), (decf <place>) - add/sub 1 to/from variable
;;
(defmacro incf (symbol) `(setf ,symbol (1+ ,symbol)))
(defmacro decf (symbol) `(setf ,symbol (1- ,symbol)))
;; (push val <place>) - cons val to list
;;
(defmacro push (val lis) `(setf ,lis (cons ,val ,lis)))
(defmacro pop (lis) `(prog1 (car ,lis) (setf ,lis (cdr ,lis))))
;; include this to use RBD's XLISP profiling hooks
;;(load "/afs/andrew/usr/rbd/lib/xlisp/profile.lsp")
;(cond ((boundp 'application-file-name)
; (load application-file-name)))
(defun get-input-file-name ()
(let (fname)
(format t "Input file name: ")
(setf fname (read-line))
(cond ((equal fname "") (get-input-file-name))
(t fname))))
(defun open-output-file ()
(let (fname)
(format t "Output file name: ")
(setf fname (read-line))
(cond ((equal fname "") t)
(t (open fname :direction :output)))))
(defmacro while (cond &rest stmts)
`(prog () loop (if ,cond () (return)) ,@stmts (go loop)))
; when parens/quotes don't match, try this
;
(defun file-sexprs ()
(let ((fin (open (get-input-file-name)))
inp)
(while (setf inp (read fin)) (print inp))))
;; get path for currently loading file (if any)
;;
(defun current-path ()
(let (fullpath n)
(setf n -1)
(cond (*loadingfiles*
(setf fullpath (car *loadingfiles*))
(dotimes (i (length fullpath))
(cond ((equal (char fullpath i) *file-separator*)
(setf n i))))
(setf fullpath (subseq fullpath 0 (1+ n)))
;; REMOVED SUPPORT FOR MAC OS-9 AND BELOW -RBD
;; if this is a Mac, use ':' in place of empty path
;; (cond ((and (equal fullpath "")
;; (equal *file-separator* #\:))
;; (setf fullpath ":")))
;; END MAC OS-9 CODE
;; Here's an interesting problem: fullpath is now the path
;; specified to LOAD, but it may be relative to the current
;; directory. What if we want to load a sound file from the
;; current directory? It seems that S-READ gives priority to
;; the *DEFAULT-SF-DIR*, so it will follow fullpath STARTING
;; FROM *DEFAULT-SF-DIR*. To fix this, we need to make sure
;; that fullpath is either an absolute path or starts with
;; and explicit ./ which tells s-read to look in the current
;; directory.
(cond ((> (length fullpath) 0)
(cond ((full-name-p fullpath))
(t ; not absolute, make it explicitly relative
(setf fullpath (strcat "./" fullpath)))))
(t (setf fullpath "./"))) ; use current directory
fullpath)
(t nil))))
;; real-random -- pick a random real from a range
;;
(defun real-random (from to)
(+ (* (rrandom) (- to from)) from))
;; power -- raise a number to some power x^y
;;
(defun power (x y)
(exp (* (log (float x)) y)))
;; require-from -- load a file if a function is undefined
;;
;; fn-symbol -- the function defined when the file is loaded
;; file-name -- the name of file to load if fn-symbol is undefined
;; path -- if t, load from current-path; if a string, prepend string
;; to file-name; if nil, ignore it
;;
(defmacro require-from (fn-symbol file-name &optional path)
(cond ((eq path t)
(setf file-name `(strcat (current-path) ,file-name)))
(path
(setf file-name `(strcat ,path ,file-name))))
`(if (fboundp (quote ,fn-symbol))
t
(load ,file-name)))

38
nyquist/nyinit.lsp Normal file
View File

@@ -0,0 +1,38 @@
(expand 5)
(load "xlinit.lsp" :verbose NIL)
(setf *gc-flag* nil)
(load "misc.lsp" :verbose NIL)
(load "evalenv.lsp" :verbose NIL)
(load "printrec.lsp" :verbose NIL)
(load "sndfnint.lsp" :verbose NIL)
(load "seqfnint.lsp" :verbose NIL)
(load "dspprims.lsp" :verbose NIL)
(load "nyquist.lsp" :verbose NIL)
(load "follow.lsp" :verbose NIL)
(load "system.lsp" :verbose NIL)
(load "seqmidi.lsp" :verbose NIL)
(load "nyqmisc.lsp" :verbose NIL)
(load "stk.lsp" :verbose NIL)
(load "envelopes.lsp" :verbose NIL)
(load "equalizer.lsp" :verbose NIL)
(load "xm.lsp" :verbose NIL)
(load "sal.lsp" :verbose NIL)
;; set to T to get ANSI headers and NIL to get antique headers
(setf *ANSI* NIL)
;; set to T to generate tracing code, NIL to disable tracing code
(setf *WATCH* NIL)
(format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%")
(format t " Copyright (c) 1991,1992,1995,2007-2009 by Roger B. Dannenberg~%")
(format t " Version 3.03~%~%")
;(setf *gc-flag* t)

27
nyquist/nyqmisc.lsp Normal file
View File

@@ -0,0 +1,27 @@
;; nyqmisc.lsp -- misc functions for nyquist
(init-global *snd-display-max-samples* 10000)
(init-global *snd-display-print-samples* 100)
; (snd-display sound) -- describe a sound
(defun snd-display (sound)
(let (t0 srate len extent dur samples)
(setf srate (snd-srate sound))
(setf t0 (snd-t0 sound))
(setf len (snd-length sound *snd-display-max-samples*))
(cond ((= len *snd-display-max-samples*)
(setf extent (format nil ">~A" (+ t0 (* srate *snd-display-max-samples*))))
(setf dur (format nil ">~A" (* srate *snd-display-max-samples*))))
(t
(setf extent (cadr (snd-extent sound *snd-display-max-samples*)))
(setf dur (/ (snd-length sound *snd-display-max-samples*) srate))))
(cond ((> len 100)
(setf samples (format nil "1st ~A samples" *snd-display-print-samples*))
(setf nsamples *snd-display-print-samples*))
(t
(setf samples (format nil "~A samples" len))
(setf nsamples len)))
(format t "~A: srate ~A, t0 ~A, extent ~A, dur ~A, ~A: ~A"
sound srate t0 extent dur samples (snd-samples sound nsamples))))

3
nyquist/nyquist-plot.txt Normal file
View File

@@ -0,0 +1,3 @@
set nokey
plot "points.dat" with lines

1708
nyquist/nyquist.lsp Normal file
View File

File diff suppressed because it is too large Load Diff

30
nyquist/printrec.lsp Normal file
View File

@@ -0,0 +1,30 @@
; prints recursive list structure
;(let (seen-list)
(setf seenlist nil)
(defun seenp (l) (member l seenlist :test 'eq))
(defun make-seen (l) (setf seenlist (cons l seenlist)))
(defun printrec (l) (printrec-any l) (setf seenlist nil))
(defun printrec-any (l)
(cond ((atom l) (prin1 l) (princ " "))
((seenp l) (princ "<...> "))
(t
(make-seen l)
(princ "(")
(printrec-list l)
(princ ") ")))
nil)
(defun printrec-list (l)
(printrec-any (car l))
(cond ((cdr l)
(cond ((seenp (cdr l))
(princ "<...> "))
((atom (cdr l))
(princ ". ")
(prin1 (cdr l))
(princ " "))
(t
(make-seen (cdr l))
(printrec-list (cdr l))))))
nil)
; )

27
nyquist/profile.lsp Normal file
View File

@@ -0,0 +1,27 @@
; profile.lsp -- support for profiling
;## show-profile -- print profile data
(defun show-profile ()
(let ((profile-flag (profile nil)) (total 0))
(dolist (name *PROFILE*)
(setq total (+ total (get name '*PROFILE*))))
(dolist (name *PROFILE*)
(format t "~A (~A%): ~A~%"
(get name '*PROFILE*)
(truncate
(+ 0.5 (/ (float (* 100 (get name '*PROFILE*)))
total)))
name))
(format t "Total: ~A~%" total)
(profile profile-flag)))
;## start-profile -- clear old profile data and start profiling
(defun start-profile ()
(profile nil)
(dolist (name *PROFILE*)
(remprop name '*PROFILE*))
(setq *PROFILE* nil)
(profile t))

BIN
nyquist/rawwaves/mand1.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand10.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand11.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand12.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand2.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand3.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand4.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand5.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand6.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand7.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand8.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mand9.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/mandpluk.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/marmstk1.raw Normal file
View File

Binary file not shown.

BIN
nyquist/rawwaves/sinewave.raw Normal file
View File

Binary file not shown.

1818
nyquist/sal-parse.lsp Normal file
View File

File diff suppressed because it is too large Load Diff

555
nyquist/sal.lsp Normal file
View File

@@ -0,0 +1,555 @@
;;; **********************************************************************
;;; Copyright (C) 2006 Rick Taube
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser Gnu Public License.
;;; See http://www.cliki.net/LLGPL for the text of this agreement.
;;; **********************************************************************
;;; $Revision: 1.2 $
;;; $Date: 2009-03-05 17:42:25 $
;; DATA STRUCTURES AND ALGORITHMS (for sal.lsp and parse.lsp)
;;
;; TOKENIZE converts source language (a string) into a list of tokens
;; each token is represented as follows:
;; (:TOKEN <type> <string> <start> <info> <lisp>)
;; where <type> is one of:
;; :id -- an identifier
;; :lp -- left paren
;; :rp -- right paren
;; :+, etc. -- operators
;; :int -- an integer
;; :float -- a float
;; :print, etc. -- a reserved word
;; <string> is the source string for the token
;; <start> is the column of the string
;; <info> and <lisp> are ??
;; Tokenize uses a list of reserved words extracted from terminals in
;; the grammar. Each reserved word has an associated token type, but
;; all other identifiers are simply of type :ID.
;;
;; *** WHY REWRITE THE ORIGINAL PARSER? ***
;; Originally, the code interpreted a grammar using a recursive pattern
;; matcher, but XLISP does not have a huge stack and there were
;; stack overflow problems because even relatively small expressions
;; went through a very deep nesting of productions. E.g.
;; "print note(between(30,odds(.5, 60, 90)))" 0 t nil))" was at recursion
;; level 46 when the stack overflowed. The stack depth is 2000 or 4000,
;; but all locals and parameters get pushed here, so since PARSE is the
;; recursive function and it has lots of parameters and locals, it appears
;; to use 80 elements in the stack per call.
;; *** END ***
;;
;; The grammar for the recursive descent parser:
;; note: [ <x> ] means optional <x>, <x>* means 0 or more of <x>
;;
;; <number> = <int> | <float>
;; <atom> = <int> | <float> | <id> | <bool>
;; <list> = { <elt>* }
;; <elt> = <atom> | <list> | <string>
;; <aref> = <id> <lb> <pargs> <rb>
;; <ifexpr> = ? "(" <sexpr> , <sexpr> [ , <sexpr> ] ")"
;; <funcall> = <id> <funargs>
;; <funargs> = "(" [ <args> ] ")"
;; <args> = <arg> [ , <arg> ]*
;; <arg> = <sexpr> | <key> <sexpr>
;; <op> = + | - | "*" | / | % | ^ | = | != |
;; "<" | ">" | "<=" | ">=" | ~= | ! | & | "|"
;; <mexpr> = <term> [ <op> <term> ]*
;; <term> = <-> <term> | <!> <term> | "(" <mexpr> ")" |
;; <ifexpr> | <funcall> | <aref> | <atom> | <list> | <string>
;; <sexpr> = <mexpr> | <object> | class
;; <top> = <command> | <block> | <conditional> | <assignment> | <loop> | <exec>
;; <exec> = exec <sexpr>
;; <command> = <define-cmd> | <file-cmd> | <output>
;; <define-cmd> = define <declaration>
;; <declaration> = <vardecl> | <fundecl>
;; <vardecl> = variable <bindings>
;; <bindings> = <bind> [ , <bind> ]*
;; <bind> = <id> [ <=> <sexpr> ]
;; <fundecl> = <function> <id> "(" [ <parms> ] ")" <statement>
;; <parms> = <parm> [ , <parm> ]*
;; this is new: key: expression for keyword parameter
;; <parm> = <id> | <key> [ <sexpr> ]
;; <statement> = <block> | <conditional> | <assignment> |
;; <output-stmt> <loop-stmt> <return-from> | <exec>
;; <block> = begin [ with <bindings> [ <statement> ]* end
;; <conditional> = if <sexpr> then [ <statement> ] [ else <statement> ] |
;; when <sexpr> <statement> | unless <sexpr> <statement>
;; <assignment> = set <assign> [ , <assign> ]*
;; <assign> = ( <aref> | <id> ) <assigner> <sexpr>
;; <assigner> = = | += | *= | &= | @= | ^= | "<=" | ">="
;; <file-cmd> = <load-cmd> | chdir <pathref> |
;; system <pathref> | play <sexpr>
;; (note: system was removed)
;; <load-cmd> = load <pathref> [ , <key> <sexpr> ]*
;; <pathref> = <string> | <id>
;; <output-stmt> = print <sexpr> [ , <sexpr> ]* |
;; output <sexpr>
;; <loop-stmt> = loop [ with <bindings> ] [ <stepping> ]*
;; [ <termination> ]* [ <statement> ]+
;; [ finally <statement> ] end
;; <stepping> = repeat <sexpr> |
;; for <id> = <sexpr> [ then <sexpr> ] |
;; for <id> in <sexpr> |
;; for <id> over <sexpr> [ by <sexpr> ] |
;; for <id> [ from <sexpr> ]
;; [ ( below | to | above | downto ) <sexpr> ]
;; [ by <sexpr> ] |
;; <termination> = while <sexpr> | until <sexpr>
;; <return-from> = return <sexpr>
;(in-package cm)
; (progn (cd "/Lisp/sal/") (load "parse.lisp") (load "sal.lisp"))
(setfn defconstant setf)
(setfn defparameter setf)
(setfn defmethod defun)
(setfn defvar setf)
(setfn values list)
(if (not (boundp '*sal-secondary-prompt*))
(setf *sal-secondary-prompt* t))
(if (not (boundp '*sal-xlispbreak*))
(setf *sal-xlispbreak* nil))
(defun sal-trace-enter (fn &optional argvals argnames)
(push (list fn *sal-line* argvals argnames) *sal-call-stack*))
(defun sal-trace-exit ()
(setf *sal-line* (second (car *sal-call-stack*)))
(pop *sal-call-stack*))
;; SAL-RETURN-FROM is generated by Sal compiler and
;; performs a return as well as a sal-trace-exit()
;;
(defmacro sal-return-from (fn val)
`(prog ((sal:return-value ,val))
(setf *sal-line* (second (car *sal-call-stack*)))
(pop *sal-call-stack*)
(return-from ,fn sal:return-value)))
(setf *sal-traceback* t)
(defun sal-traceback (&optional (file t)
&aux comma name names line)
(format file "Call traceback:~%")
(setf line *sal-line*)
(dolist (frame *sal-call-stack*)
(setf comma "")
(format file " ~A" (car frame))
(cond ((symbolp (car frame))
(format file "(")
(setf names (cadddr frame))
(dolist (arg (caddr frame))
(setf name (car names))
(format file "~A~% ~A = ~A" comma name arg)
(setf names (cdr names))
(setf comma ","))
(format file ") at line ~A~%" line)
(setf line (second frame)))
(t
(format file "~%")))))
'(defmacro defgrammer (sym rules &rest args)
`(defparameter ,sym
(make-grammer :rules ',rules ,@args)))
'(defun make-grammer (&key rules literals)
(let ((g (list 'a-grammer rules literals)))
(grammer-initialize g)
g))
'(defmethod grammer-initialize (obj)
(let (xlist)
;; each literal is (:name "name")
(cond ((grammer-literals obj)
(dolist (x (grammer-literals obj))
(cond ((consp x)
(push x xlist))
(t
(push (list (string->keyword (string-upcase (string x)))
(string-downcase (string x)))
xlist)))))
(t
(dolist (x (grammer-rules obj))
(cond ((terminal-rule? x)
(push (list (car x)
(string-downcase (subseq (string (car x)) 1)))
xlist))))))
(set-grammer-literals obj (reverse xlist))))
'(setfn grammer-rules cadr)
'(setfn grammer-literals caddr)
'(defun set-grammer-literals (obj val)
(setf (car (cddr obj)) val))
'(defun is-grammer (obj) (and (consp obj) (eq (car obj) 'a-grammer)))
(defun string->keyword (str)
(intern (strcat ":" (string-upcase str))))
(defun terminal-rule? (rule)
(or (null (cdr rule)) (not (cadr rule))))
(load "sal-parse.lsp" :verbose nil)
(defparameter *sal-print-list* t)
(defun sal-printer (x &key (stream *standard-output*) (add-space t))
(let ((*print-case* ':downcase))
(cond ((and (consp x) *sal-print-list*)
(write-char #\{ stream)
(do ((items x (cdr items)))
((null items))
(sal-printer (car items) :stream stream
:add-space (cdr items))
(cond ((cdr items)
(cond ((not (consp (cdr items)))
(princ "<list not well-formed> " stream)
(sal-printer (cdr items) :stream stream :add-space nil)
(setf items nil))))))
(write-char #\} stream))
((not x) (princ "#f" stream) )
((eq x t) (princ "#t" stream))
(t (princ x stream)))
(if add-space (write-char #\space stream))))
(defparameter *sal-printer* #'sal-printer)
(defun sal-message (string &rest args)
(format t "~&; ")
(apply #'format t string args))
(defun sal-print (&rest args)
(terpri)
(mapc *sal-printer* args)
(values))
(defmacro keyword (sym)
`(str-to-keyword (symbol-name ',sym)))
(defun plus (&rest nums)
(apply #'+ nums))
(defun minus (num &rest nums)
(apply #'- num nums))
(defun times (&rest nums)
(apply #'* nums))
(defun divide (num &rest nums)
(apply #'/ num nums))
;; implementation of infix "!=" operator
(defun not-eql (x y)
(not (eql x y)))
; dir "*.*
; chdir
; load "rts.sys"
(defun sal-chdir ( dir)
(cd (expand-path-name dir))
(sal-message "Directory: ~A" (pwd))
(values))
;;; sigh, not all lisps support ~/ directory components.
(defun expand-path-name (path &optional absolute?)
(let ((dir (pathname-directory path)))
(flet ((curdir ()
(truename
(make-pathname :directory
(pathname-directory
*default-pathname-defaults*)))))
(cond ((null dir)
(if (equal path "~")
(namestring (user-homedir-pathname))
(if absolute?
(namestring (merge-pathnames path (curdir)))
(namestring path))))
((eql (car dir) ':absolute)
(namestring path))
(t
(let* ((tok (second dir))
(len (length tok)))
(if (char= (char tok 0) #\~)
(let ((uhd (pathname-directory (user-homedir-pathname))))
(if (= len 1)
(namestring
(make-pathname :directory (append uhd (cddr dir))
:defaults path))
(namestring
(make-pathname :directory
(append (butlast uhd)
(list (subseq tok 1))
(cddr dir))
:defaults path))))
(if absolute?
(namestring (merge-pathnames path (curdir)))
(namestring path)))))))))
(defun sal-load (filename &key (verbose t) print)
(progv '(*sal-input-file-name*) (list filename)
(prog (file extended-name)
;; first try to load exact name
(cond ((setf file (open filename))
(close file) ;; found it: close it and load it
(return (generic-loader filename verbose print))))
;; try to load name with ".sal" or ".lsp"
(cond ((string-search "." filename) ; already has extension
nil) ; don't try to add another extension
((setf file (open (strcat filename ".sal")))
(close file)
(return (sal-loader (strcat filename ".sal")
:verbose verbose :print print)))
((setf file (open (strcat filename ".lsp")))
(close file)
(return (lisp-loader filename :verbose verbose :print print))))
;; search for file as is or with ".lsp" on path
(setf fullpath (find-in-xlisp-path filename))
(cond ((and (not fullpath) ; search for file.sal on path
(not (string-search "." filename))) ; no extension yet
(setf fullpath (find-in-xlisp-path (strcat filename ".sal")))))
(cond ((null fullpath)
(format t "sal-load: could not find ~A~%" filename))
(t
(return (generic-loader filename verbose print)))))))
;; GENERIC-LOADER -- load a sal or lsp file based on extension
;;
;; assumes that file exists, and if no .sal extension, type is Lisp
;;
(defun generic-loader (fullpath verbose print)
(cond ((has-extension fullpath ".sal")
(sal-loader fullpath :verbose verbose :print print))
(t
(lisp-loader fullpath :verbose verbose :print print))))
#|
(defun sal-load (filename &key (verbose t) print)
(progv '(*sal-input-file-name*) (list filename)
(let (file extended-name)
(cond ((has-extension filename ".sal")
(sal-loader filename :verbose verbose :print print))
((has-extension filename ".lsp")
(lisp-load filename :verbose verbose :print print))
;; see if we can just open the exact filename and load it
((setf file (open filename))
(close file)
(lisp-load filename :verbose verbose :print print))
;; if not, then try loading file.sal and file.lsp
((setf file (open (setf *sal-input-file-name*
(strcat filename ".sal"))))
(close file)
(sal-loader *sal-input-file-name* :verbose verbose :print print))
((setf file (open (setf *sal-input-file-name*
(strcat filename ".lsp"))))
(close file)
(lisp-load *sal-input-file-name* :verbose verbose :print print))
(t
(format t "sal-load: could not find ~A~%" filename))))))
|#
(defun lisp-loader (filename &key (verbose t) print)
(if (load filename :verbose verbose :print print)
nil ; be quiet if things work ok
(format t "error loading lisp file ~A~%" filename)))
(defun has-extension (filename ext)
(let ((loc (string-search ext filename
:start (max 0 (- (length filename)
(length ext))))))
(not (null loc)))) ; coerce to t or nil
(defmacro sal-at (s x) (list 'at x s))
(defmacro sal-at-abs (s x) (list 'at-abs x s))
(defmacro sal-stretch (s x) (list 'stretch x s))
(defmacro sal-stretch-abs (s x) (list 'stretch-abs x s))
;; splice every pair of lines
(defun strcat-pairs (lines)
(let (rslt)
(while lines
(push (strcat (car lines) (cadr lines)) rslt)
(setf lines (cddr lines)))
(reverse rslt)))
(defun strcat-list (lines)
;; like (apply 'strcat lines), but does not use a lot of stack
;; When there are too many lines, XLISP will overflow the stack
;; because args go on the stack.
(let (r)
(while (> (setf len (length lines)) 1)
(if (oddp len) (setf lines (cons "" lines)))
(setf lines (strcat-pairs lines)))
; if an empty list, return "", else list has one string: return it
(if (null lines) "" (car lines))))
(defun sal-loader (filename &key verbose print)
(let ((input "") (file (open filename)) line lines)
(cond (file
(push filename *loadingfiles*)
(while (setf line (read-line file))
(push line lines)
(push "\n" lines))
(close file)
(setf input (strcat-list (reverse lines)))
(sal-trace-enter (strcat "Loading " filename))
(sal-compile input t t filename)
(pop *loadingfiles*)
(sal-trace-exit))
(t
(format t "error loading SAL file ~A~%" filename)))))
; SYSTEM command is not implemented
;(defun sal-system (sys &rest pairs)
; (apply #'use-system sys pairs))
(defun load-sal-file (file)
(with-open-file (f file :direction :input)
(let ((input (make-array '(512) :element-type 'character
:fill-pointer 0 :adjustable t)))
(loop with flag
for char = (read-char f nil ':eof)
until (or flag (eql char ':eof))
do
(when (char= char #\;)
(loop do (setq char (read-char f nil :eof))
until (or (eql char :eof)
(char= char #\newline))))
(unless (eql char ':eof)
(vector-push-extend char input)))
(sal input :pattern :command-sequence))))
(defmacro sal-play (snd)
(if (stringp snd) `(play-file ,snd)
`(play ,snd)))
(if (not (boundp '*sal-compiler-debug*))
(setf *sal-compiler-debug* nil))
(defmacro sal-simrep (variable iterations body)
`(simrep (,variable ,iterations) ,body))
(defmacro sal-seqrep (variable iterations body)
`(seqrep (,variable ,iterations) ,body))
;; function called in sal programs to exit the sal read-compile-run-print loop
(defun sal-exit () (setf *sal-exit* t))
;; read-eval-print loop for sal commands
(defun sal ()
(progv '(*breakenable* *tracenable* *sal-exit*)
(list *sal-xlispbreak* *sal-xlispbreak* nil)
(let (input line)
(setf *sal-call-stack* nil)
(read-line) ; read the newline after the one the user
; typed to invoke this fn
(princ "Entering SAL mode ...\n");
(while (not *sal-exit*)
(princ "\nSAL> ")
(sal-trace-enter "SAL top-level command interpreter")
;; get input terminated by two returns
(setf input "")
(while (> (length (setf line (read-line))) 0)
(if *sal-secondary-prompt* (princ " ... "))
(setf input (strcat input "\n" line)))
;; input may have an extra return, remaining from previous read
;; if so, trim it because it affects line count in error messages
(if (and (> (length input) 0) (char= (char input 0) #\newline))
(setf input (subseq input 1)))
(sal-compile input t nil "<console>")
(sal-trace-exit))
(princ "Returning to Lisp ...\n")
t ; return value
)))
(defun sal-error-output (stack)
(if *sal-traceback* (sal-traceback))
(setf *sal-call-stack* stack)) ;; clear the stack
;; SAL-COMPILE -- translate string or token list to lisp and eval
;;
;; input is either a string or a token list
;; eval-flag tells whether to evaluate the program or return the lisp
;; multiple-statements tells whether the input can contain multiple
;; top-level units (e.g. from a file) or just one (from command line)
;; returns:
;; if eval-flag, then nothing is returned
;; otherwise, returns nil if an error is encountered
;; otherwise, returns a list (PROGN p1 p2 p3 ...) where pn are lisp
;; expressions
;;
(defun sal-compile (input eval-flag multiple-statements filename)
;; save some globals because eval could call back recursively
(progv '(*sal-tokens* *sal-input* *sal-input-text*) '(nil nil nil)
(let (output remainder rslt stack)
(setf stack *sal-call-stack*)
;; if first input char is "(", then eval as a lisp expression:
;(display "sal-compile" input)
(cond ((input-starts-with-open-paren input)
;(print "input is lisp expression")
(errset
(print (eval (read (make-string-input-stream input)))) t))
(t ;; compile SAL expression(s):
(loop
(setf output (sal-parse nil nil input multiple-statements
filename))
(cond ((first output) ; successful parse
(setf remainder *sal-tokens*)
(setf output (second output))
(when *sal-compiler-debug*
(terpri)
(pprint output))
(cond (eval-flag ;; evaluate the compiled code
(cond ((null (errset (eval output) t))
(sal-error-output stack)
(return)))) ;; stop on error
(t
(push output rslt)))
;(display "sal-compile after eval"
; remainder *sal-tokens*)
;; if there are statements left over, maybe compile again
(cond ((and multiple-statements remainder)
;; move remainder to input and iterate
(setf input remainder))
;; see if we've compiled everything
((and (not eval-flag) (not remainder))
(return (cons 'progn (reverse rslt))))
;; if eval but no more input, return
((not remainder)
(return))))
(t ; error encountered
(return)))))))))
;; SAL just evaluates lisp expression if it starts with open-paren,
;; but sometimes reader reads previous newline(s), so here we
;; trim off initial newlines and check if first non-newline is open-paren
(defun input-starts-with-open-paren (input)
(let ((i 0))
(while (and (stringp input)
(> (length input) i)
(eq (char input i) #\newline))
(incf i))
(and (stringp input)
(> (length input) i)
(eq (char input i) #\())))

252
nyquist/seq.lsp Normal file
View File

@@ -0,0 +1,252 @@
;; seq.lsp -- sequence control constructs for Nyquist
;; get-srates -- this either returns the sample rate of a sound or a
;; vector of sample rates of a vector of sounds
;;
(defun get-srates (sounds)
(cond ((arrayp sounds)
(let ((result (make-array (length sounds))))
(dotimes (i (length sounds))
(setf (aref result i) (snd-srate (aref sounds i))))
result))
(t
(snd-srate sounds))))
; These are complex macros that implement sequences of various types.
; The complexity is due to the fact that a behavior within a sequence
; can reference the environment, e.g. (let ((p 60)) (seq (osc p) (osc p)))
; is an example where p must be in the environment of each member of
; the sequence. Since the execution of the sequence elements are delayed,
; the environment must be captured and then used later. In XLISP, the
; EVAL function does not execute in the current environment, so a special
; EVAL, EVALHOOK must be used to evaluate with an environment. Another
; feature of XLISP (see evalenv.lsp) is used to capture the environment
; when the seq is first evaluated, so that the environment can be used
; later. Finally, it is also necessary to save the current transformation
; environment until later.
(defmacro seq (&rest list)
(cond ((null list)
(snd-zero (warp-time *WARP*) *sound-srate*))
((null (cdr list))
(car list))
((null (cddr list))
; (format t "SEQ with 2 behaviors: ~A~%" list)
`(let* ((first%sound ,(car list))
(s%rate (get-srates first%sound)))
(cond ((arrayp first%sound)
(snd-multiseq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0)
(format t "MULTISEQ's 2nd behavior: ~A~%" ',(cadr list))
(with%environment ',(nyq:the-environment)
; (display "MULTISEQ 1" t0)
(at-abs t0
(force-srates s%rate ,(cadr list)))))))
(t
; allow gc of first%sound:
(snd-seq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0)
; (format t "SEQ's 2nd behavior: ~A~%" ',(cadr list))
(with%environment ',(nyq:the-environment)
(at-abs t0
(force-srate s%rate ,(cadr list))))))))))
(t
`(let* ((nyq%environment (nyq:the-environment))
(first%sound ,(car list))
(s%rate (get-srates first%sound))
(seq%environment (getenv)))
(cond ((arrayp first%sound)
; (print "calling snd-multiseq")
(snd-multiseq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0)
(multiseq-iterate ,(cdr list)))))
(t
; (print "calling snd-seq")
; allow gc of first%sound:
(snd-seq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0)
(seq-iterate ,(cdr list))))))))))
(defun envdepth (e) (length (car e)))
(defmacro myosd (pitch)
`(let () (format t "myosc env depth is ~A~%"
(envdepth (getenv))) (osc ,pitch)))
(defmacro seq-iterate (behavior-list)
(cond ((null (cdr behavior-list))
`(eval-seq-behavior ,(car behavior-list)))
(t
`(snd-seq (eval-seq-behavior ,(car behavior-list))
(evalhook '#'(lambda (t0)
; (format t "lambda depth ~A~%" (envdepth (getenv)))
(seq-iterate ,(cdr behavior-list)))
nil nil seq%environment)))))
(defmacro multiseq-iterate (behavior-list)
(cond ((null (cdr behavior-list))
`(eval-multiseq-behavior ,(car behavior-list)))
(t
`(snd-multiseq (eval-multiseq-behavior ,(car behavior-list))
(evalhook '#'(lambda (t0)
; (format t "lambda depth ~A~%" (envdepth (getenv)))
(multiseq-iterate ,(cdr behavior-list)))
nil nil seq%environment)))))
(defmacro eval-seq-behavior (beh)
`(with%environment nyq%environment
(at-abs t0
(force-srate s%rate ,beh))))
(defmacro eval-multiseq-behavior (beh)
`(with%environment nyq%environment
; (display "MULTISEQ 2" t0)
(at-abs t0
(force-srates s%rate ,beh))))
(defmacro with%environment (env &rest expr)
`(progv ',*environment-variables* ,env ,@expr))
(defmacro seqrep (pair sound)
`(let ((,(car pair) 0)
(loop%count ,(cadr pair))
(nyq%environment (nyq:the-environment))
seqrep%closure first%sound s%rate)
; note: s%rate will tell whether we want a single or multichannel
; sound, and what the sample rates should be.
(cond ((not (integerp loop%count))
(error "bad argument type" loop%count))
(t
(setf seqrep%closure #'(lambda (t0)
; (display "SEQREP" loop%count ,(car pair))
(cond ((< ,(car pair) loop%count)
(setf first%sound
(with%environment nyq%environment
(at-abs t0 ,sound)))
; (display "seqrep" s%rate nyq%environment ,(car pair)
; loop%count)
(if s%rate
(setf first%sound (force-srates s%rate first%sound))
(setf s%rate (get-srates first%sound)))
(setf ,(car pair) (1+ ,(car pair)))
; note the following test is AFTER the counter increment
(cond ((= ,(car pair) loop%count)
; (display "seqrep: computed the last sound at"
; ,(car pair) loop%count
; (local-to-global 0))
first%sound) ;last sound
((arrayp s%rate)
; (display "seqrep: calling snd-multiseq at"
; ,(car pair) loop%count (local-to-global 0)
; (snd-t0 (aref first%sound 0)))
(snd-multiseq (prog1 first%sound
(setf first%sound nil))
seqrep%closure))
(t
; (display "seqrep: calling snd-seq at"
; ,(car pair) loop%count (local-to-global 0)
; (snd-t0 first%sound))
(snd-seq (prog1 first%sound
(setf first%sound nil))
seqrep%closure))))
(t (snd-zero (warp-time *WARP*) *sound-srate*)))))
(funcall seqrep%closure (local-to-global 0))))))
(defmacro trigger (input beh)
`(let ((nyq%environment (nyq:the-environment)))
(snd-trigger ,input #'(lambda (t0) (with%environment nyq%environment
(at-abs t0 ,beh))))))
;; EVENT-EXPRESSION -- the sound of the event
;;
(setfn event-expression caddr)
;; EVENT-HAS-ATTR -- test if event has attribute
;;
(defun event-has-attr (note attr)
(expr-has-attr (event-expression note)))
;; EXPR-SET-ATTR -- new expression with attribute = value
;;
(defun expr-set-attr (expr attr value)
(cons (car expr) (list-set-attr-value (cdr expr) attr value)))
(defun list-set-attr-value (lis attr value)
(cond ((null lis) (list attr value))
((eq (car lis) attr)
(cons attr (cons value (cddr lis))))
(t
(cons (car lis)
(cons (cadr lis)
(list-set-attr-value (cddr lis) attr value))))))
;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq
;;
(defun expand-and-eval-expr (expr)
(let ((pitch (member :pitch expr)))
(cond ((and pitch (cdr pitch) (listp (cadr pitch)))
(setf pitch (cadr pitch))
(simrep (i (length pitch))
(eval (expr-set-attr expr :pitch (nth i pitch)))))
(t
(eval expr)))))
;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...))
;; a timed-seq takes a list of events as shown above
;; it sums the behaviors, similar to
;; (sim (at time1 (stretch stretch1 expr1)) ...)
;; but the implementation avoids starting all expressions at once
;;
;; Notes: (1) the times must be in increasing order
;; (2) EVAL is used on each event, so events cannot refer to parameters
;; or local variables
;;
(defun timed-seq (score)
; check to insure that times are strictly increasing and >= 0 and stretches are >= 0
(let ((start-time 0) error-msg)
(dolist (event score)
(cond ((< (car event) start-time)
(error (format nil "Out-of-order time in TIMED-SEQ: ~A" event)))
((< (cadr event) 0)
(error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event)))
(t
(setf start-time (car event)))))
;; remove rests (a rest has a :pitch attribute of nil)
(setf score (score-select score #'(lambda (tim dur evt)
(expr-get-attr evt :pitch t))))
(cond ((and score (car score)
(eq (car (event-expression (car score))) 'score-begin-end))
(setf score (cdr score)))) ; skip score-begin-end data
; (score-print score) ;; debugging
(cond ((null score) (s-rest 0))
(t
(at (caar score)
(seqrep (i (length score))
(cond ((cdr score)
(let (event)
(prog1
(set-logical-stop
(stretch (cadar score)
(setf event (expand-and-eval-expr
(caddar score))))
(- (caadr score) (caar score)))
;(display "timed-seq" (caddar score)
; (local-to-global 0)
; (snd-t0 event)
; (- (caadr score)
; (caar score)))
(setf score (cdr score)))))
(t
(stretch (cadar score) (expand-and-eval-expr
(caddar score)))))))))))

31
nyquist/seqfnint.lsp Normal file
View File

@@ -0,0 +1,31 @@
(setfn seq-tag first)
(setfn seq-time second)
(setfn seq-line third)
(setfn seq-channel fourth)
(defun seq-value1 (e) (nth 4 e))
(setfn seq-pitch seq-value1) ; pitch of a note
(setfn seq-control seq-value1) ; control number of a control change
(setfn seq-program seq-value1) ; program number of a program change
(setfn seq-bend seq-value1) ; pitch bend amount
(setfn seq-touch seq-value1) ; aftertouch amount
(defun seq-value2 (e) (nth 5 e))
(setfn seq-velocity seq-value2) ; velocity of a note
(setfn seq-value seq-value2) ; value of a control change
(defun seq-duration (e) (nth 6 e))
(setf seq-done-tag 0)
(setf seq-other-tag 1)
(setf seq-note-tag 2)
(setf seq-ctrl-tag 3)
(setf seq-prgm-tag 4)
(setf seq-touch-tag 5)
(setf seq-bend-tag 6)

159
nyquist/seqmidi.lsp Normal file
View File

@@ -0,0 +1,159 @@
;; seqmidi.lsp -- functions to use MIDI files in Nyquist
;
; example call:
;
; (seq-midi my-seq
; (note (chan pitch velocity) (= chan 2) (my-note pitch velocity))
; (ctrl (chan control value) (...))
; (bend (chan value) (...))
; (touch (chan value) (...))
; (prgm (chan value) (setf (aref my-prgm chan) value))
;; seq-midi - a macro to create a sequence of sounds based on midi file
;
;
(defmacro seq-midi (the-seq &rest cases)
(seq-midi-cases-syntax-check cases)
`(let (_the-event _next-time _the-seq _seq-midi-closure _nyq-environment
_the-seq _tag)
(setf _the-seq (seq-copy ,the-seq))
(setf _nyq-environment (nyq:the-environment))
(setf _seq-midi-closure #'(lambda (t0)
; (format t "_seq_midi_closure: t0 = ~A~%" t0)
(prog (_the-sound)
loop ; go forward until we find note to play (we may be there)
; then go forward to find time of next note
(setf _the-event (seq-get _the-seq))
; (display "seq-midi" _the-event t0)
(setf _tag (seq-tag _the-event))
(cond ((= _tag seq-ctrl-tag)
,(make-ctrl-handler cases))
((= _tag seq-bend-tag)
,(make-bend-handler cases))
((= _tag seq-touch-tag)
,(make-touch-handler cases))
((= _tag seq-prgm-tag)
,(make-prgm-handler cases))
((= _tag seq-done-tag)
; (format t "_seq_midi_closure: seq-done")
(cond (_the-sound ; this is the last sound of sequence
; (format t "returning _the-sound~%")
(return _the-sound))
(t ; sequence is empty, return silence
; (format t "returning snd-zero~%")
(return (snd-zero t0 *sound-srate*)))))
((and (= _tag seq-note-tag)
,(make-note-test cases))
(cond (_the-sound ; we now have time of next note
(setf _next-time (/ (seq-time _the-event) 1000.0))
(go exit-loop))
(t
(setf _the-sound ,(make-note-handler cases))))))
(seq-next _the-seq)
(go loop)
exit-loop ; here, we know time of next note
; (display "seq-midi" _next-time)
; (format t "seq-midi calling snd-seq\n")
(return (snd-seq
(set-logical-stop-abs _the-sound
(local-to-global _next-time))
_seq-midi-closure)))))
; (display "calling closure" (get-lambda-expression _seq-midi-closure))
(funcall _seq-midi-closure (local-to-global 0))))
(defun seq-midi-cases-syntax-check (cases &aux n)
(cond ((not (listp cases))
(break "syntax error in" cases)))
(dolist (case cases)
(cond ((or (not (listp case))
(not (member (car case) '(NOTE CTRL BEND TOUCH PRGM)))
(not (listp (cdr case)))
(not (listp (cadr case)))
(not (listp (cddr case)))
(not (listp (last (cddr case)))))
(break "syntax error in" case))
((/= (length (cadr case))
(setf n (cdr (assoc (car case)
'((NOTE . 3) (CTRL . 3) (BEND . 2)
(TOUCH . 2) (PRGM . 2))))))
(break (format nil "expecting ~A arguments in" n) case))
((and (eq (car case) 'NOTE)
(not (member (length (cddr case)) '(1 2))))
(break
"note handler syntax is (NOTE (ch pitch vel) [filter] behavior)"
case)))))
(defun make-ctrl-handler (cases)
(let ((case (assoc 'ctrl cases)))
(cond (case
`(let ((,(caadr case) (seq-channel _the-event))
(,(cadadr case) (seq-control _the-event))
(,(caddar (cdr case)) (seq-value _the-event)))
,@(cddr case)))
(t nil))))
(defun make-bend-handler (cases)
(let ((case (assoc 'bend cases)))
(cond (case
`(let ((,(caadr case) (seq-channel _the-event))
(,(cadadr case) (seq-value _the-event)))
,@(cddr case)))
(t nil))))
(defun make-touch-handler (cases)
(let ((case (assoc 'touch cases)))
(cond (case
`(let ((,(caadr case) (seq-channel _the-event))
(,(cadadr case) (seq-value _the-event)))
,@(cddr case)))
(t nil))))
(defun make-prgm-handler (cases)
(let ((case (assoc 'pgrm cases)))
(cond (case
`(let ((,(caadr case) (seq-channel _the-event))
(,(cadadr case) (seq-value _the-event)))
,@(cddr case)))
(t nil))))
(defun make-note-test (cases)
(let ((case (assoc 'note cases)))
(cond ((and case (cdddr case))
(caddr case))
(t t))))
(defun make-note-handler (cases)
(let ((case (assoc 'note cases))
behavior)
(cond ((and case (cdddr case))
(setf behavior (cadddr case)))
(t
(setf behavior (caddr case))))
`(with%environment _nyq-environment
(with-note-args ,(cadr case) _the-event ,behavior))))
(defmacro with-note-args (note-args the-event note-behavior)
; (display "with-note-args" the-event)
`(let ((,(car note-args) (seq-channel ,the-event))
(,(cadr note-args) (seq-pitch ,the-event))
(,(caddr note-args) (seq-velocity ,the-event)))
(at (/ (seq-time ,the-event) 1000.0)
(stretch (/ (seq-duration ,the-event) 1000.0) ,note-behavior))))
;(defun seq-next-note-time (the-seq find-first-flag)
; (prog (event)
; (if find-first-flag nil (seq-next the-seq))
;loop
; (setf event (seq-get the-seq))
; (cond ((eq (seq-tag event) seq-done-tag)
; (return (if find-first-flag 0.0 nil)))
; ((eq (seq-tag event) seq-note-tag)
; (return (/ (seq-time event) 1000.0))))
; (seq-next the-seq)
; (go loop)))
;

86
nyquist/sndfnint.lsp Normal file
View File

@@ -0,0 +1,86 @@
(setf snd-head-none 0)
(setf snd-head-AIFF 1)
(setf snd-head-IRCAM 2)
(setf snd-head-NeXT 3)
(setf snd-head-Wave 4)
(setf snd-head-PAF 5)
(setf snd-head-SVX 6)
(setf snd-head-NIST 7)
(setf snd-head-VOC 8)
(setf snd-head-W64 9)
(setf snd-head-MAT4 10)
(setf snd-head-MAT5 11)
(setf snd-head-PVF 12)
(setf snd-head-XI 13)
(setf snd-head-HTK 14)
(setf snd-head-SDS 15)
(setf snd-head-AVR 16)
(setf snd-head-SD2 17)
(setf snd-head-FLAC 18)
(setf snd-head-CAF 19)
(setf snd-head-raw 20)
(setf snd-head-channels 1)
(setf snd-head-mode 2)
(setf snd-head-bits 4)
(setf snd-head-srate 8)
(setf snd-head-dur 16)
(setf snd-head-latency 32)
(setf snd-head-type 64)
(setf snd-mode-adpcm 0)
(setf snd-mode-pcm 1)
(setf snd-mode-ulaw 2)
(setf snd-mode-alaw 3)
(setf snd-mode-float 4)
(setf snd-mode-upcm 5)
(setf snd-mode-unknown 6)
(setf snd-mode-double 7)
(setf snd-mode-GSM610 8)
(setf snd-mode-DWVW 9)
(setf snd-mode-DPCM 10)
(setf snd-mode-msadpcm 11)
(SETF MAX-STOP-TIME 10E20)
(SETF MIN-START-TIME -10E20)
(setf OP-AVERAGE 1) (setf OP-PEAK 2)

189
nyquist/stk.lsp Normal file
View File

@@ -0,0 +1,189 @@
;; stk.lsp -- STK-based instruments
;;
;; currently clarinet and saxophony are implemented
(defun instr-parameter (parm)
;; coerce parameter into a *sound-srate* signal
(cond ((numberp parm)
(stretch 30 (control-srate-abs *sound-srate* (const (float parm)))))
(t
(force-srate *sound-srate* parm))))
(defun clarinet (step breath-env)
(snd-clarinet (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*))
(defun clarinet-freq (step breath-env freq-env)
;; note that the parameters are in a different order -- I defined
;; clarinet-freq this way so that the first two parameters are always
;; step and breath. I didn't redo snd-clarinet-freq.
(snd-clarinet_freq (step-to-hz step)
(instr-parameter breath-env)
(instr-parameter freq-env)
*sound-srate*))
(defun clarinet-all (step breath-env freq-env vibrato-freq vibrato-gain reed-stiffness noise)
;; note that the parameters are not in the same order as snd-clarinet-all
(setf breath-env (instr-parameter breath-env))
(setf freq-env (instr-parameter freq-env))
(setf reed-stiffness (instr-parameter reed-stiffness))
(setf noise (instr-parameter noise))
(snd-clarinet_all (step-to-hz step)
breath-env freq-env
;; STK scales 1.0 to 12Hz. Scale here so vibrato-freq is in Hz
(/ vibrato-freq 12.0) vibrato-gain
reed-stiffness noise
*sound-srate*))
(defun sax (step breath-env)
(snd-sax (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*))
(defun sax-freq (step breath-env freq-env)
(snd-sax_freq (step-to-hz step)
(instr-parameter breath-env)
(instr-parameter freq-env)
*sound-srate*))
(defun sax-all (step breath-env freq-env vibrato-freq vibrato-gain reed-stiffness noise blow-pos reed-table-offset)
(snd-sax_all (step-to-hz step)
(instr-parameter freq-env)
(instr-parameter breath-env)
(instr-parameter (/ vibrato-freq 12.0))
(instr-parameter vibrato-gain)
(instr-parameter reed-stiffness)
(instr-parameter noise)
(instr-parameter blow-pos)
(instr-parameter reed-table-offset)
*sound-srate*)
)
; instr-parameter already defined in stk.lsp
(defun flute (step breath-env)
(snd-flute (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*))
(defun flute-freq (step breath-env freq-env)
(snd-flute_freq (step-to-hz step)
(instr-parameter breath-env)
(instr-parameter freq-env)
*sound-srate*))
(defun flute-all (step breath-env freq-env vibrato-freq vibrato-gain jet-delay noise)
;; note that the parameters are not in the same order as snd-clarinet-all
(setf breath-env (instr-parameter breath-env))
(setf freq-env (instr-parameter freq-env))
(setf jet-delay (instr-parameter jet-delay))
(setf noise (instr-parameter noise))
(snd-flute_all (step-to-hz step)
breath-env freq-env
;; STK scales 1.0 to 12Hz. Scale here so vibrato-freq is in Hz
(/ vibrato-freq 12.0) vibrato-gain
jet-delay noise
*sound-srate*))
(defun bowed (step bowpress-env)
(snd-bowed (step-to-hz step) (force-srate *sound-srate* bowpress-env) *sound-srate*))
(defun bowed-freq (step bowpress-env freq-env)
(snd-bowed_freq (step-to-hz step)
(instr-parameter bowpress-env)
(instr-parameter freq-env)
*sound-srate*))
(defun mandolin (step dur &optional (detune 4.0))
(let ((d (get-duration dur)))
(snd-mandolin *rslt* (step-to-hz step) d 1.0 detune *sound-srate*)))
(defun wg-uniform-bar (step bowpress-env)
(snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 0 *sound-srate*))
(defun wg-tuned-bar (step bowpress-env)
(snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 1 *sound-srate*))
(defun wg-glass-harm (step bowpress-env)
(snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 2 *sound-srate*))
(defun wg-tibetan-bowl (step bowpress-env)
(snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 3 *sound-srate*))
(defun modalbar (preset step duration)
(let ((preset (case preset
(MARIMBA 0)
(VIBRAPHONE 1)
(AGOGO 2)
(WOOD1 3)
(RESO 4)
(WOOD2 5)
(BEATS 6)
(TWO-FIXED 7)
(CLUMP 8)
(t (error (format nil "Unknown preset for modalbar %A" preset)))))
(d (get-duration duration)))
(snd-modalbar *rslt* (step-to-hz step) preset d *sound-srate*)))
(defun sitar (step dur)
(let ((d (get-duration dur)))
(snd-sitar *rslt* (step-to-hz step) d *sound-srate*)))
(defun nyq:nrev (snd rev-time mix)
(snd-stkrev 0 snd rev-time mix *sound-srate*))
(defun nyq:jcrev (snd rev-time mix)
(snd-stkrev 1 snd rev-time mix *sound-srate*))
(defun nyq:prcrev (snd rev-time mix)
(snd-stkrev 2 snd rev-time mix *sound-srate*))
(defun nrev (snd rev-time mix)
(multichan-expand #'nyq:nrev snd rev-time mix))
(defun jcrev (snd rev-time mix)
(multichan-expand #'nyq:jcrev snd rev-time mix))
(defun prcrev (snd rev-time mix)
(multichan-expand #'nyq:prcrev snd rev-time mix))
(defun nyq:chorus (snd depth freq mix &optional (base-delay 6000))
(snd-stkchorus snd base-delay depth freq mix *sound-srate*))
(defun stkchorus (snd depth freq mix &optional (base-delay 6000))
(multichan-expand #'nyq:chorus snd depth freq mix base-delay))
(defun nyq:pitshift (snd shift mix)
(snd-stkpitshift snd shift mix *sound-srate*))
(defun pitshift (snd shift mix)
(multichan-expand #'nyq:pitshift snd shift mix))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; HELPER FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; pass in rates of increase/decrease in begin/end... this is like noteOn and noteOff
;
; STK uses setRate but the actual ramp time is also a function of the sample rate.
; I will assume the clarinet was run at 44100Hz and fix things so that the envelope
; is sample-rate independent.
;
; STK seemed to always give a very fast release, so I changed the numbers so that
; note-off values from 0.01 to 1 give an interesting range of articulations.
;
; IMPORTANT: the returned envelope is 0.1s longer than dur. There is 0.1s of silence
; at the end so that the clarinet can "ring" after the driving force is removed.
;
(defun stk-breath-env (dur note-on note-off)
(let* ((target (+ 0.55 (* 0.3 note-on)))
(on-time (/ (* target 0.0045) note-on))
(off-time (/ (* target 0.02) note-off)))
;(display "clarinet-breath-env" target on-time off-time)
(pwl on-time target
(- dur off-time) target
dur 0 (+ dur 0.1))))

90
nyquist/system.lsp Normal file
View File

@@ -0,0 +1,90 @@
;; system.lsp -- system-dependent lisp code
; local definition for play
; this one is for Linux:
(if (not (boundp '*default-sf-format*))
(setf *default-sf-format* snd-head-wave))
(if (not (boundp '*default-sound-file*))
(compute-default-sound-file))
(if (not (boundp '*default-sf-dir*))
(setf *default-sf-dir* "./"))
(if (not (boundp '*default-sf-mode*))
(setf *default-sf-mode* snd-mode-pcm))
(if (not (boundp '*default-sf-bits*))
(setf *default-sf-bits* 16))
(if (not (boundp '*default-plot-file*))
(setf *default-plot-file* (strcat (get-user) "-points.dat")))
; FULL-NAME-P -- test if file name is a full path or relative path
;
; (otherwise the *default-sf-dir* will be prepended
;
(defun full-name-p (filename)
(or (eq (char filename 0) #\/)
(eq (char filename 0) #\.)))
; RELATIVE-PATH-P -- test if filename or path is a relative path
;
(defun relative-path-p (filename)
(not (eq (char filename 0) #\/)))
(setf *file-separator* #\/)
;; PLAY-FILE - play a sound file
;;
(defun play-file (name)
;;
;; WARNING: if you invoke an external program to play files,
;; but Nyquist uses internal (portaudio) interface to
;; play synthesized sound, Nyquist may fail to open the
;; sound device while it is playing a sound file and then
;; refuse to play anything. -RBD dec05
;; (system (strcat "sndplay " (soundfilename name))))
;; (system (strcat "play " (soundfilename name) )))
;;
(play (s-read (soundfilename name))))
;; R - replay last file written with PLAY
(defun r () (play-file *default-sound-file*))
;;;; use this old version if you want to use sndplay to play
;;;; the result file rather than play the samples as they
;;;; are computed. This version does not autonormalize.
;; PLAY - write value of an expression to file and play it
;;
;(defmacro play (expr)
; `(prog (specs)
; (setf specs (s-save (force-srate *sound-srate* ,expr)
; 1000000000 *default-sound-file*))
; (r)))
;;;;
; local definition for play
(defmacro play (expr)
`(s-save-autonorm ,expr NY:ALL *default-sound-file* :play *soundenable*))
;; for Linux, modify s-plot (defined in nyquist.lsp) by saving s-plot
;; in standard-s-plot, then call gnuplot to display the points.
;;
;; we also need to save the location of this file so we can find
;; nyquist-plot.txt, the command file for gnuplot
;;
(setf *runtime-path* (current-path))
(display "system.lsp" *runtime-path*)
(setfn standard-s-plot s-plot)
(defun s-plot (s &optional (n 1000) (dur 2.0))
(let (plot-file)
(standard-s-plot s n dur) ;; this calculates the data points
(setf plot-file (strcat *runtime-path* "nyquist-plot.txt"))
(system (strcat "gnuplot -persist " plot-file))))

67
nyquist/xlinit.lsp Normal file
View File

@@ -0,0 +1,67 @@
;; xlinit.lsp -- standard definitions and setup code for XLisp
;;
(defun bt () (baktrace 6))
(defmacro setfn (a b)
`(setf (symbol-function ',a) (symbol-function ',b)))
(setfn co continue)
(setfn top top-level)
(setfn res clean-up)
(setfn up clean-up)
;## display -- debugging print macro
;
; call like this (display "heading" var1 var2 ...)
; and get printout like this:
; "heading : VAR1 = <value> VAR2 = <value> ...<CR>"
;
; returns:
; (let ()
; (format t "~A: " ,label)
; (format t "~A = ~A " ',item1 ,item1)
; (format t "~A = ~A " ',item2 ,item2)
; ...)
;
(defmacro display-macro (label &rest items)
(let ($res$)
(dolist ($item$ items)
(setq $res$ (cons
`(format t "~A = ~A " ',$item$ ,$item$)
$res$)))
(append (list 'let nil `(format t "~A : " ,label))
(reverse $res$)
'((terpri)))))
(defun display-on () (setfn display display-macro) t)
(defun display-off () (setfn display or) nil)
(display-on)
; (objectp expr) - object predicate
;
;this is built-in: (defun objectp (x) (eq (type-of x) 'OBJ))
; (filep expr) - file predicate
;
(defun filep (x) (eq (type-of x) 'FPTR))
(load "profile.lsp" :verbose NIL)
(setq *breakenable* t)
(setq *tracenable* nil)
(defmacro defclass (name super locals class-vars)
(if (not (boundp name))
(if super
`(setq ,name (send class :new ',locals ',class-vars ,super))
`(setq ,name (send class :new ',locals ',class-vars)))))
;(cond ((boundp 'application-file-name)
; (load application-file-name)))
(setq *gc-flag* t)

2332
nyquist/xm.lsp Normal file
View File

File diff suppressed because it is too large Load Diff