Haskell Boggle

Boggle.hs

module Main where

import System.Environment
import System.IO
import Data.Char
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S

------------------------------------------
-- Dirty part

main = do
  args <- getArgs
  case args of
    [gridStr] -> do
      putStrLn "Reading words from stdin..."
      wordStr <- getContents
      runTravel gridStr wordStr
    [gridStr, wordFile] -> do
      withFile wordFile ReadMode (\handle -> do
        wordStr <- hGetContents handle
        runTravel gridStr wordStr)
    _ -> do
      progName <- getProgName
      putStrLn $ "Usage: " ++ progName ++ " grid [wordfile]"

runTravel :: String -> String -> IO ()
runTravel gridStr wordStr =
  case buildGrid gridStr of
    Left errorStr -> putStrLn errorStr
    Right grid -> do
      putStrLn ":: Words found from grid:"
      mapM putStrLn $ L.filter (canTravel grid) (words wordStr)
      return ()

------------------------------------------
-- Logic part

-- exWordList = ["elm", "haskell", "purelang"]
-- (Right exGrid) = buildGrid "jpemosaakhjvella"
-- map (canTravel exGrid) exWordList

type Coord = (Int, Int)
type CharMap = M.Map Char [Coord]

data Grid = Grid
  { cmap :: CharMap
  , sideSize :: Int
  } deriving (Show)

data Path = Path
  { visited :: S.Set Coord
  , lastI :: Maybe Coord
  } deriving (Show)

buildGrid :: String -> Either String Grid
buildGrid str =
  let sideSize = floor $ sqrt $ fromIntegral $ length str
      n = sideSize - 1
      taggedChars = L.zip str [(x,y) | x <- [0..n], y <- [0..n]]
      cmap = M.fromListWith (++) [(k,[v]) | (k,v) <- taggedChars]
  in if (length str) == (sideSize * sideSize)
    then Right Grid { cmap = cmap, sideSize = sideSize }
    else Left "Only square grids are supported"

neighbours :: Grid -> Coord -> S.Set Coord
neighbours grid coord = S.filter isLegal nsC
  where s = sideSize grid
        steps = [(-1,-1),(0,-1),(1,-1),
                 (-1,0),        (1,0),
                 (-1,1), (0,1), (1,1)]
        sumC (x1,y1) (x2,y2) = (x1+x2, y1+y2)
        nsC = S.fromList $ L.zipWith sumC (repeat coord) steps
        isLegal (x,y) = 0 <= x && x < s && 0 <= y && y < s

charIndices :: Grid -> Char -> S.Set Coord
charIndices grid c =
  case M.lookup c (cmap grid) of
    Nothing -> S.empty
    Just is -> S.fromList is

pathStep :: Grid -> Path -> Char -> [Path]
pathStep grid path c = map nextPath $ S.toList usable
  where pathVisited = visited path
        available = charIndices grid c
        unvisited = S.difference available pathVisited
        usable = case lastI path of
          Nothing    -> unvisited
          Just lastI -> S.intersection unvisited (neighbours grid lastI)
        nextPath ndx = path { visited = S.insert ndx pathVisited,
                              lastI = Just ndx }

canTravel :: Grid -> String -> Bool
canTravel g str = canTravel' g str (Path S.empty Nothing)
  where canTravel' :: Grid -> String -> Path -> Bool
        canTravel' _ [] _ = True
        canTravel' g (x:xs) p = any (canTravel' g xs) nextPaths
          where nextPaths = pathStep g p x

usage

$ wc -l word_list.txt 
2266 word_list.txt

$ time ./boggle "jpemosaakhjvella" word_list.txt                                       
:: Words found from grid:
a
as
all
has
so
map
he
same
me
she
ask
shape
hope
haskell
sea
shop
shame
hell
joke
ok

real    0m0.011s
user    0m0.007s
sys     0m0.003s