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