フィボナッチミュージックを実装しました

L'eclat des jours(2007-08-07)をHaskellで実装してみました。フィボナッチ数列を使って、音楽を奏でようという試みです。
フィボナッチ数列を求めるアルゴリズムは、Tea break: Haskellでフィボナッチ数列 - hayaのHaskell日記 - haskellのものを使わせていただきました。WindowsのMIDIの低レベルAPIを直に使っています。Windows限定です。
一応実行形式も用意しました。ここからダウンロードしてください。
以下、ソースです。HaskellでFFIを使ってHMIDIOUTをポインタ渡しする方法がわからなかったので、C言語で薄っぺらなラッパーを作っています。ホントはHaskellだけで閉じたかったんだけど。。。
ファイル: fib.hs

-- -*- compile-command: "ghc --make -W -ffi fib.hs midi.c -lwinmm" -*-
module Main (main) where

import Control.Concurrent (threadDelay)
import Control.Monad (when)
import Data.Bits ((.|.), shiftL)
import System.IO (hFlush, stdout)
import System.Win32 (UINT, DWORD)

mIDIMAPPER :: UINT
mIDIMAPPER = 0xffffffff

foreign import ccall unsafe "cMidiOutOpen" cMidiOutOpen
    :: UINT -> DWORD -> DWORD -> DWORD -> IO UINT

foreign import ccall unsafe "cMidiOutShortMsg" cMidiOutShortMsg
    :: DWORD -> IO UINT

foreign import ccall unsafe "cMidiOutClose" cMidiOutClose
    :: IO UINT

midiErrorCheck :: String -> UINT -> IO ()
midiErrorCheck fname ret =
    when (ret /= 0) $ error $ fname ++ " failed. (" ++ show ret ++ ")"

withMidiOut :: IO () -> IO ()
withMidiOut f = do
  midiErrorCheck "midiOutOpen" =<< cMidiOutOpen mIDIMAPPER 0 0 0
  f 
  midiErrorCheck "midiOutClose" =<< cMidiOutClose

midiMsg :: DWORD -> DWORD -> DWORD -> DWORD
midiMsg stat data1 data2 = stat .|. (data1 `shiftL` 8) .|. (data2 `shiftL` 16)

midiNoteOn :: DWORD -> DWORD -> DWORD -> IO ()
midiNoteOn channel note volume =
    midiErrorCheck "midiOutShortMsg"
        =<< (cMidiOutShortMsg $ midiMsg (0x90 .|. channel) note volume)

midiNoteOff :: DWORD -> DWORD -> IO ()
midiNoteOff channel note = 
    midiErrorCheck "midiOutShortMsg"
        =<< (cMidiOutShortMsg $ midiMsg (0x80 .|. channel) note 0)

-- ref. <http://haskell.g.hatena.ne.jp/harg/20060822/1156262334>
fastFib :: Integer -> Integer
fastFib = fst . fibPair
    where
      fibStep :: (Integer, Integer) -> (Integer, Integer)
      fibStep (u, v) = (v, u+v)

      fibPair :: Integer -> (Integer, Integer)
      fibPair n
        | n == 0    = (0, 1)
        | otherwise = fibStep (fibPair (n-1))

main :: IO ()
main = withMidiOut $ do
  mapM_ f [fastFib(n) | n <- [1 ..]]
    where
      f x = do
        let x' = fromInteger $ x `mod` 19 + 40
        print x
        hFlush stdout
        midiNoteOn 0 x' 50
        threadDelay (200 * 1000)
        midiNoteOff 0 x'

ファイル: midi.c

#include <windows.h>

static HMIDIOUT hMidiOut;

UINT
cMidiOutOpen(UINT uDeviceID, DWORD dwCallback, 
	     DWORD dwCallbackInstance, DWORD dwFlags)
{
    return midiOutOpen(&hMidiOut, uDeviceID, dwCallback,
		       dwCallbackInstance, dwFlags);
}

UINT
cMidiOutClose()
{
    return midiOutClose(hMidiOut);
}

UINT
cMidiOutShortMsg(DWORD dwMsg)
{
    return midiOutShortMsg(hMidiOut, dwMsg);
}

実行例:

$ ghc --make -W -ffi fib.hs midi.c -lwinmm
$ ./fib.exe
1
1
2
3
5
8
13
21
34
55
89
144
233
377
610
987
1597
2584
...

参照: フィボナッチ数 - Wikipedia