Autres/audacity
1
0
Fork 0
mirror of https://github.com/cookiengineer/audacity synced 2025-11-27 07:40:10 +01:00
Code Issues Releases Wiki Activity

Update Nyquist to v3.09.

Browse Source
This commit is contained in:
Leland Lucius
2015-04-07 22:10:17 -05:00
parent f88b27e6d8
commit 9fb0ce5b82
358 changed files with 26327 additions and 7043 deletions
Download Patch File Download Diff File Expand all files Collapse all files

55
nyquist/bug.lsp
View File

@@ -1,55 +0,0 @@
; 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)

93
nyquist/dspprims.lsp
View File

@@ -93,21 +93,8 @@
(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))
(vector #'snd-delay #'snd-delay-error #'snd-delaycv #'snd-delay-error))
;; NYQ:FEEDBACK-DELAY -- single channel delay
@@ -130,29 +117,9 @@
(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)
(defun nyq:alpassvv (the-snd delay feedback min-hz)
(let (max-delay)
(cond ((or (not (numberp min-hz))
(<= min-hz 0))
(error "alpass needs numeric (>0) 4th parameter (min-hz) when delay is variable")))
@@ -164,23 +131,22 @@
(* 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:SND-ALPASS -- ignores min-hz argument and calls snd-alpass
;;
(defun nyq:snd-alpass (snd delay feedback min-hz)
(snd-alpass snd delay feedback))
;; NYQ:SND-ALPASSCV -- ignores min-hz argument and calls snd-alpasscv
;;
(defun nyq:snd-alpasscv (snd delay feedback min-hz)
(snd-alpasscv snd delay feedback))
(setf alpass-implementations
(vector #'nyq:snd-alpass #'snd-alpass-error
#'nyq:snd-alpasscv #'nyq:alpassvv))
;; NYQ:ALPASS1 -- single channel alpass
@@ -246,7 +212,7 @@
(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))))
(mult snd (gate rms floor risetime falltime lookahead threshold))))
;; QUANTIZE -- quantize a sound
@@ -342,9 +308,11 @@
; convenient biquad: normalize a0, and use zero initial conditions.
(defun nyq:biquad (x b0 b1 b2 a0 a1 a2)
(if (< a0 1.0)
(error (format t "a0 < 1 (unstable parameter) in biquad~%")))
(let ((a0r (/ 1.0 a0)))
(snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2)
(* a0r a1) (* a0r a2) 0 0)))
(* a0r a1) (* a0r a2) 0 0)))
(defun biquad (x b0 b1 b2 a0 a1 a2)
@@ -364,8 +332,9 @@
;; NYQ:LOWPASS2 -- operates on single channel
(defun nyq:lowpass2 (x hz q)
(if (or (> hz (/ (snd-srate x) 2.0))(< hz 0))
(error "frequency out of range" hz))
(if (or (> hz (* 0.5 (snd-srate x)))
(< hz 0))
(error "cutoff frequency out of range" hz))
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
@@ -383,8 +352,9 @@
(multichan-expand #'nyq:highpass2 x hz q))
(defun nyq:highpass2 (x hz q)
(if (or (> hz (/ (snd-srate x) 2.0))(< hz 0))
(error "frequency out of range" hz))
(if (or (> hz (* 0.5 (snd-srate x)))
(< hz 0))
(error "cutoff frequency out of range" hz))
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
@@ -574,8 +544,9 @@
(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)))
; Note: gate implementation moved to nyquist.lsp
;(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)))

85
nyquist/fileio.lsp
View File

@@ -13,17 +13,25 @@
;; 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\\")
(or (setdir "c:\\tmp\\" nil)
(setdir "c:\\temp\\" nil)
(setdir "d:\\tmp\\" nil)
(setdir "d:\\temp\\" nil)
(setdir "e:\\tmp\\" nil)
(setdir "e:\\temp\\" nil)
(get-temp-path)))
(format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%"
*default-sf-dir*)
(setdir current))))
;; if the steps above fail, then *default-sf-dir* might be "" (especially
;; on windows), and the current directory could be read-only on Vista and
;; Windows 7. Therefore, the Nyquist IDE will subsequently call
;; suggest-default-sf-dir with Java's idea of a valid temp directory.
;; If *default-sf-dir* is the empty string (""), this will set the variable:
(defun suggest-default-sf-dir (path)
(cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path))))
;; s-save -- saves a file
(setf NY:ALL 1000000000) ; 1GIG constant for maxlen
(defmacro s-save (expression &optional (maxlen NY:ALL) filename
@@ -69,6 +77,7 @@
(t (error "unexpected value in multichannel-max" snd))))
;; AUTONORM -- look ahead to find peak and normalize sound to 80%
;;
(defun autonorm (snd)
@@ -89,10 +98,20 @@
(t snd))))
(init-global *clipping-threshold* (/ 127.0 128.0))
(defmacro s-save-autonorm (expression &rest arglist)
`(let ((peak (s-save (autonorm ,expression) ,@arglist)))
(when (and *clipping-error* (> peak *clipping-threshold*))
(format t "s-save-autonorm peak ~A from ~A~%" peak ,expression)
(error "clipping"))
(autonorm-update peak)))
;; If the amplitude exceeds *clipping-threshold*, an error will
;; be raised if *clipping-error* is set.
;;
(init-global *clipping-error* nil)
;; 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
@@ -113,6 +132,7 @@
;;
(init-global *autonorm-type* 'lookahead)
(init-global *autonorm-max-samples* 1000000) ; default is 4MB buffer
;;
(defun autonorm-on ()
(setf *autonorm* 1.0)
@@ -127,6 +147,17 @@
(setf *autonorm* 1.0)
(format t "AutoNorm feature is off.~%"))
(defun explain-why-autonorm-failed ()
(format t "~A~A~A~A~A~A"
" *autonorm-type* is LOOKAHEAD and your sound got\n"
" louder after the lookahead period, resulting in\n"
" too large a scale factor and clipping. Consider\n"
" setting *autonorm-type* to 'PREVIOUS. Alternatively,\n"
" try turning off autonorm, e.g. \"exec autonorm-off()\"\n"
" or in Lisp mode, (autonorm-off), and scale your sound\n"
" as follows.\n"))
;; AUTONORM-UPDATE -- called with true peak to report and prepare
;;
;; after saving/playing a file, we have the true peak. This along
@@ -146,20 +177,31 @@
(cond ((> peak 1.0)
(format t "*** CLIPPING DETECTED! ***~%")))
(cond ((and *autonormflag* (> peak 0.0))
(setf *autonorm-previous-peak* (/ peak *autonorm*))
(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*))
(cond ((eq *autonorm-type* 'PREVIOUS)
(cond ((zerop *autonorm*)
(setf *autonorm* 1.0)))
(format t " new normalization factor is ~A~%" *autonorm*))
((eq *autonorm-type* 'LOOKAHEAD)
(cond ((> peak 1.0)
(explain-why-autonorm-failed)))
(format t " suggested manual normalization factor is ~A~%"
*autonorm*))
(t
(format t
" unexpected value for *autonorm-type*, reset to LOOKAHEAD\n")
(setf *autonorm-type* 'LOOKAHEAD))))
(t
(format t "Peak was ~A,~%" peak)
(format t " suggested normalization factor is ~A~%"
(/ *autonorm-target* peak)))
(cond ((> peak 0.0)
(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*)
@@ -272,18 +314,21 @@
(defun sound-on () (setf *soundenable* t))
(defun sound-off () (setf *soundenable* nil))
(defun coterm (snd1 snd2)
(multichan-expand #'snd-coterm snd1 snd2))
(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
(sum (coterm
(s-read ny:fname
:time-offset ny:offset)
ny:addend)
ny:addend))
,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0))
,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0 0.0))
(format t "Duration written: ~A~%" (car *rslt*))
ny:peak))
@@ -291,11 +336,11 @@
(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 ,time-offset)
ny:input ny:rslt (ny:offset ,time-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))
(setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset
SND-HEAD-NONE 0 0 0 0.0))
(format t "Duration written: ~A~%" (car *rslt*))
ny:peak))

52
nyquist/misc.lsp
View File

@@ -30,11 +30,46 @@
(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))
; controlling breaks and tracebacks:
; XLISP and SAL behave differently, so there are four(!) flags:
; *sal-traceback* -- print SAL traceback on error in SAL mode
; Typically you want this on always.
; *sal-break* -- allow break (to XLISP prompt) on error when in SAL mode
; (overrides *sal-traceback*) Typically, you do not want
; this unless you need to see exactly where an error happened
; or the bug is in XLISP source code called from SAL.
; *xlisp-break* -- allow break on error when in XLISP mode
; Typically, you want this on.
; *xlisp-traceback* -- print XLISP traceback on error in XLISP mode
; Typically, you do not want this because the full
; stack can be long and tedious.
(setf *sal-mode* nil)
(setf *sal-traceback* t
*sal-break* nil
*xlisp-break* t
*xlisp-traceback* nil)
(defun sal-tracenable (flag) (setf *sal-traceback* flag))
(defun sal-breakenable (flag)
(setf *sal-break* flag)
(if *sal-mode* (setf *breakenable* flag)))
(defun xlisp-breakenable (flag)
(setf *xlisp-break* flag)
(if (not *sal-mode*) (setf *breakenable* flag)))
(defun xlisp-tracenable (flag)
(setf *xlisp-traceback* flag)
(if flag (setf *xlisp-break* t))
(cond ((not *sal-mode*)
(if flag (setf *breakenable* t))
(setf *tracenable* flag))))
; enable or disable breaks
(defun bkon () (xlisp-breakenable t))
(defun bkoff () (xlisp-breakenable nil))
(bkon)
;; (grindef 'name) - pretty print a function
;;
@@ -98,8 +133,11 @@
(cond (*loadingfiles*
(setf fullpath (car *loadingfiles*))
(dotimes (i (length fullpath))
(cond ((equal (char fullpath i) *file-separator*)
;; search for "/" (and on windows, also "\") in path:
(cond ((or (equal (char fullpath i) *file-separator*)
(equal (char fullpath i) #\/))
(setf n i))))
;; trim off filename (after last separator char in path
(setf fullpath (subseq fullpath 0 (1+ n)))
;; REMOVED SUPPORT FOR MAC OS-9 AND BELOW -RBD
@@ -148,7 +186,9 @@
(setf file-name `(strcat (current-path) ,file-name)))
(path
(setf file-name `(strcat ,path ,file-name))))
; (display "require-from" file-name)
`(if (fboundp (quote ,fn-symbol))
t
(load ,file-name)))
;; search for either .lsp or .sal file
(sal-load ,file-name)))

5
nyquist/nyinit.lsp
View File

@@ -10,6 +10,7 @@
(load "seqfnint.lsp" :verbose NIL)
(load "dspprims.lsp" :verbose NIL)
(load "velocity.lsp" :verbose NIL) ; linear-to-vel etc
(load "nyquist.lsp" :verbose NIL)
(load "follow.lsp" :verbose NIL)
@@ -30,8 +31,8 @@
(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~%~%")
(format t " Copyright (c) 1991,1992,1995,2007-2012 by Roger B. Dannenberg~%")
(format t " Version 3.09~%~%")
;(setf *gc-flag* t)

219
nyquist/nyquist.lsp
View File

@@ -153,28 +153,35 @@ functions assume durations are always positive.")))
(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 (step-to-hz (+ pitch (get-transpose)))))
(cond ((> *SOUND-SRATE* modulation-srate)
(setf modulation (snd-up *SOUND-SRATE* modulation)))
((< *SOUND-SRATE* modulation-srate)
(format t "Warning: down-sampling AM modulation in amosc~%")
(setf modulation (snd-down *SOUND-SRATE* modulation))))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: amosc frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(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
(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
@@ -185,22 +192,16 @@ functions assume durations are always positive.")))
;;
(defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0))
(let ((modulation-srate (snd-srate modulation))
(hz (step-to-hz (+ pitch (get-transpose)))))
(cond ((< *SOUND-SRATE* modulation-srate)
(format t "Warning: down-sampling FM modulation in fmosc~%")
(setf modulation (snd-down *SOUND-SRATE* modulation))))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: fmosc nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(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
(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
@@ -208,10 +209,7 @@ functions assume durations are always positive.")))
;; this code is based on FMOSC above
;;
(defun fmfb (pitch index &optional dur)
(let ((hz (step-to-hz (+ pitch (get-transpose)))))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format "Warning: fmfb nominal frequency (~A hz) will alias at current sample rate (~A hz).~%"
hz *SOUND-SRATE*)))
(let ((hz (calculate-hz pitch "fmfb")))
(setf dur (get-duration dur))
(cond ((soundp index) (ny:fmfbv hz index))
(t
@@ -236,13 +234,10 @@ functions assume durations are always positive.")))
;;
(defun buzz (n pitch modulation)
(let ((modulation-srate (snd-srate modulation))
(hz (step-to-hz (+ pitch (get-transpose)))))
(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))))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: buzz nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(setf n (max n 1)) ; avoid divide by zero problem
(scale-db (get-loud)
(snd-buzz n ; number of harmonics
@@ -333,20 +328,16 @@ loop
;;
(defun siosc (pitch modulation breakpoints)
(let ((modulation-srate (snd-srate modulation))
(hz (step-to-hz (+ pitch (get-transpose)))))
(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))))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: siosc nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(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
(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)
@@ -393,12 +384,7 @@ loop
(defun osc (pitch &optional (duration 1.0)
(sound *TABLE*) (phase 0.0))
(let ((d (get-duration duration))
(hz (step-to-hz (+ pitch (get-transpose)))))
;(display "osc" *warp* global-start global-stop actual-dur
; (get-transpose))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: osc frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(hz (calculate-hz pitch "osc")))
(set-logical-stop
(scale-db (get-loud)
(snd-osc
@@ -415,10 +401,7 @@ loop
;; PARTIAL -- sine osc with built-in envelope scaling
;;
(defun partial (steps env)
(let ((hz (step-to-hz (+ steps (get-transpose)))))
(cond ((> hz (/ *sound-srate* 2))
(format t "Warning: partial frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *sound-srate*)))
(let ((hz (calculate-hz steps "partial")))
(scale-db (get-loud)
(snd-partial *sound-srate* hz
(force-srate *sound-srate* env)))))
@@ -429,15 +412,12 @@ loop
(defun sampler (pitch modulation
&optional (sample *table*) (npoints 2))
(let ((samp (car sample))
(samp-pitch (cadr sample))
(samp-loop-start (caddr sample))
(hz (step-to-hz (+ pitch (get-transpose)))))
(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)))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: sampler nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(scale-db (get-loud)
(snd-sampler
samp ; samples for table
@@ -453,11 +433,8 @@ loop
;; SINE -- simple sine oscillator
;;
(defun sine (steps &optional (duration 1.0))
(let ((hz (step-to-hz (+ steps (get-transpose))))
(let ((hz (calculate-hz steps "sine"))
(d (get-duration duration)))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: sine frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(set-logical-stop
(scale-db (get-loud)
(snd-sine *rslt* hz *sound-srate* d))
@@ -470,11 +447,8 @@ loop
;; ("time_type" "d") ("double" "final_amp"))
;;
(defun pluck (steps &optional (duration 1.0) (final-amp 0.001))
(let ((hz (step-to-hz (+ steps (get-transpose))))
(let ((hz (calculate-hz steps "pluck"))
(d (get-duration duration)))
(cond ((> hz (/ *SOUND-SRATE* 2))
(format t "Warning: pluck frequency (~A hz) will alias at current sample rate (~A hz).\n"
hz *SOUND-SRATE*)))
(set-logical-stop
(scale-db (get-loud)
(snd-pluck *SOUND-SRATE* hz *rslt* d final-amp))
@@ -549,12 +523,29 @@ loop
;;
(defmacro at-abs (x s)
`(progv '(*WARP*)
(if (warp-function *WARP*)
(list (list (sref-inverse (warp-function *WARP*) ,x)
(warp-stretch *WARP*)
(warp-function *WARP*)))
(list (list ,x (warp-stretch *WARP*) NIL)))
,s))
(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
;
@@ -674,11 +665,25 @@ loop
; extract - start is stretched and shifted as is stop
; result is shifted to start at local time zero
(defun extract (start stop sound)
(snd-xform sound (snd-srate sound) (local-to-global 0)
(local-to-global start) (local-to-global stop) 1.0))
(extract-abs (local-to-global start) (local-to-global stop) sound
(local-to-global 0)))
(defun extract-abs (start stop sound)
(snd-xform sound (snd-srate sound) 0 start stop 1.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)
@@ -1341,22 +1346,14 @@ loop
;
(defun nyq:prod-2-sounds (s1 s2)
(cond ((numberp s1)
(cond ((numberp s2)
(* s1 s2))
(t
(scale s1 s2))))
((numberp s2)
(scale s2 s1))
(t
(let ((s1sr (snd-srate s1))
(s2sr (snd-srate s2)))
; (display "nyq:prod-2-sounds" s1sr s2sr)
(cond ((> s1sr s2sr)
(snd-prod s1 (snd-up s1sr s2)))
((< s1sr s2sr)
(snd-prod (snd-up s2sr s1) s2))
(t
(snd-prod s1 s2)))))))
(cond ((numberp s2)
(* s1 s2))
(t
(scale s1 s2))))
((numberp s2)
(scale s2 s1))
(t
(snd-prod s1 s2))))
;; RAMP -- linear ramp from 0 to x
@@ -1434,14 +1431,8 @@ loop
(snd-maxv s1 (snd-const s2 (local-to-global 0.0)
(snd-srate s1) (get-duration 1.0))))
(t
(let ((s1sr (snd-srate s1))
(s2sr (snd-srate s2)))
(cond ((> s1sr s2sr)
(snd-maxv s1 (snd-up s1sr s2)))
((< s1sr s2sr)
(snd-maxv (snd-up s2sr s1) s2))
(t
(snd-maxv s1 s2)))))))
(snd-maxv s1 s2))))
(defun s-min (s1 s2)
(setf s1 (nyq:coerce-to s1 s2))
@@ -1472,14 +1463,8 @@ loop
(snd-minv s1 (snd-const s2 (local-to-global 0.0)
(snd-srate s1) (get-duration 1.0))))
(t
(let ((s1sr (snd-srate s1))
(s2sr (snd-srate s2)))
(cond ((> s1sr s2sr)
(snd-minv s1 (snd-up s1sr s2)))
((< s1sr s2sr)
(snd-minv (snd-up s2sr s1) s2))
(t
(snd-minv s1 s2)))))))
(snd-minv s1 s2))))
(defun snd-minv (s1 s2)
(scale -1.0 (snd-maxv (scale -1.0 s1) (scale -1.0 s2))))
@@ -1682,8 +1667,8 @@ loop
;;; operations on sounds
(defun diff (x &optional y)
(cond (y (sum x (prod -1 y)))
(defun diff (x &rest y)
(cond (y (sum x (prod -1 (car y))))
(t (prod -1 x))))
; compare-shape is a shape table -- origin 1.

8
nyquist/sal-parse.lsp
View File

@@ -51,8 +51,8 @@
(:/ "/" /)
(:% "%" rem)
(:^ "^" expt)
(:= "=" eql) ; equality and assigment
(:!= "!=" not-eql)
(:= "=" sal-equal) ; equality and assigment
(:!= "!=" not-sal-equal)
(:< "<" <)
(:> ">" >)
(:<= "<=" <=) ; leq and assignment minimization
@@ -1419,7 +1419,7 @@
((eq op '/=) (setq expr `(/ ,vref ,expr)))
((eq op '&=) (setq expr `(nconc ,vref (list ,expr))))
((eq op '@=) (setq expr `(cons ,expr ,vref)))
((eq op '^=) (setq expr `(nconc ,vref (copy-list ,expr))))
((eq op '^=) (setq expr `(nconc ,vref (append ,expr nil))))
((eq op '<=) (setq expr `(min ,vref ,expr)))
((eq op '>=) (setq expr `(max ,vref ,expr)))
(t (errexit (format nil "unknown assigment operator ~A" op))))
@@ -1605,7 +1605,7 @@
(and term-test (member (car term-test) '(>= >))))
(setf binding (list id init (list '1+ id))))
(t ; loop goes down because of "above" or "downto"
(display "for step" term-test)
; (display "for step" term-test)
(setf binding (list id init (list '1- id)))))
(setf binding (list binding)))
(t

93
nyquist/sal.lsp
View File

@@ -198,14 +198,15 @@
(defparameter *sal-print-list* t)
(defun sal-printer (x &key (stream *standard-output*) (add-space t))
(defun sal-printer (x &key (stream *standard-output*) (add-space t)
(in-list nil))
(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))
:add-space (cdr items) :in-list t)
(cond ((cdr items)
(cond ((not (consp (cdr items)))
(princ "<list not well-formed> " stream)
@@ -214,6 +215,7 @@
(write-char #\} stream))
((not x) (princ "#f" stream) )
((eq x t) (princ "#t" stream))
(in-list (prin1 x stream))
(t (princ x stream)))
(if add-space (write-char #\space stream))))
@@ -224,9 +226,14 @@
(apply #'format t string args))
;; sal-print has been modified from the original SAL to print items separated
;; by spaces (no final trailing space) and followed by a newline.
(defun sal-print (&rest args)
(do ((items args (cdr items)))
((null items))
;; add space unless we are at the last element
(funcall *sal-printer* (car items) :add-space (cdr items)))
(terpri)
(mapc *sal-printer* args)
(values))
(defmacro keyword (sym)
@@ -319,7 +326,7 @@
(cond ((null fullpath)
(format t "sal-load: could not find ~A~%" filename))
(t
(return (generic-loader filename verbose print)))))))
(return (generic-loader fullpath verbose print)))))))
;; GENERIC-LOADER -- load a sal or lsp file based on extension
@@ -455,10 +462,12 @@
;; function called in sal programs to exit the sal read-compile-run-print loop
(defun sal-exit () (setf *sal-exit* t))
(setf *sal-call-stack* nil)
;; read-eval-print loop for sal commands
(defun sal ()
(progv '(*breakenable* *tracenable* *sal-exit*)
(list *sal-xlispbreak* *sal-xlispbreak* nil)
(progv '(*breakenable* *tracenable* *sal-exit* *sal-mode*)
(list *sal-break* nil nil t)
(let (input line)
(setf *sal-call-stack* nil)
(read-line) ; read the newline after the one the user
@@ -478,9 +487,14 @@
(setf input (subseq input 1)))
(sal-compile input t nil "<console>")
(sal-trace-exit))
(princ "Returning to Lisp ...\n")
t ; return value
)))
(princ "Returning to Lisp ...\n")))
;; in case *xlisp-break* or *xlisp-traceback* was set from SAL, impose
;; them here
(cond ((not *sal-mode*)
(setf *breakenable* *xlisp-break*)
(setf *tracenable* *xlisp-traceback*)))
t)
(defun sal-error-output (stack)
@@ -514,44 +528,48 @@
;; otherwise, returns a list (PROGN p1 p2 p3 ...) where pn are lisp
;; expressions
;;
(defun sal-compile (input eval-flag multiple-statements filename)
;; Note: replaced local variables here with "local" names to avoid
;; collisions with globals that compiled code might try to use:
;; eval uses local bindings, not global ones
;;
(defun sal-compile (sal:input sal:evflag sal:mult-stmts sal: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*)
(let (sal:output sal:remainder sal:rslt sal:stack)
(setf sal:stack *sal-call-stack*)
;; if first input char is "(", then eval as a lisp expression:
;(display "sal-compile" input)(setf *sal-compiler-debug* t)
(cond ((input-starts-with-open-paren input)
;(print "input is lisp expression")
;(display "sal-compile" sal:input)(setf *sal-compiler-debug* t)
(cond ((input-starts-with-open-paren sal:input)
;(print "sal:input is lisp expression")
(errset
(print (eval (read (make-string-input-stream input)))) t))
(print (eval (read (make-string-input-stream sal: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))
(setf sal:output (sal-parse nil nil sal:input sal:mult-stmts
sal:filename))
(cond ((first sal:output) ; successful parse
(setf sal:remainder *sal-tokens*)
(setf sal:output (second sal: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)
(pprint sal:output))
(cond (sal:evflag ;; evaluate the compiled code
(cond ((null (errset (eval sal:output) t))
(sal-error-output sal:stack)
(return)))) ;; stop on error
(t
(push output rslt)))
(push sal:output sal:rslt)))
;(display "sal-compile after eval"
; remainder *sal-tokens*)
; sal: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))
(cond ((and sal:mult-stmts sal:remainder)
;; move sal:remainder to sal:input and iterate
(setf sal:input sal: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)
((and (not sal:evflag) (not sal:remainder))
(return (cons 'progn (reverse sal:rslt))))
;; if eval but no more sal:input, return
((not sal:remainder)
(return))))
(t ; error encountered
(return)))))))))
@@ -568,3 +586,10 @@
(and (stringp input)
(> (length input) i)
(eq (char input i) #\())))
(defun sal-equal (a b)
(or (and (numberp a) (numberp b) (= a b))
(equal a b)))
(defun not-sal-equal (a b)
(not (sal-equal a b)))

41
nyquist/seq.lsp
View File

@@ -209,7 +209,48 @@
;; (2) EVAL is used on each event, so events cannot refer to parameters
;; or local variables
;;
;; If score events are very closely spaced (< 1020 samples), the block
;; overlap can cause a ripple effect where to complete one block of the
;; output, you have to compute part of the next score event, but then
;; it in turn computes part of the next score event, and so on, until
;; the stack overflows (if you have 1000's of events).
;;
;; This is really a fundamental problem in Nyquist because blocks are
;; not aligned. To work around the problem (but not totally solve it)
;; scores are evaluated up to a length of 100. If there are more than
;; 100 score events, we form a balanced tree of adders so that maybe
;; we will end up with a lot of sound in memory, but at least the
;; stack will not overflow. Generally, we should not end up with more
;; than 100 times as many blocks as we would like, but since the
;; normal space required is O(1), we're still using constant space +
;; a small constant * log(score-length).
;;
(setf MAX-LINEAR-SCORE-LEN 100)
(defun timed-seq (score)
(let ((len (length score))
pair)
(cond ((< len MAX-LINEAR-SCORE-LEN)
(timed-seq-linear score))
(t ;; split the score -- divide and conquer
(setf pair (score-split score (/ len 2)))
(sum (timed-seq (car pair)) (timed-seq (cdr pair)))))))
;; score-split -- helper function: split score into two, with n elements
;; in the first part; returns a dotted pair
(defun score-split (score n)
;; do the split without recursion to avoid stack overflow
;; algorithm: modify the list destructively to get the first
;; half. Copy it. Reassemble the list.
(let (pair last front back)
(setf last (nthcdr (1- n) score))
(setf back (cdr last))
(rplacd last nil)
(setf front (append score nil)) ; shallow copy
(rplacd last back)
(cons front back)))
(defun timed-seq-linear (score)
; check to insure that times are strictly increasing and >= 0 and stretches are >= 0
(let ((start-time 0) error-msg)
(dolist (event score)

4
nyquist/sndfnint.lsp
View File

@@ -39,6 +39,8 @@
(setf snd-head-CAF 19)
(setf snd-head-raw 20)
(setf snd-head-OGG 21)
(setf snd-head-channels 1)
@@ -77,6 +79,8 @@
(setf snd-mode-DPCM 10)
(setf snd-mode-msadpcm 11)
(setf snd-mode-vorbis 12)
(SETF MAX-STOP-TIME 10E20)

10
nyquist/stk.lsp
View File

@@ -131,13 +131,13 @@
(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*))
(snd-stkrev 0 snd rev-time mix))
(defun nyq:jcrev (snd rev-time mix)
(snd-stkrev 1 snd rev-time mix *sound-srate*))
(snd-stkrev 1 snd rev-time mix))
(defun nyq:prcrev (snd rev-time mix)
(snd-stkrev 2 snd rev-time mix *sound-srate*))
(snd-stkrev 2 snd rev-time mix))
(defun nrev (snd rev-time mix)
(multichan-expand #'nyq:nrev snd rev-time mix))
@@ -149,13 +149,13 @@
(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*))
(snd-stkchorus snd base-delay depth freq mix))
(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*))
(snd-stkpitshift snd shift mix))
(defun pitshift (snd shift mix)
(multichan-expand #'nyq:pitshift snd shift mix))

43
nyquist/test.lsp Normal file
View File

@@ -0,0 +1,43 @@
(defun ss () (osc c5))
(defun tt () (stretch 2 (snd-tapv (ss) 1.1 (scale *d* (lfo 10)) 2.2)))
(setf *d* .01)
(defun g () (play (tt)))
;(set-sound-srate 10)
;(set-control-srate 10)
(defun rr () (stretch 10 (ramp)))
(defun ll () (stretch 10 (lfo .5)))
(defun xx () (snd-tapv (rr) 1.1 (ll) 2.2))
(defun h () (snd-samples (xx) 150))
(defun chorus (sound maxdepth depth rate saturation)
(let ((modulation (prod depth (stretch-abs 10000.0 (general-lfo rate))))
(offset (/ maxdepth 2.0))
chor)
(setf chor (snd-tapv sound offset modulation maxdepth))
(sum (prod chor saturation) (prod (seq (s-rest offset) sound)
(sum 1.0 (prod -1.0 saturation))))))
(set-sound-srate 22050.0)
(defun f ()
(chorus (s-read "runtime\\ah.wav") .1 .1 1 .5))
(defun e ()
(seq (s-rest .05) (chorus (s-read "rpd.wav") .07 .07 .7 .5)))
(defun d () (sum (e) (f)))
(defun rou () (s-read "round.wav" :time-offset 1.18 :dur (- 8.378 1.18)))
(defun rou4 () (sim (rou)
(at *rd* (rou))
(at (* *rd* 2) (rou))
(at (* *rd* 3) (rou))))

53
nyquist/upic.sal Normal file
View File

@@ -0,0 +1,53 @@
;; upic.sal -- play upic data
;;
define function upic(data)
begin
if data then
;; use reverse to make a copy of data since sort is destructive
return upic-curve(sort(reverse(data), quote(upic-compare)))
else
return s-rest()
end
define function upic-compare(a, b)
return third(a) < third(b)
define function upic-curve(data)
begin
with curve = first(data),
waveform = first(curve),
envelope = second(curve),
points = cddr(curve),
from-time = first(points),
to-time = nth(length(points) - 2, points),
dur = to-time - from-time,
next = rest(data),
next-start, snd
;; shift curve to start at t = 0
loop
with relpoints
while points
set relpoints @= first(points) - from-time
set relpoints @= second(points)
set points = cddr(points)
finally set points = cdr(reverse(relpoints))
end
set snd = hzosc(pwlv-list(points), symbol-value(waveform)) *
(funcall(envelope) ~ dur)
if next then
begin
set next-start = third(first(next))
;; display "curve", from-time, dur
set snd = seq(set-logical-stop(snd, next-start - from-time),
upic-curve(next))
end
return snd
end
define function upic-env()
return env(0.01, 0.01, 0.01, 1, 1, 1)

24
nyquist/velocity.lsp Normal file
View File

@@ -0,0 +1,24 @@
;; velocity.lsp -- conversion routines for MIDI velocity
;;
;; Roger B. Dannenberg
;; July, 2012
(defun db-to-vel (x &optional float)
(linear-to-vel (db-to-linear x) float))
(defun linear-to-vel (x &optional float)
(setf x (/ (- (sqrt (abs x)) 0.0239372) 0.00768553))
(cond (float x)
(t
(setf x (round x))
(max 1 (min 127 x)))))
(defun vel-to-db (v)
(linear-to-db (vel-to-linear v)))
(defun vel-to-linear (v)
(power (+ (* v 0.00768553) 0.0239372) 2))

92
nyquist/xm.lsp
View File

@@ -1375,7 +1375,9 @@ pattern argument (by default).
`(let (sg:seq (sg:start ,score-begin) sg:ioi
(sg:score-len ,score-len) (sg:score-dur ,score-dur)
(sg:count 0) (sg:save ,save)
(sg:begin ,score-begin) (sg:end ,score-end))
(sg:begin ,score-begin) (sg:end ,score-end) sg:det-end)
;; sg:det-end is a flag that tells us to determine the end time
(cond ((null sg:end) (setf sg:end 0 sg:det-end t)))
;; make sure at least one of score-len, score-dur is present
(loop
(cond ((or (and sg:score-len (<= sg:score-len sg:count))
@@ -1392,17 +1394,19 @@ pattern argument (by default).
(format t "get-seq trace at ~A stretch ~A: ~A~%"
sg:start sg:dur (car sg:seq))))
(incf sg:count)
(setf sg:start ,next-expr))
(setf sg:start ,next-expr)
;; end time of score will be max over start times of the next note
;; this bases the score duration on ioi's rather than durs. But
;; if user specified sg:end, sg:det-end is false and we do not
;; try to compute sg:end.
(cond ((and sg:det-end (> sg:start sg:end))
(setf sg:end sg:start))))
(setf sg:seq (reverse sg:seq))
;; avoid sorting a sorted list -- XLisp's quicksort can overflow the
;; stack if the list is sorted because (apparently) the pivot points
;; are not random.
(cond ((not (score-sorted sg:seq))
(setf sg:seq (bigsort sg:seq #'event-before))))
(cond ((and sg:seq (null sg:end))
(setf sg:end (event-end (car (last sg:seq)))))
((null sg:end)
(setf sg:end 0)))
(push (list 0 0 (list 'SCORE-BEGIN-END ,score-begin sg:end)) sg:seq)
(cond (sg:save (set sg:save sg:seq)))
sg:seq)))
@@ -1625,12 +1629,23 @@ pattern argument (by default).
;; SCORE-SORT -- sort a score into time order
;;
;; If begin-end exists, preserve it. If not, compute
;; it from the sorted score.
;;
(defun score-sort (score &optional (copy-flag t))
(setf score (score-must-have-begin-end score))
(let ((begin-end (car score)))
(setf score (cdr score))
(if copy-flag (setf score (append score nil)))
(cons begin-end (bigsort score #'event-before))))
(let* ((score1 (score-must-have-begin-end score))
(begin-end (car score1))
;; if begin-end already existed, then it will
;; be the first of score. Otherwise, one must
;; have been generated above by score-must-have-begin-end
;; in which case we should create it again after sorting.
(needs-begin-end (not (eq begin-end (first score)))))
(setf score1 (cdr score1)) ;; don't include begin-end in sort.
(if copy-flag (setf score1 (append score1 nil)))
(setf score1 (bigsort score1 #'event-before))
(if needs-begin-end (score-must-have-begin-end score1)
(cons begin-end score1))
))
;; PUSH-SORT -- insert an event in (reverse) sorted order
@@ -1762,14 +1777,26 @@ pattern argument (by default).
from-time to-time))
(cdr score)))))
;; Get the second element of params (the value field) and turn it
;; into a numeric value if possible (by looking up a global variable
;; binding). This allows scores to say C4 instead of 60.
;;
(defun get-numeric-value (params)
(let ((v (cadr params)))
(cond ((and (symbolp v) (boundp v) (numberp (symbol-value v)))
(setf v (symbol-value v))))
v))
(defun params-transpose (params keyword amount)
(cond ((null params) nil)
((and (eq keyword (car params))
(numberp (cadr params)))
(cons (car params)
(cons (+ amount (cadr params))
(cddr params))))
((eq keyword (car params))
(let ((v (get-numeric-value params)))
(cond ((numberp v)
(setf v (+ v amount))))
(cons (car params)
(cons v (cddr params)))))
(t (cons (car params)
(cons (cadr params)
(params-transpose (cddr params) keyword amount))))))
@@ -1789,11 +1816,12 @@ pattern argument (by default).
(defun params-scale (params keyword amount)
(cond ((null params) nil)
((and (eq keyword (car params))
(numberp (cadr params)))
(cons (car params)
(cons (* amount (cadr params))
(cddr params))))
((eq keyword (car params))
(let ((v (get-numeric-value params)))
(cond ((numberp v)
(setf v (* v amount))))
(cons (car params)
(cons v (cddr params)))))
(t (cons (car params)
(cons (cadr params)
(params-scale (cddr params) keyword amount))))))
@@ -2124,6 +2152,18 @@ pattern argument (by default).
(t nil))))
;; SCORE-READ -- read a standard MIDI file to a score
;;
(defun score-read (filename)
(let ((seq (seq-create))
(file (open filename)))
(cond (file
(seq-read seq file)
(close file)
(score-from-seq seq))
(t nil))))
;; SET-PROGRAM-TO -- a helper function to set a list value
(defun set-program-to (lis index value default)
;; if length or lis <= index, extend the lis with default
@@ -2167,8 +2207,12 @@ exit
(return (score-sort score))))
(defun score-write-smf (score filename &optional programs)
(let ((file (open-binary filename :direction :output))
(defun score-write (score filename &optional programs)
(score-write-smf score filename programs t))
(defun score-write-smf (score filename &optional programs as-adagio)
(let ((file (if as-adagio (open filename :direction :output)
(open-binary filename :direction :output)))
(seq (seq-create))
(chan 1))
(cond (file
@@ -2199,7 +2243,7 @@ exit
(seq-insert-note seq (round (* time 1000))
0 (1+ chan) (round pitch)
(round (* dur 1000)) (round vel))))))
(seq-write-smf seq file)
(if as-adagio (seq-write seq file) (seq-write-smf seq file))
(close file)))))