Editing Nonogram (section)

== Set based 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.

<haskell>
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 = map (:xs) fx -- 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
</haskell>

Here is a test puzzle that can be used in the solver:
<haskell>
-- | 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]]
</haskell>