music-score-1.6: src/Music/Score/Dynamics.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : non-portable (TF,GNTD)
--
-- Provides functions for manipulating dynamics.
--
-------------------------------------------------------------------------------------
module Music.Score.Dynamics (
-- * Dynamics representation
HasDynamic(..),
DynamicT(..),
dynamics,
dynamicVoice,
dynamicSingle,
-- * Dynamic transformations
-- ** Crescendo and diminuendo
Level(..),
cresc,
dim,
-- ** Miscellaneous
resetDynamics,
) where
import Control.Applicative
import Control.Arrow
import Control.Lens hiding (Level)
import Control.Monad
import Data.AffineSpace
import Data.Foldable
import qualified Data.List as List
import Data.Maybe
import Data.Ratio
import Data.Semigroup
import Data.Typeable
import Data.VectorSpace hiding (Sum)
import Music.Score.Combinators
import Music.Score.Convert
import Music.Score.Part
import Music.Score.Score
import Music.Score.Voice
import Music.Time
import Music.Dynamics.Literal
class HasDynamic a where
setBeginCresc :: Bool -> a -> a
setEndCresc :: Bool -> a -> a
setBeginDim :: Bool -> a -> a
setEndDim :: Bool -> a -> a
setLevel :: Double -> a -> a
-- end cresc/dim, level, begin cresc/dim
newtype DynamicT a = DynamicT { getDynamicT :: (((Any, Any), Option (First Double), (Any, Any)), a) }
deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad)
instance HasDynamic (DynamicT a) where
setBeginCresc (Any -> bc) (DynamicT (((ec,ed),l,(_ ,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a)
setEndCresc (Any -> ec) (DynamicT (((_ ,ed),l,(bc,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a)
setBeginDim (Any -> bd) (DynamicT (((ec,ed),l,(bc,_ )),a)) = DynamicT (((ec,ed),l,(bc,bd)),a)
setEndDim (Any -> ed) (DynamicT (((ec,_ ),l,(bc,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a)
setLevel ((Option . Just . First) -> l ) (DynamicT (((ec,ed),_,(bc,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a)
instance HasDynamic b => HasDynamic (a, b) where
setBeginCresc n = fmap (setBeginCresc n)
setEndCresc n = fmap (setEndCresc n)
setBeginDim n = fmap (setBeginDim n)
setEndDim n = fmap (setEndDim n)
setLevel n = fmap (setLevel n)
--------------------------------------------------------------------------------
-- Dynamics
--------------------------------------------------------------------------------
-- |
-- Represents dynamics over a duration.
--
data Level a
= Level a
| Change a a
deriving (Eq, Show)
instance Fractional a => IsDynamics (Level a) where
fromDynamics (DynamicsL (Just a, Nothing)) = Level (realToFrac a)
fromDynamics (DynamicsL (Just a, Just b)) = Change (realToFrac a) (realToFrac b)
fromDynamics x = error $ "fromDynamics: Invalid dynamics literal " ++ show x
-- |
-- Apply a dynamic level over the score.
--
dynamics :: (HasDynamic a, HasPart' a) => Score (Level Double) -> Score a -> Score a
dynamics d a = (duration a `stretchTo` d) `dynamics'` a
dynamicSingle :: HasDynamic a => Score (Level Double) -> Score a -> Score a
dynamicSingle d a = (duration a `stretchTo` d) `dynamicsSingle'` a
-- |
-- Apply a dynamic level over a voice.
--
dynamicVoice :: HasDynamic a => Score (Level Double) -> Voice (Maybe a) -> Voice (Maybe a)
dynamicVoice d = scoreToVoice . dynamicSingle d . removeRests . voiceToScore
dynamics' :: (HasDynamic a, HasPart' a) => Score (Level Double) -> Score a -> Score a
dynamics' ds = mapAllParts (fmap $ dynamicsSingle' ds)
dynamicsSingle' :: HasDynamic a => Score (Level Double) -> Score a -> Score a
dynamicsSingle' ds = applyDynSingle (fmap fromJust $ scoreToVoice ds)
applyDynSingle :: HasDynamic a => Voice (Level Double) -> Score a -> Score a
applyDynSingle ds = applySingle ds3
where
-- ds2 :: Voice (Dyn2 Double)
ds2 = mapValuesVoice dyn2 ds
-- ds3 :: Voice (Score a -> Score a)
ds3 = fmap g ds2
g (ec,ed,l,bc,bd) = id
. (if ec then mapFirstSingle (setEndCresc True) else id)
. (if ed then mapFirstSingle (setEndDim True) else id)
. (if bc then mapFirstSingle (setBeginCresc True) else id)
. (if bd then mapFirstSingle (setBeginDim True) else id)
. maybe id (mapFirstSingle . setLevel) l
mapFirstSingle f = mapPhraseSingle f id id
-- end cresc, end dim, level, begin cresc, begin dim
type LevelDiff a = (Bool, Bool, Maybe a, Bool, Bool)
dyn2 :: Ord a => [Level a] -> [LevelDiff a]
dyn2 = snd . List.mapAccumL g (Nothing, False, False) -- level, cresc, dim
where
g (Nothing, False, False) (Level b) = ((Just b, False, False), (False, False, Just b, False, False))
g (Nothing, False, False) (Change b c) = ((Just b, b < c, b > c), (False, False, Just b, b < c, b > c))
g (Just a , cr, dm) (Level b)
| a == b = ((Just b, False, False), (cr, dm, Nothing, False, False))
| a /= b = ((Just b, False, False), (cr, dm, Just b, False, False))
g (Just a , cr, dm) (Change b c)
| a == b = ((Just b, b < c, b > c), (cr, dm, Nothing, b < c, b > c))
| a /= b = ((Just b, b < c, b > c), (cr, dm, Just b, b < c, b > c))
mapValuesVoice :: ([a] -> [b]) -> Voice a -> Voice b
mapValuesVoice f = (^. voice) . uncurry zip . second f . unzip . (^. from voice)
cresc :: IsDynamics a => Double -> Double -> a
cresc a b = fromDynamics $ DynamicsL (Just a, Just b)
dim :: IsDynamics a => Double -> Double -> a
dim a b = fromDynamics $ DynamicsL (Just a, Just b)
resetDynamics :: HasDynamic c => c -> c
resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False