\subsubsection{Reading Midi files}
\seclabel{Haskore.Interface.MIDI.Read}

Now that we have translated a raw Midi file into a \code{MidiFile.T} data type,
we can translate that \code{MidiFile.T} into a \code{MidiMusic.T} object.

\begin{haskelllisting}

> module Haskore.Interface.MIDI.Read (toRhyMusic, toGMMusic,
>  {- debugging -} retrieveTracks)
>   where
>
> import qualified Haskore.Interface.MIDI.Note          as MidiNote
> import qualified Haskore.Interface.MIDI.InstrumentMap as InstrMap
> import           Sound.MIDI.File                  as MidiFile
> import qualified Sound.MIDI.File.Event            as MidiFileEvent
> import qualified Sound.MIDI.Message.Channel       as ChannelMsg
> import qualified Sound.MIDI.Message.Channel.Voice as Voice
> import qualified Sound.MIDI.General               as GeneralMidi
> import Sound.MIDI.File.Event (T(MIDIEvent, MetaEvent), )
> import Sound.MIDI.File.Event.Meta (T(SetTempo), defltTempo, )
> import Sound.MIDI.Message.Channel (Body(Voice), Channel, )
> import Sound.MIDI.Message.Channel.Voice (Program, )
>
> import Haskore.Basic.Duration ((%+))
> import qualified Data.EventList.Relative.TimeBody  as TimeList
> import qualified Data.EventList.Relative.MixedBody as TimeList
> import qualified Haskore.Music             as Music
> import qualified Haskore.Music.GeneralMIDI as MidiMusic
> import qualified Haskore.Music.Rhythmic    as RhyMusic
> import qualified Haskore.Performance.Context  as Context
> import qualified Haskore.Performance.BackEnd  as PfBE
> import qualified Haskore.Performance.Default  as DefltPf
> import qualified Haskore.Process.Optimization as Optimization

> import qualified Numeric.NonNegative.Class as NonNeg

> import Haskore.Music
>              (line, chord, changeTempo, Dur, DurRatio)
> import Data.Tuple.HT (mapPair, mapSnd, )
> import qualified Data.List.HT as ListHT
>
> import Haskore.General.Map (Map)
> import qualified Haskore.General.Map as Map
> import Data.Maybe (mapMaybe, fromMaybe)

\end{haskelllisting}

The main function.
Note that we need drum and instrument maps
in order to restore a \code{Context.T}
as well as a \code{RhyMusic.T} object.
\begin{haskelllisting}

> toRhyMusic ::
>    (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    InstrMap.ChannelProgramPitchTable drum ->
>    InstrMap.ChannelProgramTable instr ->
>    MidiFile.T ->
>       (Context.T time dyn (RhyMusic.Note drum instr), RhyMusic.T drum instr)
> toRhyMusic dMap iMap mf@(MidiFile.Cons _ d trks) =
>   let cpm = makeCPM trks
>       m   = Music.mapNote
>                (MidiNote.toRhyNote
>                   (InstrMap.reverseLookupMaybe dMap)
>                   (InstrMap.reverseLookupMaybe iMap))
>                (format (readFullTrack d cpm) (MidiFile.explicitNoteOff mf))
>   in (context, m)

> toGMMusic ::
>    (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    MidiFile.T -> (InstrMap.ChannelTable MidiMusic.Instr,
>                   Context.T time dyn MidiMusic.Note, MidiMusic.T)
> toGMMusic mf@(MidiFile.Cons _ d trks) =
>   let cpm     = makeCPM trks
>       upm     = map (\(ch, progNum) ->
>                       (GeneralMidi.instrumentFromProgram progNum, ch))
>                     (Map.toList cpm)
>       m       = Music.mapNote MidiNote.toGMNote
>                    (format (readFullTrack d cpm)
>                            (MidiFile.explicitNoteOff mf))
>   in (upm, context, m)

> context ::
>    (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    Context.T time dyn note
> context =
>    Context.setPlayer DefltPf.player $
>    Context.setDur 2 $
>    DefltPf.context

> retrieveTracks :: MidiFile.T -> [[MidiMusic.T]]
> retrieveTracks (MidiFile.Cons _ d trks) =
>   let cpm = makeCPM trks
>   in  map (map (Music.mapNote MidiNote.toGMNote
>                  . readTrack (MidiFile.ticksPerQuarterNote d) cpm . fst)
>              . prepareTrack) trks

> type ChannelProgramMap = Map ChannelMsg.Channel Voice.Program

> readFullTrack ::
>    Division -> ChannelProgramMap -> Track -> Music.T MidiNote.T
> readFullTrack dv cpm =
>   let readTempoTrack (t,r) =
>          changeTempo r (readTrack (MidiFile.ticksPerQuarterNote dv) cpm t)
>   in  Optimization.all . line . map readTempoTrack . prepareTrack

> prepareTrack :: Track -> [(RichTrack, DurRatio)]
> prepareTrack =
>    map (extractTempo defltTempo) . segmentBeforeSetTempo .
>    mergeNotes defltTempo . moveTempoToHead

\end{haskelllisting}

Make one big music out of the individual tracks of a MidiFile,
using different composition types depending on the format of the MidiFile.
\begin{haskelllisting}

> format :: (Track -> Music.T note) -> MidiFile.T -> Music.T note
> format tm (MidiFile.Cons typ _ trks) =
>    let trks' = map tm trks
>    in  case typ of
>           MidiFile.Mixed ->
>              case trks' of
>                 [trk] -> trk
>                 _ -> error ("toRhyMusic: Only one track allowed for MIDI file type 0.")
>           MidiFile.Parallel -> chord trks'
>           MidiFile.Serial   -> line  trks'

\end{haskelllisting}


Look for Program Changes in the given tracks,
in order to make a \code{ChannelProgramMap}.
\begin{haskelllisting}

> makeCPM :: [Track] -> ChannelProgramMap
> makeCPM =
>    Map.fromList . concatMap (mapMaybe getPC . TimeList.getBodies)
>
> getPC :: MidiFileEvent.T -> Maybe (Channel, Program)
> getPC ev =
>    do (ch, Voice.ProgramChange num) <- MidiFileEvent.maybeVoice ev
>       Just (ch, num)

\end{haskelllisting}

\code{moveTempoToHead} gets the information that occurs at the beginning of
the piece: the default tempo and the default key signature.
A \code{SetTempo} in the middle of the piece
should translate to a tempo change (\code{Tempo r m}),
but a \code{SetTempo} at time 0 should set the default
tempo for the entire piece, by translating to \code{Context.T} tempo.
It remains a matter of taste which tempo of several parallel tracks
to use for the whole music.
\code{moveTempoToHead} takes care of all events that occur at time 0
so that if any \code{SetTempo} appears at time 0,
it is moved to the front of the list,
so that it can be easily retrieved from the result of
\code{segmentBeforeSetTempo}.
\begin{haskelllisting}

> moveTempoToHead :: Track -> Track
> moveTempoToHead es =
>    let (tempo, track) = getHeadTempo es
>    in  TimeList.cons 0 (MetaEvent (SetTempo tempo)) track

> getHeadTempo :: Track -> (Tempo, Track)
> getHeadTempo es =
>    maybe
>       (defltTempo, es)
>       (\ ~(me,rest) ->
>           case me of
>              MetaEvent (SetTempo tempo) -> (tempo, rest)
>              _ -> mapSnd (TimeList.cons 0 me) (getHeadTempo rest))
>       (do ((0,me),rest) <- TimeList.viewL es
>           return (me,rest))

\end{haskelllisting}

Manages the tempo changes in the piece.
It translates each MidiFile \code{SetTempo}
into a ratio between the new tempo and the tempo at the beginning.
\begin{haskelllisting}

> extractTempo :: Tempo -> RichTrack -> (RichTrack, DurRatio)
> extractTempo d trk =
>    fromMaybe
>       (trk, 1)
>       (do ((_, Event (MetaEvent (SetTempo tempo))), rest) <- TimeList.viewL trk
>           return (rest, toInteger d %+ toInteger tempo))

\end{haskelllisting}

\code{segmentBefore} is used to split a track into sub-tracks by tempo.
We do not want to add this function to the \code{event-list} package,
because the precise type would be
\type{AlternatingList.Disparate (TimeList.T time body) (TimeList.Event time body)}
and that's inconvenient for our application.
\begin{haskelllisting}

> segmentBefore ::
>    (body -> Bool) -> TimeList.T time body -> [TimeList.T time body]
> segmentBefore p =
>    map TimeList.fromPairList .
>    ListHT.segmentBefore (p . snd) .
>    TimeList.toPairList

\end{haskelllisting}

\begin{haskelllisting}

> isSetTempo :: RichEvent -> Bool
> isSetTempo (Event (MetaEvent (SetTempo _))) = True
> isSetTempo _                                = False

> segmentBeforeSetTempo :: RichTrack -> [RichTrack]
> segmentBeforeSetTempo = segmentBefore isSetTempo

\end{haskelllisting}

\code{readTrack} is the heart of the \code{toRhyMusic} operation.
It reads a track that has been processed by \code{mergeNotes},
and returns the track as \code{StdMusic.T}.
A \code{RichEvent} consists either of a normal \code{MIDIEvent}
or of a note, which in contrast to normal \code{MIDIEvent}s
contains the information of corresponding \code{NoteOn} and \code{NoteOff} events.

\begin{haskelllisting}

> type RichTrack = TimeList.T ElapsedTime RichEvent
> data RichEvent =
>      Event MidiFileEvent.T
>    | Note  ElapsedTime MidiNote.T

> readTrack :: Tempo -> ChannelProgramMap ->
>    RichTrack -> Music.T MidiNote.T
> readTrack ticksPerQN cpm =
>    PfBE.toMusic . trackTimeToStd ticksPerQN
>     . richTrackToBE . applyProgChanges cpm

\end{haskelllisting}

Take the division in ticks per quarterNote and
a duration value in number of ticks and
converts that to a common note duration
(such as quarter note, eighth note, etc.).
\begin{haskelllisting}

> fromTicks :: Tempo -> ElapsedTime -> Dur
> fromTicks ticksPerQN d =
>    toInteger d %+ (toInteger ticksPerQN * quarter)

> quarter :: Integer
> quarter = 4

> trackTimeToStd :: Tempo ->
>    PfBE.T ElapsedTime note -> PfBE.T Dur note
> trackTimeToStd ticksPerQN =
>    TimeList.mapBody
>       (\(PfBE.Event d n) -> PfBE.Event (fromTicks ticksPerQN d) n)
>       . TimeList.mapTime (fromTicks ticksPerQN)

\end{haskelllisting}

Look up an instrument name from a \code{ChannelProgramMap} given its channel number.
\begin{haskelllisting}

> lookupChannelProg :: ChannelProgramMap -> Channel -> Program
> lookupChannelProg cpm =
>    Map.findWithDefault cpm
>       (error "Invalid channel in user patch map")

\end{haskelllisting}

Implement a \keyword{Program Change}: a change in the \code{ChannelProgramMap} in
which a channel changes from one instrument to another.
\begin{haskelllisting}

> progChange :: Channel -> Program -> ChannelProgramMap -> ChannelProgramMap
> progChange = Map.insert
> -- progChange ch num cpm = Map.insert ch num cpm

\end{haskelllisting}

Process all \code{ProgramChange} events in a track.
That is, manage a patch map and
insert in the appropriate program numbers into the \type{MidiNote.T}s.

The function works the following way:
Split the track into pieces, each beginning with a program change.
Compute the patch maps that are active after each program change.
Apply these patch maps to the track parts.
\begin{haskelllisting}

> isProgChange :: RichEvent -> Bool
> isProgChange (Event ev) =
>    maybe False (const True) (getPC ev)
> isProgChange _ = False

> applyProgChanges :: ChannelProgramMap -> RichTrack -> RichTrack
> applyProgChanges cpm track =
>    let parts@(_:pcParts) = segmentBefore isProgChange track
> {-
>        updateCPM (Event (MIDIEvent ch (ProgramChange prog))) =
>           progChange ch prog
>        updateCPM _  =  error "TimeList.collectCoincident is buggy"
> -}
>        updateCPM =
>           TimeList.switchL
>              (error "TimeList.collectCoincident is buggy")
>              (\ (_, Event ev) _ ->
>                  maybe
>                     (error "after segmentation, each part should start with ProgramChange event")
>                     (uncurry progChange)
>                     (getPC ev))
>        cpms =
>           scanl (flip id) cpm (map updateCPM pcParts)
>        setProg localCPM (Note d n) =
>           Note d (n{MidiNote.program =
>                        lookupChannelProg localCPM (MidiNote.channel n)})
>        setProg _ e = e
>    in  TimeList.concat (zipWith (TimeList.mapBody . setProg) cpms parts)

\end{haskelllisting}

Remove meta events from \type{RichTrack},
thus converting to a back-end performance.
\begin{haskelllisting}

> richNoteToBE :: RichEvent -> PfBE.Event ElapsedTime MidiNote.T
> richNoteToBE (Note d n) = PfBE.Event d n
> richNoteToBE _ = error "richNoteToBE: only Note constructor allowed"

> isRichNote :: RichEvent -> Bool
> isRichNote (Note _ _) = True
> isRichNote _          = False

> richTrackToBE :: RichTrack -> PfBE.T ElapsedTime MidiNote.T
> richTrackToBE =
>    TimeList.mapBody richNoteToBE . fst
>       . TimeList.partition isRichNote

\end{haskelllisting}

The \code{mergeNotes} function changes the order of the events in a track
so that they can be handled by readTrack: each \code{NoteOff}
is put directly after its corresponding \code{NoteOn}. Its first and second
arguments are the elapsed time and value (in microseconds per quarter
note) of the \code{SetTempo} currently in effect.
\begin{haskelllisting}

> mergeNotes :: Tempo -> Track -> RichTrack
> mergeNotes stv =
>    TimeList.mapTimeTail
>       (TimeList.switchBodyL $ \ e rest ->
>            uncurry TimeList.consBody $
>            let deflt = (Event e, mergeNotes stv rest)
>            in  case e of
>                   MetaEvent (SetTempo newStv) ->
>                      (Event e, mergeNotes newStv rest)
>                   MIDIEvent chmsg@(ChannelMsg.Cons _ (Voice msg)) ->
>                      if Voice.isNoteOn msg
>                        then mapPair
>                                (uncurry Note, mergeNotes stv)
>                                (searchNoteOff 0 stv 1 chmsg rest)
>                        else
>                          if Voice.isNoteOff msg
>                            then error "NoteOff before NoteOn"
>                            else deflt
>                   _ -> deflt)

\end{haskelllisting}

The function \code{searchNoteOff} takes a track and
looks through the list of events to find the \code{NoteOff}
corresponding to the given \code{NoteOn}.
A \code{NoteOff} corresponds to an earlier \code{NoteOn}
if it is the first in the track to have the same channel and pitch.
If between \code{NoteOn} and \code{NoteOff} are \code{SetTempo} events,
it calculates what the elapsed-time is,
expressed in the current tempo.
This function takes a ridiculous number of arguments,
I know, but I don't think it can do without any of the information.
Maybe there is a simpler way.
\begin{haskelllisting}

> searchNoteOff ::
>       Double          {- ^ time interval between NoteOn and now,
>                            in terms of the tempo at the NoteOn -}
>    -> Tempo -> Double {- ^ SetTempo values: the one at the NoteOn and
>                            the ratio between the current tempo and the first one. -}
>    -> ChannelMsg.T    {- ^ channel and pitch of NoteOn (NoteOff must match) -}
>    -> Track           {- ^ the track to be searched -}
>    -> ((ElapsedTime, MidiNote.T), Track)
>                       -- ^ the needed event and the remainder of the track
>
> searchNoteOff int ost str chm0 =
>    TimeList.switchL
>       (error "ReadMidi.searchNoteOff: no corresponding NoteOff")
>       (\(t1, mev1) es ->
>           maybe
>              -- if MIDI events don't match, then recourse
>              (mapSnd (TimeList.cons t1 mev1) $
>               searchNoteOff (addInterval str t1 int) ost
>                  (case mev1 of
>                     -- respect tempo changes
>                     MetaEvent (SetTempo nst) ->
>                          fromIntegral ost / fromIntegral nst
>                     _ -> str)
>                  chm0 es)
>              -- if MIDI events match, construct a MidiNote.T
>              (\note ->
>                 let d = round (addInterval str t1 int)
>                 in  ((d, note), TimeList.delay t1 es))
>              -- check whether NoteOn and NoteOff matches
>              (do chm1 <- MidiFileEvent.maybeMIDIEvent mev1
>                  MidiNote.fromMIDIEvents (chm0, chm1)))

> addInterval :: Double -> ElapsedTime -> Double -> Double
> addInterval str t int = int + fromIntegral t * str

\end{haskelllisting}