{-# LINE 8 "Performance.lhs" #-}
--  This code was automatically generated by lhs2tex --code, from the file 
--  HSoM/Performance.lhs.  (See HSoM/MakeCode.bat.)
{-# LINE 18 "Performance.lhs" #-}
{-#  LANGUAGE FlexibleInstances, TypeSynonymInstances  #-}

module Euterpea.Music.Note.Performance where

import Euterpea.Music.Note.Music
import Euterpea.Music.Note.MoreMusic
{-# LINE 55 "Performance.lhs" #-}
type Performance = [Event]

data Event = Event {  eTime    :: PTime, 
                      eInst    :: InstrumentName, 
                      ePitch   :: AbsPitch,
                      eDur     :: DurT, 
                      eVol     :: Volume, 
                      eParams  :: [Double]}
     deriving (Show,Eq,Ord)
{-# LINE 73 "Performance.lhs" #-}
type PTime     = Rational
type DurT      = Rational
{-# LINE 143 "Performance.lhs" #-}
data Context a = Context {  cTime    :: PTime, 
                            cPlayer  :: Player a, 
                            cInst    :: InstrumentName, 
                            cDur     :: DurT, 
                            cPch     :: AbsPitch,
                            cVol     :: Volume,
                            cKey     :: (PitchClass, Mode) }
     deriving Show
{-# LINE 164 "Performance.lhs" #-}
metro              :: Int -> Dur -> DurT
metro setting dur  = 60 / (fromIntegral setting * dur)
{-# LINE 191 "Performance.lhs" #-}
type PMap a  = PlayerName -> Player a
{-# LINE 339 "Performance.lhs" #-}
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
{-# LINE 351 "Performance.lhs" #-}
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
{-# LINE 474 "Performance.lhs" #-}
type Note1   = (Pitch, [NoteAttribute])
type Music1  = Music Note1
{-# LINE 480 "Performance.lhs" #-}
toMusic1   :: Music Pitch -> Music1
toMusic1   = mMap (\p -> (p, []))

toMusic1'  :: Music (Pitch, Volume) -> Music1
toMusic1'  = mMap (\(p, v) -> (p, [Volume v]))
{-# LINE 507 "Performance.lhs" #-}
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
{-# LINE 535 "Performance.lhs" #-}
defPlayer  :: Player Note1
defPlayer  = MkPlayer 
             {  pName         = "Default",
                playNote      = defPlayNote      defNasHandler,
                interpPhrase  = defInterpPhrase  defPasHandler,
                notatePlayer  = () }
{-# LINE 554 "Performance.lhs" #-}
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
{-# LINE 686 "Performance.lhs" #-}
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 }
{-# LINE 815 "Performance.lhs" #-}
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
{-# LINE 879 "Performance.lhs" #-}
class Performable a where
  perfDur :: PMap Note1 -> Context Note1 -> Music a -> (Performance, DurT)
{-# LINE 888 "Performance.lhs" #-}
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