-- ==========================================================================================

-- Conversion to MEvent datatype



> module Euterpea.IO.MIDI.MEvent where

> import Euterpea.Music



> data MEvent = MEvent {  

>     eTime    :: PTime, -- onset time

>     eInst    :: InstrumentName, -- instrument

>     ePitch   :: AbsPitch, -- pitch number

>     eDur     :: DurT, -- note duration

>     eVol     :: Volume, -- volume

>     eParams  :: [Double]} -- optional other parameters 

>     deriving (Show,Eq,Ord)



> type Performance = [MEvent]



> type PTime = Rational

> type DurT = Rational



> merge :: Performance -> Performance -> Performance

> merge []          es2         =  es2

> merge es1         []          =  es1

> merge a@(e1:es1)  b@(e2:es2)  =  

>   if eTime e1 < eTime e2  then  e1  : merge es1 b

>                           else  e2  : merge a es2



> data MContext = MContext {mcTime    :: PTime, 

>                           mcInst    :: InstrumentName, 

>                           mcDur     :: DurT,

>                           mcVol     :: Volume}

>     deriving Show



> perform :: (ToMusic1 a) => Music a -> Performance

> perform = perform1 . toMusic1



> perform1 :: Music1 -> Performance

> perform1 = fst . perform1Dur



> perform1Dur :: Music1 -> (Performance, DurT)

> perform1Dur = musicToMEvents defCon . applyControls where

>     defCon  = MContext {mcTime = 0, mcInst = AcousticGrandPiano, mcDur = metro 120 qn, mcVol=127}

>     -- timing musicToMEventss

>     metro :: Int -> Dur -> DurT

>     metro setting dur  = 60 / (fromIntegral setting * dur)



> applyControls :: Music1 -> Music1

> applyControls (Modify (Tempo r) m) = scaleDurations r $ applyControls m

> applyControls (Modify (Transpose k) m) = shiftPitches1 k $ applyControls m

> applyControls (Modify x m) = Modify x $ applyControls m

> applyControls (m1 :+: m2) = applyControls m1 :+: applyControls m2

> applyControls (m1 :=: m2) = applyControls m1 :=: applyControls m2

> applyControls x = x



> musicToMEvents :: MContext -> Music1 -> (Performance, DurT)

> musicToMEvents c@MContext{mcTime=t, mcDur=dt} (Prim (Note d p)) = ([noteToMEvent c d p], d*dt)

> musicToMEvents c@MContext{mcTime=t, mcDur=dt}  (Prim (Rest d)) = ([], d*dt)

> musicToMEvents c@MContext{mcTime=t, mcDur=dt} (m1 :+: m2) = 

>     let (evs1, d1) = musicToMEvents c m1

>         (evs2, d2) = musicToMEvents c{mcTime = t+d1} m2

>     in  (evs1 ++ evs2, d1+d2)

> musicToMEvents c@MContext{mcTime=t, mcDur=dt} (m1 :=: m2) = 

>     let (evs1, d1) = musicToMEvents c m1

>         (evs2, d2) = musicToMEvents c m2

>     in  (merge evs1 evs2, max d1 d2)

> musicToMEvents c (Modify (Instrument i) m) = musicToMEvents c{mcInst=i} m

> musicToMEvents c (Modify (Phrase pas) m) = phraseToMEvents c pas m

> musicToMEvents c (Modify (KeySig x y) m) = musicToMEvents c m -- KeySig causes no change

> musicToMEvents c (Modify (Custom x) m) = musicToMEvents c m -- Custom cuases no change

> musicToMEvents c m@(Modify x m') = musicToMEvents c $ applyControls m -- Transpose and Tempo addressed by applyControls



> noteToMEvent :: MContext -> Dur -> (Pitch, [NoteAttribute]) -> MEvent

> noteToMEvent c@(MContext ct ci cdur cvol) d (p, nas) = 

>     let e0 = MEvent{eTime=ct, ePitch=absPitch p, eInst=ci, eDur=d*cdur, eVol=cvol, eParams=[]}

>     in  foldr nasFun e0 nas where

>     nasFun :: NoteAttribute -> MEvent -> MEvent

>     nasFun (Volume v) ev = ev {eVol = v}

>     nasFun (Params pms) ev = ev {eParams = pms}

>     nasFun _ ev = ev



> phraseToMEvents :: MContext -> [PhraseAttribute] -> Music1 -> (Performance, DurT)

> phraseToMEvents c [] m = musicToMEvents c m

> phraseToMEvents c@MContext{mcTime=t, mcInst=i, mcDur=dt} (pa:pas) m =

>  let  pfd@(pf,dur)  =  phraseToMEvents c pas m

>       loud x        =  phraseToMEvents c (Dyn (Loudness x) : pas) m

>       stretch x     =  let  t0 = eTime (head pf);  r  = x/dur

>                             upd (e@MEvent {eTime = t, eDur = d}) = 

>                               let  dt  = t-t0

>                                    t'  = (1+dt*r)*dt + t0

>                                    d'  = (1+(2*dt+d)*r)*d

>                               in e {eTime = t', eDur = d'}

>                        in (map upd pf, (1+x)*dur)

>       inflate x     =  let  t0  = eTime (head pf);  

>                             r   = x/dur

>                             upd (e@MEvent {eTime = t, eVol = v}) = 

>                                 e {eVol =  round ( (1+(t-t0)*r) * 

>                                            fromIntegral v)}

>                        in (map upd pf, dur)

>  in case pa of

>    Dyn (Accent x) ->

>        ( map (\e-> e {eVol = round (x * fromIntegral (eVol e))}) pf, dur)

>    Dyn (StdLoudness l) -> 

>        case l of 

>           PPP  -> loud 40;       PP -> loud 50;   P    -> loud 60

>           MP   -> loud 70;       SF -> loud 80;   MF   -> loud 90

>           NF   -> loud 100;      FF -> loud 110;  FFF  -> loud 120

>    Dyn (Loudness x)     ->  phraseToMEvents c{mcVol = round x} pas m

>    Dyn (Crescendo x)    ->  inflate   x ; Dyn (Diminuendo x)  -> inflate (-x)

>    Tmp (Ritardando x)   ->  stretch   x ; Tmp (Accelerando x) -> stretch (-x)

>    Art (Staccato x)     ->  (map (\e-> e {eDur = x * eDur e}) pf, dur)

>    Art (Legato x)       ->  (map (\e-> e {eDur = x * eDur e}) pf, dur)

>    Art (Slurred x)      -> 

>        let  lastStartTime  = foldr (\e t -> max (eTime e) t) 0 pf

>             setDur e       =   if eTime e < lastStartTime

>                                then e {eDur = x * eDur e}

>                                else e

>        in (map setDur pf, dur) 

>    Art _                -> pfd -- not supported

>    Orn _                -> pfd -- not supported