Unit - Winamp と CD プレイヤーの共存

Scheme

MzScheme の FFI 機能を利用して、REPL 上で動く CD プレイヤーを作ることにしました。

Meadow の例 でコマンドの作り方は分かっていたので簡単です。

ただ、前回作った Winamp プレイヤーと play や stop などのコマンド名が被りそうなのが少々問題でした。

もちろんコマンド名をプレイヤー毎に変更すれば済むことなんですが、両方を同時に使うことはまずありませんし、共通の名前の方がタイピングが楽だと思うわけです。

こんな時、MzScheme の unit というものが使えるんじゃないかと思い付きました。

Unit とは、ML のファンクタに相当するものだそうです。よく分かりませんが、まぁモジュールとかライブラリみたいなものですよね。ただ、ファーストクラス・オブジェクトであって、関数で動的に生成したりもできます。

シグナチャというものとセットで定義するのが通例で、基本形は次のような感じです:

(define-signature unit-a^
  (func1 ...))

(define unit-a@
  (unit
    (import)
    (export unit-a^)

    (define func1 (lambda () ...))
    ...))

ユニット名を unit-a とすると、シグナチャの名前はそれに ^ を付加したもの、ユニット・オブジェクトは @ を付加した名前とするのが慣習になっています。

unit マクロの中でインポート、エクスポートする名前の指定と、エクスポートする関数等の定義を行います。シグナチャというのはそれらの名前の組を一意に扱うための方法です。Java で言うインターフェースみたいなものでしょうか。

ユニットを起動し、エクスポートされた名前を呼び出し側の名前空間内に定義するには、

(define-values/invoke-unit unit-a@ (import) (export unit-a^))

のようにします。

他にも複数のユニットをリンクする compond unit という使い方もあるんですが、ここでは省略します。


では実際のコードを示していきます。が、長いので、結果を先に見ていただこうと思います。

(player cd)
(play)

(player winamp)
(play)

(with-player cd
  (eject)
  (sleep 10)
  (play))

プレイヤーを切り替えるマクロ player と、切り替えおよびコマンド実行を行うマクロ with-player の二つのマクロを作りました。

なお、プレイヤー切り替えの際は自動的に元のプレイヤーの演奏を停止する仕組みになっています。以下、実装です。


まず、各プレイヤーが実装すべき関数を以下の 4 つと定義します。
player-sig.ss:

(module player-sig (lib "a-signature.ss")
  play pause resume stop)

これは、ファイル単位でシグナチャを定義する時の書式です。言語指定の部分に (lib "a-signature.ss") を指定した module は、-sig がモジュール名から取り除かれ、この場合 player^ というシグナチャとして提供されることになります。

次の各プレイヤー・モジュールでこれを require することで、定義すべき関数名のセットを得るわけです。

CD プレイヤー・ユニットです (cd.ss):

(module cd mzscheme
  (provide cd@ cd^)

  (require (lib "unit.ss")
           "ffi.ss"
           "player-sig.ss")

  (define-signature cd^ extends player^ (eject close))

  (define buflen 100)

  (define-api (ffi-lib "winmm")
    (mciSendStringA (_string
                     (buf : _bytes = (make-bytes buflen))
                     (_uint = buflen)
                     (_uint = 0)
                     -> (res : _int)
                     -> (let ((mes (read-chars (open-input-bytes buf))))
                          (if (> (string-length mes) 0)
                              (string->symbol mes)
                              res)))))

  (define-syntax define-controller
    (syntax-rules ()
      ((_ (cmd str) ...)
       (define-values (cmd ...)
         (values (lambda args
                   (mciSendStringA (if (procedure? str)
                                       (apply str args)
                                       str)))
                 ...)))))

  (define (read-chars in)
    (let lp ((c (read-char in))
             (l '()))
      (if (or (eof-object? c)
              (char=? c #\nul))
          (list->string (reverse l))
          (lp (read-char in)
              (cons c l)))))

  (define (ok? res) (= res 0))

  (define cd@
    (unit
      (import)
      (export cd^)

      (define-controller
        (_play "play cdaudio")
        (pause "pause cdaudio")
        (resume "resume cdaudio")
        (stop "stop cdaudio")
        (eject "set cdaudio door open wait")
        (close "set cdaudio door closed wait")
        (status "status cdaudio mode"))

      (define (open?) (eq? (status) 'open))

      (define (play)
        (if (open?) (close))
        (let lp ((res (_play))
                 (fails 5))       ;in case the tray was empty
          (unless (or (ok? res)
                      (zero? fails))
            (sleep 2)
            (lp (_play) (sub1 fails))))))))

define-signature の extends キーワードで CD プレイヤー固有の関数名を追加しています。

winamp.ss:

(module winamp mzscheme
  (provide winamp@ winamp^ winamp-path)

  (require "prelude.ss"      ; cut, constantly etc.
           (lib "unit.ss")
           "ffi.ss"
           "player-sig.ss")

  (define-signature winamp^ extends player^
    (prev next forward rewind))

  (define WM_COMMAND #x0111)
  (define WM_USER    #x0400)

  (define winamp-path "c:/Program Files/Winamp/winamp.exe")

  (define-syntax define-controller
    (syntax-rules ()
      ((_ (cmd code) ...)
       (define-values (cmd ...)
         (values (winamp-controller code) ...)))))

  (define-api (ffi-lib "user32")
    (FindWindowA ((className : _string)
                  (windowName : _string)
                  -> _uint))
    (SendMessageA ((hwnd : _uint)
                   (wMsg : _uint)
                   (wParam : _uint)
                   (lParam : _uint)
                   -> _int)))

  (define (handle-getter getter)
    (lambda ()
      (let ((handle (getter)))
        (and (> handle 0) handle))))

  (define (handle-caller getter)
    (opt-lambda (succ (fail void))
      (cond ((getter)
             => (lambda (handle)
                  (succ (lambda args
                          (apply SendMessageA handle args)))))
            (else (fail)))))

  (define winamp-handle
    (handle-getter (cut FindWindowA "Winamp v1.x" #f)))

  (define call/winamp-handle (handle-caller winamp-handle))

  (define (winamp-controller code)
    (lambda ()
      (call/winamp-handle (cut <> WM_COMMAND code 0))))

  (define (execute-winamp)
    (shell-execute "open" winamp-path "" "c:" 'SW_SHOWMINNOACTIVE))

  (define (start-winamp)
    (or (winamp-handle)
        (letrec ((poll (lambda ()
                         (or (winamp-handle)
                             (begin (sleep 1) (poll))))))
          (execute-winamp)
          (poll))))

  (define (playing?)
    (call/winamp-handle
     (lambda (send)
       (= (send WM_USER 2 104) 1))
     (constantly #f)))

  (define winamp@
    (unit
      (import)
      (export winamp^)

      (define-controller
        (prev     40044)
        (_play    40045)
        (pause    40046)
        (stop     40047)
        (next     40048)
        (forward  40060)
        (rewind   40061))

      (define resume _play)

      (define (play)
        (or (playing?)
            (and (start-winamp) (_play)))))))

winamp 実行ファイルのパスを文字列として決め打ちしていますが、嫌でなければこういう方法もあります:

(define HKEY_CURRENT_USER #x80000001)
(define size 1000)
(define-api (ffi-lib "advapi32")
  (RegOpenKeyA ((hKey : _uint)
                (lpSubKey : _string)
                (phkResult : (_ptr o _uint))
                -> (res : _int)
                -> (values res phkResult)))
  (RegEnumValueA ((hKey : _uint)
                  (dwIndex : _uint)
                  (lpValueName : _bytes = (make-bytes size))
                  (lpcbValueName : (_ptr io _uint) = size)
                  (lpReserved  : _uint)
                  (lpType : (_ptr io _uint))
                  (lpData : _bytes = (make-bytes size))
                  (lpcbData : (_ptr io _uint) = size)
                  -> (res : _int)
                  -> (values res lpValueName lpcbValueName lpData lpcbData)))
  (RegCloseKey (_uint -> _int)))

(let-values (((res hkey)
              (RegOpenKeyA HKEY_CURRENT_USER "Software\\Winamp")))
  (and (zero? res)
       (let-values (((res lpValueName lpcbValueName lpData lpcbData)
                     (RegEnumValueA hkey 0 0 4)))
         (begin0 (and (zero? res)
                      (build-path (bytes->string/utf-8
                                   (subbytes lpData 0 (sub1 lpcbData)))
                                  "winamp.exe"))
           (RegCloseKey hkey)))))

ffi.ss:

(module ffi mzscheme
  (provide (all-from (lib "foreign.ss"))
           define-api)

  (require (lib "foreign.ss"))

  (unsafe!)

  (define-syntax define-api
    (syntax-rules ()
      ((_ lib (func type) ...)
       (define-values (func ...)
         (let ((the-lib lib))
           (values (get-ffi-obj 'func the-lib (_fun . type))
                   ...)))))))

本体です:

(require (lib "unit.ss")
         "cd.ss"
         "winamp.ss")

(define on-switch (make-parameter void))

(define-syntax (player x)
  (define (unit/sig id post)
    (datum->syntax-object id
                          (string->symbol
                           (format "~a~a" (syntax-e id) post))))
  (syntax-case x ()
    ((_ id)
     #`(begin ((on-switch))
              (define-values/invoke-unit
                #,(unit/sig #'id "@")
                (import)
                (export #,(unit/sig #'id "^")))
              (on-switch stop)))))

(define-syntax with-player
  (syntax-rules ()
    ((_ id expr ...)
     (begin (player id) expr ...))))

動的に関数定義を書き換える、というのはもしかしたら本来想定されている unit の使い方ではないかも知れないんですが、unit の動的性質を生かす方法として有効なんじゃないかと思います。


追記:

Winamp に mp3 ファイルを enqueue (プレイリスト末尾に追加) できるようになりました。構造体を作ってそのポインタを渡す、というサンプルとして書き留めておきます。

Winamp に渡すファイル名等のデータは次の構造体にまとめます:

(define-cstruct _COPYDATASTRUCT
  ((dwData _ulong) (cbData _ulong) (lpData _string)))

構造体 (や型一般) を作るときは、名前の頭にアンダースコアを付ける必要があるようです。

次にデータを送信するための関数です。

(define SendMessageC
  (get-ffi-obj 'SendMessageA "user32"
               (_fun
                (hwnd : _uint)
                (wMsg : _uint)
                (wParam : _uint)
                (lParam : _COPYDATASTRUCT-pointer)
                -> _int)))

関数の型宣言の中で、扱いたい構造体のポインタ型を明示的に指定しています。

既に定義されている SendMessageA 関数は lParam の型が整数型になっているんですが、関数の呼び出し側で構造体のポインタを得る

SendMessageA(... (LPARAM)&copydata)

のような方法が分かりませんでした (多分無いんだと思います)。

オーバーローディングの方法もおそらく無いので、SendMessageA とは別の関数として定義しています。

これに合わせて、define-api マクロもエイリアスを定義できるように改定してみました:

(define-syntax (define-api x)
  (syntax-case x ()
    ((_ lib spec ...)
     (let lp ((names '())
              (funcs '())
              (specs (syntax->list #'(spec ...))))
       (if (null? specs)
           (with-syntax (((name ...) names)
                         ((func ...) funcs))
             #'(define-values (name ...)
                 (let ((the-lib lib))
                   (values func ...))))
           (let-values
               (((name func)
                 (syntax-case (car specs) (as)
                   ((func as alias type)
                    (values #'alias
                            #'(get-ffi-obj 'func
                                           the-lib
                                           (_fun . type))))
                   ((func type)
                    (values #'func
                            #'(get-ffi-obj 'func
                                           the-lib
                                           (_fun . type)))))))
             (lp (cons name names)
                 (cons func funcs)
                 (cdr specs))))))))

定義例:

(define-api (ffi-lib "user32")
  (SendMessageA ((hwnd : _uint)
                 (wMsg : _uint)
                 (wParam : _uint)
                 (lParam : _uint)
                 -> _int))
  (SendMessageA as SendMessageC
                ((hwnd : _uint)
                 (wMsg : _uint)
                 (wParam : _uint)
                 (lParam : _COPYDATASTRUCT-pointer)
                 -> _int)))

エンキュー関数の例です:

(define WM_COPYDATA #x004A)
(define IPC_ENQUEUEFILE 100)

(define (enqueue path)
  (SendMessageC (winamp-handle)
                WM_COPYDATA
                0
                (make-COPYDATASTRUCT IPC_ENQUEUEFILE
                                     (add1 (string-length path))
                                     path)))

手元では play 関数の定義を次のようにして、引数があれば演奏ではなくエンキューを行うようにしてみました:

(define (play . l)
  (or (playing?) (start-winamp))
  (play/enqueue l _play))

(define (play/enqueue l play)
  (cond ((null? l) (play))
        (else (for-each enqueue l))))