1  module Main where
   2  
   3  import System(getArgs)
   4  import Control.Monad(liftM)
   5  import Data.Array.IArray(Array,listArray,elems,indices,bounds,amap,array,assocs,(//),(!))
   6  import Data.List(sort,group,intersperse)
   7  import System.Random(StdGen,getStdGen,randoms)
   8  import Data.Char(isAsciiLower)
   9  
  10  -- A 2d Grid of letters.
  11  newtype Grid = Grid (Array (Int, Int) Char)
  12  
  13  -- The score of a grid is the number of cells that are empty.
  14  
  15  score :: Grid -> Int
  16  score (Grid g) = length $ filter (== '.') $ elems g
  17  
  18  -- Convenient type classes
  19  
  20  instance Eq Grid where
  21    g1 == g2 = (score g1) == (score g2)
  22  
  23  instance Ord Grid where
  24    g1 <= g2 = (score g1) <= (score g2)
  25  
  26  instance Show Grid where
  27    show (Grid g) = concat $ intersperse "\n" $ every w $ elems g where
  28                      (_, (_, w)) = bounds g
  29                      every n = takeWhile (not . null) . map (take n) . iterate (drop n)
  30  
  31  -- Place one word into the grid. Returns a list of all possible grids
  32  -- with the new word in place.
  33  
  34  addWord :: Grid -> String -> [Grid]
  35  addWord (Grid g) w = [Grid $ g // v | pos <- indices g,
  36                                        dir <- [(x, y) | x <- [-1, 0, 1],
  37                                                         y <- [-1, 0, 1],
  38                                                         x /= 0 || y /= 0],
  39                                        let v = vec w pos dir,
  40                                        fits g v]
  41                       where
  42                         vec "" _ _ = []
  43                         vec (h:t) p@(px, py) d@(dx, dy) = (p, h) : vec t (px + dx, py + dy) d
  44                         fits g [] = True
  45                         fits g ((p, c) : t) = p `elem` (indices g) &&
  46                                               (g ! p == c || g ! p == '.') &&
  47                                               fits g t
  48  
  49  -- Place all of the words in the grid. The grid may already have letters in
  50  -- it. This returns a list of the possible grids, which may be empty if no grids
  51  -- could be formed with all of the words.
  52  
  53  fillGrid :: [String] -> Grid -> [Grid]
  54  fillGrid []    g = [g]
  55  fillGrid (h:t) g = concatMap (fillGrid t) potential where
  56                       -- Exhaustive search:
  57                            potential = addWord g h
  58                       -- Exhaustive search but checking sparse grids first
  59                       --   potential = reverse $ sort $ addWord g h
  60                       -- Exhaustive search only considering the sparsist grids
  61                       -- at each iteration. May miss solutions.
  62                       --   potential = head $ group $ reverse $ sort $ addWord g h
  63  
  64  -- Fill in empty cells with letters from the infinite list.
  65  
  66  fillEmpty :: [Char] -> Grid -> Grid
  67  fillEmpty chars (Grid g) = Grid $ array (bounds g) $ map fixEmpty $ zip (assocs g) chars where
  68                               fixEmpty ((i, '.'), c) = (i, c)
  69                               fixEmpty (e, c) = e
  70  
  71  -- Return a list of word search grids of a certain size that
  72  -- contains all of the words in the given word list oriented
  73  -- in any direction. All grids returned tied for 'best'.
  74  -- The list may be empty if no such grid is possible.
  75  -- The infinite list of Char is used to fill in the empty
  76  -- positions.
  77  
  78  solve :: [Char] -> [String] -> Int -> Int -> [Grid]
  79  solve gen words w h = map (fillEmpty gen) $ fillGrid words grid where
  80                          grid = Grid $ listArray ((1, 1), (h, w)) (repeat '.')
  81  
  82  -- Read the file and solve the puzzle. Print the result.
  83  
  84  main = do [file, width, height] <- getArgs
  85            words <- liftM lines $ readFile file
  86            gen <- getStdGen
  87            let chars = filter isAsciiLower $ randoms gen
  88            let grids = solve chars words (read width) (read height)
  89            case grids of
  90              []    -> putStrLn "No grid was found using the given parameters."
  91              (g:_) -> print g