{-# 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");