{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PostfixOperators #-}
module Generate.Applications.Diatonic where
import Generate.Generate
import Generate.QuickCheck
import Music
import Data.List
import Data.Maybe
import qualified Control.Arrow as Arrow
import Control.Monad
import Control.Monad.State
import Grammar.Utilities
import Test.QuickCheck
import Generate.Applications.GenConfig
densityToDurations :: Density -> [(Weight, Duration)]
densityToDurations High =
[ (0.05, 1%32)
, (0.15, 1%16)
, (0.55, 1%8)
, (0.30, 1%4)
, (0.05, 1%2)
]
densityToDurations Medium =
[ (0.02, 1%16)
, (0.05, 1%8)
, (0.55, 1%4)
, (0.30, 1%2)
, (0.05, 1%1)
]
densityToDurations Low =
[ (0.10, 1%8)
, (0.40, 1%4)
, (0.40, 1%2)
, (0.10, 1%1)
]
relativeWeights :: [(Weight, Interval)]
relativeWeights = [ (10.0, P1)
, (0.50, Mi2)
, (2.50, M2)
, (8.00, Mi3)
, (8.00, M3)
, (5.00, P4)
, (1.00, A4)
, (9.00, P5)
, (1.00, Mi6)
, (4.00, M6)
, (4.00, Mi7)
, (4.00, M7)
, (10.0, P8)
, (1.00, Mi9)
, (2.50, M9)
, (8.00, A9)
, (8.00, M10)
, (5.00, P11)
, (1.00, A11)
, (9.00, P12)
, (1.00, Mi13)
, (4.00, M13)
, (4.00, Mi14)
, (4.00, M14)
, (10.0, P15)
]
intervalWeights :: PitchClass -> [Interval]
-> [(Weight, PitchClass)]
intervalWeights key scale =
map (\(a, b) -> (a, key =| b)) $
filter (\(a, b) -> b `elem` scale) relativeWeights
semiChordWeights :: PitchClass -> SemiChord
-> [(Weight, PitchClass)]
semiChordWeights key chord =
map (
(\(a, b) -> (a, key =| b)) .
(\pc ->
relativeWeights!!(
((12 +
((fromEnum ([C .. B]!!(fromEnum pc))) -
(fromEnum ([C .. B]!!(fromEnum key)))))
`mod` 12)
)
)) chord
mergeWeights :: (Eq a) => [(Weight, a)] -> [(Weight, a)] -> [(Weight, a)]
mergeWeights xs ys =
let xs' = normalize xs
in let ys' = normalize ys
in normalize $
(filter
((not . (flip elem) (stripList ys)) . snd) xs'
) ++
(filter
((not . (flip elem) (stripList xs)) . snd) ys'
) ++
zipWith (\(x1, x2) (y1, _) -> ((x1 + y1) / 2, x2))
(filter ((flip elem) intersection . snd) xs')
(filter ((flip elem) intersection . snd) ys')
where
normalize xs =
let k = (sum . map fst) xs
in map (\(x, v) -> (x / k, v)) xs
intersection = intersect (stripList xs) (stripList ys)
inScale :: PitchClass -> [Interval]
-> Constraint PitchClass
inScale key scale = (flip elem) (key +| scale :: [PitchClass])
beamSelector :: (Eq a, Enum a) => Double
-> Accessor st s a
-> Selector a a
beamSelector k _ s xs = do
(el, _) <- quickCheckSelector s (getDistributions s k xs)
return (el, el)
getDistributions :: (Eq a, Enum a) => a
-> Double
-> [(Weight, a)]
-> [(Weight, a)]
getDistributions el k xs =
case idx of
(Just _) -> (map (\(w, v) -> (getWeight v w, v)) xs)
(Nothing) -> xs
where idx = (elemIndex el (stripList xs))
getWeight el' ow | el == el' = ow * 0.5
getWeight el' ow | otherwise =
ow * k^^(0 - abs((fromJust idx) -
(fromJust (elemIndex el' (stripList xs )))))
stripList :: [(Weight, a)] -> [a]
stripList = map snd
genAspect :: (Eq a, Enum a) => Accessor GenState a a
-> a
-> Int
-> Double
-> [(Weight, a)]
-> MusicGenerator () [a]
genAspect accessor initial n k options = do
lift $ runGenerator initial $
do accessor >+ options
accessor >? (beamSelector k accessor)
replicateM n (accessor??)
diatonicPhrase :: Duration -> Density
-> PitchClass
-> [Interval]
-> SemiChord
-> [(Int, Octave)]
-> MusicGenerator () MusicCore
diatonicPhrase dur density key scale chord octD = do
durations <- boundedRhythm dur density
octaves <- genAspect octave 4
(length durations) 2.0
(map (Arrow.first fromIntegral) octD)
pitches <- genAspect pitchClass key
(length durations) 1.3
(mergeWeights
(intervalWeights key scale)
(semiChordWeights key chord))
let fullPitches = ((flip (<:) $ []) <$> (zipWith (#) pitches octaves))
return $ line
(zipWith (<|) fullPitches durations)
diatonicMelody :: GenConfig -> MusicGenerator () MusicCore
diatonicMelody config =
let timeline = chordalTimeline (chords config)
in f timeline 0
where f [] pos = return $ Rest 0
f tl pos =
do density <- lift (fromDistribution (phraseDistribution config))
len <- lift $ phraseLength density
pause <- lift pauseLength
phrase <- diatonicPhrase
len density
(key config)
(baseScale config)
(fst $ head tl)
(octaveDistribution config)
r <- f (remainder tl (pos + len + pause)) (pos + len + pause)
return $ phrase :+: (Rest pause) :+: r
where remainder [] _ = []
remainder [x] _ = []
remainder (x:y:xs) p | p < snd y = (y:xs)
| otherwise = remainder (y:xs) p
melodyInC :: MusicGenerator () MusicCore
melodyInC = do
pitchClass >! (inScale C major)
options <- (pitchClass?+)
rhythm <- boundedRhythm (1 * wn) High
pitchClass >+ map
(\(w, v) ->
if v `elem` (G =| d7 :: [PitchClass])
then (4 * w, v) else (w, v)) options
pitches <- (length rhythm) .#. (pitchClass??)
let fullPitches = (flip (<:) $ []) <$> (zipWith (#) pitches (repeat 4))
let gmaj7 = (toMusicCore . chord .
map (Note (1 * wn) . (flip (#)) 3)) (G =| d7)
return $ gmaj7 :=: line (zipWith (<|) fullPitches rhythm)
randomMelody :: MusicGenerator () MusicCore
randomMelody = do
pitches <- 20 .#. (pitchClass??)
durations <- 20 .#. (duration??)
octaves <- 20 .#. (octave??)
return (line $ zipWith (<|)
((flip (<:) $ []) <$> zipWith (#) pitches octaves)
durations)
phraseLength :: Density -> IO Duration
phraseLength density = do
aux <- generate $ oneof
(map (elements . (\x -> [x]))
[2..maxLen]
)
return $ aux * qn
where maxLen =
case density of
Low -> 8
Medium -> 16
High -> 32
pauseLength :: IO Duration
pauseLength = do
aux <- generate $ oneof
(map (elements . (\x -> [x]))
[1..8]
)
return $ aux * en
fromDistribution :: [(Int, a)] -> IO a
fromDistribution dist = do
sample <- generate $ frequency
(map (\(x, y) -> (x, elements [y])) dist)
return sample
chordalTimeline :: Music SemiChord -> [(SemiChord, Duration)]
chordalTimeline chords = getTimeline (toListM chords) 0
getTimeline :: [(Maybe a, Duration)] -> Duration -> [(a, Duration)]
getTimeline [] _ = []
getTimeline ((x, y):xs) p =
case x of
Nothing -> getTimeline xs (p + y)
(Just v) -> (v, p):getTimeline xs (p + y)
trimToLength :: Duration -> [Duration] -> [Duration]
trimToLength d [] = []
trimToLength d (x:xs) | d - x <= 0 = [d]
trimToLength d (x:xs) | otherwise = x:(trimToLength (d - x) xs)
boundedRhythm :: Duration -> Density -> MusicGenerator () [Duration]
boundedRhythm bound density = do
dur <- (duration??)
rhythm <- genAspect duration
dur (round (bound / qn)) 2.0 (densityToDurations density)
return $ trimToLength bound rhythm
concatM :: (Monad m) => [m [a]] -> m [a]
concatM [] = return []
concatM (x:xs) = do
v <- x
vs <- concatM xs
return (v ++ vs)