module Sound.Hommage.Midi
(
MidiFile (..)
, writeMidiFile
, Ticks
, MidiNote (..)
, Chan
, MidiValue
, MidiMusic
, noteMidiMusic
, restMidiMusic
, appendMidiMusic
, mergeMidiMusic
, runMidiMusic
, MidiTrack
, Delta
, MidiEvent (..)
, encodeMidiFile
, midiHeaderSync
, midiHeaderSingle
, midiHeaderAsync
, encodeMidiTrack
, encodeDelta
, encodeMidiDeltaEvent
, encodeEvent
, lastByte
, nextByte
, toBytes
)
where
import Sound.Hommage.WavFile
import Data.Word
import Data.Bits
import Data.Ratio
type Delta = Int
type MidiMusic = [(Delta, Maybe MidiEvent)]
type MidiTrack = [(Delta, MidiEvent)]
type Ticks = Int
runMidiMusic :: MidiMusic -> MidiTrack
runMidiMusic mt = loop 0 mt
where
loop delta ((d, Just e) : r) = (delta + d, e) : loop 0 r
loop delta ((d, Nothing) : r) = loop (d+delta) r
loop delta [] = [(delta, MidiEndOfTrack)]
writeMidiFile :: FilePath -> MidiFile -> IO ()
writeMidiFile fp mf = writeDataFile fp $ encodeMidiFile mf
type Chan = Word8
type MidiValue = Word8
data MidiNote = MidiNote Chan MidiValue MidiValue
| MidiCtrl Chan MidiValue MidiValue
noteMidiMusic :: Int -> MidiNote -> MidiMusic
noteMidiMusic d (MidiNote c n v) =
[(0, Just $ MidiNoteOn c n v), (d, Just $ MidiNoteOff c n v)]
noteMidiMusic d (MidiCtrl c n v) =
[(0, Just $ MidiControl c n v), (d, Nothing)]
restMidiMusic :: Int -> MidiMusic
restMidiMusic d = [(d, Nothing)]
mergeMidiMusic :: MidiMusic -> MidiMusic -> MidiMusic
mergeMidiMusic ((d1,m1):r1) ((d2,m2):r2) | d1 < d2 = (d1,m1) : mergeMidiMusic r1 ((d2d1,m2):r2)
| d1 > d2 = (d2,m2) : mergeMidiMusic ((d1d2,m1):r1) r2
| otherwise = (d1,m1) : (0, m2) : mergeMidiMusic r1 r2
mergeMidiMusic [] r2 = r2
mergeMidiMusic r1 [] = r1
appendMidiMusic :: MidiMusic -> MidiMusic -> MidiMusic
appendMidiMusic = (++)
data MidiFile = MidiSync Ticks [MidiTrack]
| MidiSingle Ticks MidiTrack
| MidiAsync Ticks [MidiTrack]
data MidiEvent = MidiNoteOff !Chan !MidiValue !MidiValue
| MidiNoteOn !Chan !MidiValue !MidiValue
| MidiKeyAfter !Chan !MidiValue !MidiValue
| MidiControl !Chan !MidiValue !MidiValue
| MidiEndOfTrack
encodeMidiFile :: MidiFile -> [Word8]
encodeMidiFile mf =
case mf of
MidiSync tc mts -> midiHeaderSync ++ toBytes 2 (length mts) ++ toBytes 2 tc ++ (mts >>= encodeMidiTrack)
MidiSingle tc mt -> midiHeaderSingle ++ toBytes 2 1 ++ toBytes 2 tc ++ encodeMidiTrack mt
MidiAsync tc mts -> midiHeaderAsync ++ toBytes 2 (length mts) ++ toBytes 2 tc ++ (mts >>= encodeMidiTrack)
midiHeaderSingle :: [Word8]
midiHeaderSingle = [ 77, 84, 104, 100, 0, 0, 0, 6, 0, 0]
midiHeaderSync :: [Word8]
midiHeaderSync = [ 77, 84, 104, 100, 0, 0, 0, 6, 0, 1]
midiHeaderAsync :: [Word8]
midiHeaderAsync = [ 77, 84, 104, 100, 0, 0, 0, 6, 0, 2]
encodeMidiTrack :: MidiTrack -> [Word8]
encodeMidiTrack ms = [ 77, 84, 114, 107 ] ++ toBytes 4 (length t) ++ t
where
t = (ms >>= encodeMidiDeltaEvent)
encodeDelta :: Int -> [Word8]
encodeDelta n = loop n
where
loop n | n < 128 = [fromIntegral n]
| otherwise = fromIntegral (128 + mod n 128) : loop (div n 128)
encodeMidiDeltaEvent :: (Delta, MidiEvent) -> [Word8]
encodeMidiDeltaEvent (delta, me) = encodeDelta delta ++ encodeEvent me
encodeEvent :: MidiEvent -> [Word8]
encodeEvent me =
case me of
MidiNoteOff ch no va -> [ch + 128, no, va]
MidiNoteOn ch no va -> [ch + 144, no, va]
MidiKeyAfter ch no va -> [ch + 160, no, va]
MidiControl ch no va -> [ch + 176, no, va]
MidiEndOfTrack -> [255,47,0]
lastByte :: Int -> Word8
lastByte n = fromIntegral (mod n 256)
nextByte :: Int -> Int
nextByte n = div n 256
toBytes :: Int -> Int -> [Word8]
toBytes k n = reverse $ take k $ map lastByte $ iterate nextByte n