{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
--------------------------------------------------------------------------------
-- |
-- Module : Main
-- 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: Top-level file
--------------------------------------------------------------------------------
module Main where
import System.Console.CmdArgs.Explicit hiding (Arg)
import Constants (vERSION, defaultChordPrinting)
import HarmTrace.HarmTrace
import HarmTrace.IO.Main
import HarmTrace.IO.Errors
import HarmTrace.IO.PrintTree
import HarmTrace.IO.BasePaths (setPaths)
import HarmTrace.HAnTree.ToHAnTree (gTreeHead)
import HarmTrace.Matching.Standard
import HarmTrace.Matching.GuptaNishimura (getLCES)
import HarmTrace.Matching.Alignment (getAlignDist, alignChordLab
, pPrintV, alignHAnChord)
import HarmTrace.Audio.Annotate ( simpleAnnotator, groupAnnotator
, 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" mempty "Harmonic Analysis and Retrieval of Music"
[parseMode, matchMode, recogniseMode])
{ modeGroupFlags = toGroup (inputFlags : helpVerFlags) }
inputFlags :: Flag [MyArgs]
inputFlags = flagReq ["r"] (upd "ReadFlags")
"file" "File to read flags from"
main :: IO ()
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 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 -> 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 -> -- Handle help and version, if present
handleHelpVer newArgs harmTrace
-- If invoked without arguments, print help
when (null cliArgs) $ print (helpText [] HelpFormatDefault harmTrace)
--------------------------------------------------------------------------------
-- Parse mode
--------------------------------------------------------------------------------
parseMode :: Mode [MyArgs]
parseMode = mode "parse" [Arg "Mode" "Parse"] "Parse files into harmonic analysis trees"
(flagArg upd0 "")
([flagReq ["g", "grammar"] updG "string" "Grammar to use (jazz|pop)"
,flagReq ["c", "chords"] (upd "SourceInputString") "string" "Input chord sequence to parse"
,flagReq ["i", "file"] (upd "SourceInputFile") "filepath" "Input file to parse"
,flagReq ["d", "dir"] (upd "InputDir") "filepath" "Input directory to parse all files within"
,flagReq ["o", "out"] (upd "BinaryOut") "filepath" "Output binary file to write parse results to"
-- We should add a flag for describing that when using -k we are
-- reading files in a different input syntax...
,flagReq ["k", "key"] (upd "SourceKeyInputFile") "filepath" "Ground-truth key annotation file"
,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"
] ++ inputFlags : helpVerFlags)
where -- Flags without input
upd0 "--print" args = Right $ Switch "Print" : args
upd0 "-p" args = Right $ Switch "Print" : args
upd0 "--print-insertions" args = Right $ Switch "PrintIns" : args
upd0 "-s" args = Right $ Switch "PrintIns" : args
upd0 s _ = Left $ "Unknown argument: " ++ s
mainParse :: [MyArgs] -> IO ()
mainParse args =
do let cStr = getArg args "SourceInputString"
sif = getArg args "SourceInputFile"
ky = getArg args "SourceKeyInputFile"
bOut = getArg args "BinaryOut"
mdir = getArg args "InputDir"
kdir = getArg args "AnnotationKeyInputDir"
prnt = gotArg args "Print"
opts = if gotArg args "PrintIns"
then delete RemoveInsertions defaultOpts else defaultOpts
-- Handle help and version, if present
handleHelpVer args parseMode
case (getGram args) of
Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure
Just (GrammarEx g) ->
case (cStr, sif,mdir, prnt, ky, kdir) of
-- parse a string of chords
(Just c, Nothing, Nothing, False, Nothing, Nothing) ->
do pr <- parseTreeVerb g opts c
mapM_ (print . gTreeHead) (parsedPiece pr)
-- and print a parsetree
(Just c, Nothing, Nothing, True, Nothing, Nothing) ->
do pr <- parseTree g opts c
let ts = map gTreeHead (parsedPiece pr)
_ <- printTreeHAn (pieceTreeHAn pr) (trimFilename ("pp" ++ c))
printTreeHAnF ts (trimFilename c) >> return ()
-- Parse one file, show full output
(Nothing, Just f1, Nothing, False, Nothing, Nothing) ->
do pr <- readFile f1 >>= parseTreeVerb g opts
print (pieceTreeHAn pr)
mapM_ (print . gTreeHead) (parsedPiece pr)
(Nothing, Just f1, Nothing , True, Nothing, Nothing) ->
--with post processing
do pr <- readFile f1 >>= parseTree g opts
let ts = map gTreeHead (parsedPiece pr)
printTreeHAn (pieceTreeHAn pr) (f1 ++ ".postProc") >> return ()
printTreeHAnF ts f1 >> return ()
-- Parse all files in one dir, show condensed output
(Nothing, Nothing, Just dir, False, Nothing, Nothing) ->
parseDir g opts dir bOut
-- ** audio ground-truth annotation part **
(Nothing, Just f1, Nothing, False, Just kf, Nothing) ->
-- parse a ground-truth annotation and its key and give verbose output
do key <- readFile kf
pr <- readFile f1 >>= parseAnnotationVerb g opts key
print (pieceTreeHAn pr)
mapM_ (print . gTreeHead) (take 10 $ parsedPiece pr)
(Nothing, Just f1, Nothing, True , Just kf, Nothing) ->
-- parse a ground-truth annotation and its key and print the parse
do key <- readFile kf
pr <- readFile f1 >>= parseAnnotation g opts key
let ts = map gTreeHead (parsedPiece pr)
printTreeHAn (pieceTreeHAn pr) (f1 ++ ".postProc") >> return ()
printTreeHAnF ts f1 >> return ()
-- Parse all files in one dir, show condensed output
(Nothing, Nothing, Just dir, False, Nothing, Just kd) ->
parseAnnotationDir g opts kd dir
-- Else throw error
_ -> usageError args err1
--------------------------------------------------------------------------------
-- Match mode
--------------------------------------------------------------------------------
matchMode :: Mode [MyArgs]
matchMode = mode "match" [Arg "Mode" "Match"] "Harmonic similarity matching"
(flagArg upd0 "")
([flagReq ["m", "mode"] upd1 "string" "Matching mode (stdiff|lces-s|lcessim|hanlign|align)"
,flagReq ["1", "sfile"] (upd "SourceInputFile") "filepath" "Source file to match"
,flagReq ["2", "tfile"] (upd "TargetInputFile") "filepath" "Target file to match"
,flagReq ["d", "dir"] (upd "InputDir") "filepath" "Input directory to parse all files within"
,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)"
] ++ inputFlags : helpVerFlags)
where upd0 "--print-insertions" args = Right $ Switch "PrintIns" : args
upd0 "-s" args = Right $ Switch "PrintIns" : args
upd0 s _ = Left $ "Unknown argument: " ++ s
upd1 "stdiff" args = Right $ (MatchMode STDiff) : args
upd1 "lces-s" args = Right $ (MatchMode LCESsize) : args
upd1 "lcessim" args = Right $ (MatchMode LCESsim) : args
upd1 "hanlign" args = Right $ (MatchMode HAnAlign) : args
upd1 "align" args = Right $ (MatchMode Align) : args
upd1 s _ = Left $ "Unknown match mode: " ++ s
mainMatch :: [MyArgs] -> IO ()
mainMatch args =
do let cStr = getArg args "SourceInputString"
sif = getArg args "SourceInputFile"
mf2 = getArg args "TargetInputFile"
mdir = getArg args "InputDir"
bIn = getArg args "BinaryIn"
me = getArg args "MaxErrorRate"
mode = getMode args
prnt = gotArg args "Print"
opts = if gotArg args "PrintIns"
then delete RemoveInsertions defaultOpts else defaultOpts
-- Handle help and version, if present
handleHelpVer args matchMode
case (getGram args) of
Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure
Just (GrammarEx g) ->
case (cStr,sif,mf2,mdir,prnt) of
-- Parse source and target file, show full output
(_, Just f1, Just f2, Nothing, _) ->
do c1 <- readFile' f1
c2 <- readFile' f2
matchFiles opts mode prnt c1 c2 f1 f2
(Just c, Just f1, Nothing, Nothing, True) ->
matchFiles opts mode True c f1 (trimFilename c) (trimFilename f1)
-- match all files in one dir, show condensed output
(_,Nothing, Nothing, Just dir, False) -> dirMatch g opts bIn mode (fmap read me) dir
_ -> usageError args err2
matchFiles :: [PPOption] -> MatchMode -> Bool -> String -> String
-> FilePath -> FilePath -> IO ()
matchFiles o m prnt f1 f2 n1 n2 =
-- should move to HarmTrace.IO.Main
let (ParseResult key1 toks1 _ ts1 _nr1 te1 pe1 _)
= postProc o $ string2Piece Jazz f1
(ParseResult key2 toks2 _ ts2 _nr2 te2 pe2 _)
= postProc o $ string2Piece Jazz f2
in
do if not $ null te1 then showErrors "tokenizer 1: " te1 else putStr ""
if not $ null te2 then showErrors "tokenizer 2: " te2 else putStr ""
if not $ null pe1 then showErrors "parser 1: " pe1 else putStr ""
if not $ null pe2 then showErrors "parser 2: " pe2 else putStr ""
case (m,prnt) of
(STDiff,_) -> print (diffChordsLen toks1 toks2)
(Align ,False) -> print (getAlignDist key1 key2 toks1 toks2)
(Align ,True ) -> do let (mat,v,t) = alignChordLab key1 key2 toks1 toks2
pPrintV t; print mat ; print v
(HAnAlign,True ) -> do let (mat,v,t) = alignHAnChord ts1 ts2
pPrintV t; print mat ; print v
-- quick and dirty LCES plotting (should move to HarmTrace.IO)
(LCESsize,True) ->
do printTreeHAn ts1 (n1 ++ ".postProc") >> return ()
printTreeHAn ts2 (n2 ++ ".postProc") >> return ()
printTreeHAnF (fst $ getLCES ts1 ts2)
( (take 10 $ takeFileName n1) ++ ".vs."
++ (take 10 $ takeFileName n2) ++ ".lces") >> return ()
_ -> error "Unimplemented."
--------------------------------------------------------------------------------
-- Recognise mode
--------------------------------------------------------------------------------
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|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 ["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"
] ++ inputFlags : helpVerFlags)
where upd0 "--print" args = Right $ Switch "Print" : args
upd0 "-p" args = Right $ Switch "Print" : args
upd0 s _ = Left $ "Unknown argument: " ++ s
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")
mout
(getArg args "LogBaseDir")
(getArg args "SonicAnnotator")
-- Handle help and version, if present
handleHelpVer args recogniseMode
case (getGram args) of
Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure
Just g ->
let ann :: Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation
ann = (getAnn args) g
in case (gt,af,key,gtdir,afdir,keydir,lst) of
-- evaluates a single audio feature set
(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, 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, 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, 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
--------------------------------------------------------------------------------
-- Arguments and utilities
--------------------------------------------------------------------------------
data MyArgs = Grammar GrammarEx
| MatchMode MatchMode
| RecognitionMode RecognitionFun
| Arg String String
| Switch String
deriving (Eq, Show)
newtype RecognitionFun = RecognitionFun (GrammarEx -> Maybe [TimedData Key]
-> AudioFeat -> ChordAnnotation)
instance Show RecognitionFun where
show _ = "RecognitionFun"
instance Eq RecognitionFun where
_ == _ = error "please do not use this"
-- Grammar parser
updG :: String -> [MyArgs] -> Either String [MyArgs]
updG "jazz" args = Right $ (Grammar (GrammarEx Jazz)) : args
updG "pop" args = Right $ (Grammar (GrammarEx Pop)) : args
updG s _ = Left $ "Unknown grammar: " ++ s
-- General update function
upd :: String -> String -> [MyArgs] -> Either String [MyArgs]
upd c s args = Right $ (Arg c s) : args
getGram :: [MyArgs] -> Maybe GrammarEx
getGram [] = Nothing
getGram ((Grammar g):_) = Just g
getGram (_:t) = getGram t
getMode :: [MyArgs] -> MatchMode
getMode [] = error "impossible?"
getMode ((MatchMode m):_) = m
getMode (_:t) = getMode t
getAnn :: [MyArgs] -> (GrammarEx -> Maybe [TimedData Key] -> AudioFeat
-> ChordAnnotation)
getAnn [] = error "impossible?"
getAnn ((RecognitionMode (RecognitionFun f)):_) = f
getAnn (_:t) = getAnn t
gotArg :: [MyArgs] -> String -> Bool
gotArg [] _ = False
gotArg ((Switch k):_) s | k == s = True
gotArg (_:t) s = gotArg t s
getArg :: [MyArgs] -> String -> Maybe String
getArg [] _ = Nothing
getArg ((Arg k v):_) s | k == s = Just v
getArg (_:t) s = getArg t s
-- Help and Version flags, used in all modes
helpVerFlags :: [Flag [MyArgs]]
helpVerFlags = [ flagHelpSimple ((Switch "Help"):)
, flagVersion ((Switch "Version"):)]
-- Handler for the Help and Version flags
handleHelpVer :: [MyArgs] -> Mode [MyArgs] -> IO ()
handleHelpVer args mode = do
let ver = gotArg args "Version"
help = gotArg args "Help"
-- Output version and exit
when ver $ putStrLn vERSION >> exitSuccess
-- Output help and exit
when help $
print (helpText [] HelpFormatDefault mode) >> exitSuccess
--------------------------------------------------------------------------------
-- Misc
--------------------------------------------------------------------------------
err1, err2, err3, err4 :: String
err1 = "Use a source file, or a directory."
err2 = "Use a source file and a target file, or a directory."
err3 = "Use a source file and optionally a target file."
err4 = "Use an audio-feature location and a ground-truth file, "++
"or an audio-feature directory and a ground-truth directory."
usageError :: [MyArgs] -> String -> IO ()
usageError _args err = putStrLn err
trimFilename :: String -> String
trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20
-- by default all post processing operations are executed
defaultOpts :: [PPOption]
defaultOpts = [ RemovePDPT , RemoveInsertions
, MergeDelChords, ExpandChordDurations ]