HarmTrace-2.2.1: src/HarmTrace/Audio/ChromaChord.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : HarmTrace.Audio.ChromaChord
-- 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: Recognise audio chroma vectors into textual chord descriptions.
--------------------------------------------------------------------------------
module HarmTrace.Audio.ChromaChord ( createChordRanks
, beatSync
-- , mergeByBeat
, meanBeatSyncVectors
, mergeByOneAndThree
) where
import Constants (maxProbChordListLength, cutOffProbability)
import HarmTrace.Audio.DataParser (shift)
import HarmTrace.Base.MusicTime
import HarmTrace.Base.MusicRep
-- import Text.Printf (printf)
import Data.List (sortBy,find) -- , elemIndices, minimumBy)
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import HarmTrace.Audio.VectorNumerics
import Data.Vector ( Vector, slice, generate )
import Data.Matrix ( Matrix, fromLists, ncols, nrows, getCol, prettyMatrix )
--------------------------------------------------------------------------------
-- Matching chords and chroma
--------------------------------------------------------------------------------
-- | Synchronises the 'ChordinoData' with the list of beats
-- by grouping the 'ChordinoLines' of the 'ChordinoData' in separate lists.
beatSync :: BarTimeTrackData -> [ChordinoLine] -> [BeatChroma] -- = [TimedData ChordinoLine]
beatSync _ [] = []
beatSync [] _ = error "HarmTrace.Audio.ChromaChord: no beat tracker data"
beatSync bt cs = beatTime fstBeat syncbt beatAlignedChroma where
fstBeat = BarTime 0 (prevBeat . beat . head $ bt)
lstBeat = BarTime (time . last $ cs) (nextBeat . beat . last $ bt)
syncbt = takeWhile (< lstBeat) bt ++ [lstBeat]
beatAlignedChroma = groupChroma (getBeatTrack syncbt) [head cs] cs
-- groups a list of 'ChromaLine's into beat synchronised group:
-- one list per beat
groupChroma :: [NumData] -> [ChordinoLine] -> [ChordinoLine] -> [[ChordinoLine]]
groupChroma _ _ [] = []
groupChroma [] _ c = [c] -- TODO: prv should be first arg
groupChroma (b:bs) prv c -- we also store the previous group in case beat < time
| null x = prv : groupChroma bs prv c -- Why do we need this?
| otherwise = x : groupChroma bs x xs
where (x, xs) = span ((b >=) . time) c
-- given beatTracker data and a grouped chroma, the grouped chroma is wrapped
-- into a TimedData type
beatTime :: BarTime -> [BarTime] -> [a] -> [TimedData a]
-- TODO replace last by this case
-- beatTime (BarTime (on, onbt)) [] [c] = TimedData c onbt on (time . last $ c)
beatTime _ [] [] = []
beatTime (BarTime on onbt) (next@(BarTime off _) : bs) (x : xs) =
TimedData x [BarTime on onbt, BarTime off (nextBeat onbt)] : beatTime next bs xs
beatTime _ _ _ = error "beatSync: asynchronous beats and data"
-- | Merges chord segments, adding a bias toward merging at the first
-- and the third 'Beat'
mergeByOneAndThree :: [TimedData [ProbChord]] -> [TimedData [ProbChord]]
mergeByOneAndThree = mergeByBeat canMerge intersectPC where
-- specifies which combinations of beats are allowed to merge
canMerge :: Beat -> Beat -> Bool
canMerge One _ = True
canMerge Three _ = True
canMerge _ _ = False
-- Conditionally combines lists wrapped in a 'BeatTimeData' in a list. The first
-- argument should determine at which combinations of beats the merging function
-- (the second argument) should be applied. N.B. this function cannot
-- be rewritten with a foldr, because the outcome is dependend of the
-- left-to-right processing. Rewriting the function with foldl makes the
-- whole recognition process about 1/3 slower...
mergeByBeat :: (Beat -> Beat -> Bool) -> ([a] -> [a] -> [a])
-> [TimedData [a]] -> [TimedData [a]]
mergeByBeat _ _ [] = []
mergeByBeat _ _ [a] = [a]
mergeByBeat canMerge merge (x:y:xs)
| canMerge (getBeat x) (getBeat y)
&& not (null m) = mergeByBeat canMerge merge (xy:xs)
| otherwise = x : mergeByBeat canMerge merge ( y:xs)
where xy = TimedData m (getTimeStamps x ++ (tail . getTimeStamps $ y))
m = merge (getData x) (getData y)
-- | Calculates the intersection of to ['ProbChord]' N.B. because of the
-- set-based nature of the function the function is rather expensive, luckily
-- the length of the ['ProbChord'] is constant. Also, because the intersection
-- might change the order of the 'ProbChord's we sort the list again
-- descendingly
intersectPC :: [ProbChord] -> [ProbChord] -> [ProbChord]
intersectPC a b = reverse . sortBy (comparing prob)
$ mapMaybe (findAndMerge a') b' where
(a',b') = order a b
-- N.B. the probabilities are not divided by their length so > 1,
-- due to the addition
findAndMerge :: [ProbChord] -> ProbChord -> Maybe ProbChord
findAndMerge pcs pc = case find (== pc) pcs of
(Just pc') -> Just (ProbChord (chordLab pc) (prob pc + prob pc'))
Nothing -> Nothing
-- takes two lists and returns a tuple where the first element is the smallest
-- and the second element is the largest of the two lists
order :: [a] -> [a] -> ([a],[a])
order x y
| length x <= length y = (x,y)
| otherwise = (y,x)
--------------------------------------------------------------------------------
-- Matrix Functions for matching chords
--------------------------------------------------------------------------------
-- | Having a matrix of beat-synchronised bass and treble chromagrams and a
-- chord dictionary, the probability of a chord sounding at a particular beat is
-- estimated by calculating the Euclidean distance between the chord structures
-- and the chroma feature. These distances are calculated for every chord
-- candidate at every beat. Next, we sort the chord candidates by descending
-- Euclidean distance. To obtain a relative measure of the fit
-- between a chord candidate and the chroma vector in the range [0,1],
-- the distances are normalised by dividing them by distance of the best
-- matching chord candidate.
createChordRanks :: [BeatChroma] -> [TimedData [ProbChord]]
createChordRanks =
map (selectTop . normalize . sortTake . matchCDictionary <$>) . meanBeatSyncVectors
where
-- here prob is still (unnormalised) euclidean distance
sortTake, normalize :: [ProbChord] -> [ProbChord]
sortTake = take maxProbChordListLength . sortBy (comparing prob)
normalize l@(h:_) = let ph = prob h in map (\p -> p{prob = ph / prob p }) l
normalize [] = []
selectTop l -- selects the everything with a probability > x
| null s = none
-- so far, this had not positive effect
-- length s > maxProbChordListLength = none
| otherwise = s
where s = takeWhile ((> cutOffProbability) . prob) l
none = [ProbChord noneLabel 0.0]
-- takes the mean of every "beat block" and these Vectors as one Matrix
-- Each row of this matrix corresponds to the chroma within one beat
-- N.B. BeatChroma = BeatTimeData ChordinoLine
meanBeatSyncVectors :: [BeatChroma] -> [TimedData (Vector NumData)]
meanBeatSyncVectors = map (meanMat <$>) . beatSyncMatrix
-- creates a list of matrices, in which each matrix corresponds to the
-- collection of chroma vectors within one beat (drop the time stamp)
beatSyncMatrix :: [BeatChroma] -> [TimedData (Matrix NumData)]
beatSyncMatrix = map (toChromaMatrix <$>)
-- converts a ChordinoData into a Matrix
toChromaMatrix :: [ChordinoLine] -> Matrix NumData
toChromaMatrix = fromLists . map mergeLine where
mergeLine :: ChordinoLine -> [NumData]
mergeLine (ChordinoLine tm bs tb) = bs ++ tb
-- matches all transpositions of a chord structure with a chroma vector
matchCDictionary :: Vector NumData -> [ProbChord]
matchCDictionary v = map (matchStruct v) chordDictionary
-- calculate an Euclidean (PNorm2) norm
-- I also tried using the maximum norm, but this gave inferior results
matchStruct :: Vector NumData -> ChordCand -> ProbChord
matchStruct chroma (ChordCand r _ir None cs) =
ProbChord (Chord r None [] 0 1) (norm2 (chroma - fromList (cs ++ cs)))
matchStruct chroma (ChordCand r _ir sh cs) =
-- Chord root shorthand degrees location duration
-- ProbChord (Chord r sh [] 0 1) (sqrt (bss * bss + treble * treble))
ProbChord (Chord r sh [] 0 1) ((bss + treble) * 0.5)
where treble = norm2 (slice 12 12 chroma - fromList cs)
(_ir,bss) = matchInv r
-- calculates the euclidean distance between the bass chromagram
-- and all bass note inversions.
matchInv :: Root -> (Root, NumData)
matchInv ir = (ir, norm2 (slice 0 12 chroma - bcs)) where
bcs = fromList (pre ++ [1.0] ++ tail post)
(pre, post) = splitAt (toSemitone ir) (shortHandToCS None)
-- For a given chord structure, compute all possible
-- roots for inversions
-- rootInvs :: ChordStruct -> [Root]
-- rootInvs cs = map iThRoot (elemIndices 1 cs)
--------------------------------------------------------------------------------
-- The Chord Dictionary
--------------------------------------------------------------------------------
-- the chord dictionary of all chords that are matched
chordDictionary :: [ChordCand]
chordDictionary = concatMap transpose12 [minBound..] -- all shorthands :-)
-- takes a ChordStruct and returns a list containing the 12 transposed versions
-- (including the original) of the ChordStruct, times the number of possible
-- inversions (3 or 4, depending on the number of notes in the shorthand).
transpose12 :: Shorthand -> [ChordCand]
transpose12 sh
| null cstruct = []
| sh == None = [ChordCand (Note Nothing N) (Note Nothing N) None cstruct]
| otherwise = concatMap mkChordCands [0..11]
where
cstruct :: ChordStruct
cstruct = shortHandToCS sh
mkChordCands :: Int -> [ChordCand]
mkChordCands n = [ ChordCand r r sh shiftedCS]
where shiftedCS = shift (12-n) cstruct
r = toRoot n
shortHandToCS :: Shorthand -> ChordStruct
shortHandToCS sh = case sh of
-- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11
-- C, Db, D, Eb, E, F, F#, G, Ab, A, Bb, B
Maj -> [1.5, 0, 0.5, 0, 1.0, 0, 0, 1.5, 0, 0.5, 0, 0.5 ]
Min -> [1.5, 0, 0 , 1.0, 0 , 0, 0, 1.5, 0, 0 , 1.0, 0 ]
Sev -> [1.5, 0, 0 , 0, 1.0, 0, 0, 1.5, 0, 0.0, 1.0, 0 ]
-- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ]
-- HDim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 ]
-- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ]
-- Maj6 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0 ]
-- Dim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0 ]
-- Maj7 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 ]
-- Min7 -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 ]
-- Min6 -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0 ]
-- Sus4 -> [1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 ]
None -> [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]
-- None -> [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ]
_ -> []
-- none
-- all
-- ....
--------------------------------------------------------------------------------
-- general Matrix stuff
--------------------------------------------------------------------------------
-- given a matrix, calculates the mean vector
meanMat :: forall t. (Fractional t, Num t, Show t) => Matrix t -> Vector t
meanMat m = generate (ncols m) vmean where
vmean :: Int -> t
vmean i = mean (getCol (i+1) m)