{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} -- Testing module MIR.Run ( readFile', parseTree, testDir, string2PieceC , diffPiece, diffChords, diffChordsLen, diffPieceLen, showFloat , getId, getTitle, getDb, readDataDir, writeGroundTruth , createGroundTruth, getClassSizes, showErrors, errorRatio ) where -- Parser stuff import Text.ParserCombinators.UU import Text.ParserCombinators.UU.BasicInstances hiding (head) import Text.ParserCombinators.UU.BasicInstances.List -- Music stuff import MIR.HarmGram.ParserChord import MIR.HarmGram.ShowChord --import EnumChord import MIR.HarmGram.MIR import MIR.HarmGram.Tokenizer import qualified MIR.Matching.GDiff as GD import qualified MIR.Matching.Standard as STDiff import MIR.GeneratedInstances.GeneratedInstances () --import MIR.Instances () import Text.Regex.TDFA -- Library modules import System.Console.ParseArgs hiding (args) -- cabal install parseargs import Control.Monad (when) import Data.List (intersperse, sort, groupBy, genericLength) import Control.Arrow ((***)) import System.FilePath import System.Directory import System.IO import System.CPUTime -- import qualified Data.HashTable as HT -------------------------------------------------------------------------------- -- From tokens to structured music pieces -------------------------------------------------------------------------------- -- Piece needs to be adhoc so that we do not use 'amb' {- instance ParseG Piece where parseG = Piece <$> parseG <|> Piece_min <$> parseG <|> Piece_bls <$> parseG instance ShowChord Piece where showChord (Piece l) = paren (showString "P" . showChord l) showChord (Piece_min l) = paren (showString "PMin" . showChord l) showChord (Piece_bls l) = paren (showString "PBls" . showChord l) -} -- parsePiece :: PMusic [Piece] {- parsePiece = fmap (:[]) $ Piece <$> parseG <|> Piece_min <$> parseG <|> Piece_bls <$> parseG -} -- parsePiece = amb (parseG :: PMusic Piece) -- parsePiece = fmap ((:[]) . head) $ amb (parseG :: PMusic Piece) pMajOrMin :: ChordName -> PMusic [Piece] pMajOrMin (Chord C (Just Maj) _ _ _) = map Piece <$> amb parseG pMajOrMin (Chord C (Just Min) _ _ _) = map Piece_min <$> amb parseG pMajOrMin _ = error "Parser: key must be C:Maj or C:min" -------------------------------------------------------------------------------- -- Plugging everything together -------------------------------------------------------------------------------- instance Show Piece where show x = showChord x "" -- Takes a string with line-separated chords of a song in C and -- returns all possible parsed pieces, together with error-correction steps -- taken (on tokenizing and on musical recognition). string2PieceC :: String -> ([ChordName],[Piece],[Error (Int, Int)],[Error (Int, Int)]) string2PieceC s = let (PieceToken k a,err) = parse ((,) <$> parseSong <*> pEnd) (createStr s (0,0)) b = mergeDups (map relativizeC a) (c,err2) = parse_h ((,) <$> pMajOrMin k <*> pEnd) (createStr b (0,0)) in (a, c, err, err2) -------------------------------------------------------------------------------- -- Matching -------------------------------------------------------------------------------- diffPiece :: Piece -> Piece -> String diffPiece x y = show (GD.diff x y) diffPieceLen :: Maybe Float -> Float -> Float -> Piece -> Piece -> Float diffPieceLen Nothing _ _ x y = GD.diffLen x y diffPieceLen (Just et) ex ey x y = GD.diffLen x y -- Error penalty + if (GD.diffLen x y > 0) then et * (ex + ey) else 0 diffChordsLen :: Maybe Float -> Float -> Float -> [ChordName] -> [ChordName] -> Float diffChordsLen _ _ _ = STDiff.diffLen diffChords :: [ChordName] -> [ChordName] -> String diffChords x y = show (STDiff.diff x y) -------------------------------------------------------------------------------- -- Data set Info -------------------------------------------------------------------------------- biabPat :: String biabPat = "^(.*)_id_([0-9]{5})_(allanah|wdick|community|midicons|realbook).(M|S|m|s)(G|g)[0-9A-Za-z]{1}.txt$" getInfo :: String -> Maybe [String] getInfo fileName = do let (_,_,_,groups) <- fileName =~~ biabPat :: Maybe (String,String,String,[String]) return groups getTitle, getId, getDb :: String -> String getTitle fn = getInfo' 0 fn getId fn = getInfo' 1 fn getDb fn = getInfo' 2 fn getInfo' :: Int -> String -> String getInfo' i fn = maybe "no_info" (!!i) (getInfo fn) createGroundTruth :: [String] -> [(String, String)] createGroundTruth files = [ (getTitle x, getId x) | x <- files ] getClassSizes :: [String] -> [(String,[String])] getClassSizes = map ((head *** id) . unzip) . groupBy gf . createGroundTruth where gf (name1, _key1) (name2, _key2) = name1 == name2 writeGroundTruth :: [FilePath] -> FilePath -> IO () writeGroundTruth files outfp = writeFile outfp . Prelude.tail $ concatMap merge (createGroundTruth files) where merge :: (String, String) -> String -- merge = uncurry (++) . second ((:) '\t') . first ((:) '\n') merge (x,y) = '\n' : y ++ "\t" ++ x -------------------------------------------------------------------------------- -- Testing -------------------------------------------------------------------------------- -- parses a string of chords s and returns a parse tree with the harmony structure parseTree :: String -> IO () parseTree s = do let (toks, ps, err1, err2) = string2PieceC s -- we hardcode C for now putStrLn "\nTokenizer output:" mapM_ print toks putStrLn "\nCorrection steps (tokenizer):" show_errors err1 putStrLn "\nCorrection steps (music recognizer):" show_errors err2 putStrLn (show (length ps) ++ " possible outputs:") mapM_ print (take 10 ps) -- Batch analyzing a directory with chord sequence files with reduced output. testDir :: FilePath -> IO () testDir filepath = getDirectoryContents filepath >>= process filepath . sort process :: String -> [String] -> IO () process fp fs = do putStr "Filename\tNumber of trees\t" putStr "Insertions\tDeletions\tDeletions at the end\t" putStr "Tot_Correction\tNr_of_chords\t" putStrLn "Error ratio\tTime taken" mapM_ (process1 fp) fs where process1 path x = when (takeExtension x == ".txt") $ do content <- readFile (path x) let (toks, ps, _err1, err2) = string2PieceC content t = seq (length (show (head ps))) (return ()) ErrorNrs i d e = countErrors err2 errRat = errorRatio err2 toks nrOfChords = length (mergeDups toks) t1 <- getCPUTime t t2 <- getCPUTime let diff = fromIntegral (t2 - t1) / (1000000000 :: Float) mapM_ putStr (intersperse "\t" [ x, show (length ps) , show i, show d, show e, show (i+d+e) , show nrOfChords, showFloat errRat , showFloat diff ++ "\n"]) -- | Shows a Float with three decimal places showFloat :: Float -> String showFloat = show . (/ (1000 :: Float)) . fromIntegral . (round :: Float -> Int) . (* 1000) data ErrorNrs = ErrorNrs { ins :: Int, del :: Int, delEnd :: Int } -- datatype for storing the number of different error types instance Show ErrorNrs where show (ErrorNrs i d e) = show i ++ " insertions, " ++ show d ++ " deletions and " ++ show e ++ " unconsumed tokens" -- Counts the number of insertions and deletions countErrors :: [Error (Int,Int)] -> ErrorNrs countErrors [] = ErrorNrs 0 0 0 countErrors ((Inserted _ _ _):t) = inc1 (countErrors t) countErrors ((Deleted _ _ _) :t) = inc2 (countErrors t) countErrors ((DeletedAtEnd _):t) = inc3 (countErrors t) simpleErrorMeasure :: ErrorNrs -> Float simpleErrorMeasure (ErrorNrs i d e) = fromIntegral (i + d + e) errorRatio :: (Eq a) => [Error (Int,Int)] -> [Chord a] -> Float errorRatio errs toks = simpleErrorMeasure (countErrors errs) / genericLength (mergeDups toks) inc1, inc2, inc3 :: ErrorNrs -> ErrorNrs inc1 e = e { ins = ins e + 1 } inc2 e = e { del = del e + 1 } inc3 e = e { delEnd = delEnd e + 1 } -- More concise showing errors, and in IO showErrors :: [Error (Int, Int)] -> IO () showErrors l = case countErrors l of ErrorNrs i d e -> putStrLn ( show i ++ " insertions, " ++ show d ++ " deletions, " ++ show e ++ " deletions at the end") -------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- -- Stricter readFile hGetContents' :: Handle -> IO [Char] hGetContents' hdl = do e <- hIsEOF hdl if e then return [] else do c <- hGetChar hdl cs <- hGetContents' hdl return (c:cs) readFile' :: FilePath -> IO [Char] readFile' fn = do hdl <- openFile fn ReadMode xs <- hGetContents' hdl hClose hdl return xs readDataDir :: FilePath -> IO [FilePath] readDataDir fp = do fs <- getDirectoryContents fp return . sort $ filter (\str -> str =~ biabPat) fs