Difference between revisions of "Nonogram"
(My nonogram solver) |
(No difference)
|
Revision as of 22:27, 14 January 2007
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]]