アナグラム

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が便利,型で検索してくれる.