diff --git a/cndict.cabal b/cndict.cabal --- a/cndict.cabal +++ b/cndict.cabal @@ -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 - diff --git a/data/SUBTLEX_CH_131210_CE.utf8 b/data/SUBTLEX_CH_131210_CE.utf8 deleted file mode 100644 # file too large to diff: data/SUBTLEX_CH_131210_CE.utf8 diff --git a/data/dict.txt.big b/data/dict.txt.big new file mode 100644 # file too large to diff: data/dict.txt.big diff --git a/src/Data/Chinese/CCDict.hs b/src/Data/Chinese/CCDict.hs --- a/src/Data/Chinese/CCDict.hs +++ b/src/Data/Chinese/CCDict.hs @@ -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 diff --git a/src/Data/Chinese/Frequency.hs b/src/Data/Chinese/Frequency.hs --- a/src/Data/Chinese/Frequency.hs +++ b/src/Data/Chinese/Frequency.hs @@ -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 + ] diff --git a/src/Data/Chinese/Segmentation.hs b/src/Data/Chinese/Segmentation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Chinese/Segmentation.hs @@ -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