wordsearch-1.0.0: Text/WordSearchSolver.hs
-- | A word search solver library
--
-- This solver is case sensitive, but users can still map data consistently to one case before using this library.
{-# LANGUAGE TemplateHaskell, ExistentialQuantification, ScopedTypeVariables, FlexibleContexts, KindSignatures, DeriveDataTypeable #-}
module Text.WordSearchSolver ( WordSearch, ws_grid, ws_search
, Grid
, Search
, Pos(..)
, PosIndex
, Match
, readWordSearch
, wordSearch
, readGrid
, arrayToGrid
, setToSearch
, solveWordSearch
, fillMatches
, showGridInsert
) where
import Prelude hiding (foldr, foldl, concat)
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.Default
import Data.Foldable
import Data.List hiding (foldr, foldl, foldl', concat)
import Data.Record.Label
import Data.Typeable (Typeable)
--- Main ---
-- | Abstract container of a word search puzzle
--
-- This can be created either from a 'Search' and a 'Grid' by the
-- 'wordSearch' function or from a properly formatted 'String' by the
-- 'readWordSearch' function.
data WordSearch a = WordSearch { _ws_grid :: Grid a
, _ws_search :: Search a
} deriving (Typeable, Eq, Ord)
-- | A grid in which to search
--
-- Constructors of this container usually assume that the grid is rectangular and properly sized; this precondition is \not\ checked.
data Grid a = Grid { _g_array :: Array Pos a
, _g_index :: GridIndex a
} deriving (Typeable, Eq, Ord)
instance Default (Grid a) where
def = Grid { _g_array = listArray (Pos (0, 0), Pos (0, 0)) $ []
, _g_index = def
}
newtype GridIndex a = GridIndex { _gi_map :: M.Map a (S.Set Pos)
} deriving (Typeable, Eq, Ord)
instance Default (GridIndex a) where
def = GridIndex { _gi_map = def
}
-- | A set of words or lists to search
newtype Search a = Search { _s_set :: S.Set [a]
} deriving (Typeable, Eq, Ord)
instance Default (Search a) where
def = Search { _s_set = def
}
-- | A position of a grid
newtype Pos = Pos (PosIndex, PosIndex) deriving (Typeable, Eq, Ord, Ix)
instance Default Pos where
def = Pos (def, def)
-- | The integral type used for 'Pos'
type PosIndex = Integer
-- | An individual value describing a match
data Match = Match { _m_dir :: Dir
, _m_len :: Integer
, _m_pos :: Pos
} deriving (Eq, Ord)
instance Default Match where
def = Match { _m_dir = def
, _m_len = def
, _m_pos = def
}
data Dir = N
| NW
| W
| SW
| S
| SE
| E
| NE
deriving (Eq, Enum, Ord, Ix, Bounded)
instance Default Dir where
def = N
$(mkLabels [''WordSearch, ''Grid, ''GridIndex, ''Search, ''Match])
-- | Constructs a 'WordSearch' container from a properly formatted 'String'
--
-- The 'String' should contain two sections, separated by at least one empty
-- line. The first section represents the grid, and thus is formatted as the
-- String that 'readGrid' expects. The second section represents the search
-- words; it contains each word on its own separate line. In the case that
-- is ill-formed, Nothing is returned. The precondition that each grid row
-- has equal length is \not\ checked.
readWordSearch :: String -> Maybe (WordSearch Char)
readWordSearch xs = do
let (former, latter) = span (not . null) . lines $ xs
grid = readGrid $ former
search = Search . S.fromList . filter (not . null) $ dropWhile null latter
guard $ (not . null $ former)
return $ wordSearch grid search
-- | Constructs a 'WordSearch' container from a 'Grid' and a 'Search'
wordSearch :: Grid a -> Search a -> WordSearch a
wordSearch g s = WordSearch {_ws_grid = g, _ws_search = s}
-- | Constructs a 'Grid' from a formatted list of 'String's
--
-- The 'String' should be formatted as expected:
--
-- @[\"aoaoenxrcoedxncd\",
-- \"aoesnitdaoeusntd\",
-- \"itenohtneahuoteh\"]@
--
-- The precondition that each row has equal length is \not\ checked.
readGrid :: [String] -> Grid Char
readGrid xs = arrayToGrid . listArray (Pos (0, 0), Pos (pred . genericLength . head $ xs, pred . genericLength $ xs)) . concat . transpose $ xs
-- | Constructs a 'Grid' from an 'Array'
--
-- A grid array is indexed by (column, row) or (x, y), so users should be
-- careful that a list is in the proper order if listArray is used.
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
-- | Constructs a 'Search' from a set of lists
setToSearch :: S.Set [a] -> Search a
setToSearch = Search
-- | Solves a 'WordSearch' and returns a set of matches
solveWordSearch :: forall a. (Ord a) => WordSearch a -> S.Set Match
solveWordSearch ws = foldr step S.empty . getL (s_set) $ wsSearch
where wsGrid = getL (ws_grid) $ ws
wsSearch = getL (ws_search) $ ws
gi = getL (g_index) $ wsGrid
gr = getL (g_array) $ wsGrid
step s acc = let match = foldr (flip mplus . search s . Match def (genericLength s)) Nothing $ lookupIndex gi (head s)
in case match of
(Just m) -> m `S.insert` acc
(Nothing) -> acc
lookupIndex gi' k = case M.lookup k $ getL gi_map gi' of
(Just ps) -> ps
(Nothing) -> S.empty
search :: (Ord a) => [a] -> Match -> Maybe Match
search [] m = let d' = dirOpposite $ getL (m_dir) m
in Just . dirUpdateMatchPos d' . setL m_dir d' $ m
search (x:xs) m
| not $ (getL (m_pos) $ m) `inRangeOf` gr = Nothing
| gr ! (getL (m_pos) $ m) == x =
if null xs
then let d' = dirOpposite $ getL (m_dir) m
in Just . setL (m_dir) d' $ m
else foldr mplus Nothing $ [search xs m' | d <- enumFromTo minBound maxBound, let m' = dirUpdateMatchPos d m]
| otherwise = Nothing
-- | Creates a 'Grid' in which every cell that does not match is set to a default value
fillMatches :: forall e (t :: * -> *). (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 . dirUpdateMatchPos dir . setL (m_len) (pred len) $ m
| otherwise = return ()
forM_ ms $ fill
return ma
-- | Renders a 'Grid', appending a cell, usually a newline character, after every row
showGridInsert :: forall a. 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]]
--- Dir ---
dirsGrid :: M.Map Dir Pos
dirsGrid = 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 dirsGrid of
(Nothing) -> error "dirToOffset: unrecognized direction"
(Just p) -> p
dirOpposite :: Dir -> Dir
dirOpposite d = case M.lookup d dirsOpposite of
(Nothing) -> error "dirOpposite: unrecognized direction"
(Just d') -> d'
dirUpdateMatchPos :: Dir -> Match -> Match
dirUpdateMatchPos d = setL (m_dir) d . modL (m_pos) (`posPlus` dirToOffset d)
--- Helper Functions ---
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)