418 lines
17 KiB
Common Lisp
418 lines
17 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 *in-s-save* nil)
|
|
(setf NY:ALL 576460752303423488) ; constant for maxlen == 1 << 59
|
|
;; note that at 16-bytes-per-frame, this could generate a file byte offset
|
|
;; that overflows an int64_t. Is this big enough? Time will tell.
|
|
;; What if Nyquist is compiled for 32-bit machines and FIXNUM is 32-bits?
|
|
;; if we don't have 64-bit ints, use 0x7f000000, which is about 10M less
|
|
;; than the maximum signed 32-bit int, giving a lot of "headroom" but still
|
|
;; over 2 billion, or about 13.4 hours at 44.1KHz
|
|
(if (/= 10000000000 (* 100000 100000))
|
|
(setf NY:ALL 2130706432))
|
|
|
|
|
|
;; S-SAVE combines optional and keyword parameters, but this is a really bad
|
|
;; idea because keywords and values are used as optional parameters until
|
|
;; all the optional parameters are used up. Thus if you leave out filename
|
|
;; and progress, but you provide :endian T, then filename becomes :endian and
|
|
;; progress becomes T. AARRGG!!
|
|
;; I should have required filename and made everything else keyword, but
|
|
;; rather than breaking compatibility, I'm using &rest to grab everything,
|
|
;; parse the parameters for keywords (giving them priority over optional
|
|
;; parameters, and filling in optional parameters as they are encountered.
|
|
;;
|
|
(defmacro s-save (expression &rest parameters)
|
|
(prog (parm (format *default-sf-format*)
|
|
(mode *default-sf-mode*)
|
|
(bits *default-sf-bits*)
|
|
;; endian can be nil, :big, or :little
|
|
endian play optionals maxlen filename progress swap)
|
|
loop ;; until all parameters are used
|
|
(cond ((setf parm (car parameters))
|
|
(setf parameters (cdr parameters))
|
|
(case parm
|
|
(:format (setf format (car parameters)
|
|
parameters (cdr parameters)))
|
|
(:mode (setf mode (car parameters)
|
|
parameters (cdr parameters)))
|
|
(:bits (setf bits (car parameters)
|
|
parameters (cdr parameters)))
|
|
(:endian (setf endian (car parameters)
|
|
parameters (cdr parameters)))
|
|
(:play (setf play (car parameters)
|
|
parameters (cdr parameters)))
|
|
(t (setf optionals (cons parm optionals))))
|
|
(go loop)))
|
|
(cond ((> (length optionals) 3)
|
|
(error "S-SAVE got extra parameter(s)")))
|
|
(cond ((< (length optionals) 1) ;; need maxlen
|
|
(setf optionals (list ny:all))))
|
|
(cond ((< (length optionals) 2) ;; need filename
|
|
(setf optionals (cons nil optionals))))
|
|
(cond ((< (length optionals) 3) ;; need progress
|
|
(setf optionals (cons 0 optionals))))
|
|
(setf progress (first optionals) ;; note that optionals are in reverse order
|
|
filename (second optionals)
|
|
maxlen (third optionals))
|
|
(cond (*in-s-save*
|
|
(error "Recursive call to S-SAVE (or maybe PLAY) detected!")))
|
|
|
|
;; finally, we have all the parameters and we can call snd-save
|
|
(return
|
|
`(let ((ny:fname ,filename) (ny:swap 0) (ny:endian ,endian)
|
|
(ny:play ,play)
|
|
ny:max-sample) ; return value
|
|
(progv '(*in-s-save*) '(t)
|
|
(if (null ny:fname)
|
|
(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))))
|
|
|
|
; print device info the first time sound is played
|
|
(cond (ny:play
|
|
(cond ((not (boundp '*snd-list-devices*))
|
|
(setf *snd-list-devices* t))))) ; one-time show
|
|
(setf max-sample
|
|
(snd-save ',expression ,maxlen ny:fname ,format
|
|
,mode ,bits ny:swap ny:play ,progress))
|
|
; more information if *snd-list-devices* was unbound:
|
|
(cond (ny:play
|
|
(cond (*snd-list-devices*
|
|
(format t "\nSet *snd-lfist-devices* = t \n ~
|
|
and call play to see device list again.\n~
|
|
Set *snd-device* to a fixnum to select an output device\n ~
|
|
or set *snd-device* to a substring of a device name\n ~
|
|
to select the first device containing the substring.\n")))
|
|
(setf *snd-list-devices* nil))) ; normally nil
|
|
max-sample)))))
|
|
|
|
|
|
;; 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 10e20) (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 (snd-read-format *rslt*))
|
|
(setf channels (snd-read-channels *rslt*))
|
|
(setf mode (snd-read-mode *rslt*))
|
|
(setf bits (snd-read-bits *rslt*))
|
|
; (setf swap (snd-read-swap *rslt*))
|
|
(setf srate (snd-read-srate *rslt*))
|
|
(setf dur (snd-read-dur *rslt*))
|
|
(setf flags (snd-read-flags *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 snd-read-format car)
|
|
(setfn snd-read-channels cadr)
|
|
(setfn snd-read-mode caddr)
|
|
(setfn snd-read-bits cadddr)
|
|
(defun snd-read-swap (rslt) (car (cddddr rslt)))
|
|
(defun snd-read-srate (rslt) (cadr (cddddr rslt)))
|
|
(defun snd-read-dur (rslt) (caddr (cddddr rslt)))
|
|
(defun snd-read-flags (rslt) (cadddr (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) (progress 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 ,progress))
|
|
(format t "Duration written: ~A~%" (car *rslt*))
|
|
ny:peak))
|
|
|
|
|
|
(defmacro s-overwrite (expr maxlen filename
|
|
&optional (time-offset 0.0) (progress 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:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset ,progress))
|
|
(format t "Duration written: ~A~%" (car *rslt*))
|
|
ny:peak))
|
|
|
|
|
|
|
|
|