cndict 0.2.0 → 0.2.1
raw patch · 2 files changed
+107/−36 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Chinese.CCDict: tokenizer' :: CCDict -> Text -> [Token]
Files
- cndict.cabal +1/−1
- src/Data/Chinese/CCDict.hs +106/−35
cndict.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: cndict-version: 0.2.0+version: 0.2.1 synopsis: Chinese/Mandarin <-> English dictionary, Chinese lexer. -- description: license: PublicDomain
src/Data/Chinese/CCDict.hs view
@@ -11,12 +11,13 @@ , ccDict , Token(..) , tokenizer+ , tokenizer' ) where import Control.Monad (mplus,guard) import Data.Char import Data.FileEmbed-import Data.List (foldl', nub, maximumBy)+import Data.List (foldl', nub, maximumBy, sortBy) import Data.Ord (comparing) import Data.Map (Map) import qualified Data.Map as M@@ -28,6 +29,8 @@ import Prelude hiding (lookup) +import Data.Tree+ import Data.Chinese.Pinyin import Data.Chinese.Frequency @@ -67,7 +70,10 @@ lookupMatches key trie = case T.unpack key of [] -> Nothing- (x:xs) -> fmap (go xs) (M.lookup x trie)+ (x:xs) ->+ case fmap (go xs) (M.lookup x trie) of+ Just [] -> Nothing+ other -> other where go [] (CCTrieEntry Nothing _) = [] go [] (CCTrieEntry (Just e) _) = [e]@@ -75,7 +81,28 @@ go (x:xs) (CCTrieEntry (Just e) m) = e : maybe [] (go xs) (M.lookup x m) +-- 点出发+-- [[点,出发],[点出,发]]+-- 出发点+-- [[出发]]+lookupNonDet :: Text -> CCDict -> Maybe [[Entry]]+lookupNonDet key trie = do+ entries <- lookupMatches key trie+ let longest = maximum (map (T.length . entryChinese) entries)+ if longest == 1+ then return [entries]+ else return $ do+ entry <- entries+ let len = T.length (entryChinese entry) + case lookupMatches (T.drop len key) trie of+ Nothing -> return [entry]+ Just rest -> do+ next <- rest+ guard (T.length (entryChinese next) + len > longest)+ return [entry, next]++ -------------------------------------------------- -- Tokenizer @@ -98,6 +125,7 @@ -- FIXME: 那是 should tokenize to [那,是] -- FIXME: 后生活 should tokenize to [后,生活] -- 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 trie inp = maximumBy (comparing score) (tokenizerNondet trie inp)@@ -116,43 +144,86 @@ where unknown = UnknownWord $ T.take n unrecognied -tokenizer_tests :: Bool-tokenizer_tests = and- [ flat (tokenizer ccDict input) == result- | (input, result) <- cases ]+tokenizer_tests :: [(Text, [Text], [Text])]+tokenizer_tests =+ [ (input, result, tokens)+ | (input, result) <- cases+ , let tokens = flat (tokenizer' ccDict input)+ , tokens /= result ] where cases = [ ("多工作", ["多","工作"])- , ("有电话", ["有","电话"]) ]- flat tokens = [ entryChinese entry | KnownWord entry <- tokens ]+ , ("有电话", ["有","电话"]) + -- , ("回电话", ["回","电话"]) -- Hm, we fail on this one.+ , ("不知道", ["不","知道"])+ , ("定时间", ["定","时间"])+ -- , ("这位子", ["这","位子"]) -- Hm, we fail on this one.+ , ("十分钟", ["十","分钟"])+ , ("有电梯", ["有","电梯"])+ -- , ("家中餐馆", ["家","中餐馆"])+ , ("后生活", ["后","生活"])+ , ("不愿意", ["不","愿意"])+ , ("点出发", ["点","出发"])]+flat tokens = [ entryChinese entry | KnownWord entry <- tokens ] ---tokenizerNondet :: CCDict -> Text -> [[Token]]---tokenizerNondet trie inp = {- nub $ -} map compact $ go inp--- where--- compact (UnknownWord t1 : UnknownWord t2 : rest) = compact (UnknownWord (T.append t1 t2) : rest)--- compact (x : xs) = x : compact xs--- compact [] = []--- isValid (UnknownWord txt) = not (T.null txt)--- isValid _ = True--- go txt | T.null txt = return []--- go txt =--- case lookupMatches txt ccDict of--- Nothing -> do--- rest <- go (T.drop 1 txt)--- return (UnknownWord (T.take 1 txt) : rest)--- Just es -> do--- entry <- es--- let len = T.length (entryChinese entry)--- rest <- go (T.drop len txt)--- return (KnownWord entry : rest)--- --case lookupExact word trie of--- -- Nothing -> do--- -- guard (len == 1)--- -- rest <- go (T.drop len txt)--- -- return (UnknownWord word : rest)--- -- Just es -> do--- -- rest <- go (T.drop len txt)--- -- return (KnownWord es : rest)+type NonDet = Tree [Token]++ppNonDet :: [NonDet] -> String+ppNonDet forest = drawForest (map (fmap (unwords . map ppToken)) forest)+ where+ ppToken (KnownWord entry) = T.unpack (entryChinese 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 forest =+ case listToMaybe (sortBy (flip $ comparing snd) assocs) of+ Nothing -> []+ Just (Node entries rest,score) -> entries ++ collapseNonDet rest+ where+ assocs = [ (node, nodeSum node)+ | node <- forest ]+ wordCount word = maybe 0 subtlexWCount (M.lookup word subtlex)+ entryCount (KnownWord entry) = wordCount (entryChinese entry)+ entryCount UnknownWord{} = 0+ entriesSum = sum . map entryCount+ nodeSum (Node entries _) = entriesSum entries++-- Enhanced tokenizer, mixed non-determistic and greedy algorithm+tokenizer' :: CCDict -> Text -> [Token]+tokenizer' trie inp = collapseNonDet (tokenizerNondet trie inp)++tokenizerNondet :: CCDict -> Text -> [NonDet]+tokenizerNondet trie inp = go inp+ where+ isValid (UnknownWord txt) = not (T.null txt)+ isValid _ = True+ go txt | T.null txt = []+ go txt =+ case lookupNonDet txt ccDict of+ Nothing -> do+ --rest <- go (T.drop 1 txt)+ --return (UnknownWord (T.take 1 txt) : rest)+ return $ Node [UnknownWord (T.take 1 txt)] $ go (T.drop 1 txt)+ Just es -> do+ entries <- es+ let len = sum (map (T.length . entryChinese) entries)+ return $ Node (map KnownWord entries) $ go (T.drop len txt)+ --rest <- go (T.drop len txt)+ --return (map KnownWord entries ++ rest)+ --case lookupExact word trie of+ -- Nothing -> do+ -- guard (len == 1)+ -- rest <- go (T.drop len txt)+ -- return (UnknownWord word : rest)+ -- Just es -> do+ -- rest <- go (T.drop len txt)+ -- return (KnownWord es : rest) --score :: [Token] -> Double --score = sum . map fn