wav/write-header.lisp: cleaner code for writing WAV headers

core/core.lisp

@@ -28,38 +28,23 @@
            ,@body)))))
 
 ;; Utility functions
-(defun integer-to-array (val array)
-  (loop for i below (length array)
-	for pos from 0 by 8 do
-	(setf (aref array i)
-	      (ldb (byte 8 pos) val)))
-  array)
-
-(defun integer-to-array-be (val array)
-  (let* ((len (length array))
-         (len-bits (ash len 3)))
-    (loop for i below len
-          for pos from 0 by 8 do
-          (setf (aref array i)
-                (ldb (byte 8 (- len-bits pos 8)) val))))
-  array)
-
 (defun mixchannels-n (out buffers)
   (declare (type list buffers)
 	   (type (simple-array (signed-byte 32)) out)
 	   (optimize #+easy-audio-unsafe-code
                      (safety 0) (speed 3)))
   (let ((offset (length buffers))
 	(size (length (the (simple-array (signed-byte 32))
-			(nth 0 buffers))))
+			   (nth 0 buffers))))
 	(idx 0))
     (declare (type fixnum offset size idx))
     (dotimes (i size)
       (dotimes (j offset)
 	(declare (type fixnum i j))
 	(setf (aref out (+ idx j))
 	      (aref (the (simple-array (signed-byte 32))
-		      (nth j buffers)) i)))
+		         (nth j buffers))
+                    i)))
       (incf idx offset))
     out))
 

core/package.lisp

@@ -14,6 +14,4 @@
    #:sa-sb
 
    ;; Utility functions
-   #:mixchannels
-   #:integer-to-array
-   #:integer-to-array-be))
+   #:mixchannels))

easy-audio.asd

@@ -89,6 +89,7 @@
   :depends-on (:easy-audio/core
                :easy-audio/bitreader
                :easy-audio/general-decoders
+               :nibbles-streams
                :flexi-streams))
 
 (defsystem :easy-audio/ape

wav/package.lisp

@@ -25,6 +25,7 @@
   (:use #:cl
         #:easy-audio.bitreader
         #:easy-audio.core)
+  (:local-nicknames (:ns :nibbles-streams))
   (:export #:+wav-id+   ; Useful constants which can be used in examples
            #:+wav-format+
            #:+format-subchunk+

wav/write-header.lisp

@@ -2,60 +2,43 @@
 
 (defun write-pcm-wav-header (out-stream &key samplerate channels bps totalsamples)
   "Writes header of uncompressed wav into stream"
-  (let ((size (ash (* bps channels totalsamples) -3))
-        (buf2 (make-array 2 :element-type '(unsigned-byte 8)))
-        (buf4 (make-array 4 :element-type '(unsigned-byte 8))))
-
-    (write-sequence (integer-to-array-be +wav-id+ buf4) out-stream)
-    (write-sequence (integer-to-array (+ 36 size) buf4) out-stream)
-    (write-sequence (integer-to-array-be +wav-format+ buf4) out-stream)
+  (let ((size (/ (* bps channels totalsamples) 8)))
+    (nibbles:write-ub32/be +wav-id+ out-stream)
+    (nibbles:write-ub32/le (+ 36 size) out-stream)
+    (nibbles:write-ub32/be +wav-format+ out-stream)
 
     ;; Subchunk 1
-    (write-sequence (integer-to-array-be +format-subchunk+ buf4) out-stream)
-    (write-sequence #(16 0 0 0) out-stream)
-    (write-sequence (integer-to-array +wave-format-pcm+ buf2) out-stream)
-    (write-sequence (integer-to-array channels buf2) out-stream)
-    (write-sequence (integer-to-array samplerate buf4) out-stream)
-
-    (write-sequence (integer-to-array
-                     (ash
-                      (* samplerate channels bps) -3)
-                     buf4)
-                    out-stream)
-
-    (write-sequence (integer-to-array
-                     (ash
-                      (* channels bps) -3)
-                     buf2)
-                    out-stream)
+    (nibbles:write-ub32/be +format-subchunk+ out-stream)
+    (nibbles:write-ub32/le 16 out-stream)
+    (nibbles:write-ub16/le +wave-format-pcm+ out-stream)
+    (nibbles:write-ub16/le channels out-stream)
+    (nibbles:write-ub32/le samplerate out-stream)
 
-    (write-sequence (integer-to-array
-                     bps buf2)
-                    out-stream)
+    (nibbles:write-ub32/le (/ (* samplerate channels bps) 8) out-stream)
+    (nibbles:write-ub16/le (/ (* channels bps) 8) out-stream)
+    (nibbles:write-ub16/le bps out-stream)
 
     ;; Subchunk 2
-    (write-sequence (integer-to-array-be +data-subchunk+ buf4) out-stream)
-    (write-sequence (integer-to-array size buf4) out-stream))
-  t)
+    (nibbles:write-ub32/be +data-subchunk+ out-stream)
+    (nibbles:write-ub32/le size out-stream))
+  (values))
 
 (defmacro with-output-to-wav ((stream filename
                                       &key supersede samplerate channels bps totalsamples)
                               &body body)
   "Opens a STREAM and writes PCM-coded (uncompressed) WAV header to a file with filename FILENAME"
-  `(progn
-     (with-open-file (,stream ,filename
-                              :direction :output
-                              :element-type '(unsigned-byte 8)
-                              ,@(if supersede '(:if-exists :supersede))
-                              :if-does-not-exist :create)
-       (write-pcm-wav-header ,stream
-                             :samplerate ,samplerate
-                             :channels ,channels
-                             :bps ,bps
-                             :totalsamples ,totalsamples))
-     (with-open-file (,stream ,filename
-                              :direction :output
-                              :element-type (list 'signed-byte ,bps)
-                              :if-exists :append)
-       ,@body)
-     t))
+  (let ((file-stream (gensym)))
+    `(with-open-file (,file-stream ,filename
+                                   :direction         :output
+                                   :element-type      '(unsigned-byte 8)
+                                   ,@(if supersede    '(:if-exists :supersede))
+                                   :if-does-not-exist :create)
+       (write-pcm-wav-header ,file-stream
+                             :samplerate   ,samplerate
+                             :channels     ,channels
+                             :bps          ,bps
+                             :totalsamples ,totalsamples)
+       (let ((,stream (make-instance 'ns:nibbles-output-stream
+                                     :stream       ,file-stream
+                                     :element-type (list 'signed-byte ,bps))))
+         ,@body))))