module Text.WordSearchSolver (
WordSearch, ws_grid, ws_search
, Grid
, Search
, Pos(..)
, PosIndex
, Match(..), m_dir, m_len, m_pos
, Dir(..)
, readWordSearch
, wordSearch
, solveWordSearch
, search
, tryMatch
, readGrid
, arrayToGrid
, setToSearch
, searchToSet
, fillMatches
, showGridInsert
, dirs
, dirs'
, dirsPos
, dirsOpposite
, dirToOffset
, dirOpposite
, dirUpdatePos
, inRangeOf
, posPlus
) where
import Prelude hiding (id, (.), foldr, foldl, concat)
import Control.Category
import Control.Monad hiding (forM, forM_)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Array
import Data.Array.MArray
import Data.Array.ST
import Data.Data (Data)
import Data.Foldable
import Data.List hiding (foldr, foldl, foldl', concat)
import Data.Record.Label
import Data.Typeable (Typeable)
data WordSearch a = WordSearch { _ws_grid :: Grid a
, _ws_search :: Search a
} deriving (Data, Typeable, Eq, Ord, Show, Read)
data Grid a = Grid { _g_array :: Array Pos a
, _g_index :: GridIndex a
} deriving (Data, Typeable, Eq, Ord, Show, Read)
newtype GridIndex a = GridIndex { _gi_map :: M.Map a (S.Set Pos)
} deriving (Data, Typeable, Eq, Ord, Show, Read)
newtype Search a = Search { _s_set :: S.Set [a]
} deriving (Data, Typeable, Eq, Ord, Show, Read)
newtype Pos = Pos (PosIndex, PosIndex) deriving (Data, Typeable, Eq, Ord, Ix, Show, Read)
type PosIndex = Integer
data Match = Match { _m_dir :: Dir
, _m_len :: Integer
, _m_pos :: Pos
} deriving (Data, Typeable, Eq, Ord, Show, Read)
data Dir = N
| NW
| W
| SW
| S
| SE
| E
| NE
deriving (Data, Typeable, Eq, Enum, Ord, Ix, Show, Read)
$(mkLabels [''WordSearch, ''Grid, ''GridIndex, ''Search, ''Match])
readWordSearch :: String -> Maybe (WordSearch Char)
readWordSearch xs = do
let (former, latter) = span (not . null) . lines $ xs
grid = readGrid $ former
searchTerms = Search . S.fromList . filter (not . null) $ dropWhile null latter
guard $ (not . null $ former)
return $ wordSearch grid searchTerms
wordSearch :: Grid a -> Search a -> WordSearch a
wordSearch g s = WordSearch {_ws_grid = g, _ws_search = s}
readGrid :: [String] -> Grid Char
readGrid xs = arrayToGrid . listArray (Pos (0, 0), Pos (pred . genericLength . head $ xs, pred . genericLength $ xs)) . concat . transpose $ xs
arrayToGrid :: (Ord a) => Array Pos a -> Grid a
arrayToGrid a = Grid { _g_array = a
, _g_index = gridIndex a
}
where gridIndex arr = GridIndex $ foldr step M.empty $ assocs arr
step ~(p, v) acc = M.insertWith (flip S.union) v (S.singleton p) acc
setToSearch :: S.Set [a] -> Search a
setToSearch = Search
searchToSet :: Search a -> S.Set [a]
searchToSet = getL s_set
solveWordSearch :: (Eq a, Ord a) => WordSearch a -> (S.Set Match, Search a)
solveWordSearch ws = let (matches, nonmatches) = foldr step (S.empty, S.empty) . getL (s_set) $ getL ws_search ws
in (matches, Search nonmatches)
where step s (matches, nonmatches) =
let match = foldr (flip mplus . search (getL ws_grid ws) s) Nothing $ positions
positions = case M.lookup (head s) $ getL (gi_map . g_index . ws_grid) ws of
(Just ps) -> ps
(Nothing) -> S.empty
in case match of
(Just m) -> (m `S.insert` matches, nonmatches)
(Nothing) -> (matches, s `S.insert` nonmatches)
search :: (Eq a) => Grid a -> [a] -> Pos -> Maybe Match
search _ [] _ = Nothing
search grid xs p = foldr mplus Nothing $ [tryMatch grid xs p d | d <- dirs]
tryMatch :: (Eq a) => Grid a -> [a] -> Pos -> Dir -> Maybe Match
tryMatch grid = tryMatch' 0
where arr = getL g_array grid
tryMatch' i [] p d = let d' = dirOpposite d
in Just $ Match {_m_dir = d', _m_len = i, _m_pos = dirUpdatePos d' p}
tryMatch' i (x:xs) p d
| not $ p `inRangeOf` arr = Nothing
| arr ! p == x = tryMatch' (succ i) xs (dirUpdatePos d p) d
| otherwise = Nothing
fillMatches :: (Foldable t, Ord e) => e -> Grid e -> t Match -> Grid e
fillMatches deft g ms = arrayToGrid . runSTArray $ do
let a = getL (g_array) g
ma <- thaw $ listArray (bounds a) $ repeat deft
let fill ~m@(Match dir len pos)
| len == 0 = return ()
| pos `inRangeOf` a = do
writeArray ma pos $ a ! pos
fill . modL m_pos (dirUpdatePos dir) . setL (m_len) (pred len) $ m
| otherwise = return ()
forM_ ms $ fill
return ma
showGridInsert :: a -> Grid a -> [a]
showGridInsert ins g = let a = getL (g_array) g
~((Pos (0, 0)), Pos (w, h)) = bounds a
step ~p@(x, _) acc
| x == w = (a ! Pos p):ins : acc
| otherwise = a ! Pos p : acc
in foldr step [] $ [(x, y) | y <- [0..h], x <- [0..w]]
dirs :: [Dir]
dirs =
[ N
, NW
, W
, SW
, S
, SE
, E
, NE
]
dirs' :: S.Set Dir
dirs' = S.fromList dirs
dirsPos :: M.Map Dir Pos
dirsPos = M.fromList . map (\ ~(a, b) -> (a, Pos b)) $
[ (N, ( 0, 1))
, (NW, (1, 1))
, (W, (1, 0))
, (SW, (1, 1))
, (S, ( 0, 1))
, (SE, ( 1, 1))
, (E, ( 1, 0))
, (NE, ( 1, 1))
]
dirsOpposite :: M.Map Dir Dir
dirsOpposite = M.fromList $
[ (N, S)
, (NW, SE)
, (W, E)
, (SW, NE)
, (S, N)
, (SE, NW)
, (E, W)
, (NE, SW)
]
dirToOffset :: Dir -> Pos
dirToOffset d = case M.lookup d dirsPos of
(Just p) -> p
(Nothing) -> error "dirToOffset: unrecognized direction"
dirOpposite :: Dir -> Dir
dirOpposite d = case M.lookup d dirsOpposite of
(Just d') -> d'
(Nothing) -> error "dirOpposite: unrecognized direction"
dirUpdatePos :: Dir -> Pos -> Pos
dirUpdatePos d = (`posPlus` dirToOffset d)
inRangeOf :: (Ix a) => a -> Array a e -> Bool
i `inRangeOf` a = inRange (bounds a) i
posPlus :: Pos -> Pos -> Pos
posPlus (Pos (ax, ay)) (Pos (ba, by)) = Pos (ax + ba, ay + by)