Playing Audio In PLT-Scheme Scheme - Using MCI

I needed to play a .wav file in my MrEd application, but I needed more control than the built in play-sound gave me. Specifically, I needed to be able to stop the sound in the middle of playing, and be notified when it was done playing.

A bit of Googling found Eli Barzilay had made important progress on solving this issue. His solution was to use the remarkably simple and sane Windows API: Multimedia Command Strings. Check out the docs here, it's almost too easy to use.

So, I grabbed Eli's code and started hacking. What I came up with was a single function named play. You pass this function a path to a .wav file, and an option thunk that will be invoked when the sound is done playing.

The play function returns back procedure which you can invoke to control the sound. You can, for example say:

 (define p (play "c:/long-sound.wav"))
 (sleep 2)
 (p 'pause) ; pause the sound
 (sleep 1)
 (p 'resume) ; resume the sound

See the docs below for all the commands you can send in to the command procedure.

Thanks Eli for getting me started on this, and I hope I didn't butcher your code too badly.

#lang scheme
;;
;; See:
;; http://list.cs.brown.edu/pipermail/plt-scheme/2008-June/024925.html
;; http://tmp.barzilay.org/mci.scm -
;; http://msdn.microsoft.com/en-us/library/ms712587(VS.85).aspx
;; to make sense of this code.
;;

(require (lib "foreign.ss"))
(unsafe!)

(provide play)

(define winmm (ffi-lib "Winmm"))

;; used for string results
(define scheme-make-byte-string-without-copying
  (get-ffi-obj "scheme_make_byte_string_without_copying" #f
               (_fun _pointer -> _scheme)))

(define mci-get-error-string
  (get-ffi-obj "mciGetErrorStringA" winmm
    (_fun _int [buf : _pointer = (malloc 500)] [_int = 500]
          -> [ret : _bool]
          -> (if ret
               (scheme-make-byte-string-without-copying buf)
               "(unknown error code)"))))

(define mci-send-string
  (get-ffi-obj "mciSendStringA" winmm
    (_fun _string [_pointer = #f] [_int = 0] [_pointer = #f]
          -> [ret : _int]
          -> (if (zero? ret)
               (void)
               (error 'mci-send-string "~a" (mci-get-error-string ret))))))

(define mci-send-string*
  (get-ffi-obj "mciSendStringA" winmm
    (_fun _string [buf : _pointer = (malloc 500)] [_int = 500] [_pointer = #f]
          -> [ret : _int]
          -> (if (zero? ret)
               (scheme-make-byte-string-without-copying buf)
               (error 'mci-send-string* "~a" (mci-get-error-string ret))))))

(define counter 0)
(define sema (make-semaphore 1))

;;
;; Our primary, public, function. You provide the path to a wav file,
;; and optionally a thunk to invoke when the file is done being played.
;;
;; A function is returned to you which you can pass various symbols to control
;; playback.
;;
;; You can, for example, say:
;;   (define p (play "c:/.../foo.wav"))
;;   ...time passes...
;;   (if (p 'playing?) (p 'stop))
;;
;; This will, after some time passes, will stop the clip from playing if it is
;; still going on.
;;
;; All commands that can be passed to the returned promise include:
;;   playing? | stop | pause | resume
;;
;; Note: when you invoke stop, the clip is done - dead - kaput.
;;
(define play
  (let ([n 0])
    (case-lambda 
      ((wav)
       (play wav (lambda () (void))))
      ((wav thunk)
       (let ((id (begin (set! n (add1 n)) n))
             (shutdown? #f))
         (thread
          (lambda ()
            (semaphore-wait sema)
            (set! counter (add1 counter))
            (semaphore-post sema)
            (mci-send-string (format "open \"~a\" type waveaudio alias ~a" wav id))
            (mci-send-string (format "play ~a" id))
            (let loop ([s 1])
              (sleep s)
              (let ((status  (mci-send-string* (format "status ~a mode" id))))
                (if (or (equal? #"playing" status) (equal? #"paused" status))
                    (loop (add1 s))
                    (mci-send-string (format "close ~a" id)))))
            (set! shutdown? #t)
            (semaphore-wait sema)
            (set! counter (sub1 counter))
            (semaphore-post sema)
            (thunk)))
         (lambda (command)
           (case command
             ((id) id)
             ((playing?) (and (not shutdown?) (equal? #"playing" (mci-send-string* (format "status ~a mode" id)))))
             ((pause) (mci-send-string (format "pause ~a" id)))
             ((resume) (mci-send-string (format "resume ~a" id)))
             ((stop) (mci-send-string (format "stop ~a" id)))
             (else (error 'play "Unknown command: ~a" command)))))))))