FComp-1.0: src/HarmTrace/Accompany.hs
--------------------------------------------------------------------------------
-- |
-- Module : HarmTrace.Accompany
-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford
-- License : GPL3
--
-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk
-- Stability : experimental
-- Portability : non-portable
--
-- Summary: Generate a melody (accompaniment) for a given harmony
--------------------------------------------------------------------------------
module HarmTrace.Accompany where
import HarmTrace.Base.MusicRep
import HarmTrace.Song
import HarmTrace.Models.Simple.Model ( Piece )
import HarmTrace.Models.Simple.Main ( getChords )
import HarmTrace.Models.ChordTokens ( ChordToken(..), ctToCL, sdToNote )
import Control.Monad.State
import System.Random
import Data.List ( intersect )
import Debug.Trace
map2 :: (b -> c) -> [(a,b)] -> [(a,c)]
map2 f = map (\(a,b) -> (a, f b))
data MyState = MyState { genState :: StdGen
, keyState :: Key
, pieceState :: Piece
, chordsState :: [ChordToken] }
accompanyIO :: Key -> Piece -> IO Song
accompanyIO k p = do gen <- getStdGen
let initState = MyState gen k p (getChords p)
return (evalState (accompany k) initState)
accompany :: Key -> State MyState Song
accompany k = allPossible >>= refine >>= pickBest>>= embellish
>>= return . Song k
-- 2.1) Generate candidate melody notes from chords
allPossibleRel :: [ChordToken] -> [(ChordToken,[ScaleDegree])]
allPossibleRel cs = [ (c, notesRootedOn (root c) (classType c)) | c <- cs ]
allPossible :: State MyState [(ChordLabel,[MelodyNote])]
allPossible = do k <- get >>= return . keyState
p <- get >>= return . pieceState
let unRel (c,sds) = ( ctToCL k c
, map (flip MelodyNote 3 . sdToNote k) sds)
return $ map unRel (allPossibleRel (getChords p))
-- All notes that belong to this chord
notesRootedOn :: ScaleDegree -> ClassType -> [ScaleDegree]
notesRootedOn sd cls =
let indices = case cls of
MajClass -> [0,4,7]
MinClass -> [0,3,7]
DimClass -> [0,3,6]
DomClass -> [0,4,7,10]
x -> error $ "notesRootedOn: " ++ show x
in [ transposeSem sd i | i <- indices ]
-- 2.2) Trim to remove bad candidates
refine :: [(ChordLabel, [MelodyNote])] -> State MyState [(ChordLabel, [MelodyNote])]
refine [] = return []
refine ((cl,mns):cs) =
do k <- get >>= return . keyState
-- Make sure the first note is one of I, III, or V
let indices = case keyMode k of
MajMode -> [0,4,7::Int]
MinMode -> [0,3,7]
ki = toSemitone (keyRoot k)
makeNote i = MelodyNote (toRootM (i + ki)) 3
first = map makeNote indices
firstNotes = let wanted = first `intersect` mns
in if null wanted then mns else wanted
-- Handle the final note
lastNote ns = let (a,[b]) = splitAt (length ns - 1) ns
in a ++ [final b]
-- We want the final note to be a I, or, if I is not in the chord, a V
final (c,n) = let n' = if makeNote 0 `elem` n
then [makeNote 0]
else [makeNote 7]
in (c,n')
return $ ((cl,firstNotes) : lastNote cs)
-- 2.3) Pick one note per chord
pickBest :: [(ChordLabel, [MelodyNote])] -> State MyState [(ChordLabel, MelodyNote)]
pickBest cs =
do s <- get
-- Just randomly pick notes from the list of candidates
let g = genState s
rs = randoms g
f ((cl, mns), r) = (cl, mns !! (r `mod` length mns))
result = map f (zip cs rs)
-- Make sure VIIs are followed by a I in the right octave
k = keyState s
ki = toSemitone (keyRoot k)
makeNote i = MelodyNote (toRootM (i + ki)) 3
resolveCadences :: [(ChordLabel, MelodyNote)] -> [(ChordLabel, MelodyNote)]
resolveCadences ((c1,n1):(c2,n2):cns)
| n1 == makeNote 0 && n2 == makeNote 11
= (c1,n1) : (c2,octaveDown n2) : resolveCadences cns
| n1 == makeNote 11 && n2 == makeNote 0
= (c1,n1) : (c2,octaveUp n2) : resolveCadences cns
| otherwise = (c1,n1) : resolveCadences ((c2,n2):cns)
resolveCadences x = x
return (resolveCadences result)
-- 2.4) Embellish the melody
embellish :: [(ChordLabel, MelodyNote)] -> State MyState [(ChordLabel, [MelodyNote])]
embellish [] = return []
embellish ((cl,mn):cls) = do g <- get >>= return . genState
k <- get >>= return . keyState
return $ go k (cl,mn,g) cls
where
go k (cl1,n1,g1) [] = [(cl1,[n1])]
go k (cl1,n1,g1) ((cl2,n2):cls) = let (_,g2) = next g1
in (cl1, connectNotes g1 k cl1 n1 n2)
: go k (cl2,n2,g2) cls
-- Given two notes, return a melody that begins in the first and ends in
-- something suitable to be connected to the second.
connectNotes :: StdGen -> Key -> ChordLabel
-> MelodyNote -> MelodyNote -> [MelodyNote]
connectNotes g k cl n1@(MelodyNote r1 o1) n2@(MelodyNote r2 o2)
| n1 == n2
-- embellish repetitions
= let scale = notesInChord cl -- this is debatable...
in case fst (randomR (0,3::Int) g) of
-- C C -> C C
0 -> [n1]
-- C C -> C D E C
1 -> if n1 `elem` scale
then take 3 . dropWhile (/= n1) $ scale
else [n1]
-- C C -> C B C
2 -> if n1 `elem` scale
then take 2 . dropWhile (/= n1) $ reverse scale
else [n1]
-- C C -> C E D C
3 -> let f123_132 [c,d,e] = [c,e,d]
in if n1 `elem` scale
then f123_132 . take 3 . dropWhile (/= n1) $ scale
else [n1]
_ -> error "connectNotes: impossible"
-- Connect from a scale in the current key
connectNotes g k cl n1@(MelodyNote r1 o1) n2@(MelodyNote r2 o2)
= let scale = notesInKey k
-- scale = notesInChord cl
line = if n1 < n2
then n1 : takeWhile (< n2) (dropWhile (<= n1) scale)
else n1 : takeWhile (n2 <) (dropWhile (n1 <=) (reverse scale))
in line
-- Like toRoot, but mod 12
toRootM :: Int -> Root
toRootM = toRoot . (`mod` 12)
-- Returns a scale
notesInKey :: Key -> [MelodyNote]
notesInKey (Key r m) = let indices = case m of
MajMode -> [0,2,4,5,7,9,11]
MinMode -> [0,2,3,5,7,8,10] -- tricky
base = [ toRootM (toSemitone r + i) | i <- indices ]
in filter (\n -> mnRoot n `elem` base) allMelodyNotes
-- Return the scale associated with a chord
notesInChord :: ChordLabel -> [MelodyNote]
notesInChord cl = let r = chordRoot cl
indices = case chordShorthand cl of
Maj -> [0,2,4,5,7,9,11]
Sev -> [0,2,4,5,7,9,10]
Min -> [0,2,3,5,7,8,10]
Dim -> [0,2,3,5,6,8,9]
m -> error $ "notesInChord: " ++ show m
base = [ toRootM (toSemitone r + i) | i <- indices ]
in filter (\n -> mnRoot n `elem` base) allMelodyNotes