diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} import Data.Record.Label +import qualified Data.Set as S import Text.WordSearchSolver main :: IO () main = interact conv where conv s = let ~(Just ws) = readWordSearch s - in showGridInsert '\n' . fillMatches '_' (getL (ws_grid) $ ws) . solveWordSearch $ ws + (matches, nonmatches) = solveWordSearch ws + in (++ "\n" ++ (unlines . S.toList . searchToSet $ nonmatches)) . showGridInsert '\n' . fillMatches '_' (getL (ws_grid) $ ws) $ matches diff --git a/Text/WordSearchSolver.hs b/Text/WordSearchSolver.hs --- a/Text/WordSearchSolver.hs +++ b/Text/WordSearchSolver.hs @@ -1,39 +1,65 @@ -- | A word search solver library -- --- This solver is case sensitive, but users can still map data consistently to one case before using this library. +-- This solver is case sensitive; users should map data consistently to one case before using this library when such behavior is desired. -{-# LANGUAGE TemplateHaskell, ExistentialQuantification, ScopedTypeVariables, FlexibleContexts, KindSignatures, DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} -module Text.WordSearchSolver ( WordSearch, ws_grid, ws_search +module Text.WordSearchSolver ( + -- * Types and containers + WordSearch, ws_grid, ws_search , Grid , Search , Pos(..) , PosIndex - , Match + , Match(..), m_dir, m_len, m_pos + , Dir(..) + + -- * 'WordSearch' puzzles , readWordSearch , wordSearch + , solveWordSearch + , search + , tryMatch + + -- * 'Grid' and 'Search' containers , readGrid , arrayToGrid , setToSearch - , solveWordSearch + , searchToSet + + -- * Operations on solutions and rendering 'Grid's , fillMatches , showGridInsert + + -- * 'Dir's + , dirs + , dirs' + , dirsPos + , dirsOpposite + , dirToOffset + , dirOpposite + , dirUpdatePos + + -- * Helper functions + , inRangeOf + , posPlus ) where -import Prelude hiding (foldr, foldl, concat) +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.Default +import Data.Data (Data) import Data.Foldable import Data.List hiding (foldr, foldl, foldl', concat) import Data.Record.Label import Data.Typeable (Typeable) ---- Main --- +--- Types and containers --- -- | Abstract container of a word search puzzle -- @@ -42,36 +68,24 @@ -- 'readWordSearch' function. data WordSearch a = WordSearch { _ws_grid :: Grid a , _ws_search :: Search a - } deriving (Typeable, Eq, Ord) + } deriving (Data, Typeable, Eq, Ord, Show, Read) -- | 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 - } + } deriving (Data, Typeable, Eq, Ord, Show, Read) 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 - } + } deriving (Data, Typeable, Eq, Ord, Show, Read) -- | 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 - } + } deriving (Data, Typeable, Eq, Ord, Show, Read) -- | A position of a grid -newtype Pos = Pos (PosIndex, PosIndex) deriving (Typeable, Eq, Ord, Ix) -instance Default Pos where - def = Pos (def, def) +newtype Pos = Pos (PosIndex, PosIndex) deriving (Data, Typeable, Eq, Ord, Ix, Show, Read) -- | The integral type used for 'Pos' type PosIndex = Integer @@ -80,12 +94,7 @@ 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 - } + } deriving (Data, Typeable, Eq, Ord, Show, Read) data Dir = N | NW @@ -95,9 +104,7 @@ | SE | E | NE - deriving (Eq, Enum, Ord, Ix, Bounded) -instance Default Dir where - def = N + deriving (Data, Typeable, Eq, Enum, Ord, Ix, Show, Read) $(mkLabels [''WordSearch, ''Grid, ''GridIndex, ''Search, ''Match]) @@ -114,10 +121,10 @@ 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 + grid = readGrid $ former + searchTerms = Search . S.fromList . filter (not . null) $ dropWhile null latter guard $ (not . null $ former) - return $ wordSearch grid search + return $ wordSearch grid searchTerms -- | Constructs a 'WordSearch' container from a 'Grid' and a 'Search' wordSearch :: Grid a -> Search a -> WordSearch a @@ -150,36 +157,45 @@ 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 +-- | Returns the set of search terms from a 'Search' container +searchToSet :: Search a -> S.Set [a] +searchToSet = getL s_set - 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 +-- | Solves a 'WordSearch' and returns a set of matches together with a set of search terms for which a match was not found in a tuple +-- +-- This algorithm solves word search puzzles by looking at the first cell of each search term, and looking for a match by checking each direction from each position whose cell contains the starting cell of the search term until a match is found. The dictionary of individual cell values and sets of positions is part of the 'Grid' container; 'arrayToGrid' creates this dictionary automatically. +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) = -- look at algorithm + 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 :: (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 +-- | Determines whether a given 'Search' term can be matched at a given position of a grid +-- +-- This is done by trying each direction for a match from the given location. +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] +-- | If the location and the direction matches the 'Search' term, returns the 'Match'; otherwise, returns Nothing +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 + -- | 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 :: (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 @@ -187,13 +203,13 @@ | len == 0 = return () | pos `inRangeOf` a = do writeArray ma pos $ a ! pos - fill . dirUpdateMatchPos dir . setL (m_len) (pred len) $ m + fill . modL m_pos (dirUpdatePos 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 :: 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 @@ -202,8 +218,26 @@ 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)) $ +-- | Complete set of possible 'Grid' 'Match' directions +dirs :: [Dir] +dirs = + [ N + , NW + , W + , SW + , S + , SE + , E + , NE + ] + +-- | More efficient (and real, unordered) 'Set' of 'dirs' +dirs' :: S.Set Dir +dirs' = S.fromList dirs + +-- | 'Map' of directions and 'Pos' offsets +dirsPos :: M.Map Dir Pos +dirsPos = M.fromList . map (\ ~(a, b) -> (a, Pos b)) $ [ (N, ( 0, -1)) , (NW, (-1, -1)) , (W, (-1, 0)) @@ -214,6 +248,7 @@ , (NE, ( 1, -1)) ] +-- | Bidirectional 'Map' of opposite directions dirsOpposite :: M.Map Dir Dir dirsOpposite = M.fromList $ [ (N, S) @@ -226,22 +261,27 @@ , (NE, SW) ] +-- | Returns the appropriate offset of a direction dirToOffset :: Dir -> Pos -dirToOffset d = case M.lookup d dirsGrid of - (Nothing) -> error "dirToOffset: unrecognized direction" +dirToOffset d = case M.lookup d dirsPos of (Just p) -> p + (Nothing) -> error "dirToOffset: unrecognized direction" -- This shouldn't happen, since the lookup should always succeed +-- | Returns the opposite direction dirOpposite :: Dir -> Dir dirOpposite d = case M.lookup d dirsOpposite of - (Nothing) -> error "dirOpposite: unrecognized direction" (Just d') -> d' + (Nothing) -> error "dirOpposite: unrecognized direction" -- This shouldn't happen, since the lookup should always succeed -dirUpdateMatchPos :: Dir -> Match -> Match -dirUpdateMatchPos d = setL (m_dir) d . modL (m_pos) (`posPlus` dirToOffset d) +-- | Updates a position by one step in the given direction +dirUpdatePos :: Dir -> Pos -> Pos +dirUpdatePos d = (`posPlus` dirToOffset d) --- Helper Functions --- +-- | Determines whether an index is within the range of the bounds of an array inRangeOf :: (Ix a) => a -> Array a e -> Bool i `inRangeOf` a = inRange (bounds a) i +-- | Adds two positions posPlus :: Pos -> Pos -> Pos posPlus (Pos (ax, ay)) (Pos (ba, by)) = Pos (ax + ba, ay + by) diff --git a/wordsearch.cabal b/wordsearch.cabal --- a/wordsearch.cabal +++ b/wordsearch.cabal @@ -1,5 +1,5 @@ name: wordsearch -version: 1.0.0 +version: 1.0.1 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -13,19 +13,19 @@ tested-with: GHC == 6.12.3 library - build-depends: base >= 4.2.0.0 && < 5, containers, array >= 0.3.0.1, fclabels >= 0.9.1, data-default >= 0.2 + build-depends: base >= 4 && < 5, containers, array, fclabels >= 0.9.1 exposed-modules: Text.WordSearchSolver exposed: True - build-tools: ghc >= 6.12.3 + build-tools: ghc >= 6.10.1 buildable: True ghc-options: -Wall -O2 - extensions: TemplateHaskell, ExistentialQuantification, ScopedTypeVariables, FlexibleContexts, KindSignatures, DeriveDataTypeable + extensions: TemplateHaskell, DeriveDataTypeable -executable wordSearch +executable wordsearch main-is: Main.hs - build-depends: base >= 4.2.0.0 && < 5, fclabels >= 0.9.1 + build-depends: base >= 4 && < 5, containers, fclabels >= 0.9.1 other-modules: Text.WordSearchSolver - build-tools: ghc >= 6.12.3 + build-tools: ghc >= 6.10.1 buildable: True ghc-options: -Wall -O2 extensions: TemplateHaskell