cndict 0.2.5 → 0.3.0

raw patch · 4 files changed

+167/−88 lines, 4 filesdep +binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: binary

API changes (from Hackage documentation)

Files

• cndict.cabal +4/−2
• src/Data/Chinese/CCDict.hs +116/−65
• src/Data/Chinese/Frequency.hs +19/−16
• src/Data/Chinese/Pinyin.hs +28/−5

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                cndict-version:             0.2.5+version:             0.3.0 synopsis:            Chinese/Mandarin <-> English dictionary, Chinese lexer. -- description: license:             PublicDomain@@ -32,7 +32,9 @@                        containers >= 0.5.0.0,                        vector     >= 0.10.0.0,                        bytestring >= 0.9.0.0,-                       cassava    >= 0.3.0.0+                       cassava    >= 0.3.0.0,+                       binary   hs-source-dirs:      src   ghc-options:         -Wall+  ghc-prof-options:    -auto-all 

@@ -1,26 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE CPP   #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE BangPatterns      #-} -- | Simplified Chinese <-> English dictionary with pinyin phonetics. module Data.Chinese.CCDict   ( CCDict   , Entry(..)+  , entryPinyin   , load   , parse   , lookup   , ccDict   , Token(..)   , tokenizer-  , tokenizer'   ) where -import           Control.Monad       (mplus,guard)+import           Control.Monad       (guard) import           Data.Char import           Data.FileEmbed-import           Data.List           (foldl', sortBy)-import Data.Ord (comparing)-import           Data.Map            (Map)-import qualified Data.Map            as M+import           Data.List           (foldl')+import           Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict            as M import           Data.Maybe import           Data.Text           (Text) import qualified Data.Text           as T@@ -40,14 +41,26 @@  -- | Dictionary entry data Entry = Entry-  { entryChinese    :: Text-  , entryPinyin     :: [Text]+  { entryChinese    :: {-# UNPACK #-} !Text+  , entryPinyinRaw  :: [Text]   , entryDefinition :: [[Text]]   } deriving ( Read, Show, Eq, Ord ) -type CCDict = Map Char CCTrieEntry-data CCTrieEntry = CCTrieEntry (Maybe Entry) CCDict+entryPinyin :: Entry -> [Text]+entryPinyin = map (T.unwords . map toToneMarks . T.words) . entryPinyinRaw +type CCDict = IntMap CCTrieEntry+data CCTrieEntry+  = CCTrieEntry    {-# UNPACK #-} !Entry !CCDict+  | CCTrieEntryEnd {-# UNPACK #-} !Entry+  | CCTrieNoEntry                        !CCDict+  deriving ( Show )+++-- instance Binary CCTrieEntry where+--   put (CCTrieEntry entry rest) = put entry >> put rest+--   get = CCTrieEntry <$> get <*> get+ -- | Load dictionary from file. load :: FilePath -> IO CCDict load path = parse `fmap` T.readFile path@@ -59,26 +72,30 @@ -- | O(n). Lookup dictionary entry for a string of simplified chinese. lookup :: Text -> CCDict -> Maybe Entry lookup key trie =-    case T.unpack key of+    case map ord $ T.unpack key of       [] -> Nothing-      (x:xs) -> go xs =<< M.lookup x trie+      (x:xs) -> go xs =<< IntMap.lookup x trie   where-    go [] (CCTrieEntry es _) = es-    go (x:xs) (CCTrieEntry es m) = (go xs =<< M.lookup x m) `mplus` es+    go _ (CCTrieEntryEnd es) = Just es+    go [] (CCTrieEntry es _) = Just es+    go [] (CCTrieNoEntry _) = Nothing+    go (x:xs) (CCTrieEntry es m) = Just (fromMaybe es (go xs =<< IntMap.lookup x m))+    go (x:xs) (CCTrieNoEntry m) = (go xs =<< IntMap.lookup x m)  lookupMatches :: Text -> CCDict -> Maybe [Entry] lookupMatches key trie =-    case T.unpack key of+    case map ord $ T.unpack key of       []     -> Nothing       (x:xs) ->-        case fmap (go xs) (M.lookup x trie) of+        case fmap (go xs) (IntMap.lookup x trie) of           Just [] -> Nothing           other   -> other   where-    go [] (CCTrieEntry Nothing _) = []-    go [] (CCTrieEntry (Just e) _) = [e]-    go (x:xs) (CCTrieEntry Nothing m) = maybe [] (go xs) (M.lookup x m)-    go (x:xs) (CCTrieEntry (Just e) m) = e : maybe [] (go xs) (M.lookup x m)+    go _ (CCTrieEntryEnd e) = [e]+    go [] (CCTrieNoEntry _) = []+    go [] (CCTrieEntry e _) = [e]+    go (x:xs) (CCTrieNoEntry m) = maybe [] (go xs) (IntMap.lookup x m)+    go (x:xs) (CCTrieEntry e m) = e : maybe [] (go xs) (IntMap.lookup x m)   -- 点出发@@ -177,19 +194,28 @@ --   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+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] -> Double     geoMean [] = 0-    geoMean n = round (fromIntegral (product n)**(recip (fromIntegral (length n))))-    assocs = [ (node, geoMean (filter (/=0) (nodeSum node)))-             | node <- forest ]+    geoMean n = fromIntegral (product n)**(recip (fromIntegral (length n)))+    -- assocs = [ (node, geoMean (filter (/=0) (nodeSum node)))+    --          | node <- forest ]     wordCount word = maybe 0 subtlexWCount (M.lookup word subtlex)     entryCount (KnownWord entry) = wordCount (entryChinese entry)     entryCount UnknownWord{} = 0     nodeSum (Node entries _) = map entryCount entries+    nodeScore = geoMean . filter (/=0) . nodeSum  -- Enhanced tokenizer, mixed non-determistic and greedy algorithm tokenizer' :: CCDict -> Text -> [Token]@@ -202,23 +228,11 @@     go txt =       case lookupNonDet txt trie 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@@ -234,48 +248,80 @@ -------------------------------------------------- -- Dictionary trie -union :: CCDict -> CCDict -> CCDict-union = M.unionWith join-  where-    join (CCTrieEntry e1 t1) (CCTrieEntry e2 t2) =-      CCTrieEntry (joinEntry e1 e2) (M.unionWith join t1 t2)+-- union :: CCDict -> CCDict -> CCDict+-- union = IntMap.unionWith joinTrie -joinEntry :: Maybe Entry -> Maybe Entry -> Maybe Entry-joinEntry Nothing Nothing     = Nothing-joinEntry Nothing (Just e)    = Just e-joinEntry (Just e) Nothing    = Just e-joinEntry (Just e1) (Just e2) = Just Entry+joinTrie :: CCTrieEntry -> CCTrieEntry -> CCTrieEntry+joinTrie (CCTrieNoEntry t1) (CCTrieNoEntry t2) = CCTrieNoEntry (IntMap.unionWith joinTrie t1 t2)+joinTrie (CCTrieNoEntry t1) (CCTrieEntry e t2) = CCTrieEntry e (IntMap.unionWith joinTrie t1 t2)+joinTrie (CCTrieNoEntry t1) (CCTrieEntryEnd e) = CCTrieEntry e t1+joinTrie (CCTrieEntry e t1) (CCTrieNoEntry t2) = CCTrieEntry e (IntMap.unionWith joinTrie t1 t2)+joinTrie (CCTrieEntry e1 t1) (CCTrieEntry e2 t2) =+  CCTrieEntry (joinEntry e1 e2) (IntMap.unionWith joinTrie t1 t2)+joinTrie (CCTrieEntry e1 t2) (CCTrieEntryEnd e2) = CCTrieEntry (joinEntry e1 e2) t2+joinTrie (CCTrieEntryEnd e) (CCTrieNoEntry t)    = CCTrieEntry e t+joinTrie (CCTrieEntryEnd e1) (CCTrieEntry e2 t)  = CCTrieEntry (joinEntry e1 e2) t+joinTrie (CCTrieEntryEnd e1) (CCTrieEntryEnd e2) = CCTrieEntryEnd (joinEntry e1 e2)++joinEntry :: Entry -> Entry -> Entry+joinEntry e1 e2 = Entry   { entryChinese    = entryChinese e1-  , entryPinyin     = entryPinyin e1 ++ entryPinyin e2+  , entryPinyinRaw  = entryPinyinRaw e1 ++ entryPinyinRaw e2   , entryDefinition = entryDefinition e1 ++ entryDefinition e2 } -unions :: [CCDict] -> CCDict-unions = foldl' union M.empty+-- unions :: [CCDict] -> CCDict+-- unions = foldl' union IntMap.empty  fromList :: [Entry] -> CCDict-fromList = unions . map singleton+-- fromList = unions . map singleton+fromList = foldl' (flip insert) IntMap.empty -singleton :: Entry -> CCDict-singleton entry = go (T.unpack (entryChinese entry))+insert :: Entry -> CCDict -> CCDict+insert entry = go (T.unpack (entryChinese entry))   where-    go []     = error "singleton: Invalid entry."-    go [x]    = M.singleton x (CCTrieEntry (Just entry) M.empty)-    go (x:xs) = M.singleton x (CCTrieEntry Nothing (go xs))+    go :: [Char] -> CCDict -> CCDict+    go [] _ = error "insert: Invalid entry."+    go [x] t =+      IntMap.insertWith joinTrie (ord x) (CCTrieEntryEnd entry) t+    go (x:xs) t =+      IntMap.alter (go' xs) (ord x) t+    go' xs Nothing = Just $ CCTrieNoEntry (go xs IntMap.empty)+    go' xs (Just trie) = Just $+      case trie of+        CCTrieNoEntry t -> CCTrieNoEntry $ go xs t+        CCTrieEntry e t -> CCTrieEntry e $ go xs t+        CCTrieEntryEnd e -> CCTrieEntry e $ go xs IntMap.empty +-- singleton :: Entry -> CCDict+-- singleton entry = go (T.unpack (entryChinese entry))+--   where+--     go []     = error "singleton: Invalid entry."+--     go [x]    = IntMap.singleton (ord x) (CCTrieEntryEnd entry)+--     go (x:xs) = IntMap.singleton (ord x) (CCTrieNoEntry (go xs))+ parseLine :: Text -> Maybe Entry parseLine line | "#" `T.isPrefixOf` line = Nothing parseLine line =     Just Entry-    { entryChinese    = chinese-    , entryPinyin     = [T.unwords $ map toToneMarks $ T.words $ T.tail $ T.init $ T.unwords (pinyin ++ [pin])]-    , entryDefinition = [splitDefinition (T.unwords english)] }+    { entryChinese    = T.copy simplified+    , entryPinyinRaw  = [pinyin] -- [T.unwords $ map toToneMarks $ T.words pinyin]+    , entryDefinition = [splitDefinition english] }+    -- , entryPinyin     = V.singleton $ T.unwords $ map toToneMarks $ T.words $ T.tail $+    --                       T.init $ T.unwords (pinyin ++ [pin])+    -- , entryDefinition = V.singleton $ splitDefinition (T.unwords english) }   where-    (_traditional : chinese : rest) = T.words line-    (pinyin, (pin : english)) = break (\word -> T.count "]" word > 0) rest+    (_traditional, line') = T.breakOn " " line+    (simplified, line'') = T.breakOn " " (T.drop 1 line')+    (pinyin_, english_) = T.breakOn "/" (T.drop 1 line'')+    !english = T.copy english_+    !pinyin = T.copy $ T.dropAround (\c -> isSpace c || c == '[' || c == ']') pinyin_+    -- firstSep = breakOn " ", breakOn " ", breakOn "/"+    -- (_traditional : chinese : rest) = T.words (T.copy line)+    -- (pinyin, (pin : english)) = break (\word -> T.count "]" word > 0) rest  -- /first/second/third/ -> [first, second, third] splitDefinition :: Text -> [Text]-splitDefinition = filter (not . T.null) . T.splitOn "/"+splitDefinition = filter (not . T.null) . T.splitOn "/" . T.dropAround isSpace   --------------------------------------------------@@ -286,3 +332,8 @@ ccDict = parse $ T.decodeUtf8 raw   where     raw = $(embedFile "data/cedict_1_0_ts_utf-8_mdbg.txt")++-- ccDict' :: CCDict+-- ccDict' = decode (BL.fromStrict raw)+--   where+--     raw = $(embedFile "data/cedict_1_0_ts_utf-8_mdbg.txt.binary")

@@ -11,35 +11,36 @@ import           Data.Csv             as Csv import           Data.FileEmbed import           Data.Map             (Map)-import qualified Data.Map             as M+import qualified Data.Map.Strict            as M import           Data.Text            (Text) import qualified Data.Text            as T import           Data.Vector          (Vector) import qualified Data.Vector          as V -import           Data.Chinese.Pinyin+-- import           Data.Chinese.Pinyin  type SubtlexMap = Map Text SubtlexEntry  data SubtlexEntry = SubtlexEntry-  { subtlexIndex    :: Int-  , subtlexWord     :: T.Text-  , subtlexPinyin   :: [T.Text]-  , subtlexWCount   :: Int-  , subtlexWMillion :: Double-  , subtlexEnglish  :: T.Text+  { subtlexIndex    :: {-# UNPACK #-} !Int+  , subtlexWord     :: {-# UNPACK #-} !T.Text+  -- , subtlexPinyin   :: [T.Text]+  , subtlexWCount   :: {-# UNPACK #-} !Int+  , subtlexWMillion :: {-# UNPACK #-} !Double+  -- , subtlexEnglish  :: T.Text   } deriving ( Show )  instance FromRecord SubtlexEntry where   parseRecord rec = SubtlexEntry     <$> pure 0-    <*> index rec 0-    <*> fmap (map toToneMarks . T.splitOn "/") (index rec 2)+    <*> fmap T.copy (index rec 0)+    -- <*> fmap (map toToneMarks . T.splitOn "/") (index rec 2)     <*> index rec 4-    <*> index rec 5 <*> index rec 14+    <*> index rec 5+    -- <*> index rec 14 -loadSubtlexEntries :: FilePath -> IO (Vector SubtlexEntry)-loadSubtlexEntries path = do+_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@@ -49,15 +50,17 @@ mkSubtlexMap rows = M.fromListWith join   [ (subtlexWord row, row{subtlexIndex = n})   | (n,row) <- zip [0..] (V.toList rows)-  , subtlexEnglish row /= "#" ]+  -- , subtlexEnglish row /= "#"+  ]   where     join e1 e2 = SubtlexEntry       { subtlexIndex = min (subtlexIndex e1) (subtlexIndex e2)       , subtlexWord  = subtlexWord e1-      , subtlexPinyin = subtlexPinyin e1+      -- , subtlexPinyin = subtlexPinyin e1       , subtlexWCount = subtlexWCount e1 + subtlexWCount e2       , subtlexWMillion = subtlexWMillion e1 + subtlexWMillion e2-      , subtlexEnglish = subtlexEnglish e1 }+      -- , subtlexEnglish = subtlexEnglish e1+      }   

@@ -15,11 +15,15 @@ toToneMarks = modToneNumber toTonal  fromToneMarks :: Text -> Text-fromToneMarks = error "Data.Chinese.Pinyin.fromToneMarks: undefined."+fromToneMarks txt = clearToneMarks $+  case wordToneNumber txt of+    Nothing -> txt+    Just n  -> txt `T.append` T.pack (show n)  modToneNumber :: (Int -> Char -> Char) -> Text -> Text modToneNumber fn txt-  | T.null txt || not (isDigit (T.last txt)) = txt+  | T.null txt || not (isDigit (T.last txt)) ||+    T.last txt > '5' = txt   | Just n <- T.findIndex (`elem` "ae") txt' = modify n   | Just n <- findStrIndex "ou" txt'         = modify n   | Just n <- findSecondVowel txt'           = modify n@@ -45,14 +49,33 @@  toTonal :: Int -> Char -> Char toTonal n key =-    case Prelude.lookup key lst of+    case Prelude.lookup key toneList of       Nothing    -> key-      Just tones -> tones !! (n-1)+      Just tones+        | n < length tones -> tones !! (n-1)+        | otherwise        -> key   where-    lst =++toneList :: [(Char, String)]+toneList =       [ ('a', "āáǎàa")       , ('o', "ōóǒòo")       , ('e', "ēéěèe")       , ('i', "īíǐìi")       , ('u', "ūúǔùu") ] +wordToneNumber :: Text -> Maybe Int+wordToneNumber txt = listToMaybe+  [ n+  | (n, str) <- zip [1..] (transpose (map (take 4 . snd) toneList))+  , elt <- str+  , T.count (T.singleton elt) txt > 0 ]++clearToneMarks :: Text -> Text+clearToneMarks = T.map worker+  where+    worker c = fromMaybe c (lookup c assocs)+    assocs =+      [ (elt, clear)+      | (clear, marked) <- toneList+      , elt <- marked ]