;;;

;;; ###########################################################

;;; ### NYQUIST-- A Language for Composition and Synthesis. ###

;;; ### ###

;;; ### Copyright (c) 1994-2006 by Roger B. Dannenberg ###

;;; ###########################################################

;;;

(load "fileio.lsp" :verbose NIL)

(prog ()

(setq lppp -12.0) (setq lpp -9.0) (setq lp -6.0) (setq lmp -3.0)

(setq lfff 12.0) (setq lff 9.0) (setq lf 6.0) (setq lmf 3.0)

(setq dB0 1.00) (setq dB1 1.122) (setq dB10 3.1623)

(setq s 0.25) (setq sd 0.375) (setq st (/ 0.5 3.0))

(setq i 0.5) (setq id 0.75) (setq it (* st 2.0))

(setq q 1.0) (setq qd 1.5) (setq qt (* st 4.0))

(setq h 2.0) (setq hd 3.0) (setq ht (* st 8.0))

(setq w 4.0) (setq wd 6.0) (setq wt (* st 16.0))

)

(init-global *A4-Hertz* 440.0)

; next pitch, for initializations below

;

(defun np () (incf nyq:next-pitch))

(defun set-pitch-names ()

(setq no-pitch 116.0)

; note: 58.0 is A4 - (C0 - 1) = 69 - (12 - 1)

(setf nyq:next-pitch (- (hz-to-step *A4-Hertz*) 58.0))

(setf nyq:pitch-names

'(c0 (cs0 df0) d0 (ds0 ef0) e0 f0 (fs0 gf0) g0 (gs0 af0) a0

(as0 bf0) b0

c1 (cs1 df1) d1 (ds1 ef1) e1 f1 (fs1 gf1) g1 (gs1 af1) a1

(as1 bf1) b1

c2 (cs2 df2) d2 (ds2 ef2) e2 f2 (fs2 gf2) g2 (gs2 af2) a2

(as2 bf2) b2

c3 (cs3 df3) d3 (ds3 ef3) e3 f3 (fs3 gf3) g3 (gs3 af3) a3

(as3 bf3) b3

c4 (cs4 df4) d4 (ds4 ef4) e4 f4 (fs4 gf4) g4 (gs4 af4) a4

(as4 bf4) b4

c5 (cs5 df5) d5 (ds5 ef5) e5 f5 (fs5 gf5) g5 (gs5 af5) a5

(as5 bf5) b5

c6 (cs6 df6) d6 (ds6 ef6) e6 f6 (fs6 gf6) g6 (gs6 af6) a6

(as6 bf6) b6

c7 (cs7 df7) d7 (ds7 ef7) e7 f7 (fs7 gf7) g7 (gs7 af7) a7

(as7 bf7) b7))

(dolist (p nyq:pitch-names)

(cond ((atom p) (set p (np)))

(t (let ((pitch (np)))

(dolist (s p) (set s pitch)))))))

(set-pitch-names)

(init-global *default-sound-srate* 44100.0)

(init-global *default-control-srate* 2205.0)

(setf *environment-variables*

'(*WARP* *SUSTAIN* *START* *LOUD* *TRANSPOSE*

*STOP* *CONTROL-SRATE* *SOUND-SRATE*))

(setfn environment-time car)

(setfn environment-stretch cadr)

; ENVIRONMENT-MAP - map virtual time using an environment

;

;(defun environment-map (env tim)

; (+ (environment-time env)

; (* (environment-stretch env) tim)))

(defun nyq:the-environment () (mapcar 'eval *environment-variables*))

;; GLOBAL ENVIRONMENT VARIABLES and their startup values:

(defun nyq:environment-init ()

(setq *WARP* '(0.0 1.0 nil))

(setq *LOUD* 0.0) ; now in dB

(setq *TRANSPOSE* 0.0)

(setq *SUSTAIN* 1.0)

(setq *START* MIN-START-TIME)

(setq *STOP* MAX-STOP-TIME)

(setq *CONTROL-SRATE* *DEFAULT-CONTROL-SRATE*)

(setq *SOUND-SRATE* *DEFAULT-SOUND-SRATE*)

t) ; return nothing in particular

(nyq:environment-init)

(defun get-duration (dur)

(let ((duration

(- (local-to-global (* (get-sustain) dur))

(setf *rslt* (local-to-global 0)))))

(cond ((minusp duration)

(error

"duration is less than zero: perhaps a warp or stretch

is ill-formed. Nyquist cannot continue because synthesis

functions assume durations are always positive.")))

duration))

(defun get-loud ()

(cond ((numberp *loud*) *loud*)

((soundp *loud*)

(sref *loud* 0))

(t

(error (format t "*LOUD* should be a number or sound: ~A" *LOUD*)))))

(defun get-sustain ()

(cond ((numberp *SUSTAIN*) *SUSTAIN*)

((soundp *SUSTAIN*)

;(display "get-sustain: lookup " (local-to-global 0) 0))

(sref *SUSTAIN* 0))

(t

(error (format t "*SUSTAIN* should be a number or sound: ~A" *SUSTAIN*)))))

(defun get-tempo ()

(slope (snd-inverse (get-warp) (local-to-global 0)

*control-srate*)))

(defun get-transpose ()

(cond ((numberp *TRANSPOSE*) *TRANSPOSE*)

((soundp *TRANSPOSE*)

; (display "get-transpose: lookup " 0)

; (format t "samples: ~A~%" (snd-samples *TRANSPOSE* 100))

(sref *TRANSPOSE* 0))

(t

(error (format t "*TRANSPOSE* should be a number or sound: ~A" *TRANSPOSE*)))))

(defun get-warp ()

(let ((f (warp-function *WARP*)))

(cond ((null f) (error "Null warp function"))

(t

(shift-time (scale-srate f (/ (warp-stretch *WARP*)))

(- (warp-time *WARP*)))))))

;;;;;;;;;;;;;;;;;;;;;;

;; OSCILATORS

;;;;;;;;;;;;;;;;;;;;;;

(defun build-harmonic (n table-size) (snd-sine 0 n table-size 1))

(setf *SINE-TABLE* (list (build-harmonic 1 2048)

(hz-to-step 1.0)

T))

(setf *TABLE* *SINE-TABLE*)

(defun calculate-hz (pitch what)

(let ((hz (step-to-hz (+ pitch (get-transpose))))

(octaves 0))

(cond ((> hz (/ *SOUND-SRATE* 2))

(format t "Warning: ~A frequency (~A hz) will alias at current sample rate (~A hz).\n"

what hz *SOUND-SRATE*)

(while (> hz *SOUND-SRATE*)

(setf octaves (1+ octaves)

hz (* hz 0.5)))

(cond ((> octaves 0)

(format t "Warning: ~A frequency reduced by ~A octaves to ~A hz (which will still alias).\n"

what octaves hz)))))

hz))

;; AMOSC

;;

(defun amosc (pitch modulation &optional (sound *table*) (phase 0.0))

(let ((modulation-srate (snd-srate modulation))

(hz (calculate-hz pitch "amosc")))

(scale-db (get-loud)

(snd-amosc

(car sound) ; samples for table

(cadr sound) ; step represented by table

*SOUND-SRATE* ; output sample rate

hz ; output hz

(local-to-global 0) ; starting time

modulation ; modulation

phase)))) ; phase

;; FMOSC

;;

;; modulation rate must be less than or equal to sound-srate, so

;; force resampling and issue a warning if necessary. snd-fmosc can

;; handle upsampling cases internally.

;;

(defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0))

(let ((modulation-srate (snd-srate modulation))

(hz (calculate-hz pitch "fmosc")))

(scale-db (get-loud)

(snd-fmosc

(car sound) ; samples for table

(cadr sound) ; step represented by table

*SOUND-SRATE* ; output sample rate

hz ; output hz

(local-to-global 0) ; starting time

modulation ; modulation

phase)))) ; phase

;; FMFB

;;

;; this code is based on FMOSC above

;;

(defun fmfb (pitch index &optional dur)

(let ((hz (calculate-hz pitch "fmfb")))

(setf dur (get-duration dur))

(cond ((soundp index) (ny:fmfbv hz index))

(t

(scale-db (get-loud)

(snd-fmfb (local-to-global 0)

hz *SOUND-SRATE* index dur))))))

;; private variable index version of fmfb

(defun ny:fmfbv (hz index)

(let ((modulation-srate (snd-srate index)))

(cond ((< *SOUND-SRATE* modulation-srate)

(format t "Warning: down-sampling FM modulation in fmfb~%")

(setf index (snd-down *SOUND-SRATE* index))))

(scale-db (get-loud)

(snd-fmfbv (local-to-global 0) hz *SOUND-SRATE* index))))

;; BUZZ

;;

;; (ARGUMENTS ("long" "n") ("rate_type" "sr") ("double" "hz")

;; ("time_type" "t0") ("sound_type" "s_fm"))

;;

(defun buzz (n pitch modulation)

(let ((modulation-srate (snd-srate modulation))

(hz (calculate-hz pitch "buzz nominal")))

(cond ((< *SOUND-SRATE* modulation-srate)

(format t "Warning: down-sampling modulation in buzz~%")

(setf modulation (snd-down *SOUND-SRATE* modulation))))

(setf n (max n 1)) ; avoid divide by zero problem

(scale-db (get-loud)

(snd-buzz n ; number of harmonics

*SOUND-SRATE* ; output sample rate

hz ; output hz

(local-to-global 0) ; starting time

modulation)))) ; freq. modulation

;; (HZOSC hz [table [phase]])

;;

;; similar to FMOSC, but without "carrier" frequency parameter

;; also, hz may be a scalar or a sound

;;

(defun hzosc (hz &optional (sound *table*) (phase 0.0))

(let (hz-srate)

(cond ((numberp hz)

(osc (hz-to-step hz) 1.0 sound phase))

(t

(setf hz-srate (snd-srate hz))

(cond ((< *SOUND-SRATE* hz-srate)

(format t "Warning: down-sampling hz in hzosc~%")

(setf hz (snd-down *SOUND-SRATE* hz))))

(scale-db (get-loud)

(snd-fmosc (car sound) ; samples for table

(cadr sound) ; step repr. by table

*SOUND-SRATE* ; output sample rate

0.0 ; dummy carrier

(local-to-global 0) ; starting time

hz phase))))))

;; (SIOSC-BREAKPOINTS tab0 t1 tab1 ... tn tabn)

;; converts times to sample numbers

;; NOTE: time-warping the spectral envelope seems

;; like the wrong thing to do (wouldn't it be better

;; to warp the parameters that control the spectra,

;; or don't warp at all?). Nominally, a note should

;; have a "score" or local time duration equal to the

;; SUSTAIN environment variable. (When sustain is 1.0

;; and no time-warping is in effect, the duration is 1).

;; So, scale all times by

;; (local-to-global (get-sustain))

;; so that if the final time tn = 1.0, we get a nominal

;; length note.

(defun siosc-breakpoints (breakpoints)

(display "siosc-breakpoints" breakpoints)

(prog (sample-count result (last-count 0) time-factor)

(setf time-factor

(- (local-to-global (get-sustain))

(local-to-global 0.0)))

(setf time-factor (* time-factor *SOUND-SRATE*))

(cond ((and (listp breakpoints)

(cdr breakpoints)

(cddr breakpoints)))

(t (error "SIOSC table list must have at least 3 elements")))

loop

(cond ((and (listp breakpoints)

(soundp (car breakpoints)))

(push (car breakpoints) result)

(setf breakpoints (cdr breakpoints)))

(t

(error "SIOSC expecting SOUND in table list")))

(cond ((and breakpoints

(listp breakpoints)

(numberp (car breakpoints)))

(setf sample-count (truncate

(+ 0.5 (* time-factor (car breakpoints)))))

(cond ((< sample-count last-count)

(setf sample-count (1+ last-count))))

(push sample-count result)

(setf last-count sample-count)

(setf breakpoints (cdr breakpoints))

(cond (breakpoints

(go loop))))

(breakpoints

(error "SIOSC expecting number (time) in table list")))

(setf result (reverse result))

(display "siosc-breakpoints" result)

(return result)))

;; SIOSC -- spectral interpolation oscillator

;;

;; modulation rate must be less than or equal to sound-srate, so

;; force resampling and issue a warning if necessary. snd-fmosc can

;; handle upsampling cases internally.

;;

(defun siosc (pitch modulation breakpoints)

(let ((modulation-srate (snd-srate modulation))

(hz (calculate-hz pitch "siosc nominal")))

(cond ((< *SOUND-SRATE* modulation-srate)

(format t "Warning: down-sampling FM modulation in siosc~%")

(setf modulation (snd-down *SOUND-SRATE* modulation))))

(scale-db (get-loud)

(snd-siosc (siosc-breakpoints breakpoints) ; tables

*SOUND-SRATE* ; output sample rate

hz ; output hz

(local-to-global 0) ; starting time

modulation)))) ; modulation

;; LFO -- freq &optional duration sound phase)

;;

;; Default duration is 1.0 sec, default sound is *TABLE*,

;; default phase is 0.0.

;;

(defun lfo (freq &optional (duration 1.0)

(sound *SINE-TABLE*) (phase 0.0))

(let ((d (get-duration duration)))

(if (minusp d) (setf d 0))

(cond ((> freq (/ *CONTROL-SRATE* 2))

(format t "Warning: lfo frequency (~A hz) will alias at current control rate (~A hz).\n"

freq *CONTROL-SRATE*)))

(set-logical-stop

(snd-osc

(car sound) ; samples for table

(cadr sound) ; step represented by table

*CONTROL-SRATE* ; output sample rate

freq ; output hz

*rslt* ; starting time

d ; duration

phase) ; phase

duration)))

;; FMLFO -- like LFO but uses frequency modulation

;;

(defun fmlfo (freq &optional (sound *SINE-TABLE*) (phase 0.0))

(let ()

(cond ((numberp freq)

(lfo freq 1.0 sound phase))

((soundp freq)

(cond ((> (snd-srate freq) *CONTROL-SRATE*)

(setf freq (force-srate *CONTROL-SRATE* freq))))

(snd-fmosc (car sound) (cadr sound) *CONTROL-SRATE* 0.0

(local-to-global 0) freq phase))

(t

(error "frequency must be a number or sound")))))

;; OSC - table lookup oscillator

;;

(defun osc (pitch &optional (duration 1.0)

(sound *TABLE*) (phase 0.0))

(let ((d (get-duration duration))

(hz (calculate-hz pitch "osc")))

(set-logical-stop

(scale-db (get-loud)

(snd-osc

(car sound) ; samples for table

(cadr sound) ; step represented by table

*SOUND-SRATE* ; output sample rate

hz ; output hz

*rslt* ; starting time

d ; duration

phase)) ; phase

duration)))

;; PARTIAL -- sine osc with built-in envelope scaling

;;

(defun partial (steps env)

(let ((hz (calculate-hz steps "partial")))

(scale-db (get-loud)

(snd-partial *sound-srate* hz

(force-srate *sound-srate* 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 (calculate-hz pitch "sampler nominal")))

; make a waveform table look like a sample with no attack:

(cond ((not (numberp samp-loop-start))

(setf samp-loop-start 0.0)))

(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 (calculate-hz steps "sine"))

(d (get-duration duration)))

(set-logical-stop

(scale-db (get-loud)

(snd-sine *rslt* hz *sound-srate* d))

duration)))

;; 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 (calculate-hz steps "pluck"))

(d (get-duration duration)))

(set-logical-stop

(scale-db (get-loud)

(snd-pluck *SOUND-SRATE* hz *rslt* d final-amp))

duration)))

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

MIN-START-TIME MAX-STOP-TIME

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

;; issue warning if sound starts in the past

(check-t0 ,s ',s)))

(defun check-t0 (s src)

(let (flag t0 (now (local-to-global 0)))

(cond ((arrayp s)

(dotimes (i (length s))

(setf t0 (snd-t0 (aref s i))))

(if (< t0 now) (setf flag t0)))

(t

(setf t0 (snd-t0 s))

(if (< t0 now) (setf flag t0))))

(if flag

(format t "Warning: cannot go back in time to ~A, sound came from ~A~%"

flag src))

; (display "check-t0" t0 now src)

; return s whether or not warning was reported

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 ((or (soundp s1) (numberp 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 x 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 x i)))))

result))

(t

(snd-scale (/ 1.0 ln10over20) (snd-log x)))))

(cond ((not (fboundp 'scalar-step-to-hz))

(setfn scalar-step-to-hz step-to-hz)

(setfn scalar-hz-to-step hz-to-step)))

(defun step-to-hz (x)

(cond ((numberp x)

(scalar-step-to-hz x))

((arrayp x)

(let* ((len (length x))

(result (make-array len)))

(dotimes (i len)

(setf (aref result i) (step-to-hz (aref x i))))

result))

(t

(s-exp (snd-offset (snd-scale 0.0577622650466621 x)

2.1011784386926213)))))

(defun hz-to-step (x)

(cond ((numberp x)

(scalar-hz-to-step x))

((arrayp x)

(let* ((len (length x))

(result (make-array len)))

(dotimes (i len)

(setf (aref result i) (hz-to-step (aref x i))))

result))

(t

(snd-scale 17.312340490667565

(snd-offset (s-log x) -2.1011784386926213)))))

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

(extract-abs (local-to-global start) (local-to-global stop) sound

(local-to-global 0)))

; extract-abs - return sound between start and stop

; start-time is optional (to aid the implementation of

; extract) and gives the start time of the result, normally 0.

; There is a problem if sound t0 is not equal to start-time.

; E.g. if sound was created with AT, its t0 might be

; in the future, but snd-xform works by first shifting

; t0 to local time zero, so we need to be very careful.

; The solution is that if t0 > start_time, subtract the difference

; from start and stop to shift them appropriately.

(defun extract-abs (start stop sound &optional (start-time 0))

(let ((t0 (snd-t0 sound)) offset)

(cond ((/= t0 start-time)

(setf offset (- t0 start-time))

(setf start (- start offset))

(setf stop (- stop offset))))

(snd-xform sound (snd-srate sound) start-time 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

;

; dur is how many seconds of sound to plot. If necessary, cut the

; sample rate to allow plotting dur seconds

; n is the number of points to plot. If there are more than n points,

; cut the sample rate. If there are fewer than n samples, just

; plot the points that exist.

;

(defun s-plot (snd &optional (dur 2.0) (n 1000))

(prog* ((sr (snd-srate snd))

(t0 (snd-t0 snd))

(filename (soundfilename *default-plot-file*))

(s snd) ;; s is either snd or resampled copy of snd

(outf (open filename :direction :output)) ;; for plot data

(maximum -1000000.0) ;; maximum amplitude

(minimum 1000000.0) ;; minimum amplitude

actual-dur ;; is the actual-duration of snd

sample-count ;; is how many samples to get from s

period ;; is the period of samples to be plotted

truncation-flag ;; true if we didn't get whole sound

points) ;; is array of samples

;; If we need more than n samples to get dur seconds, resample

(cond ((< n (* dur sr))

(setf s (force-srate (/ (float n) dur) snd))))

;; Get samples from the signal

(setf points (snd-samples s (1+ n)))

;; If we got fewer than n points, we can at least estimate the

;; actual duration (we might not know exactly if we use a lowered

;; sample rate). If the actual sample rate was lowered to avoid

;; getting more than n samples, we can now raise the sample rate

;; based on our estimate of the actual sample duration.

(display "test" (length points) n)

(cond ((< (length points) n)

;; sound is shorter than dur, estimate actual length

(setf actual-dur (/ (length points) (snd-srate s)))

(setf sample-count (round (min n (* actual-dur sr))))

(cond ((< n (* actual-dur sr))

(setf s (force-srate (/ (float n) actual-dur) snd)))

(t ;; we can use original signal

(setf s snd)))

(setf points (snd-samples s sample-count))

;; due to rounding, need to recalculate exact count

(setf sample-count (length points)))

((= (length points) n)

(setf actual-dur dur)

(setf sample-count n))

(t ;; greater than n points, so we must have truncated sound

(setf actual-dur dur)

(setf sample-count n)

(setf truncation-flag t)))

;; actual-dur is the duration of the plot

;; sample-count is how many samples we have

(setf period (/ 1.0 (snd-srate s)))

(cond ((null outf)

(format t "s-plot: could not open ~A!~%" filename)

(return nil)))

(format t "s-plot: writing ~A ... ~%" filename)

(cond (truncation-flag

(format t " !!TRUNCATING SOUND TO ~As\n" actual-dur)))

(cond ((/= (snd-srate s) (snd-srate snd))

(format t " !!RESAMPLING SOUND FROM ~A to ~Ahz\n"

(snd-srate snd) (snd-srate s))))

(cond (truncation-flag

(format t " Plotting ~As, actual sound duration is greater\n"

actual-dur))

(t

(format t " Sound duration is ~As~%" actual-dur)))

(dotimes (i sample-count)

(setf maximum (max maximum (aref points i)))

(setf minimum (min minimum (aref points i)))

(format outf "~A ~A~%" (+ t0 (* i period)) (aref points i)))

(close outf)

(format t " Wrote ~A points from ~As to ~As~%"

sample-count t0 (+ t0 actual-dur))

(format t " Range of values ~A to ~A\n" minimum maximum)

(cond ((or (< minimum -1) (> maximum 1))

(format t " !!SIGNAL EXCEEDS +/-1~%")))))

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

;; COMPUTE-DEFAULT-SOUND-FILE -- construct and set *default-sound-file*

;;

;; (this is harder than it might seem because the default place for

;; sound files is in /tmp, which is shared by users, so we'd like to

;; use a user-specific name to avoid collisions)

;;

(defun compute-default-sound-file ()

(let (inf user extension)

; the reason for the user name is that if UserA creates a temp file,

; then UserB will not be able to overwrite it. The user name is a

; way to give each user a unique temp file name. Note that we don't

; want each session to generate a unique name because Nyquist doesn't

; delete the sound file at the end of the session.

(setf user (get-user))

#|

(cond ((null user)

(format t

"Please type your user-id so that I can construct a default

sound-file name. To avoid this message in the future, add

this to your .login file:

setenv USER <your id here>

or add this to your init.lsp file:

(setf *default-sound-file* \"<your filename here>\")

(setf *default-sf-dir* \"<full pathname of desired directory here>\")

Your id please: ")

(setf user (read))))

|#

; now compute the extension based on *default-sf-format*

(cond ((= *default-sf-format* snd-head-AIFF)

(setf extension ".aif"))

((= *default-sf-format* snd-head-Wave)

(setf extension ".wav"))

(t

(setf extension ".snd")))

(setf *default-sound-file*

(strcat (string-downcase user) "-temp" extension))

(format t "Default sound file is ~A.~%" *default-sound-file*)))

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

(snd-inverse warp-fn (local-to-global 0) wrate)))

(t

(snd-compose control

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

;; (cue sound)

;; Cues the given sound; that is, it applies the current *WARP*, *LOUD*,

;; *START*, and *STOP* values to the argument. The logical start time is at

;; local time 0.

(defun cue (sound)

(cond ((arrayp sound)

(let* ((len (length sound))

(result (make-array len)))

(dotimes (i len)

(setf (aref result i)

(cue-sound (aref sound i))))

result))

(t

(cue-sound sound))))

(defun cue-sound (sound)

(snd-xform sound

(snd-srate sound)

(local-to-global 0) *START* *STOP* (db-to-linear (get-loud))))

;; (sound sound)

;; Same as (cue sound), except also warps the sound.

;; Note that the *WARP* can change the pitch of the

;; sound as a result of resampling.

;; Here's the derivation for the warping code:

;; *WARP* is a triple: (d s f) which denotes that the warp from local to

;; global time is: f(st+d)

;; We need to compose sound with the inverse of this to get a function

;; of global time

;; Let f-1 be the inverse of f. Then the inverse of f(st+d) is

;; (f-1(t) - d)/s

;; The composition gives us: (snd-compose sound (f-1(t) - d)/s)

;; Eliminate the 1/s term by changing the sample rate of sound:

;; = (snd-compose (snd-scale-srate sound s) (f-1(t) - d))

;; Eliminate the -d term by shifting f before taking the inverse:

;; = (snd-compose (scale-srate sound s) ((inverse f) - d))

;; = (snd-compose (scale-srate sound s) (inverse f(t + d)))

;; = (snd-compose (scale-srate sound s) (inverse (shift f -d)))

;; snd-inverse takes a time and sample rate. For time, use zero.

;; The sample rate of inverse determines the final sample rate of

;; this function, so use *SOUND-SRATE*:

;; = (snd-compose (scale-srate sound s) (snd-inverse (shift-time f (- d))

;; 0 *SOUND-SRATE*))

;;

(defun nyq:sound (sound)

(cond ((null (warp-function *WARP*))

(snd-xform sound (/ (snd-srate sound) (warp-stretch *WARP*))

(local-to-global 0)

*START* *STOP* (db-to-linear (get-loud))))

(t

(snd-compose (scale-srate sound (warp-stretch *WARP*))

(snd-inverse (shift-time (warp-function *WARP*)

(- (warp-time *WARP*)))

0 *SOUND-SRATE*)))))

(defun nyq:sound-of-array (sound)

(let* ((n (length sound))

(s (make-array n)))

(dotimes (i n)

(setf (aref s i) (nyq:sound (aref sound i))))

s))

(defun sound (sound)

(cond ((arrayp sound)

(nyq:sound-of-array sound))

(t

(nyq:sound sound))))

;; (SCALE-SRATE SOUND SCALE)

;; multiplies the sample rate by scale

(defun scale-srate (sound scale)

(let ((new-srate (* scale (snd-srate sound))))

(snd-xform sound new-srate (snd-time sound)

MIN-START-TIME MAX-STOP-TIME 1.0)))

;; (SHIFT-TIME SOUND SHIFT)

;; shift the time of a function by SHIFT, i.e. if SOUND is f(t),

;; then (shift-time SOUND SHIFT) is f(t - SHIFT). Note that if

;; you look at plots, the shifted sound will move *right* when SHIFT

;; is positive.