Haskell Quiz/Word Search/Solution Sjanssen
< Haskell Quiz | Word Search
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
A trie structure
A prefix oriented structure is ideal for the word search algorithm.
module Trie where
import qualified Data.Map as Map
data Trie = Trie Bool (Map.Map Char Trie) deriving (Show)
empty = Trie False Map.empty
insert [] (Trie b m) = Trie True m
insert (x:xs) (Trie b m) = Trie b $ Map.alter (maybe (Just $ fromString xs) (Just . insert xs)) x m
fromString = foldr (\x xs -> Trie False (Map.singleton x xs)) (Trie True Map.empty)
fromList = foldr insert empty
Initial solution
import Data.Array
import Data.Char
import qualified Data.Map as Map
import Trie
type Grid = Array (Int, Int) Char
-- | Given a grid and a trie, produce a list of matched words as well as the
-- location of the match. The algorithm differs slightly from the example,
-- if a word appears several times a match is produced for each location.
match :: Grid -> Trie -> [(String, [(Int, Int)])]
match g t = concatMap (flip go t) paths
where
bs = bounds g
paths = concatMap dirs (range bs)
dirs x = [takeWhile (inRange bs) $ iterate (next (i, j)) x
| i <- [-1 .. 1], j <- [-1 .. 1], i /= 0 || j /= 0]
go xs (Trie b m) = (if b then [([], [])] else [])
++ do
(x:xs) <- return xs
let c = g ! x
t <- Map.lookup c m
(s, is) <- go xs t
return (c:s, x:is)
next (x, y) (i, j) = (i + x, j + y)
readBoard = do
l <- getLine
if null l
then return []
else fmap (l:) readBoard
csv [] = []
csv xs = l : csv (dropWhile (\x -> isSpace x || x == ',') r)
where (l, r) = span (/= ',') xs
output g ms = sequence_ [putStrLn [g' ! (i, j) | j <- [1..c]] | i <- [1..r]]
where
g' = listArray ((1, 1), (r, c)) (repeat '+') // (map (\x -> (x, g ! x)) $ concatMap snd ms)
((1, 1), (r, c)) = bounds g
main = do
b <- readBoard
let r = length b
c = length (head b)
g = listArray ((1, 1), (r, c)) . map toUpper . concat $ b
l <- getLine
let ws = map (map toUpper) $ csv l
t = fromList ws
ms = match g t
output g ms
Extra credit
For extra credit, I extended the program to support wildcards (*) in the board. This only required changing two lines and adding another.
import Data.Array
import Data.Char
import qualified Data.Map as Map
import Trie
type Grid = Array (Int, Int) Char
-- | Given a grid and a trie, produce a list of matched words as well as the
-- location of the match. The algorithm differs slightly from the example,
-- if a word appears several times a match is produced for each location.
match :: Grid -> Trie -> [(String, [(Int, Int)])]
match g t = concatMap (flip go t) paths
where
bs = bounds g
paths = concatMap dirs (range bs)
dirs x = [takeWhile (inRange bs) $ iterate (next (i, j)) x
| i <- [-1 .. 1], j <- [-1 .. 1], i /= 0 || j /= 0]
go xs (Trie b m) = (if b then [([], [])] else [])
++ do
(x:xs) <- return xs
(c, t) <- case g ! x of
'*' -> Map.assocs m
c -> fmap ((,) c) (Map.lookup c m)
(s, is) <- go xs t
return (c:s, x:is)
next (x, y) (i, j) = (i + x, j + y)
readBoard = do
l <- getLine
if null l
then return []
else fmap (l:) readBoard
csv [] = []
csv xs = l : csv (dropWhile (\x -> isSpace x || x == ',') r)
where (l, r) = span (/= ',') xs
output g ms = sequence_ [putStrLn [g' ! (i, j) | j <- [1..c]] | i <- [1..r]]
where
g' = listArray ((1, 1), (r, c)) (repeat '+') // (map (\x -> (x, g ! x)) $ concatMap snd ms)
((1, 1), (r, c)) = bounds g
main = do
b <- readBoard
let r = length b
c = length (head b)
g = listArray ((1, 1), (r, c)) . map toUpper . concat $ b
l <- getLine
let ws = map (map toUpper) $ csv l
t = fromList ws
ms = match g t
output g ms