Solving nonograms

In this post I will show how to solve nonograms automatically using a computer. The code has been on the Haskell wiki for over year, but I have never taken the time to explain how it works.

This post is literate haskell (download the source here), so we need to start with some imports:

import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set (Set)
import Data.List
import Control.Applicative

Since we will be working with sets a lot, here are some additional utility functions:

setAll :: (a -> Bool) -> Set a -> Bool
setAll pred = all pred . Set.toList
unionMap :: (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b
unionMap f = Set.unions . map f . Set.toList

The puzzle

So, what is a nonogram anyway? Quoting Wikipedia:

Nonograms are picture logic puzzles in which cells in a grid have to be colored or left blank according to numbers given at the side of the grid to reveal a hidden picture. In this puzzle type, the numbers measure how many unbroken lines of filled-in squares there are in any given row or column. For example, a clue of "4 8 3" would mean there are sets of four, eight, and three filled squares, in that order, with at least one blank square between successive groups.

A solved nonogram might look like the following image:

A Haskell function to solve nonograms for us could have the following type, taking the clues for the rows and columns, and returning a grid indicating which squares are filled,

solvePuzzle :: [[Int]] -> [[Int]] -> [[Bool]]

Values and cells

For simplicity we will start with a single row. A first idea is to represent the cells in a row as booleans, type Row = [Bool]. This works fine for a finished puzzle like:
but consider a partially solved row:

First of all we will need a way to distinguish between blank cells (indicated by a cross) and unknown cells. Secondly, we throw away a lot of information. For instance, we know that the last filled cell will be the last cell of a group of three.

To solve the second problem we can give each position an unique label, so the first filled cell will always be, for instance 1, the second one will be 2, etc. For blank cells we can use negative numbers; the first group of blanks will be labeled -1, the second group will be -2, etc. Since the groups of blanks are of variable size, we give each one the same value. Our solved row now looks like:
[3 4][-1,2,3,4,5,-6,-6,7,8,9].

In Haskell we can define the type of cell values as simply

newtype Value = Value Int
    deriving (Eq, Ord, Show)

Since negative values encode empty cells, and positive values are filled cells, we can add some utility functions:

blank (Value n) = n < 0
filled = not . blank

This still leaves the first issue, dealing with partially solved puzzles.

Partial information

When we don't know the exact value of a cell it is still possible that there is some information. For instance, we might know that the first cell will not contain the value 9, since that value is already somewhere else. One way of representing this is to keep a set of possible values:

type Cell = Set Value

An unknown cell is simply a cell containing all possible values, and the more we know about a cell, the less the set will contain.

At a higher level we can still divide cells into four categories:

data CellState = Blank | Filled | Indeterminate | Error
    deriving Eq
cellState :: Cell -> CellState cellState x | Set.null x = Error -- Something went wrong, no options remain | setAll blank x = Blank -- The cell is guaranteed to be blank | setAll filled x = Filled -- The cell is guaranteed to be filled | otherwise = Indeterminate

CellStates are convenient for displaying (partial) solution grids,

instance Show CellState where
    show Blank         = "."
    show Filled        = "#"
    show Indeterminate = "?"
    show Error         = "E"

For example, here is our running example again, this time rotated 90°. The CellStates are shown on the left as before; while the actual Cell set is on the right:
[3 4][-1,2,3,4,5,-6,-6,7,8,9]

Solving a single row

Now it is time to solve a row.

As stated before, each filled cell gets a unique value. From a clue of the group lengths we need to construct such a unique labeling, such that labeling [4,3] == [-1,-1,2,3,4,5,-6,-6,7,8,9,-10,-10]. The exact values don't matter, as long as they are unique and have the right sign.

Constructing this labeling is simply a matter of iterating over the clues,

labeling :: [Int] -> [Value]
labeling = map Value . labeling' 1
    where labeling' n []     = [-n,-n]
          labeling' n (x:xs) = [-n,-n] ++ [n+1 .. n+x] ++ labeling' (n+x+1) xs

This labeling gives us important local information: we know what values can occur before and after a particular value. This is also the reason for including the negative (blank) values twice, since after a -1 another -1 can occur.

We can determine what comes after a value by zipping the labeling with its tail. In our example:

after    [-1,-1, 2, 3, 4, 5,-6,-6, 7, 8,  9, -10, -10]
comes [-1,-1, 2, 3, 4, 5,-6,-6, 7, 8, 9,-10, -10]

Collecting all pairs gives the mapping:

{ -1 -> {-1,2}, 2 -> {3}, 3 -> {4}, 4 -> {5}, 5 -> {-6}, -6 -> {-6,7}, ...}

Instead of carrying a Map around we can use a function that does the lookup in that map. Of course we don't want to recalculate the map every time the function is called, so we need to be careful about sharing:

bad1 a    x =  Map.lookup x (expensiveThing a)
bad2 a    x =  Map.lookup x theMap  where theMap = expensiveThing a
good a = \x -> Map.lookup x theMap  where theMap = expensiveThing a

So for determining what comes after a value in the labeling:

mkAfter :: [Value] -> (Value -> Cell)
mkAfter vs = \v -> Map.findWithDefault Set.empty v afters
    where afters = Map.fromListWith Set.union
                 $ zip vs (map Set.singleton $ tail vs)

Row data type

In the Row datatype we put all the information we have:

data Row = Row
    { cells         :: [Cell]
    , before, after :: Value -> Cell
    , start,  end   :: Cell

Some simple Show and Eq instances:

instance Show Row where
    show row = "[" ++ concatMap show (rowStates row) ++ "]"
instance Eq Row where a == b = cells a == cells b

To construct a row we first make a labeling for the clues. Then we can determine what comes after each value, and what comes after each value in the reversed labeling (and hence comes before it in the normal order).

mkRow :: Int -> [Int] -> Row
mkRow width clue = Row
        { cells  = replicate width (Set.fromList l)
        , before = mkAfter (reverse l)
        , after  = mkAfter l
        , start  = Set.singleton $ head l
        , end    = Set.singleton $ last l
    where l = labeling clue

Actually solving something

Now all the things are in place to solve our row: For each cell we can determine what values can come after it, so we can filter the next cell using this information. To be more precise, we can take the intersection of the set of values in a cell with the set of values that can occur after the previous cell. In this way we can make a forward pass through the row:

solveForward, solveBackward :: Row -> Row
solveForward row = row { cells = newCells (start row) (cells row) }
    where newCells _    []     = []
          newCells prev (x:xs) = x' : newCells x' xs
              where x' = x `Set.intersection` afterPrev
                    afterPrev = unionMap (after row) prev

Applying solveForward to the example row above, we get


In much the same way we can do a backwards pass. Instead of duplicating the code from solveForward it is easier to reverse the row, do a forward pass and then reverse the row again:

solveBackward = reverseRow . solveForward . reverseRow

Where reverseRow reverses the cells and swaps before/after and start/end:

reverseRow :: Row -> Row
reverseRow row = Row
    { cells  = reverse (cells row)
    , before = after row,   after = before row
    , start  = end   row,   end   = start  row }

In the running example even more cells will be known after doing a backwards pass,


These two steps together are as far as we are going to get with a single row, so let's package them up:

solveRow :: Row -> Row
solveRow = solveBackward . solveForward

In the end we hopefully have a row that is completely solved, or we might h We can determine whether this is the case by looking at the CellStates of the cells:

rowStates :: Row -> [CellState]
rowStates = map cellState . cells
rowDone, rowFailed :: Row -> Bool rowDone = not . any (== Indeterminate) . rowStates rowFailed = any (== Error) . rowStates

Human solution strategies

By using just one single solution strategy we can in fact emulate most of the techniques humans use. The Wikipedia page on nongrams lists several of these techniques. For instance, the simple boxes technique is illustrated with the example:

The Haskell program gives the same result:

Nonograms> solveRow $ mkRow 10 [8]

The reason why humans need many different techniques, while a single technique suffices for the program is that this simple technique requires a huge amount of administration. For each cell there is a while set of values, which would never fit into the small square grid of a puzzle.

The whole puzzle

Just a single row, or even a list of rows is not enough. In a whole nonogram there are clues for both the rows and the columns. So, let's make a data type to hold both:

data Puzzle = Puzzle { rows, columns :: [Row] }
    deriving Eq

And a function for constructing the Puzzle from a list of clues,

mkPuzzle :: [[Int]] -> [[Int]] -> Puzzle
mkPuzzle rowClues colClues = Puzzle 
    { rows    = map (mkRow (length colClues)) rowClues
    , columns = map (mkRow (length rowClues)) colClues

To display a puzzle we show the rows,

instance Show Puzzle where
    show = unlines . map show . rows
    showList = showString . unlines . map show

Initially the puzzle grids are a bit boring, for example entering in GHCi

Nonograms> mkPuzzle [[1],[3],[1]] [[1],[3],[1]]

We already know how to solve a single row, so solving a whole list of rows is not much harder,

stepRows :: Puzzle -> Puzzle
stepRows puzzle = puzzle { rows = map solveRow (rows puzzle) }

Continuing in GHCi:

Nonograms> stepRows previousPuzzle

To also solve the columns we can use the same trick as with reverseRow, this time transposing the puzzle by swapping rows and columns.

transposePuzzle :: Puzzle -> Puzzle
transposePuzzle (Puzzle rows cols) = Puzzle cols rows

But this doesn't actually help anything! We still display only the rows, and what happens there is not affected by the values in the columns. Of course when a certain cell in a row is filled (its cellState is Filled), then we know that the cell in the corresponding column is also filled. We can therefore filter that cell by removing all blank values

filterCell :: CellState -> Cell -> Cell
filterCell Blank  = Set.filter blank
filterCell Filled = Set.filter filled
filterCell _      = id

A whole row can be filtered by filtering each cell,

filterRow :: [CellState] -> Row -> Row
filterRow states row = row { cells = zipWith filterCell states (cells row) }

By transposing the list of states for each row we get a list of states for the columns. With filterRow the column cells are then filtered.

stepCombine :: Puzzle -> Puzzle
stepCombine puzzle = puzzle { columns = zipWith filterRow states (columns puzzle) }
    where states = transpose $ map rowStates $ rows puzzle

To solve the puzzle we apply stepRows and stepCombine alternatingly to the rows and to the columns. When to stop this iteration? We could stop when the puzzle is done, but not all puzzles can be solved this way. A better aproach is to take the fixed point:

solveDirect :: Puzzle -> Puzzle
solveDirect = fixedPoint (step . step)
    where step = transposePuzzle . stepCombine . stepRows

The fixed point of a function f is the value x such that x == f x. Note that there are different fixed points, but the one we are interested in here is found by simply iterating x, f x, f (f x), ...

fixedPoint :: Eq a => (a -> a) -> a -> a
fixedPoint f x
    | x == fx   = x
    | otherwise = fixedPoint f fx
  where fx = f x

The tiny 3*3 example can now be solved:

Nonograms> solveDirect previousPuzzle

But for other puzzles, such as the letter lambda from the introduction, we have no such luck:

Nonograms> solveDirect lambdaPuzzle


To solve more difficult puzzles the direct reasoning approach is not enough. To still solve these puzzles we need to make a guess, and backtrack if it is wrong.

Note that there are puzzles with more than one solution, for example

To find all solutions, and not just the first one, we can use the list monad.

To make a guess we can pick a cell that has multiple values in its set, and for each of these values see what happens if the cell contains just that value. Since there are many cells in a puzzle there are also many cells to choose from when we need to guess. It is a good idea to pick the best one.

For picking the best alternative a pair of a value and a score can be used:

data Scored m a = Scored { best :: m a, score :: Int }

This data type is an applicative functor if we use 0 as a default score:

instance Functor m => Functor (Scored m) where
    fmap f (Scored a i) = Scored (fmap f a) i
instance Applicative m => Applicative (Scored m) where
    pure a = Scored (pure a) 0
    Scored f n <*> Scored x m = Scored (f <*> x) (n `min` m)

When there are alternatives we want to pick the best one, the one with the highest score:

instance Alternative m => Alternative (Scored m) where
    empty = Scored empty minBound
    a <|> b | score a >= score b  =  a
            | otherwise           =  b

Now given a list we can apply a function to each element, but change only the best one. This way we can find the best cell to guess and immediately restrict it to a single alternative. We can do this by simply enumerating all ways to change a single element in a list.

mapBest :: Alternative m => (a -> m a) -> [a] -> m [a]
mapBest _ []      =  pure []
mapBest f (x:xs)  =  (:xs) <$> f x         -- change x and keep the tail
                 <|> (x:) <$> mapBest f xs -- change the tail and keep x

This can also be generalized to Rows and whole Puzzles:

mapBestRow :: Alternative m => (Cell -> m Cell) -> Row -> m Row
mapBestRow f row = fmap setCells $ mapBest f $ cells row
    where setCells cells' = row { cells = cells' }
mapBestRows :: Alternative m => (Cell -> m Cell) -> Puzzle -> m Puzzle mapBestRows f puzzle = fmap setRows $ mapBest (mapBestRow f) $ rows puzzle where setRows rows' = puzzle { rows = rows' }

What is the best cell to guess? A simple idea is to use the cell with the most alternatives, in the hope of eliminating as many of them as soon as possible. Then the score of a cell is the size of its set. The alternatives are a singleton set for each value in the cell.

guessCell :: Cell -> Scored [] Cell
guessCell cell = Scored
    { best  = map Set.singleton $ Set.toList cell
    , score = Set.size cell }

We can now make a guess by taking the best way to apply guessCell to a single cell:

guess :: Puzzle -> [Puzzle]
guess = best . mapBestRows guessCell

Putting it together

Direct solving is much faster than guess based solving. So the overall strategy is to use solveDirect, and when we get a puzzle that is not done we do a single guess, and then continue with direct solving all alternatives:

solve :: Puzzle -> [Puzzle]
solve puzzle
    | failed puzzle' = []
    | done   puzzle' = [puzzle']
    | otherwise      = concatMap solve (guess puzzle')
  where puzzle' = solveDirect puzzle
done, failed :: Puzzle -> Bool
done   puzzle = all rowDone   (rows puzzle ++ columns puzzle)
failed puzzle = any rowFailed (rows puzzle ++ columns puzzle)

Finally we can solve the lambda puzzle!

lambdaPuzzle = mkPuzzle
Nonograms> solve lambdaPuzzle



I actually did this in C++ once, years ago, but without the clever labeling strategy that you use. I just listed all possible alternatives for a row based on the clues (usually there aren't too many). Then removed the impossible ones based on the current cells (where a cell is filled/open/unknown), and checked whether the alternatives all agreed upon a certain value (filled/open) for a certain cell, in which case we could fill it in. This was iterated over rows and columns, with backtracking, much in the same way as you do.

But it doesn't scale, and your solution is far more elegant anyway :)

I wonder whether it is possible to extend the labeling approach in a way that keeps both rows and columns into account... something like "this cell is the third in the row of 3 and the second in the column of 4", like a Cartesian product between the current labelings. Might allow for a more two-dimensional approach instead of iterating only over rows. But I haven't thought this through, so it's probably rubbish :P

How did you do the pretty pictures ?

The pretty pictures where made with Corel PhotoPaint, and a lot of manual work. I imagine that any other drawing program would also work.

So, no fancy output libraries, sorry :)

D. I. Lewisx

Nice. This is a good explanation of some pretty code.

I think there's something amiss with your Applicative instance, though. (pure f <*> x) should be the same as (fmap f x), but the former will always have score 0 and the latter will have x's score.

D. I. Lewisx

Where by "pure f x" I mean "pure f <*> x". The angle brackets got eaten.

D. I. Lewis: You are right, the pure function should have a score of maxBound for pure f <*> x to be the same as fmap f. Unfortunatly that would change the behaviour of mapBest, because not changing anything becomes the best choice. Perhaps a better fix would be to use a different way of combining scores, for example (+) instead of min.

D WilliamsDate: 2014-07-13T19:22Zx

I've written a solver in C++ before now, it was actually the first step to write a program that would generate them.


(optional, will not be revealed)
What greek letter is usually used for anonymous functions?
Use > code for code blocks, @code@ for inline code. Some html is also allowed.