content: > {-#  LANGUAGE FlexibleInstances, TypeSynonymInstances  #-}
  > module HSoM.Performance where
  > import Euterpea
  
  From Euterpea we have:
  
  type Performance = [MEvent]
  
  data MEvent = MEvent {  eTime    :: PTime, 
                        eInst    :: InstrumentName, 
                        ePitch   :: AbsPitch,
                        eDur     :: DurT, 
                        eVol     :: Volume, 
                        eParams  :: [Double]}
       deriving (Show,Eq,Ord)
  
  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 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
  
  > hsomPerform :: PMap a -> Context a -> Music a -> Performance
  > hsomPerform 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  (Phrase pas)    m  -> interpPhrase pl pm c pas       m
  >      Modify  (Custom s)     m  -> 
  >          if take 7 s == "Player " then perf pm (c {cPlayer = pm $ drop 7 s})  m
  >          else perf pm c m
  
  > type PlayerName = String
  
  > data Player a = MkPlayer {  pName         :: PlayerName, 
  >                             playNote      :: NoteFun a,
  >                             interpPhrase  :: PhraseFun a}
  
  > type NoteFun a    =  Context a -> Dur -> a -> Performance
  > type PhraseFun a  =  PMap a -> Context a -> [PhraseAttribute]
  >                      -> Music a -> (Performance, DurT)
  
  > instance Show a => Show (Player a) where
  >    show p = pName p
  
  > defPlayer  :: Player Note1
  > defPlayer  = MkPlayer 
  >              {  pName         = "Default",
  >                 playNote      = defPlayNote      defNasHandler,
  >                 interpPhrase  = defInterpPhrase  defPasHandler}
  
  > defPlayNote ::  (Context (Pitch,[a]) -> a -> MEvent-> MEvent)
  >                 -> NoteFun (Pitch, [a])
  > defPlayNote nasHandler 
  >   c@(Context cTime cPlayer cInst cDur cPch cVol cKey) d (p,nas) =
  >     let initEv = MEvent {  eTime    = cTime,     eInst  = cInst,
  >                           eDur     = d * cDur,  eVol = cVol,
  >                           ePitch   = absPitch p + cPch,
  >                           eParams  = [] }
  >     in [ foldr (nasHandler c) initEv nas ]
  
  > defNasHandler :: Context a -> NoteAttribute -> MEvent -> MEvent
  > 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 "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}
  
  > 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@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)     ->  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
  
  > playA myPMap myCon = playC defParams{perfAlg=hsomPerform myPMap myCon}
  > writeMidiA fn myPMap myCon = exportMidiFile fn . toMidi . hsomPerform myPMap myCon
  