module Music.Score.Dynamics (
HasDynamic(..),
DynamicT(..),
dynamics,
dynamicVoice,
dynamicSingle,
Level(..),
cresc,
dim,
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
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)
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
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
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 = mapValuesVoice dyn2 ds
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
type LevelDiff a = (Bool, Bool, Maybe a, Bool, Bool)
dyn2 :: Ord a => [Level a] -> [LevelDiff a]
dyn2 = snd . List.mapAccumL g (Nothing, False, False)
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