{-# OPTIONS_GHC -Wall #-} module Main where -- Libs import System.Console.ParseArgs hiding (args) -- cabal install parseargs import System.FilePath import System.IO import Data.Maybe (isJust, fromJust) import Data.Binary -- Music stuff import HarmTrace.HarmTrace import HarmTrace.Base.MusicRep import HarmTrace.IO.Main import HarmTrace.IO.Errors import HarmTrace.Matching.GuptaNishimuraEditMatch import HarmTrace.Matching.Standard import HarmTrace.Matching.Matching import HarmTrace.IO.PrintTree import HarmTrace.HAnTree.Tree (Tree) import HarmTrace.HAnTree.HAn import HarmTrace.Matching.Sim (selfSim) -- Parallelism import Control.Parallel.Strategies -------------------------------------------------------------------------------- -- Command-line arguments -------------------------------------------------------------------------------- data MyArgs = SourceInputString | SourceInputFile | TargetInputFile | InputDir | OpMode | Print | MaxErrorRate | BinaryOut | BinaryIn deriving (Eq, Ord, Show) myArgs :: [Arg MyArgs] myArgs = [ Arg { argIndex = MaxErrorRate, argAbbr = Just 'e', argName = Just "max-error", argData = argDataOptional "float" ArgtypeFloat, argDesc = "Ignore pieces with higher error rate for diff" }, Arg { argIndex = SourceInputString, argAbbr = Just 'c', argName = Just "chords", argData = argDataOptional "string" ArgtypeString, argDesc = "Input Chord Sequence to parse" }, Arg { argIndex = SourceInputFile, argAbbr = Just '1', argName = Just "sfile", argData = argDataOptional "filepath" ArgtypeString, argDesc = "Input file (source for diff)" }, Arg { argIndex = TargetInputFile, argAbbr = Just '2', argName = Just "tfile", argData = argDataOptional "filepath" ArgtypeString, argDesc = "Input file (target for diff)" }, Arg { argIndex = InputDir, argAbbr = Just 'd', argName = Just "dir", argData = argDataOptional "directory" ArgtypeString, argDesc = "Input directory (to process all files within)" }, Arg { argIndex = OpMode, argAbbr = Just 'm', argName = Just "mode", argData = argDataRequired "parse|stdiff|lces|bpm" ArgtypeString, argDesc = "One of \"parse\", \"lces\", \"stdiff\", "++ "or \"bpm\"" }, Arg { argIndex = Print, argAbbr = Just 'p', argName = Just "print", argData = Nothing, argDesc = "Set this flag to generate a .png for an input file" }, Arg { argIndex = BinaryOut, argAbbr = Just 'o', argName = Just "out", argData = argDataOptional "filepath" ArgtypeString, argDesc = "Output binary file for parsing results" }, Arg { argIndex = BinaryIn, argAbbr = Just 'i', argName = Just "in", argData = argDataOptional "filepath" ArgtypeString, argDesc = "Input binary file for matching" } ] -------------------------------------------------------------------------------- -- Main -------------------------------------------------------------------------------- data MatchMode = STDiff | LCES | BPMatch deriving (Eq, Ord, Show) err1, err2, err3 :: 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." main :: IO () main = do args <- parseArgsIO ArgsComplete myArgs let mode = getRequiredArg args OpMode prnt = gotArg args Print case mode of "parse" -> mainParse prnt "stdiff" -> mainMatch False STDiff "bpm" -> mainMatch prnt BPMatch "lces" -> mainMatch prnt LCES s -> usageError args ("Unknown mode: " ++ s) mainParse :: Bool -> IO () mainParse p = do args <- parseArgsIO ArgsComplete myArgs let cStr = getArgString args SourceInputString mf1 = getArgString args SourceInputFile mf2 = getArgString args TargetInputFile bOut = getArgString args BinaryOut mdir = getArgString args InputDir case (cStr, mf1,mf2,mdir, p) of -- parse a string of chords (Just c, Nothing, Nothing, Nothing , False) -> parseTree c >> return () (Just c, Nothing, Nothing, Nothing , True) -> do ts <- parseTree c printTreeHAnF ts (trimFilename c) >> return () -- Parse one file, show full output (Nothing, Just f1, Nothing, Nothing , False) -> do ts <- readFile f1 >>= parseTreeVerb mapM_ print ts (Nothing, Just f1, Nothing, Nothing , True ) -> --with post processing do ts <- readFile f1 >>= parseTree printTreeHAnF ts f1 >> return () -- Parse all files in one dir, show condensed output (Nothing, Nothing, Nothing, Just dir, False) -> parseDir dir bOut _ -> usageError args err1 trimFilename :: String -> String trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 mainMatch :: Bool -> MatchMode -> IO () mainMatch p m = do args <- parseArgsIO ArgsComplete myArgs let cStr = getArgString args SourceInputString mf1 = getArg args SourceInputFile mf2 = getArg args TargetInputFile mdir = getArg args InputDir bIn = getArgString args BinaryIn me = getArg args MaxErrorRate case (cStr,mf1,mf2,mdir,p) of -- Parse source and target file, show full output (_,Just f1, Just f2, Nothing, prnt) -> do c1 <- readFile' f1 c2 <- readFile' f2 matchFiles m prnt c1 c2 f1 f2 (Just c, Just f1, Nothing, Nothing, True) -> matchFiles m True c f1 (trimFilename c) (trimFilename f1) -- match all files in one dir, show condensed output (_,Nothing, Nothing, Just dir, False) -> testDirMatch bIn m me dir _ -> usageError args err2 printSelfSims :: Tree HAn -> Tree HAn -> IO() printSelfSims a b = putStrLn (str a ++ str b) where str x = "self similarity" ++ (show $ selfSim x) matchFiles :: MatchMode -> Bool -> String -> String -> String -> String -> IO () matchFiles m prnt f1 f2 _n1 _n2 = let (toks1, _, ts1, te1, pe1) = string2PieceCPostProc f1 (toks2, _, ts2, te2, pe2) = string2PieceCPostProc 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) (BPMatch,True) -> printBPM 2 (head ts1) (head ts2) (BPMatch,False) -> error "Unimplemented." -- putStrLn ( "score: " ++ show (getMatch 2 ts1 ts2)) (LCES,False) -> do printSelfSims (head ts1) (head ts2) putStrLn ("1vs2\n" ++show lcesab ++ "\nscore: " ++ show scoreab) putStrLn ("2vs1\n" ++show lcesba ++ "\nscore: " ++ show scoreba) putStrLn ("self Simlarity 1: " ++ (show . selfSim $ head ts1)) putStrLn ("self Simlarity 2: " ++ (show . selfSim $ head ts2)) where (lcesab,lcesba,scoreab,scoreba) = matchTwo (head ts1) (head ts2) (LCES,True) -> do {- printTreeHAnF (show ts1) ( n1 <.> "png") >> return () printTreeHAnF (show ts2) ( n2 <.> "png") >> return () printTreeHAn (show lcesab) ("match1vs2" <.> "png") >> return () printTreeHAn (show lcesba) ("match2vs1" <.> "png") >> return () printSelfSims ts1 ts2 -} putStrLn ("refactor me"); matchTwo :: Tree HAn -> Tree HAn -> ([Tree HAn], [Tree HAn], Float, Float) matchTwo ta tb = (lcesab,lcesba,scoreab,scoreba) where (lcesab, scoreab) = getWeightLCES ta tb (lcesba, scoreba) = getWeightLCES tb ta -- filters the songs that have multiple versions and can be used as query filterNonQuery :: [FilePath] -> [FilePath] filterNonQuery = concatMap snd . filter ((>1) . length . snd) . getClassSizes -- matches a directory of chord description files testDirMatch :: Maybe FilePath -> MatchMode -> Maybe Float -> FilePath -> IO () testDirMatch bIn m me fp = do fs <- readDataDir fp let process s = let (tks, _, ts, _, e2) = string2PieceCPostProc s in (tks, head ts, errorRatio e2 tks) filterError = if isJust me then filter (\(_,_,e) -> e <= fromJust me) else id pss <- mapM (\f -> readFile' (fp f)) fs (tks, ps) <- case bIn of Just bp -> decodeFile bp :: IO ([[ChordLabel]],[Tree HAn]) Nothing -> let (toks, ps', _) = unzip3 (filterError (map process pss)) in return (toks, ps' `using` parList rdeepseq) let fsq = filterNonQuery fs putStr "true\n" if (m == LCES || m == BPMatch) then putStr "false\n" else putStr "true\n" mapM_ (putStr . (++ "\t")) fsq putChar '\n' mapM_ (putStr . (++ "\t"). getId) fs putStrLn "" let match sim l = [ [ sim x y | y <- l ] | (x,i) <- zip l (map getId fs), i `elem` fsq ] printLine l = putStrLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) >> hFlush stdout let r = (case m of STDiff -> match diffChordsLen tks LCES -> match getSimLCES ps BPMatch -> match (getMatch 2) ps) -- we could use nr-of-cores threads to pars nr-of-cores chunks... -- `using` parListChunk numCapabilities rdeepseq -- ... but this is just faster `using` parList rdeepseq sequence_ [ printLine x | x <- r]