{- | Save MIDI data to files. The functions in this module allow 'Sound.MIDI.File.T's to be made into Standard MIDI files (@*.mid@) that can be read and played by music programs such as Cakewalk. -} module Sound.MIDI.File.Save (toFile, toStream, toOpenStream) where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile import qualified Sound.MIDI.Event as MIDIEvent import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg import qualified Sound.MIDI.Bit as Bit import Data.Bits ((.|.)) import Sound.MIDI.IO (ByteString, writeBinaryFile, stringByteFromChar) import Control.Monad.Writer (Writer, tell, execWriter) import Data.Ix (Ix, index) import Data.List (genericLength) {- | The function 'toFile' is the main function for writing 'MIDIFile.T' values to an actual file; its first argument is the filename: -} toFile :: FilePath -> MIDIFile.T -> IO () toFile fn mf = writeBinaryFile fn (toStream mf) {- | MIDI files are first converted to a monadic string computation using the function 'outMF', and then \"executed\" using 'execWriter'. -} toStream, toOpenStream :: MIDIFile.T -> ByteString toStream = execWriter . outMF outChunk toOpenStream = execWriter . outMF outOpenChunk outMF :: OutChunk -> MIDIFile.T -> MIDIWriter () outMF outChk (MIDIFile.Cons mft divisn trks) = do outChunk "MThd" (do outInt 2 (fromEnum mft) -- format (type 0, 1 or 2) outInt 2 (length trks) -- number of tracks to come outputDivision divisn) -- time unit mapM_ (outputTrack outChk) trks outputDivision :: Division -> MIDIWriter () outputDivision (Ticks nticks) = outInt 2 (NonNeg.toNumber nticks) outputDivision (SMPTE mode nticks) = do outInt 1 (256-mode) outInt 1 nticks outputTrack :: OutChunk -> Track -> MIDIWriter () outputTrack outChk trk = outChk "MTrk" $ EventList.mapM_ outVar outputEvent $ EventList.snoc trk 0 (MetaEvent EndOfTrack) {- | The following functions encode various 'MIDIFile.T' elements into the raw data of a standard MIDI file. -} outputEvent :: MIDIFile.Event -> MIDIWriter () outputEvent e = case e of MIDIEvent ch mevent -> outputMIDIEvent ch mevent MetaEvent mevent -> outputMetaEvent mevent _ -> error ("don't know, how to write a "++show e++".") outputMIDIEvent :: MIDIEvent.Channel -> MIDIEvent.T -> MIDIWriter () outputMIDIEvent c e = let outC = outChan c in case e of (MIDIEvent.NoteOff p v) -> outC 8 [MIDIEvent.fromPitch p, MIDIEvent.fromVelocity v] (MIDIEvent.NoteOn p v) -> outC 9 [MIDIEvent.fromPitch p, MIDIEvent.fromVelocity v] (MIDIEvent.PolyAfter p pr) -> outC 10 [MIDIEvent.fromPitch p, pr] (MIDIEvent.Control cn cv) -> outC 11 [fromEnum cn, cv] (MIDIEvent.ProgramChange pn) -> outC 12 [MIDIEvent.fromProgram pn] (MIDIEvent.MonoAfter pr) -> outC 13 [pr] (MIDIEvent.PitchBend pb) -> let (hi,lo) = Bit.splitAt 7 pb in outC 14 [lo,hi] -- little-endian!! -- output a channel event outChan :: MIDIEvent.Channel -> Int -> [Int] -> MIDIWriter () outChan chan code bytes = do outInt 1 (16*code + MIDIEvent.fromChannel chan) mapM_ (outInt 1) bytes outMetaByteStr :: Int -> ByteString -> MIDIWriter () outMetaByteStr code bytes = do outInt 1 255 outInt 1 code outVar (genericLength bytes) outByteStr bytes outMetaStr :: Int -> String -> MIDIWriter () outMetaStr code = outMetaByteStr code . stringByteFromChar outMetaList :: Int -> [Int] -> MIDIWriter () outMetaList code = outMetaByteStr code . map fromIntegral -- As with outChunk, there are other ways to do this - but -- it's not obvious which is best or if performance is a big issue. outMetaMW :: Int -> MIDIWriter () -> MIDIWriter () outMetaMW code = outMetaByteStr code . execWriter outputMetaEvent :: MetaEvent -> MIDIWriter () outputMetaEvent (SequenceNum num) = outMetaMW 0 (outInt 2 num) outputMetaEvent (TextEvent s) = outMetaStr 1 s outputMetaEvent (Copyright s) = outMetaStr 2 s outputMetaEvent (TrackName s) = outMetaStr 3 s outputMetaEvent (InstrName s) = outMetaStr 4 s outputMetaEvent (Lyric s) = outMetaStr 5 s outputMetaEvent (Marker s) = outMetaStr 6 s outputMetaEvent (CuePoint s) = outMetaStr 7 s outputMetaEvent (MIDIPrefix c) = outMetaList 32 [MIDIEvent.fromChannel c] outputMetaEvent EndOfTrack = outMetaList 47 [] outputMetaEvent (SetTempo tp) = outMetaMW 81 (outInt 3 (NonNeg.toNumber tp)) outputMetaEvent (SMPTEOffset hr mn se fr ff) = outMetaList 84 [hr,mn,se,fr,ff] outputMetaEvent (TimeSig n d c b) = outMetaList 88 [n,d,c,b] outputMetaEvent (KeySig sf mi) = outMetaList 89 [sf', fromEnum mi] where k = index (KeyCf,KeyCs) sf - 7 sf' = if (k >= 0) then k else 255+k outputMetaEvent (SequencerSpecific codes) = outMetaByteStr 127 codes outputMetaEvent (Unknown typ s) = outMetaByteStr typ s {- | The 'MIDIWriter' accumulates a String. For all the usual reasons, the String is represented by ShowS. -} type MIDIWriter a = Writer ByteString a outInt :: Int -> Int -> MIDIWriter () outInt a = outByteStr . map fromIntegral . Bit.someBytes a outStr :: String -> MIDIWriter () outStr = outByteStr . stringByteFromChar outByteStr :: ByteString -> MIDIWriter () outByteStr = tell {- | Numbers of variable size are represented by sequences of 7-bit blocks tagged (in the top bit) with a bit indicating: (1) that more data follows; or (0) that this is the last block. -} outVar :: NonNeg.Integer -> MIDIWriter () outVar n = let bytes = map fromIntegral $ Bit.toBase 128 n in case bytes of [] -> outInt 1 0 (_:bs) -> let highBits = map (const 128) bs ++ [0] in outByteStr (zipWith (.|.) highBits bytes) outTag :: String -> MIDIWriter () outTag tag@(_:_:_:_:[]) = outStr tag outTag tag = error ("SaveMIDI.outChunk: Chunk name " ++ tag ++ " does not consist of 4 characters.") {- Note: here I've chosen to compute the track twice rather than store it. Other options are worth exploring. -} type OutChunk = String -> MIDIWriter () -> MIDIWriter () outChunk, outOpenChunk :: OutChunk outChunk tag m = do outTag tag let str = execWriter m outInt 4 (length str) outByteStr str {- | The MIDI standard seems to require a fixed length for all chunks. Chunks with unknown length are essential for infinite music and music that is created on the fly. -} outOpenChunk tag m = do outTag tag outInt 4 (-1) m