{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE FlexibleInstances #-} module Main where -- Libs import System.Console.ParseArgs hiding (args) -- Music stuff import HarmTrace.HarmTrace import HarmTrace.IO.Main import HarmTrace.IO.Errors import HarmTrace.IO.PrintTree import HarmTrace.HAnTree.ToHAnTree (gTreeHead) --import HarmTrace.Matching.GuptaNishimuraEditMatch import HarmTrace.Matching.Standard -- import HarmTrace.Matching.Matching (printBPM) import HarmTrace.Matching.Alignment (getAlignDist, alignChordLab, pPrintV, alignHAnChord) -- import HarmTrace.Matching.Sim (maxSim) import Data.List (delete) -------------------------------------------------------------------------------- -- Command-line arguments -------------------------------------------------------------------------------- data MyArgs = SourceInputString | SourceInputFile | TargetInputFile | InputDir | OpMode | Print | MaxErrorRate | BinaryOut | BinaryIn | PrintIns | Grammar 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 (process all files within)" }, Arg { argIndex = OpMode, argAbbr = Just 'm', argName = Just "mode", argData = argDataRequired "string" ArgtypeString, argDesc = "Matching mode (parse|stdiff|lces|hanlign|align)" }, Arg { argIndex = Grammar, argAbbr = Just 'g', argName = Just "grammar", argData = argDataRequired "string" ArgtypeString, argDesc = "Grammar to use (jazz|test|pop)" }, Arg { argIndex = Print, argAbbr = Just 'p', argName = Just "print", argData = Nothing, argDesc = "Set this flag to print a .png of the parse" }, Arg { argIndex = PrintIns, argAbbr = Just 's', argName = Just "print-insertions", argData = Nothing, argDesc = "Set this flag to show inserted nodes" }, 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 -------------------------------------------------------------------------------- -- by default all post processing operations are executed defaultOpts :: [PPOption] defaultOpts = [ RemovePDPT , RemoveInsertions , MergeDelChords, ExpandChordDurations ] 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 grmS = getRequiredArg args Grammar prnt = gotArg args Print opts = if gotArg args PrintIns then delete RemoveInsertions defaultOpts else defaultOpts gram = case grmS of "jazz" -> GrammarEx Jazz "pop" -> GrammarEx Pop "test" -> GrammarEx Test s -> usageError args ("Unknown grammar: " ++ s) case mode of "parse" -> mainParse args opts prnt gram "stdiff" -> mainMatch args opts False STDiff gram "hanlign"-> mainMatch args opts prnt HAnAlign gram "lces" -> mainMatch args opts prnt LCES gram "align" -> mainMatch args opts prnt Align gram s -> usageError args ("Unknown mode: " ++ s) mainParse :: Args MyArgs -> [PPOption] -> Bool -> GrammarEx -> IO () mainParse args o p (GrammarEx g) = do 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) -> do pr <- parseTreeVerb g o c mapM_ (print . gTreeHead) (parsedPiece pr) -- and print a parsetree (Just c, Nothing, Nothing, Nothing , True) -> do pr <- parseTree g o 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, Nothing , False) -> do pr <- readFile f1 >>= parseTreeVerb g o print (pieceTreeHAn pr) mapM_ (print . gTreeHead) (parsedPiece pr) (Nothing, Just f1, Nothing, Nothing , True ) -> --with post processing do pr <- readFile f1 >>= parseTree g o 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, Nothing, Just dir, False) -> parseDir g o dir bOut _ -> usageError args err1 trimFilename :: String -> String trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 mainMatch :: Args MyArgs -> [PPOption] -> Bool -> MatchMode -> GrammarEx -> IO () mainMatch args o p m (GrammarEx g) = do 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 o m prnt c1 c2 f1 f2 (Just c, Just f1, Nothing, Nothing, True) -> matchFiles o m True c f1 (trimFilename c) (trimFilename f1) -- match all files in one dir, show condensed output (_,Nothing, Nothing, Just dir, False) -> dirMatch g o bIn m me dir _ -> usageError args err2 matchFiles :: [PPOption] -> MatchMode -> Bool -> String -> String -> String -> String -> 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 (HAnAlign,False) -> error "Unimplemented." (LCES,False) -> error "Unimplemented." (LCES,True) -> do putStrLn ("refactor me");