cndict 0.6.4 → 0.7.0
raw patch · 6 files changed
+264/−274 lines, 6 files
Files
- cndict.cabal +4/−4
- data/SUBTLEX_CH_131210_CE.utf8 too large to diff
- data/dict.txt.big too large to diff
- src/Data/Chinese/CCDict.hs +19/−164
- src/Data/Chinese/Frequency.hs +18/−106
- src/Data/Chinese/Segmentation.hs +223/−0
cndict.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: cndict-version: 0.6.4+version: 0.7.0 synopsis: Chinese/Mandarin <-> English dictionary, Chinese lexer. -- description: license: PublicDomain@@ -16,15 +16,16 @@ cabal-version: >=1.8 data-files:- data/SUBTLEX_CH_131210_CE.utf8 data/cedict_1_0_ts_utf-8_mdbg.txt+ data/dict.txt.big source-repository head type: git location: git://github.com/Lemmih/cndict.git library- exposed-modules: Data.Chinese.CCDict, Data.Chinese.Pinyin, Data.Chinese.Frequency+ exposed-modules: Data.Chinese.CCDict, Data.Chinese.Pinyin,+ Data.Chinese.Frequency, Data.Chinese.Segmentation other-modules: Paths_cndict build-depends: base == 4.*, text >= 0.11.0.0,@@ -36,4 +37,3 @@ hs-source-dirs: src ghc-options: -Wall ghc-prof-options: -auto-all-
− data/SUBTLEX_CH_131210_CE.utf8
file too large to diff
+ data/dict.txt.big view
file too large to diff
src/Data/Chinese/CCDict.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} -- | Simplified Chinese <-> English dictionary with pinyin phonetics. module Data.Chinese.CCDict ( CCDict@@ -9,11 +8,8 @@ , load , parse , lookup+ , lookupMatches , ccDict- , Token(..)- , tokenizer- , toTraditional- , toSimplified ) where import qualified Data.ByteString as B@@ -171,8 +167,6 @@ -------------------------------------------------- -- Tokenizer -data Token = KnownWord Entry | UnknownWord Text- deriving ( Read, Show, Eq, Ord ) -- Interesting case: 他的话 tokenizes to [他,的话] by both google translate and -- MDGB. The correct tokenization is [他,的,话]. Not sure if it can be fixed without@@ -180,151 +174,8 @@ -- TODO: Mark text inclosed in curly brackets as unknown words. -- FIXME: 不想 should tokenize to [不,想] -- FIXME: 那是 should tokenize to [那,是]--- | Break a string of simplified chinese down to a list of tokens.-tokenizer :: CCDict -> Text -> [Token]-tokenizer = tokenizer'---tokenizer trie inp = maximumBy (comparing score) (tokenizerNondet trie inp)--- tokenizer trie inp = filter isValid $ go 0 inp inp--- where--- isValid (UnknownWord txt) = not (T.null txt)--- isValid _ = True--- go n unrecognied txt--- | T.null txt = [ unknown ]--- | otherwise =--- case lookup txt trie of--- Nothing -> go (n+1) unrecognied (T.drop 1 txt)--- Just es ->--- let rest = T.drop (T.length (entryChinese es)) txt in--- unknown : KnownWord es : go 0 rest rest--- where--- unknown = UnknownWord $ T.take n unrecognied -_ppTokenizerTests :: IO ()-_ppTokenizerTests =- case _tokenizer_tests of- [] -> putStrLn "No test failures."- lst -> do- flip mapM_ lst $ \(orig, expected, actual) -> do- T.putStr orig- putStr ": expected: "- T.putStr (T.unwords expected)- putStr ", got: "- T.putStrLn (T.unwords actual) -_tokenizer_tests :: [(Text, [Text], [Text])]-_tokenizer_tests =- [ (input, result, tokens)- | (input, result) <- cases- , let tokens = flat (tokenizer' ccDict input)- , tokens /= result ]- where- cases =- [ ("多工作", ["多","工作"])- , ("有电话", ["有","电话"])- , ("回电话", ["回","电话"])- , ("不知道", ["不","知道"])- , ("定时间", ["定","时间"])- , ("这位子", ["这","位子"])- , ("十分钟", ["十","分钟"])- , ("有电梯", ["有","电梯"])- , ("中午前", ["中午","前"])- -- , ("得很", ["得","很"])- -- , ("不想", ["不","想"])- -- , ("那是", ["那","是"])- , ("外套", ["外套"])- , ("家中餐馆", ["家","中餐馆"])- , ("后生活", ["后","生活"])- , ("不愿意", ["不","愿意"])- , ("点出发", ["点","出发"])- , ("老婆婆", ["老","婆婆"])- , ("不会跳舞", ["不会","跳舞"])- , ("穿上外套", ["穿上","外套"])- , ("建议", ["建议"])- , ("怎么不知道", ["怎么","不","知道"])- , ("蛋糕发起来", ["蛋糕","发","起来"])- , ("管理的人才", ["管理","的","人才"])- , ("轻快乐曲", ["轻快","乐曲"])- , ("高明和", ["高明","和"])- , ("一下子之间", ["一下子","之间"])- , ("我绝没想到", ["我","绝","没想到"])- , ("没想到会", ["没想到","会"]) ]--flat :: [Token] -> [Text]-flat = map worker- where- worker (KnownWord entry) = entrySimplified entry- worker (UnknownWord txt) = txt--type NonDet = Tree [Token]--_ppNonDet :: [NonDet] -> String-_ppNonDet = drawForest . map (fmap (unwords . map ppToken))- where- ppToken (KnownWord entry) = T.unpack (entrySimplified entry)- ppToken (UnknownWord txt) = T.unpack txt--_compactNonDet :: NonDet -> NonDet-_compactNonDet (Node a [Node b rest]) =- _compactNonDet (Node (a++b) rest)-_compactNonDet (Node a rest) =- Node a (map _compactNonDet rest)--collapseNonDet :: [NonDet] -> [Token]-collapseNonDet [] = []-collapseNonDet [Node entries rest] = entries ++ collapseNonDet rest-collapseNonDet (node:nodes) =- case maxBy nodeScore node nodes of- Node entries rest -> entries ++ collapseNonDet rest- where- maxBy fn x xs = maxBy' (fn x) x xs- where- maxBy' _hiScore hiItem [] = hiItem- maxBy' hiScore hiItem (y:ys) =- let score = fn y in- if score > hiScore then maxBy' score y ys else maxBy' hiScore hiItem ys- geoMean :: [Int] -> Integer- geoMean [] = 0- geoMean n = product $ map fromIntegral n- -- assocs = [ (node, geoMean (filter (/=0) (nodeSum node)))- -- | node <- forest ]- wordCount word = maybe 1 subtlexWCount (Frequency.lookup word subtlex)- entryCount (KnownWord entry) = wordCount (entrySimplified entry)- entryCount UnknownWord{} = 1- nodeSum (Node entries _) = map entryCount entries- nodeScore = geoMean . nodeSum---- Enhanced tokenizer, mixed non-determistic and greedy algorithm-tokenizer' :: CCDict -> Text -> [Token]-tokenizer' trie inp = compress $ collapseNonDet (tokenizerNondet trie inp)- where- compress [] = []- compress (UnknownWord a:UnknownWord b:xs) = compress (UnknownWord (a `T.append` b):xs)- compress (x:xs) = x:compress xs--tokenizerNondet :: CCDict -> Text -> [NonDet]-tokenizerNondet trie inp = map _compactNonDet $ go inp- where- go txt | T.null txt = []- go txt =- case lookupNonDet txt trie of- Nothing -> do- return $ Node [UnknownWord (T.take 1 txt)] $ go (T.drop 1 txt)- Just es -> do- entries <- es- let len = sum (map (T.length . entrySimplified) entries)- return $ Node (map KnownWord entries) $ go (T.drop len txt)----score :: [Token] -> Double---score = sum . map fn--- where--- fn UnknownWord{} = 0--- fn (KnownWord entry) | T.length (entryChinese entry) == 1 = 0--- fn (KnownWord entry) =--- case M.lookup (entryChinese entry) subtlex of--- Nothing -> 0--- Just freq -> subtlexWMillion freq-- -------------------------------------------------- -- Dictionary trie @@ -421,27 +272,31 @@ splitDefinition = filter (not . T.null) . T.splitOn "/" . T.dropAround isSpace ------------------------------------------------------ Simplified <-> Traditional -flatMap :: (Entry -> Text) -> [Token] -> Text-flatMap fn = T.concat . map worker- where- worker (KnownWord e) = fn e- worker (UnknownWord txt) = txt -toTraditional :: Text -> Text-toTraditional = flatMap entryTraditional . tokenizer ccDict--toSimplified :: Text -> Text-toSimplified = flatMap entrySimplified . tokenizer ccDict- -------------------------------------------------- -- Embedded dictionary +remove :: Text -> CCDict -> CCDict+remove = worker . map ord . T.unpack+ where+ worker [] dict = dict+ worker (x:xs) dict =+ IntMap.update (fn xs) x dict+ fn xs (CCTrieNoEntry rest) = Just $ CCTrieNoEntry (worker xs rest)+ fn [] CCTrieEntryEnd{} = Nothing+ fn _ (CCTrieEntryEnd entry) = Just $ CCTrieEntryEnd entry+ fn [] (CCTrieEntry _ rest) = Just $ CCTrieNoEntry rest+ fn xs (CCTrieEntry e rest) = Just $ CCTrieEntry e (worker xs rest)+ -- | Embedded dictionary. ccDict :: CCDict-ccDict = parse $ T.decodeUtf8 raw+ccDict =+ remove "得很" $+ remove "那是" $ remove "到了" $+ remove "里人" $ remove "多事" $+ remove "你我" $ remove "家的" $+ parse $ T.decodeUtf8 raw where -- raw = $(embedFile "data/cedict_1_0_ts_utf-8_mdbg.txt") raw = unsafePerformIO $ do
src/Data/Chinese/Frequency.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BangPatterns #-} module Data.Chinese.Frequency- ( SubtlexMap- , SubtlexEntry(..)- , subtlex- , Data.Chinese.Frequency.lookup+ ( FreqMap+ , freqMap ) where import qualified Data.ByteString as B@@ -13,112 +11,26 @@ import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Read as T import Data.Text.Encoding import Paths_cndict import System.IO.Unsafe (unsafePerformIO) -type SubtlexMap = Map B.ByteString RawEntry--data RawEntry = RawEntry- { rawEntryIndex :: {-# UNPACK #-} !Int- , rawEntryWCount :: {-# UNPACK #-} !Int- , rawEntryWMillion :: {-# UNPACK #-} !Double- }--data SubtlexEntry = SubtlexEntry- { subtlexIndex :: !Int- , subtlexWord :: !T.Text- , subtlexWCount :: !Int- , subtlexWMillion :: !Double- } deriving ( Show )--toEntry :: Int -> B.ByteString -> RawEntry-toEntry idx row = RawEntry- { rawEntryIndex = idx- , rawEntryWCount = asInt (chunks!!4)- , rawEntryWMillion = read (B8.unpack $ chunks!!5) }- where- chunks = B.split 9 row- asInt str =- case B8.readInt str of- Nothing -> -1- Just (n,_rest) -> n--lookup :: Text -> SubtlexMap -> Maybe SubtlexEntry-lookup key m = do- RawEntry n wcount wmillion <- M.lookup (encodeUtf8 key) m- return SubtlexEntry- { subtlexIndex = n- , subtlexWord = key- , subtlexWCount = wcount- , subtlexWMillion = wmillion }--- instance FromRecord SubtlexEntry where--- parseRecord rec = SubtlexEntry--- <$> pure 0--- <*> fmap T.copy (index rec 0)--- -- <*> fmap (map toToneMarks . T.splitOn "/") (index rec 2)--- <*> index rec 4--- <*> index rec 5--- -- <*> index rec 14---- _loadSubtlexEntries :: FilePath -> IO (Vector SubtlexEntry)--- _loadSubtlexEntries path = do--- inp <- L.readFile path--- case Csv.decodeWith (Csv.DecodeOptions 9) HasHeader inp of--- Left msg -> error msg--- Right rows -> return rows---- mkSubtlexMap :: Vector SubtlexEntry -> SubtlexMap--- mkSubtlexMap rows = M.fromListWith join--- [ (subtlexWord row, row{subtlexIndex = n})--- | (n,row) <- zip [0..] (V.toList rows)--- -- , subtlexEnglish row /= "#"--- ]--- where--- join e1 e2 = SubtlexEntry--- { subtlexIndex = min (subtlexIndex e1) (subtlexIndex e2)--- , subtlexWord = subtlexWord e1--- -- , subtlexPinyin = subtlexPinyin e1--- , subtlexWCount = subtlexWCount e1 + subtlexWCount e2--- , subtlexWMillion = subtlexWMillion e1 + subtlexWMillion e2--- -- , subtlexEnglish = subtlexEnglish e1--- }--mkSubtlexMap :: [B.ByteString] -> SubtlexMap-mkSubtlexMap rows = M.fromListWith join- [ (word, toEntry n row)- | (n,row) <- zip [0..] rows- , let chunks = B.split 9 row- word = head chunks- , not (null chunks)- -- , subtlexEnglish row /= "#"- ]- where- join (RawEntry n1 c1 m1) (RawEntry n2 c2 m2) =- RawEntry (min n1 n2) (c1+c2) (m1+m2)-------------------------------------------------------------------- Embedded files+type FreqMap = Map Text Int -subtlex :: SubtlexMap-subtlex = mkSubtlexMap $- rows+freqMap :: FreqMap+freqMap = mkFreqMap rows where utfData = unsafePerformIO $ do- path <- getDataFileName "data/SUBTLEX_CH_131210_CE.utf8"- B.readFile path- -- utfData = $(embedFile "data/SUBTLEX_CH_131210_CE.utf8")- -- utfData = B.empty- rows = drop 1 (B.split 0xa utfData)---- subtlex :: SubtlexMap--- subtlex = mkSubtlexMap $--- case Csv.decodeWith (Csv.DecodeOptions 9) HasHeader inp of--- Left msg -> error msg--- Right rows -> rows--- where--- inp = L.fromStrict $(embedFile "data/SUBTLEX_CH_131210_CE.utf8")+ path <- getDataFileName "data/dict.txt.big"+ T.readFile path+ rows = T.lines utfData +mkFreqMap :: [Text] -> FreqMap+mkFreqMap rows = M.fromListWith max+ [ (word, count)+ | (n,row) <- zip [0..] rows+ , let [word,countStr,_type] = T.words row+ Right (count,_) = T.decimal countStr+ ]
+ src/Data/Chinese/Segmentation.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Chinese.Segmentation+ ( Token(..)+ , Entry(..)+ , tokenizer+ , tokenizer_+ , ppTokens+ , toTraditional+ , toSimplified+ ) where++import Data.Chinese.CCDict (Entry(..))+import qualified Data.Chinese.CCDict as CC+import qualified Data.Chinese.Frequency as F+import qualified Data.Text as T+import qualified Data.Map.Strict as M+import Data.Text (Text)+import qualified Data.IntMap as IntMap+import Data.List+import Data.Maybe+import Control.Monad+import Data.Ord++data Token = KnownWord Entry | UnknownWord Text+ deriving ( Read, Show, Eq, Ord )++--+-- ABC+-- [[A,AB],[B],[C]]+-- [ [[A,B],[AB]]+-- , [[C]] ]+splitText :: CC.CCDict -> Text -> [[Token]]+splitText dict txt =+ [ case CC.lookupMatches offset dict of+ Nothing -> [UnknownWord char]+ Just entries -> map KnownWord entries+ | n <- [0..T.length txt-1]+ , let offset = T.drop n txt+ char = T.take 1 offset ]++-- [[A,AB],[B]] -> [ [[A,B],[AB]] ]+-- [[A,AB],[BC],[C]] -> [[[A,BC],[AB,C]]]+-- [[A,AB],[B,BC],[C]] -> [[[A,B,C],[A,BC],[AB,C]]]+-- [[A,ABC],[B],[C]]+findGroups :: [[Token]] -> [[[Token]]]+findGroups [] = []+findGroups tokens =+ nub (map trim (sequence lst)) : findGroups rest+ where+ lst = take len tokens+ rest = drop len tokens+ len = groupLength tokens+ trim [] = []+ trim (t:ts) = t : trim (drop (tokenLength t-1) ts)++groupLength :: [[Token]] -> Int+groupLength = worker 1+ where+ worker l [] = 0+ worker 0 _ = 0+ worker l (ts:tss) =+ let maxLength = maximum (map tokenLength ts) in+ 1 + worker (max l maxLength - 1) tss++greedyGroups :: [[[Token]]] -> [[[Token]]]+greedyGroups = map worker+ where+ worker tss =+ filter (onlyWithLength (minimum $ map length tss)+ (maximum $ map (maximum.map tokenLength) tss)) tss+ onlyWithLength len tlen ts =+ length ts == len && maximum (map tokenLength ts) == tlen++tokenLength UnknownWord{} = 0+tokenLength (KnownWord e) = T.length (entrySimplified e)++flattenGroups :: [[[Token]]] -> [Token]+flattenGroups = concatMap pickBest++pickBest :: [[Token]] -> [Token]+pickBest lst =+ snd (maximumBy (comparing fst) graded)+ where+ graded = [ (score x,x) | x <- lst ]+ score x = geoMean (mapMaybe tokenScore x)++ppGroups :: [[[Token]]] -> String+ppGroups = unwords . map worker+ where+ worker :: [[Token]] -> String+ worker [] = []+ worker tss = "{" ++ unwords (intersperse "|" $ map ppGroup tss) ++ "}"+ ppGroup :: [Token] -> String+ ppGroup ts = unwords (map ppToken ts)+ ppToken (UnknownWord txt) = T.unpack txt+ ppToken (KnownWord e) = T.unpack (entrySimplified e)++ppTokens :: [Token] -> String+ppTokens = unwords . map toString+ where+ toString (UnknownWord txt) = T.unpack txt+ toString (KnownWord e) = T.unpack (entrySimplified e)++geoMean :: [Int] -> Int+geoMean ls = round $+ fromIntegral (product ls) ** recip (fromIntegral (length ls))++tokenScore :: Token -> Maybe Int+tokenScore UnknownWord{} = Nothing+tokenScore (KnownWord e)+ -- | T.length (entrySimplified e) == 1 = Nothing+ | otherwise = Just $ wordCount (entrySimplified e)++wordCount :: Text -> Int+wordCount txt =+ case M.lookup txt F.freqMap of+ Just n -> n+ Nothing -> 0 {-minimum+ [ M.findWithDefault 1 char F.freqMap+ | char <- T.chunksOf 1 txt ]-}++-- | Break a string of simplified chinese down to a list of tokens.+tokenizer :: Text -> [Token]+tokenizer = tokenizer_ CC.ccDict++tokenizer_ :: CC.CCDict -> Text -> [Token]+tokenizer_ dict = flattenGroups . greedyGroups . findGroups . splitText dict++_ppSegmentationTests =+ forM_ wrong $ \(txt, expected, got) -> do+ putStrLn $ "Fail: " ++ T.unpack txt +++ ", expected: " ++ expected +++ ", got: " ++ got+ where+ wrong =+ [ (txt, expected, got)+ | (txt, expected) <- cases+ , let got = ppTokens $ tokenizer txt+ , got /= expected]+ cases =+ [ ("多工作", "多 工作")+ , ("有电话", "有 电话")+ , ("回电话", "回 电话")+ , ("不知道", "不 知道")+ , ("定时间", "定 时间")+ , ("这位子", "这 位子")+ , ("十分钟", "十 分钟")+ , ("有电梯", "有 电梯")+ , ("中午前", "中午 前")+ , ("好心地", "好心 地")+ , ("想要点", "想要 点")+ , ("得很", "得 很")+ -- , ("不想", ["不","想"])+ -- , ("那是", ["那","是"])+ , ("外套", "外套")+ , ("家中餐馆", "家 中餐馆")+ , ("后生活", "后 生活")+ , ("不愿意", "不 愿意")+ , ("点出发", "点 出发")+ , ("老婆婆", "老 婆婆")+ , ("不会跳舞", "不会 跳舞")+ , ("穿上外套", "穿上 外套")+ , ("建议", "建议")+ , ("怎么不知道", "怎么 不 知道")+ , ("蛋糕发起来", "蛋糕 发 起来")+ , ("管理的人才", "管理 的 人才")+ , ("轻快乐曲", "轻快 乐曲")+ , ("高明和", "高明 和")+ , ("一下子之间", "一下子 之间")+ , ("我绝没想到", "我 绝 没想到")+ , ("没想到会", "没想到 会")++ , ("公园里人挤人","公园 里 人 挤 人")+ , ("我可没有时间闲呆着","我 可 没有 时间 闲 呆 着")+ , ("你定时间吧","你 定 时间 吧")+ -- , ("这位子有人吗","这 位子 有人 吗")+ , ("我要看病","我 要 看病")+ , ("你好像不太舒服","你 好像 不 太 舒服")+ , ("我非常想见到她","我 非常 想 见到 她")+ , ("能认识你我非常幸福","能 认识 你 我 非常 幸福")+ , ("没有你我无法活下去","没有 你 我 无法 活下去")+ , ("为你我在所不惜","为 你 我 在 所 不惜")+ , ("婚后生活怎么样","婚 后 生活 怎么样")+ , ("我是个顾家的人","我 是 个 顾 家 的 人")+ , ("我有好多事要干","我 有 好多 事 要 干")+ , ("我不知道这张表怎么填","我 不 知道 这 张 表 怎么 填")+ , ("我有很多事要做","我 有 很 多 事 要 做")+ , ("我不知道他在想什么","我 不 知道 他 在 想 什么")+ , ("我是个不顾家的人","我 是 个 不顾 家 的 人")+ , ("你真有胆量","你 真 有胆量")+ , ("夏天到了", "夏天 到 了")+ , ("我先做作业再吃晚饭","我 先 做 作业 再 吃 晚饭")+ , ("现在一点钟了", "现在 一 点钟 了")++ , ("我合上书准备离开", "我 合上 书 准备 离开")+ , ("他的话","他 的 话")+ ]+++++++++++++--------------------------------------------------+-- Simplified <-> Traditional++flatMap :: (Entry -> Text) -> [Token] -> Text+flatMap fn = T.concat . map worker+ where+ worker (KnownWord e) = fn e+ worker (UnknownWord txt) = txt++toTraditional :: Text -> Text+toTraditional = flatMap entryTraditional . tokenizer++toSimplified :: Text -> Text+toSimplified = flatMap entrySimplified . tokenizer