module Dynamics ( addDynamics
, dyn
, sinTimeDynamics
, sinPitchDynamics
, expPitchDynamics
, DynamicsMap) where
import Data.KMeans (kmeansGen)
import Data.List (find)
import Data.Maybe (fromJust)
import Music
type AbsStartTime = Rational
type PitchIntValue = Int
type ClusterMusicA = (FullPitch, (AbsStartTime, PitchIntValue))
type MusicCluster = Music ClusterMusicA
type Cluster = [ClusterMusicA]
type DynamicsMap = Double
-> Double
-> Double
sinTimeDynamics :: DynamicsMap
sinTimeDynamics x _ = 0.25 + (0.25 * sin (2 * pi * x))
sinPitchDynamics :: DynamicsMap
sinPitchDynamics x _ = 0.25 + (0.25 * sin (2 * pi * x))
expPitchDynamics :: DynamicsMap
expPitchDynamics _ y = max 0.45 (min 0.8 (-log (1 - y)))
dyn :: (ToMusicCore a) => Music a -> MusicCore
dyn m = addDynamics m expPitchDynamics
addDynamics :: (ToMusicCore a) => Music a -> DynamicsMap -> MusicCore
addDynamics m' dynMap = do
let m = toMusicCore m'
let mCluster = coreToCluster m
let clusters = cluster mCluster
let dynamics = concatMap (addDynamicsToCluster dynMap) clusters
addDynamicsToMCore mCluster dynamics
addDynamicsToMCore :: MusicCluster -> Cluster -> MusicCore
addDynamicsToMCore m c =
fmap add m
where add (_,info) =
fst $ fromJust $ find ((info==) . snd) c
bounds :: [ClusterMusicA] -> ((Double, Double),(Double, Double))
bounds m = ( (fromRational (minimum (map (fst . snd) m)), fromIntegral (minimum (map (snd . snd) m)))
, (fromRational (maximum (map (fst . snd) m)), fromIntegral (maximum (map (snd . snd) m)))
)
addDynamicsToCluster :: DynamicsMap -> Cluster -> Cluster
addDynamicsToCluster _ [] = []
addDynamicsToCluster f c = do
let ((minTime,minNote),(maxTime,maxNote)) = bounds c
let tProg t = ((fromRational t) - minTime) / (maxTime - minTime)
let pProg n = ((fromIntegral n) - minNote) / (maxNote - minNote)
let pToDyn ((p',attrs),(t,p)) = do
let dynDouble = f (tProg t) (pProg p)
if dynDouble < 0 || dynDouble > 1 then
error "Result from DynamicsMap is not in range [0,1]."
else do
let maxDynNum = fromIntegral (fromEnum (maxBound :: Dynamic)) :: Double
let dynNum = round (maxDynNum * dynDouble)
let d = Dynamic (toEnum dynNum :: Dynamic)
((p',d:attrs),(t,p))
map pToDyn c
cluster :: MusicCluster -> [Cluster]
cluster m = kmeansGen gen k (notes m)
where gen :: ClusterMusicA -> [Double]
gen (_,(x,y)) = [fromRational x, fromIntegral y]
k = max 1 (round ((fromRational (duration m) :: Double) / 4))
coreToCluster :: MusicCore -> MusicCluster
coreToCluster = calcClusterInfo . fmap (\p -> (p,(0,0)) )
calcClusterInfo :: MusicCluster -> MusicCluster
calcClusterInfo (m1@(Rest l) :+: m2) = m1 :+: fmap (addTime l) (calcClusterInfo m2)
calcClusterInfo (m1@(Note l _) :+: m2) = calcClusterInfo m1 :+: fmap (addTime l) (calcClusterInfo m2)
calcClusterInfo (m1 :=: m2) = calcClusterInfo m1 :=: calcClusterInfo m2
calcClusterInfo (m1 :+: m2) =
calcClusterInfo m1 :+: fmap (addTime (duration m1)) (calcClusterInfo m2)
calcClusterInfo r@(Rest _) = r
calcClusterInfo (Note l (p,(x,_))) = Note l (p,(x, fromEnum p))
duration :: Music a -> Duration
duration (m1 :+: m2) = (+) (duration m1) (duration m2)
duration (m1 :=: m2) = max (duration m1) (duration m2)
duration (Note l _) = l
duration (Rest l) = l
addTime :: Duration -> ClusterMusicA -> ClusterMusicA
addTime t (p,(x,y)) = (p,(x+t,y))