# Nonogram

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)

Here are some solvers for Nonogram puzzles. A description of what a nonogram is, as well as some basic solvers can be found in Ninety-Nine Haskell Problems.

## Mostly deterministic solver

By: Twan van Laarhoven

The idea behind this solver is similair to that of most Sudoku solvers, in each cell a set of its possible values are stored, and these sets are iterativly reduced until a single value remains. Instead of only using the possible values black and white this solver uses positions. If for some row the lengths [4,3] are given, then there are 10 possible positions:

• white, left of both sections of black
• 4 positions inside the first black section.
• between the two black sections
• 3 positions inside the second black section.
• after both sections.

Each cell has a both a horizontal and a vertical set of possible positions/values.

There are two kinds of passes that are made:

• hStep: for each cell, it can only have values that can follow that of its left neighbour.
• efStep: If a cell is guaranteed to be white/black according to its horizontal value its vertical value must also be white/black, and vice-versa.

The hStep is applied in all four directions by reversing and transposing the board.

If no more progress can be made using this algorithm, the solver makes a guess. In the first cell that still has multiple choices all these choices are inspected individually by 'splitting' the puzzle into a list of puzzles. These are then solved using the deterministic algorithm. Puzzles that lead to a contradiction (no possible values in a cell) are removed from the list.

```module Nonogram where

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

------------------------------------------------------------------------
-- Cells

-- | The value of a single cell
newtype Value = Value Int
deriving (Eq, Ord, Show)

-- | Negative values encode empty cells, positive values filled cells
empty (Value n) = n <= 0
full = not . empty

type Choice = Set Value

------------------------------------------------------------------------
-- Puzzle

type Grid = [[Choice]]

-- | Datatype for solved and unsolved puzzles
data Puzzle = Puzzle
-- | List of rows, containing horizontal choices for each cell
{ gridH :: Grid
-- | List of columns, containing vertical choices for each cell
, gridV :: Grid
-- | What is allowed before/after a specific value?
--   (after (Value 0)) are the values allowed on the first position
, afterH, beforeH :: [Value -> Choice]
, afterV, beforeV :: [Value -> Choice]
}

instance Eq Puzzle where
p == q = gridH p == gridH q

instance Show Puzzle where
show = dispGrid . gridH

-- | Transpose a puzzle (swap horizontal and vertical components)
transposeP :: Puzzle -> Puzzle
transposeP p = Puzzle
{ gridH      = gridV p
, gridV      = gridH p
, afterH     = afterV p
, beforeH    = beforeV p
, afterV     = afterH p
, beforeV    = beforeH p
}

-- | Display a puzzle
dispGrid = concatMap (\r -> "[" ++ map disp'' r ++ "]\n")
where	disp'' x
| Set.null     x = 'E'
| setAll full  x = '#'
| setAll empty x = '.'
| otherwise      = '/'

------------------------------------------------------------------------
-- Making puzzles

-- | Make a puzzle, when given the numbers at the edges
puzzle :: [[Int]] -> [[Int]] -> Puzzle
puzzle h v = Puzzle
{ gridH   = map (replicate cols . Set.fromList) ordersH
, gridV   = map (replicate rows . Set.fromList) ordersV
, afterH  = map mkAfter ordersH
, beforeH = map mkAfter (map reverse ordersH)
, afterV  = map mkAfter ordersV
, beforeV = map mkAfter (map reverse ordersV)
}
where	rows = length h
cols = length v
ordersH = map order h
ordersV = map order v

-- | Order of allowed values in a single row/column
--   Input = list of lengths of filled cells, which are separated by empty cells
--   Repeats empty values, because those values may be repeated
--   example:
--     order [1,2,3] = map Value [-1,-1, 1, -2,-2, 2,3, -4,-4, 4,5,6, -7,-7]
order :: [Int] -> [Value]
order = order' 1
where	order' n []     = [Value (-n), Value (-n)] -- repeated empty cells allowed at the end
order' n (x:xs) = [Value (-n), Value (-n)] ++ map Value [n..n+x-1] ++ order' (n+x) xs

-- | What values are allowed after a given value in the given order?
mkAfter :: [Value] -> Value -> Choice
mkAfter order = (mkAfterM order Map.!)

mkAfterM order  = Map.fromListWith (Set.union) aftersL
where	aftersL = -- after the start (0) the first non empty value, at position 2 is allowed
-- this is a bit of a hack
(if length order > 2
then [(Value 0, Set.singleton (order !! 2))]
else []) ++
-- after each value comes the next one in the list
zip (Value 0:order) (map Set.singleton order)

------------------------------------------------------------------------
-- Classifying puzzles

-- | Is a puzzle completely solved?
done :: Puzzle -> Bool
done = all (all ((==1) . Set.size)) . gridH

-- | Is a puzzle invalid?
invalid :: Puzzle -> Bool
invalid = any (any Set.null) . gridH

------------------------------------------------------------------------
-- Solving

-- | Solve a puzzle deterministicly, i.e. don't make any guesses
-- make sure
solveD :: Puzzle -> Puzzle
solveD = takeSame . iterate step

-- | All solving steps combined, the orientation after a step is the same as before
step = efStep . transposeP . hStep . transposeP . hStep

-- | A step in the solving process.
--   Propagate allowed values after from left to right
hStep p = p { gridH = gridH'' }
where	gridH'  = zipWith hStepLTR (afterH  p) (gridH p) -- left to right
gridH'' = zipWith hStepRTL (beforeH p) (gridH')  -- right to left

-- | hStep on a single row, from left to right, after is a function that gives the allowed after values
hStepLTR after row = hStepLTR' (after (Value 0)) row
where	hStepLTR' _         []     = []
hStepLTR' afterPrev (x:xs) = x' : hStepLTR' afterX' xs
where	x'      = Set.intersection x afterPrev
afterX' = Set.unions \$ map after \$ Set.toList x'
-- | Same as hStepRTL, but from right to left, should be given allowed before values
hStepRTL before = reverse . hStepLTR before . reverse

-- | A step in the solving process
--   Combine horizontal and verticall grids, empty/full in one <-> empty/full in the oter
--   Note: we transpose gridV, to make it compatible with gridH (row-of-cells)
efStep puzzle = puzzle { gridH = gridH', gridV = transpose gridV't }
where  (gridH', gridV't) = zzMap ef (gridH puzzle) (transpose (gridV puzzle))
-- Step on a single cell
ef h v = filterCell empty . filterCell full \$ (h,v)
-- Step on a single cell, for a single predicate, if either h or v satisfies the predicate
-- then the other is filtered so it will satisfy as well
filterCell pred (h,v)
| setAll pred h = (h, Set.filter pred v)
| setAll pred v = (Set.filter pred h, v)
| otherwise     = (h, v)

------------------------------------------------------------------------
-- Guessing

-- | Solve a puzzle, gives all solutions
solve :: Puzzle -> [Puzzle]
solve puzzle
| done    puzzle' = [puzzle'] -- single solution
| invalid puzzle' = []        -- no solutions
| otherwise       = concatMap solve (guess puzzle') -- we have to guess
where puzzle' = solveD puzzle

-- | Split a puzzle into multiple puzzles, by making a guess at the first position with multiple choices
--   we return all possible puzzles for making a guess at that position
guess :: Puzzle -> [Puzzle]
guess puzzle = map (\gh -> puzzle {gridH = gh} ) gridHs
where gridHs = trySplit (trySplit splitCell) (gridH puzzle)

-- | Try to split a cell into multiple alternatives
splitCell :: Choice -> [Choice]
splitCell = map Set.singleton . Set.toList

-- | Try to split a single item in a list using the function f
--   Stops at the first position where f has more than 1 result.
--   TODO: A more soffisticated guessing strategy might be faster.
trySplit :: (a -> [a]) -> [a] -> [[a]]
trySplit f []     = []
trySplit f (x:xs)
| length fx  > 1 = zipWith (:) fx (repeat xs) -- This element is split, don't look further
| length fxs > 1 = map (x:) fxs               -- The list is split furter on
| otherwise      = []
where	fx  = f x
fxs = trySplit f xs

------------------------------------------------------------------------
-- Utilities

-- | Set.all, similair to Data.List.all
setAll f = all f . Set.toList

-- | Map a function simultaniously over two lists, like zip
zMap :: (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zMap f a b = unzip \$ zipWith f a b

-- | Map a function simultaniously over two lists of lists, like zip
zzMap :: (a -> b -> (c, d)) -> [[a]] -> [[b]] -> ([[c]], [[d]])
zzMap f a b = unzip \$ zipWith (zMap f) a b

-- | Find the first item in a list that is repeated
takeSame :: Eq a => [a] -> a
takeSame (a:b:xs)
| a == b    = a
| otherwise = takeSame (b:xs)

------------------------------------------------------------------------
-- Test```

Here is a test puzzle that can be used in the solver:

```-- | A test puzzle
test = puzzle [[6],[3,1,3],[1,3,1,3],[3,14],[1,1,1],
[1,1,2,2],[5,2,2],[5,1,1],[5,3,3,3],[8,3,3,3]]
[[4],[4],[1,5],[3,4],[1,5],[1],[4,1],[2,2,2],
[3,3],[1,1,2],[2,1,1],[1,1,2],[4,1],[1,1,2],
[1,1,1],[2,1,2],[1,1,1],[3,4],[2,2,1],[4,1]]```