content: 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 -- end marker, very important!
  > 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 7 . numToBinStr
  
  Pad a binary string to be a multiple of i 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) = -- META EVENT, HAS NO CHANNEL NUMBER
  >     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)
   