# Haskell Quiz/Word Search/Solution Sjanssen

< Haskell Quiz | Word Search

Jump to navigation
Jump to search

## 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
```