diff --git a/HarmTrace.cabal b/HarmTrace.cabal --- a/HarmTrace.cabal +++ b/HarmTrace.cabal @@ -1,5 +1,5 @@ name: HarmTrace -version: 2.0 +version: 2.1 synopsis: Harmony Analysis and Retrieval of Music description: HarmTrace: Harmony Analysis and Retrieval of Music with Type-level Representations of Abstract @@ -15,8 +15,8 @@ 2011. -copyright: (c) 2010--2012 Universiteit Utrecht, - 2012 University of Oxford +copyright: (c) 2010--2013 Universiteit Utrecht, + 2012--2013 University of Oxford license: GPL-3 license-file: LICENSE author: W. Bas de Haas and Jose Pedro Magalhaes @@ -26,7 +26,7 @@ category: Music build-type: Custom cabal-version: >= 1.6 -tested-with: GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1 +tested-with: GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1 extra-source-files: README @@ -36,7 +36,6 @@ HarmTrace.HarmTrace - HarmTrace.Audio.ChordTypes HarmTrace.Audio.Annotate HarmTrace.Audio.AnnotationParser HarmTrace.Audio.DataParser @@ -46,11 +45,6 @@ HarmTrace.Audio.Evaluation HarmTrace.Audio.Statistical - HarmTrace.Base.MusicRep - HarmTrace.Base.Parsing - HarmTrace.Base.TypeLevel - - HarmTrace.HAnTree.Binary HarmTrace.HAnTree.HAn HarmTrace.HAnTree.HAnParser HarmTrace.HAnTree.PostProcess @@ -67,6 +61,7 @@ HarmTrace.IO.FeatExtract HarmTrace.IO.Downsample HarmTrace.IO.BasePaths + HarmTrace.IO.Wave HarmTrace.Matching.Alignment HarmTrace.Matching.HChord @@ -77,6 +72,8 @@ HarmTrace.Models.Models HarmTrace.Models.Parser + HarmTrace.Models.ChordTokens + HarmTrace.Models.TypeLevel HarmTrace.Models.Jazz.Instances HarmTrace.Models.Jazz.Main @@ -86,17 +83,15 @@ HarmTrace.Models.Pop.Main HarmTrace.Models.Pop.Model - HarmTrace.Tokenizer.Tokenizer - HarmTrace.Tokenizer.Tokens - main-is: Main.hs - build-depends: base >= 4.2 && < 4.6, template-haskell >=2.4 && <2.8, + build-depends: base >= 4.2 && < 4.7, template-haskell >=2.4 && <2.9, mtl, directory, filepath, array, parallel >= 3, - Diff == 0.1.*, cmdargs >= 0.9 && < 0.10, process >= 1.0, - uu-parsinglib == 2.7.1, ListLike >= 3.0.1, - vector >= 0.7, deepseq, sox >= 0.2.2.1, - instant-generics >= 0.3.1 && < 0.4, binary == 0.5.*, - hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9 + Diff == 0.1.*, cmdargs >= 0.10.1, process >= 1.0, + uu-parsinglib == 2.7.4.*, ListLike >= 3.0.1, + vector >= 0.7, deepseq, sox >= 0.2.2.2, + instant-generics >= 0.3.6 && < 0.4, binary >= 0.6.4, + hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9, + HarmTrace-Base >= 1.0.0.2, ghc-prim >= 0.2 ghc-options: -Wall -O2 -fno-spec-constr-count -funbox-strict-fields @@ -109,13 +104,14 @@ library -- Note the extreme duplication of information -- I don't think there's much we can do about that - build-depends: base >= 4.2 && < 4.6, template-haskell >=2.4 && <2.8, + build-depends: base >= 4.2 && < 4.7, template-haskell >=2.4 && <2.9, mtl, directory, filepath, array, parallel >= 3, Diff == 0.1.*, parseargs >= 0.1.3.2, process >= 1.0, - uu-parsinglib == 2.7.1, ListLike >= 3.0.1, - vector >= 0.7, deepseq, - instant-generics >= 0.3.1 && < 0.4, binary == 0.5.*, - hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9 + uu-parsinglib == 2.7.4.*, ListLike >= 3.0.1, + vector >= 0.7, deepseq, HCodecs >= 0.2.2, + instant-generics >= 0.3.6 && < 0.4, binary >= 0.6.4, + hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9, + HarmTrace-Base >= 1.0.0.2, ghc-prim >= 0.2 ghc-options: -Wall -O2 -fno-spec-constr-count -funbox-strict-fields @@ -126,8 +122,7 @@ hs-source-dirs: src - exposed-modules: HarmTrace.Audio.ChordTypes - HarmTrace.Audio.Annotate + exposed-modules: HarmTrace.Audio.Annotate HarmTrace.Audio.AnnotationParser HarmTrace.Audio.DataParser HarmTrace.Audio.ChromaChord @@ -136,11 +131,6 @@ HarmTrace.Audio.Evaluation HarmTrace.Audio.Statistical - HarmTrace.Base.MusicRep - HarmTrace.Base.Parsing - HarmTrace.Base.TypeLevel - - HarmTrace.HAnTree.Binary HarmTrace.HAnTree.HAn HarmTrace.HAnTree.HAnParser HarmTrace.HAnTree.PostProcess @@ -156,6 +146,8 @@ HarmTrace.Models.Models HarmTrace.Models.Parser + HarmTrace.Models.ChordTokens + HarmTrace.Models.TypeLevel HarmTrace.Models.Jazz.Instances HarmTrace.Models.Jazz.Main @@ -164,6 +156,3 @@ HarmTrace.Models.Pop.Instances HarmTrace.Models.Pop.Main HarmTrace.Models.Pop.Model - - HarmTrace.Tokenizer.Tokenizer - HarmTrace.Tokenizer.Tokens diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -9,7 +9,7 @@ , preBuild = preBuild' } -- Runs the testsuite -runTests' _ _ _ _ = system "shelltest tests -c -d" >> return () +runTests' _ _ _ _ = system "shelltest tests -c -d -- --threads=4" >> return () -- Update the VERSION string before building --preBuild' :: Args -> BuildFlags -> IO HookedBuildInfo diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -18,11 +18,12 @@ , displaySampleRate, outputSampleRate, outputBitsPerSample , outputNrOfChannels, keyStr, chromaStr, beatStr , beatVampPath, chromaVampPath, keyVampPath - , deleteDownsampledWav - , defaultVampDir, defaultFeatDir , defaultOutDir - , modulationPenalty, minModulationLength ) where + , deleteDownsampledWav, downSample, defaultLogDir + , defaultVampDir, defaultFeatDir , defaultOutDir, logFileSuffix + , sonicAnnotator, modulationPenalty, minModulationLength + , ChordPrintOpts (..), defaultChordPrinting ) where -import HarmTrace.Audio.ChordTypes (NumData) +import HarmTrace.Base.MusicTime (NumData) -------------------------------------------------------------------------------- -- Constants @@ -33,8 +34,7 @@ vERSION = gitVersion ++ " (master)" gitVersion :: String -gitVersion = "HarmTrace-2.0" - +gitVersion = "HarmTrace-2.0-145-g3a005f7" -------------------------------------------------------------------------------- -- Chord Transcription Parameters @@ -43,7 +43,7 @@ -- | The cutOffProbability is the value that determines the length of the -- probChord list (a sorted list with normalised distances to the chroma vector) cutOffProbability :: NumData -cutOffProbability = 0.90 +cutOffProbability = 0.85 maxProbChordListLength, maxSegmentSize, maxLProductSize :: Int -- | The maximum number if chords (the lenght) of a chord candidate list @@ -95,9 +95,14 @@ -- | Controls whether the downsampled wav file is deleted after feature -- extraction. -deleteDownsampledWav :: Bool +deleteDownsampledWav, downSample :: Bool deleteDownsampledWav = True +-- | Controls whether SoX is used to downsample the audio or whether the +-- audio file is passed to the sonic annotator directly. If 'downSample is +-- set to False, all paramters downsampling parameters will be ignored +downSample = True + -- | The strings that build up a audio feature file name keyStr, chromaStr, beatStr :: String chromaStr = "_vamp_nnls-chroma_nnls-chroma_bothchroma.csv" @@ -113,11 +118,26 @@ -- | specifying the filename of the key-finding chroma VAMP plugin transform file keyVampPath = "tuned-chroma.txt" -defaultVampDir, defaultOutDir, defaultFeatDir :: FilePath +defaultVampDir, defaultLogDir, defaultOutDir, defaultFeatDir :: FilePath -- | The default base directory is the current directory -defaultVampDir = "" +defaultVampDir = "" defaultOutDir = "" +defaultLogDir = "" defaultFeatDir = "" + +-- | By default we assume the sonic-annotator is in the path +sonicAnnotator, logFileSuffix :: String +sonicAnnotator = "sonic-annotator" +logFileSuffix = "extract.log" + +-- | An ennumerator of determining the output format of the chords +data ChordPrintOpts = PrintMajMin | PrintChordClass + +-- | By default we only display major and minor chords to the user (because +-- the transcription quality of these chords is better than that of the +-- chord class). +defaultChordPrinting :: ChordPrintOpts +defaultChordPrinting = PrintMajMin -------------------------------------------------------------------------------- -- Chroma key estimation diff --git a/src/HarmTrace/Audio/Annotate.hs b/src/HarmTrace/Audio/Annotate.hs --- a/src/HarmTrace/Audio/Annotate.hs +++ b/src/HarmTrace/Audio/Annotate.hs @@ -17,25 +17,24 @@ -- knowledge (the HarmTrace harmony model) -------------------------------------------------------------------------------- module HarmTrace.Audio.Annotate ( mptreeAnnotator, groupAnnotator - , simpleAnnotator , putSegStats, preProcessData - , preProcessKeyData ) where + , simpleAnnotator, mptreeAnnotatorSTG + , putSegStats, preProcessData + ) where -- parameters import Constants ( maxSegmentSize, maxLProductSize) -- Audio Stuff import HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync - , mergeByBeat, addBeatTimeStamp - , mergeAndTimeStamp) --- import HarmTrace.Audio.ChromaKey ( syncWithAnnKey) + , mergeByOneAndThree ) import HarmTrace.Audio.Key (getBeatSyncKeyFromChroma) -import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicTime -- 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.Models.ChordTokens import HarmTrace.IO.Errors import HarmTrace.HAnTree.HAn (HAn) import HarmTrace.HAnTree.Tree (Tree, size, depth) @@ -46,73 +45,51 @@ import Text.ParserCombinators.UU.BasicInstances import System.IO (stdout,hFlush) -import Data.List (sortBy, groupBy, zipWith4) +import Data.List (sortBy, groupBy, intersperse) +import Control.Arrow (first) import Text.Printf (printf) -------------------------------------------------------------------------------- -- From chords with probabilities to a single chord, using harmony -------------------------------------------------------------------------------- +mptreeAnnotatorSTG :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat + -> ChordAnnotation +mptreeAnnotatorSTG gex k = snapToGrid . mptreeAnnotator gex k + -- | MPTrEE (Model Propelled Transcription of Euphonic Enitities): -- a sophisticated, harmony and beat informed chord annotator mptreeAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat - -> ChordBeatAnnotation + -> ChordAnnotation 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 +-- chord candidate lists are created. Third, smart, beat informed grouping of +-- the chord candidates is performed. Fourth, 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] +preProcessData gtk af@(AudioFeat chrm beats _afk _id) = + segmentByTonic $ segmentByKey key . mergeByOneAndThree + . createChordRanks $ beatSync beats chrm + where key = maybe (getBeatSyncKeyFromChroma af) id gtk --- reminder: ProbChordSeg = Segment Key [BeatTimedData [ProbChord]] -harmonize :: forall g. (GTree g) => Grammar g -> ProbChordSeg -> ChordBeatAnnotation +-- reminder: ProbChordSeg = Segment Key [TimedData [ProbChord]] +-- | Chord selection based on the harmtrace model +harmonize :: forall g. (GTree g) => Grammar g -> ProbChordSeg + -> ChordAnnotation 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 + myParse :: [ProbChord] -> (Tree HAn,[ProbChord],Float) + myParse cs = + let x = map probChord cs + + -- First, parse the tokens res :: ([g],[Error Int]) res = case g of Jazz -> parse_h ((,) <$> pJazz k <*> pEnd) (createStr 0 x) @@ -123,52 +100,111 @@ 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) + -- Return the Tree HAn, the input tokens, and the error-ratio + in (t, cs, errorRatio (snd res) x ) -- 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) ] + parseResults :: [(Tree HAn,[ProbChord],Float)] + parseResults = [ myParse l + | l <- lProduct (map getData cands) ] -- From all possible parse trees, take the best one - select :: [(Tree HAn,[ChordToken],Float)] -> [ChordToken] + select :: [(Tree HAn,[ProbChord],Float)] -> [ProbChord] 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 :: [(Tree HAn,[ProbChord],Float)] -> [ProbChord] select1 = snd3 . head . sortBy cmp where cmp (a,_,_) (b,_,_) = (size a, depth a) `compare` (size b, depth b) - snd3 (_,a,_) = a + snd3 (_,s,_) = s probChord :: ProbChord -> ChordToken - probChord (ProbChord lab@(Chord r sh _add _on _dur) _p) = + 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 + sh' = toClassType lab - -- 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) + -- replaces the candidate list by the selected chord in a TimedData + setBestChords :: [ProbChord] -> [TimedData ProbChord] + setBestChords = zipWith setData cands -- 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) - +pickHead :: TimedData [ProbChord] -> TimedData ProbChord +pickHead = fmap head + -------------------------------------------------------------------------------- +-- post-processing functions +-------------------------------------------------------------------------------- + +-- snapToGrid :: ChordAnnotation -> ChordAnnotation -- = [TimedData ProbChord] +snapToGrid :: [TimedData ProbChord] -> [TimedData ProbChord] +snapToGrid = foldr snap [] . reduceTimedPChords where + + snap :: TimedData a -> [TimedData a] -> [TimedData a] + snap td [] = [td] + snap a (h : tl) = case ( odd (beatLen a) && odd (beatLen h) , getBeat h ) of + (True, Two ) -> shiftFwd a h ++ tl + (True, Four) -> shiftBwd a h ++ tl + _ -> a : h : tl + + beatLen :: TimedData a -> Int + beatLen = pred . length . getTimeStamps + +-- Shifts the second TimedData backwards in time, lengthing the first TimedData +shiftBwd :: TimedData a -> TimedData a -> [TimedData a] +shiftBwd (TimedData a ta) tdb = case getTimeStamps tdb of + [_on, off] -> [TimedData a (ta ++ [off]) ] + (_hb : hhb : tb) -> [TimedData a (ta ++ [hhb]), tdb{getTimeStamps = (hhb:tb)}] + [_] -> error "HarmTrace.Audio.Annotate.shiftBwd: 1 timestamp, onset == offset" + [ ] -> error "HarmTrace.Audio.Annotate.shiftBwd: No timestamps to shift" + +-- Shifts the second TimedData forwards in time at the cost of the first +shiftFwd :: TimedData a -> TimedData a -> [TimedData a] +shiftFwd tda (TimedData b tb) = case getTimeStamps tda of + [ ] -> error "HarmTrace.Audio.Annotate.shiftFwd: No timestamps to shift" + [_] -> error "HarmTrace.Audio.Annotate.shiftFwd: 1 timestamp, onset == offset" + [on, _off] -> [TimedData b (on : tb) ] + ta -> [tda {getTimeStamps = initTa}, TimedData b (oneButLastTa : tb)] + where + (initTa,oneButLastTa) = snocsnoc ta + + -- takes a list of elements and returns, all elements up to the one-but- + -- last element (discarding the last elem), and the one-but last element + snocsnoc :: [a] -> ([a],a) + snocsnoc [] = error "snocsnoc: empty list" + snocsnoc [_] = error "snocsnoc: singleton list" + snocsnoc [x,_lst] = ([x], x) -- = the one-but-last element + snocsnoc (x:xs) = first (x :) (snocsnoc xs) + +-- | Returns the reduced chord sequences, where repeated chords are merged +-- into one 'ProbChord', wrapped in a 'TimedData' type. +reduceTimedPChords :: [TimedData ProbChord] -> [TimedData ProbChord] +reduceTimedPChords = foldr group [] where + + group :: TimedData ProbChord -> [TimedData ProbChord] -> [TimedData ProbChord] + group c [] = [c] + group tc@(TimedData c tsc ) (th@(TimedData h tsh ) : t) + | c `pChordEq` h = concatTimedData c {prob = avgProb} tc th : t + | otherwise = tc : th : t where + + avgProb :: NumData + avgProb = let ltsc = fromIntegral $ length tsc + ltsh = fromIntegral $ length tsh + tot = ltsc + ltsh + in (prob c * ltsc) + (prob h * ltsh) / tot + + pChordEq :: ProbChord -> ProbChord -> Bool + pChordEq (ProbChord cA _pA) (ProbChord cB _pB) = + chordRoot cA == chordRoot cB && + chordShorthand cA == chordShorthand cB + +-------------------------------------------------------------------------------- -- Segmentation functions -------------------------------------------------------------------------------- -- Temporary test values @@ -184,13 +220,12 @@ -- move to segmentations function in Harmonize? -segmentByKey ::Timed t=>[t Key] -> [BeatTimedData [ProbChord]] -> [ProbChordSeg] +segmentByKey :: [TimedData Key] -> [TimedData [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] @@ -210,8 +245,7 @@ (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 :: Key -> [TimedData [ProbChord]] -> [[TimedData [ProbChord]]] segmentTonic k cands = segment cands [] where segment [] [] = [] segment [] acc = [reverse acc] @@ -222,7 +256,7 @@ -- Take the first chord (which is the one with the highest probability, since -- the list is sorted) -getFstChord :: Timed t => t [ProbChord] -> ChordLabel +getFstChord :: TimedData [ProbChord] -> ChordLabel getFstChord c = case getData c of [] -> error "getFstChord: empty list" (h:_) -> chordLab h -- only split on chords we are certain of @@ -230,21 +264,16 @@ -- Check if this chord label is the tonic isTonic :: ChordLabel -> Key -> Bool -isTonic c (Key r m) = r == chordRoot c && m `eqMode` chordShorthand c +isTonic (Chord (Note Nothing N) _ _ _ _) _ = False +isTonic c (Key r m) = r == chordRoot c && m == toMode (toTriad 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 + && toTriad c == MajTriad --- 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 [] = [] @@ -260,19 +289,28 @@ putSegStats k af = mapM_ segmentStat $ preProcessData k af segmentStat :: ProbChordSeg -> IO () -segmentStat s@(Segment k bs) = - do putStr ("start: " ++ (printf "%.3f" . onset $ head bs)) +segmentStat (Segment k bs) = + do putStr ("\nstart: " ++ (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 + (putStrLn . concat . intersperse "\n" . map showTimedData $ bs) + >> hFlush stdout where + showTimedData :: TimedData [ProbChord] -> String + showTimedData td = + (concat . intersperse ", " . map showProbChord . getData $ td) + ++ ": " ++ ( show . getTimeStamps $ td ) + + showProbChord :: ProbChord -> String + showProbChord (ProbChord lab p) = show lab ++ '@' : printf "%.3f" p + -- 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 :: [TimedData [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 @@ -284,22 +322,17 @@ -- | 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) +groupAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation +groupAnnotator _g _keyAnn (AudioFeat chrm beats _key _id) = -- ignore key info + -- TODO: check is this synchronisation still needed??? + let endTime = BarTime (time $ last chrm) Four beats' = takeWhile (< endTime) beats ++ [endTime] - in map pickHead . mergeByBeat . addBeatTimeStamp beats' . createChordRanks - $ beatSync beats' chrm + in map pickHead . mergeByOneAndThree + . 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 - +simpleAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation +simpleAnnotator _g _keyAnn (AudioFeat crm bts _key _id) = -- ignore key + map pickHead . createChordRanks $ beatSync bts crm diff --git a/src/HarmTrace/Audio/AnnotationParser.hs b/src/HarmTrace/Audio/AnnotationParser.hs --- a/src/HarmTrace/Audio/AnnotationParser.hs +++ b/src/HarmTrace/Audio/AnnotationParser.hs @@ -17,72 +17,49 @@ module HarmTrace.Audio.AnnotationParser ( parseAnnotationData , parseKeyAnnotationData - , preProcess) where - -import Data.Maybe (isJust,fromJust) + ) where import HarmTrace.Audio.DataParser (pNumData) -import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicTime import HarmTrace.Base.MusicRep import HarmTrace.Base.Parsing -import HarmTrace.Tokenizer.Tokenizer ( parseDegrees, parseDegree - , parseRoot , parseShorthand) +import HarmTrace.Base.ChordTokenizer ( pRoot, pChord) -- perhaps this file should be moved to the tokeniser module, because it is -- is very related to tokenising -------------------------------------------------------------------------------- --- Harmonically analysing Chord Annotations --------------------------------------------------------------------------------- - --- | Preprocesses a chord annotation for analysing their harmonic structure by --- removing the time stamps and the None chords. -preProcess :: [TimedData ChordLabel] -> [ChordLabel] -preProcess = preProcess' 0 -preProcess' :: Int -> [TimedData ChordLabel] -> [ChordLabel] -preProcess' _ [] = [] -preProcess' ix (TimedData c@(Chord r sh ad _loc dur) _on _off : ns) - | isNoneChord c = preProcess' ix ns - | otherwise = Chord r sh ad ix dur : preProcess' (ix+1) ns - --------------------------------------------------------------------------------- --- Chords +-- Parse MIREX style chord annotations -------------------------------------------------------------------------------- -- | Parses a chord annotation. -parseAnnotationData :: Parser ChordAnnotation -parseAnnotationData = pListSep_ng pLineEnd pChordSegment <* pLineEnd +parseAnnotationData :: Parser [TimedData ChordLabel] +parseAnnotationData = pListSep_ng pLineEnd pChordSegment <* pLineEnd + <* (pLineEnd `opt` "\n") +-- | Parses the onset, offset and chordlabel on one line pChordSegment :: Parser (TimedData ChordLabel) -pChordSegment = timedData' <$> pNumData <* pSpaceTab - <*> pNumData <* pSpaceTab <*> pChord - - -pChord :: Parser ChordLabel -pChord = f <$> parseRoot <*> pMaybe (pSym ':' *> parseShorthand) - <*> (parseDegrees `opt` []) - -- there might be a basenote inversion annotation - -- which we currently ignore - <*> pMaybe (pSym '/' *> parseDegree) where - -- if there is no root note, there is no chord type - -- Chord root shorthand additions start duration - f r sh _ _ | r == Note Nothing N = Chord r None [] 0 1 - | isJust sh = Chord r (fromJust sh) [] 0 1 - | otherwise = Chord r Maj [] 0 1 +pChordSegment = timedData' <$> pNumData <* pSpaceTab + <*> pNumData <* pSpaceTab + <*> pChord -------------------------------------------------------------------------------- -- Keys -------------------------------------------------------------------------------- -- | Parses a 'Key' annotation. parseKeyAnnotationData :: Parser [TimedData Key] -parseKeyAnnotationData = pListSep_ng pLineEnd pKeySegment <* pLineEnd +parseKeyAnnotationData = noNoneKey <$> pListSep_ng pLineEnd pKeySegment + <* pLineEnd where + -- filter the None keys + noNoneKey = filter ((/= Note Nothing N) . keyRoot . getData) + pKeySegment :: Parser (TimedData Key) pKeySegment = timedData' <$> pNumData <* pSpaceTab <*> pNumData <* pSpaceTab <*> (pKey <|> pKeyNone) pKey :: Parser Key -pKey = Key <$ pString "Key" <* pSpaceTab <*> parseRoot <*> pMode +pKey = Key <$ pString "Key" <* pSpaceTab <*> pRoot <*> pMode pKeyNone :: Parser Key pKeyNone = Key (Note Nothing N) MajMode <$ pString "Silence" @@ -102,7 +79,7 @@ -------------------------------------------------------------------------------- timedData' :: NumData -> NumData -> a -> TimedData a -timedData' on off chrd = TimedData chrd on off +timedData' on off chrd = TimedData chrd [Time on, Time off] pSpaceTab :: Parser Char pSpaceTab = pSym ' ' <|> pSym '\t' diff --git a/src/HarmTrace/Audio/ChordTypes.hs b/src/HarmTrace/Audio/ChordTypes.hs deleted file mode 100644 --- a/src/HarmTrace/Audio/ChordTypes.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --------------------------------------------------------------------------------- --- | --- Module : HarmTrace.Audio.ChordTypes --- 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: A set of types and classes for representing musical chords --- recognised from an arbitrary audio source. --------------------------------------------------------------------------------- - -module HarmTrace.Audio.ChordTypes ( - -- * The 'Timed' class - Timed (..) - - -- * Datatypes - -- ** Types for representing Chords and their probabilities - , ChordBeatAnnotation - , ChordAnnotation - , ProbChordSeg (..) - , ProbChord (..) - , ChordCand (..) - - -- ** Representing musical time - , TimedData (..) - , BeatTimedData (..) - -- , beatTimedData - , Beat (..) - , BeatBar (..) - , BeatBarTrackData - , NumData - - -- ** Representing raw audio data - , AudioFeat (..) - , ChordinoData - , ChordinoLine (..) - , KeyStrengthData - , BeatTrackerData - , BeatChroma - , ChordStruct - - -- * Functions - -- ** Type conversion and other utilities - , getBeatTrack - , getBeat - , setBeat - , nextBeat - , prevBeat - , dumpBeats - , dumpBeat - , timeStamp - , beat - - -- ** miscellaneous - , chromaPC -)where - -import HarmTrace.Base.MusicRep -import Text.Printf (printf) -import Control.DeepSeq - --------------------------------------------------------------------------------- --- High-level structure --------------------------------------------------------------------------------- - --- | Represents a chord transcription, similar to 'ChordAnnotation', but --- 'ChordBeatAnnotation' also contains 'Beat' information. -type ChordBeatAnnotation = [BeatTimedData ChordLabel] - --- | A chord annotation consists of a --- list with chords and segment boundaries. -type ChordAnnotation = [TimedData ChordLabel] - -data TimedData a = TimedData a NumData NumData - --- | A datatype that wraps around an arbitrary datatype, adding (in this order) --- a 'Beat', an onset, and an offset. -data BeatTimedData a = BeatTimedData a Beat NumData NumData - --- | An alternative constructor for a BeatTimedData using two BeatBar datatypes --- instead of a 'Beat' and two 'NumData's. --- beatTimedData :: a -> BeatBar -> BeatBar -> BeatTimedData a --- beatTimedData a on off = let (onnum,onbt) = beatBar on - -- in BeatTimedData a onbt onnum (fst $ beatBar off) - --- | Clustering 'ProbChord's in a collection of chords that share a key -data ProbChordSeg = Segment { segKey :: Key - , segChords :: [BeatTimedData [ProbChord]] } - --- | Combines a 'ChordLabel' with a probability. -data ProbChord = ProbChord {chordLab :: ChordLabel, prob :: NumData} - --- | A chord candidate: an intermediate datatype that matches shorthand, --- chord structure and root note (plus inversion) -data ChordCand = ChordCand { originalRootCC :: Root - , inversionRootCC :: Root - , shorthardCC :: Shorthand - , chordStructCC :: ChordStruct } - deriving Show - -type ChordStruct = [NumData] - --- | For now, we fix the number of available beats to four, because this is also --- hard-coded into the bar and beat-tracker. -data Beat = One | Two | Three | Four deriving (Eq, Enum) - --- | An iterable list of Roots -chromaPC ::[Root] -chromaPC = [ Note Nothing C - , Note (Just Fl) D - , Note Nothing D - , Note (Just Fl) E - , Note Nothing E - , Note Nothing F - , Note (Just Sh) F - , Note Nothing G - , Note (Just Fl) A - , Note Nothing A - , Note (Just Fl) B - , Note Nothing B - ] - --- | 'Timed' provides an interface for datatypes that add (musical) time --- information to other datatypes. Hence, it allows for accessing the fields --- of 'TimedData' and 'BeatTimedData' via the same interface. -class Timed t where - -- | Returns the contained datatype - getData :: t a -> a - -- | Returns the onset time stamp - onset :: t a -> NumData - -- | Returns the offset time stamp - offset :: t a -> NumData - -- | wraps a datatype in 't' - setData :: t a -> b -> t b - -- | Sets the onset time stamp - setOnset :: t a -> NumData -> t a - -- | Sets the offset time stamp - setOffset :: t a -> NumData -> t a - -instance Timed TimedData where - getData (TimedData d _ _ ) = d - onset (TimedData _ on _ ) = on - offset (TimedData _ _ off) = off - setData (TimedData _ on off) d = TimedData d on off - setOnset (TimedData d _ off) on = TimedData d on off - setOffset (TimedData d on _ ) off = TimedData d on off - -instance Timed BeatTimedData where - getData (BeatTimedData d _ _ _ ) = d - onset (BeatTimedData _ _ on _ ) = on - offset (BeatTimedData _ _ _ off) = off - setData (BeatTimedData _ b on off) d = BeatTimedData d b on off - setOnset (BeatTimedData d b _ off) on = BeatTimedData d b on off - setOffset (BeatTimedData d b on _ ) off = BeatTimedData d b on off - --------------------------------------------------------------------------------- --- NFData instances --------------------------------------------------------------------------------- - --- Simplified -instance NFData (TimedData ChordLabel) where - rnf (TimedData a b c) = a `seq` rnf b `seq` rnf c - -instance NFData Beat where - rnf One = () - rnf Two = () - rnf Three = () - rnf Four = () - --------------------------------------------------------------------------------- --- Instances of high-level data structure --------------------------------------------------------------------------------- - -instance Eq (ProbChord) where - a == b = chordLab a == chordLab b - --- TODO remove line-endings from show instances - -instance Show (ProbChord) where - show (ProbChord (Chord r sh _ _ _) p) = - show r ++ ':' : show sh ++ ':' : printf "%.2f" p - -instance Show a => Show (TimedData a) where - show (TimedData bk s l) = show bk ++ " (" ++ show s ++ ':' : show l ++ ")\n" - -instance Show ProbChordSeg where - show pc = concatMap (\x -> show (segKey pc) ++ ' ' : show x) (segChords pc) - -instance Show Beat where - show One = "1" - show Two = "2" - show Three = "3" - show Four = "4" - -instance Show BeatBar where - show = show . beatBar - -instance Show a => Show (BeatTimedData a) where - show (BeatTimedData dat bt on off) = - show bt ++ ';' : show dat ++ ';' : show on ++ ';' : show off ++ "\n" - --------------------------------------------------------------------------------- --- numerical data representation --------------------------------------------------------------------------------- - --- | Groups the three types of VAMP plug-in data: 'ChordinoData', --- 'BeatBarTrackData', and 'KeyStrengthData'. See for more information: --- --- * --- --- * --- --- * -data AudioFeat = AudioFeat { getChroma :: ChordinoData - , getBeats :: BeatBarTrackData - , getKeys :: KeyStrengthData } - -type ChordinoData = [ChordinoLine] - --- | Represents two chroma features and a time stamp. -data ChordinoLine = ChordinoLine - { - -- | Returns the time stamp of the chroma features - time :: NumData - -- | Returns the bass chroma feature - , bass :: [NumData] -- each of the lists has always 12 elements - -- | Returns the treble chroma feature - , treb :: [NumData] -- A, Bb, B, C, Db, D, Eb, E, F, F#, G, Ab - } deriving (Eq, Show) -- and is shifted 3 positions to match C, Db, .., B - -type KeyStrengthData = ChordinoData - -type BeatTrackerData = [NumData] - -newtype BeatBar = BeatBar {beatBar :: (NumData, Beat)} deriving Eq - -type BeatBarTrackData = [BeatBar] - --- | A type synonym is defined for our main numerical representation, this --- allows us to easily change the precision. -type NumData = Double - -type BeatChroma = [[ChordinoLine]] -- one list per beat - --- we compare based on the timestamp only -instance Ord BeatBar where - compare (BeatBar (b1,_)) (BeatBar (b2,_)) = compare b1 b2 - --------------------------------------------------------------------------------- --- Some type conversion utilities --------------------------------------------------------------------------------- - --- | Converts 'BeatBarTrackData' into 'BeatTrackerData' -getBeatTrack :: BeatBarTrackData -> BeatTrackerData -getBeatTrack = map (fst . beatBar) - --- | Provides access to the 'Beat' field of a 'BeatTimedData'. The other fields --- should be accessed by the methods of the 'Timed' class. -getBeat :: BeatTimedData a -> Beat -getBeat (BeatTimedData _ b _ _) = b - --- | Adds 'Beat' information to a 'Timed' datatype -setBeat :: Timed t => t a -> Beat -> BeatTimedData a -setBeat tdat bt = BeatTimedData (getData tdat) bt (onset tdat) (offset tdat) - -nextBeat, prevBeat :: Beat -> Beat --- | returns the next beat, e.g. @ nextBeat Two = Three @. --- Following the (current) definition of 'Beat', we still assume 4/4, in the --- future this function should also have the meter as an argument. -nextBeat Four = One -nextBeat b = succ b - --- | returns the previous 'Beat', similar to 'prevBeat'. -prevBeat One = Four -prevBeat b = pred b - --- | Converts a list of 'BeatTimedData's into a list of 'TimedData's -dumpBeats :: [BeatTimedData a] -> [TimedData a] -dumpBeats = map dumpBeat - --- | Converts a 'BeatTimedData' into a 'TimedData' -dumpBeat :: BeatTimedData a -> TimedData a -dumpBeat (BeatTimedData dat _bt on off) = TimedData dat on off - --- | Returns the time stamp of a 'BeatBar' -timeStamp :: BeatBar -> NumData -timeStamp = fst . beatBar - --- | Returns the 'Beat' of a 'BeatBar' -beat :: BeatBar -> Beat -beat = snd . beatBar diff --git a/src/HarmTrace/Audio/ChromaChord.hs b/src/HarmTrace/Audio/ChromaChord.hs --- a/src/HarmTrace/Audio/ChromaChord.hs +++ b/src/HarmTrace/Audio/ChromaChord.hs @@ -14,8 +14,10 @@ -------------------------------------------------------------------------------- module HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync - , mergeByBeat, addBeatTimeStamp - , mergeAndTimeStamp, meanBeatSyncVectors + -- , mergeByBeat + , meanBeatSyncVectors + , mergeByOneAndThree + -- , addBeatTimeStamp , module Numeric.LinearAlgebra , module Numeric.GSL.Statistics ) where @@ -23,14 +25,14 @@ import Constants (maxProbChordListLength, cutOffProbability) import HarmTrace.Audio.DataParser (shift) -import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicTime import HarmTrace.Base.MusicRep -- import Text.Printf (printf) import Data.List (sortBy,find) -- , elemIndices, minimumBy) -import Data.Maybe (isJust, fromJust, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Ord (comparing) --- import Data.Function (on) +import Data.Functor ((<$>)) -- http://hackage.haskell.org/package/hmatrix import Numeric.LinearAlgebra hiding (find) @@ -40,61 +42,81 @@ -------------------------------------------------------------------------------- -- Matching chords and chroma -------------------------------------------------------------------------------- - --- | Wraps Chord candidate lists into a 'BeatTimedData' structure -addBeatTimeStamp :: [BeatBar] -> [[a]] -> [BeatTimedData [a]] -addBeatTimeStamp = beatTime (BeatBar (0,Four)) where + +-- | 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 - beatTime :: BeatBar -> [BeatBar] -> [[a]] -> [BeatTimedData [a]] + -- 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 (BeatBar (on, onbt)) (next@(BeatBar (off, _)) : bs) (x : xs) = - BeatTimedData x onbt on off : beatTime next bs xs - beatTime _ _ _ = error "addBeatTimeStamp:: asynchronous beats and data" - --- | Given a list of beats, a list of grouped data items, and a merging function --- 'mergeAndTimeStamp' returns a list of 'BeatTimedData'. Before wrapping the --- the grouped data items, e.g. chord candidates, the list is reduced by the --- provided merging function. -mergeAndTimeStamp ::([a] -> a)-> [BeatBar] -> [[a]] -> [BeatTimedData a] -mergeAndTimeStamp f = merge (BeatBar (0,Four)) where - -- merge :: BeatBar -> [BeatBar] -> [[a]] -> [BeatTimedData a] - merge _ [] [] = [] - merge (BeatBar (on, bt)) beats (x : xs) = - let (off : rest) = drop (length x -1) beats - in BeatTimedData (f x) bt on (timeStamp off) : merge off rest xs - merge _ _ _ = error "mergeAndTimeStamp: asynchronous beats and data" - + 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' (specified by 'canMerge'). -mergeByBeat :: [BeatTimedData [ProbChord]] -> [BeatTimedData [ProbChord]] -mergeByBeat [] = [] -mergeByBeat [a] = [a] -mergeByBeat (x:y:xs) - | canMerge (getBeat x) (getBeat y) && isJust xy = mergeByBeat (fromJust xy:xs) - | otherwise = x : mergeByBeat (y:xs) where - xy = merge x y - -- merges two Timed 'ProbChord's using intersectPC (currently in Utils.hs) - merge :: BeatTimedData [ProbChord] -> BeatTimedData [ProbChord] - -> Maybe (BeatTimedData [ProbChord]) - merge a b - | not $ null m = Just (BeatTimedData m (getBeat a) (onset a) (offset b)) - | otherwise = Nothing - where m = intersectPC (getData a) (getData b) - -- specifies which combinations of beats are allowed to merge - canMerge :: Beat -> Beat -> Bool - canMerge One _ = True - canMerge Three _ = True - canMerge _ _ = False +-- 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 = let (a',b') = order a b - in mapMaybe (findAndMergePC a') b' where +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 - findAndMergePC :: [ProbChord] -> ProbChord -> Maybe ProbChord - findAndMergePC pcs pc = case find (== pc) pcs of - (Just pc') -> Just (ProbChord (chordLab pc) (prob pc + prob pc')) + 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 @@ -104,19 +126,6 @@ | length x <= length y = (x,y) | otherwise = (y,x) --- | Synchronises the 'ChordinoData' with the list of beats --- by grouping the 'ChordinoLines' of the 'ChordinoData' in separate lists. -beatSync :: BeatBarTrackData -> ChordinoData -> BeatChroma -beatSync _ [] = [] -beatSync bt (cd:cs) = beatSync' (getBeatTrack bt) [cd] (cd:cs) where - beatSync' :: [NumData] -> [ChordinoLine] -> [ChordinoLine] -> [[ChordinoLine]] - beatSync' _ _ [] = [] - beatSync' [] _ c = [c] - beatSync' (b:bs) prv c -- we also store the previous group in case beat < time - | null x = prv : beatSync' bs prv xs - | otherwise = x : beatSync' bs x xs - where (x, xs) = span ((>=) b . time) c - -------------------------------------------------------------------------------- -- Matrix Functions for matching chords -------------------------------------------------------------------------------- @@ -130,11 +139,12 @@ -- 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 -> [[ProbChord]] +createChordRanks :: [BeatChroma] -> [TimedData [ProbChord]] createChordRanks = - map (selectTop . normalize . sortTake . matchCDictionary). meanBeatSyncVectors + map (selectTop . normalize . sortTake . matchCDictionary <$>) . meanBeatSyncVectors where - sortTake, normalize :: [ProbChord] -> [ProbChord] + -- 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 @@ -150,23 +160,17 @@ -- 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 -meanBeatSyncVectors :: BeatChroma -> [Vector NumData] -- [[ChordinoLine]] -meanBeatSyncVectors = map mean . beatSyncMatrix - --- takes the median of every "beat block" and these Vectors as one Matrix --- Each row of this matrix corresponds to the chroma within one beat --- N.B. does not perform as well as meanBeatSyncVectors --- medianBeatSyncVectors :: BeatChroma -> [Vector NumData] --- medianBeatSyncVectors = - -- map (fromList . map GSL.median . toColumns) . beatSyncMatrix +-- N.B. BeatChroma = BeatTimeData ChordinoLine +meanBeatSyncVectors :: [BeatChroma] -> [TimedData (Vector NumData)] +meanBeatSyncVectors = map (mean <$>) . 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 -> [Matrix NumData] -beatSyncMatrix = map (dropColumns 1 . toChromaMatrix) +beatSyncMatrix :: [BeatChroma] -> [TimedData (Matrix NumData)] +beatSyncMatrix = map (dropColumns 1 . toChromaMatrix <$>) -- converts a ChordinoData into a Matrix -toChromaMatrix :: ChordinoData -> Matrix NumData +toChromaMatrix :: [ChordinoLine] -> Matrix NumData toChromaMatrix = fromLists . map mergeLine where mergeLine :: ChordinoLine -> [NumData] mergeLine (ChordinoLine tm bs tb) = tm : bs ++ tb @@ -181,17 +185,18 @@ matchStruct chroma (ChordCand r _ir None cs) = ProbChord (Chord r None [] 0 1) (pnorm PNorm2 (chroma - fromList (cs ++ cs))) matchStruct chroma (ChordCand r _ir sh cs) = - -- Chord root shorthand degrees description_str repetitions - ProbChord (Chord r sh [] 0 1) (sqrt (bss * bss + treble * treble)) + -- 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 = pnorm PNorm2 (subVector 12 12 chroma - fromList cs) - -- (_ir,bss) = minimumBy (compare `on` snd) . map matchInv $ rootInvs 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, pnorm PNorm2 (subVector 0 12 chroma - bcs)) where - bcs = fromList (pre ++ [1] ++ tail post) + bcs = fromList (pre ++ [1.0] ++ tail post) (pre, post) = splitAt (toSemitone ir) (shortHandToCS None) -- For a given chord structure, compute all possible @@ -223,28 +228,19 @@ mkChordCands :: Int -> [ChordCand] mkChordCands n = [ ChordCand r r sh shiftedCS] where shiftedCS = shift (12-n) cstruct - r = iThRoot n - --- Get the i-th chord root, for 0 <= i < 12 --- For i >= 12, the result is given modulo 12 --- JPM: I actually think this is not necessary because we know that --- 0 <= i < 12, but it makes things safer anyway -iThRoot :: Int -> Root -iThRoot n | n < 0 = error "iThRoot: negative index" - | n >= 0 && n < 12 = chromaPC !! n - | otherwise = iThRoot (n `mod` 12) + 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, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0 ] - Min -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0 ] + -- 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 ] - Sev -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 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 ] diff --git a/src/HarmTrace/Audio/ChromaKey.hs b/src/HarmTrace/Audio/ChromaKey.hs --- a/src/HarmTrace/Audio/ChromaKey.hs +++ b/src/HarmTrace/Audio/ChromaKey.hs @@ -15,47 +15,60 @@ module HarmTrace.Audio.ChromaKey ( beatSyncKeyStrength, keyMap ) where import HarmTrace.Audio.ChromaChord ( Vector, fromList, correlation - , beatSync, meanBeatSyncVectors ) -import HarmTrace.Audio.ChordTypes + , beatSync, meanBeatSyncVectors + ) +import HarmTrace.Base.MusicTime import HarmTrace.Base.MusicRep - -------------------------------------------------------------------------------- -- Chroma key estimation -------------------------------------------------------------------------------- -- | Calculates the beat synchronised key strenght for all -- 24 keys (ordered by 'KeyMap'). -beatSyncKeyStrength :: BeatBarTrackData -> ChordinoData -> [[NumData]] +beatSyncKeyStrength :: BarTimeTrackData -> ChordinoData -> [TimedData [NumData]] beatSyncKeyStrength bts key = - map matchKeyProfiles . meanBeatSyncVectors $ beatSync bts key + map matchKeyProfiles . meanBeatSyncVectors $ beatSync bts key where + + -- canMerge :: Beat -> Beat -> Bool + -- canMerge One Two = True + -- canMerge One Three = True + -- canMerge One Four = True + -- canMerge _ _ = False + -nanToZero :: RealFloat a => a -> a +nanToZero :: Double -> NumData nanToZero n = if isNaN n then 0 else n -matchKeyProfiles :: Vector NumData -> [NumData] +matchKeyProfiles :: TimedData (Vector NumData) -> TimedData [NumData] -- matchKeyProfiles chroma = map (\x -> pnorm PNorm2 (chroma - x)) allKeyProfiles -- matchKeyProfiles crm = map (nanToZero . GSL.correlation crm) allKeyProfiles -matchKeyProfiles crm = map (nanToZero . correlation crm) allKeyProfiles +-- matchKeyProfiles crm = map (nanToZero . correlation crm) allKeyProfiles +matchKeyProfiles = fmap (\x -> map (nanToZero . correlation x) allKeyProfiles) -allKeyProfiles :: [Vector NumData] +allKeyProfiles :: [Vector Double] allKeyProfiles = map (fromList . keyToProfile) keyMap -keyToProfile :: Key -> [NumData] +keyToProfile :: Key -> [Double] keyToProfile (Key root m) = reverseShift (toSemitone root) (selectProfile m) where reverseShift :: Int -> [a] -> [a] reverseShift p l = b ++ a where (a,b) = splitAt (length l - p) l -selectProfile :: Mode -> [NumData] -selectProfile MajMode = krumhanslProfCMaj -selectProfile MinMode = krumhanslProfCMin +selectProfile :: Mode -> [Double] +selectProfile MajMode = temperleyProfCMaj +selectProfile MinMode = temperleyProfCMin -krumhanslProfCMaj, krumhanslProfCMin :: [NumData] -krumhanslProfCMaj = - [6.35, 2.23, 3.48, 2.33, 4.38, 4.09, 2.52, 5.19, 2.39, 3.66, 2.29, 2.88] -krumhanslProfCMin = - [6.33, 2.68, 3.52, 5.38, 2.60, 3.53, 2.54, 4.75, 3.98, 2.69, 3.34, 3.17] +-- krumhanslProfCMaj, krumhanslProfCMin :: [NumData] +-- krumhanslProfCMaj = + -- [6.35, 2.23, 3.48, 2.33, 4.38, 4.09, 2.52, 5.19, 2.39, 3.66, 2.29, 2.88] +-- krumhanslProfCMin = + -- [6.33, 2.68, 3.52, 5.38, 2.60, 3.53, 2.54, 4.75, 3.98, 2.69, 3.34, 3.17] +temperleyProfCMaj, temperleyProfCMin :: [Double] +temperleyProfCMaj = + [5.0, 2.0, 3.5, 2.0, 4.5, 4.0, 2.0, 4.5, 2.0, 3.5, 1.5, 4.0 ] +temperleyProfCMin = + [5.0, 2.0, 3.5, 4.5, 2.0, 4.0, 2.0, 4.5, 3.5, 2.0, 1.5, 4.0 ] -------------------------------------------------------------------------------- -- key strength Matrix Computations -------------------------------------------------------------------------------- diff --git a/src/HarmTrace/Audio/DataParser.hs b/src/HarmTrace/Audio/DataParser.hs --- a/src/HarmTrace/Audio/DataParser.hs +++ b/src/HarmTrace/Audio/DataParser.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall #-} -------------------------------------------------------------------------------- @@ -17,7 +18,7 @@ module HarmTrace.Audio.DataParser ( -- * Parsing beat data parseBeatData - , parseBeatBarData + , parseBarTimeData , pBeat -- * Parsing chromagram data , parseChordinoData @@ -32,7 +33,7 @@ , shift ) where -import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicTime import HarmTrace.Base.Parsing hiding (pComma,pQuotedString,pParentheticalString) -------------------------------------------------------------------------------- @@ -44,11 +45,11 @@ parseBeatData = pListSep_ng pLineEnd pLine <* pLineEnd where pLine = opt pLabel "" *> pNumData <* opt (pComma *> pQuotedString) "" --- | Parses 'BeatBar' data. -parseBeatBarData :: Parser BeatBarTrackData -parseBeatBarData = pListSep_ng pLineEnd pLine <* pLineEnd where - pLine = curry BeatBar <$> (opt pLabel "" *> pNumData ) - <*> (pComma *> pBeat) +-- | Parses 'BarTime' data. +parseBarTimeData :: Parser BarTimeTrackData +parseBarTimeData = pListSep_ng pLineEnd pLine <* pLineEnd where + pLine = BarTime <$> (opt pLabel "" *> pNumData ) + <*> (pComma *> pBeat) -- | Parses a 'Beat'. pBeat :: Parser Beat pBeat = toBeat <$> pQuotedString where @@ -94,6 +95,7 @@ -------------------------------------------------------------------------------- pNumData :: Parser NumData +{-# INLINE pNumData #-} pNumData = pDoubleRaw pComma :: Parser Char diff --git a/src/HarmTrace/Audio/Evaluation.hs b/src/HarmTrace/Audio/Evaluation.hs --- a/src/HarmTrace/Audio/Evaluation.hs +++ b/src/HarmTrace/Audio/Evaluation.hs @@ -8,21 +8,37 @@ -- Stability : experimental -- Portability : non-portable -- --- Summary: Basic parsers for parsing VAMP csv files. +-- Summary: A module for evaluating chord and key annotations -------------------------------------------------------------------------------- + module HarmTrace.Audio.Evaluation ( - relCorrectOverlap, printRelCorrectOverlap + -- * Evaluation functions + relCorrectOverlap + , achievScore + , chordChangeRatio + , avgDistToOne + -- * Chord and key equality functions + , chordTriadEq + , chordClassEq + , majMinEq + -- * Displaying evaluations + , printChordRCO + , printRCO + -- * Sampling + , sample ) where import Constants -import HarmTrace.Audio.ChordTypes -import HarmTrace.Audio.Annotate (preProcessData, preProcessKeyData) +import HarmTrace.Base.MusicTime +import HarmTrace.Audio.Annotate (preProcessData) import HarmTrace.Base.MusicRep -import Data.List (genericLength, zipWith5) +import Data.List (genericLength, zipWith5, foldl') import Text.Printf(printf) import System.IO (stdout,hFlush) +import Data.Foldable (foldrM) +import Control.Monad.State (State, execState, modify) -- TODO this is a parameter and should some how be integrated into Constants.hs -- this functions determines when two chords are considered the same @@ -30,55 +46,148 @@ eqFunc = chordTriadEq -------------------------------------------------------------------------------- --- Evaluation functions +-- Chord and key equality functions -------------------------------------------------------------------------------- --- chordClassEq :: ChordLabel -> ChordLabel -> Bool --- chordClassEq (Chord (Note Nothing N) None _ _ _) - -- (Chord (Note Nothing N) None _ _ _) = True --- chordClassEq (Chord (Note Nothing N) None _ _ _) _ = False --- chordClassEq _ (Chord (Note Nothing N) None _ _ _) = False --- chordClassEq (Chord r1 sh1 _ _ _) (Chord r2 sh2 _ _ _) = - -- (toSemitone r1) == (toSemitone r2) && (toClassType sh1 == toClassType sh2) +-- | Returns True if both 'ChordLabel's are equal at the chord class level: +-- A chord is classified as being major, minor, dominant seventh, or dimished +-- seventh. 'chordClassEq' only returns True if the class of compared chords +-- is the same. "None Chords" match only with other None Chords and +-- with nothing else +chordClassEq :: ChordLabel -> ChordLabel -> Bool +chordClassEq a b = chordRoot a `rootEQ` chordRoot b + && toClassType a == toClassType b +-- | Returns True if both 'ChordLabel's are equal at the triad level: they are +-- either moth major or both minor. "None Chords" match only with other "None +-- Chords" and with nothing else chordTriadEq :: ChordLabel -> ChordLabel -> Bool -chordTriadEq (Chord (Note Nothing N) None _ _ _) - (Chord (Note Nothing N) None _ _ _) = True -chordTriadEq (Chord (Note Nothing N) None _ _ _) _ = False -chordTriadEq _ (Chord (Note Nothing N) None _ _ _) = False -chordTriadEq (Chord r1 sh1 _ _ _) (Chord r2 sh2 _ _ _) = - toSemitone r1 == toSemitone r2 && toMode sh1 == toMode sh2 +chordTriadEq a b = chordRoot a `rootEQ` chordRoot b + && toMajMin (toTriad a) == toMajMin (toTriad b) +-- | Returns True if the 'Root's of the 'Chord's are equal, but the one chord +-- is Major and the other chord is Minor. +majMinEq :: ChordLabel -> ChordLabel -> Bool +majMinEq a b = chordRoot a `rootEQ` chordRoot b + && toTriad a `triadEq` toTriad b where + + -- ingore the NoClass and only return True in case of maj/min and min/maj + triadEq :: Triad -> Triad -> Bool + triadEq x y = case (toMajMin x, toMajMin y) of + (MajClass, MinClass) -> True + (MinClass, MajClass) -> True + _ -> False + + + +-- | enharmonic equality for 'Root' 'Note's, N == N, X == X, and G# == Ab +rootEQ :: Root -> Root -> Bool +rootEQ (Note Nothing X) (Note Nothing X) = True -- two unknown roots +rootEQ (Note Nothing N) (Note Nothing N) = True -- two none roots +rootEQ (Note Nothing X) _ = False -- one unknown root +rootEQ _ (Note Nothing X) = False +rootEQ (Note Nothing N) _ = False -- one none root +rootEQ _ (Note Nothing N) = False +rootEQ a b = toSemitone a == toSemitone b + +-------------------------------------------------------------------------------- +-- Evaluation functions +-------------------------------------------------------------------------------- + -- | Calculates the relative correct overlap, which is the recall -- of matching frames, and defined as the nr of matching frames (sampled at -- an 10 milisecond interval) divided by all frames. -relCorrectOverlap :: ChordAnnotation -> ChordAnnotation -> Double -relCorrectOverlap a b = - foldl countMatch 0 (zipWith eqFunc sama samb) / tot where - sama = sample a - samb = sample b - tot = max (genericLength sama) (genericLength samb) +relCorrectOverlap :: (a -> a -> Bool) -> [TimedData a] -> [TimedData a] + -> Double +relCorrectOverlap eq a b = foldl' countMatch 0 (zipWith eq sama samb) / tot + where sama = sample a + samb = sample b + tot = max (genericLength sama) (genericLength samb) +countMatch :: Double -> Bool -> Double +countMatch x y | y = succ x -- count the number of matching frames + | otherwise = x + +-- | Given a chord annotation sample the chord label at every 10 ms +sample :: [TimedData a]-> [a] +sample = sampleWith evaluationSampleRate + +-- like sample, but takes a sample rate (seconds :: Float) as argument +sampleWith :: NumData -> [TimedData a] -> [a] +sampleWith rate = sampleAt [0.00, rate .. ] + + +-- samples at specific points in time, specified in a list +sampleAt :: [NumData] -> [TimedData a] -> [a] +sampleAt _ [] = [] -- below, will never occur +sampleAt [] _ = error "Harmtrace.Audio.Evaluation: No sampling grid specified" +sampleAt (t:ts) (c:cs) + | t <= offset c = getData c : sampleAt ts (c:cs) + | otherwise = sampleAt (t:ts) cs + +-- | calculates the maximal achievable score given a ground truth annotation +-- and a chord candidate list. +achievScore :: [TimedData ChordLabel] -> [TimedData [ChordLabel]] -> Double +achievScore a b = sum (zipWith eq sama samb) / len + where sama = sample a + samb = sample b + len = min (genericLength sama) (genericLength samb) + eq c cs | foldr (\x -> (chordTriadEq c x ||)) False cs = 1.0 + | otherwise = 0.0 + +-- | calculates the number of chord changes in the ground-truth divided +-- by the number of chord changes in the machine annotation. A number < 1 +-- indicates that the machine annotation misses some chord changes. A number +-- > 1 indicates that the machine annotation finds to many chord sequences. +chordChangeRatio :: (ChordLabel -> ChordLabel -> Bool) + -> [TimedData ChordLabel] -> [TimedData ChordLabel] -> Double +chordChangeRatio eq gt ma = (fromIntegral . countChordChanges $ gt) + / (fromIntegral . countChordChanges $ ma) where + + countChordChanges :: [TimedData ChordLabel] -> Int + countChordChanges cs = execState (foldrM step [] $ dropTimed cs) 0 + + step :: ChordLabel -> [ChordLabel] -> State Int [ChordLabel] + step c [] = do modify succ + return [c] + step a ( b : cs ) + | a `eq` b = return (a : b : cs) + | otherwise = do modify succ + return (a : b : cs) + +-- | The 'chordChangeRatio' is optimal if it is one, but it can be larger or +-- smaller than 1. Therefore, calculating the average blurs the actual result. +-- 'avgDistToOne' takes the absolute difference to 1.0 and averages these for a +-- list of Doubles. +avgDistToOne :: [Double] -> Double +avgDistToOne ds = (sum . map absDistToOne $ ds) / genericLength ds where + + absDistToOne :: Double -> Double + absDistToOne a = abs (1.0 - a) + +-------------------------------------------------------------------------------- +-- Displaying evaluations (all in IO) +-------------------------------------------------------------------------------- + -- | does the same thing as relCorrectOverlap, but it also prints the -- chords and uses a lower sample rate. N.B. the number output by -- 'printRelCorrectOverlap' might differ from the output of -- 'relCorrectOverlap', because a different sample rate might be used (see -- 'Constants'). -printRelCorrectOverlap :: (AudioFeat -> ChordBeatAnnotation) -> AudioFeat - -> ChordAnnotation -> IO Double -printRelCorrectOverlap annotator af@(AudioFeat chrm btbar afk) gt = do - let keys = snd $ preProcessKeyData chrm btbar afk - -- BUG: now alswo when we are evaluating a simple annotator grouping is +printChordRCO :: (AudioFeat -> ChordAnnotation) -> [TimedData Key] + -> AudioFeat -> [TimedData ChordLabel] -> IO Double +printChordRCO annotator key af gt = do + let -- BUG: now alswo when we are evaluating a simple annotator grouping is -- is displayed, this is wrong. printRelCorrectOverlap should -- be independend of the kind of annotator. - blks :: [BeatTimedData [ProbChord]] + blks :: [TimedData [ProbChord]] blks = concatMap segChords $ preProcessData Nothing af -- sample the info for printing and evaluation - samaf = sampleWith displaySampleRate (annotator af) + samaf = sampleWith displaySampleRate (dropProb . annotator $ af) samgt = sampleWith displaySampleRate gt sambk = sampleWith displaySampleRate blks - samk = sampleWith displaySampleRate keys + samk = sampleWith displaySampleRate key tot = max (genericLength samaf) (genericLength samgt) showEq m = if m then "==" else "/=" @@ -91,28 +200,26 @@ return equal where equal = g `eqFunc` a putStrLn "time\tmatch\tGT\t\tMPTREE\tkey\toptional chords" m <- sequence (zipWith5 printEval [0.0,displaySampleRate ..] - samgt samaf samk sambk) + samgt + samaf + samk + sambk) return (foldl countMatch 0 m / tot) - -countMatch :: Double -> Bool -> Double -countMatch x y | y = succ x -- count the number of matching frames - | otherwise = x - --- given a chord annotation sample the chord label at every 10 ms -sample :: Timed t => [t a] -> [a] -sample = sampleWith evaluationSampleRate - --- like sample, but takes a sample rate (seconds :: Float) as argument -sampleWith :: Timed t => NumData -> [t a] -> [a] -sampleWith rate = sampleAt [0.00, rate .. ] - - --- samples at specific points in time, specified in a list -sampleAt :: Timed t => [NumData] -> [t a] -> [a] -sampleAt _ [] = [] -- below, will never occur -sampleAt [] _ = error "Harmtrace.Audio.Evaluation: No sampling grid specified" -sampleAt (t:ts) (c:cs) - | t <= offset c = getData c : sampleAt ts (c:cs) - | otherwise = sampleAt (t:ts) cs + + +-- | Calculates the relative correct overlap, which is the recall +-- of matching frames, and defined as the nr of matching frames (sampled at +-- an interval set in 'HarnTrace.Constants' divided by all frames. +-- This functions difers from 'relCorrectOverlap' in that it uses an +-- equality function that is in IO. +printRCO :: (a -> a -> IO (Bool)) -> [TimedData a] -> [TimedData a] + -> IO (Double) +printRCO ioeq a b = do matches <- sequence (zipWith3 printEq [0,displaySampleRate ..] sama samb) + return (foldl' countMatch 0 matches / tot) + where sama = sampleWith displaySampleRate a + samb = sampleWith displaySampleRate b + tot = max (genericLength sama) (genericLength samb) - + -- printEq :: NumData -> a -> a -> IO (Bool) + printEq ts x y = do putStr (printf "%.2f: " ts) + ioeq x y diff --git a/src/HarmTrace/Audio/Key.hs b/src/HarmTrace/Audio/Key.hs --- a/src/HarmTrace/Audio/Key.hs +++ b/src/HarmTrace/Audio/Key.hs @@ -16,7 +16,7 @@ module HarmTrace.Audio.Key (getBeatSyncKeyFromChroma) where -import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicTime import HarmTrace.Audio.Statistical (groupMinSize, mode) import HarmTrace.Audio.ChromaKey ( beatSyncKeyStrength, keyMap) import HarmTrace.Base.MusicRep @@ -37,18 +37,41 @@ -------------------------------------------------------------------------------- -- | Returns a 'Key' key assignment, given 'Beat' and chroma information. -getBeatSyncKeyFromChroma :: [BeatBar] -> [ChordinoLine] -> [[Key]] -getBeatSyncKeyFromChroma bts key = - groupKeys . getKeyFromTable $ selectKey bts key +-- N.B. The beats and chroma do not have to be synchronised, they will be +-- sychronised in the process of finding the key +-- (see 'Harmtrace.Audio.ChromaKey' and 'Harmtrace.Audio.ChromaChord.BeatSync') +getBeatSyncKeyFromChroma :: AudioFeat -> [TimedData Key] +getBeatSyncKeyFromChroma (AudioFeat _cs bt key _id) = + mergeAndTimeStamp fstBeat syncbt + . groupKeys . getKeyFromTable . selectKey $ beatSyncKeyStrength bt key where -selectKey :: [BeatBar] -> [ChordinoLine] -> Vector (Vector (Int, NumData)) -selectKey _bts [] = empty -selectKey [] _key = empty -selectKey bts key = k where + -- This synchronisation is ugly, but necessary... + -- keyStr = beatSyncKeyStrength bt key + fstBeat = BarTime 0 (prevBeat . beat . L.head $ bt) + lstBeat = BarTime (time . L.last $ key) (nextBeat . beat . L.last $ bt) + syncbt = L.takeWhile (< lstBeat) bt L.++ [lstBeat] + + -- | Given a list of beats, a list of grouped data items, and a merging function + -- 'mergeAndTimeStamp' returns a list of 'BeatTimedData'. Before wrapping the + -- the grouped data items, e.g. chord candidates, the list is reduced by the + -- provided merging function. + mergeAndTimeStamp :: BarTime -> [BarTime] -> [[a]] -> [TimedData a] + mergeAndTimeStamp _ [] [] = [] + mergeAndTimeStamp on beats (x : xs) = + let (off : rest) = L.drop (L.length x -1) beats + in TimedData (L.head x) [on, off] : mergeAndTimeStamp off rest xs + mergeAndTimeStamp _ _ _ = error "mergeAndTimeStamp: asynchronous beats and data" + + +-- selectKey :: [BarTime] -> [ChordinoLine] -> Vector (Vector (Int, NumData)) +selectKey :: [TimedData [NumData]] -> Vector (Vector (Int, NumData)) +selectKey [] = empty +-- selectKey [] _key = empty +selectKey key = k where -- start by calculating the beat synchronised key strenght for all -- 24 keys (ordered by HarmTrace.Audio.ChromaKey.keyMap) m :: Vector (Vector NumData) - m = fromList . L.map fromList $ beatSyncKeyStrength bts key + m = fromList . L.map fromList $ dropTimed key -- calculate for every beat the maximum key (the index) and the -- profile correlation (snd) @@ -87,24 +110,26 @@ -- key assignments getKeyFromTable :: Vector (Vector (Int, NumData)) -> [Key] getKeyFromTable k = L.map (keyMap !!) (L.reverse yek) where - yek = collectMax (fst $ maximumBy (comparing snd) (last k)) (reverse k) + yek = collectMax (getMax $ last k) (reverse k) -- given the table calulated with selectKey, this function calculates -- the actual key assignment for every beat collectMax :: Int -> Vector (Vector (Int, NumData)) -> [Int] collectMax startj l | null l = [] - | otherwise = fst (head l ! startj) : collectMax m (tail l) where - m = fst $ maximumBy (comparing snd) (head l) + | otherwise = fst (head l ! startj) : collectMax (getMax $ head l) (tail l) + + getMax :: Vector (Int, NumData) -> Int + getMax = fst . maximumBy (comparing snd) -- debugging: --- printKeyTable :: [BeatBar] -> [ChordinoLine] -> IO () +-- printKeyTable :: [BarTime] -> [ChordinoLine] -> IO () -- printKeyTable bts chrm = -- let showLn :: Vector (Int, NumData) -> IO () -- showLn x = do mapM_ (\(i,f) -> putStr (printf "(%d, %.2f)" i f)) x -- putStr "\n" -- in mapM_ showLn $ selectKey bts chrm --- naiveBeatSyncKey :: BeatBarTrackData -> [ChordinoLine] -> [Key] +-- naiveBeatSyncKey :: BarTimeTrackData -> [ChordinoLine] -> [Key] -- naiveBeatSyncKey bts key = -- L.map (((!!) keyMap) . maxListIndex) $ beatSyncKeyStrenth bts key diff --git a/src/HarmTrace/Audio/Statistical.hs b/src/HarmTrace/Audio/Statistical.hs --- a/src/HarmTrace/Audio/Statistical.hs +++ b/src/HarmTrace/Audio/Statistical.hs @@ -13,7 +13,7 @@ -------------------------------------------------------------------------------- module HarmTrace.Audio.Statistical where -import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicTime import Data.List ( genericLength, tails , inits,maximumBy, sort, group) diff --git a/src/HarmTrace/Base/MusicRep.hs b/src/HarmTrace/Base/MusicRep.hs deleted file mode 100644 --- a/src/HarmTrace/Base/MusicRep.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Base.MusicRep where - -import Data.Maybe -import Data.List (elemIndex, intersperse, intercalate) -import Control.DeepSeq -import HarmTrace.HAnTree.Binary -import Generics.Instant.TH -import Data.Binary - --------------------------------------------------------------------------------- --- Representing musical information at the value level --------------------------------------------------------------------------------- - --- Keys (at the value level) -data Key = Key { keyRoot :: Root, keyMode :: Mode } deriving (Eq, Ord) -data Mode = MajMode | MinMode deriving (Eq, Ord) - -instance NFData Mode where - rnf MinMode = () - rnf MajMode = () - -type ChordLabel = Chord Root -type ChordDegree = Chord ScaleDegree - --- the representation for a single tokenized chord -data Chord a = Chord { chordRoot :: a - , chordShorthand :: Shorthand - , chordAdditions :: [Addition] - , getLoc :: Int -- the index of the chord - , duration :: Int -- in the list of tokens - } - -data Class = Class ClassType Shorthand - -data ClassType = MajClass | MinClass | DomClass | DimClass | NoClass - deriving (Eq) - -data Shorthand = -- Triad chords - Maj | Min | Dim | Aug - -- Seventh chords - | Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7 - -- Sixth chords - | Maj6 | Min6 - -- Extended chords - | Nin | Maj9 | Min9 - -- Suspended chords - | Sus4 | Sus2 - -- In some cases there is no chord a certain position - -- This is especially important for the chroma processing - | None - deriving (Show, Eq, Enum, Bounded) - - --- Key relative scale degrees to abstract from the absolute Root notes -type ScaleDegree = Note DiatonicDegree - -data DiatonicDegree = I | II | III | IV | V | VI | VII | Imp - deriving (Show, Eq, Enum, Ord, Bounded) - --- Representing absolute root notes -type Root = Note DiatonicNatural - -data DiatonicNatural = C | D | E | F | G | A | B | N -- N is for no root - deriving (Show, Eq, Enum, Ord, Bounded) - --- Intervals for additonal chord notes -type Addition = Note Interval - -data Interval = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10 - | I11 | I12 | I13 - deriving (Eq, Enum, Ord, Bounded) - -data Note a = Note (Maybe Modifier) a deriving (Eq, Ord) - -data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat - deriving (Eq, Ord) - --------------------------------------------------------------------------------- --- Instances for the general music datatypes --------------------------------------------------------------------------------- - -instance Show Key where - show (Key r m) = show r ++ show m - -instance Show Mode where - show MajMode = "" - show MinMode = "m" - -instance Eq a => Eq (Chord a) where - (Chord ra sha dega _loc _d) == (Chord rb shb degb _locb _db) - = ra == rb && sha == shb && dega == degb - -instance (Show a) => Show (Chord a) where - show (Chord r sh deg _loc _d) = show r ++ ':' : show sh - ++ (if not (null deg) then showAdds deg else "") - -- ++ '_' : show loc ++ ':' : show d - -showAdds :: Show a => [a] -> String -showAdds x = '(' : intercalate "," (map show x) ++ ")" - -instance Show Class where show (Class ct _) = show ct - -instance Show ClassType where - show MajClass = "" - show MinClass = "m" - show DomClass = "7" - show DimClass = "0" - show NoClass = "N" - -instance (Show a) => Show (Note a) where - show (Note m interval) = show interval ++ maybe "" show m - -instance Show Interval where - show a = show . ((!!) ([1..13]::[Integer])) - . fromJust $ elemIndex a [minBound..] - - -instance Show Modifier where - show Sh = "#" - show Fl = "b" - show SS = "##" - show FF = "bb" - --- for showing additional additions -showAdditions :: [Addition] -> String -showAdditions a - | null a = "" - | otherwise = "(" ++ concat (intersperse "," (map show a)) ++ ")" - --------------------------------------------------------------------------------- --- Utils --------------------------------------------------------------------------------- - -isNone :: Root -> Bool -isNone (Note _ N) = True -isNone _ = False - -noneLabel :: ChordLabel -noneLabel = (Chord (Note Nothing N) None [] 0 0) - -isNoneChord :: ChordLabel -> Bool -isNoneChord (Chord (Note _ N) _ _ _ _) = True -isNoneChord (Chord _ None _ _ _) = True -isNoneChord _ = False - -toClassType :: Shorthand -> ClassType -toClassType sh - | sh `elem` [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4,Sus2] = MajClass - | sh `elem` [Min,Min7,Min6,Min9,HDim7] = MinClass - | sh `elem` [Sev,Nin,Aug] = DomClass - | sh `elem` [Dim,Dim7] = DimClass - | otherwise = error - ("HarmTrace.Base.MusicRep.toClassType: unknown shorthand: " ++ show sh) - -toMode :: Shorthand -> Mode -toMode Maj = MajMode -toMode Min = MinMode -toMode Dim = MinMode -toMode Aug = MajMode -toMode Maj7 = MajMode -toMode Min7 = MinMode -toMode Sev = MajMode -toMode Dim7 = MinMode -toMode HDim7 = MinMode -toMode MinMaj7 = MinMode -toMode Maj6 = MajMode -toMode Min6 = MinMode -toMode Nin = MajMode -toMode Maj9 = MajMode -toMode Min9 = MinMode -toMode Sus4 = MinMode -- for now -toMode Sus2 = MinMode -- for now -toMode m = error - ("HarmTrace.Base.MusicRep.toMode: unknown shorthand: " ++ show m) - --------------------------------------------------------------------------------- --- Value Level Scale Degree Transposition --------------------------------------------------------------------------------- - --- Chord root shorthand degrees location duration -toChordDegree :: Key -> ChordLabel -> ChordDegree -toChordDegree k (Chord r sh degs loc d) = - Chord (toScaleDegree k r) sh degs loc d - -toScaleDegree :: Key -> Root -> ScaleDegree -toScaleDegree _ n@(Note _ N) = - error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose" ++ show n) -toScaleDegree (Key kr _) cr = -- Note Nothing I - scaleDegrees!!(((toSemitone cr) - (toSemitone kr)) `mod` 12) - --- transposes a degree with sem semitones up -transposeSem :: ScaleDegree -> Int -> ScaleDegree -transposeSem deg sem = scaleDegrees!!((sem + (toSemitone deg)) `mod` 12) where - --- gives the semitone value [0,11] of a Degree, e.g. F# = 6 -toSemitone :: (Show a, Enum a) => Note a -> Int -toSemitone (Note m p) - | ix > 6 = error ("HarmTrace.Base.MusicRep.toSemitone: no semitone for" - ++ show (Note m p)) - | otherwise = ([0,2,4,5,7,9,11] !! ix) + modToSemi m where - ix = fromEnum p - --- transforms type-level modifiers to semitones (Int values) -modToSemi :: Maybe Modifier -> Int -modToSemi Nothing = 0 -modToSemi (Just Sh) = 1 -modToSemi (Just Fl) = -1 -modToSemi (Just SS) = 2 -modToSemi (Just FF) = -2 - -scaleDegrees ::[ScaleDegree] -scaleDegrees = [ Note Nothing I - , Note (Just Fl) II - , Note Nothing II - , Note (Just Fl) III - , Note Nothing III - , Note Nothing IV - , Note (Just Sh) IV - , Note Nothing V - , Note (Just Fl) VI - , Note Nothing VI - , Note (Just Fl) VII - , Note Nothing VII - ] - --------------------------------------------------------------------------------- --- Binary instances --------------------------------------------------------------------------------- - -deriveAllL [''Note, ''DiatonicDegree - , ''Mode, ''Chord, ''DiatonicNatural, ''ClassType - , ''Modifier, ''Shorthand, ''Interval] - -instance (Binary a) => Binary (Note a) where - put = putDefault - get = getDefault -instance Binary DiatonicDegree where - put = putDefault - get = getDefault -instance Binary Mode where - put = putDefault - get = getDefault -instance (Binary a) => Binary (Chord a) where - put = putDefault - get = getDefault -instance Binary DiatonicNatural where - put = putDefault - get = getDefault -instance Binary ClassType where - put = putDefault - get = getDefault -instance Binary Modifier where - put = putDefault - get = getDefault -instance Binary Shorthand where - put = putDefault - get = getDefault -instance Binary Interval where - put = putDefault - get = getDefault diff --git a/src/HarmTrace/Base/Parsing.hs b/src/HarmTrace/Base/Parsing.hs deleted file mode 100644 --- a/src/HarmTrace/Base/Parsing.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -Wall #-} - -module HarmTrace.Base.Parsing ( parseData, parseDataWithErrors - , pString, pLineEnd, pManyTill - , module Data.ListLike.Base - , module Text.ParserCombinators.UU - , module Text.ParserCombinators.UU.Utils - , module Text.ParserCombinators.UU.BasicInstances - ) where - -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.Utils hiding (pSpaces) -import Text.ParserCombinators.UU.BasicInstances hiding (IsLocationUpdatedBy) -import Data.ListLike.Base (ListLike) - --------------------------------------------------------------------------------- --- A collection of parsing functions used by parsers throughout the project --------------------------------------------------------------------------------- - --- toplevel parsers -parseData :: (ListLike s a, Show a) => P (Str a s LineColPos) b -> s -> b -parseData p inp = fst ( parseDataWithErrors p inp ) - -parseDataWithErrors :: (ListLike s a, Show a) - => P (Str a s LineColPos) b -> s -> (b, [Error LineColPos]) -parseDataWithErrors p inp = (parse ( (,) <$> p <*> pEnd) - (createStr (LineColPos 0 0 0) inp)) - --- parses specific string -pString :: (ListLike state a, IsLocationUpdatedBy loc a, Show a, Eq a) - => [a] -> P (Str a state loc) [a] -pString s = foldr (\a b -> (:) <$> a <*> b) (pure []) (map pSym s) - --- parses whitespace (@pedro: should probably not contain '\n') --- pSpaces :: Parser Char --- pSpaces = pAnySym [' ','\n','\t'] - --- parses UNIX and DOS/WINDOWS line endings -pLineEnd :: Parser String -pLineEnd = pString "\n" <|> pString "\r\n" <|> pString " " <|> pString "\t" - -pManyTill :: P st a -> P st b -> P st [a] -pManyTill p end = [] <$ end - <<|> - (:) <$> p <*> pManyTill p end - diff --git a/src/HarmTrace/Base/TypeLevel.hs b/src/HarmTrace/Base/TypeLevel.hs deleted file mode 100644 --- a/src/HarmTrace/Base/TypeLevel.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module HarmTrace.Base.TypeLevel ( - Su, Ze - , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10 - , T11, T12, T13, T14, T15, T16, T17, T18, T19, T20 - , ToNat(..) - ) where - -import Data.Typeable - - --- Type level peano naturals -data Su :: * -> * deriving Typeable -data Ze :: * deriving Typeable - --- Some shorthands -type T0 = Ze -type T1 = Su T0 -type T2 = Su T1 -type T3 = Su T2 -type T4 = Su T3 -type T5 = Su T4 -type T6 = Su T5 -type T7 = Su T6 -type T8 = Su T7 -type T9 = Su T8 -type T10 = Su T9 -type T11 = Su T10 -type T12 = Su T11 -type T13 = Su T12 -type T14 = Su T13 -type T15 = Su T14 -type T16 = Su T15 -type T17 = Su T16 -type T18 = Su T17 -type T19 = Su T18 -type T20 = Su T19 - -class ToNat n where - toNat :: n -> Int - -instance ToNat Ze where toNat _ = 0 -instance (ToNat n) => ToNat (Su n) where toNat _ = 1 + toNat (undefined :: n) -{- --- Below is some experimentation... - --- A degree has a distance to root in semi-tones (n in T0..T11) and a --- class (major or minor) -data Degree n cls - --- Transposing is a bit like addition... -type family Transpose m n --- ... but we normalize at the end to stay within T0..T11 -type instance Transpose m T0 = Norm m -type instance Transpose m (Su n) = Transpose (Su m) n - --- Normalizing is the same as subtracting T12, but only if we can. Else we keep --- the type unchanged. -type Norm m = Sub m T12 m - --- Subtraction with an extra type for failure -type family Sub m n fail --- Inductive case -type instance Sub (Su m) (Su n) fail = Sub m n fail --- Base case, subtraction succeeded -type instance Sub m T0 fail = m --- Base case, subtraction failed -type instance Sub T0 (Su n) fail = fail - --- A secondary dominant is a transposition by 7 semi-tones -type SD deg = Transpose deg T7 - --- A tritone substitution is a transposition by 6 semi-tones -type TS deg = Transpose deg T6 --} diff --git a/src/HarmTrace/HAnTree/Binary.hs b/src/HarmTrace/HAnTree/Binary.hs deleted file mode 100644 --- a/src/HarmTrace/HAnTree/Binary.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} - --- Generic Binary - -module HarmTrace.HAnTree.Binary where - -import Control.Monad (liftM, liftM2) -import Data.Binary -import Generics.Instant - - -class GBinary a where - gput :: a -> Put - gget :: Get a - - -instance GBinary U where - gput _ = return () - gget = return U - -instance (GBinary a) => GBinary (CEq c p p a) where - gput (C a) = gput a - gget = liftM C gget -{- -instance (GBinary a) => GBinary (CEq c p q a) where - gput _ = return () - gget = error "gget: CEq impossible" --} -instance (GBinary a, GBinary b) => GBinary (a :+: b) where - gput (L a) = put (0 :: Word8) >> gput a - gput (R a) = put (1 :: Word8) >> gput a - gget = do t <- get :: Get Word8 - case t of - 0 -> liftM L gget - 1 -> liftM R gget - _ -> error "gget: :+: impossible" - -instance (GBinary a, GBinary b) => GBinary (a :*: b) where - gput (a :*: b) = gput a >> gput b - gget = liftM2 (:*:) gget gget - -instance (Binary a) => GBinary (Rec a) where - gput (Rec a) = put a - gget = liftM Rec get - -instance (Binary a) => GBinary (Var a) where - gput (Var a) = put a - gget = liftM Var get - - --- Default implementations -getDefault :: (Representable a, GBinary (Rep a)) => Get a -getDefault = fmap to gget - -putDefault :: (Representable a, GBinary (Rep a)) => a -> Put -putDefault = gput . from diff --git a/src/HarmTrace/HAnTree/HAn.hs b/src/HarmTrace/HAnTree/HAn.hs --- a/src/HarmTrace/HAnTree/HAn.hs +++ b/src/HarmTrace/HAnTree/HAn.hs @@ -2,16 +2,16 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} module HarmTrace.HAnTree.HAn where import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens -import HarmTrace.HAnTree.Binary +import HarmTrace.Models.ChordTokens -import Generics.Instant.TH import Control.DeepSeq import Data.Binary +import GHC.Generics (Generic) -------------------------------------------------------------------------------- -- Datatypes for representing Harmonic Analyses (at the value level) @@ -22,7 +22,8 @@ | HAnFunc !HFunc | HAnPrep !Prep | HAnTrans !Trans - | HAnChord !ChordToken + | HAnChord !ChordToken + deriving Generic -- duration Mode constructor_ix specials data HFunc = Ton !Int !Mode !Int !(Maybe Spec) @@ -30,44 +31,35 @@ | Sub !Int !Mode !Int !(Maybe Spec) | P | PD - | PT + | PT + deriving Generic data Spec = Blues | MinBorrow | Parallel - deriving Eq + deriving (Eq, Generic) -- Preparations, like secondary dominants etc. that cause a "split" in the tree data Prep = SecDom !Int !ScaleDegree -- "V/X" | SecMin !Int !ScaleDegree -- "v/X" | DiatDom !Int !ScaleDegree -- "Vd" | NoPrep + deriving Generic -- Scalde degree transformations, e.g. tritone substitutions etc. data Trans = Trit !Int !ScaleDegree -- "bII/X" | DimTrit !Int !ScaleDegree -- "bIIb9/X" | DimTrans !Int !ScaleDegree -- "VII0" | NoTrans + deriving Generic -------------------------------------------------------------------------------- -- Binary instances -------------------------------------------------------------------------------- -deriveAllL [ ''HAn, ''Trans, ''Prep, ''HFunc, ''Spec] - -instance Binary HAn where - put = putDefault - get = getDefault -instance Binary Trans where - put = putDefault - get = getDefault -instance Binary Prep where - put = putDefault - get = getDefault -instance Binary HFunc where - put = putDefault - get = getDefault -instance Binary Spec where - put = putDefault - get = getDefault +instance Binary HAn +instance Binary Trans +instance Binary Prep +instance Binary HFunc +instance Binary Spec -------------------------------------------------------------------------------- -- NFData instances diff --git a/src/HarmTrace/HAnTree/PostProcess.hs b/src/HarmTrace/HAnTree/PostProcess.hs --- a/src/HarmTrace/HAnTree/PostProcess.hs +++ b/src/HarmTrace/HAnTree/PostProcess.hs @@ -4,7 +4,7 @@ , mergeDelChords ) where import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens as CT +import HarmTrace.Models.ChordTokens as CT import HarmTrace.HAnTree.HAn import HarmTrace.HAnTree.Tree @@ -76,7 +76,7 @@ toDelHAn :: Key -> [ChordLabel] -> [Tree HAn] toDelHAn key m = map f m where f c@(Chord r sh _add _loc d) = (Node (HAnChord - (ChordToken (toScaleDegree key r) (toClassType sh) [c] CT.Deleted 1 d)) + (ChordToken (toScaleDegree key r) (toClassType c) [c] CT.Deleted 1 d)) [] Nothing) -- returns the deleted chords, given a list of errors and the input tokes diff --git a/src/HarmTrace/HarmTrace.hs b/src/HarmTrace/HarmTrace.hs --- a/src/HarmTrace/HarmTrace.hs +++ b/src/HarmTrace/HarmTrace.hs @@ -14,17 +14,17 @@ import HarmTrace.HAnTree.HAn (HFunc (P)) import HarmTrace.HAnTree.PostProcess import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Tokenizer.Tokenizer +import HarmTrace.Models.ChordTokens as CT +import HarmTrace.Base.ChordTokenizer import Data.Ord (comparing) import Data.List (minimumBy) -- Audio/Annotation Stuff import HarmTrace.Audio.AnnotationParser -import HarmTrace.Audio.ChordTypes import HarmTrace.Base.Parsing (parseDataWithErrors) +import HarmTrace.Base.MusicTime (dropTimed, getData) -- Parser stuff import Text.ParserCombinators.UU @@ -75,7 +75,7 @@ -- taken (on tokenizing and on musical recognition). string2Piece :: Grammar g -> String -> ParseResult g string2Piece g s = let - (PieceLabel key tok, err) = parse ((,) <$> parseSongAbs <*> pEnd) + (PieceLabel key tok, err) = parse ((,) <$> pSongAbs <*> pEnd) (createStr (LineColPos 0 0 0) s) (trees, err2) = case g of Jazz -> parse_h ((,) <$> pJazz key <*> pEnd) @@ -94,7 +94,7 @@ (ks , errK) = parseDataWithErrors parseKeyAnnotationData kstr key = getData . head $ filter (not . isNone . keyRoot . getData) ks (tok, errT) = parseDataWithErrors parseAnnotationData cstr - ppTok = preProcess tok + ppTok = dropTimed tok (ts, errP) = case g of Jazz -> parse_h ((,) <$> pJazz key <*> pEnd) (createStr 0 (toKeyRelTok key ppTok)) diff --git a/src/HarmTrace/IO/BasePaths.hs b/src/HarmTrace/IO/BasePaths.hs --- a/src/HarmTrace/IO/BasePaths.hs +++ b/src/HarmTrace/IO/BasePaths.hs @@ -1,19 +1,19 @@ -module HarmTrace.IO.BasePaths ( BasePaths, setPaths - , consBasePaths, basePathsExist - , getVampDir, getFeatDir , getOutDir - , getBeatVampPath, getChromaVampPath - , getKeyVampPath) where +module HarmTrace.IO.BasePaths ( BasePaths (..), setPaths, getLogFile + , consBasePaths, basePathsExist) where -import System.FilePath (()) +import System.FilePath ((), (<.>), takeFileName) import HarmTrace.IO.Common (fileExists, dirExists) -import Constants ( defaultVampDir, defaultOutDir, defaultFeatDir - , beatVampPath, chromaVampPath, keyVampPath) +import Constants ( defaultVampDir, defaultOutDir, defaultFeatDir, defaultLogDir + , beatVampPath, chromaVampPath, keyVampPath + , sonicAnnotator, logFileSuffix) -- | A datatype for storing the base directories of the vamp plugins, feature -- csv files, and the chord and log Files. data BasePaths = BasePaths { getVampDir :: FilePath , getFeatDir :: FilePath , getOutDir :: FilePath + , getLogDir :: FilePath + , getSonic :: FilePath , getBeatVampPath :: FilePath , getChromaVampPath :: FilePath , getKeyVampPath :: FilePath @@ -21,17 +21,21 @@ -- | Similar to 'consBasePaths', but instead excepts 'Maybe FilePath's instead -- of 'FilePath's -setPaths :: Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> BasePaths -setPaths mv mf mo = +setPaths :: Maybe FilePath -> Maybe FilePath -> Maybe FilePath + -> Maybe FilePath -> Maybe FilePath -> BasePaths +setPaths mv mf mo ml msa = let vamp = maybe defaultVampDir id mv feat = maybe defaultFeatDir id mf out = maybe defaultOutDir id mo - in consBasePaths vamp feat out + logd = maybe defaultLogDir id ml + sa = maybe sonicAnnotator id msa -- there is a specific function without id, but hackage is down + in consBasePaths vamp feat out logd sa -- | contructs a new 'BasePaths' based on a VAMP transform directory, -- a feature directory (to store the CSV files), and an output directory. -consBasePaths :: FilePath -> FilePath -> FilePath -> BasePaths -consBasePaths vamp feat out = BasePaths vamp feat out +consBasePaths :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath + -> BasePaths +consBasePaths vamp feat out logd sa = BasePaths vamp feat out logd sa (vamp beatVampPath) (vamp chromaVampPath) (vamp keyVampPath) -- | checks (verbosely) if the paths stored in a 'BaseDir' exist. @@ -39,6 +43,10 @@ basePathsExist dirs = do v <- fileExists (getBeatVampPath dirs) c <- fileExists (getChromaVampPath dirs) k <- fileExists (getKeyVampPath dirs) + -- l <- fileExists (getLogDir dirs) f <- dirExists (getFeatDir dirs) o <- dirExists (getOutDir dirs) - return (v && c && k && f && o) + return (v && c && k && f && o) + +getLogFile :: BasePaths -> FilePath -> FilePath +getLogFile bp fp = getLogDir bp takeFileName fp <.> logFileSuffix diff --git a/src/HarmTrace/IO/Common.hs b/src/HarmTrace/IO/Common.hs --- a/src/HarmTrace/IO/Common.hs +++ b/src/HarmTrace/IO/Common.hs @@ -19,7 +19,6 @@ import Constants (vERSION) -- Library modules -import System.Console.ParseArgs hiding (args) -- cabal install parseargs import Data.List (sort, groupBy) import Control.Arrow ((***)) import System.FilePath diff --git a/src/HarmTrace/IO/FeatExtract.hs b/src/HarmTrace/IO/FeatExtract.hs --- a/src/HarmTrace/IO/FeatExtract.hs +++ b/src/HarmTrace/IO/FeatExtract.hs @@ -21,15 +21,17 @@ import System.FilePath import System.Directory (removeFile) import System.Process +import System.Exit (ExitCode (..)) import Data.List (isPrefixOf) -import Constants ( keyStr, chromaStr, beatStr, deleteDownsampledWav) +import Constants ( keyStr, chromaStr, beatStr, deleteDownsampledWav, downSample) import HarmTrace.Base.Parsing import HarmTrace.IO.Downsample import HarmTrace.IO.BasePaths( BasePaths, getBeatVampPath, basePathsExist , getKeyVampPath, getChromaVampPath - , getFeatDir, getOutDir) + , getFeatDir, getSonic, getLogFile) + -- | Extracts the features of an arbitrary audio file, given three VAMP plugin -- descriptions. Before the feature extraction the audio is preprocessed -- (downsampled) with the the SoX library (see 'HarmTrace.IO.Downsample') @@ -46,26 +48,31 @@ case exists of False -> return Nothing True -> -- create a log file - do let logf = getOutDir dirs takeFileName f <.> "extract.log" - cfp = getFeatDir dirs dropExtension f ++ chromaStr - bfp = getFeatDir dirs dropExtension f ++ beatStr - kfp = getFeatDir dirs dropExtension f ++ keyStr + do let -- logf = getOutDir dirs takeFileName f <.> "extract.log" + cfp = getFeatDir dirs + dropExtension (takeFileName f) ++ chromaStr + bfp = getFeatDir dirs + dropExtension (takeFileName f) ++ beatStr + kfp = getFeatDir dirs + dropExtension (takeFileName f) ++ keyStr -- open a logfile - hdl <- openFile logf AppendMode + hdl <- openFile (getLogFile dirs f) AppendMode hSetBuffering hdl LineBuffering -- downsample the audio - hPutStrLn hdl (f ++ ";process audio;0;0") - df <- downsample f - hPutStrLn hdl (f ++ ";process audio;99;19") + hPutStrLn hdl (f ++ ";preprocessing;0;0") + df <- case downSample of + True -> downsample f + False -> return f + hPutStrLn hdl (f ++ ";preprocessing;99;9") -- extract the features - sonicannotatorProcPipe (LogInfo "" "" 0 20) hdl + sonicannotatorProcPipe dirs (LogInfo f "" 0 10) hdl (getBeatVampPath dirs) df bfp - sonicannotatorProcPipe (LogInfo "" "" 0 40) hdl + sonicannotatorProcPipe dirs (LogInfo f "" 0 30) hdl (getChromaVampPath dirs) df cfp - sonicannotatorProcPipe (LogInfo "" "" 0 60) hdl + sonicannotatorProcPipe dirs (LogInfo f "" 0 50) hdl (getKeyVampPath dirs) df kfp hClose hdl @@ -76,18 +83,26 @@ -- executes the sonicannotator and logs all execution info to a log file -- TODO: perhaps output a Bool for loggin if the annotating is successful -sonicannotatorProcPipe :: LogInfo -> Handle -> FilePath -> FilePath -> FilePath - -> IO () -sonicannotatorProcPipe info logh transformfile inp outp= do +sonicannotatorProcPipe :: BasePaths -> LogInfo -> Handle -> FilePath + -> FilePath -> FilePath -> IO () +sonicannotatorProcPipe bp info logh transformfile inp outp= do let par = "--transform" : transformfile : "--writer" : "csv" : "--csv-one-file" : [outp, inp] - (_,_,Just err,p) <- createProcess (proc "sonic-annotator" par) + (_,_,Just err,p) <- createProcess (proc (getSonic bp) par) {std_err = CreatePipe} - x <- hGetContents err - let tlog = transformLog info x + -- {std_out = CreatePipe} + cerr <- hGetContents err + -- cout <- hGetContents out + -- print cerr + -- print cout + let tlog = transformLog info cerr hPutStr logh $ concatMap show tlog void (waitForProcess p) - -- return () + + (Just ex) <- getProcessExitCode p + -- print the error when the sonic-annotator fails + when (ex /= ExitSuccess) + (putStr ("sonic annotator failed to exit normally:\n" ++ cerr)) -------------------------------------------------------------------------------- -- parsing sonic annotator logs @@ -115,13 +130,15 @@ combineLine i (l:ls) = let i' = comb i l in i' : combineLine i' ls -- comb does the actual combining comb :: LogInfo -> LogLine -> LogInfo - comb info (LogFile n) = info {file = n} + -- we do not updated the filename because this file will contain a + -- "downsampled.wav" suffix, and we want the orginal file to appear in the log + comb info (LogFile _) = info -- {file = n} comb info (LogFeat d) = info {feature = d} comb info (LogPerc p) = let t = if p `mod` 5 == 0 then 1 else 0 in info {perc = p, total = total info + t} -- a datatype storing for collecting the information in the log file -data LogInfo = LogInfo {file :: String, +data LogInfo = LogInfo {_file :: String, feature :: String, perc :: Int, total :: Int} diff --git a/src/HarmTrace/IO/Parse.hs b/src/HarmTrace/IO/Parse.hs --- a/src/HarmTrace/IO/Parse.hs +++ b/src/HarmTrace/IO/Parse.hs @@ -3,7 +3,8 @@ module HarmTrace.IO.Parse ( - parseTree, parseTreeVerb, parseDir + parseTree, parseTreeVerb, parseDir, + parseAnnotation, parseAnnotationVerb, parseAnnotationDir, ) where @@ -34,13 +35,13 @@ -- Symbolic Parsing IO -------------------------------------------------------------------------------- --- parses a string of chords and returns a parse tree with the harmony structure +-- | Parses a string of chords and returns a parse tree with the harmony structure parseTree, parseTreeVerb :: (GTree g) => Grammar g -> [PPOption] -> String -> IO (ParseResult g) parseTree g opts s = do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s putStrLn ("parsed " ++ show (length tks) ++ " chords into " - ++ show n ++ " ambiguous trees") + ++ show n ++ " analysis tree(s)") if not $ null te then showErrors "tokenizer: " te else putStr "" if not $ null pe then showErrors "parser: " pe @@ -50,14 +51,15 @@ parseTreeVerb g opts s = do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s putStrLn ("parsed " ++ show (length tks) ++ " chords into " - ++ show n ++ " ambiguous trees") + ++ show n ++ " analysis tree(s)") if not $ null te then mapM_ print te else putStr "" if not $ null pe then mapM_ print pe else putStr "" return pr --- Batch analyzing a directory with chord sequence files with reduced output. +-- | Batch analyses a directory with chord sequence files and presents the +-- user some reduced output. parseDir :: (GTree g) => Grammar g -> [PPOption] -> FilePath -> Maybe FilePath -> IO () parseDir g opts filepath bOut = getDirectoryContents filepath @@ -106,3 +108,80 @@ case bOut of Nothing -> return () Just bf -> encodeFile bf (cs, ts) + +-------------------------------------------------------------------------------- +-- Audio Ground-truth annotations IO +-------------------------------------------------------------------------------- + +parseAnnotation, parseAnnotationVerb :: (GTree g) => Grammar g -> [PPOption] + -> String -> String -> IO (ParseResult g) +-- | Parses a ground-truth chord annotation in standard MIREX format and +-- presents the user some condensed parsing statistics +parseAnnotation g opts k ann = + do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ gt2Piece g k ann + putStrLn ("key: " ++ k) + putStrLn ("parsed " ++ show (length tks)++ " audio chord annotations into " + ++ show n ++ " ambiguous trees") + when (not $ null te) (showErrors "tokenizer: " te) + when (not $ null pe) (showErrors "parser: " pe) + return pr + +-- | Parses a ground-truth chord annotation in standard MIREX format and +-- presents the user somewhat more elaborate parsing statistics +parseAnnotationVerb g opts k ann = + do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ gt2Piece g k ann + putStrLn ("key: " ++ k) + when (not $ null te) (do putStrLn "tokenizer errors:" ; mapM_ print te) + when (not $ null pe) (do putStrLn "parser errors:" ; mapM_ print pe) + putStrLn ("parsed " ++ show (length tks)++ " audio chord annotations into " + ++ show n ++ " ambiguous trees") + return pr + +-- | Parses a directory of annotation files and key description files +-- and prints condensed parsing information to std out +parseAnnotationDir :: GTree a => Grammar a -> [PPOption] -> FilePath -> FilePath + -> IO () +parseAnnotationDir g opts kdir andir = + do ks <- getDirectoryContents kdir + ans <- getDirectoryContents andir + -- prints parse results in one line + let prntParse :: (FilePath,FilePath) -> IO () + prntParse (kfp,anfp) = + do k <- readFile kfp + a <- readFile anfp + printLn . concat $ intersperse "\t" (takeFileName kfp + : (showParseResult . postProc opts $ gt2Piece g k a)) + -- filters .lab files and adds the path + fileFilter :: FilePath -> [FilePath] -> [FilePath] + fileFilter pf = map (combine pf) . filter ((== ".lab") . takeExtension) + + case matchKeyAnn (fileFilter kdir $ reverse ks) + (fileFilter andir $ reverse ans) of + Just x -> do printVersion + printLn ("Filename\tkey\tnrOfTrees\tInsertions\tDeletions" + ++ "\tDelsAtEnd\tTotalErr\tnrOfChords\tTokenizerErr") + mapM_ prntParse x + Nothing -> putStrLn ("the filenames in " ++ kdir + ++ " do not exactly match the ones in " ++ andir) + +-- shows some elements of a ParseResult +showParseResult :: ParseResult a -> [String] +showParseResult (ParseResult k tk _p _han n te pe _pp) = + let pErr = countErrors pe + insert = ins pErr + delete = del pErr + endDel = delEnd pErr + total = insert + delete + endDel + -- key nrOfTrees Insertions Deletions DelsAtEnd TotalErr tokenizerErr + in show k : (map show (n : insert : delete : endDel : total + : length tk : length te :[])) + + +-- Checks if the key and the annotation files all match, if this is the +-- case it will return a paired list of these files +matchKeyAnn :: [FilePath] -> [FilePath] -> Maybe [(FilePath,FilePath)] +matchKeyAnn ks ans = + let match = and $ zipWith eqFileName ks ans + eqFileName :: FilePath -> FilePath -> Bool + eqFileName a b = takeFileName a == takeFileName b + in if match then Just $ zip ks ans else Nothing diff --git a/src/HarmTrace/IO/Recognise.hs b/src/HarmTrace/IO/Recognise.hs --- a/src/HarmTrace/IO/Recognise.hs +++ b/src/HarmTrace/IO/Recognise.hs @@ -17,127 +17,53 @@ module HarmTrace.IO.Recognise ( - parseAnnotation, parseAnnotationVerb, parseAnnotationDir, - evaluateLabeling, printLabeling, batchLabeling + evaluateLabeling, printLabelling, batchPrintLabelling, batchLabeling + , batchEvaluateKeyFinding, evaluateKeyFinding ) where -- Common IO functions import HarmTrace.IO.Common -import HarmTrace.IO.BasePaths (BasePaths, getOutDir, getFeatDir) -import Constants ( keyStr, chromaStr, beatStr ) +import HarmTrace.IO.BasePaths (BasePaths, getOutDir, getFeatDir, getLogFile) +import Constants ( keyStr, chromaStr, beatStr + , ChordPrintOpts (..) ) -- Parser stuff import Text.ParserCombinators.UU -- Music stuff -import HarmTrace.HarmTrace import HarmTrace.Base.MusicRep import HarmTrace.Models.Jazz.Instances () -import HarmTrace.HAnTree.ToHAnTree -import HarmTrace.IO.Errors import HarmTrace.Base.Parsing +import HarmTrace.Models.Models -- Audio stuff import HarmTrace.Audio.DataParser ( parseChordinoData, parseChromaData - , parseBeatBarData) + , parseBarTimeData) import HarmTrace.Audio.AnnotationParser -import HarmTrace.Audio.Annotate (putSegStats) -import HarmTrace.Audio.Evaluation -import HarmTrace.Audio.ChordTypes +import HarmTrace.Audio.Annotate (putSegStats, mptreeAnnotator) +import HarmTrace.Audio.Evaluation ( relCorrectOverlap, achievScore, avgDistToOne + , chordTriadEq, chordClassEq, majMinEq + , printChordRCO, printRCO, chordChangeRatio ) +import HarmTrace.Base.MusicTime +import HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync ) +import HarmTrace.Audio.Key (getBeatSyncKeyFromChroma) import HarmTrace.IO.FeatExtract import Data.List (genericLength, isSuffixOf, stripPrefix) -- Library modules -import Data.List (sort, intersperse) +import Data.List (sort, unzip6, intersperse) import System.FilePath import System.Directory import System.IO import System.CPUTime import Data.Maybe (isJust, fromJust, isNothing) +import Text.Printf (printf) -- import Control.Parallel.Strategies (parList, rdeepseq, using) -------------------------------------------------------------------------------- --- Audio Ground-truth annotations IO --------------------------------------------------------------------------------- - --- @pedro: I think the three "parse" functions should go to HarmTrace.IO.Parse -parseAnnotation, parseAnnotationVerb :: (GTree g) => Grammar g -> [PPOption] - -> String -> String -> IO (ParseResult g) -parseAnnotation g opts k ann = - do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ gt2Piece g k ann - putStrLn ("key: " ++ k) - putStrLn ("parsed " ++ show (length tks)++ " audio chord annotations into " - ++ show n ++ " ambiguous trees") - if not $ null te then showErrors "tokenizer: " te - else putStr "" - if not $ null pe then showErrors "parser: " pe - else putStr "" - return pr - -parseAnnotationVerb g opts k ann = - do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ gt2Piece g k ann - putStrLn ("key: " ++ k) - if not $ null te then do putStrLn "tokenizer errors:" ; mapM_ print te - else putStr "" - if not $ null pe then do putStrLn "parser errors:" ; mapM_ print pe - else putStr "" - putStrLn ("parsed " ++ show (length tks)++ " audio chord annotations into " - ++ show n ++ " ambiguous trees") - return pr - --- parses a directory of annotation files and key description files --- and prints condenced parsing information to std out -parseAnnotationDir :: GTree a => Grammar a -> [PPOption] -> FilePath -> FilePath - -> IO () -parseAnnotationDir g opts kdir andir = - do ks <- getDirectoryContents kdir - ans <- getDirectoryContents andir - -- prints parse results in one line - let prntParse :: (FilePath,FilePath) -> IO () - prntParse (kfp,anfp) = - do k <- readFile kfp - a <- readFile anfp - printLn . concat $ intersperse "\t" (takeFileName kfp - : (showParseResult . postProc opts $ gt2Piece g k a)) - -- filters .lab files and adds the path - fileFilter :: FilePath -> [FilePath] -> [FilePath] - fileFilter pf = map (combine pf) . filter ((== ".lab") . takeExtension) - - case matchKeyAnn (fileFilter kdir $ reverse ks) - (fileFilter andir $ reverse ans) of - Just x -> do printVersion - printLn ("Filename\tkey\tnrOfTrees\tInsertions\tDeletions" - ++ "\tDelsAtEnd\tTotalErr\tnrOfChords\tTokenizerErr") - mapM_ prntParse x - Nothing -> putStrLn ("the filenames in " ++ kdir - ++ " do not exactly match the ones in " ++ andir) - --- Checks if the key and the annotation files all match, if this is the --- case it will return a paired list of these files -matchKeyAnn :: [FilePath] -> [FilePath] -> Maybe [(FilePath,FilePath)] -matchKeyAnn ks ans = - let match = and $ zipWith eqFileName ks ans - eqFileName :: FilePath -> FilePath -> Bool - eqFileName a b = takeFileName a == takeFileName b - in if match then Just $ zip ks ans else Nothing - --- shows some elements of a ParseResult -showParseResult :: ParseResult a -> [String] -showParseResult (ParseResult k tk _p _han n te pe _pp) = - let pErr = countErrors pe - insert = ins pErr - delete = del pErr - endDel = delEnd pErr - total = insert + delete + endDel - -- key nrOfTrees Insertions Deletions DelsAtEnd TotalErr tokenizerErr - in show k : (map show (n : insert : delete : endDel : total - : length tk : length te :[])) - - --------------------------------------------------------------------------------- --- Audio Data IO +-- Some audiofile specific utitlities -------------------------------------------------------------------------------- -- | Returns True when the argument is an audio feature file based on @@ -161,13 +87,13 @@ chm = stripSuffix chromaStr fp bt = stripSuffix beatStr fp - -- drops a given suffix from a string. It returns nothing if the suffix - -- is not a suffix of the string - stripSuffix :: String -> String -> Maybe String - stripSuffix suf txt - | isJust stp = Just . reverse $ fromJust stp - | otherwise = Nothing - where stp = stripPrefix (reverse suf) (reverse txt) +-- drops a given suffix from a string. It returns nothing if the suffix +-- is not a suffix of the string +stripSuffix :: String -> String -> Maybe String +stripSuffix suf txt + | isJust stp = Just . reverse $ fromJust stp + | otherwise = Nothing + where stp = stripPrefix (reverse suf) (reverse txt) -- maps readAudioFeat over a directory readAudioFeatureDir :: FilePath -> IO [AudioFeat] @@ -185,14 +111,23 @@ -- a chroma, beat and key feature file, 'readAudioFeat' parses all data and returns an 'AudioFeat'. readAudioFeatures :: (FilePath,FilePath,FilePath) -> IO (AudioFeat) readAudioFeatures (cfp,bfp,kfp) = - do dChroma <- readFile cfp + do let bfpid = getAudioFeatureId bfp + cfpid = getAudioFeatureId cfp + kfpid = getAudioFeatureId kfp + when (bfpid /= cfpid && bfpid /= kfpid && isJust bfpid) + (error ("HarmTrace.IO.readAudioFeatures: non matching audio " ++ + "features:\n" ++ show bfp ++ "\n" ++ show cfp ++ "\n" ++ + show kfp ++ "\n")) + + dChroma <- readFile cfp dBeat <- readFile bfp dKey <- readFile kfp - + + -- TODO: use parseDataSafe here let chrm = parseData parseChordinoData dChroma - beats = parseData parseBeatBarData dBeat + beats = parseData parseBarTimeData dBeat keys = parseData parseChromaData dKey - return (AudioFeat chrm beats keys) + return (AudioFeat chrm beats keys (fromJust bfpid)) -- Given one VAMP feature CSV file, HarmTrace will look for the other two -- feature files needed for chord transcription. If the first argument it True @@ -215,11 +150,45 @@ case (cfpExists && bfpExists && kfpExists) of True -> return (Just (cfp,bfp,kfp)) - False -> return Nothing - --- | Evaluluates a single labeling of a piece with a ground truth annotation + False -> + do when verbose (putStrLn ("I did not find 3 " + ++ "matching feature files, I looked for:\n" + ++ cfp ++ "\n" ++ bfp ++ "\n" ++ kfp)) + return Nothing + +-- | Returns True if fp is an audio file +isAudioFile :: FilePath -> Bool +isAudioFile fp = elem (tail $ takeExtension fp) -- all sox file formats :-) + [ "mp3", "wav", "mp4","MP3", "MP4","WAV" -- start with common extensions + , "8svx", "aif", "aifc", "aiff", "aiffc", "al", "amb", "amr-nb", "amr-wb" + , "anb", "au", "avi", "avr", "awb", "cdda", "cdr", "cvs", "cvsd", "cvu", "dat" + , "dvms", "f32", "f4", "f64", "f8", "ffmpeg", "flac", "fssd", "gsm", "gsrt" + , "hcom", "htk", "ima", "ircam", "la", "lpc", "lpc10", "lu", "m4a", "m4b" + , "maud", "mp2", "mpg", "nist", "ogg", "prc", "raw", "s1" + , "s16", "s2", "s24", "s3", "s32", "s4", "s8", "sb", "sds", "sf", "sl", "smp" + , "snd", "sndfile", "sndr", "sndt", "sou", "sox", "sph", "sw", "txw", "u1" + , "u16", "u2", "u24", "u3", "u32", "u4", "u8", "ub", "ul", "uw", "vms", "voc" + , "vorbis", "vox", "wavpcm", "wmv", "wv", "wve", "xa" + -- and the same extensions in uppercase + -- TODO: use equalFilePath + , "8SVX", "AIF", "AIFC", "AIFF", "AIFFC", "AL", "AMB", "AMR-NB", "AMR-WB" + , "ANB", "AU", "AVI", "AVR", "AWB", "CDDA", "CDR", "CVS", "CVSD", "CVU", "DAT" + , "DVMS", "F32", "F4", "F64", "F8", "FFMPEG", "FLAC", "FSSD", "GSM", "GSRT" + , "HCOM", "HTK", "IMA", "IRCAM", "LA", "LPC", "LPC10", "LU", "M4A", "M4B" + , "MAUD", "MP2", "MPG", "NIST", "OGG", "PRC", "RAW", "S1" + , "S16", "S2", "S24", "S3", "S32", "S4", "S8", "SB", "SDS", "SF", "SL", "SMP" + , "SND", "SNDFILE", "SNDR", "SNDT", "SOU", "SOX", "SPH", "SW", "TXW", "U1" + , "U16", "U2", "U24", "U3", "U32", "U4", "U8", "UB", "UL", "UW", "VMS", "VOC" + , "VORBIS", "VOX", "WAVPCM", "WMV", "WV", "WVE", "XA" + ] + +-------------------------------------------------------------------------------- +-- Evaluating Audio Chord Transcription +-------------------------------------------------------------------------------- + +-- | Evaluates a single labeling of a piece with a ground truth annotation -- visually. -evaluateLabeling :: (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) +evaluateLabeling :: (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) -> Bool -> FilePath -> FilePath -> Maybe FilePath -> IO Double evaluateLabeling annotator prnt gtfp featfp keyfp = do @@ -231,167 +200,302 @@ (True, Nothing,True) -> do printLn ("using key finding") putSegStats Nothing af - printRelCorrectOverlap (annotator Nothing) af gt + printChordRCO (annotator Nothing) (getBeatSyncKeyFromChroma af) af gt (True, Nothing,False) -> - do return (relCorrectOverlap gt (dumpBeats $ annotator Nothing af)) + do return (relCorrectOverlap chordTriadEq gt (dropProb $ annotator Nothing af)) (True, Just k ,True) -> do key <- readAndParseKeyAnn k printLn ("using groundTruth key annotation: " ++ show key) putSegStats (Just key) af - printRelCorrectOverlap (annotator (Just key)) af gt + printChordRCO (annotator (Just key)) key af gt (True, Just k ,False) -> do key <- readAndParseKeyAnn k - return (relCorrectOverlap gt (dumpBeats $ annotator (Just key) af)) + return (relCorrectOverlap chordTriadEq gt (dropProb $ annotator (Just key) af)) (False, _, _) -> return (-1) + +-- | Evaluates the keyfinding for a single audio feature set. +evaluateKeyFinding :: Bool -> FilePath -> FilePath -> IO () +evaluateKeyFinding prnt featfp kdir = do + + maf <- findAudioFeatures True featfp + af <- readAudioFeatures (fromJust maf) + gt <- readAndParseKeyAnn (kdir takeFileName (getAudioFeatId af) <.> "lab") + let keys = getBeatSyncKeyFromChroma af + + case (prnt) of + True -> void (printRCO printKeyEq gt keys) + False -> putStrLn (show $ relCorrectOverlap (==) gt keys) + + where printKeyEq :: Key -> Key -> IO (Bool) + printKeyEq a b = do putStrLn (show a ++ " == " ++ show b) + return (a == b) + + -- | Given a ground truth directory and an data directory (containing exactly -- 3 times as much files as the gt directory) all files will be labeled and -- the relative correct overlap wil be corrected an presented to the user -batchLabeling :: (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) +batchLabeling :: ChordPrintOpts -> Maybe FilePath -> + (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) -> FilePath -> FilePath -> Maybe FilePath -> IO () -batchLabeling annotator gtfp audiofp keyfp = do - gt <- getDirectoryContents gtfp - af <- readAudioFeatureDir audiofp +batchLabeling opts mout annotator gtdir audiodir mkeydir = do - -- parse the key annotations [Maybe [TimedData Key]] - mKeys <- case keyfp of - Nothing -> - do printLn "using key finding" - return $ repeat Nothing - (Just fp) -> - do printLn "using key ground-truth annotations" - kfs <- getDirectoryContents fp - -- better to move also the reading etc. to evalR - ks <- mapM (\x ->readAndParseKeyAnn (fp x)) - (sort $ filter ((== ".lab") . takeExtension ) kfs) - return $ map Just ks + -- inform the user wheter we are using ground-truth key annotations or not + maybe (putStrLn "using key finding") + (const $ putStrLn "using key ground-truth annotations") mkeydir + + printVersion -- print the current HarmTrace version + printLn ("file\trun time (seconds)\tRCO triad (maj/min)\tmaj/min errors" ++ + "\tRCO chord class (maj/min/dom/dim)\tMaximum achievable" ++ + "\tchord change ratio") + + result <- readAudioFeatureDir audiodir >>= mapM evalR + + let -- result' = result `using` parList rdeepseq + totNrSongs = genericLength result + printAVG r = show (sum r / totNrSongs) + (triad, majMinErrs, chordClass, maxAchieve, cChangeRat, runTimes) = unzip6 result + -- print some averaged statistics + putStrLn ("average RCO triad level: " ++ printAVG triad) + putStrLn ("average MajMin error ratio: " ++ printAVG majMinErrs) + putStrLn ("average RCO chord class level: " ++ printAVG chordClass) + putStrLn ("average maximum achievable score: " ++ printAVG maxAchieve) + putStrLn ("average chord change ratio (distance to 1.0): " + ++(show . avgDistToOne $ cChangeRat)) + putStrLn ("total running time: " ++ show (sum runTimes )) + + where + -- evaluates one set of audio features, prints the results to the std. out + -- and returns a tuple with the relative correct overlap and the run time + evalR :: AudioFeat -> IO(Double, Double, Double, Double, Double, Double) + evalR af@(AudioFeat crm bts _ afid) = do + + let gtfp = takeFileName afid <.> "lab" + gt <- readAnnotation (gtdir gtfp) + + -- if a directory with ground-truth key annotations has been provided + -- we use this directory to find a file with the same name in this + -- directory and parse it + mkey <- case mkeydir of + Just kfp -> readAndParseKeyAnn (kfp gtfp) >>= return . Just + Nothing -> return Nothing + + let timedAnno = annotator mkey af + annotation = dropProb timedAnno + resultTriad = relCorrectOverlap chordTriadEq gt annotation + resultClass = relCorrectOverlap chordClassEq gt annotation + majMinErr = relCorrectOverlap majMinEq gt annotation + chordChange = chordChangeRatio chordTriadEq gt annotation + ccList = fmap (fmap (fmap chordLab)) . createChordRanks + $ beatSync bts crm + resultMax = achievScore gt ccList + exec = seq annotation (return ()) + + -- TODO: refactor into seperate function + -- log the execution time + t1 <- getCPUTime + exec -- evaluate the automatic annotation + t2 <- getCPUTime + + -- optionally write the chords to an output file (if an output directory + -- has been specified) + when (isJust mout) + (writeAnnotationNoLog opts (fromJust mout) afid timedAnno) + + let runtime = fromIntegral (t2 - t1) / (1000000000000 :: Double) + + -- print the information to the user + printLn (gtfp ++ '\t' : pPrintDoubles [runtime, resultTriad + , majMinErr, resultClass, resultMax, chordChange]) + return (resultTriad, majMinErr, resultClass, resultMax, chordChange, runtime) - -- this is really hacky, but there is no zipWith3M - let files = zip (sort $ filter ((== ".lab") . takeExtension ) gt) mKeys +-- | Pretty prints a list of doubles separated by tabs. +pPrintDoubles :: [Double] -> String +pPrintDoubles = concat . intersperse "\t" . map (printf "%.3f") + +-- | reads a single chord annotation +readAnnotation :: FilePath -> IO [TimedData ChordLabel] +readAnnotation fp = do f <- readFile fp + return (parseDataSafe parseAnnotationData f) + +-- | Given a 'FilePath' reads and returns a ground-truth 'Key' Annotation. +readAndParseKeyAnn :: FilePath -> IO [TimedData Key] +readAndParseKeyAnn keyfp = do key <- readFile keyfp + return $ parseDataSafe parseKeyAnnotationData key + +-- | Evaluates key finding based on a directory of audio features +batchEvaluateKeyFinding :: FilePath -> FilePath -> IO () +batchEvaluateKeyFinding audiodir keydir = do + putStrLn "Evaluating key finding" + printVersion -- print the current HarmTrace version - printVersion - printLn "file\trun time (seconds)\trelative correct overlap" - res <- zipWithM evalR files af - -- let res' = res `using` parList rdeepseq - printLn ("average: " ++ show (sum (fmap fst res) / genericLength res)) + result <- readAudioFeatureDir audiodir >>= mapM evalKey + + let totNrSongs = genericLength result + (roc,runTimes) = unzip result + -- print some averaged statistics + putStrLn ("average RCO: " ++ show (sum roc / totNrSongs )) + putStrLn ("total running time: " ++ show (sum runTimes )) where - evalR :: (FilePath, Maybe [TimedData Key]) -> AudioFeat -> IO(Double, Float) - -- evalR _ Nothing = error "evalR: Nothing" - evalR (fp, maybeKey) af = do - gt <- readAnnotation (gtfp fp) - let result = relCorrectOverlap gt (dumpBeats $ annotator maybeKey af) + + -- Evaluates a the key annotation for a single AudioFeature set + evalKey :: AudioFeat -> IO (Double, Float) + evalKey af = do + + let gtfp = takeFileName (getAudioFeatId af) <.> "lab" + gt <- readAndParseKeyAnn (keydir gtfp) + + let result = relCorrectOverlap (==) gt (getBeatSyncKeyFromChroma af) exec = seq result (return ()) + + -- log the execution time t1 <- getCPUTime - exec + exec -- evaluate the automatic annotation t2 <- getCPUTime - let runtime = fromIntegral (t2 - t1) / (1000000000000 :: Float) - printRes fp (result, runtime) + let runtime = fromIntegral (t2 - t1) / (1000000000000 :: Float) + + -- print the information to the user + printLn (gtfp ++ ":\t" ++ showFloat runtime ++ '\t' : show result ) return (result, runtime) + - printRes :: FilePath -> (Double, Float) -> IO () - printRes fp (r,t) = printLn (fp ++ ":\t" ++ showFloat t ++ '\t' : show r) - >> hFlush stdout +-------------------------------------------------------------------------------- +-- Analysing and printing chord labels +-------------------------------------------------------------------------------- +batchPrintLabelling :: ChordPrintOpts -> BasePaths + -> (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) + -> FilePath -> IO () +batchPrintLabelling opts dirs annotator fp = + do fl <- readFile fp + mapM_ (printLabelling opts dirs annotator) (lines fl) + -- takes a set of features or an audio file and writes the chords to a file -- the process is also logged in a logfile to keep track of the process -- (see HarmTrace.IO.FeatExtract) -printLabeling :: BasePaths - -> (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) - -> FilePath -> IO () -printLabeling dirs annotator fp = do +printLabelling :: ChordPrintOpts -> BasePaths + -> (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) + -> FilePath -> IO () +printLabelling opts dirs annotator fp = do let -- we use the same logfile for adding harmtrace status - logf = getOutDir dirs takeFileName fp <.> "extract.log" - out = getOutDir dirs takeFileName fp <.> "chords.txt" + logf = getLogFile dirs fp + out = getOutDir dirs takeFileName fp <.> "chords.txt" ffp = getFeatDir dirs dropExtension (takeFileName fp) ++ chromaStr - + -- check (silently) if features have been extracted earlier - hasFt <- findAudioFeatures True ffp + hasFt <- findAudioFeatures False ffp case (isAudioFile fp, hasFt) of -- We found an audio file and no previously extracted features: extract them (True, Nothing) -> do -- extract features maf <- extractFeatures dirs fp + hdl <- openFile logf AppendMode if isNothing maf - then appendFile logf (fp ++";ERROR;0;99\n") - else do appendFile logf (fp ++ ";harmtrace;1;80\n") - -- print chords - readAndPrint out maf annotator - appendFile logf (fp++";harmtrace;100;99\n") - appendFile logf (fp++";DONE;100;100\n") + then harmTraceLogFinal hdl fp "error" + else do readAndPrint opts hdl fp out maf annotator + harmTraceLogFinal hdl fp "done" + hClose hdl -- We found an audio file, but also found matching features - (True,Just maf) -> do -- appendFile logf (fp ++ ";Initialize;1;1\n") - writeFile logf (fp ++ ";harmtrace;1;80\n") - readAndPrint out (Just maf) annotator - appendFile logf (fp ++ ";harmtrace;100;99\n") - appendFile logf (fp ++ ";DONE;100;100\n") + (True,Just _ ) -> do putStrLn ("I found matching feature files for " ++ fp) + hdl <- openFile logf WriteMode + readAndPrint opts hdl fp out hasFt annotator + harmTraceLogFinal hdl fp "done" + hClose hdl -- No audio, but one feature file: look for all feature files - (False,_ ) -> do maf <- findAudioFeatures True fp - readAndPrint out maf annotator + (False,_ ) -> do maf <- findAudioFeatures True fp -- N.B. will print + hdl <- openFile logf WriteMode + if isNothing maf + then harmTraceLogFinal hdl fp "error" + else do readAndPrint opts hdl fp out maf annotator + harmTraceLogFinal hdl fp "done" + hClose hdl + -- reads the features and prints the chords -readAndPrint :: FilePath -> Maybe (FilePath, FilePath, FilePath) - -> (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) +readAndPrint :: ChordPrintOpts -> Handle -> FilePath -> FilePath + -> Maybe (FilePath, FilePath, FilePath) + -> (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) -> IO () -readAndPrint _ Nothing _ = return () -readAndPrint out (Just af) annotator = +readAndPrint _ _ _ _ Nothing _ = return () +readAndPrint opts logh src out (Just af) annotator = do feat <- readAudioFeatures af - writeAnnotation out . segPerBeat (getBeats feat) $ annotator Nothing feat - --- returns True if fp is an audio file -isAudioFile :: FilePath -> Bool -isAudioFile fp = elem (tail $ takeExtension fp) -- all sox file formats :-) - [ "8svx", "aif", "aifc", "aiff", "aiffc", "al", "amb", "amr-nb", "amr-wb" - , "anb", "au", "avi", "avr", "awb", "cdda", "cdr", "cvs", "cvsd", "cvu", "dat" - , "dvms", "f32", "f4", "f64", "f8", "ffmpeg", "flac", "fssd", "gsm", "gsrt" - , "hcom", "htk", "ima", "ircam", "la", "lpc", "lpc10", "lu", "m4a", "m4b" - , "maud", "mp2", "mp3", "mp4", "mpg", "nist", "ogg", "prc", "raw", "s1" - , "s16", "s2", "s24", "s3", "s32", "s4", "s8", "sb", "sds", "sf", "sl", "smp" - , "snd", "sndfile", "sndr", "sndt", "sou", "sox", "sph", "sw", "txw", "u1" - , "u16", "u2", "u24", "u3", "u32", "u4", "u8", "ub", "ul", "uw", "vms", "voc" - , "vorbis", "vox", "wav", "wavpcm", "wmv", "wv", "wve", "xa" - ] + -- Compute the length of the input list of beats, to be used to provide + -- progress information `writeAnnotation` + let len = genericLength . getBeats $ feat + writeAnnotation logh len src out . expandPerBeat + . applyPrintOpts opts $ annotator Nothing feat --- reads an annotation -readAnnotation :: FilePath -> IO ChordAnnotation -readAnnotation fp = do f <- readFile fp - return (parseData parseAnnotationData f) - -readAndParseKeyAnn :: FilePath -> IO [TimedData Key] -readAndParseKeyAnn keyfp = do key <- readFile keyfp - return $ parseData parseKeyAnnotationData key +-- | writes an annotation to a specific file +writeAnnotation :: Handle -> Float -> FilePath -> FilePath + -> ChordAnnotation -> IO () +writeAnnotation hlog len src out ca = + do hout <- openFile out ReadWriteMode -- perhaps use WriteMode? + let step = 100 / len + -- showLn a = show a ++ "\n" + mapWithStatus (hPutStr hout . showTDPC) (harmTraceLogger hlog src) step ca + hClose hout --- writes an annotation to a specific file -writeAnnotation :: FilePath -> ChordBeatAnnotation -> IO () -writeAnnotation f ca = do hdl <- openFile f ReadWriteMode - mapM_ (hPutStr hdl . show) ca - hClose hdl +-- | Does the same thing as writeAnnotation (storing a chord transcription), +-- but without the logging. +writeAnnotationNoLog :: ChordPrintOpts -> FilePath -> FilePath + -> [TimedData ProbChord] -> IO () +writeAnnotationNoLog opts dir srcfp ca = + do let outfp = dir (takeFileName srcfp) <.> "chords.txt" + exists <- doesDirectoryExist dir + if exists + then writeFile outfp . concatMap showTDPC + . expandPerBeat . applyPrintOpts opts $ ca + else hPutStr stderr (dir ++ " does not exits") + +-- Shows chords in such a way that Chordify can understand them +showTDPC :: Show a => TimedData a -> String +showTDPC td = concat . intersperse ";" $ [ show . getBeat $ td + , show . getData $ td + , show . onset $ td + ,(show . offset $ td) ++ "\n" ] --- segment a chord annotation per beat --- ChordAnnotation = [TimedData ChordLabel] and BeatTrackerData = [NumData] -segPerBeat :: BeatBarTrackData -> ChordBeatAnnotation -> ChordBeatAnnotation -segPerBeat bts cds = segment (start : bts) cds where - start = BeatBar (0,prevBeat . snd . beatBar $ head bts) +-- like mapM_, but also print progress information +mapWithStatus :: (a -> IO b) -> (Float -> IO()) -> Float -> [a] -> IO () +mapWithStatus f logger step l = + let statusEval e b cur = logger cur >> f e >> (b (step + cur)) + in foldr statusEval (const (return ())) l 0 + +-- Writes a harmtrace status indicator to a log file in the same format +-- as 'HarmTrace.FeatExtract.FeatExtract'. +harmTraceLogger :: RealFrac a => Handle -> FilePath -> a -> IO () +harmTraceLogger hdl f step = + do let fstep = floor step :: Integer + total = 70 + (fstep * 30 `div` 100) + hPutStr hdl (f ++ ";harmtrace;" ++ show fstep ++ ';' : show total ++ "\n") + +-- Writes a final (100 percent) status message, should be "done" or "error" +harmTraceLogFinal :: Handle -> FilePath -> String -> IO () +harmTraceLogFinal hdl f str = + hPutStr hdl (f ++ ";" ++ str ++";100;100\n") + +applyPrintOpts :: ChordPrintOpts -> ChordAnnotation -> ChordAnnotation +applyPrintOpts PrintMajMin cs = map (updateTPChord toMajMinChord) cs +applyPrintOpts PrintChordClass cs = cs + +-- Expands the previously merged 'TimedData ProbChord's +-- TODO perhaps move to HarmTrace.Base.MusicTime because of it general structure +expandPerBeat :: [TimedData a] -> [TimedData a] +expandPerBeat = concatMap expand where - -- takes a list of beats and a list of chords (where chords can span multiple - -- beats) and returns a list of beat synchronised list chords (every chord - -- annoation has a one beat duration) - segment :: Show a => [BeatBar] -> [BeatTimedData a] -> [BeatTimedData a] - segment _ [] = [] - segment [b] [c] - | on < offset c = [setOnset c on] - | otherwise = [] -- N.B. includes on == offset b! - where on = fst $ beatBar b - segment (a : b : bs) (c:cs) - | onset c <= on && offset c >= off - = BeatTimedData (getData c) bt on off : segment (b:bs) (c:cs) - | otherwise = segment (a : b : bs) cs - where (on, bt) = beatBar a - off = fst $ beatBar b - -- should not happen - segment [] c = error ("we ran out of beats! Chords left: " ++ show c ) - segment [b] c = error ("Asynchroneous beat (" ++ show b ++ - ") and chords: " ++ show c ) + expand :: TimedData a -> [TimedData a] + expand td = let ts = getTimeStamps td + in zipWith3 timedDataBT (repeat . getData $ td) ts (tail ts) +-------------------------------------------------------------------------------- +-- for testing in ghci +-------------------------------------------------------------------------------- + +mptree :: FilePath -> IO [TimedData ProbChord] +mptree f = do maf <- findAudioFeatures True f + case maf of + Nothing -> error ("invalid audiofeature file " ++ show f) + Just af -> do readAudioFeatures af >>= + return . mptreeAnnotator (GrammarEx Pop) Nothing diff --git a/src/HarmTrace/IO/Wave.hs b/src/HarmTrace/IO/Wave.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/Wave.hs @@ -0,0 +1,48 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.IO.Wave +-- 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: Read .wav files into hmatrix. +-------------------------------------------------------------------------------- + +module HarmTrace.IO.Wave ( + + readWave, waveToVector + + ) where + + +-- HCodecs +import Codec.Wav ( importFile ) +import Data.Audio ( Audio, sampleData, convert ) + +-- hmatrix +import Data.Packed.Vector ( Vector, fromList ) + +-- Other +import Data.Array.Unboxed ( elems ) +import Data.Int ( Int32 ) + +-------------------------------------------------------------------------------- +-- Reading wave files +-------------------------------------------------------------------------------- + +-- | Reads a wave file from disk into a vector +readWave :: FilePath -> IO (Vector Double) +readWave fp = do r <- importFile fp + case r of + Left err -> putStrLn ("Error reading .wav file: " ++ err) + >> return (fromList []) -- return empty Vector + Right a -> return (waveToVector a) + +-- | Converts HCodecs' internal Audio representation to an hmatrix Vector. +-- Innefficient at the moment, because of list conversions. +waveToVector :: Audio Int32 -> Vector Double +waveToVector = fromList . elems . convert . sampleData diff --git a/src/HarmTrace/Matching/HChord.hs b/src/HarmTrace/Matching/HChord.hs --- a/src/HarmTrace/Matching/HChord.hs +++ b/src/HarmTrace/Matching/HChord.hs @@ -1,7 +1,7 @@ module HarmTrace.Matching.HChord (HChord, Sim, toHChords) where import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens +import HarmTrace.Models.ChordTokens import HarmTrace.Matching.Sim import HarmTrace.HAnTree.HAn import HarmTrace.HAnTree.Tree @@ -21,7 +21,8 @@ instance Show HChord where show (HChord r ct fc pr tr) = show fc ++ ':' : show pr ++ ':' : show tr - ++ ':' : show (scaleDegrees !! r) ++ show ct + ++ ':' : show (toScaleDegree (Key (Note Nothing C) MajMode) (toRoot r)) + ++ show ct toHChords :: Tree HAn -> [HChord] toHChords t = getHAn undefinedHChord t diff --git a/src/HarmTrace/Matching/Sim.hs b/src/HarmTrace/Matching/Sim.hs --- a/src/HarmTrace/Matching/Sim.hs +++ b/src/HarmTrace/Matching/Sim.hs @@ -4,7 +4,7 @@ import HarmTrace.HAnTree.HAn import HarmTrace.HAnTree.Tree import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens (ChordToken) +import HarmTrace.Models.ChordTokens (ChordToken) -------------------------------------------------------------------------------- -- A class for representing numerical similarity between datatypes diff --git a/src/HarmTrace/Matching/SimpleChord.hs b/src/HarmTrace/Matching/SimpleChord.hs --- a/src/HarmTrace/Matching/SimpleChord.hs +++ b/src/HarmTrace/Matching/SimpleChord.hs @@ -14,10 +14,13 @@ | otherwise = -1 instance Show SimChord where - show (SimChord r sh) = show (scaleDegrees !! r) + show (SimChord r sh) = show (toScaleDegree (Key (Note Nothing C) MajMode) + (toRoot r)) ++ if sh == MajMode then "" else "m" toSimChords :: ChordDegree -> [SimChord] -toSimChords (Chord r sh _add _loc d) = - -- replicate (d `div1` 2) (SimChord (diaDegToSemi r) (toMode sh)) - replicate d (SimChord (toSemitone r) (toMode sh)) +toSimChords c = replicate (duration c) (SimChord (toSemitone . chordRoot $ c) m) + + where m = case toTriad c of + NoTriad -> MinMode -- this is odd, but this is how it was.... + t -> toMode t diff --git a/src/HarmTrace/Models/ChordTokens.hs b/src/HarmTrace/Models/ChordTokens.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/ChordTokens.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module HarmTrace.Models.ChordTokens ( ChordToken (..) + , PieceToken (..) + , ParseStatus (..) + , toKeyRelTok + ) where + +import HarmTrace.Base.MusicRep +import HarmTrace.Base.Instances () +import Data.Binary +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- +-- Tokens for parsing chords +-------------------------------------------------------------------------------- + +-- merged Chords that will be presented to the parser +data ChordToken = ChordToken { root :: ScaleDegree + , classType :: ClassType + , chords :: [ChordLabel] + , status :: ParseStatus + , chordNumReps :: Int + , dur :: Int -- duration + } deriving Generic + +data ParseStatus = NotParsed | Parsed | Deleted | Inserted + deriving (Eq, Show, Generic) + +-- a datatype to store a tokenized chords +data PieceToken = PieceToken Key [ChordToken] + +-- (previously called mergeDups) +-- TODO rewrite function +-- | Merges duplicate chords and transforms absolute chord labels into key +-- relative tokens that can be parsed by the HarmTrace model +toKeyRelTok :: Key -> [ChordLabel] -> [ChordToken] +toKeyRelTok k (c@(Chord r _sh _add _loc d):cs) = toKeyRelTok' k + (ChordToken (toScaleDegree k r) (toClassType c) [c] NotParsed 1 d) cs +toKeyRelTok _key [] = [] +toKeyRelTok' :: Key -> ChordToken -> [ChordLabel] -> [ChordToken] +toKeyRelTok' _k p [] = [p] +toKeyRelTok' k p@(ChordToken deg clss cs' _stat n d1) (c@(Chord r _sh _a _l d2):cs) + | deg == deg2 && clss == clss2 = + toKeyRelTok' k (ChordToken deg clss (cs' ++ [c]) NotParsed (n+1) (d1+d2)) cs + | otherwise = p : toKeyRelTok' k (ChordToken deg2 clss2 [c] NotParsed 1 d2) cs + where clss2 = toClassType c + deg2 = toScaleDegree k r + + +-------------------------------------------------------------------------------- +-- Instances for Chord Tokens +-------------------------------------------------------------------------------- +instance Eq ChordToken where + (ChordToken sd clss _cs stat _n _d) == (ChordToken sd2 clss2 _cs2 stat2 _n2 _d2) + = sd == sd2 && clss == clss2 && stat == stat2 + +instance Show ChordToken where + show (ChordToken sd clss _cs Inserted _n _d) = show sd ++ show clss++"[Inserted]" + show (ChordToken sd clss cs Deleted _n _d) = + show sd ++ show clss ++ "[Deleted" ++ showChords cs ++ "]" + show (ChordToken sd clss cs _ _n d) = show sd ++ show clss ++ '_' : show d + ++ showChords cs +showChords :: [ChordLabel] -> String +showChords = concatMap (\x -> '[' : show x ++ "]") + + +-------------------------------------------------------------------------------- +-- Binary instances +-------------------------------------------------------------------------------- + +instance Binary ChordToken +instance Binary ParseStatus diff --git a/src/HarmTrace/Models/Jazz/Instances.hs b/src/HarmTrace/Models/Jazz/Instances.hs --- a/src/HarmTrace/Models/Jazz/Instances.hs +++ b/src/HarmTrace/Models/Jazz/Instances.hs @@ -40,8 +40,8 @@ import HarmTrace.HAnTree.Tree import HarmTrace.HAnTree.ToHAnTree import HarmTrace.HAnTree.HAn -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Base.TypeLevel +import HarmTrace.Models.ChordTokens as CT +import HarmTrace.Models.TypeLevel import HarmTrace.Base.MusicRep -- Library modules @@ -128,17 +128,22 @@ parseG = pChord deg clss where deg = toDegree (undefined :: deg) clss = toClass (undefined :: clss) - - + +-- generic ad-hoc parser that forms the bridge between the type-level and +-- value-level representation pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n)) -- Do not parse Imp degrees pChord (Note _ Imp) _clss = empty -- General case pChord deg clss = setStatus <$> pSatisfy recognize insertion where - recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss' - setStatus (ChordToken r t l NotParsed n d) - = Surface_Chord (ChordToken r t l Parsed n d) - setStatus c = Surface_Chord c + {-# INLINE recognize #-} + recognize ct = deg == root ct && clss == classType ct + + {-# INLINE setStatus #-} + setStatus c = case status c of + NotParsed -> Surface_Chord c {status = Parsed} + _ -> Surface_Chord c + insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 -------------------------------------------------------------------------------- diff --git a/src/HarmTrace/Models/Jazz/Model.hs b/src/HarmTrace/Models/Jazz/Model.hs --- a/src/HarmTrace/Models/Jazz/Model.hs +++ b/src/HarmTrace/Models/Jazz/Model.hs @@ -23,10 +23,10 @@ module HarmTrace.Models.Jazz.Model where -import HarmTrace.Base.TypeLevel +import HarmTrace.Models.TypeLevel import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens +import HarmTrace.Models.ChordTokens import Language.Haskell.TH.Syntax (Name) -------------------------------------------------------------------------------- diff --git a/src/HarmTrace/Models/Parser.hs b/src/HarmTrace/Models/Parser.hs --- a/src/HarmTrace/Models/Parser.hs +++ b/src/HarmTrace/Models/Parser.hs @@ -19,7 +19,11 @@ -- Summary: Semi-generic parser for chords -------------------------------------------------------------------------------- -module HarmTrace.Models.Parser where +module HarmTrace.Models.Parser ( + ParseG (..) + , parseGdefault + , PMusic + ) where -- Parser stuff @@ -30,13 +34,14 @@ import Generics.Instant.Base as G -- Music stuff -import HarmTrace.Tokenizer.Tokens +import HarmTrace.Models.ChordTokens -------------------------------------------------------------------------------- -- The generic part of the parser -------------------------------------------------------------------------------- +-- | a type synoniome for a harmonic analysis of a piece of music type PMusic a = P (Str ChordToken [ChordToken] Int) a class Parse' f where @@ -77,6 +82,7 @@ instance (ParseG a) => ParseG (Maybe a) where parseG = pMaybe parseG +-- | default generic parser parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a -- parseGdefault = fmap (to . head) (amb parse') -- Previously we used: diff --git a/src/HarmTrace/Models/Pop/Instances.hs b/src/HarmTrace/Models/Pop/Instances.hs --- a/src/HarmTrace/Models/Pop/Instances.hs +++ b/src/HarmTrace/Models/Pop/Instances.hs @@ -27,8 +27,8 @@ import HarmTrace.HAnTree.Tree import HarmTrace.HAnTree.ToHAnTree import HarmTrace.HAnTree.HAn -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Base.TypeLevel +import HarmTrace.Models.ChordTokens as CT +import HarmTrace.Models.TypeLevel import HarmTrace.Base.MusicRep -- Library modules @@ -101,13 +101,6 @@ -- Ad-hoc cases for Surface_Chord instance ParseG (Surface_Chord deg clss Ze) where parseG = empty - --- instance ( ToDegree deg - -- , ParseG (Surface_Chord (MinThird deg) DimClass n) - -- ) => ParseG (Surface_Chord deg DimClass (Su n)) where - -- parseG = Dim_Chord_Trns <$> parseG - -- <|> pChord deg DimClass - -- where deg = toDegree (undefined :: deg) -- all chords instance ( ToDegree deg, ToClass clss @@ -116,18 +109,23 @@ where deg = toDegree (undefined :: deg) clss = toClass (undefined :: clss) - +-- generic ad-hoc parser that forms the bridge between the type-level and +-- value-level representation pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n)) -- Do not parse Imp degrees pChord (Note _ Imp) _clss = empty -- General case pChord deg clss = setStatus <$> pSatisfy recognize insertion where - recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss' - setStatus (ChordToken r t l NotParsed n d) - = Surface_Chord (ChordToken r t l Parsed n d) - setStatus c = Surface_Chord c + {-# INLINE recognize #-} + recognize ct = deg == root ct && clss == classType ct + + {-# INLINE setStatus #-} + setStatus c = case status c of + NotParsed -> Surface_Chord c {status = Parsed} + _ -> Surface_Chord c + insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 - + -------------------------------------------------------------------------------- -- The non-generic part of the GTree wrapper -------------------------------------------------------------------------------- diff --git a/src/HarmTrace/Models/Pop/Model.hs b/src/HarmTrace/Models/Pop/Model.hs --- a/src/HarmTrace/Models/Pop/Model.hs +++ b/src/HarmTrace/Models/Pop/Model.hs @@ -10,10 +10,10 @@ module HarmTrace.Models.Pop.Model where -import HarmTrace.Base.TypeLevel +import HarmTrace.Models.TypeLevel import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens +import HarmTrace.Models.ChordTokens import Language.Haskell.TH.Syntax (Name) -------------------------------------------------------------------------------- diff --git a/src/HarmTrace/Models/TypeLevel.hs b/src/HarmTrace/Models/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/TypeLevel.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module HarmTrace.Models.TypeLevel ( + Su, Ze + , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10 + , T11, T12, T13, T14, T15, T16, T17, T18, T19, T20 + , ToNat(..) + ) where + +import Data.Typeable + + +-- Type level peano naturals +data Su :: * -> * deriving Typeable +data Ze :: * deriving Typeable + +-- Some shorthands +type T0 = Ze +type T1 = Su T0 +type T2 = Su T1 +type T3 = Su T2 +type T4 = Su T3 +type T5 = Su T4 +type T6 = Su T5 +type T7 = Su T6 +type T8 = Su T7 +type T9 = Su T8 +type T10 = Su T9 +type T11 = Su T10 +type T12 = Su T11 +type T13 = Su T12 +type T14 = Su T13 +type T15 = Su T14 +type T16 = Su T15 +type T17 = Su T16 +type T18 = Su T17 +type T19 = Su T18 +type T20 = Su T19 + +class ToNat n where + toNat :: n -> Int + +instance ToNat Ze where toNat _ = 0 +instance (ToNat n) => ToNat (Su n) where toNat _ = 1 + toNat (undefined :: n) +{- +-- Below is some experimentation... + +-- A degree has a distance to root in semi-tones (n in T0..T11) and a +-- class (major or minor) +data Degree n cls + +-- Transposing is a bit like addition... +type family Transpose m n +-- ... but we normalize at the end to stay within T0..T11 +type instance Transpose m T0 = Norm m +type instance Transpose m (Su n) = Transpose (Su m) n + +-- Normalizing is the same as subtracting T12, but only if we can. Else we keep +-- the type unchanged. +type Norm m = Sub m T12 m + +-- Subtraction with an extra type for failure +type family Sub m n fail +-- Inductive case +type instance Sub (Su m) (Su n) fail = Sub m n fail +-- Base case, subtraction succeeded +type instance Sub m T0 fail = m +-- Base case, subtraction failed +type instance Sub T0 (Su n) fail = fail + +-- A secondary dominant is a transposition by 7 semi-tones +type SD deg = Transpose deg T7 + +-- A tritone substitution is a transposition by 6 semi-tones +type TS deg = Transpose deg T6 +-} diff --git a/src/HarmTrace/Tokenizer/Tokenizer.hs b/src/HarmTrace/Tokenizer/Tokenizer.hs deleted file mode 100644 --- a/src/HarmTrace/Tokenizer/Tokenizer.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -module HarmTrace.Tokenizer.Tokenizer ( parseRoot, parseShorthand - , parseSongAbs, toKeyRelTok - , parseDegrees, parseDegree ) where - -import HarmTrace.Base.Parsing -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens - -import Data.Maybe - --------------------------------------------------------------------------------- --- Tokenizing: parsing strings into tokens --------------------------------------------------------------------------------- - --- Merges duplicate chords and transforms absolute chord labels into key --- relative tokens that can be parsed by the HarmTrace model --- (previously called mergeDups) -toKeyRelTok :: Key -> [ChordLabel] -> [ChordToken] -toKeyRelTok k (c@(Chord r sh _add _loc d):cs) = toKeyRelTok' k - (ChordToken (toScaleDegree k r) (toClassType sh) [c] NotParsed 1 d) cs -toKeyRelTok _key [] = [] -toKeyRelTok' :: Key -> ChordToken -> [ChordLabel] -> [ChordToken] -toKeyRelTok' _k p [] = [p] -toKeyRelTok' k p@(ChordToken deg clss cs' _stat n d1) (c@(Chord r sh _a _l d2):cs) - | deg == deg2 && clss == clss2 = - toKeyRelTok' k (ChordToken deg clss (cs' ++ [c]) NotParsed (n+1) (d1+d2)) cs - | otherwise = p : toKeyRelTok' k (ChordToken deg2 clss2 [c] NotParsed 1 d2) cs - where clss2 = toClassType sh - deg2 = toScaleDegree k r - --- Input is a string of whitespace-separated chords, e.g. --- Bb:9(s11) E:min7 Eb:min7 Ab:7 D:min7 G:7(13) C:maj6(9) --- First token is the key of the piece -parseSongAbs :: Parser PieceLabel -- PieceRelToken -- -parseSongAbs = PieceLabel <$> parseKey <* pLineEnd - <*> (setLoc 0 <$> pListSep_ng pLineEnd parseChord ) - <* pList pLineEnd where - setLoc :: Int -> [Chord a] -> [Chord a] - setLoc _ [] = [] - setLoc ix (Chord r c d _ l :cs) = (Chord r c d ix l) : setLoc (ix+1) cs - --- For now, I assume there is always a shorthand, and sometimes extra --- degrees. I guess it might be the case that sometimes there is no shorthand, --- but then there certainly are degrees. -parseChord :: Parser ChordLabel -parseChord = f <$> parseRoot <* pSym ':' <*> pMaybe parseShorthand - <*> (parseDegrees `opt` []) <* pSym ';' <*> pNaturalRaw - where f r (Just s) [] l = Chord r s [] 0 l - -- if there are no degrees and no shorthand (should not occur) - -- we make it a minor chord - f r Nothing [] l = Chord r Maj [] 0 l - -- in case of there is no short hand we analyse the degree list - f r Nothing d l = Chord r (analyseDegs d) d 0 l - -- in case of a sus4/maj we also analyse the degree list - f r (Just Sus4) d l = Chord r (analyseDegs d) d 0 l - f r (Just Maj) d l = Chord r (analyseDegs d) d 0 l - -- if we have another short hand we ignore the degrees list - f r (Just s) d l = Chord r s d 0 l - - -parseKey :: Parser Key -parseKey = f <$> parseRoot <* pSym ':' <*> parseShorthand - where f r m | m == Maj = Key r MajMode - | m == Min = Key r MinMode - | otherwise = error ("Tokenizer: key must be Major or Minor, " - ++ "found: " ++ show m) - - --- analyses a list of Degrees and assigns a shortHand i.e. Chord Class -analyseDegs :: [Addition] -> Shorthand -analyseDegs d - | (Note (Just Fl) I3) `elem` d = Min - | (Note (Just Sh) I5) `elem` d = Sev - | (Note (Just Fl) I7) `elem` d = Sev - | (Note Nothing I7) `elem` d = Maj7 - | (Note (Just Fl) I9) `elem` d = Sev - | (Note (Just Sh) I9) `elem` d = Sev - | (Note Nothing I11) `elem` d = Sev - | (Note (Just Sh) I11) `elem` d = Sev - | (Note (Just Fl) I13) `elem` d = Sev - | (Note Nothing I13) `elem` d = Sev - | (Note Nothing I3) `elem` d = Maj - | otherwise = Maj - - - -parseShorthand :: Parser Shorthand -parseShorthand = Maj <$ pString "maj" - <|> Min <$ pString "min" - <|> Dim <$ pString "dim" - <|> Aug <$ pString "aug" - <|> Maj7 <$ pString "maj7" - <|> Min7 <$ pString "min7" - <|> Sev <$ pString "7" - <|> Dim7 <$ pString "dim7" - <|> HDim7 <$ pString "hdim" <* opt (pSym '7') '7' - <|> MinMaj7 <$ pString "minmaj7" - <|> Maj6 <$ pString "maj6" - <|> Maj6 <$ pString "6" - <|> Min6 <$ pString "min6" - <|> Nin <$ pString "9" - <|> Maj9 <$ pString "maj9" - <|> Min9 <$ pString "min9" - <|> Sus4 <$ pString "sus4" - <|> Sus2 <$ pString "sus2" - "Shorthand" - --- We don't produce intervals for a shorthand. This could easily be added, --- though. -parseDegrees :: Parser [Addition] -parseDegrees = pPacked (pSym '(') (pSym ')') - (catMaybes <$> (pList1Sep (pSym ',') parseDegree)) - -parseDegree :: Parser (Maybe Addition) -parseDegree = (Just <$> (Note <$> pMaybe parseModifier <*> parseInterval)) - <|> Nothing <$ pSym '*' <* pMaybe parseModifier <* parseInterval - -parseModifier :: Parser Modifier -parseModifier = Sh <$ pSym 's' - <|> Sh <$ pSym '#' - <|> Fl <$ pSym 'b' - <|> SS <$ pString "ss" - <|> FF <$ pString "bb" "Modifier" - -parseInterval :: Parser Interval -parseInterval = ((!!) [minBound..] ) . pred <$> pNaturalRaw - -parseRoot :: Parser Root -parseRoot = Note Nothing A <$ pSym 'A' - <|> Note Nothing B <$ pSym 'B' - <|> Note Nothing C <$ pSym 'C' - <|> Note Nothing D <$ pSym 'D' - <|> Note Nothing E <$ pSym 'E' - <|> Note Nothing F <$ pSym 'F' - <|> Note Nothing G <$ pSym 'G' - <|> Note Nothing N <$ pSym 'N' -- for no chord - <|> Note (Just Fl) A <$ pString "Ab" - <|> Note (Just Fl) B <$ pString "Bb" - <|> Note (Just Fl) C <$ pString "Cb" - <|> Note (Just Fl) D <$ pString "Db" - <|> Note (Just Fl) E <$ pString "Eb" - <|> Note (Just Fl) F <$ pString "Fb" - <|> Note (Just Fl) G <$ pString "Gb" - <|> Note (Just Sh) A <$ pString "A#" - <|> Note (Just Sh) B <$ pString "B#" - <|> Note (Just Sh) C <$ pString "C#" - <|> Note (Just Sh) D <$ pString "D#" - <|> Note (Just Sh) E <$ pString "E#" - <|> Note (Just Sh) F <$ pString "F#" - <|> Note (Just Sh) G <$ pString "G#" "Chord root" diff --git a/src/HarmTrace/Tokenizer/Tokens.hs b/src/HarmTrace/Tokenizer/Tokens.hs deleted file mode 100644 --- a/src/HarmTrace/Tokenizer/Tokens.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceLabel (..) - , PieceToken (..), ParseStatus (..) - ) where - -import HarmTrace.Base.MusicRep -import HarmTrace.HAnTree.Binary -import Generics.Instant.TH -import Data.Binary - --------------------------------------------------------------------------------- --- Tokens for parsing chords --------------------------------------------------------------------------------- - --- merged Chords that will be presented to the parser -data ChordToken = ChordToken { root :: ScaleDegree - , classType :: ClassType - , chords :: [ChordLabel] - , status :: ParseStatus - , chordNumReps :: Int - , dur :: Int -- duration - } - -data ParseStatus = NotParsed | Parsed | Deleted | Inserted - deriving (Eq, Show) - --- a datatype to store a tokenized chords --- type PieceRelToken = PieceToken ChordDegree --- type PieceAbsToken = PieceToken ChordLabel -data PieceToken = PieceToken Key [ChordToken] -data PieceLabel = PieceLabel Key [ChordLabel] - --------------------------------------------------------------------------------- --- Instances for Chord Tokens --------------------------------------------------------------------------------- -instance Eq ChordToken where - (ChordToken sd clss _cs stat _n _d) == (ChordToken sd2 clss2 _cs2 stat2 _n2 _d2) - = sd == sd2 && clss == clss2 && stat == stat2 - -instance Show ChordToken where - show (ChordToken sd clss _cs Inserted _n _d) = show sd ++ show clss++"[Inserted]" - show (ChordToken sd clss cs Deleted _n _d) = - show sd ++ show clss ++ "[Deleted" ++ showChords cs ++ "]" - show (ChordToken sd clss cs _ _n d) = show sd ++ show clss ++ '_' : show d - ++ showChords cs -showChords :: Show a => [Chord a] -> String -showChords = concatMap (\x -> '[' : show x ++ "]") - - --------------------------------------------------------------------------------- --- Binary instances --------------------------------------------------------------------------------- - -deriveAllL [''ChordToken, ''ParseStatus] - -instance Binary ChordToken where - put = putDefault - get = getDefault -instance Binary ParseStatus where - put = putDefault - get = getDefault diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -17,7 +17,7 @@ import System.Console.CmdArgs.Explicit hiding (Arg) -import Constants (vERSION) +import Constants (vERSION, defaultChordPrinting) import HarmTrace.HarmTrace import HarmTrace.IO.Main @@ -30,54 +30,68 @@ import HarmTrace.Matching.Alignment (getAlignDist, alignChordLab , pPrintV, alignHAnChord) import HarmTrace.Audio.Annotate ( simpleAnnotator, groupAnnotator - , mptreeAnnotator) -import HarmTrace.Audio.ChordTypes -- (AudioFeat, ChordBeatAnnotation, TimedData) + , mptreeAnnotator, mptreeAnnotatorSTG) +import HarmTrace.Base.MusicTime-- (AudioFeat, ChordBeatAnnotation, TimedData) import HarmTrace.Base.MusicRep (Key) import Data.List (delete) import System.FilePath (takeFileName) import System.Exit (exitSuccess, exitFailure) +import System.Environment ( getArgs ) import Control.Monad (when) +import Data.List ( elemIndex ) +import Data.Monoid ( mempty ) -------------------------------------------------------------------------------- -- Top-level main -------------------------------------------------------------------------------- harmTrace :: Mode [MyArgs] -harmTrace = (modes "harmtrace" emptyArgs "Harmonic Analysis and Retrieval of Music" +harmTrace = (modes "harmtrace" mempty "Harmonic Analysis and Retrieval of Music" [parseMode, matchMode, recogniseMode]) { modeGroupFlags = toGroup (inputFlags : helpVerFlags) } inputFlags :: Flag [MyArgs] -inputFlags = flagReq ["r", "read-flags"] (upd "ReadFlags") +inputFlags = flagReq ["r"] (upd "ReadFlags") "file" "File to read flags from" main :: IO () -main = do -- Parse the arguments - args <- processArgs harmTrace +main = do -- Get the original args + cliArgs <- getArgs + -- Check if we've got -r + let rArgs = case elemIndex "-r" cliArgs of + -- We did, remove all the rest + Just n | length cliArgs > (n+1) + -> [cliArgs !! n, cliArgs !! (n+1)] + -- We did not, so all the flags come from the CLI + _ -> cliArgs + strippedArgs = processValue harmTrace rArgs -- Check if we should get flags from a file -- NOTE: reading flags such as --chords="A B" will not work, because -- there are spaces inside the string "A B", and `words` isn't clever -- enough to ignore those. - newArgs <- case (getArg args "ReadFlags") of - -- Nope, use the flags received - Nothing -> return args - -- Yes, read them from the file and overwrite the + newArgs <- case (getArg strippedArgs "ReadFlags") of + -- Nope, use the original flags + Nothing -> return (processValue harmTrace cliArgs) + -- Yes, read them from the file and merge with the -- received flags - Just f -> readFile f >>= - return . processValue harmTrace . words - + Just f -> do s <- readFile f + return $ processValue harmTrace + (words s ++ cliArgs) + -- Check mode and redirect control to appropriate function case (getArg newArgs "Mode") of Just "Parse" -> mainParse newArgs Just "Match" -> mainMatch newArgs Just "Recognise" -> mainRecognise newArgs Just m -> putStrLn ("Unknown mode: " ++ m) - Nothing -> do -- Handle help and version, if present - handleHelpVer newArgs harmTrace - putStrLn "Please supply a mode" + Nothing -> -- Handle help and version, if present + handleHelpVer newArgs harmTrace + -- If invoked without arguments, print help + when (null cliArgs) $ print (helpText [] HelpFormatDefault harmTrace) + -------------------------------------------------------------------------------- -- Parse mode -------------------------------------------------------------------------------- @@ -95,7 +109,7 @@ ,flagReq ["x", "key-dir"] (upd "AnnotationKeyInputDir") "filepath" "Ground-truth key annotation directory" ,flagNone ["p", "print"] ((Switch "Print"):) "Output a .png of the parse tree" ,flagNone ["s", "print-insertions"] ((Switch "PrintIns"):) "Show inserted nodes" - ] ++ helpVerFlags) + ] ++ inputFlags : helpVerFlags) where -- Flags without input upd0 "--print" args = Right $ Switch "Print" : args @@ -180,7 +194,7 @@ ,flagReq ["i", "in"] (upd "BinaryIn") "filepath" "Input binary file for matching" ,flagNone ["s", "print-insertions"] ((Switch "PrintIns"):) "Show inserted nodes" ,flagReq ["g", "grammar"] updG "string" "Grammar to use (jazz|pop)" - ] ++ helpVerFlags) + ] ++ inputFlags : helpVerFlags) where upd0 "--print-insertions" args = Right $ Switch "PrintIns" : args upd0 "-s" args = Right $ Switch "PrintIns" : args @@ -261,19 +275,28 @@ recogniseMode :: Mode [MyArgs] recogniseMode = mode "recognise" [Arg "Mode" "Recognise"] "Recognise chords from audio files" (flagArg upd0 "") - ([flagReq ["m", "mode"] upd1 "string" "Recognition mode (mptree|group|simple)" + ([flagReq ["m", "mode"] upd1 "string" "Recognition mode (mptree|group|simple|mpt-stg)" ,flagReq ["i", "file"] (upd "SourceInputFile") "filepath" "Input file" + ,flagReq ["l", "list"] (upd "SourceInputFileList") "filepath" "List with input files" ,flagReq ["c", "gt"] (upd "GroundTruthInputFile") "filepath" "Ground truth chord annotation file (for evaluation)" ,flagReq ["k", "key"] (upd "SourceKeyInputFile") "filepath" "Ground truth key annotation file" ,flagReq ["d", "dir"] (upd "InputDir") "filepath" "Input directory" ,flagReq ["v", "vamp-dir"] (upd "VampBaseDir") "filepath" "Vamp-plugin transform specification base directory" - ,flagReq ["o", "out-dir"] (upd "OutputDir") "filepath" "output directory (for logs and chords)" - ,flagReq ["f", "csv-dir"] (upd "CSVBaseDir") "filepath" "directory for storing the feature csv files" - ,flagReq ["t", "gt-dir"] (upd "GroundTruthInputDir") "filepath" "Ground truth chord annotation input directory (for evaluation)" - ,flagReq ["x", "key-dir"] (upd "AnnotationKeyInputDir") "filepath" "Ground truth chord annotation input directory (for evaluation)" + ,flagReq ["o", "out-dir"] (upd "OutputDir") "filepath" "output directory (for logs and chords)" + ,flagReq ["f", "csv-dir"] (upd "CSVBaseDir") "filepath" "directory for storing the feature csv files" + ,flagReq ["w", "log-dir"] (upd "LogBaseDir") "filepath" "directory for storing the feature extraction logs (for every processed file)" + ,flagReq ["s", "sa-path"] (upd "SonicAnnotator") "filepath" "Path to the sonic annotator executable (it is assumed to be in the path by default)" + ,flagReq ["t", "gt-dir"] (upd "GroundTruthInputDir") "filepath" "Ground-truth chord annotation input directory (for evaluation)" + ,flagReq ["x", "key-dir"] (upd "AnnotationKeyInputDir") "filepath" + ("Ground-truth key annotation input directory (for evaluation). " ++ + "This flag also functions as a switch for selecting harmtrace chord " ++ + "recognision using ground-truth key annotations. Using this flag without " ++ + "the --gt-dir flag will trigger the evaluation of the key finding only. " ++ + "Similarly, using this flag together with -i will trigger the key finding" ++ + "of that specific file") ,flagReq ["g", "grammar"] updG "string" "Grammar to use (jazz|pop)" ,flagNone ["p", "print"] ((Switch "Print"):) "Output a .png of the parse tree" - ] ++ helpVerFlags) + ] ++ inputFlags : helpVerFlags) where upd0 "--print" args = Right $ Switch "Print" : args upd0 "-p" args = Right $ Switch "Print" : args @@ -282,21 +305,25 @@ upd1 "group" args = Right $ (RecognitionMode (RecognitionFun groupAnnotator)) : args upd1 "simple" args = Right $ (RecognitionMode (RecognitionFun simpleAnnotator)) : args upd1 "mptree" args = Right $ (RecognitionMode (RecognitionFun mptreeAnnotator)) : args + upd1 "mpt-stg" args = Right $ (RecognitionMode (RecognitionFun mptreeAnnotatorSTG)) : args upd1 s _ = Left $ "Unknown recognition mode: " ++ s mainRecognise :: [MyArgs] -> IO () mainRecognise args = do let af = getArg args "SourceInputFile" gt = getArg args "GroundTruthInputFile" + lst = getArg args "SourceInputFileList" key = getArg args "SourceKeyInputFile" afdir = getArg args "InputDir" gtdir = getArg args "GroundTruthInputDir" keydir = getArg args "AnnotationKeyInputDir" prnt = gotArg args "Print" + mout = getArg args "OutputDir" dirs = setPaths (getArg args "VampBaseDir") (getArg args "CSVBaseDir") - (getArg args "OutputDir") - + mout + (getArg args "LogBaseDir") + (getArg args "SonicAnnotator") -- Handle help and version, if present handleHelpVer args recogniseMode @@ -304,27 +331,40 @@ case (getGram args) of Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure Just g -> - let ann :: Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation + let ann :: Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation ann = (getAnn args) g - in case (gt,af,key,gtdir,afdir,keydir) of + in case (gt,af,key,gtdir,afdir,keydir,lst) of -- evaluates a single audio feature set - (Just g, Just a, Nothing, Nothing, Nothing, Nothing) -> + (Just g, Just a, Nothing, Nothing, Nothing, Nothing, Nothing) -> evaluateLabeling ann prnt g a Nothing >>= print -- evaluates a single audio feature set and key annotation - (Just g, Just a, maybek, Nothing, Nothing, Nothing) -> + (Just g, Just a, maybek, Nothing, Nothing, Nothing, Nothing) -> evaluateLabeling ann prnt g a maybek >>= print + (Nothing, Just a, Nothing, Nothing, Nothing, Just keydir, Nothing) -> + evaluateKeyFinding prnt a keydir -- evaluates a single audio feature set and prints the auto-labelling -- This is the only option that automatically extracts features -- from an audio file (if no features, and an audio file are found) -- TODO enable feature extraction for all options - (Nothing, Just a, Nothing, Nothing, Nothing, Nothing) -> - printLabeling dirs ann a - -- evaluates a directory with audio features - (Nothing, Nothing, Nothing, Just gd, Just ad, Nothing) -> - batchLabeling ann gd ad Nothing + (Nothing, Just a, Nothing, Nothing, Nothing, Nothing, Nothing) -> + printLabelling defaultChordPrinting dirs ann a + -- takes a list of files and prints the chords to files + (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just a) -> + batchPrintLabelling defaultChordPrinting dirs ann a + -- evaluates a directory with audio features, when an output flag + -- is present we also store the chords in a file (the actual + -- output dir is stored in a 'BasePaths') + (Nothing, Nothing, Nothing, Just gd, Just ad, Nothing, Nothing) -> + batchLabeling defaultChordPrinting mout ann gd ad Nothing -- evaluates a directory with audio features and key annotations - (Nothing, Nothing, Nothing, Just gd, Just ad, maybek) -> - batchLabeling ann gd ad maybek + (Nothing, Nothing, Nothing, Just gd, Just ad, maybek, Nothing) -> + batchLabeling defaultChordPrinting mout ann gd ad maybek + -- if we only encounter audio features and key annotations (and no + -- ground-truth chords), we evaluate only the key finding. I agree + -- this is rather hacky... (the annotator options are completely + -- ignored) + (Nothing, Nothing, Nothing, Nothing, Just ad, Just key, Nothing) -> + batchEvaluateKeyFinding ad key _ -> usageError args err4 -------------------------------------------------------------------------------- @@ -338,7 +378,7 @@ deriving (Eq, Show) newtype RecognitionFun = RecognitionFun (GrammarEx -> Maybe [TimedData Key] - -> AudioFeat -> ChordBeatAnnotation) + -> AudioFeat -> ChordAnnotation) instance Show RecognitionFun where show _ = "RecognitionFun" @@ -346,9 +386,6 @@ instance Eq RecognitionFun where _ == _ = error "please do not use this" -emptyArgs :: [MyArgs] -emptyArgs = [] - -- Grammar parser updG :: String -> [MyArgs] -> Either String [MyArgs] updG "jazz" args = Right $ (Grammar (GrammarEx Jazz)) : args @@ -370,7 +407,7 @@ getMode (_:t) = getMode t getAnn :: [MyArgs] -> (GrammarEx -> Maybe [TimedData Key] -> AudioFeat - -> ChordBeatAnnotation) + -> ChordAnnotation) getAnn [] = error "impossible?" getAnn ((RecognitionMode (RecognitionFun f)):_) = f getAnn (_:t) = getAnn t @@ -400,7 +437,8 @@ when ver $ putStrLn vERSION >> exitSuccess -- Output help and exit - when help $ print (helpText [] HelpFormatDefault mode) >> exitSuccess + when help $ + print (helpText [] HelpFormatDefault mode) >> exitSuccess -------------------------------------------------------------------------------- -- Misc