MIDI File-writing module for use with Euterpea
Donya Quick
Last modified: 19-June-2013
This file fixes some file-writing bugs in Codec.Midi that
prevent some multi-instrument output from showing up correctly.
It defines the function exportMidiFile, which can be used like
Codec.Midi's exportFile function. Additionally, it defines two
functions for writing MIDI files, writeMidi and writeMidiA that
are like test and testA respectively but with an additional file
path argument.
NOTE #1: some of the binary handling should be redone at some
point. Currently, parts of it are using conversion to a String
type, and although it works, it should not be necessary (or at
least a cleaner way should be found).
NOTE #2: many MIDI messages are currently unsupported. The set
of supported messages is limited to those that can be produced by
Euterpea.
> module Euterpea.IO.MIDI.ExportMidiFile
> (exportMidiFile) where
> import Codec.Midi
> import Numeric
> import Data.Char
> import qualified Data.ByteString as Byte
A standard MIDI file has two main sections: a header and a
series of track chunks. Track chunks each have a track header
section and end with an end-of-track marker. Detailed infomation
on the file format can be found here:
http://faydoc.tripod.com/formats/mid.htm
> makeFile :: Midi -> Byte.ByteString
> makeFile (Midi ft td trs) =
> let ticksPerQn =
> case td of TicksPerBeat x -> x
> TicksPerSecond x y ->
> error ("(makeFile) Don't know how "++
> "to handle TicksPerSecond yet.")
> header = makeHeader ft (length trs) ticksPerQn
> body = map makeTrack trs
> in Byte.concat (header:body)
============
BUILD FILE HEADER
The standard MIDI file header starts with the following value:
4D 54 68 00 00 00 06 ff ff nn nn dd dd
ff ff is the format of the file: single-track, multi-track, or
multi-track/multi-pattern. Only the first two cases are addressed
here.
nn nn is the number of tracks in the file.
dd dd is the delta-time in ticks for a quarternote or beat.
> midiHeaderConst :: Byte.ByteString
> midiHeaderConst =
> Byte.pack [0x4D, 0x54, 0x68, 0x64, 0x00, 0x00, 0x00, 0x06]
> type TrackCount = Int
> type TicksPerQN = Int
The MIDI file header is built as described above.
> makeHeader :: FileType -> TrackCount -> TicksPerQN -> Byte.ByteString
> makeHeader ft numTracks ticksPerQn =
> let
> ft' = case ft of SingleTrack -> [0x00, 0x00]
> MultiTrack -> [0x00, 0x01]
> MultiPattern -> error ("(makeHeader) Don't know "++
> "how to handle multi-pattern yet.")
> numTracks' = padByte 2 numTracks
> ticksPerQn' = padByte 2 ticksPerQn
> in if numTracks > 16 then error ("(makeHeader) Don't know how to "++
> "handle >16 tracks!")
> else Byte.concat [midiHeaderConst, Byte.pack ft', numTracks', ticksPerQn']
> padByte :: Integral a => Int -> a -> Byte.ByteString
> padByte byteCount i =
> let b = Byte.pack [fromIntegral i]
> n = Byte.length b
> padding = Byte.pack $ take (byteCount - n) $ repeat 0x00
> in if n < byteCount then Byte.concat [padding, b] else b
================
BUILDING TRACKS
A track consists of a track header, event information, and an
end-of-track marker. The track header has the format:
4D 54 72 6B xx xx xx xx
xx xx xx xx is the total number of BYTES in the track that
follows the header. This includes the end marker! This value
is obtained by generating the track first and then generating
its header.
> makeTrack :: Track Ticks -> Byte.ByteString
> makeTrack t =
> let body = makeTrackBody t
> header = makeTrackHeader body
> in Byte.concat [header, body]
> trackHeaderConst :: Byte.ByteString
> trackHeaderConst = Byte.pack [0x4D, 0x54, 0x72, 0x6B]
> makeTrackHeader :: Byte.ByteString -> Byte.ByteString
> makeTrackHeader tbody =
> let len = Byte.length tbody
> f = Byte.pack . map (fromIntegral . binStrToNum . reverse) .
> breakBinStrs 8 . pad (8*4) '0' . numToBinStr
> in Byte.concat [trackHeaderConst, f len]
Track events have two components: a variable-length delta-time and
a message. The delta-time is the number of ticks between the last
message and the next one. The format will be: time message time message ...
However, delta-times are tricky things. The fact that they can be
any length requires that they be encoded in a special way. The binary
value of the number is split into 7-bit sections. This splitting
goes from RIGHT TO LEFT (this is not in any documentation I have read,
but was the only way that worked). For n sections, the first start
with a 1 and the last starts with a 0 - thereby indicating the last
byte of the number. The following is an example of the conversion:
192 track ticks = C0 (hex) = 1100 0000 (bin)
==> converts to 8140 (hex)
Split into 7-bit groups: [1] [100 0000]
Apply padding: [000 0001] [100 0000]
Add flags: [1000 0001] [0100 0000]
Result as hex 8 1 4 0
> makeTrackBody :: Track Ticks -> Byte.ByteString
> makeTrackBody [] = endOfTrack
> makeTrackBody ((ticks, msg):rest) =
> let b = msgToBytes msg
> b' = [to7Bits ticks, msgToBytes msg, makeTrackBody rest]
> in if Byte.length b > 0 then Byte.concat b'
> else makeTrackBody rest
The end of track marker is set 96 ticks after the last event in the
track. This offset is arbitrary, but it helps avoid clipping the notes
at the end of a file during playback in a program like Winamp or
Quicktime.
> endOfTrack = Byte.concat [to7Bits 96, Byte.pack [0xFF, 0x2F, 0x00]]
Splitting numbers into 7-bit sections and applying flags is done
by the following process:
- convert to a binary string representation
- pad the number to be full bytes
- split from right to left into groups of 7 and apply flags
- convert each 8-bit chunk back to a byte representation
> to7Bits :: (Integral a, Show a) => a -> Byte.ByteString
> to7Bits = Byte.pack . map (fromIntegral . binStrToNum . reverse) .
> fixBinStrs . map (padTo 7 . reverse). reverse .
> breakBinStrs 7 . reverse . padTo 8 . numToBinStr
Pad a binary string to be a multiple of 8 bits:
> padTo :: Int -> String -> String
> padTo i xs = if length xs `mod` i == 0 then xs else padTo i ('0':xs)
Break a string into chunks of length i:
> breakBinStrs :: Int -> String -> [String]
> breakBinStrs i s =
> if length s <= i then [s] else take i s : breakBinStrs i (drop i s)
Convert a number to a binary string:
> numToBinStr :: (Integral a, Show a) => a -> String
> numToBinStr i = showIntAtBase 2 intToDigit i ""
Convert a binary string to an integer:
> binStrToNum :: String -> Int
> binStrToNum [] = 0
> binStrToNum ('0':xs) = 2* binStrToNum xs
> binStrToNum ('1':xs) = 1 + 2*binStrToNum xs
> binStrToNum _ = error "bad data."
Append flags to a string (note, the string must be BACKWARDS):
> fixBinStrs :: [String] -> [String]
> fixBinStrs xs =
> let n = length xs
> bits = take (n-1) (repeat '1') ++ "0"
> in Prelude.zipWith (:) bits xs
Pad a list from the left until it is a fixed length:
> pad :: Int -> a -> [a] -> [a]
> pad b x xs = if length xs >= b then xs else pad b x (x:xs)
Messages have the following encodings:
8x nn vv Note Off for pitch nn at velocity vv, channel x
9x nn vv Note On for pitch nn at velocity vv, channel x
Ax nn vv Key aftertouch for pitch nn at velocity vv, channel x
Bx cc vv Control Change for controller cc with value vv, channel x
Cx pp Program Change to patch pp for channel x
Dx cc Channel after-touch to cc on channel x
Ex bb tt Pitch wheel to value ttbb, channel x (2000 hex is "normal")
(note: bb are least significant bits, tt are most significant)
Currently, only note on/off, control change, and program change are supported.
There are also META -EVENTS. This are events that have no channel number.
All meta-events have the format
FF xx nn nn dd dd ...
where xx is the command code, and nnnn is the number of bytes in the data (dd).
FF 00 nn ssss Set track sequence number
FF 01 nn tt... Text event
FF 02 nn tt... Copyright info
FF 03 nn tt... Track name
FF 04 nn tt... Track instrument name
FF 05 nn tt... Lyric
FF 06 nn tt... Marker
FF 07 nn tt... Cue point
FF 2F 00 END OF TRACK MARKER
FF 51 03 tttttt Tempo change marker, where tttttt is the microseconds per qn
FF 48 04 nnddccbb Time signature nn/dd with cc ticks per beat and bb 32nds/qn
FF 59 02 sfmi Key signature with sf sharps/flats and mi mode in {0,1}
Of these, only the end of track and tempo marker are implemented.
> msgToBytes :: Message -> Byte.ByteString
> msgToBytes (NoteOn c k v) =
> Byte.concat [Byte.pack [0x90 + fromIntegral c], padByte 1 k, padByte 1 v]
> msgToBytes (NoteOff c k v) =
> Byte.concat [Byte.pack [0x80 + fromIntegral c], padByte 1 k, padByte 1 v]
> msgToBytes (ProgramChange c p) =
> Byte.concat [Byte.pack [0xC0 + fromIntegral c], padByte 1 p]
> msgToBytes (ControlChange c n v) =
> Byte.concat [Byte.pack [0xB0 + fromIntegral c], padByte 1 n, padByte 1 v]
> msgToBytes (TempoChange t) =
> Byte.concat [Byte.pack [0xFF, 0x51, 0x03], fixTempo t]
> msgToBytes x = error ("(msgToBytes) Message type not currently "++
> "supported: "++show x)
Fix a tempo value to be exactly 3 bytes:
> fixTempo = Byte.pack . map (fromIntegral . binStrToNum . reverse) .
> breakBinStrs 8 . pad (4*6) '0' . numToBinStr
> exportMidiFile :: FilePath -> Midi -> IO ()
> exportMidiFile fn = Byte.writeFile fn . makeFile
=================
USAGE
The exportMidiFile can now be used as follows in place of Codec.Midi's exportFile:
writeMidi :: (ToMusic1 a) => FilePath -> Music a -> IO ()
writeMidi fn = exportMidiFile fn . testMidi
writeMidiA :: (ToMusic1 a) => FilePath -> PMap Note1 -> Context Note1 -> Music a -> IO ()
writeMidiA fn pm con m = exportMidiFile fn $ testMidiA pm con m
test :: (ToMusic1 a) => Music a -> IO ()
test = exportMidiFile "test.mid" . testMidi
testA :: ToMusic1 a => PMap Note1 -> Context Note1 -> Music a -> IO ()
testA pm con m = exportMidiFile "test.mid" (testMidiA pm con m)