-- This code was automatically generated by lhs2tex --code, from the file 
-- HSoM/ToMidi.lhs.  (See HSoM/MakeCode.bat.)

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
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]  -- channel 9 is for percussion
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 :: 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
allValid :: UserPatchMap -> [InstrumentName] -> Bool
allValid upm = and . map (lookupB upm)

lookupB :: UserPatchMap -> InstrumentName -> Bool
lookupB upm x = or (map ((== x) . fst) upm)
splitByInst :: Performance ->  [(InstrumentName,Performance)]
splitByInst [] = []
splitByInst pf = (i, pf1) : splitByInst pf2
       where i          = eInst (head pf)
             (pf1, pf2) = partition (\e -> eInst e == i) pf
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
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)
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'

defUpm :: UserPatchMap
defUpm = [(AcousticGrandPiano,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

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
 
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)
 
play :: Performable a => Music a -> IO ()
play = playM . testMidi 
 
playM :: Midi -> IO ()
playM midi = do
  initialize
  (defaultOutput playMidi) midi 
  terminate
  return ()
 
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)
makeMidi :: (Music1, Context Note1, UserPatchMap) -> Midi
makeMidi (m,c,upm) = toMidi (perform defPMap c m) upm
 
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
 
gmUpm :: UserPatchMap
gmUpm = map (\n -> (toEnum n, mod n 16 + 1)) [0..127]
 
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)