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