Haskell solver for nonograms

nonograms.hs

import Control.Monad
import Data.List

data Square = Blank | Box | X
  deriving (Eq)

type Clue = [Int]


-- returns all fits for a given clue in a row of the given length, regardless of matching its current state.
allFits :: [Square] -> Clue -> [[Square]]
allFits [] [] = [[]] -- both empty, successful fit
allFits [] _  = []   -- row empty, clue not, unsuccessful.
allFits row [] = [map (const X) row]
allFits row clues = do
  guard $ sum (map (+1) clues) - 1 <= length row
  this <- [X,Box]
  case this of
    X -> map (X:) $ allFits (tail row) clues
    Box -> do
      let (c:cs) = clues
      let (rowHead, rowTail) = splitAt c row
      case rowTail of
        [] -> return $ map (const Box) rowHead
        [_] -> if null cs then return $ map (const Box) rowHead ++ [X] else return []
        (x:xs) -> do
          fit <- allFits xs cs
          return $ map (const Box) rowHead ++ (X : fit)


-- returns a list of possibilities, given a row and a clue.
possibilities :: [Square] -> Clue -> [[Square]]
possibilities row clue = filter (match row) fits
  where fits = allFits row clue
        match x y = and $ zipWith check x y
        check Blank _ = True
        check x y = x == y


-- flattens the possibilities for a row to fill in any squares that are common to them all.
-- note that possibilities are all specified, no blanks.
-- leaves uncertain squares as blank.
flatten :: [[Square]] -> [Square]
flatten poss = map (foldl1 combine) (transpose poss)
  where combine Blank _ = Blank
        combine X X = X
        combine Box Box = Box
        combine _ _ = Blank

-- take each row/clue pair, retrieve the possibilities, flatten and store.
-- this function does one iteration
pass :: [[Square]] -> [Clue] -> [[Square]]
pass rows clues = zipWith (\r c -> flatten $ possibilities r c) rows clues

-- solves the grid by alternating column and row passes until there are no more blanks.
-- the Bool parameter is the parity, True if the board needs to be transposed to match the input.
solve :: [[Square]] -> [Clue] -> [Clue] -> Bool -> [[Square]]
solve grid hClues vClues flipped = case done of
                                     False -> solve (transpose grid') hClues vClues (not flipped)
                                     True  -> if flipped then transpose grid' else grid'
  where grid' = pass grid (if flipped then vClues else hClues)
        done = not $ any (any (== Blank)) grid'


-- prepares a grid for solving by its clues (dimensions are inferred from the number of clues)
-- vertical (down the side) clues first, horizontal (across the top) second.
-- prints the result.
solveHelper :: [Clue] -> [Clue] -> IO ()
solveHelper vClues hClues = putStrLn . showGrid $ solve grid vClues hClues False
  where width = length hClues
        height = length vClues
        grid = replicate height (replicate width Blank)

showGrid = unlines . map showRow
showRow = concatMap show

instance Show Square where
  show Blank = "-"
  show Box = "X"
  show X = "."