1;; fileio.lsp 2 3;; if *default-sf-dir* undefined, set it to user's tmp directory 4;; 5(cond ((not (boundp '*default-sf-dir*)) 6 ;; it would be nice to use get-temp-path, but when running 7 ;; the Java-based IDE, Nyquist does not get environment 8 ;; variables to tell TMP or TEMP or USERPROFILE 9 ;; We want to avoid the current directory because it may 10 ;; be read-only. Search for some likely paths... 11 ;; Note that since these paths don't work for Unix or OS X, 12 ;; they will not be used, so no system-dependent code is 13 ;; needed 14 (let ((current (setdir "."))) 15 (setf *default-sf-dir* 16 (or (setdir "c:\\tmp\\" nil) 17 (setdir "c:\\temp\\" nil) 18 (setdir "d:\\tmp\\" nil) 19 (setdir "d:\\temp\\" nil) 20 (setdir "e:\\tmp\\" nil) 21 (setdir "e:\\temp\\" nil) 22 (get-temp-path))) 23 (format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%" 24 *default-sf-dir*) 25 (setdir current)))) 26 27;; if the steps above fail, then *default-sf-dir* might be "" (especially 28;; on windows), and the current directory could be read-only on Vista and 29;; Windows 7. Therefore, the Nyquist IDE will subsequently call 30;; suggest-default-sf-dir with Java's idea of a valid temp directory. 31;; If *default-sf-dir* is the empty string (""), this will set the variable: 32(defun suggest-default-sf-dir (path) 33 (cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path)))) 34 35;; s-save -- saves a file 36(setf *in-s-save* nil) 37(setf NY:ALL 576460752303423488) ; constant for maxlen == 1 << 59 38;; note that at 16-bytes-per-frame, this could generate a file byte offset 39;; that overflows an int64_t. Is this big enough? Time will tell. 40;; What if Nyquist is compiled for 32-bit machines and FIXNUM is 32-bits? 41;; if we don't have 64-bit ints, use 0x7f000000, which is about 10M less 42;; than the maximum signed 32-bit int, giving a lot of "headroom" but still 43;; over 2 billion, or about 13.4 hours at 44.1KHz 44(if (/= 10000000000 (* 100000 100000)) 45 (setf NY:ALL 2130706432)) 46 47 48;; S-SAVE combines optional and keyword parameters, but this is a really bad 49;; idea because keywords and values are used as optional parameters until 50;; all the optional parameters are used up. Thus if you leave out filename 51;; and progress, but you provide :endian T, then filename becomes :endian and 52;; progress becomes T. AARRGG!! 53;; I should have required filename and made everything else keyword, but 54;; rather than breaking compatibility, I'm using &rest to grab everything, 55;; parse the parameters for keywords (giving them priority over optional 56;; parameters, and filling in optional parameters as they are encountered. 57;; 58(defmacro s-save (expression &rest parameters) 59 (prog (parm (format *default-sf-format*) 60 (mode *default-sf-mode*) 61 (bits *default-sf-bits*) 62 ;; endian can be nil, :big, or :little 63 endian play optionals maxlen filename progress swap) 64 loop ;; until all parameters are used 65 (cond ((setf parm (car parameters)) 66 (setf parameters (cdr parameters)) 67 (case parm 68 (:format (setf format (car parameters) 69 parameters (cdr parameters))) 70 (:mode (setf mode (car parameters) 71 parameters (cdr parameters))) 72 (:bits (setf bits (car parameters) 73 parameters (cdr parameters))) 74 (:endian (setf endian (car parameters) 75 parameters (cdr parameters))) 76 (:play (setf play (car parameters) 77 parameters (cdr parameters))) 78 (t (setf optionals (cons parm optionals)))) 79 (go loop))) 80 (cond ((> (length optionals) 3) 81 (error "S-SAVE got extra parameter(s)"))) 82 (cond ((< (length optionals) 1) ;; need maxlen 83 (setf optionals (list ny:all)))) 84 (cond ((< (length optionals) 2) ;; need filename 85 (setf optionals (cons nil optionals)))) 86 (cond ((< (length optionals) 3) ;; need progress 87 (setf optionals (cons 0 optionals)))) 88 (setf progress (first optionals) ;; note that optionals are in reverse order 89 filename (second optionals) 90 maxlen (third optionals)) 91 (cond (*in-s-save* 92 (error "Recursive call to S-SAVE (or maybe PLAY) detected!"))) 93 94 ;; finally, we have all the parameters and we can call snd-save 95 (return 96 `(let ((ny:fname ,filename) (ny:swap 0) (ny:endian ,endian) 97 (ny:play ,play) 98 ny:max-sample) ; return value 99 (progv '(*in-s-save*) '(t) 100 (if (null ny:fname) 101 (setf ny:fname *default-sound-file*)) 102 103 (cond ((equal ny:fname "") 104 (cond ((not ,play) 105 (format t "S-SAVE: no file to write! ~ 106 play option is off!\n")))) 107 (t 108 (setf ny:fname (soundfilename ny:fname)) 109 (format t "Saving sound file to ~A~%" ny:fname))) 110 111 (cond ((eq ny:endian :big) 112 (setf ny:swap (if (bigendianp) 0 1))) 113 ((eq ny:endian :little) 114 (setf ny:swap (if (bigendianp) 1 0)))) 115 116 ; print device info the first time sound is played 117 (cond (ny:play 118 (cond ((not (boundp '*snd-list-devices*)) 119 (setf *snd-list-devices* t))))) ; one-time show 120 (setf max-sample 121 (snd-save ',expression ,maxlen ny:fname ,format 122 ,mode ,bits ny:swap ny:play ,progress)) 123 ; more information if *snd-list-devices* was unbound: 124 (cond (ny:play 125 (cond (*snd-list-devices* 126 (format t "\nSet *snd-lfist-devices* = t \n ~ 127 and call play to see device list again.\n~ 128 Set *snd-device* to a fixnum to select an output device\n ~ 129 or set *snd-device* to a substring of a device name\n ~ 130 to select the first device containing the substring.\n"))) 131 (setf *snd-list-devices* nil))) ; normally nil 132 max-sample))))) 133 134 135;; MULTICHANNEL-MAX -- find peak over all channels 136;; 137(defun multichannel-max (snd samples) 138 (cond ((soundp snd) 139 (snd-max snd samples)) 140 ((arrayp snd) ;; assume it is multichannel sound 141 (let ((peak 0.0) (chans (length snd))) 142 (dotimes (i chans) 143 (setf peak (max peak (snd-max (aref snd i) (/ samples chans))))) 144 peak)) 145 (t (error "unexpected value in multichannel-max" snd)))) 146 147 148 149;; AUTONORM -- look ahead to find peak and normalize sound to 80% 150;; 151(defun autonorm (snd) 152 (let (peak) 153 (cond (*autonormflag* 154 (cond ((and (not (soundp snd)) 155 (not (eq (type-of snd) 'ARRAY))) 156 (error "AUTONORM (or PLAY?) got unexpected value" snd)) 157 ((eq *autonorm-type* 'previous) 158 (scale *autonorm* snd)) 159 ((eq *autonorm-type* 'lookahead) 160 (setf peak (multichannel-max snd *autonorm-max-samples*)) 161 (setf peak (max 0.001 peak)) 162 (setf *autonorm* (/ *autonorm-target* peak)) 163 (scale *autonorm* snd)) 164 (t 165 (error "unknown *autonorm-type*")))) 166 (t snd)))) 167 168 169(init-global *clipping-threshold* (/ 127.0 128.0)) 170 171(defmacro s-save-autonorm (expression &rest arglist) 172 `(let ((peak (s-save (autonorm ,expression) ,@arglist))) 173 (when (and *clipping-error* (> peak *clipping-threshold*)) 174 (format t "s-save-autonorm peak ~A from ~A~%" peak ,expression) 175 (error "clipping")) 176 (autonorm-update peak))) 177 178;; If the amplitude exceeds *clipping-threshold*, an error will 179;; be raised if *clipping-error* is set. 180;; 181(init-global *clipping-error* nil) 182 183;; The "AutoNorm" facility: when you play something, the Nyquist play 184;; command will automatically compute what normalization factor you 185;; should have used. If you play the same thing again, the normalization 186;; factor is automatically applied. 187;; 188;; Call AUTONORM-OFF to turn off this feature, and AUTONORM-ON to turn 189;; it back on. 190;; 191;; *autonorm-target* is the peak value we're aiming for (it's set below 1 192;; so allow the next signal to get slightly louder without clipping) 193;; 194(init-global *autonorm-target* 0.9) 195;; 196;; *autonorm-type* selects the autonorm algorithm to use 197;; 'previous means normalize according to the last computed sound 198;; 'precompute means precompute *autonorm-max-samples* samples in 199;; memory and normalize according to the peak 200;; 201(init-global *autonorm-type* 'lookahead) 202(init-global *autonorm-max-samples* 1000000) ; default is 4MB buffer 203 204;; 205(defun autonorm-on () 206 (setf *autonorm* 1.0) 207 (setf *autonorm-previous-peak* 1.0) 208 (setf *autonormflag* t) 209 (format t "AutoNorm feature is on.~%")) 210 211(if (not (boundp '*autonormflag*)) (autonorm-on)) 212 213(defun autonorm-off () 214 (setf *autonormflag* nil) 215 (setf *autonorm* 1.0) 216 (format t "AutoNorm feature is off.~%")) 217 218(defun explain-why-autonorm-failed () 219 (format t "~A~A~A~A~A~A" 220 " *autonorm-type* is LOOKAHEAD and your sound got\n" 221 " louder after the lookahead period, resulting in\n" 222 " too large a scale factor and clipping. Consider\n" 223 " setting *autonorm-type* to 'PREVIOUS. Alternatively,\n" 224 " try turning off autonorm, e.g. \"exec autonorm-off()\"\n" 225 " or in Lisp mode, (autonorm-off), and scale your sound\n" 226 " as follows.\n")) 227 228 229;; AUTONORM-UPDATE -- called with true peak to report and prepare 230;; 231;; after saving/playing a file, we have the true peak. This along 232;; with the autonorm state is printed in a summary and the autonorm 233;; state is updated for next time. 234;; 235;; There are currently two types: PREVIOUS and LOOKAHEAD 236;; With PREVIOUS: 237;; compute the true peak and print the before and after peak 238;; along with the scale factor to be used next time 239;; With LOOKAHEAD: 240;; compute the true peak and print the before and after peak 241;; along with the "suggested scale factor" that would achieve 242;; the *autonorm-target* 243;; 244(defun autonorm-update (peak) 245 (cond ((> peak 1.0) 246 (format t "*** CLIPPING DETECTED! ***~%"))) 247 (cond ((and *autonormflag* (> peak 0.0)) 248 (setf *autonorm-previous-peak* (/ peak *autonorm*)) 249 (setf *autonorm* (/ *autonorm-target* *autonorm-previous-peak*)) 250 (format t "AutoNorm: peak was ~A,~%" *autonorm-previous-peak*) 251 (format t " peak after normalization was ~A,~%" peak) 252 (cond ((eq *autonorm-type* 'PREVIOUS) 253 (cond ((zerop *autonorm*) 254 (setf *autonorm* 1.0))) 255 (format t " new normalization factor is ~A~%" *autonorm*)) 256 ((eq *autonorm-type* 'LOOKAHEAD) 257 (cond ((> peak 1.0) 258 (explain-why-autonorm-failed))) 259 (format t " suggested manual normalization factor is ~A~%" 260 *autonorm*)) 261 (t 262 (format t 263 " unexpected value for *autonorm-type*, reset to LOOKAHEAD\n") 264 (setf *autonorm-type* 'LOOKAHEAD)))) 265 (t 266 (format t "Peak was ~A,~%" peak) 267 (cond ((> peak 0.0) 268 (format t " suggested normalization factor is ~A~%" 269 (/ *autonorm-target* peak)))))) 270 peak 271 ) 272 273 274;; s-read -- reads a file 275(defun s-read (filename &key (time-offset 0) (srate *sound-srate*) 276 (dur 10e20) (nchans 1) (format *default-sf-format*) 277 (mode *default-sf-mode*) (bits *default-sf-bits*) (endian NIL)) 278 (let ((swap 0)) 279 (cond ((eq endian :big) 280 (setf swap (if (bigendianp) 0 1))) 281 ((eq endian :little) 282 (setf swap (if (bigendianp) 1 0)))) 283 (if (minusp dur) (error "s-read :dur is negative" dur)) 284 (snd-read (soundfilename filename) time-offset 285 (local-to-global 0) format nchans mode bits swap srate 286 dur))) 287 288 289;; SF-INFO -- print sound file info 290;; 291(defun sf-info (filename) 292 (let (s format channels mode bits swap srate dur flags) 293 (format t "~A:~%" (soundfilename filename)) 294 (setf s (s-read filename)) 295 (setf format (snd-read-format *rslt*)) 296 (setf channels (snd-read-channels *rslt*)) 297 (setf mode (snd-read-mode *rslt*)) 298 (setf bits (snd-read-bits *rslt*)) 299 ; (setf swap (snd-read-swap *rslt*)) 300 (setf srate (snd-read-srate *rslt*)) 301 (setf dur (snd-read-dur *rslt*)) 302 (setf flags (snd-read-flags *rslt*)) 303 (format t "Format: ~A~%" 304 (nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX" 305 "NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK" 306 "SDS" "AVR" "SD2" "FLAC" "CAF"))) 307 (cond ((setp (logand flags snd-head-channels)) 308 (format t "Channels: ~A~%" channels))) 309 (cond ((setp (logand flags snd-head-mode)) 310 (format t "Mode: ~A~%" 311 (nth mode '("ADPCM" "PCM" "uLaw" "aLaw" "Float" "UPCM" 312 "unknown" "double" "GSM610" "DWVW" "DPCM" 313 "msadpcm"))))) 314 (cond ((setp (logand flags snd-head-bits)) 315 (format t "Bits/Sample: ~A~%" bits))) 316 (cond ((setp (logand flags snd-head-srate)) 317 (format t "SampleRate: ~A~%" srate))) 318 (cond ((setp (logand flags snd-head-dur)) 319 (format t "Duration: ~A~%" dur))) 320 )) 321 322;; SETP -- tests whether a bit is set (non-zero) 323; 324(defun setp (bits) (not (zerop bits))) 325 326;; IS-FILE-SEPARATOR -- is this a file path separation character, e.g. "/"? 327;; 328(defun is-file-separator (c) 329 (or (eq c *file-separator*) 330 (and (eq *file-separator* #\\) ;; if this is windows (indicated by "\") 331 (eq c #\/)))) ;; then "/" is also a file separator 332 333;; SOUNDFILENAME -- add default directory to name to get filename 334;; 335(defun soundfilename (filename) 336 (cond ((= 0 (length filename)) 337 (break "filename must be at least one character long" filename)) 338 ((full-name-p filename)) 339 (t 340 ; if sf-dir nonempty and does not end with filename separator, 341 ; append one 342 (cond ((and (< 0 (length *default-sf-dir*)) 343 (not (is-file-separator 344 (char *default-sf-dir* 345 (1- (length *default-sf-dir*)))))) 346 (setf *default-sf-dir* (strcat *default-sf-dir* (string *file-separator*))) 347 (format t "Warning: appending \"~A\" to *default-sf-dir*~%" 348 *file-separator*))) 349 (setf filename (strcat *default-sf-dir* (string filename))))) 350 ;; now we have a file name, but it may be relative to current directory, so 351 ;; expand it with the current directory 352 (cond ((relative-path-p filename) 353 ;; get current working directory and build full name 354 (let ((path (setdir "."))) 355 (cond (path 356 (setf filename (strcat path (string *file-separator*) 357 (string filename)))))))) 358 filename) 359 360 361(setfn snd-read-format car) 362(setfn snd-read-channels cadr) 363(setfn snd-read-mode caddr) 364(setfn snd-read-bits cadddr) 365(defun snd-read-swap (rslt) (car (cddddr rslt))) 366(defun snd-read-srate (rslt) (cadr (cddddr rslt))) 367(defun snd-read-dur (rslt) (caddr (cddddr rslt))) 368(defun snd-read-flags (rslt) (cadddr (cddddr rslt))) 369 370;; round is tricky because truncate rounds toward zero as does C 371;; in other words, rounding is down for positive numbers and up 372;; for negative numbers. You can convert rounding up to rounding 373;; down by subtracting one, but this fails on the integers, so 374;; we need a special test if (- x 0.5) is an integer 375(defun round (x) 376 (cond ((> x 0) (truncate (+ x 0.5))) 377 ((= (- x 0.5) (truncate (- x 0.5))) (truncate x)) 378 (t (truncate (- x 0.5))))) 379 380;; change defaults for PLAY macro: 381(init-global *soundenable* t) 382(defun sound-on () (setf *soundenable* t)) 383(defun sound-off () (setf *soundenable* nil)) 384 385(defun coterm (snd1 snd2) 386 (multichan-expand #'snd-coterm snd1 snd2)) 387 388(defmacro s-add-to (expr maxlen filename 389 &optional (time-offset 0.0) (progress 0)) 390 `(let ((ny:fname (soundfilename ,filename)) 391 ny:peak ny:input (ny:offset ,time-offset)) 392 (format t "Adding sound to ~A at offset ~A~%" 393 ny:fname ,time-offset) 394 (setf ny:peak (snd-overwrite '(let ((ny:addend ,expr)) 395 (sum (coterm 396 (s-read ny:fname 397 :time-offset ny:offset) 398 ny:addend) 399 ny:addend)) 400 ,maxlen ny:fname ny:offset ,progress)) 401 (format t "Duration written: ~A~%" (car *rslt*)) 402 ny:peak)) 403 404 405(defmacro s-overwrite (expr maxlen filename 406 &optional (time-offset 0.0) (progress 0)) 407 `(let ((ny:fname (soundfilename ,filename)) 408 (ny:peak 0.0) 409 ny:input ny:rslt (ny:offset ,time-offset)) 410 (format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset) 411 (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset ,progress)) 412 (format t "Duration written: ~A~%" (car *rslt*)) 413 ny:peak)) 414 415 416 417 418