> {-# LINE 8 "ToMidi.lhs" #-}
> module Euterpea.IO.MIDI.ToMidi where
> import Euterpea.Music
> import Euterpea.IO.MIDI.MEvent
> import Euterpea.IO.MIDI.GeneralMidi
> import Euterpea.IO.MIDI.MidiIO
> import Euterpea.IO.MIDI.ExportMidiFile
> import Sound.PortMidi
> import Data.List(partition)
> import Data.Char(toLower,toUpper)
> import Codec.Midi
> type ProgNum = Int
> type UserPatchMap = [(InstrumentName, Channel)]
> makeGMMap :: [InstrumentName] -> UserPatchMap
> makeGMMap ins = mkGMMap 0 ins
> where mkGMMap _ [] = []
> mkGMMap n _ | n>=15 =
> error "makeGMMap: too many instruments."
> mkGMMap n (Percussion : ins) =
> (Percussion, 9) : mkGMMap n ins
> mkGMMap n (i : ins) =
> (i, chanList !! n) : mkGMMap (n+1) ins
> chanList = [0..8] ++ [10..15]
> upmLookup :: UserPatchMap -> InstrumentName
> -> (Channel, ProgNum)
> upmLookup upm iName = (chan, toGM iName)
> where chan = maybe (error ( "instrument " ++ show iName ++
> " not in patch map") )
> id (lookup iName upm)
> toMidi :: [MEvent] -> Midi
> toMidi = toMidiUPM defUpm
> toMidiUPM :: UserPatchMap -> [MEvent] -> Midi
> toMidiUPM upm pf =
> let split = splitByInst pf
> insts = map fst split
> rightMap = if (allValid upm insts) then upm
> else (makeGMMap insts)
> in Midi (if length split == 1 then SingleTrack
> else MultiTrack)
> (TicksPerBeat division)
> (map (fromAbsTime . mevsToMessages rightMap) split)
> division = 96 :: Int
> allValid :: UserPatchMap -> [InstrumentName] -> Bool
> allValid upm = and . map (lookupB upm)
> lookupB :: UserPatchMap -> InstrumentName -> Bool
> lookupB upm x = or (map ((== x) . fst) upm)
> splitByInst :: [MEvent] -> [(InstrumentName, [MEvent])]
> splitByInst [] = []
> splitByInst pf = (i, pf1) : splitByInst pf2
> where i = eInst (head pf)
> (pf1, pf2) = partition (\e -> eInst e == i) pf
> type MidiEvent = (Ticks, Message)
> defST = 500000
> mevsToMessages :: UserPatchMap
> -> (InstrumentName, [MEvent])
> -> [MidiEvent]
> mevsToMessages upm (inm, pf) =
> let (chan,progNum) = upmLookup upm inm
> setupInst = (0, ProgramChange chan progNum)
> setTempo = (0, TempoChange defST)
> loop [] = []
> loop (e:es) = let (mev1,mev2) = mkMEvents chan e
> in mev1 : insertMEvent mev2 (loop es)
> in setupInst : setTempo : loop pf
> mkMEvents :: Channel -> MEvent -> (MidiEvent,MidiEvent)
> mkMEvents mChan (MEvent { eTime = t, ePitch = p,
> eDur = d, eVol = v})
> = ( (toDelta t, NoteOn mChan p v'),
> (toDelta (t+d), NoteOff mChan p v') )
> where v' = max 0 (min 127 (fromIntegral v))
> toDelta t = round (t * 2.0 * fromIntegral division)
> insertMEvent :: MidiEvent -> [MidiEvent] -> [MidiEvent]
> insertMEvent mev1 [] = [mev1]
> insertMEvent mev1@(t1,_) mevs@(mev2@(t2,_):mevs') =
> if t1 <= t2 then mev1 : mevs
> else mev2 : insertMEvent mev1 mevs'
> defUpm :: UserPatchMap
> defUpm = [(AcousticGrandPiano,0),
> (Marimba,1),
> (Vibraphone,2),
> (AcousticBass,3),
> (Flute,4),
> (TenorSax,5),
> (AcousticGuitarSteel,6),
> (Viola,7),
> (StringEnsemble1,8),
> (AcousticGrandPiano,9)]
>
> writeMidi :: ToMusic1 a => FilePath -> Music a -> IO ()
> writeMidi fn m = exportMidiFile fn $ toMidi $ perform m
play :: ToMusic1 a => Music a -> IO ()
play = playM . toMidi . perform
playM :: Midi -> IO ()
playM midi = do
initialize
(defaultOutput playMidi) midi
terminate
return ()