\subsubsection{Instrument map}
\seclabel{user-patch-map}
\begin{haskelllisting}
> module Haskore.Interface.MIDI.InstrumentMap where
> import Haskore.Music.Standard(Instr)
> import qualified Sound.MIDI.Message.Channel as ChannelMsg
> import qualified Sound.MIDI.General as GeneralMidi
> import qualified Haskore.General.Map as Map
> import qualified Data.List as List
> import Data.Tuple.HT (swap, )
> import Data.Char (toLower, )
> import Data.Maybe (fromMaybe, )
\end{haskelllisting}
A \type{InstrumentMap.ChannelProgramTable} is a user-supplied table for mapping instrument
names (\type{Instr}s) to Midi channels and General Midi patch names.
The patch names are by default General Midi names, although the user
can also provide a \type{PatchMap} for mapping Patch Names to
unconventional Midi Program Change numbers.
\begin{haskelllisting}
> type ChannelTable instr =
> [(instr, ChannelMsg.Channel)]
> type ChannelProgramTable instr =
> [(instr, (ChannelMsg.Channel, ChannelMsg.Program))]
> type ChannelProgramPitchTable instr =
> [(instr, (ChannelMsg.Channel, ChannelMsg.Program, ChannelMsg.Pitch))]
>
> type ToChannel instr =
> instr -> ChannelMsg.Channel
> type ToChannelProgram instr =
> instr -> (ChannelMsg.Channel, ChannelMsg.Program)
> type ToChannelProgramPitch instr =
> instr -> (ChannelMsg.Channel, ChannelMsg.Program, ChannelMsg.Pitch)
>
> type FromChannel instr =
> ChannelMsg.Channel -> Maybe instr
> type FromChannelProgram instr =
> (ChannelMsg.Channel, ChannelMsg.Program) -> Maybe instr
> type FromChannelProgramPitch instr =
> (ChannelMsg.Channel, ChannelMsg.Program, ChannelMsg.Pitch) -> Maybe instr
\end{haskelllisting}
The \function{allValid} is used to test whether or not every instrument
in a list is found in a \type{InstrumentMap.ChannelProgramTable}.
\begin{haskelllisting}
> repair :: [Instr] -> ChannelProgramTable Instr -> ChannelProgramTable Instr
> repair insts pMap =
> if allValid pMap insts
> then pMap
> else tableFromInstruments insts
>
> allValid :: ChannelProgramTable Instr -> [Instr] -> Bool
> allValid upm = all (\x -> any (partialMatch x . fst) upm)
\end{haskelllisting}
If a Haskore user only uses General Midi instrument names as
\type{Instr}s, we can define a function that automatically creates a
\type{InstrumentMap.ChannelProgramTable} from these names. Note that, since there are only 15
Midi channels plus percussion, we can handle only 15 instruments.
Perhaps in the future a function could be written to test whether or
not two tracks can be combined with a Program Change (tracks can be
combined if they don't overlap).
\begin{haskelllisting}
> tableFromInstruments :: [Instr] -> ChannelProgramTable Instr
> tableFromInstruments instrs =
> zip instrs (assignChannels GeneralMidi.instrumentChannels instrs)
>
> assignChannels :: [ChannelMsg.Channel] -> [Instr] ->
> [(ChannelMsg.Channel, ChannelMsg.Program)]
> assignChannels _ [] = []
> assignChannels [] _ =
> error "Too many instruments; not enough MIDI channels."
> assignChannels chans@(c:cs) (i:is) =
> let percList = ["percussion", "perc", "drum", "drums"]
> in if map toLower i `elem` percList
> then (GeneralMidi.drumChannel, GeneralMidi.drumProgram)
> : assignChannels chans is
> else (c, fromMaybe
> (error ("unknown instrument <<" ++ i ++ ">>"))
> (GeneralMidi.instrumentNameToProgram i))
> : assignChannels cs is
> fromInstruments :: Ord instr => [instr] -> ToChannel instr
> fromInstruments instrs =
> let fm = Map.fromList (zip instrs GeneralMidi.instrumentChannels)
> in Map.findWithDefault fm (error "More instruments than channels")
\end{haskelllisting}
The following functions lookup \type{Instr}s in \type{InstrumentMap.ChannelProgramTable}s to
recover channel and program change numbers.
Note that the function that does string matching ignores case,
and that instrument name and search pattern match
if one is a prefix of the other one.
For example, \code{"chur"} matches \code{"Church Organ"}. Note also
that the {\em first} match succeeds, so using a substring should be
done with care to be sure that the correct instrument is selected.
\begin{haskelllisting}
> partialMatch :: Instr -> Instr -> Bool
> partialMatch "piano" "Acoustic Grand Piano" = True
> partialMatch s1 s2 =
> let s1' = map toLower s1
> s2' = map toLower s2
> in all (uncurry (==)) (zip s1' s2')
>
> lookupIName :: [(Instr, a)] -> Instr -> a
> lookupIName ys x =
> maybe (error ("InstrumentMap.lookupIName: Instrument " ++ x ++ " unknown"))
> snd (List.find (partialMatch x . fst) ys)
>
> lookup :: Eq instr => [(instr, a)] -> instr -> a
> lookup ys x =
> fromMaybe (error ("InstrumentMap.lookup: Instrument unknown"))
> (List.lookup x ys)
\end{haskelllisting}
\begin{haskelllisting}
> reverseLookupMaybe :: Eq a => [(instr, a)] -> a -> Maybe instr
> reverseLookupMaybe ys x =
> List.lookup x (map swap ys)
> reverseLookup :: Eq a => [(instr, a)] -> a -> instr
> reverseLookup ys x =
> let instr = reverseLookupMaybe ys x
> err = error "InstrumentMap.reverseLookup: channel+program not found"
> in fromMaybe err instr
\end{haskelllisting}
A default \type{InstrumentMap.ChannelProgramTable}.
Note: the PC sound card I'm using is limited to 9 instruments.
\begin{haskelllisting}
> defltTable :: [(Instr, ChannelMsg.Channel, GeneralMidi.Instrument)]
> defltTable =
> map (\(instr,chan,gmInstr) -> (instr, ChannelMsg.toChannel chan, gmInstr))
> [("piano", 1, GeneralMidi.AcousticGrandPiano),
> ("vibes", 2, GeneralMidi.Vibraphone),
> ("bass", 3, GeneralMidi.AcousticBass),
> ("flute", 4, GeneralMidi.Flute),
> ("sax", 5, GeneralMidi.TenorSax),
> ("guitar", 6, GeneralMidi.AcousticGuitarSteel),
> ("violin", 7, GeneralMidi.Viola),
> ("violins", 8, GeneralMidi.StringEnsemble1),
> ("drums", 9, GeneralMidi.AcousticGrandPiano)]
>
> deflt :: ChannelProgramTable Instr
> deflt =
> map (\(iName, chan, gmName) ->
> (iName, (chan, GeneralMidi.instrumentToProgram gmName))) defltTable
> defltGM :: ChannelProgramTable GeneralMidi.Instrument
> defltGM =
> map (\(_, chan, gmName) ->
> (gmName, (chan, GeneralMidi.instrumentToProgram gmName))) defltTable
> defltCMap :: [(GeneralMidi.Instrument, ChannelMsg.Channel)]
> defltCMap =
> map (\(_, chan, gmName) -> (gmName, chan)) defltTable
\end{haskelllisting}