{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -------------------------------------------------------------------------------- -- | -- Module : HarmTrace.Audio.Annotate -- 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: Combining low-level features (VAMP plug-ins) with high-level -- knowledge (the HarmTrace harmony model) -------------------------------------------------------------------------------- module HarmTrace.Audio.Annotate ( mptreeAnnotator, groupAnnotator , simpleAnnotator , putSegStats, preProcessData , preProcessKeyData ) where -- parameters import Constants ( maxSegmentSize, maxLProductSize) -- Audio Stuff import HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync , mergeByBeat, addBeatTimeStamp , mergeAndTimeStamp) -- import HarmTrace.Audio.ChromaKey ( syncWithAnnKey) import HarmTrace.Audio.Key (getBeatSyncKeyFromChroma) import HarmTrace.Audio.ChordTypes -- Harmony Model stuff import HarmTrace.Base.MusicRep import HarmTrace.Models.Models import HarmTrace.Models.Jazz.Main import HarmTrace.Models.Pop.Main import HarmTrace.Tokenizer.Tokens import HarmTrace.IO.Errors import HarmTrace.HAnTree.HAn (HAn) import HarmTrace.HAnTree.Tree (Tree, size, depth) import HarmTrace.HAnTree.ToHAnTree (GTree) import HarmTrace.HarmTrace import Text.ParserCombinators.UU import Text.ParserCombinators.UU.BasicInstances import System.IO (stdout,hFlush) import Data.List (sortBy, groupBy, zipWith4) import Text.Printf (printf) -------------------------------------------------------------------------------- -- From chords with probabilities to a single chord, using harmony -------------------------------------------------------------------------------- -- | MPTrEE (Model Propelled Transcription of Euphonic Enitities): -- a sophisticated, harmony and beat informed chord annotator mptreeAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation mptreeAnnotator (GrammarEx g) k f = concatMap (harmonize g) (preProcessData k f) -- | preprocesses the raw audio data before using chord harmony model based -- chord selection. First, the beats and chroma are synchronised. Second, -- chord candidate lists are created. Third, a beat time-stamp is added. Fourth, -- smart, beat informed grouping of the chord candidates is performed. Fifth, -- the chord candidate lists are grouped in segments based on the key (obtained -- as provided by the user or as derived from the audio data). Last, the -- chord candidate lists are further segmented based on the occurrences of -- I and V chords. preProcessData :: Maybe [TimedData Key] -> AudioFeat -> [ProbChordSeg] preProcessData gtk (AudioFeat chrm beats afk) = segmentByTonic $ segmentByKey key . mergeByBeat . addBeatTimeStamp bt . createChordRanks $ beatSync bt chrm where -- if a ground-truth key annotations are provided, we use these -- annotations otherwise the key is derived from audio data (bt, key) = case gtk of Nothing -> preProcessKeyData chrm beats afk (Just k) -> syncWithAnnKey k -- syncronises the last beat and key frame to match the last chord frame syncWithAnnKey :: [TimedData Key] -> ([BeatBar], [TimedData Key]) syncWithAnnKey keys = let endTime = BeatBar (time $ last chrm, Four) beats' = takeWhile (< endTime) beats ++ [endTime] -- filter the None keys none (Key r _) = r /= Note Nothing N noNoneKey = (filter (none . getData) keys) -- reset key start timestamp to 0.0 and end timestampt to chorma end resetHead = setOnset (head noNoneKey) 0.0 : tail noNoneKey (l,[lst]) = splitAt (length resetHead - 1) resetHead in (beats',l ++[setOffset lst (timeStamp endTime)]) -- | preprocesses the audio data for automatic key detection. preProcessKeyData :: [ChordinoLine] -> [BeatBar] -> [ChordinoLine] -> ([BeatBar], [TimedData Key]) preProcessKeyData chrm beats afk = ( b, dumpBeats . mergeAndTimeStamp head b $ getBeatSyncKeyFromChroma b key ) where -- synchronise the last beat and key to match the last chord endTime = time $ last chrm afk' = takeWhile ((< endTime).time) afk (l,[lst]) = splitAt (length afk' - 1) afk' end = BeatBar (endTime, Four) key = l ++ [lst{time = endTime}] b = takeWhile (< end) beats ++ [end] -- reminder: ProbChordSeg = Segment Key [BeatTimedData [ProbChord]] harmonize :: forall g. (GTree g) => Grammar g -> ProbChordSeg -> ChordBeatAnnotation harmonize g (Segment k cands) = let isExpandable :: Bool isExpandable = length (filter ((>1) . length) (map getData cands)) > 0 myParse :: [ChordToken] -> (Tree HAn,[ChordToken],[Error Int]) myParse x = let -- First, parse the tokens res :: ([g],[Error Int]) res = case g of Jazz -> parse_h ((,) <$> pJazz k <*> pEnd) (createStr 0 x) Pop -> parse_h ((,) <$> pPop k <*> pEnd) (createStr 0 x) -- Build a ParseResult from that pr = ParseResult u (concatMap chords x) (fst res) u u u (snd res) [] -- So that we can post-process it. Then extract the Tree HAn t = pieceTreeHAn (postProc [ RemovePDPT, MergeDelChords ] pr) u :: forall a. a u = error "harmonize: undefined placeholder evaluated" -- Return the Tree HAn, the input tokens, and the errors in (t, x, snd res) -- To be improved evaluateParse :: (Tree HAn,[ChordToken],[Error Int]) -> (Tree HAn,[ChordToken],Float) evaluateParse (ts,tokens,errors) = (ts,tokens,errorRatio errors tokens) -- Generate, parse, and evaluate all possible sequences of chords parseResults :: [(Tree HAn,[ChordToken],Float)] parseResults = [ evaluateParse (myParse l) | l <- lProduct (map (map probChord . getData) cands) ] -- From all possible parse trees, take the best one select :: [(Tree HAn,[ChordToken],Float)] -> [ChordToken] select = select1 . head . groupBy (\(_,_,a) (_,_,b) -> a `compare` b == EQ) . sortBy (\(_,_,a) (_,_,b) -> a `compare` b) -- These all have the same error ratio, so we sort them first by tree -- size, then depth, and pick the first select1 :: [(Tree HAn,[ChordToken],Float)] -> [ChordToken] select1 = snd3 . head . sortBy cmp where cmp (a,_,_) (b,_,_) = (size a, depth a) `compare` (size b, depth b) snd3 (_,a,_) = a probChord :: ProbChord -> ChordToken probChord (ProbChord lab@(Chord r sh _add _on _dur) _p) = (ChordToken r' sh' [lab] NotParsed 1 0) where r' = if isNone r then Note Nothing Imp else toScaleDegree k r sh' = if sh == None then NoClass else toClassType sh -- replaces the candidate list by the selected chord in a -- Timed datatype (either TimedData or BeatTimedData) -- setBestChords :: Timed t => [ChordToken] -> [t ChordLabel] setBestChords :: [ChordToken] -> [BeatTimedData ChordLabel] setBestChords = zipWith setData cands . map (head . chords) -- if there is nothing to expand, do not parse in if isExpandable then setBestChords $ select parseResults else map pickHead cands pickHead :: Timed t => t [ProbChord] -> t ChordLabel pickHead tpc = setData tpc (chordLab . head $ getData tpc) -------------------------------------------------------------------------------- -- Segmentation functions -------------------------------------------------------------------------------- -- Temporary test values {- test = segmentTonic testKey testSeq testKey = Key (Note Nothing C) MajMode testSeq = testChordG ++ testChordC ++ testChordC ++ testChordG ++ testChordG testChordC = [TimedData [ProbChord labC 1, ProbChord labG 0.5] 0 0] testChordG = [TimedData [ProbChord labG 1, ProbChord labC 0.5] 0 0] labC = Chord (Note Nothing C) Maj [] 0 0 labG = Chord (Note Nothing G) Maj [] 0 0 -} -- move to segmentations function in Harmonize? segmentByKey ::Timed t=>[t Key] -> [BeatTimedData [ProbChord]] -> [ProbChordSeg] segmentByKey [] _ = error "segmentByKey: empty key list" segmentByKey [k] chds = [Segment (getData k) chds] segmentByKey (k : ks) chds = let (seg,cs) = span ((<= offset k) . offset) chds in Segment (getData k) seg : segmentByKey ks cs -- Reminder: TimedData [ProbChord] == Block segmentByTonic :: [ProbChordSeg] -> [ProbChordSeg] segmentByTonic segs = concatMap emergencySplit $ concatMap split segs where split :: ProbChordSeg -> [ProbChordSeg] split (Segment key cs) = zipWith Segment (repeat key) (segmentTonic key cs) -- In case segments are just to big, even after segmenting on Tonic and Dominant -- split these segments into smaller segements recursively. emergencySplit :: ProbChordSeg -> [ProbChordSeg] emergencySplit (Segment k cs) = map (Segment k) (recSplit cs) where -- recSplit :: [TimedData [a]] -> [[TimedData [a]]] recSplit [] = [] recSplit b | blen <= maxSegmentSize && snd (lProdStats b) <= maxLProductSize = [b] | otherwise = recSplit l ++ recSplit r where blen = length b (l,r) = splitAt (blen `div` 2) b -- Break into segments according to the key -- segmentTonic :: Timed t => Key -> [t [ProbChord]] -> [[t [ProbChord]]] segmentTonic :: Key -> [BeatTimedData [ProbChord]] -> [[BeatTimedData [ProbChord]]] segmentTonic k cands = segment cands [] where segment [] [] = [] segment [] acc = [reverse acc] segment (c:cs) acc | c' `isTonic` k || c' `isDom` k = reverse (c:acc) : segmentTonic k cs | otherwise = segment cs (c:acc) where c' = getFstChord c -- Take the first chord (which is the one with the highest probability, since -- the list is sorted) getFstChord :: Timed t => t [ProbChord] -> ChordLabel getFstChord c = case getData c of [] -> error "getFstChord: empty list" (h:_) -> chordLab h -- only split on chords we are certain of -- _ -> Chord (Note Nothing N) None [] 0 0 -- else return None -- Check if this chord label is the tonic isTonic :: ChordLabel -> Key -> Bool isTonic c (Key r m) = r == chordRoot c && m `eqMode` chordShorthand c -- Check if this chord label is the dominant -- JPM: I don't understand why this function looks so different from `isTonic` isDom :: ChordLabel -> Key -> Bool isDom (Chord (Note Nothing N) _ _ _ _) _ = False isDom c key = toScaleDegree key (chordRoot c) == Note Nothing V && MajMode `eqMode` chordShorthand c -- It is debatable how to implement this function, musically speaking. This -- is what I came up with, without thinking too much. eqMode :: Mode -> Shorthand -> Bool eqMode _ Sus4 = False eqMode _ Sus2 = False eqMode m sh = m == toMode sh lProduct :: [[a]] -> [[a]] lProduct [] = [] lProduct [l] = [ [x] | x <- l ] lProduct (h:t) = concat [ map (x:) (lProduct t) | x <- h ] -------------------------------------------------------------------------------- -- Some printing and statistics functions -------------------------------------------------------------------------------- -- | prints Segmetation statistics putSegStats :: Maybe [TimedData Key] -> AudioFeat -> IO() putSegStats k af = mapM_ segmentStat $ preProcessData k af segmentStat :: ProbChordSeg -> IO () segmentStat s@(Segment k bs) = do putStr ("start: " ++ (printf "%.3f" . onset $ head bs)) putStr (", end: " ++ (printf "%.3f" . offset $ last bs)) putStr (", key: " ++ show k) putStr (", probChords: " ++ show (length bs)) let (l, lpr) = lProdStats bs putStr (", lists > 1: " ++ show l) putStrLn (" lProduct: " ++ show lpr) print s >> hFlush stdout -- Given a Block list this function returns the number of probChords with a -- list > 1 (fst) and the lProduct size (snd) lProdStats :: Timed t => [t [a]] -> (Int, Int) lProdStats bs = (length l, lpr) where l = filter ((>1) . length ) (map getData bs) lpr = foldr (\a b -> length a * b) 1 l -------------------------------------------------------------------------------- -- A baseline chord label annotator -------------------------------------------------------------------------------- -- | Creates an annotation out of a Chord candidate list by just picking the -- first chord. This annotator does smart grouping -- (see 'HarmTrace.Audio.ChromaChord.mergeByBeat'). groupAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation groupAnnotator _g _keyAnn (AudioFeat chrm beats _key ) = -- ignore key info let endTime = BeatBar (time $ last chrm, Four) beats' = takeWhile (< endTime) beats ++ [endTime] in map pickHead . mergeByBeat . addBeatTimeStamp beats' . createChordRanks $ beatSync beats' chrm -- | The most simple annotator, no grouping, no matching, -- just pick the best matching chord simpleAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation simpleAnnotator _g _keyAnn (AudioFeat crm bts _key ) = -- ignore key addTimeInfo . map (chordLab . head) . createChordRanks $ beatSync bts crm where -- wraps a data types into 'BeatTimedData' datatype addTimeInfo :: [a] -> [BeatTimedData a] addTimeInfo blcks = zipWith4 BeatTimedData blcks bts' (0 : off) off (off,bts') = unzip $ map beatBar bts