diff --git a/HarmTrace.cabal b/HarmTrace.cabal new file mode 100644 --- /dev/null +++ b/HarmTrace.cabal @@ -0,0 +1,43 @@ +name: HarmTrace +version: 0.1 +synopsis: HarmTrace: Harmony Analysis and Retrieval of Music + with Type-level Representations of Abstract + Chords Entities +description: This is the first public release of HarmTrace, a system + for automatically analysing the harmony of music + sequences. HarmTrace is described in the paper: + . + * José Pedro Magalhães and W. Bas de Haas. + /Experience Report: Functional Modelling of Musical Harmony./ + International Conference on Functional Programming, + 2011. + + +copyright: (c) 2010--2011 Universiteit Utrecht +license: OtherLicense +license-file: LICENSE +author: W. Bas de Haas and José Pedro Magalhães +stability: experimental +maintainer: bash@cs.uu.nl, jpm@cs.uu.nl +category: Music +build-type: Custom +cabal-version: >= 1.6 +tested-with: GHC == 7.0.3 + +executable mir + hs-source-dirs: . + main-is: Main.hs + build-depends: base >= 4.2 && < 4.4, template-haskell >=2.4 && <2.6, + mtl, directory, filepath, array, parallel >= 3, + Diff == 0.1.*, parseargs >= 0.1.3.2, + regex-tdfa == 1.1.*, process >= 1.0, + uu-parsinglib == 2.7.1, ListLike >= 3.0.1, + vector == 0.7.*, deepseq, + -- temporary + containers, syb, ghc-prim + ghc-options: -Wall + -O2 -fno-spec-constr-count -funbox-strict-fields + -fcontext-stack=50 + -threaded -feager-blackholing -rtsopts + + ghc-prof-options: -auto-all diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +This work is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/3.0/ or send a letter to Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,173 @@ +{-# 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.List (unzip4) +import Control.Monad (when) + +-- Music stuff +import MIR.Run + +-- Parallelism +import Control.Parallel.Strategies + +-------------------------------------------------------------------------------- +-- Command-line arguments +-------------------------------------------------------------------------------- + +data MyArgs = SourceInputString | SourceInputFile | TargetInputFile + | InputDir | OpMode | Print | MaxErrorRate | WriteGT + 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|gdiff|stdiff" + ArgtypeString, + argDesc = "One of \"parse\", \"diff\", or \"stdiff\"" + }, + 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 = WriteGT, + argAbbr = Just 'g', + argName = Just "writegt", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Write ground truth to file" + } + ] + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + + +data MatchMode = STDiff | GDiff + 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 + "gdiff" -> mainDiff False GDiff -- diffs cannot be printed + "stdiff" -> mainDiff False STDiff + s -> usageError args ("Unknown mode: " ++ s) + +mainParse :: Bool -> IO () +mainParse p = do args <- parseArgsIO ArgsComplete myArgs + -- cdir <- getCurrentDirectory + let cStr = getArgString args SourceInputString + mf1 = getArgString args SourceInputFile + mf2 = getArgString args TargetInputFile + mdir = getArgString args InputDir + case (cStr, mf1,mf2,mdir, p) of + -- parse a string of chords + (Just c, Nothing, Nothing, Nothing , False) + -> parseTree c + -- Parse one file, show full output + (Nothing, Just f1, Nothing, Nothing , False) + -> readFile' f1 >>= parseTree + -- Parse all files in one dir, show condensed output + (Nothing, Nothing, Nothing, Just dir, False) + -> testDir dir + _ -> usageError args err1 + + + +mainDiff :: Bool -> MatchMode -> IO () +mainDiff p m = + do args <- parseArgsIO ArgsComplete myArgs + let mf1 = getArg args SourceInputFile + mf2 = getArg args TargetInputFile + mdir = getArg args InputDir + me = getArg args MaxErrorRate + gt = getArg args WriteGT + case (mf1,mf2,mdir,p) of + -- Parse source and target file, show full output + (Just f1, Just f2, Nothing, False) -> diff m f1 f2 + -- Diff all files in one dir, show condensed output + (Nothing, Nothing, Just dir, False) -> testDirMatch m me gt dir + _ -> usageError args err2 + +diff :: MatchMode -> String -> String -> IO () +diff m f1 f2 = do (toks1, ts1, _, _) <- readFile' f1 >>= return . string2PieceC + (toks2, ts2, _, _) <- readFile' f2 >>= return . string2PieceC + case m of + STDiff -> putStrLn (diffChords toks1 toks2) + GDiff -> print (diffPiece (head ts1) (head ts2)) + + +filterNonQuery :: [FilePath] -> [FilePath] +filterNonQuery = concat . map snd . filter ((>1) . length . snd) . getClassSizes + +testDirMatch :: MatchMode -> Maybe Float -> Maybe FilePath -> FilePath -> IO () +testDirMatch m me od fp = + do fs <- readDataDir fp + let process f = do s <- readFile' (fp f) + let (toks, ps, _, errs) = string2PieceC s + return (f, toks, head ps, errorRatio errs toks) + (fs', toks, ps, errs) <- fmap unzip4 (mapM process fs) + when (isJust od) $ writeGroundTruth fs' (fromJust od) + let fsq = filterNonQuery fs' + putStr "true\ntrue\n" + mapM_ (putStr . (++ "\t")) fsq + putChar '\n' + mapM_ (putStr . (++ "\t"). getId) fs' + putStrLn "" + let runDiff df l = [ [ df me ex ey x y | (y,ey) <- l ] + | ((x,ex),i) <- zip l (map getId fs'), i `elem` fsq ] + printLine l = putStrLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) + >> hFlush stdout + undf = error "stdiff should not inspect parsing results" + let r = case m of + STDiff -> runDiff diffChordsLen (zip toks (repeat undf)) + GDiff -> runDiff diffPieceLen (zip ps errs) + `using` parList rdeepseq + sequence_ [ printLine x | x <- r] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import Distribution.Simple +import System.FilePath (()) +import System.Cmd (system) +import System.IO (hFlush, stdout) +import System.Exit +import System.Directory + +main :: IO () +main = defaultMainWithHooks (simpleUserHooks { postConf = mypostConf }) + +mypostConf a f d b = let path = "MIR" "GeneratedInstances" + file = "GenerateInstances.hs" + ghc = "ghc " + flags = "-e main " + in do putStr "Generating instances..." + hFlush stdout + setCurrentDirectory path + ec <- system (ghc ++ flags ++ file) + case ec of + ExitSuccess -> putStrLn " done." + ExitFailure _ -> putStrLn " failed!" >> exitWith ec + postConf simpleUserHooks a f d b +