Haskellでものすごく簡単なスペル修正プログラムを作ってみる - その3:スペル修正プログラムを仕上げる

前回は修正候補を列挙する関数を定義した。スペル修正プログラムはどう書くかをなぞりながらいろいろ関数を定義してきたが、今回はそれらを使って最後残っている関数correctを定義していきたい。

スペル修正プログラムはどう書くかによればcorrectはエラーモデルP(w|c)を実装することになるらしい。エラーモデルと言うのは、候補単語の選び方に関わる部分だ。つまり、"thay"に対して"they"なのか"that"なのか"their"を選び出す部分だ。スペル修正プログラムはどう書くかでは単純に編集距離だけを使うことにしたそうだ。つまり、編集距離0の文字、編集距離1の文字、編集距離2の文字の順に辞書に存在するかどうかを試していって存在したらそれを使う。すると編集距離0の文字が辞書にあれば(つまり間違っていない)それを使って、編集距離1と2は調べない。編集距離0がなければ編集距離1のものの中で辞書にあるものだけをピックアップする。あればそれを、なければ編集距離2という風に調べていく。

correct関数を定義する

まず、リストに対する"or"的な関数を定義する。ここでHaskellが遅延評価であることが生きてくる。この"or"的な関数(ここではorSetと呼ぼう)は2つのリストを取って、片方のリストが空でなければそれを、空ならばもう片方のリストを返す関数だ。こんな感じ？

    orSet a b = if not (null a) then a else b

null関数はリストが空だとTrueを返す。ので、これでok。これでcorrect関数を書いてみると

    import qualified Data.Ord as Ord

    orSet a b = if not (null a) then a else b

    correct :: Text.Text -> Map.Map Text.Text Int -> ((Text.Text, Int), [(Text.Text, Int)])
    correct word knownWords =
        let
            candidate =
                known [word] knownWords `orSet`
                known (edits1 word) knownWords `orSet`
                knownEdits2 word knownWords `orSet`
                [word]
        in
            let
                candidatePacked = List.sortBy (flip $ Ord.comparing snd) (map (\x -> (x, Map.findWithDefault 0 x knownWords)) candidate)
            in
                (List.head candidatePacked, candidatePacked)

orSetで連結している部分が見えるはず。スペル修正プログラムはどう書くかのcorrect関数の面影が見えるはず。orSetで編集距離それぞれのリストのknownをつなげている。空でない最初のリストが得られるはず。 それをcandidateということにして、出現頻度順にソートする。出現頻度はknownWordsというmapに入っているので、まずは単語から出現頻度を得るためにMap.findWithDefaultをつかってmapから出現頻度を得る。それを単語自体と合わせて(単語, 出現頻度)というタプルをつくってそのリストをソートすることになる。つまり

List.sortBy (flip $ Ord.comparing snd) (map (\x -> (x, Map.findWithDefault 0 x knownWords)) candidate)

は

List.sortBy (flip $ Ord.comparing snd) [("word1", 10), ("word2", 15), ("word3", 8), ... , ("lastWord", 5)]

という感じになる。このタプルの2番め、右側の数字順に並べたいのでcomparing関数にsnd関数を渡す。comparing関数はcomparing f x y -> compare (f x) (f y)というふうにしてくれるので比較する2つのタプルから右側を取り出して普通の比較関数を呼んでくれる。この時に降順にソートしたいのでflip関数を使ってcomparing f x yをcomparing f y xという風にする。ここでfはsndになる。

デバッグ用にcorrectの呼び出しをmainに書いてビルドして実行してみよう。今回はいよいよPeter Norvig氏のページにある大きなテキストファイルを使ってみよう。

    main = do
        let url = "http://norvig.com/big.txt"
        respStr <- CHD.getUrl url
        printf "Completed.\n"
        print $ correct "thay" $ train $ wordsFromText respStr

~/spllerD
Completed.
(("that",12341),[("that",12341),("they",3926),("than",1205),("thy",47),("hay",39),("tray",7),("thaw",1)])

Process finished with exit code 0

となる。correctの出した答えは"thay"にたいしては"that"だ。"they"ではないらしい。というのはcorrectは編集距離しか見ないので"that"と"they"という編集距離1の単語に対しては出現頻度しか見ない。当然thatの方が出現頻度が多いので、thatが選ばれる。ここはエラーモデルP(w|c)に改良の余地がありそうだ。

main関数に手を加えてプログラムの引数を受け取れるようにしたりする

最後に./spller theyみたいにコマンドラインから使えるように改造してみる。System.Environmentを使うとgetArgv関数で引数をリストで受け取ることができる。getArgsはプログラム名を除いたリストをくれるので、最初の引数は0番目の部分に入っている。パターンマッチで受け取るのが楽ちんなので

    main = do
        word:url:_ <- getArgs
        respStr <- CHD.getUrl url
        printf "Completed.\n"
        print $ correct word $ train $ wordsFromText respStr

こうすると

$ ./spllerE thay http://norvig.com/big.txt
Completed.
(("that",12341),[("that",12341),("they",3926),("than",1205),("thy",47),("hay",39),("tray",7),("thaw",1)])

うまく動いた。ただし

$ ./spllerE thay
spllerE: user error (Pattern match failure in do expression at src/Main.hs:15:9-18)

URLを入れないと動かない。デフォルトでbig.txtのURL、指定された場合はそれを使うようにしたい。面倒なのでこうしてみると

    import Control.Monad

    main = do
        word:url:_ <- liftM (++ ["http://norvig.com/big.txt"]) getArgs
        respStr <- CHD.getUrl url
        printf "Completed.\n"
        print $ correct (Text.pack word) $ train $ wordsFromText respStr

$ ./spllerE thay
Completed.
(("that",12341),[("that",12341),("they",3926),("than",1205),("thy",47),("hay",39),("tray",7),("thaw",1)])

URLなしでも動いた。

ここでは単にgetArgsのリストにbig.txtのリストをくっつけてるだけ。これをやるためにはgetArgsの返り値がIOなので、liftM関数でモナドとしてくっつけないといけない。liftM関数の型は

liftM :: Monad m => (a1 -> r) -> m a1 -> m r

となっている。第1引数の関数は普通の関数を書けばいい。ここではリストをくっつける++をつかってもう片方のリストを受け取ってリストを返す [String] -> [String]な関数を渡している。liftMはこの関数をモナドに適用する。getArgsはIO [String]なのでliftMを使うことによってIO [String]の[String]部分を取り出してURLをくっつける関数を適用してIO [String]を返すことができる。

これでほとんど出来上がり。最後に出力を綺麗にして、とりあえず最終的なコードを見てみると:

{-# LANGUAGE OverloadedStrings #-}

module Main where
    import Text.Printf (printf)
    import System.Environment (getArgs)
    import qualified Data.Text as Text
    import Data.Text ()
    import qualified Data.List as List
    import qualified Data.Map as Map
    import qualified CachedHttpData as CHD
    import qualified Data.Ord as Ord
    import Control.Monad

    main = do
        word:url:_ <- liftM (++ ["http://norvig.com/big.txt"]) getArgs
        respStr <- CHD.getUrl url
        let (corrected,candidates) = correct (Text.pack word) $ train $ wordsFromText respStr
        printf "Corrected : "
        print corrected
        printf "Candidates : "
        print $ List.take 5 candidates
        printf "...\n"

    wordsFromText :: Text.Text -> [Text.Text]
    wordsFromText textStr = Text.split (`elem` " ,\"\'\r\n!@#$%^&*-_=+()") (Text.toLower textStr)

    train :: [Text.Text] -> Map.Map Text.Text Int
    train =
        List.foldl' (\map element -> Map.insertWithKey (\_ v y -> v + y) element 1 map) Map.empty

    substr :: Text.Text -> Int -> Int -> Text.Text
    substr s i j = Text.take (j - i) $ Text.drop i s

    edits1 :: Text.Text -> [Text.Text]
    edits1 word =
        let
            l = Text.length word
            alphabet = "abcdefghijklmnopqrstuvwxyz"
        in
        [ substr word 0 i `Text.append` substr word (i + 1) l | i <- [0..l-1] ] ++
            [ substr word 0 i `Text.snoc` (word `Text.index` (i+1)) `Text.snoc` (word `Text.index` i) `Text.append` substr word (i + 2) l | i <- [0..l-2] ] ++
            [ substr word 0 i `Text.snoc` (alphabet !! c) `Text.append` substr word (i + 1) l | c <- [0..25], i <- [0..l-1] ] ++
            [ substr word 0 i `Text.snoc` (alphabet !! c) `Text.append` substr word i l | c <- [0..25], i <- [0..l-1] ]

    edits2 :: Text.Text -> [Text.Text]
    edits2 word =
        [e2 | e1 <- edits1 word, e2 <- edits1 e1]

    known :: [Text.Text] -> Map.Map Text.Text Int -> [Text.Text]
    known words knownWords = List.foldl' (\z x -> if x `Map.member` knownWords then x:z else z) [] words

    knownEdits2 :: Text.Text -> Map.Map Text.Text Int -> [Text.Text]
    knownEdits2 word = known (edits2 word)

    orSet a b = if not (null a) then a else b

    correct :: Text.Text -> Map.Map Text.Text Int -> ((Text.Text, Int), [(Text.Text, Int)])
    correct word knownWords =
        let
            candidate =
                known [word] knownWords `orSet`
                known (edits1 word) knownWords `orSet`
                knownEdits2 word knownWords `orSet`
                [word]
        in
            let
                candidatePacked = List.sortBy (flip $ Ord.comparing snd) (map (\x -> (x, Map.findWithDefault 0 x knownWords)) candidate)
            in
                (List.head candidatePacked, candidatePacked)

で、出力は

$./spllerE thay
Corrected : ("that",12341)
Candidates : [("that",12341),("they",3926),("than",1205),("thy",47),("hay",39)]
...

Process finished with exit code 0

こんなかんじ。やったね。

次回は

スペル修正プログラムはどう書くかにしたがって評価を始めてよう。評価をするためにユニットテストを定義して使ってみる。ユニットテストにはいろんなフレームワークがあるけど、HUnitをまずは使ってみたい。