classify (empty) → 2007.6.26
raw patch · 6 files changed
+462/−0 lines, 6 filesdep +basedep +mtlbuild-type:Customsetup-changed
Dependencies added: base, mtl
Files
- Setup.hs +2/−0
- classify.cabal +16/−0
- src/Data/Classify/DataTypes.hs +37/−0
- src/Data/Classify/Parser.hs +264/−0
- src/Data/Classify/Printer.hs +59/−0
- src/Data/Classify/Rank.hs +84/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ classify.cabal view
@@ -0,0 +1,16 @@+Name: classify+Version: 2007.6.26+Copyright: 2004-2007, Lemmih+Build-Depends: base, mtl+License: BSD3+Author: Lemmih <lemmih@gmail.com>+Maintainer: Lemmih <lemmih@gmail.com>+Homepage: http://www.scannedinavian.org/~lemmih/+Synopsis: Library for classification of files.+Category: Tool+HS-Source-Dirs: src+Exposed-Modules:+ Data.Classify.DataTypes,+ Data.Classify.Rank,+ Data.Classify.Parser,+ Data.Classify.Printer
+ src/Data/Classify/DataTypes.hs view
@@ -0,0 +1,37 @@+module Data.Classify.DataTypes where++data Element+ = Series+ {+ name :: Name,+ version :: Version,+ title :: Title,+ lastname :: LastName,+ score :: Int+ }+ deriving (Eq,Read,Show)++type Name = String+type LastName = Name+type Title = String+data Version = Version+ {+ season :: Int,+ episode :: Int+ } | DateVersion+ { year :: Int+ , month :: Int+ , day :: Int+ } deriving (Ord,Eq,Read,Show)+++data MarkupStyle+ = Literate Char+ | Symbol Char+ | Numeric Char Int+ deriving (Eq)++data MarkupLayout+ = Replace Char String+ | Function Char (Int -> String)+
+ src/Data/Classify/Parser.hs view
@@ -0,0 +1,264 @@+module Data.Classify.Parser +--(parseElement,generateMarkup,module Parser)+where++import Data.Classify.DataTypes++-- import Text.ParserCombinators.Parsec++import Text.ParserCombinators.ReadP+import Data.Char+import Data.List+import Data.Ord+import Control.Monad+--import Utils+import System.Time+import System.IO.Unsafe++import qualified Data.Map as Map+import qualified Data.Set as Set++run readp inp+ = let rets = map fst $ readP_to_S readp inp+ in nub rets++separator+ = choice+ [ do skipSpaces+ skipMany (char '-')+ skipSpaces+ , do skipSpaces+ skipMany (char '.')+ skipSpaces+ , do skipSpaces ]+++makeVersion s e = Version (read s) (read e)++digit :: ReadP Char+digit = satisfy isDigit++oneOf :: String -> ReadP Char+oneOf str = choice (map char str)++anyChar :: ReadP Char+anyChar = satisfy (const True)++putback :: ReadP a -> ReadP a+putback readp+ = do inp <- look+ choice+ $ flip map (readP_to_S readp inp) $ \(a,str)+ -> return a++currentYear = ctYear (unsafePerformIO (toCalendarTime =<< getClockTime))++parseYear = choice+ [ do string (show currentYear)+ return (currentYear, 2)+ , do string (drop 2 (show currentYear))+ return (currentYear, 0)+ ]++parseDateVersion+ = choice+ [ do (year, n) <- parseYear+ separator+ month <- count 2 digit+ separator+ day <- count 2 digit+ return (DateVersion year (read month) (read day), n)+ , do month <- count 2 digit+ separator+ day <- count 2 digit+ separator+ (year, n) <- parseYear+ return (DateVersion year (read month) (read day), n)+ ]++parseVersion+ = choice+ [ parseDateVersion+ , do s <- many1 digit+ oneOf "XxEe."+ e <- many1 digit+ return (makeVersion s e, 0)+ , do s <- count 1 digit +++ count 2 digit+ e <- count 2 digit+ return (makeVersion s e, 0)+ , do oneOf "sS"+ s <- many1 digit+ oneOf "Ee"+ e <- many1 digit+ return (makeVersion s e, 2)+ , between (char '(') (char ')') parseVersion+ , between (char '{') (char '}') parseVersion+ , between (char '[') (char ']') parseVersion+ ]++trunc xs = [ toLower x | x <- xs, isAlphaNum x ]++parseSeries known+ = do many anyChar+ nPre <- many1 anyChar+ n <- Map.lookup (trunc nPre) known+-- guard (trunc n `Map.member` known)+ s <- look+ guard (take 2 s /= "th") -- Fix for '24th 2007.avi'. It shouldn't parse 24th as a series.+ many anyChar+ separator+ (v,s) <- parseVersion+ separator+ (t,l) <- choice+ [do { t <- manyTill anyChar (do char '.'+ rest <- look+ if '.' `elem` rest+ then pfail+ else return ())+ ; l <- look+ ; return (t,l) }+ ,do { t <- look+ ; return ("",t) }]+-- guard (null $ takeWhile isDigit $ pp t)+-- guard (null $ takeWhile isDigit $ pp l)+ guard (trunc l `Set.member` knownExtensions)+ return $ Series n v (pp t) (pp l) s+ where pp = trim . removeGarbage++knownExtensions = Set.fromList $ map trunc ["avi","mpg", "mpeg", "mp4", "mov","wmv","mkw"]++removeGarbage [] = []+removeGarbage ('.':xs) = ' ':removeGarbage xs+removeGarbage ('_':xs) = ' ':removeGarbage xs+removeGarbage ('-':xs) = ' ':removeGarbage xs+removeGarbage (x:xs) | isAlphaNum x || isSpace x = x:removeGarbage xs+ | otherwise = ' ':removeGarbage xs++trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++parseElement known+ = do choice [parseSeries known]++++{-+The simpsons - 0x00 - Null+Simpsons - S00E00 - Null+Simpsons S0x0 Null+S0E0 Null+-}+{-+putback p+ = do tok <- getInput+ r <- p+ setInput tok+ return r++separator1+ = do spaces+ oneOf "-"+ spaces++separator2+ = do many space+ return ()+separator3+ = do many1 $ oneOf "-./,[]{}_ "+ return ()++separator+ = choice $ map try+ [separator3,+ separator2,+ separator1]+-- return ()]++makeVersion s e = Version (read s) (read e)+parseVersion1+ = do s <- many1 digit+ oneOf "XxEe."+ e <- many1 digit+ return $ makeVersion s e+parseVersion2+ = do oneOf "sS"+ s <- many1 digit+ oneOf "Ee"+ e <- many1 digit+ return $ makeVersion s e+parseVersion3+ = do (s,e) <- choice $ map try+ [count 2 digit >>= \s -> count 2 digit >>= \e -> return (s,e),+ count 1 digit >>= \s -> count 2 digit >>= \e -> return (s,e)]+ return $ makeVersion s e++parseVersion4+ = between (char '(') (char ')') parseVersion+parseVersion+ = choice $ map try+ [parseVersion1,+ parseVersion2,+ parseVersion3,+ parseVersion4]++parseName :: Parser Name+parseName = manyTill anyChar (putback $ try $ (separator >> parseVersion>>return ()))++{-parseSeries1 :: Parser Element+parseSeries1+ = do v <- parseVersion+ separator+ n <- parseName+ separator+ t <- many (noneOf ".")+ l <- many anyChar+ return $ Series n v t l-}++parseSeries2 :: Parser Element+parseSeries2+ = do n <- parseName+ separator+ v <- parseVersion+ separator+ (t,l) <- choice $ map try+ [do { t <- manyTill anyChar (char '.')+ ; l <- getInput+ ; return (t,l) }+ ,do { t <- getInput+ ; return ("",t) }]+ return $ Series n v t l++parseElement :: Parser Element+parseElement+ = do choice $ map try [parseSeries2]++-}++-----------------------------+-- Markup Parser+-----------------------------++parseMarkupElement+ = choice+ [parseNumeric,+ parseSymbol,+ parseLiterate]+ where parseLiterate+ = do lit <- anyChar+ return $ Literate lit+ parseSymbol+ = do char '%'+ sym <- anyChar+ return $ Symbol sym+ parseNumeric+ = do char '%'+ n <- many1 digit+ sym <- anyChar+ return $ Numeric sym (read n)++parseMarkup = many1 parseMarkupElement++generateMarkup s+ = case readP_to_S parseMarkup s of+ rets -> fst (head (sortBy (comparing (length.snd)) rets))++
+ src/Data/Classify/Printer.hs view
@@ -0,0 +1,59 @@+module Data.Classify.Printer+ ( ppElement+ , applyMarkup+ ) where++import Data.Classify.DataTypes+import Data.Classify.Parser+import Data.Maybe+import Data.List+import Data.Char++buffering :: String -> Int -> String+buffering s len = replicate l '0'++s+ where l = max 0 (len-length s)++ppElement :: String -- ^ Format+ -> Element -- ^ File structure+ -> String -- ^ Result+ppElement format element+ = applyMarkup markup layout+ where layout = elementLayout element+ markup = generateMarkup format++-----------------------------+-- Styles+-----------------------------++elementLayout :: Element -> [MarkupLayout]+elementLayout (s@Series {})+ = [Replace 'S' (name s),+ Replace 'E' (title s),+ Replace 'l' (map toLower $ lastname s),+ Function 's' (buffering (show $ season (version s))),+ Function 'e' (buffering (show $ episode (version s)))]++-----------------------------+-- Markup+-----------------------------+++applyMarkup :: [MarkupStyle] -> [MarkupLayout] -> String+applyMarkup [] _ = ""+applyMarkup (Literate c:xs) l = c:applyMarkup xs l+applyMarkup (Symbol c:xs) l = s ++ applyMarkup xs l+ where s = fromMaybe "" findReplacement+ findReplacement = case find findReplace l of+ Nothing -> Nothing+ Just (Replace _ s) -> Just s+ Just (Function _ f) -> Just (f 0)+ where findReplace (Replace a _) = a==c+ findReplace (Function a _) = a==c+applyMarkup (Numeric c n:xs) l =numeric ++ applyMarkup xs l+ where numeric = fromMaybe "" findNumeric+ findNumeric = case find findFunction l of+ Nothing -> Nothing+ Just (Function _ f) -> Just (f n)+ where findFunction (Function a _) = a==c+ findFunction _ = False+
+ src/Data/Classify/Rank.hs view
@@ -0,0 +1,84 @@+module Data.Classify.Rank+ ( selectBest+ , sortByRank+ , sortByRank'+ ) where+++import Data.Classify.DataTypes+import Data.List+import Data.Char+import Data.Ord++-- For testing+import qualified Data.Map as Map+import qualified Data.Classify.Parser as P+import Control.Monad+-- import Utils++selectBest :: [Element] -> Element+selectBest = last . sortByRank++sortByRank :: [Element] -> [Element]+sortByRank = map fst . sortByRank'++sortByRank' elts+ = concatMap (sortBy (comparing (length.name.fst)))+ $ groupBy (\a b -> snd a == snd b)+ $ sortBy (comparing snd) $ zip elts (map getRank elts)++getRank elt+ = sum [ score elt,+ cleanExtension ==> 2,+ cleanTitle ==> 1,+ unrealVersion (version elt)+ ]+ where + cleanExtension = all isAlpha (lastname elt)+ cleanTitle = all isAlpha (title elt)++unrealVersion (Version season episode) = sum [ episode > 0 ==> 1+ , episode > 50 ==> negate 2+ , season > 0 ==> 1+ , season > 30 ==> negate 1+ ]+unrealVersion (DateVersion year month day) = 0++infix 2 ==>+True ==> n = n+False ==> _ = 0+--------------------------------------------------------------+-- Tests+--------------------------------------------------------------++testSeries = Map.fromList [ (P.trunc t,t) | (_,t,_) <- testData]++testData = [ ("24.S06E01.6AM.TO.7AM.PROPER.DVDRip.XviD-MEMETiC.avi", "24", Version 6 1)+ , ("The.Simpsons.S18E09.PROPER.PDTV.XviD-2HD.avi", "The Simpsons", Version 18 9)+ , ("30.Rock.S01E09.HDTV.XviD-NoTV.avi", "30 Rock", Version 1 9)+ , ("Cops.S19E32.HDTV.XviD-2HD.avi", "Cops", Version 19 32)+ , ("The.4400.S04E02.DSR.XviD-ORENJi.avi", "The 4400", Version 4 2)+ , ("Jay.Leno.2007.06.25.John.Edwards.HDTV.XViD-STFU.avi", "Jay Leno", DateVersion 2007 6 25)+ , ("the.daily.show.06.21.07.dsr.xvid-crimson.[VTV].avi", "The Daily Show", DateVersion 2007 6 21)+ , ("the.colbert.report.06.21.07.dsr.xvid-w4f.[VTV].avi", "The Colbert Report", DateVersion 2007 6 21)+ , ("hidden.palms.0107-yestv.[VTV].avi", "Hidden Palms", Version 1 7)+ , ("hidden.palms.0108-yestv.[VTV].avi", "Hidden Palms", Version 1 8)+ , ("hidden.palms.0109-yestv.[VTV].avi", "Hidden Palms", Version 1 9)+ , ("hidden.palms.0110-yestv.[VTV].avi", "Hidden Palms", Version 1 10)+ , ("hidden.palms.0111-yestv.[VTV].avi", "Hidden Palms", Version 1 11)+ ]++runTests = flip mapM_ testData $ \(str, series, expectedVersion) ->+ let elts = P.run (P.parseElement testSeries) str+ in if null elts+ then do putStrLn $ "Failed to parse: " ++ str+ putStrLn $ "Expected: " ++ show (series, expectedVersion)+ else let best = selectBest elts+ v = version best+ in when (version best /= expectedVersion) $+ do forM (sortByRank elts) $ \elt ->+ putStrLn $ "Erroneous parse: " ++ show (str, title elt, version elt)+ putStrLn $ "Expected: " ++ show (series, expectedVersion)+++