350 lines
14 KiB
Common Lisp
350 lines
14 KiB
Common Lisp
;; 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\\" 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
|
|
&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))))
|
|
|
|
|
|
(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
|
|
;; 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.~%"))
|
|
|
|
(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
|
|
;; 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)
|
|
(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)
|
|
(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*)
|
|
(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))
|
|
|
|
(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 (coterm
|
|
(s-read ny:fname
|
|
:time-offset ny:offset)
|
|
ny:addend)
|
|
ny:addend))
|
|
,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 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 ,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 ny:offset
|
|
SND-HEAD-NONE 0 0 0 0.0))
|
|
(format t "Duration written: ~A~%" (car *rslt*))
|
|
ny:peak))
|
|
|
|
|
|
|
|
|