前回はURLをフェッチするモジュールを外部化してMainモジュールはいまスペル修正ロジックだけを含むようになっていて大変見通しがいい。なので、コーディングを進めて今回はスペル修正に必要な候補を列挙する関数を書いていきたい。

編集距離から候補単語の集合をつくる

確率モデルに基づいたスペル修正プログラムの話を思い出してみる。与えられた打ち間違い単語wに対して、候補単語の集合を得ることについて考えていた。stadyという言葉に対して、直感的に思いつく修正単語の候補としてはstudyやsteadyなどが思い浮かぶ。studiesかもしれないしstupidとかreadyという可能性だってある。修正単語の候補としてどのような単語を列挙すればよいだろうか。

ここで編集距離という概念を使おう。

レーベンシュタイン距離 - Wikipedia

文字列の類似度を測る(1) レーベンシュタイン距離｜Colorless Green Ideas

編集距離とは2つの文字列の距離を、いくつかの編集操作を何回適用すると片方の単語をもう片方の単語にすることができるかで定義する。ここで編集操作は

削除(deletion) : 例えばport -> pot
転位(transposition) : 例えば beam -> bema (こういう単語はないと思うけど、思いつかなかった)
置換(alteration) : 例えば vine -> wine
挿入(insertion) : 例えば fair -> fairy

といった4つの操作としよう。これらの操作はそれぞれ1回で同じ編集距離を作り出すとする。例えば挿入と置換はどちらが近いという取り扱いはしない。これを使ってstadyの例を考える。stadyからの編集距離はそれぞれ

study : これは1回の置換なので編集距離は1
steady : これは1回の挿入なので編集距離は1
studies : これはa->uとしてy->iと2回の置換、eとsの2回の挿入がいるので編集距離は4
stupid : a->uの置換、pとiの2回の挿入とyの削除で編集距離は4
ready : s->r, t->eの2回の置換なので、編集距離は2

となる。

ちなみにこの編集距離というのはDiffプログラムでも使われている。我々がいまからやることはある単語をベースに決まった編集距離の単語をたくさん作る、ということだが、Diffプログラムは2つの単語が与えられたとき、その2つの最短編集距離を求めることにほかならない。最短距離を求めるので最短距離を求めるアルゴリズムを編集距離で定義されたグラフ上で走らせるイメージだ。

参考にしているスペル修正プログラムはどう書くかによれば編集距離が1である単語と2である単語を候補とすれば十分であるようなので、それらを得る関数を実際に書いていこう。

編集距離1の単語を得る関数edits1

edits1はある単語を受け取って、その単語に

一文字消す
隣同士を入れ替える
一文字をa-zのどれかと入れ替える
どこかの隙間にa-zのどれかを挿入する

のどれかを施した単語のすべてのパターンを尽くしてそれをすべて返す。この時n文字の単語の修正候補は

一文字の消し方はn通り
隣同士の入れ替え方はn-1通り
どこか一文字をa-zに入れ替える方法はn文字に対して26通り
一文字をa-zに入れる方法はアルファベットが26文字なので入れる場所がn+1通り、その入れるアルファベットが26通りあって26 * (n + 1) = 26n + 26通り

全部合わせて54n + 25通りある。ちなみにこれは重複を含む。例えばaaaaaの転位は全部同じだ。これを早速プログラムに落としこんでみよう。

    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] ]

という感じ。

substr関数は文字列sのi番目からj番目までを取り出す関数だ。返り値はsの[i,j)の範囲の文字列が帰る。edits1関数はスペル修正プログラムはどう書くかにあるものとほぼ同じ雰囲気で書けた。HaskellでもPythonのようなリスト内包表記をサポートしているためだろう。

4つあるうちの最初のリスト内包表記は与えられたwordの0からi-1番目の部分文字列とi+1番目から最後までの部分文字列を足したものを返す、というのをiが文字列の最初の文字から文字列の最後の文字まで繰り返す、ということによって最初の文字がない場合、次の文字がない場合、と消去のパターンを挙げている。

次は文字列wordの0からi-1番目にi+1番目をつなげてi番目をつなげて残りをつなげることでiとi+1番目を入れ替えることを実現している。

3番めはwordの0からi-1番目とi+1番目から最後までの2つのパーツに分けて、その隙間にアルファベットのうちどれかを入れることによって、i番目の文字がアルファベットのc番目と入れ替えた場合、という文字列を作る。これをi0からl-1まで動かしてすべての位置を網羅してそれら全てに対してcがアルファベットの最初から最後までを走査することで二重ループのようなパターンを網羅する。

最後は3番目とほとんど同じで、違うのはi番目を置き換えるために0番目からi-1番目、i+1番目から最後の2つに割っていたのを0からi番目と残りというふうにi番目を含むように割って隙間にアルファベットを詰めるようにした。

かなり何をやっているかがわかりやすいのがHaskellのいいところだ。中置演算子の'Text.snoc'とかが少し読みにくくさせているのが玉に瑕、かも(OCamlなら演算子オーバーロードできるのに...ごにょごにょ)。

試しに"foods"を入れて何が出くるか見てみよう。

    main = do
        let url = "http://textfiles.com/humor/computer.txt"
        respStr <- CHD.getUrl url
        printf "Completed.\n"
        print $ train $ wordsFromText respStr
        print $ edits1 "foods"

最後に"foods"をedits1に入れてprintしてみる、と多分ビルドエラーが出る。edits1はTextを取るのだけど、ダブルクォーテーション文字列はStringなので、型エラーが出てしまう。でもいちいちText.packするのはダサい。なのでこうしてみる

{-# LANGUAGE OverloadedStrings #-}

module Main where
    import Text.Printf (printf)
...

ファイルの一番上に何やら見慣れないものを書いてみた。詳しくは割愛するが、このOverloadedStringという言語拡張をいれるとダブルクォーテーションの文字列を必要なところでText型としてとってくれる。

Haskellライブラリ入門 (2011年版) - あどけない話

Basic Syntax Extensions - School of Haskell | FP Complete

これでRunしてみると

~/spllerD
Completed.
fromList [("",316),(".",4),("1.",1)...(割愛)...,("you",30),("you.",3),("your",33)]
["oods","fods","fods","foos","food","ofods","foods","fodos","foosd","aoods","faods","foads","fooas","fooda","boods","fbods","fobds","foobs","foodb","coods","fcods","focds","foocs","foodc","doods","fdods","fodds","foods","foodd","eoods","feods","foeds","fooes","foode","foods","ffods","fofds","foofs","foodf","goods","fgods","fogds","foogs","foodg","hoods","fhods","fohds","foohs","foodh","ioods","fiods","foids","foois","foodi","joods","fjods","fojds","foojs","foodj","koods","fkods","fokds","fooks","foodk","loods","flods","folds","fools","foodl","moods","fmods","fomds","fooms","foodm","noods","fnods","fonds","foons","foodn","ooods","foods","foods","fooos","foodo","poods","fpods","fopds","foops","foodp","qoods","fqods","foqds","fooqs","foodq","roods","frods","fords","foors","foodr","soods","fsods","fosds","fooss","foods","toods","ftods","fotds","foots","foodt","uoods","fuods","fouds","foous","foodu","voods","fvods","fovds","foovs","foodv","woods","fwods","fowds","foows","foodw","xoods","fxods","foxds","fooxs","foodx","yoods","fyods","foyds","fooys","foody","zoods","fzods","fozds","foozs","foodz","afoods","faoods","foaods","fooads","foodas","bfoods","fboods","fobods","foobds","foodbs","cfoods","fcoods","focods","foocds","foodcs","dfoods","fdoods","fodods","foodds","foodds","efoods","feoods","foeods","fooeds","foodes","ffoods","ffoods","fofods","foofds","foodfs","gfoods","fgoods","fogods","foogds","foodgs","hfoods","fhoods","fohods","foohds","foodhs","ifoods","fioods","foiods","fooids","foodis","jfoods","fjoods","fojods","foojds","foodjs","kfoods","fkoods","fokods","fookds","foodks","lfoods","floods","folods","foolds","foodls","mfoods","fmoods","fomods","foomds","foodms","nfoods","fnoods","fonods","foonds","foodns","ofoods","fooods","fooods","fooods","foodos","pfoods","fpoods","fopods","foopds","foodps","qfoods","fqoods","foqods","fooqds","foodqs","rfoods","froods","forods","foords","foodrs","sfoods","fsoods","fosods","foosds","foodss","tfoods","ftoods","fotods","footds","foodts","ufoods","fuoods","fouods","foouds","foodus","vfoods","fvoods","fovods","foovds","foodvs","wfoods","fwoods","fowods","foowds","foodws","xfoods","fxoods","foxods","fooxds","foodxs","yfoods","fyoods","foyods","fooyds","foodys","zfoods","fzoods","fozods","foozds","foodzs"]

Process finished with exit code 0

と言った感じで以下にもfoodsから距離1な単語かもしれない文字列がたくさん出てきた。いい感じだ。

編集距離2の単語を得る関数edits2

調子に乗ってこのままedits2を実装してしまおう。

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

これだけ。wordをedits1に入れた結果をもう一度edits1に入れるとedits2になっている。もちろん巡回するパターンもあるけど(例えばstudentの最後のtを"削除"して、tを最後に"挿入"するとか, 同じ場所で転置を二回するとか)。

これだけだと膨大なパターンが出てくるので、これを前回途中で作ったwordsFromTextでフィルタしておく。すると辞書にある単語だけがピックアップされてくる。これを参考のリンク先同様knownEdits2と名付けよう。まずは辞書にある単語だけをリストからフィルタする関数knownをつくる。

    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

こういう風に書いてみた。リスト内包表記の中で書いても良かったのだけど、遅そうなのでやめた。foldl'なら末尾再帰なので早いはず。この関数はedits2から出てくるヘタすると数万通りの単語列を処理するのでスタックが単語一個で一個とかで伸びていくのはまずい。たとえば5文字の単語なら(54n + 25)²のn=5なので295²=87025パターンを処理することになる。大変だ。末尾再帰ということは単なるfor文と同じなので、安心できる。

known関数が定義できたらknownEdits2は簡単だ:

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

できた。これを"foods"に対してやってみると:

    main = do
        let url = "http://textfiles.com/humor/computer.txt"
        respStr <- CHD.getUrl url
        printf "Completed.\n"
--        print $ train $ wordsFromText respStr
        print $ knownEdits2 "foods" $ train $ wordsFromText respStr

trainの部分は長いのでコメントアウトして欲しいknownEdits2だけをprintしている。すると:

~/spllerD
Completed.
["oops","looks","looks","good","good","oops"]

Process finished with exit code 0

"foods"にたいして"oops"とか"looks"とか近い気がするよ！上のテキストファイルに入っている単語が少ないのでこれだけしか出てこないのだけど、かなり雰囲気は出てきたのではないかという気がする。

まとめ

{-# LANGUAGE OverloadedStrings #-}

module Main where
    import Text.Printf (printf)
    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

    main = do
        let url = "http://textfiles.com/humor/computer.txt"
        respStr <- CHD.getUrl url
        printf "Completed.\n"
        print $ knownEdits2 "foods" $ train $ wordsFromText respStr

    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)