Haskell Quiz/Word Search/Solution Sjanssen

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

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

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