Игра Wordament — реализация помощника на языке Haskell

Как обычно с опозданием в месяц или даже полтора я публикую отчёт о проведённом в начале августа конкурсе по функциональному программированию под эгидой Фонда Поддержки Функционального Программирования ФП(ФП). Задачей конкурса было разработать программное решение для игры Wordament, которая заключается в поиске на квадратном поле 4х4 из букв запрятанных в нём слов. Слова могут быть в любой форме, каждая буква может быть использована в слове только один раз. Переходить от буквы к букве можно по горизонтали, вертикали или диагонали, поэтому иногда слова запрятаны в поле очень мудрёным способом.

Задача осложнялась тем, что один раунд игры длится ровно две минуты, а потому необходимо было реализовать очень быстрое решение — загрузка словаря в память, ввод исходных данных, поиск слов и вывод найденных слов на экран в порядке, отсортированном по возрастанию стоимости слов — всё это надо было сделать очень быстро, чтобы у игрока оставалось время на ввод слов в игру для получения большого количества очков. Скажем, что на экране слова должны были появиться не позднее, чем через 15 секунд после ввода исходных данных.

В конкурсе приняли участие четыре человека, которые написали свои решения на следующих языках программирования: Clojure, Nemerle, Python и Haskell. На основе последнего решения и написана данная краткая заметка.

Так что ежели кто интересуется алгоритмом поиска слов в поле, то добро пожаловать под кат.

Решение

Идеология, лежащая за решением, проста — мы будем использовать нагруженное дерево Trie (см., например, статью Flux «Trie, или нагруженное дерево»), которое на языке Haskell реализовано в модуле Data.Trie, который может быть с лёгкостью получен из архива Hackage. В этом модуле метами для дерева выбраны метки типа Bytestring, что, в общем-то, вполне логично. Кроме того, для решения потребуются словари, множества, массивы, списки, немного монад и всё остальное прочее, что предлагает программисту прекрасный язык Haskell. Ради всего этого нам придётся подключить кучу модулей:

import System.IO (hSetBuffering, stdout, stdin, BufferMode(..))
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 (Array(..), bounds, inRange, listArray, (!))
import Data.List (nub, sortBy, foldl')
import Data.Ord (comparing)
import Control.Monad (liftM, when)
import Control.Parallel.Strategies (parMap, rdeepseq)
import System.IO.UTF8 as UTF8 (readFile)
import qualified Data.ByteString.Char8 as BS (length, lines, pack)

Теперь определим два синонима типа, которые помогут нам в процессе реализации программы. Они будут использоваться исключительно для упрощения кода:

type Dictionary = Trie ()

type Board = Array (Int, Int) Char

Первый синоним типа определяет словарь, который мы будем загружать из файла. Второй синоним — это доска 4х4, на которой расположены буквы.

Теперь перейдём к определению главной функции. Поскольку нам необходимо быстро решать задачу, модуль у нас будет содержать функцию main, которая будет организовывать диалог с пользователем в режиме командной строки. Этот модулю надо будет компилировать с ключами оптимизации, а полученную программу запускать из консоли, поскольку режим интерпретации не справится с временными ограничениями, нлагаемыми на решение задачи. Итак, функция main будет выглядеть так:

main = do hSetBuffering stdout NoBuffering
          hSetBuffering stdin  NoBuffering
          dict <- readDictionary "2174526.dic"
          runCycle dict
  where
    runCycle d = do putStr "Введите входную последовательность: "
                    iSquare <- getLine
                    let board = listArray ((0, 0), (3, 3)) iSquare
                        words = nub (wordament d board)
                    mapM_ putStrLn $ sortBy (comparing score) words
                    putStrLn ""
                    putStr "Ещё раз (д/н)? "
                    yesNo <- getChar
                    when (yesNo == 'д' || yesNo == 'Д') $ runCycle d

Работаем в монаде IO. Для начала эта функция устанавливает режимы буфферизации для стандартных потоков ввода и вывода. Поскольку система ввода-вывода в языке Haskell ленива, без этих установок порядок вывода строк на экран непредсказуем. Собственно, по опыту это приходится делать всегда, равно как и многие другие вещи, связанные с ленивостью монады IO, но приходится привыкать, поскольку оная ленивость помогает в очень многих случаях. После установки режимов буфферизации произодится чтение словаря и запуск цикла интерпретации для работы с пользователем. Функцию чтения словаря мы ещё рассмотрим, а вот цикл интерпретации опишем здесь подробнее.

Как обычно, для начала выводится строка с приглашением ввести последовательность букв, которая выпала в коне игры. Последовательность вводится просто как 16 букв без каких-либо разделителей. Пользователь просто должен будет ввести все буквы, выпавшие ему на доске, ряд за рядом (не в разнобой, конечно). Далее строится внутреннее представление доски, на котором рассчитываютя слова. Далее все найденные слова сортируются по «стоимости» (стоимость слова рассчитывается по стоимости букв и длине слова) и выводятся на экран. Выводятся так, чтобы наиболее весомые слова были в конце списка, чтобы их сразу можно было начинать вводить.

После вывода всего списка слов пользователю задаётся вопрос о том, не хотел бы он сыграть ещё раз. Если пользователь отвечает положительно, то цикл интерпретации запускается повторно. Вот, собственно, и вся наука.

Теперь прочиаем словарь из файла. Для этого используется следующая функция:

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

Тут всё очень просто. Читаем из файла в кодировке UTF8 все строки, упаковываем их в список строк ByteString. После этого строим нагруженное дерево, забирая в него только слова, длина которых больше 2, поскольку только такие слова учитываются при игре в Wordament. Результатом получаем нагруженное дерево из всех слов словаря, упакованное в монаду IO. Файл словаря представляет собой просто перечисление слов — под одному слову на каждой строке.

Здесь есть функция listTrie, которая преобразует список в нагруженное дерево. Её необходимо рассмотреть подробнее, хотя её определение очень просто:

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

Обычная энергичная свёртка списка с построением нагруженного дерева. Каждый, кто хочет овладеть искусством программирования на языке Haskell, должен уметь использовать готовые блоки для организации рекурсивного перебора структур данных, а не писать свои явно-рекурсивные функции для этих целей.

Доска строится при помощи функции <a href="http://hackage.haskell.org/packages/archive/array/latest/doc/html/Data-Array-IArray.html#v:listArray">listArray</a> из модуля работы с массивами. Поэтому нам стоит рассмотреть функцию для рассчёта списка слов. Она является самой сложной в этой программе:

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

Для категорического ускорения решения используется параллелизация, функции взяты из модуля Control.Parallel.Strategies. Здесь используется стратегия параллельного энергичного построения списка всех возможных слов, начинающихся с каждой буквы на поле. Замыкание cells используется для получения списка координат всех клеток доски, а замыкание diffs содержит список всех возможных путей (8 направлений, стало быть) из клетки. Соответственно, самая главная локальная функция solve устроена следующим образом:

Если очередная найденная последовательность букв содержится в словаре, то оно добавляется в список найденных слов, иначе она просто пропускается. А последовательности собираются при помощи рекурсивного вызова этой же функции, и их построение заключается в сборе всех возможных букв по 8-ми направлениям, если только клетка с буквой ещё не рассматривалась в этом процессе построения. Последовательности собираются сразу всех длин во всех возможных направлениях и ветвлениях. И если долго всматриваться в код этой функции, то станет вполне ясно, как она работает.

Осталось дать определение ещё паре функций, которые используются для расчёта очков:

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.!)

Функция points, как видно, просто содержит ассоциированный словарь, в котором каждой букве русского алфавита сопоставлено число — количество очков за эту букву. Ну а функция score вычисляет сумму очков за буквы в заданном слове.

Собственно, на этом всё.

Заключение

Реализация этого модуля позволила мне с первого же раза занять первое место в списке игроков в коне. Затем я несколько раз повторил этот результат, после чего потерял интерес к игре Wordament :).

Описанный модуль всякий заинтересованный читатель может скачать здесь: Wordament.hs. Словарь для игры можно получить по этому адресу. Ну и как обычно несколько слов о недочётах:

1. Использование функции nub для исключения повторяющихся элементов в списке — слишком дорогое удовольствие. Можно реализовать такое решение, которое уже в функции wordament будет проверять на наличие в уже имеющемся списке найденного слова.
2. Функция score неправильно рассчитывает стоимость слова, поскольку в правилах игры используются повышающие коэффициенты для слов большой длины. Впрочем, для поиска слов это неважно.
3. Внимательный читатель заметил в модуле определение оператора (.+.). Его можно переписать в при помощи стрелок Arrow. Как?
4. Можно было бы выводить слова на экран не просто списком, но к каждому слову добавлять и его стоимость.

Мои предыдущие статьи о конкурсах по ФП на Хаброхабре:

• Конкурсы в 2011 году: Альманах конкурсов по ФП за 2011 год
• Конкурсы в 2012 году: Альманах конкурсов по ФП за 2012 год
• Игра в «кошки — мышки», поиск минимальной стратегии
• Немного стеганографии: о подготовке апрельского конкурса по ФП
• Июньский конкурс по ФП: поиск закодированной фразы мудреца

Автор: Darkus

Источник