-- This code was automatically generated by lhs2tex --code, from the file -- HSoM/Performance.lhs. (See HSoM/MakeCode.bat.) {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Euterpea.Music.Note.Performance where import Euterpea.Music.Note.Music import Euterpea.Music.Note.MoreMusic type Performance = [Event] data Event = Event { eTime :: PTime, eInst :: InstrumentName, ePitch :: AbsPitch, eDur :: DurT, eVol :: Volume, eParams :: [Double]} deriving (Show,Eq,Ord) type PTime = Rational type DurT = Rational data Context a = Context { cTime :: PTime, cPlayer :: Player a, cInst :: InstrumentName, cDur :: DurT, cPch :: AbsPitch, cVol :: Volume, cKey :: (PitchClass, Mode) } deriving Show metro :: Int -> Dur -> DurT metro setting dur = 60 / (fromIntegral setting * dur) type PMap a = PlayerName -> Player a 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 perform :: PMap a -> Context a -> Music a -> Performance perform pm c m = fst (perf pm c m) perf :: PMap a -> Context a -> Music a -> (Performance, DurT) perf pm c@Context {cTime = t, cPlayer = pl, cDur = dt, cPch = k} m = case m of Prim (Note d p) -> (playNote pl c d p, d*dt) Prim (Rest d) -> ([], d*dt) m1 :+: m2 -> let (pf1,d1) = perf pm c m1 (pf2,d2) = perf pm (c {cTime = t+d1}) m2 in (pf1++pf2, d1+d2) m1 :=: m2 -> let (pf1,d1) = perf pm c m1 (pf2,d2) = perf pm c m2 in (merge pf1 pf2, max d1 d2) Modify (Tempo r) m -> perf pm (c {cDur = dt / r}) m Modify (Transpose p) m -> perf pm (c {cPch = k + p}) m Modify (Instrument i) m -> perf pm (c {cInst = i}) m Modify (KeySig pc mo) m -> perf pm (c {cKey = (pc,mo)}) m Modify (Player pn) m -> perf pm (c {cPlayer = pm pn}) m Modify (Phrase pas) m -> interpPhrase pl pm c pas m type Note1 = (Pitch, [NoteAttribute]) type Music1 = Music Note1 toMusic1 :: Music Pitch -> Music1 toMusic1 = mMap (\p -> (p, [])) toMusic1' :: Music (Pitch, Volume) -> Music1 toMusic1' = mMap (\(p, v) -> (p, [Volume v])) data Player a = MkPlayer { pName :: PlayerName, playNote :: NoteFun a, interpPhrase :: PhraseFun a, notatePlayer :: NotateFun a } type NoteFun a = Context a -> Dur -> a -> Performance type PhraseFun a = PMap a -> Context a -> [PhraseAttribute] -> Music a -> (Performance, DurT) type NotateFun a = () instance Show a => Show (Player a) where show p = "Player " ++ pName p defPlayer :: Player Note1 defPlayer = MkPlayer { pName = "Default", playNote = defPlayNote defNasHandler, interpPhrase = defInterpPhrase defPasHandler, notatePlayer = () } defPlayNote :: (Context (Pitch,[a]) -> a -> Event-> Event) -> NoteFun (Pitch, [a]) defPlayNote nasHandler c@(Context cTime cPlayer cInst cDur cPch cVol cKey) d (p,nas) = let initEv = Event { eTime = cTime, eInst = cInst, eDur = d * cDur, eVol = cVol, ePitch = absPitch p + cPch, eParams = [] } in [ foldr (nasHandler c) initEv nas ] defNasHandler :: Context a -> NoteAttribute -> Event -> Event defNasHandler c (Volume v) ev = ev {eVol = v} defNasHandler c (Params pms) ev = ev {eParams = pms} defNasHandler _ _ ev = ev defInterpPhrase :: (PhraseAttribute -> Performance -> Performance) -> ( PMap a -> Context a -> [PhraseAttribute] -> --PhraseFun Music a -> (Performance, DurT) ) defInterpPhrase pasHandler pm context pas m = let (pf,dur) = perf pm context m in (foldr pasHandler pf pas, dur) defPasHandler :: PhraseAttribute -> Performance -> Performance defPasHandler (Dyn (Accent x)) = map (\e -> e {eVol = round (x * fromIntegral (eVol e))}) defPasHandler (Art (Staccato x)) = map (\e -> e {eDur = x * eDur e}) defPasHandler (Art (Legato x)) = map (\e -> e {eDur = x * eDur e}) defPasHandler _ = id defPMap :: PMap Note1 defPMap "Fancy" = fancyPlayer defPMap "Default" = defPlayer defPMap n = defPlayer { pName = n } defCon :: Context Note1 defCon = Context { cTime = 0, cPlayer = fancyPlayer, cInst = AcousticGrandPiano, cDur = metro 120 qn, cPch = 0, cKey = (C, Major), cVol = 127 } fancyPlayer :: Player (Pitch, [NoteAttribute]) fancyPlayer = MkPlayer { pName = "Fancy", playNote = defPlayNote defNasHandler, interpPhrase = fancyInterpPhrase, notatePlayer = () } fancyInterpPhrase :: PhraseFun a fancyInterpPhrase pm c [] m = perf pm c m fancyInterpPhrase pm c@Context { cTime = t, cPlayer = pl, cInst = i, cDur = dt, cPch = k, cVol = v} (pa:pas) m = let pfd@(pf,dur) = fancyInterpPhrase pm c pas m loud x = fancyInterpPhrase pm c (Dyn (Loudness x) : pas) m stretch x = let t0 = eTime (head pf); r = x/dur upd (e@Event {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@Event {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) -> fancyInterpPhrase pm c{cVol = 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 class Performable a where perfDur :: PMap Note1 -> Context Note1 -> Music a -> (Performance, DurT) instance Performable Note1 where perfDur pm c m = perf pm c m instance Performable Pitch where perfDur pm c = perfDur pm c . toMusic1 instance Performable (Pitch, Volume) where perfDur pm c = perfDur pm c . toMusic1' defToPerf :: Performable a => Music a -> Performance defToPerf = fst . perfDur defPMap defCon toPerf :: Performable a => PMap Note1 -> Context Note1 -> Music a -> Performance toPerf pm con = fst . perfDur pm con