{-# 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]