FPFP-2013-August.hs

import Data.Trie as T (Trie, empty, insert, member)
import Data.Map  as M (Map, fromList, (!))
import Data.Set  as S (Set, fromList, toList, delete, intersection)
import Data.Array.IArray as A
import Data.List
import Data.Ord
import Data.Ix
import Control.Monad
import Control.Parallel.Strategies
import System.IO.UTF8 as UTF8 (readFile)
import qualified Data.ByteString.Char8 as BS

(a,b) .+. (c,d) = (a + c, b + d)

listTrie = foldl' (\t s -> T.insert s () t) T.empty

type Dictionary = Trie ()
type Board = Array (Int,Int) Char

readDictionary :: FilePath -> IO Dictionary
readDictionary = liftM buildTrie . readWords
  where
    buildTrie = listTrie . filter ((> 2) . BS.length)
    readWords = liftM (BS.lines . BS.pack) . UTF8.readFile

wordament :: Dictionary -> Board -> [String]
wordament dict board = concat $ parMap rdeepseq (solve (S.fromList cells) "") cells
  where
    (xMax, yMax) = snd (bounds board)

    cells = [ (x,y) | x <- [0 .. xMax], y <- [0 .. yMax] ]
    diffs = [ (dx,dy) | dx <- [-1,0,1], dy <- [-1,0,1], dx /= 0 || dy /= 0 ]

    onBoard     = inRange ((0,0),(xMax,yMax))
    expand cell = filter onBoard $ map (cell .+.) diffs

    neighbourhood = M.fromList $ zip cells (map (S.fromList . expand) cells)

    solve unvisited prefix cell@(x,y)
      | T.member (BS.pack word) dict = word : results
      | otherwise                    = results
      where
        neighbours = neighbourhood M.! cell
        unvisited' = S.delete cell unvisited
        prefix'    = (board A.! (x,y)) : prefix
        word       = reverse prefix'
        fringe     = S.toList $ S.intersection unvisited neighbours
        results    = concatMap (solve unvisited' prefix') fringe

board :: Board
board = listArray ((0,0),(3,3)) "лдывщцшуывабнетс"

points :: Map Char Int
points =
  M.fromList $
    [ ('а',1), ('б',5), ('в',2), ('г',4), ('д',4), ('е',1), ('ё',1),  ('ж',6)
    , ('з',4), ('и',1), ('й',5), ('к',3), ('л',2), ('м',2), ('н',1),  ('о',1)
    , ('п',3), ('р',2), ('с',2), ('т',2), ('у',3), ('ф',7), ('х',5),  ('ц',7)
    , ('ч',5), ('ш',4), ('щ',1), ('ъ',1), ('ы',4), ('ь',5), ('э',10), ('ю',4),
      ('я',3)
    ]

score :: String -> Int
score = sum . map (points M.!)

main = do
  dict <- readDictionary "2174526.dic"
  let words = nub (wordament dict board)
  mapM_ putStrLn $
    sortBy (comparing (Down . score)) words

shell

$ cabal install bytestring-trie
$ ghc -O3 -threaded FPFP-2013-August.hs
$ FPFP-2013-August.exe +RTS -N4

words-found

ставцы
дышав
дышат
дышу
швабу
дыша
цвета
шатены
шуба
бац
башу
ставные
цвет
шваб
шуб
ушатен
ушаст
цате
табу
ушате
ставы
цат
вынет
вашу
швы
ушат
баш
стены
вшу
шатен
шву
абу
таены
увы
баев
бает
бате
ставне
ставен
вены
абс
бас
ставе
ныв
вые
вша
ваш
ватен
шве
шва
бае
став
стаен
вате
тау
стен
стае
ват
вас
авт
таен
ста
нет
вне
вен