{-# LANGUAGE
FlexibleInstances,
TypeSynonymInstances,
Rank2Types #-}
-- | representing volume
module Temporal.Music.Notation.Volume(
-- * Types
-- | Main datatypes are 'Amplitude', 'Diapason' and 'Level'.
-- 'Volume' consists of 'Diapason' and 'Level'. Every
-- 'Volume' can be converted to 'Amplitude' (see 'absVolume').
-- 'Amplitude' is linear units and 'Level' is logarithmic units,
-- or decibels. 'Diapason' defines lower and upper bound for volume level
-- in amplitude linear units.
Amplitude,
Diapason, Accent,
Vol(volume),
Volume(..), Level(..),
volumeNum, levelNum,
level, mediumLevel,
-- * Transformers
VolumeFunctor(..), LevelFunctor(..),
setDiapason, setDiapasonRel, setLevel, setAccent,
accent, al', aq',
loud, quiet, louder, quieter,
dynamics, dynamicsRel, dynamicsSeg,
-- * Rendering
amplitude, unsafeAmplitude,
absVolume, unsafeAbsVolume,
diapasonAt,
levelAsDouble, unsafeLevelAsDouble,
levelAsDoubleRel, unsafeLevelAsDoubleRel
)
where
import Data.Function(on)
import Temporal.Music.Notation.Seg(Seg, segSize)
import Temporal.Music.Notation.Score(Score, Time, tmapRel, linseg)
-- | Linear volume units
type Amplitude = Double
-- | Volume lower and upper bounds. Lower bound must be positive
-- and upper bound must exceed lower bound.
type Diapason = (Amplitude, Amplitude)
-- | 'Accent' defines values between 'Level' values on logarithmic
-- scale. 1 'Accent' == 1 'Level' 's step.
type Accent = Double
class Seg a => Vol a where
volume :: Level a -> Volume a
-- | 'Volume' consists of 'Diapason' and 'Level'.
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
-- | sets diapason to specified value
setDiapason :: VolumeFunctor a => (Amplitude, Amplitude) -> a -> a
setDiapason x = mapVolume $ \(Volume _ l) -> Volume x l
-- | relative update of diapason value in decibels,
-- (0, 1) turns diapason interval into itself.
setDiapasonRel :: VolumeFunctor a => (Double, Double) -> a -> a
setDiapasonRel (a, b) = mapVolume $
\(Volume x l) -> Volume (diapasonAt x a, diapasonAt x b) l
--------------------------------------------------
--------------------------------------------------
-- Level
-- | 'Level' defines number of equally spaced stamps on
-- logarithmic scale (steps), and degree of diversion
-- from the stamps (accents).
data Seg n => Level n = Level
{ levelAccent :: Accent
, levelStep :: n
} deriving (Show, Eq)
-- | number of levels in 'Volume' scale
volumeNum :: Seg n => Volume n -> Int
volumeNum = phantomNum
-- | number of levels in 'Level' scale
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
-------------------------------------------
-- constructors
-- | 'level' constructs 'Level' from type of class 'Seg'. 'Accent' is set to zero.
level :: Seg n => n -> Level n
level = Level 0
-------------------------------------------
-- instances
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
--------------------------------------
-- transformers
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' increases 'Accent' value by some degree
accent :: LevelFunctor a => Accent -> a -> a
accent d = mapLevel $ \(Level a s) -> Level (a+d) s
-- | shorcut for 'accent louder'
al' :: LevelFunctor a => Accent -> a -> a
al' = accent
-- | shorcut for 'accent quieter'
aq' :: LevelFunctor a => Accent -> a -> a
aq' = accent . negate
-- | 'setAccent' sets 'Accent' value to given input
setAccent :: LevelFunctor a => Accent -> a -> a
setAccent d = mapLevel $ \(Level _ s) -> Level d s
-- | 'setLevel' sets 'levelStep' to given input
setLevel :: (Seg n, LevelFunctor a) => n -> a -> a
setLevel n = mapLevel
(\l@(Level a _) -> Level a $ toEnum $ sat 0 (levelNum l) $ fromEnum n)
-- | Input becomes one step louder
loud :: LevelFunctor a => a -> a
loud = louder 1
-- | Input becomes one step quieter
quiet :: LevelFunctor a => a -> a
quiet = quieter 1
-- | Input becomes given number of steps quieter
quieter :: LevelFunctor a => Int -> a -> a
quieter n = louder (-n)
-- | Input becomes given number of steps louder
louder :: LevelFunctor a => Int -> a -> a
louder n
| n > 0 = mapLevel $ liftUn id (+n)
| n < 0 = mapLevel $ liftUn id (\x -> x - n)
-- | Medium level
mediumLevel :: Seg n => Level n
mediumLevel = res
where res = level $ toEnum $ round $ fromIntegral n / 2
n = levelNum res
-- | Accent that depends on time of note
dynamics :: LevelFunctor a => (Time -> Accent) -> Score a -> Score a
dynamics f = tmapRel $ \t -> accent (f t)
-- | Linear relative 'dyn' function. Function is defined by list of
-- its values equaly spaced along time axis. For example
-- list [0, 1, 0] defines rise then decay lineary along full 'Score' 's
-- input duration. Time intervals of
-- rise and decay segments are equal to 'dur' /2. And list [0, 1, 0.5, 0]
-- defines
-- rise and decay again but here decay segment is twice longer then
-- rise segment.
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]
-- | 'dynSeg' lifts 'linseg' function to dynamics level
dynamicsSeg :: LevelFunctor a => [Double] -> Score a -> Score a
dynamicsSeg xs = dynamics $ linseg xs
--------------------------------------------------
-- rendering
-- | converts volume to amplitude with 'amplitude' function
absVolume :: Seg n => Volume n -> Amplitude
absVolume (Volume d l) = amplitude d l
-- | converts volume to amplitude with 'unsafeAmplitude' function
unsafeAbsVolume :: Seg n => Volume n -> Amplitude
unsafeAbsVolume (Volume d l) = unsafeAmplitude d l
-- | converts equally spaced between lower and upper diapason bounds
-- 'Level' values to amplitudes.
-- Here resulting amplitude value lies within 'Diapason' interval.
-- All outsiders are placed inside interval with saturation.
amplitude :: Seg n => Diapason -> Level n -> Amplitude
amplitude d l = diapasonAt d $ levelAsDoubleRel l
-- | unsafe analog of 'amplitude' function. Here result can go
-- beyond limits of 'Diapason' interval.
unsafeAmplitude :: Seg n => Diapason -> Level n -> Amplitude
unsafeAmplitude d l = diapasonAt d $ unsafeLevelAsDouble l
-- | mapps decibels to amplitudes within specified amplitude diapason,
-- 0 turns to lower diapason value and 1 turns to higher diapason value
diapasonAt :: Diapason -> Double -> Double
diapasonAt (low, high) d = (low * ) $ (high / low) ** d
-- | converts level value to double
levelAsDouble :: Seg s => Level s -> Double
levelAsDouble x = sat 0 n $ unsafeLevelAsDouble x
where n = fromIntegral $ levelNum x - 1
-- | converts level value to double, value can exceed level limits
unsafeLevelAsDouble :: Seg s => Level s -> Double
unsafeLevelAsDouble l@(Level a x) = (fromIntegral $ fromEnum l) + a
-- | converts level value to double, and normalizes output by level limits
levelAsDoubleRel :: Seg s => Level s -> Double
levelAsDoubleRel l = (/n) $ levelAsDouble l
where n = fromIntegral $ levelNum l - 1
-- | converts level value to double and normalizes output by level limits,
-- value can exceed (0, 1) interval
unsafeLevelAsDoubleRel :: Seg s => Level s -> Double
unsafeLevelAsDoubleRel l = (/n) $ unsafeLevelAsDoubleRel l
where n = fromIntegral $ levelNum l - 1
--------------------------------------
-- level manipulation
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