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
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))
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 ]
refine :: [(ChordLabel, [MelodyNote])] -> State MyState [(ChordLabel, [MelodyNote])]
refine [] = return []
refine ((cl,mns):cs) =
do k <- get >>= return . keyState
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
lastNote ns = let (a,[b]) = splitAt (length ns 1) ns
in a ++ [final b]
final (c,n) = let n' = if makeNote 0 `elem` n
then [makeNote 0]
else [makeNote 7]
in (c,n')
return $ ((cl,firstNotes) : lastNote cs)
pickBest :: [(ChordLabel, [MelodyNote])] -> State MyState [(ChordLabel, MelodyNote)]
pickBest cs =
do s <- get
let g = genState s
rs = randoms g
f ((cl, mns), r) = (cl, mns !! (r `mod` length mns))
result = map f (zip cs rs)
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)
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
connectNotes :: StdGen -> Key -> ChordLabel
-> MelodyNote -> MelodyNote -> [MelodyNote]
connectNotes g k cl n1@(MelodyNote r1 o1) n2@(MelodyNote r2 o2)
| n1 == n2
= let scale = notesInChord cl
in case fst (randomR (0,3::Int) g) of
0 -> [n1]
1 -> if n1 `elem` scale
then take 3 . dropWhile (/= n1) $ scale
else [n1]
2 -> if n1 `elem` scale
then take 2 . dropWhile (/= n1) $ reverse scale
else [n1]
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"
connectNotes g k cl n1@(MelodyNote r1 o1) n2@(MelodyNote r2 o2)
= let scale = notesInKey k
line = if n1 < n2
then n1 : takeWhile (< n2) (dropWhile (<= n1) scale)
else n1 : takeWhile (n2 <) (dropWhile (n1 <=) (reverse scale))
in line
toRootM :: Int -> Root
toRootM = toRoot . (`mod` 12)
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]
base = [ toRootM (toSemitone r + i) | i <- indices ]
in filter (\n -> mnRoot n `elem` base) allMelodyNotes
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