module Codec.Midi
(
Midi (..)
, FileType (..)
, Track
, TimeDiv (..)
, Message (..)
, Ticks
, Time
, Channel
, Key
, Velocity
, Pressure
, Preset
, Bank
, PitchWheel
, Tempo
, isNoteOff
, isNoteOn
, isKeyPressure
, isControlChange
, isProgramChange
, isChannelPressure
, isPitchWheel
, isChannelMessage
, isMetaMessage
, isSysexMessage
, isTrackEnd
, removeTrackEnds
, toSingleTrack
, merge
, fromAbsTime
, toAbsTime
, toRealTime
, fromRealTime
, importFile
, exportFile
, parseMidi
, buildMidi
, parseTrack
, buildTrack
, parseMessage
, buildMessage
)
where
import qualified Data.ByteString.Lazy as L
import Test.QuickCheck (Arbitrary, arbitrary, choose, oneof)
import Codec.ByteString.Parser
import Codec.ByteString.Builder
import Codec.Internal.Arbitrary ()
import Data.Word
import Data.Bits
import Data.Maybe
import Data.List
import Data.Monoid (mempty, mconcat, mappend)
import Control.Applicative
import Control.Monad
data Midi = Midi {
fileType :: FileType
, timeDiv :: TimeDiv
, tracks :: [Track Ticks]
} deriving (Eq, Show)
instance Arbitrary Midi where
arbitrary = do
ft <- arbitrary
td <- arbitrary
if ft == SingleTrack
then do
trk <- arbitrary >>= return . fAux
return $! Midi ft td [trk]
else do
trks <- arbitrary >>= return . map fAux
return $! Midi ft td trks
where
fAux = (++ [(0,TrackEnd)]) . map (\(dt,m) -> (abs dt,m)) . removeTrackEnds
data FileType = SingleTrack | MultiTrack | MultiPattern
deriving (Eq, Show)
instance Arbitrary FileType where
arbitrary = oneof [return SingleTrack , return MultiTrack , return MultiPattern]
type Track a = [(a,Message)]
data TimeDiv =
TicksPerBeat Int |
TicksPerSecond Int Int
deriving (Show,Eq)
instance Arbitrary TimeDiv where
arbitrary = oneof [
choose (1,2 ^ (15 :: Int) - 1) >>= return . TicksPerBeat
, two (choose (1,127)) >>= \(w1,w2) -> return $! TicksPerSecond w1 w2]
type Ticks = Int
type Time = Double
type Channel = Int
type Key = Int
type Velocity = Int
type Pressure = Int
type Preset = Int
type Bank = Int
type PitchWheel = Int
type Tempo = Int
data Message =
NoteOff { channel :: !Channel, key :: !Key, velocity :: !Velocity } |
NoteOn { channel :: !Channel, key :: !Key, velocity :: !Velocity } |
KeyPressure { channel :: !Channel, key :: !Key, pressure :: !Pressure} |
ControlChange { channel :: !Channel, controllerNumber :: !Int, controllerValue :: !Int } |
ProgramChange { channel :: !Channel, preset :: !Preset } |
ChannelPressure { channel :: !Channel, pressure :: !Pressure } |
PitchWheel { channel :: !Channel, pitchWheel :: !PitchWheel } |
SequenceNumber !Int |
Text !String |
Copyright !String |
TrackName !String |
InstrumentName !String |
Lyrics !String |
Marker !String |
CuePoint !String |
ChannelPrefix !Channel |
ProgramName !String |
DeviceName !String |
TrackEnd |
TempoChange !Tempo |
SMPTEOffset !Int !Int !Int !Int !Int |
TimeSignature !Int !Int !Int !Int |
KeySignature !Int !Int |
Reserved !Int !L.ByteString |
Sysex !Int !L.ByteString
deriving (Show,Eq)
instance Arbitrary Message where
arbitrary = do
c <- choose (0,15)
oneof [
two (choose (0,127)) >>= \(w2,w3) -> return $! NoteOff c w2 w3
, two (choose (0,127)) >>= \(w2,w3) -> return $! NoteOn c w2 w3
, two (choose (0,127)) >>= \(w2,w3) -> return $! KeyPressure c w2 w3
, two (choose (0,127)) >>= \(w2,w3) -> return $! ControlChange c w2 w3
, choose (0,127) >>= \w2 -> return $! ProgramChange c w2
, choose (0,127) >>= \w2 -> return $! ChannelPressure c w2
, do p <- choose (0,2 ^ (14 :: Int) - 1)
return $! PitchWheel c p
, choose (0,2 ^ (16 :: Int) - 1) >>= return . SequenceNumber
, arbitrary >>= return . Text
, arbitrary >>= return . Copyright
, arbitrary >>= return . TrackName
, arbitrary >>= return . InstrumentName
, arbitrary >>= return . Lyrics
, arbitrary >>= return . Marker
, arbitrary >>= return . CuePoint
, return $! ChannelPrefix c
, arbitrary >>= return . ProgramName
, arbitrary >>= return . DeviceName
, choose (0,2 ^ (14 :: Int) - 1) >>= return . TempoChange
, do w1 <- choose (0,23)
w2 <- choose (0,59)
w3 <- choose (0,59)
w4 <- choose (0,30)
w5 <- choose (0,99)
return $! SMPTEOffset w1 w2 w3 w4 w5
, do w1 <- choose (0,255)
w2 <- choose (0,255)
w3 <- choose (0,255)
w4 <- choose (1,255)
return $! TimeSignature w1 w2 w3 w4
, do w1 <- choose (-7,7)
w2 <- choose (0,1)
return $! KeySignature w1 w2
, arbitrary >>= \bs -> return $! Reserved 0x60 bs
, do w <- oneof [return 0xF0, return 0xF7]
bs <- arbitrary
return $! Sysex w bs]
isNoteOff :: Message -> Bool
isNoteOff (NoteOff {}) = True
isNoteOff _ = False
isNoteOn :: Message -> Bool
isNoteOn (NoteOn {}) = True
isNoteOn _ = False
isKeyPressure :: Message -> Bool
isKeyPressure (KeyPressure {}) = True
isKeyPressure _ = False
isControlChange :: Message -> Bool
isControlChange (ControlChange {}) = True
isControlChange _ = False
isProgramChange :: Message -> Bool
isProgramChange (ProgramChange {}) = True
isProgramChange _ = False
isChannelPressure :: Message -> Bool
isChannelPressure (ChannelPressure {}) = True
isChannelPressure _ = False
isPitchWheel :: Message -> Bool
isPitchWheel (PitchWheel {}) = True
isPitchWheel _ = False
isChannelMessage :: Message -> Bool
isChannelMessage msg = (not $ isMetaMessage msg) && (not $ isSysexMessage msg)
isSysexMessage :: Message -> Bool
isSysexMessage (Sysex _ _) = True
isSysexMessage _ = False
isMetaMessage :: Message -> Bool
isMetaMessage msg = case msg of
SequenceNumber _ -> True
Text _ -> True
Copyright _ -> True
TrackName _ -> True
InstrumentName _ -> True
Lyrics _ -> True
Marker _ -> True
CuePoint _ -> True
ChannelPrefix _ -> True
ProgramName _ -> True
DeviceName _ -> True
TrackEnd -> True
TempoChange _ -> True
SMPTEOffset _ _ _ _ _ -> True
TimeSignature _ _ _ _ -> True
KeySignature _ _ -> True
Reserved _ _ -> True
_ -> False
isTrackEnd :: Message -> Bool
isTrackEnd TrackEnd = True
isTrackEnd _ = False
removeTrackEnds :: Track a -> Track a
removeTrackEnds [] = []
removeTrackEnds trk = filter (not. isTrackEnd . snd) trk
toSingleTrack :: Midi -> Midi
toSingleTrack m@(Midi SingleTrack _ _) = m
toSingleTrack (Midi MultiTrack td trks) = Midi SingleTrack td [trk']
where trk' = foldl' merge [] trks
toSingleTrack (Midi MultiPattern td trks) = Midi SingleTrack td [trk']
where trk' = (concat $ map removeTrackEnds trks) ++ [(0,TrackEnd)]
merge :: (Num a, Ord a) => Track a -> Track a -> Track a
merge track1 track2 = (fromAbsTime $ f trk1' trk2') ++ [(0,TrackEnd)]
where
trk1' = toAbsTime $ removeTrackEnds track1
trk2' = toAbsTime $ removeTrackEnds track2
f trk [] = trk
f [] trk = trk
f ((dt1,m1) : trk1) ((dt2,m2) : trk2) = if dt1 <= dt2
then (dt1,m1) : (f trk1 ((dt2,m2) : trk2))
else (dt2,m2) : (f ((dt1,m1) : trk1) trk2)
toAbsTime :: (Num a) => Track a -> Track a
toAbsTime trk = zip ts' ms
where
(ts,ms) = unzip trk
(_,ts') = mapAccumL (\acc t -> let t' = acc + t in (t',t')) 0 ts
fromAbsTime :: (Num a) => Track a -> Track a
fromAbsTime trk = zip ts' ms
where
(ts,ms) = unzip trk
(_,ts') = mapAccumL (\acc t -> (t,t - acc)) 0 ts
toRealTime :: TimeDiv -> Track Ticks -> Track Time
toRealTime (TicksPerBeat tpb) trk = trk'
where
(_,trk') = mapAccumL f (div 60000000 120) trk
formula dt tempo =
(fromIntegral dt / fromIntegral tpb) * (fromIntegral tempo) * (1.0E-6)
f :: Tempo -> (Ticks,Message) -> (Tempo, (Time,Message))
f _ (dt, TempoChange tempo) = (tempo, (formula dt tempo, TempoChange tempo))
f tempo (dt,msg) = (tempo, (formula dt tempo,msg))
toRealTime (TicksPerSecond fps tpf) trk = map f trk
where
f (dt,msg) = (fromIntegral dt / (fromIntegral fps * fromIntegral tpf), msg)
fromRealTime :: TimeDiv -> Track Time -> Track Ticks
fromRealTime (TicksPerBeat tpb) trk = trk'
where
(_,trk') = mapAccumL f (div 60000000 120) trk
formula dt tempo = round $
(dt * fromIntegral tpb) / (fromIntegral tempo * 1.0E-6)
f :: Tempo -> (Time,Message) -> (Tempo, (Ticks,Message))
f _ (dt, TempoChange tempo) = (tempo, (formula dt tempo, TempoChange tempo))
f tempo (dt,msg) = (tempo, (formula dt tempo,msg))
fromRealTime (TicksPerSecond fps tpf) trk = map f trk
where
f (dt,msg) = (round $ dt * fromIntegral fps * fromIntegral tpf, msg)
importFile :: FilePath -> IO (Either String Midi)
importFile f = do
bs <- L.readFile f
return $! runParser parseMidi bs
exportFile :: FilePath -> Midi -> IO ()
exportFile f m = do
let bs = toLazyByteString $ buildMidi m
L.writeFile f bs
parseMidi :: Parser Midi
parseMidi = do
_ <- string "MThd"
_ <- word32be 6
formatType' <- getWord16be
trackNumber' <- getWord16be
timeDivision' <- getWord16be
let timeDivision = if testBit timeDivision' 15
then TicksPerSecond
(fromIntegral $ (flip shiftR) 9 $ shiftL timeDivision' 1)
(fromIntegral $ (flip shiftR) 8 $ shiftL timeDivision' 8)
else TicksPerBeat (fromIntegral timeDivision')
case (formatType',trackNumber') of
(0,1) -> do
track' <- parseTrack
return $! Midi SingleTrack timeDivision [track']
(1,n) -> do
tracks' <- sequence $ replicate (fromIntegral n) parseTrack
return $! Midi MultiTrack timeDivision tracks'
(2,n) -> do
tracks' <- sequence $ replicate (fromIntegral n) parseTrack
return $! Midi MultiPattern timeDivision tracks'
_ -> fail "Invalid Midi file format"
buildMidi :: Midi -> Builder
buildMidi m = mconcat [
putString "MThd"
, putWord32be 6
, case fileType m of
SingleTrack -> putWord16be 0
MultiTrack -> putWord16be 1
MultiPattern -> putWord16be 2
, putWord16be (fromIntegral $ length $ tracks m)
, case timeDiv m of
TicksPerBeat i -> putWord16be (fromIntegral i)
TicksPerSecond i1 i2 -> mconcat [
putWord8 (setBit (fromIntegral i1) 7)
, putWord8 (fromIntegral i2)]
, mconcat (map buildTrack $ tracks m)]
parseTrack :: Parser (Track Ticks)
parseTrack = do
_ <- string "MTrk"
_ <- getWord32be
track' <- parseMessages Nothing
return track'
buildTrack :: Track Ticks -> Builder
buildTrack trk = mconcat [
putString "MTrk"
, putWord32be $ fromIntegral $ L.length bs
, fromLazyByteString bs]
where
f (dt,msg) = (putVarLenBe $ fromIntegral dt) `append` buildMessage msg
bs = toLazyByteString $ mconcat (map f trk)
parseMessages :: Maybe Message -> Parser (Track Ticks)
parseMessages mPreMsg = do
dt <- getVarLenBe >>= return . fromIntegral
msg <- parseMessage mPreMsg
if (isTrackEnd msg)
then return [(dt,msg)]
else do
let mMsg = if isChannelMessage msg then (Just msg) else mPreMsg
msgs <- parseMessages mMsg
return $! (dt,msg) : msgs
parseMessage :: Maybe Message -> Parser Message
parseMessage mPreMsg = choice [
parseChannelMessage mPreMsg
, parseMetaMessage
, parseSysexMessage]
buildMessage :: Message -> Builder
buildMessage msg | isChannelMessage msg = buildChannelMessage msg
buildMessage msg | isMetaMessage msg = buildMetaMessage msg
buildMessage msg | isSysexMessage msg = buildSysexMessage msg
buildMessage _ = mempty
parseChannelMessage :: Maybe Message -> Parser Message
parseChannelMessage mPreMsg = choice $ map (\f -> f mPreMsg) [
parseNoteOff
, parseNoteOn
, parseKeyPressure
, parseControlChange
, parseProgramChange
, parseChannelPressure
, parsePitchWheel
]
parseChannel :: Maybe Message -> (Message -> Bool) -> Word8 -> Parser Channel
parseChannel mPreMsg isNeededMsg msgCode = p1 <|> p2
where
p1 = do
_ <- lookAhead (satisfy ( < 0x80))
guard $ (isJust mPreMsg) && (isNeededMsg $ fromJust mPreMsg)
return $! channel (fromJust mPreMsg)
p2 = do
w8 <- getWord8
guard (msgCode == shiftR w8 4)
return $! fromIntegral $ w8 .&. (0x0F :: Word8)
parseNoteOff :: Maybe Message -> Parser Message
parseNoteOff mPreMsg = do
ch <- parseChannel mPreMsg isNoteOff 0x08
p1 <- getWord8
p2 <- getWord8
return $! NoteOff ch (fromIntegral p1) (fromIntegral p2)
parseNoteOn :: Maybe Message -> Parser Message
parseNoteOn mPreMsg = do
ch <- parseChannel mPreMsg isNoteOn 0x09
p1 <- getWord8
p2 <- getWord8
return $! NoteOn ch (fromIntegral p1) (fromIntegral p2)
parseKeyPressure :: Maybe Message -> Parser Message
parseKeyPressure mPreMsg = do
ch <- parseChannel mPreMsg isKeyPressure 0x0A
p1 <- getWord8
p2 <- getWord8
return $! KeyPressure ch (fromIntegral p1) (fromIntegral p2)
parseControlChange :: Maybe Message -> Parser Message
parseControlChange mPreMsg = do
ch <- parseChannel mPreMsg isControlChange 0x0B
p1 <- getWord8
p2 <- getWord8
return $! ControlChange ch (fromIntegral p1) (fromIntegral p2)
parseProgramChange :: Maybe Message -> Parser Message
parseProgramChange mPreMsg = do
ch <- parseChannel mPreMsg isProgramChange 0x0C
p1 <- getWord8
return $! ProgramChange ch (fromIntegral p1)
parseChannelPressure :: Maybe Message -> Parser Message
parseChannelPressure mPreMsg = do
ch <- parseChannel mPreMsg isChannelPressure 0x0D
p1 <- getWord8
return $! ChannelPressure ch (fromIntegral p1)
parsePitchWheel :: Maybe Message -> Parser Message
parsePitchWheel mPreMsg = do
ch <- parseChannel mPreMsg isPitchWheel 0x0E
p1 <- getWord8
p2 <- getWord8
return $! PitchWheel ch $ (shiftL (fromIntegral p2) 7) .|. (fromIntegral p1)
buildChannelMessage :: Message -> Builder
buildChannelMessage msg = case msg of
NoteOff _ p1 p2 -> mconcat
[f 0x08, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
NoteOn _ p1 p2 -> mconcat
[f 0x09, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
KeyPressure _ p1 p2 -> mconcat
[f 0x0A, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
ControlChange _ p1 p2 -> mconcat
[f 0x0B, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
ProgramChange _ p1 -> mconcat [f 0x0C, putWord8 $ fromIntegral $ p1]
ChannelPressure _ p1 -> mconcat [f 0x0D, putWord8 $ fromIntegral $ p1]
PitchWheel _ p1 -> mconcat [ f 0x0E
, putWord8 (fromIntegral $ p1 .&. 0x7F)
, putWord8 (fromIntegral $ shiftR p1 7)]
_ -> mempty
where
f :: Int -> Builder
f w8 = putWord8 $ fromIntegral $ (shiftL w8 4) .|. (channel msg)
parseMetaMessage :: Parser Message
parseMetaMessage = do
_ <- word8 0xFF
choice [
parseSequenceNumber
, parseText
, parseCopyright
, parseTrackName
, parseInstrumentName
, parseLyrics
, parseMarker
, parseCuePoint
, parseChannelPrefix
, parseProgramName
, parseDeviceName
, parseTrackEnd
, parseTempoChange
, parseSMPTEOffset
, parseTimeSignature
, parseKeySignature
, parseReserved
]
buildMetaMessage :: Message -> Builder
buildMetaMessage msg = putWord8 0xFF `mappend`
case msg of
SequenceNumber i -> mconcat
[putWord8 0x00, putVarLenBe 2, putWord16be $ fromIntegral $ i]
Text s -> mconcat
[putWord8 0x01, putVarLenBe (fromIntegral $ length s), putString s]
Copyright s -> mconcat
[putWord8 0x02, putVarLenBe (fromIntegral $ length s), putString s]
TrackName s -> mconcat
[putWord8 0x03, putVarLenBe (fromIntegral $ length s), putString s]
InstrumentName s -> mconcat
[putWord8 0x04, putVarLenBe (fromIntegral $ length s), putString s]
Lyrics s -> mconcat
[putWord8 0x05, putVarLenBe (fromIntegral $ length s), putString s]
Marker s -> mconcat
[putWord8 0x06, putVarLenBe (fromIntegral $ length s), putString s]
CuePoint s -> mconcat
[putWord8 0x07, putVarLenBe (fromIntegral $ length s), putString s]
ProgramName s -> mconcat
[putWord8 0x08, putVarLenBe (fromIntegral $ length s), putString s]
DeviceName s -> mconcat
[putWord8 0x09, putVarLenBe (fromIntegral $ length s), putString s]
ChannelPrefix i -> mconcat
[putWord8 0x20, putVarLenBe 1, putWord8 $ fromIntegral $ i]
TrackEnd -> putWord8 0x2F `mappend` putVarLenBe 0
TempoChange i -> mconcat
[putWord8 0x51, putVarLenBe 3, putWord24be $ fromIntegral $ i]
SMPTEOffset i1 i2 i3 i4 i5 -> mconcat [
putWord8 0x54
, putVarLenBe 5
, mconcat $ map (putWord8 . fromIntegral) [i1,i2,i3,i4,i5]]
TimeSignature i1 i2 i3 i4 -> mconcat [
putWord8 0x58
, putVarLenBe 4
, mconcat $ map (putWord8 . fromIntegral) [i1,i2,i3,i4]]
KeySignature i1 i2 -> mconcat [
putWord8 0x59
, putVarLenBe 2
, putInt8 $ fromIntegral $ i1
, putWord8 $ fromIntegral $ i2]
Reserved w bs -> mconcat [
putWord8 (fromIntegral w)
, putVarLenBe (fromIntegral $ L.length bs)
, fromLazyByteString bs]
_ -> mempty
parseSequenceNumber :: Parser Message
parseSequenceNumber = do
_ <- word8 0x00
_ <- varLenBe 2
n <- getWord16be
return $! SequenceNumber (fromIntegral n)
parseText :: Parser Message
parseText = do
_ <- word8 0x01
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! Text s
parseCopyright :: Parser Message
parseCopyright = do
_ <- word8 0x02
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! Copyright s
parseTrackName :: Parser Message
parseTrackName = do
_ <- word8 0x03
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! TrackName s
parseInstrumentName :: Parser Message
parseInstrumentName = do
_ <- word8 0x04
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! InstrumentName s
parseLyrics :: Parser Message
parseLyrics = do
_ <- word8 0x05
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! Lyrics s
parseMarker :: Parser Message
parseMarker = do
_ <- word8 0x06
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! Marker s
parseCuePoint :: Parser Message
parseCuePoint = do
_ <- word8 0x07
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! CuePoint s
parseProgramName :: Parser Message
parseProgramName = do
_ <- word8 0x08
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! ProgramName s
parseDeviceName :: Parser Message
parseDeviceName = do
_ <- word8 0x09
l <- getVarLenBe
s <- getString (fromIntegral l)
return $! DeviceName s
parseChannelPrefix :: Parser Message
parseChannelPrefix = do
_ <- word8 0x20
_ <- varLenBe 1
p <- getWord8
return $! ChannelPrefix (fromIntegral p)
parseTrackEnd :: Parser Message
parseTrackEnd = do
_ <- word8 0x2F
_ <- varLenBe 0
return $! TrackEnd
parseTempoChange :: Parser Message
parseTempoChange = do
_ <- word8 0x51
_ <- varLenBe 3
t <- getWord24be
return $! TempoChange (fromIntegral t)
parseSMPTEOffset :: Parser Message
parseSMPTEOffset = do
_ <- word8 0x54
_ <- varLenBe 5
bs <- getLazyByteString 5
let [n1,n2,n3,n4,n5] = map fromIntegral (L.unpack bs)
return $! SMPTEOffset n1 n2 n3 n4 n5
parseTimeSignature :: Parser Message
parseTimeSignature = do
_ <- word8 0x58
_ <- varLenBe 4
bs <- getLazyByteString 4
let [n1,n2,n3,n4] = map fromIntegral (L.unpack bs)
return $! TimeSignature n1 n2 n3 n4
parseKeySignature :: Parser Message
parseKeySignature = do
_ <- word8 0x59
_ <- varLenBe 2
n1 <- getInt8
n2 <- getWord8
return $! KeySignature (fromIntegral n1) (fromIntegral n2)
parseReserved :: Parser Message
parseReserved = do
t <- getWord8
l <- getVarLenBe
bs <- getLazyByteString (fromIntegral l)
return $! Reserved (fromIntegral t) bs
parseSysexMessage :: Parser Message
parseSysexMessage = do
w <- (word8 0xF0) <|> (word8 0xF7)
l <- getVarLenBe
d <- getLazyByteString (fromIntegral l)
return $! Sysex (fromIntegral w) d
buildSysexMessage :: Message -> Builder
buildSysexMessage (Sysex i bs) =
mconcat [ putWord8 $ fromIntegral $ i
, putVarLenBe $ fromIntegral $ L.length bs
, fromLazyByteString bs]
buildSysexMessage _ = mempty
two :: Applicative f => f a -> f (a,a)
two a = pure ((,)) <*> a <*> a