> module Euterpea.IO.MIDI.MEvent where
> import Euterpea.Music
> data MEvent = MEvent {
> eTime :: PTime,
> eInst :: InstrumentName,
> ePitch :: AbsPitch,
> eDur :: DurT,
> eVol :: Volume,
> eParams :: [Double]}
> 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}
>
> 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
> musicToMEvents c (Modify (Custom x) m) = musicToMEvents c m
> musicToMEvents c m@(Modify x m') = musicToMEvents c $ applyControls m
> 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
> Orn _ -> pfd