playing an aiff file.

[alanr@saint.media-lab.media.mit.edu (Alan Ruttenberg)]

Here is some code I've used. I just tested it in 2.01, and it seems to
still work. Eval the file, then to play an example:

(with-open-sound-file (sf (choose-file-dialog)) ;choose an aiff file
   (play-range s 0 10))

-alan


(in-package :ccl)

;; ****************************************************************
;;
;; Author: Alan Ruttenberg, MIT Media Lab
;; email:  alanr@media.mit.edu
;;
;; Created: Thursday August 19,1993
;; 
;; ****************************************************************

(in-package :ccl)

(defun refnum-of-open-file (f)
  (rref (uvref (cdr (column.fblock f)) 1) :cinfopbrec.iofrefnum))

(defun make-fixed-point (num)
  (assert (<= 0 num 32767) () "out of range for fixed point")
  (+ (ash (floor num) 16) (round (* (rem num 1) 65536))))

(defun unpack-fixed-point (fixed)
  (+ (floor (ash fixed -16)) (/ (logand fixed #xffff) 65536.0)))


(defclass sound-channel-that-works ()
  ((channel :initarg :channel :initform (make-sound-channel) :accessor channel)
   (time-started :initarg :time-started :initform nil :accessor time-started)))

(defclass sound-file (input-binary-file-stream sound-channel-that-works)
  ())

(defclass aiff-sound-file (sound-file)
  ((sample-rate :accessor sample-rate)
   (number-of-samples  :accessor number-of-samples)
   (sound-offset :accessor sound-offset)
   (number-of-channels :accessor number-of-channels)
   (sample-size :accessor sample-size)
   (datasize :accessor datasize)
   (refnum :initarg :refnum :initform nil :accessor refnum)))

(defclass 8bit-aiff-sound-file (aiff-sound-file)
  ())


(defclass 16bit-aiff-sound-file (aiff-sound-file)
  ())

(defmethod update-instance-for-different-class ((f file-stream) (s sound-file) &rest args)
  (declare (ignore args))
  (call-next-method)
  (unless (typep f 'sound-file)
    (cond ((eq (mac-file-type (slot-value s 'my-file-name)) :aiff)
           (return-from update-instance-for-different-class
             (change-class s 'aiff-sound-file)))
          (t (error "I only know how to handle aiff files")))))

(defmethod read-ostype ((s aiff-sound-file))
  (let ((a (read-byte s))
        (b (read-byte s))
        (c (read-byte s))
        (d (read-byte s)))
    (coerce (list (code-char a) (code-char b) (code-char c) (code-char d)) 'string)))

(defmethod read-long ((s aiff-sound-file))
  (let ((a (read-byte s))
        (b (read-byte s))
        (c (read-byte s))
        (d (read-byte s)))
    (logior (ash a 24) (ash b 16) (ash c 8) d)))

(defmethod read-short ((s aiff-sound-file))
  (let ((a (read-byte s))
        (b (read-byte s)))
    (logior (ash a 8) b)))

(defmethod read-extended ((s aiff-sound-file))
  (%stack-block ((x 8))
    (dotimes (i 8)
      (%put-byte x (read-byte s) i))
    (%get-x2float x)))

(defmethod update-instance-for-different-class ((f sound-file) 
                                                      (s aiff-sound-file)
                                                      &rest args)
  (declare (ignore args))
  (call-next-method)
  (unless (typep f 'aiff-sound-file)
    (file-position s 0)
    (let ((formchunk (read-ostype s))
          (datasize (read-long s))
          (formtype (read-ostype s)))
      (assert (and (string-equal formchunk "FORM")
                   (string-equal formtype "AIFF"))
              () "This file is not parsing as an aiff file")
      (setf (datasize s) datasize)
      (loop while (not (eofp s))
            for chunk = (read-ostype s)
            for size = (read-long s)
            for pos = (file-position s)
            do
            (cond ((string-equal chunk "COMM")
                   (setf (number-of-channels s) (read-short s)
                         (number-of-samples s) (read-long s)
                         (sample-size s) (read-short s)
                         (sample-rate s) (read-extended s)))
                  ((string-equal chunk "SSND")
                   (assert (zerop (read-long s)) () "Don't know how to handle non zero block size")
                   (assert (zerop (read-long s)) () "Don't know how to handle non zero offset")
                   (setf (sound-offset s) (file-position s))
                   ))
            (file-position s (+ pos size)))
      (setf (refnum s) (refnum-of-open-file s))
      (assert (every #'(lambda (slot) (slot-boundp s slot))
                     '(sample-size sound-offset number-of-samples number-of-channels))
              ()
              "COMM chunk not found")
      (cond ((and (= (number-of-channels s) 1) (= (sample-size s) 8))
             (return-from update-instance-for-different-class
               (change-class s '8bit-aiff-sound-file)))
            ((and (= (number-of-channels s) 1) (= (sample-size s) 16))
             (return-from update-instance-for-different-class
               (change-class s '16bit-aiff-sound-file)))
            (t (error "can't handle this sound file. sorry"))))))

(defun open-sound-file (path)
  (let ((it (open path :element-type 'unsigned-byte)))
    (change-class it 'sound-file)
    it)) 

(defmacro with-open-sound-file ((stream path) &body body)
  `(with-open-file (,stream ,path :element-type 'unsigned-byte)
    (change-class ,stream 'sound-file)
    ,@body))

(defun make-sound-channel ()
  (rlet ((p :pointer))
    (%put-long p 0) ;; better zero this, or you will die!
    (#_sndnewchannel p #$sampledSynth 0 (%null-ptr))
    (%get-ptr p)))

(defmethod sound-channel-status ((channel sound-file))
  (rlet ((r :scstatus))
    (#_sndchannelstatus (channel channel) #.(record-length :scstatus) r)
    (let ((busy (rref r scstatus.scchannelbusy)))
      (when busy
        (+ (unpack-fixed-point (rref r scstatus.scstarttime))
           (/ (- (get-internal-real-time) (time-started channel)) 1000.0))))))

(defmethod play-range ((channel sound-file) start end &optional synchronous)
  (when (sound-channel-status channel)
    (#_sndstopfileplay (channel channel) t))
  (rlet ((selection :audioselection
                    :unittype #$unittypeseconds
                    :selstart (make-fixed-point start)
                    :selend (make-fixed-point end)))
    (let ((error? (#_SndStartFilePlay 
                   (channel  channel)
                   (refnum channel) 
                   0                       ; 0 resource for aiff play
                   #x8000 (%null-ptr)      ; 32k buffer, let sound manager allcoate
                   selection               
                   (%null-ptr)             ; No completion routine
                   t)))                    ; asynchronous
      (setf (time-started channel) (get-internal-real-time))
      (when synchronous
        (loop until (null (sound-channel-status channel))))
      (assert (zerop error?) () "There was an error trying to play the the range ~a to ~a in ~a."
              start end channel))))