アナグラム

Haskellらしさってなんだろうということを考えつつ，[id:yard:20091104]にある課題を解くプログラムを考える過程を記録してみた．整理していないのでとりとめがないです．

単語辞書から相互にアナグラムになっている単語を集める．
アナグラムとは，(意味のある)単語の文字をならび変えてできた別の(意味のある)単語のこと．

さて，2つの単語が相互にアナグラムになっていることはどう判定する．2つの単語が同じ文字を含んでいればよい．なら，それぞれの文字列を文字でソートすれば同じになる．

そうか．単語に単語を文字でソートしたものを属性として付加しておいて，この属性で単語辞書をソートすれば，アナグラムになっている単語は隣接することになるよな．

属性の付加は，よくあるパターンだよな．

addAttr :: (a -> b) -> a -> (a, b)
addAttr = ((,) <*>)

かな．ということは全体として，辞書の単語に，(1)属性を付加して，(2)属性でソートして，(3)グループ化して，(4)長さ2以上のグループだけ濾過して，(5)属性を除去すればいいよな．

anagrams :: [String] -> [[String]]
anagrams = map (map fst)                      -- (5)
         . filter ((2 =<) . length)           -- (4)
         . groupBy ((==) `on` snd)            -- (3)
         . sortBy (comparing snd)             -- (2)
         . map (addAttr (sort . map toLower)) -- (1)

さて，実際の辞書は標準入力から喰わせればいいか．とすると結果の表示は標準出力にだすことになるな．

main :: IO ()
main = interact (postproc . anagrams . preproc)

preprocは単語辞書データを単語に分割すればいい．

preproc :: String -> [String]
preproc = words

postprocは同一アナグラムを一行にならべればいいから

postproc :: [[String]] -> String
postproc = unlines . map unwords

これでそぼくな実装はできあがり．

preprocは入力辞書の性質によっていろいろフィルタを追加すればいい，たとえば，非ASCII文字とか，アルファベットではない文字とかを排除するなら

preproc :: String -> [String]
preproc = filter (all isAlpha &&& all isAscii) . words

(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)
(p &&& q) x = p x && q x

とかね．全体としては，こんな感じになるかな．

module Main (main) where

import Control.Applicative ((<*>))
import Data.Char (toLower, isAscii, isAlpha)
import Data.Function (on)
import Data.List (sort,sortBy,groupBy)
import Data.Ord (comparing)
import qualified System.IO.UTF8 as U (U.interact)

addAttr :: (a -> b) -> a -> (a, b)
addAttr = ((,) <*>)

anagrams :: [String] -> [[String]]
anagrams = map (map fst)                      
         . filter ((2 <=) . length)           
         . groupBy ((==) `on` snd)            
         . sortBy (comparing snd)             
         . map (addAttr (sort . map toLower)) 

main :: IO ()
main = U.interact (postproc . anagrams . preproc)

postproc :: [[String]] -> String
postproc = unlines . map unwords

preproc :: String -> [String]
preproc = filter (all isAlpha &&& all isAscii) . words

infixr 3 &&& 
(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)
p &&& q = (&&) . p <*> q

<*> とか on とか comparing は自分で定義しても対した手間ではないけど，この手の抽象化はたいていライブラリにあると思っていい．こういうものを探すのはHoogλeとかHayooが便利，型で検索してくれる．