wordsearch 1.0.0 → 1.0.1

raw patch · 3 files changed

+122/−80 lines, 3 filesdep −data-defaultdep ~arraydep ~basenew-component:exe:wordsearchPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: data-default

Dependency ranges changed: array, base

API changes (from Hackage documentation)

Files

• Main.hs +3/−1
• Text/WordSearchSolver.hs +112/−72
• wordsearch.cabal +7/−7

@@ -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

@@ -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)

@@ -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