\subsection{Conversion functions with default settings}
\seclabel{fancy-performance}

{\small
\begin{haskelllisting}

> module Haskore.Performance.Fancy where

> import qualified Haskore.Music       as Music
> import qualified Haskore.Performance as Performance
> import qualified Haskore.Performance.Context as Context
> import qualified Haskore.Performance.Player  as Player
> import qualified Haskore.Performance.Default as DefltPf

> import Haskore.Performance (eventDur, )

> -- import qualified Data.EventList.Relative.TimeBody  as TimeList
> -- import qualified Data.EventList.Relative.TimeTime  as TimeListPad
> import qualified Data.EventList.Relative.MixedTime as TimeListPad
> import qualified Data.EventList.Relative.BodyTime  as BodyTimeList

> import Control.Monad.Trans.State  (state, evalState, )
> import Control.Monad.Trans.Reader (local, )
>
> import qualified Numeric.NonNegative.Class   as NonNeg
> import qualified Numeric.NonNegative.Wrapper as NonNegW

> import Prelude hiding (map)

\end{haskelllisting}
}

\begin{figure}
{\small
\begin{haskelllisting}

> player :: (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    Player.T time dyn note
> player = map "Fancy"
>
> -- a PMap that makes everything into a fancyPlayer
> map ::
>    (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    String -> Player.T time dyn note
> map pname =
>    Performance.PlayerCons {
>       Performance.name            = pname,
>       Performance.playNote        = DefltPf.playNote,
>       Performance.interpretPhrase = fancyInterpretPhrase,
>       Performance.notatePlayer    = DefltPf.notatePlayer ()
>    }
>
> processPerformance :: (Num time) =>
>    (time ->
>       (time -> time -> time,
>        time -> Performance.Event time dyn note -> Performance.Event time dyn note,
>        time)) ->
>    (Performance.PaddedWithRests time dyn note, time) ->
>    (Performance.PaddedWithRests time dyn note, time)
> processPerformance f (pf, dur) =
>    let (fTime, fEvent, newDur) = f dur
>        procPf =
>           flip evalState 0 .
>           BodyTimeList.mapM
>              (\dt -> state $ \t -> (fTime  t dt, t+dt))
>              (\ev -> state $ \t -> (fmap (fEvent t) ev, t))
>    in  (TimeListPad.mapTimeTail procPf pf, newDur)
>
> fancyInterpretDynamic ::
>    (Fractional time, Real time, Fractional dyn) =>
>    Music.Dynamic -> Performance.Monad time dyn note -> Performance.Monad time dyn note
> fancyInterpretDynamic dyn =
>  let loud x = local (Performance.updateDynamics (fromRational x *))
>      inflate add x dur =
>         let r = fromRational x / realToFrac dur
>         in  (const id,
>              \t -> Player.changeVelocity (add (realToFrac t * r)),
>              dur)
>  in  case dyn of
>         Music.Accent x       -> Player.accent x
>         Music.Loudness x     -> loud x
>         Music.Crescendo x    -> fmap (processPerformance (inflate (+)      x))
>         Music.Diminuendo x   -> fmap (processPerformance (inflate subtract x))
> --        Music.Crescendo x    -> fmap (processPerformance (inflate x))
> --        Music.Diminuendo x   -> fmap (processPerformance (inflate (-x)))
>
> fancyInterpretTempo :: (Fractional time, Real time) =>
>    Music.Tempo -> Performance.Monad time dyn note -> Performance.Monad time dyn note
> fancyInterpretTempo tmp =
>  let stretch add x dur =
>         let x' = fromRational x
>             r = x' / dur
>             fac t dt = add 1 (r * (2*t + dt))
>         in  (\t dt -> dt * fac t dt,
>              \t (e@Performance.Event {eventDur = d}) ->
>                 e{eventDur = d * fac t d },
>              dur * add 1 x')
>  in  case tmp of
>         Music.Ritardando  x  -> fmap (processPerformance (stretch (+) x))
>         Music.Accelerando x  -> fmap (processPerformance (stretch (-) x))
> --        Music.Accelerando x  -> fmap (processPerformance (stretch (\a b -> if a>=b then a-b else 0) x))

> fancyInterpretArticulation :: (NonNeg.C time, Fractional time) =>
>    Music.Articulation -> Performance.Monad time dyn note -> Performance.Monad time dyn note
> fancyInterpretArticulation art =
>    case art of
>       Music.Staccato x -> Player.staccatoAbs x
>       Music.Legato   x -> Player.legatoAbs   x
>       Music.Slurred  x -> Player.slurredAbs  x
>       _ -> id
>         {- Remaining articulations:
>              Tenuto | Marcato | Pedal | Fermata  | FermataDown
>            | Breath | DownBow | UpBow | Harmonic | Pizzicato
>            | LeftPizz | BartokPizz | Swell | Wedge | Thumb | Stopped -}

> fancyInterpretOrnament :: (Fractional time, Real time) =>
>    Music.Ornament -> Performance.Monad time dyn note -> Performance.Monad time dyn note
> fancyInterpretOrnament _orn = id
>    {- Remaining ornamenations:
>         Trill | Mordent | InvMordent | DoubleMordent | Turn
>       | TrilledTurn | ShortTrill | Arpeggio | ArpeggioUp
>       | ArpeggioDown | Instruction String | Head NoteHead -}
>     {- Design Problem: To do these right we need to keep the KEY SIGNATURE
>        around so that we can determine, for example, what the trill note is.
>        Alternatively, provide an argument to Trill to carry this info. -}

> fancyInterpretPhrase ::
>    (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    Performance.PhraseFun time dyn note
> fancyInterpretPhrase pa =
>    case pa of
>       Music.Dyn dyn -> fancyInterpretDynamic dyn
>       Music.Tmp tmp -> fancyInterpretTempo tmp
>       Music.Art art -> fancyInterpretArticulation art
>       Music.Orn orn -> fancyInterpretOrnament orn

> context ::
>    (NonNeg.C time, Fractional time, Real time, Fractional dyn) =>
>    Context.T time dyn note
> context = DefltPf.context {Performance.contextPlayer = player}

\end{haskelllisting}
}
\caption{Definition of Player \function{Fancy.player}.}
\figlabel{fancy-Player}
\end{figure}


{\small
\begin{haskelllisting}

> fromMusic ::
>    (Ord note, NonNeg.C time, RealFrac time, Fractional dyn, Ord dyn) =>
>    Music.T note -> Performance.T time dyn note
> fromMusic =
>    Performance.fromMusic map context
>
> fromMusicModifyContext ::
>    (Ord note, NonNeg.C time, RealFrac time, Fractional dyn, Ord dyn) =>
>    (Context.T time dyn note -> Context.T time dyn note) ->
>    Music.T note ->
>    Performance.T time dyn note
> fromMusicModifyContext update =
>    Performance.fromMusic
>       map
>       (update context)
>
> floatFromMusic :: (Ord note) =>
>    Music.T note -> Performance.T NonNegW.Float Float note
> floatFromMusic = fromMusic
>
> paddedFromMusic  ::
>    (Ord note, NonNeg.C time, RealFrac time, Fractional dyn, Ord dyn) =>
>    Music.T note -> Performance.Padded time dyn note
> paddedFromMusic =
>    Performance.paddedFromMusic map context
>
> doublePaddedFromMusic  ::
>    (Ord note) =>
>    Music.T note -> Performance.Padded NonNegW.Double Double note
> doublePaddedFromMusic =
>    Performance.paddedFromMusic map context
>
> paddedFromMusicModifyContext ::
>    (Ord note, NonNeg.C time, RealFrac time, Fractional dyn, Ord dyn) =>
>    (Context.T time dyn note -> Context.T time dyn note) ->
>    Music.T note ->
>    Performance.T time dyn note
> paddedFromMusicModifyContext update =
>    Performance.fromMusic
>       map
>       (update context)

\end{haskelllisting}
}



% fromRhythmicMusic  :: (Ord drum, Ord instr, RealFrac time) =>
%    RhyMusic.T drum instr -> Performance.T time (RhyMusic.Note drum instr)
% fromRhythmicMusic =
%    Performance.fromMusic map context
%
% floatFromRhythmicMusic :: (Ord drum, Ord instr) =>
%    RhyMusic.T drum instr -> Performance.T Float (RhyMusic.Note drum instr)
% floatFromRhythmicMusic = fromRhythmicMusic
%
% stateFromRhythmicMusic ::
%    (Ord drum, Ord instr, Fractional time, Real time) =>
%    (RhyMusic.T drum instr) ->
%      ((Performance.T time (RhyMusic.Note drum instr), time),
%       Context.T time (RhyMusic.Note drum instr))
% stateFromRhythmicMusic m =
%    runState (Performance.monadFromMusic map m) context

% monadFromMusic ::
%    (Ord note, RealFrac time) =>
%    Music.T note -> 
%      ((Performance.T time dyn note, time),
%       Context.T time dyn note)
% monadFromMusic m =
%    runReader (Performance.monadFromMusic map m) context