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
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]]
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:
.
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.
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:
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)
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
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
solveForward
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,
solveBackward
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
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.
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
and
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
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 [[2],[1,2],[1,1],[2],[1],[3],[3],[2,2],[2,1],[2,2,1],[2,3],[2,2]] [[2,1],[1,3],[2,4],[3,4],[4],[3],[3],[3],[2],[2]]
Nonograms> solve lambdaPuzzle [.##.......] [#.##......] [#..#......] [...##.....] [....#.....] [...###....] [...###....] [..##.##...] [..##..#...] [.##...##.#] [.##....###] [##.....##.]
Comments
Neat.
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 :)
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.
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.
I've written a solver in C++ before now, it was actually the first step to write a program that would generate them.
Thanks a lot for this! It's a great explanation and gave me lots to ponder about the specific knowledge representation.
I've reimplemented on my side. That got me wondering if the Scored datatype wasn't a bit misguided with its Alternative instance:
The underlying Alternative isn't used as such anywhere in the mapBest* family of functions (or at all, come to think of it), so it really seems to me all we need is a Semigroup. One that we lifted through various containers. I'd reach for the sequenceA kind of function, but all of those would tend to use the underlying Applicative structure, which is exactly what we're trying to avoid with our Semigroup. Maybe there's a chance of achieving something with the Alt wrapper, but I couldn't.
I've left my code here if you'd like to compare:
https://gist.github.com/jmazon/f42c2416b253ae1356b6523ca655a336#file-nonograms-hs-L128
(please pardon my changing most of the identifier names, it's part of my “enforce understanding before typing” process)
Reply