diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/Text/WordSearchSolver.hs b/Text/WordSearchSolver.hs new file mode 100644 --- /dev/null +++ b/Text/WordSearchSolver.hs @@ -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) diff --git a/wordsearch.cabal b/wordsearch.cabal new file mode 100644 --- /dev/null +++ b/wordsearch.cabal @@ -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