{-# LINE 8 "ToMidi.lhs" #-}
--  This code was automatically generated by lhs2tex --code, from the file 
--  HSoM/ToMidi.lhs.  (See HSoM/MakeCode.bat.)
{-# LINE 18 "ToMidi.lhs" #-}
module Euterpea.IO.MIDI.ToMidi(toMidi, UserPatchMap, defST,
  defUpm, testMidi, testMidiA,
  test, testA, writeMidi, writeMidiA,
  play, playM, playA,
  makeMidi, mToMF, gmUpm, gmTest)  where

import Euterpea.Music.Note.Music
import Euterpea.Music.Note.MoreMusic
import Euterpea.Music.Note.Performance
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
{-# LINE 136 "ToMidi.lhs" #-}
type ProgNum     = Int
{-# LINE 170 "ToMidi.lhs" #-}
type UserPatchMap = [(InstrumentName, Channel)]
{-# LINE 197 "ToMidi.lhs" #-}
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]  --  channel 9 is for percussion
{-# LINE 219 "ToMidi.lhs" #-}
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)
{-# LINE 371 "ToMidi.lhs" #-}
toMidi :: Performance -> UserPatchMap -> Midi
toMidi pf upm =
  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 . performToMEvs rightMap) split)

division = 96 :: Int
{-# LINE 388 "ToMidi.lhs" #-}
allValid :: UserPatchMap -> [InstrumentName] -> Bool
allValid upm = and . map (lookupB upm)

lookupB :: UserPatchMap -> InstrumentName -> Bool
lookupB upm x = or (map ((== x) . fst) upm)
{-# LINE 401 "ToMidi.lhs" #-}
splitByInst :: Performance ->  [(InstrumentName,Performance)]
splitByInst [] = []
splitByInst pf = (i, pf1) : splitByInst pf2
       where i          = eInst (head pf)
             (pf1, pf2) = partition (\e -> eInst e == i) pf
{-# LINE 430 "ToMidi.lhs" #-}
type MEvent = (Ticks, Message)

defST = 500000

performToMEvs ::  UserPatchMap
                  -> (InstrumentName, Performance) 
                  -> [MEvent]
performToMEvs 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
{-# LINE 453 "ToMidi.lhs" #-}
mkMEvents :: Channel -> Event -> (MEvent,MEvent)
mkMEvents  mChan (Event {  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)
{-# LINE 477 "ToMidi.lhs" #-}
insertMEvent :: MEvent -> [MEvent] -> [MEvent]
insertMEvent mev1  []         = [mev1]
insertMEvent mev1@(t1,_) mevs@(mev2@(t2,_):mevs') = 
      if t1 <= t2 then mev1 : mevs
                  else mev2 : insertMEvent mev1 mevs'
{-# LINE 558 "ToMidi.lhs" #-}
defUpm :: UserPatchMap
defUpm = [(AcousticGrandPiano,0),
          (Marimba,1),
          (Vibraphone,2),
          (AcousticBass,3),
          (Flute,4),
          (TenorSax,5),
          (AcousticGuitarSteel,6),
          (Viola,7),
          (StringEnsemble1,8),
          (AcousticGrandPiano,9)]
            --  the GM name for drums is unimportant, only channel 9
{-# LINE 579 "ToMidi.lhs" #-}
testMidi :: Performable a => Music a -> Midi
testMidi m = toMidi (defToPerf m) defUpm

testMidiA :: Performable a => PMap Note1 -> Context Note1 -> Music a -> Midi
testMidiA pm con m = toMidi (toPerf pm con m) defUpm
{-# LINE 590 "ToMidi.lhs" #-}
test :: Performable a => Music a -> IO ()
test     m = exportMidiFile "test.mid" (testMidi m)

testA :: Performable a => PMap Note1 -> Context Note1 -> Music a -> IO ()
testA pm con m = exportMidiFile "test.mid" (testMidiA pm con m)

writeMidi :: Performable a => FilePath -> Music a -> IO ()
writeMidi fn = exportMidiFile fn . testMidi

writeMidiA :: Performable a => 
              FilePath -> PMap Note1 -> Context Note1 -> Music a -> IO ()
writeMidiA fn pm con m = exportMidiFile fn (testMidiA pm con m)
{-# LINE 609 "ToMidi.lhs" #-}
play :: Performable a => Music a -> IO ()
play = playM . testMidi 
{-# LINE 617 "ToMidi.lhs" #-}
playM :: Midi -> IO ()
playM midi = do
  initialize
  (defaultOutput playMidi) midi 
  terminate
  return ()
{-# LINE 629 "ToMidi.lhs" #-}
playA :: Performable a => PMap Note1 -> Context Note1
         -> Music a -> IO ()
playA pm con m = 
  let pf = fst $ perfDur pm con m
  in playM (toMidi pf defUpm)
{-# LINE 641 "ToMidi.lhs" #-}
makeMidi :: (Music1, Context Note1, UserPatchMap) -> Midi
makeMidi (m,c,upm) = toMidi (perform defPMap c m) upm
{-# LINE 649 "ToMidi.lhs" #-}
mToMF :: PMap a -> Context a -> UserPatchMap -> FilePath -> Music a -> IO ()
mToMF pmap c upm fn m =
      let pf = perform pmap c m
          mf = toMidi pf upm
      in exportMidiFile fn mf
{-# LINE 666 "ToMidi.lhs" #-}
gmUpm :: UserPatchMap
gmUpm = map (\n -> (toEnum n, mod n 16 + 1)) [0..127]
{-# LINE 675 "ToMidi.lhs" #-}
gmTest :: Int -> IO ()
gmTest i =  let gMM = take 8 (drop (i*8) [0..127])
                mu  = line (map simple gMM)
                simple n = Modify (Instrument (toEnum n)) cMajArp
            in  mToMF defPMap defCon gmUpm "test.mid" mu

cMaj = [ n 4 qn | n <- [c,e,g] ]  --  octave 4, quarter notes
cMajArp = toMusic1 (line cMaj)