A solved nonogram might look like the following image: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 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:

. 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:

== 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: * The cells in the row * What values can come before and after a value * The values at the edges > 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 @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 @CellState@s 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 ] [??????????] ] [??????????] ] ... -- Guessing -- 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 @Row@s and whole @Puzzle@s: > 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 > [[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 ] [.##.......] ] [#.##......] ] [#..#......] ] [...##.....] ] [....#.....] ] [...###....] ] [...###....] ] [..##.##...] ] [..##..#...] ] [.##...##.#] ] [.##....###] ] [##.....##.]