module Temporal.Music.Notation.Volume(
Amplitude,
Diapason, Accent,
Vol(volume),
Volume(..), Level(..),
volumeNum, levelNum,
level, mediumLevel,
VolumeFunctor(..), LevelFunctor(..),
setDiapason, setLevel, setAccent,
accent, al', aq',
loud, quiet, louder, quieter,
dynamics, dynamicsRel, dynamicsSeg,
amplitude, unsafeAmplitude,
absVolume, unsafeAbsVolume
)
where
import Data.Function(on)
import Temporal.Music.Notation.Seg(Seg, segSize)
import Temporal.Music.Notation.Score(Score, Time, tmapRel, linseg)
type Amplitude = Double
type Diapason = (Amplitude, Amplitude)
type Accent = Double
class Seg a => Vol a where
volume :: Level a -> Volume a
data Seg n => Volume n = Volume
{ volumeDiapason :: Diapason
, volumeLevel :: Level n
} deriving (Show, Eq)
class VolumeFunctor a where
mapVolume :: (forall n . Seg n => Volume n -> Volume n) -> (a -> a)
instance Seg n => VolumeFunctor (Volume n) where
mapVolume f = f
instance VolumeFunctor a => VolumeFunctor (Score a) where
mapVolume f = fmap (mapVolume f)
instance Seg n => LevelFunctor (Volume n) where
mapLevel f = \(Volume d l) -> Volume d $ f l
setDiapason :: VolumeFunctor a => (Amplitude, Amplitude) -> a -> a
setDiapason x = mapVolume $ \(Volume _ l) -> Volume x l
data Seg n => Level n = Level
{ levelAccent :: Accent
, levelStep :: n
} deriving (Show, Eq)
volumeNum :: Seg n => Volume n -> Int
volumeNum = phantomNum
levelNum :: Seg n => Level n -> Int
levelNum = phantomNum
phantomNum :: Seg n => f n -> Int
phantomNum = segSize . num
where num :: f n -> n
num = const undefined
level :: Seg n => n -> Level n
level = Level 0
instance Seg n => Enum (Level n) where
toEnum = level . toEnum
fromEnum = fromEnum . levelStep
instance Seg n => Bounded (Level n) where
maxBound = level maxBound
minBound = level minBound
instance Seg n => Seg (Level n)
instance (Eq n, Seg n) => Ord (Level n) where
compare = compare `on` (\(Level a s) -> (fromIntegral $ fromEnum s) + a)
instance (Show n, Eq n, Seg n) => Num (Level n) where
(+) = liftBi (+) (+)
() = liftBi () ()
(*) = liftBi (*) (*)
abs = id
signum x
| x == minBound = 0
| otherwise = 1
fromInteger x = res
where n = levelNum res
res = level $ toEnum $ sat 0 n $ fromInteger x
class LevelFunctor a where
mapLevel :: (forall n . Seg n => Level n -> Level n) -> (a -> a)
instance Seg n => LevelFunctor (Level n) where
mapLevel f = f
instance LevelFunctor a => LevelFunctor (Score a) where
mapLevel f = fmap (mapLevel f)
accent :: LevelFunctor a => Accent -> a -> a
accent d = mapLevel $ \(Level a s) -> Level (a+d) s
al' :: LevelFunctor a => Accent -> a -> a
al' = accent
aq' :: LevelFunctor a => Accent -> a -> a
aq' = accent . negate
setAccent :: LevelFunctor a => Accent -> a -> a
setAccent d = mapLevel $ \(Level _ s) -> Level d s
setLevel :: (Seg n, LevelFunctor a) => n -> a -> a
setLevel n = mapLevel
(\l@(Level a _) -> Level a $ toEnum $ sat 0 (levelNum l) $ fromEnum n)
loud :: LevelFunctor a => a -> a
loud = louder 1
quiet :: LevelFunctor a => a -> a
quiet = quieter 1
quieter :: LevelFunctor a => Int -> a -> a
quieter n = louder (n)
louder :: LevelFunctor a => Int -> a -> a
louder n
| n > 0 = mapLevel $ liftUn id (+n)
| n < 0 = mapLevel $ liftUn id (\x -> x n)
mediumLevel :: Seg n => Level n
mediumLevel = res
where res = level $ toEnum $ round $ fromIntegral n / 2
n = levelNum res
dynamics :: LevelFunctor a => (Time -> Accent) -> Score a -> Score a
dynamics f = tmapRel $ \t -> accent (f t)
dynamicsRel :: LevelFunctor a => [Accent] -> Score a -> Score a
dynamicsRel xs = dynamics $ linseg $ init $ f =<< xs
where dt = recip $ fromIntegral $ length xs
f x = [x, dt]
dynamicsSeg :: LevelFunctor a => [Double] -> Score a -> Score a
dynamicsSeg xs = dynamics $ linseg xs
absVolume :: Seg n => Volume n -> Amplitude
absVolume (Volume d l) = amplitude d l
unsafeAbsVolume :: Seg n => Volume n -> Amplitude
unsafeAbsVolume (Volume d l) = unsafeAmplitude d l
amplitude :: Seg n => Diapason -> Level n -> Amplitude
amplitude d l = amplitudeGen (sat 0 $ fromIntegral $ levelNum l) d l
unsafeAmplitude :: Seg n => Diapason -> Level n -> Amplitude
unsafeAmplitude = amplitudeGen id
amplitudeGen :: Seg n
=> (Double -> Double)
-> Diapason -> Level n -> Amplitude
amplitudeGen bound (low, high) l@(Level a s) = (low * ) $ (high / low) ** x
where n = fromIntegral $ levelNum l
x = ( / n) $ bound $ (fromIntegral $ fromEnum s) + a
liftUn :: Seg n
=> (Accent -> Accent)
-> (Int -> Int)
-> (Level n -> Level n)
liftUn f g l@(Level a s) = Level (f a)
(toEnum $ sat 0 (levelNum l) $ g $ fromEnum s)
liftBi :: Seg n
=> (Accent -> Accent -> Accent)
-> (Int -> Int -> Int )
-> (Level n -> Level n -> Level n)
liftBi f g l@(Level a s) (Level a' s') =
Level (a `f` a') (toEnum $ sat 0 (levelNum l) $ fromEnum s `g` fromEnum s')
sat :: Ord a => a -> a -> a -> a
sat low high x
| x < low = low
| x > high = high
| otherwise = x