First player wins Superghost

Inspired by the XKCD's blag post on the solution to Ghost, I first verified his results, and then moved onto the somewhat harder task of solving Ghost's wicked step-sister, Superghost.

Briefly, the rules of Superghost: the first player names a letter; then, each player in turn either adds a letter to the beginning ("conses" a letter) or to the end ("snocs" a letter; the words "cons" and "snoc" are not game terminology, but functional-programming jargon). The first player to create a string of letters which is not part of a real word, or completes a real word, loses. I consider only the two-player version.

The solver is written in Haskell, and uses the Ubuntu British English word list. Only words with four or more letters are considered. Words containing capital or accented letters are ignored.

The program took about 22.5 seconds to find the solution: The first player wins, by playing a, i, o, s, or v.

The winning responses for the second player:

('a',[])
('b',[Snoc 'w'])
('c',[Cons 'g',Cons 'w',Snoc 'd',Snoc 'q'])
('d',[Cons 'c',Cons 'f',Cons 'g',Snoc 'w'])
('e',[Snoc 'r'])
('f',[Cons 'f',Cons 'h',Cons 'l',Cons 'x',Snoc 'd',Snoc 'f',Snoc 'g',Snoc 'n',Snoc 'p',Snoc 'w'])
('g',[Cons 'f',Cons 'h',Cons 'l',Cons 'x',Snoc 'c',Snoc 'd',Snoc 'j',Snoc 'm',Snoc 'w',Snoc 'z'])
('h',[Cons 'm',Cons 'n',Cons 'x',Snoc 'f',Snoc 'g',Snoc 'k',Snoc 'q'])
('i',[])
('j',[Cons 'g',Cons 'k',Cons 'p',Cons 'r',Cons 'u'])
('k',[Cons 'h',Cons 'k',Cons 't',Cons 'w',Cons 'y',Snoc 'j',Snoc 'k'])
('l',[Cons 'w',Cons 'x',Snoc 'f',Snoc 'g'])
('m',[Cons 'g',Snoc 'h'])
('n',[Cons 'f',Cons 'x',Snoc 'h',Snoc 'w',Snoc 'x'])
('o',[])
('p',[Cons 'f',Snoc 'j'])
('q',[Cons 'c',Cons 'h',Cons 'x'])
('r',[Cons 'e',Cons 'r',Snoc 'j',Snoc 'r'])
('s',[])
('t',[Snoc 'k'])
('u',[Snoc 'j'])
('v',[])
('w',[Cons 'b',Cons 'd',Cons 'f',Cons 'g',Cons 'n',Cons 'w',Snoc 'c',Snoc 'k',Snoc 'l',Snoc 'w',Snoc 'y'])
('x',[Cons 'n',Snoc 'f',Snoc 'g',Snoc 'h',Snoc 'l',Snoc 'n',Snoc 'q'])
('y',[Cons 'w',Snoc 'k'])
('z',[Cons 'g'])

Byorgey wanted code... he gets code. Sorry about the lack of comments, but this is a for-fun hack.

module Main where

import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Control.Applicative

type SuperghostDict = M.Map String (S.Set String)

data Play = Cons Char | Snoc Char deriving (Show, Eq, Ord)

getWords :: IO [String]
getWords = filter (all (`elem` ['a'..'z'])) <$>
            lines <$>
            readFile "/usr/share/dict/words"

makeDict :: [String] -> SuperghostDict
makeDict words = M.unionWith S.union
                 (M.fromListWith S.union $
                    concatMap (\word -> let tails = L.tails word in
                                        zip (tail tails) $ map S.singleton tails)
                               words)
                 (M.fromAscList $ map (\x -> (x, S.empty)) $ words)

wordsEnding :: String -> SuperghostDict -> S.Set String
wordsEnding word dict = (fromMaybe S.empty $ M.lookup word dict)

wordsStarting :: String -> SuperghostDict -> S.Set String
wordsStarting word dict = S.fromAscList $
                            (takeWhile (word `L.isPrefixOf`) $ map fst $
                                                M.toAscList $ snd $ M.split word dict)

wordsMiddling :: String -> SuperghostDict -> S.Set String
wordsMiddling word dict = (foldr S.union S.empty
                        (map snd $ takeWhile ((word `L.isPrefixOf`) . fst) $
                                                M.toAscList $ snd $ M.split word dict))

wordsWith :: String -> SuperghostDict -> S.Set String
wordsWith word dict = (wordsEnding word dict) `S.union`
                        (wordsStarting word dict) `S.union`
                            (wordsMiddling word dict)

plays :: String -> SuperghostDict -> S.Set Play
plays word dict = (S.map (\ w -> (Snoc $ w !! (length word))) $
                        wordsStarting word dict)
                    `S.union` (S.map (\ w -> Cons $ head w)
                                $ wordsEnding word dict)
                        `S.union` (S.map (\ w -> Cons $ head w)
                                    $ wordsMiddling word dict)

apply :: String -> Play -> String
apply word (Snoc c) = word ++ [c]
apply word (Cons c) = c:word

winnable :: SuperghostDict -> String -> Bool
winnable dict word = let moves = S.toList $ plays word dict in
                        if null moves then
                            True
                        else
                            any (not . (winnable dict) . (apply word)) moves

winningPlays :: SuperghostDict -> String -> [Play]
winningPlays dict word = let moves = S.toList $ plays word dict in
                            filter (not . (winnable dict) . (apply word)) moves

forever :: (Monad m) => m a -> m ()
forever x = x >> forever x

main = do
        dict <- makeDict <$> filter ((> 3) . length) <$> getWords
        print $ winningPlays dict ""