wordsearch (empty) → 1.0.0
raw patch · 5 files changed
+322/−0 lines, 5 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, data-default, fclabels
Files
- LICENSE +28/−0
- Main.hs +9/−0
- Setup.hs +3/−0
- Text/WordSearchSolver.hs +247/−0
- wordsearch.cabal +35/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2010, Byron James Johnson+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}++import Data.Record.Label+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
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ Text/WordSearchSolver.hs view
@@ -0,0 +1,247 @@+-- | 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)
+ wordsearch.cabal view
@@ -0,0 +1,35 @@+name: wordsearch+version: 1.0.0+cabal-version: >= 1.6+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright (C) 2010 Byron James Johnson+author: Byron James Johnson+maintainer: KrabbyKrap@gmail.com+synopsis: A word search solver library and executable+description: A word search solver library and executable+category: Algorithms+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+ exposed-modules: Text.WordSearchSolver+ exposed: True+ build-tools: ghc >= 6.12.3+ buildable: True+ ghc-options: -Wall -O2+ extensions: TemplateHaskell, ExistentialQuantification, ScopedTypeVariables, FlexibleContexts, KindSignatures, DeriveDataTypeable++executable wordSearch+ main-is: Main.hs+ build-depends: base >= 4.2.0.0 && < 5, fclabels >= 0.9.1+ other-modules: Text.WordSearchSolver+ build-tools: ghc >= 6.12.3+ buildable: True+ ghc-options: -Wall -O2+ extensions: TemplateHaskell++source-repository head+ type: darcs+ location: http://patch-tag.com/r/bob/wordsearch