path: root/tests/examplefiles/Sudoku.lhs

% Copyright 2005 Brian Alliet

\documentclass[11pt]{article}
\usepackage{palatino}
\usepackage{fullpage}
\usepackage{parskip}
\usepackage{lhs}

\begin{document}

\title{Sudoku Solver}
\author{Brian Alliet}
\maketitle

\ignore{
\begin{code}
module Sudoku (
    Sudoku,
    makeSudoku, solve, eliminate, analyze, backtrack,
    main
    ) where

import Array
import Monad
import List (union,intersperse,transpose,(\\),nub,nubBy)
\end{code}
}

\section{Introduction}

This Haskell module implements a solver for Sudoku~\footnote{http://en.wikipedia.org/wiki/Sudoku} puzzles. It can solve
any Sudoku puzzle, even those that require backtracking.

\section{Data Types}

\begin{code}
data CellState a = Known a | Unknown [a] | Impossible deriving Eq
\end{code}

Each cell in a Sudoku grid can be in one of three states: ``Known'' if it has a known correct value~\footnote{Actually
this doesn't always means it is correct. While we are in the backtracking stage we make our guesses ``Known''.},
``Unknown'' if there is still more than one possible correct value, or ``Impossible'' if there is no value that can
possibly fit the cell. Sudoku grids with ``Impossible'' cells are quickly discarded by the {\tt solve} function.

\begin{code}
type Coords = (Int,Int)
type Grid a = Array Coords (CellState a)
newtype Sudoku a = Sudoku { unSudoku :: Grid a } deriving Eq
\end{code}

We represent a Sudoku grid as an Array indexed by integer coordinates. We additionally define a newtype wrapper for the
grid. The smart constructor, {\tt makeSudoku} verifies some invariants before creating the Sudoku value. All the public
API functions operate on the Sudoku type.

\begin{code}
instance Show a => Show (Sudoku a) where showsPrec p = showParen (p>0) . showsGrid . unSudoku
instance Show a => Show (CellState a) where showsPrec _ = showsCell
\end{code}

We define {\tt Show} instances for the above types.

\section{Internal Functions}

\begin{code}
size :: Grid a -> Int
size = (+1).fst.snd.bounds
\end{code}

{\tt size} returns the size (the width, height, and number of subboxes) for a Sudoku grid. We ensure Grid's are always
square and indexed starting at $(0,0)$ so simply incrementing either of the array's upper bounds is correct.

\begin{code}
getRow,getCol,getBox :: Grid a -> Int -> [(Coords,CellState a)]
getRow grid r = [let l = (r,c) in (l,grid!l)|c <- [0..size grid - 1]]
getCol grid c = [let l = (r,c) in (l,grid!l)|r <- [0..size grid - 1]]
getBox grid b = [let l = (r,c) in (l,grid!l)|r <- [boxR..boxR+boxN-1],c <- [boxC..boxC+boxN-1]]
    where
        boxN = intSqrt (size grid); boxR = b `quot` boxN * boxN; boxC = b `rem`  boxN * boxN

getBoxOf :: Grid a -> Coords -> [(Coords,CellState a)]
getBoxOf grid (r,c) = grid `getBox` ((r `quot` boxN * boxN) + (c `quot` boxN))
    where boxN = intSqrt (size grid)
\end{code}

{\tt getRow}, {\tt getCol}, and {\tt getBox} return the coordinates and values of the cell in row, column, or box
number {\tt n}, {\tt r}, or {\tt b}.

\begin{code}
getNeighbors :: Eq a => Grid a -> Coords -> [(Coords,CellState a)]
getNeighbors grid l@(r,c) = filter ((/=l).fst) 
                          $ foldr (union.($grid)) [] 
                          [(`getRow`r),(`getCol`c),(`getBoxOf`l)]
\end{code}

{\tt getNeighbors} returns the coordinates and values of all the neighbors of this cell.

\begin{code}
impossible :: Eq a => Grid a -> Coords -> [a]
impossible grid l = map snd $ justKnowns $ grid `getNeighbors` l
\end{code}

{\tt impossible} returns a list of impossible values for a given cell. The impossible values consist of the values any
``Known'' neighbors.

\begin{code}
justUnknowns :: [(Coords,CellState a)] -> [(Coords,[a])]
justUnknowns = foldr (\c -> case c of (p,Unknown xs) -> ((p,xs):); _ -> id) []

justKnowns :: [(Coords,CellState a)] -> [(Coords,a)]
justKnowns = foldr (\c -> case c of (p,Known x) -> ((p,x):); _ -> id) []
\end{code}

{\tt justUnknowns} and {\tt justKnowns} return only the Known or Unknown values (with the constructor stripped off)
from a list of cells.

\begin{code}
updateGrid :: Grid a -> [(Coords,CellState a)] -> Maybe (Grid a)
updateGrid _ [] = Nothing
updateGrid grid xs = Just $ grid // nubBy (\(x,_) (y,_) -> x==y) xs
\end{code}

{\tt updateGrid} applies a set of updates to a grid and returns the new grid only if it was updated.

\section{Public API}

\begin{code}
makeSudoku :: (Num a, Ord a, Enum a) => [[a]] -> Sudoku a
makeSudoku xs
    | not (all ((==size).length) xs) = error "error not a square"
    | (intSqrt size)^(2::Int) /= size = error "error dims aren't perfect squares"
    | any (\x -> x < 0 || x > fromIntegral size) (concat xs) = error "value out of range"
    | otherwise = Sudoku (listArray ((0,0),(size-1,size-1)) states)
    where
        size = length xs
        states = map f (concat xs)
        f 0 = Unknown [1..fromIntegral size]
        f x = Known x
\end{code}

{\tt makeSudoku} makes a {\tt Sudoku} value from a list of numbers. The given matrix must be square and have dimensions
that are a perfect square. The possible values for each cell range from 1 to the dimension of the square with ``0''
representing unknown values.\footnote{The rest of the code doesn't depend on any of this weird ``0'' is unknown
representation. In fact, it doesn't depend on numeric values at all. ``0'' is just used here because it makes
representing grids in Haskell source code easier.}

\begin{code}
eliminate :: Eq a => Sudoku a -> Maybe (Sudoku a)
eliminate (Sudoku grid) = fmap Sudoku $ updateGrid grid changes >>= sanitize
    where
        changes = concatMap findChange $ assocs grid
        findChange (l,Unknown xs) 
            = map ((,) l) 
            $ case filter (not.(`elem`impossible grid l)) xs of
                [] -> return Impossible
                [x] -> return $ Known x
                xs'
                    | xs' /= xs -> return $ Unknown xs'
                    | otherwise -> mzero
        findChange _ = mzero
        sanitize grid = return $ grid // [(l,Impossible) | 
            (l,x) <- justKnowns changes, x `elem` impossible grid l]
\end{code}

The {\tt eliminate} phase tries to remove possible choices for ``Unknowns'' based on ``Known'' values in the same row,
column, or box as the ``Unknown'' value. For each cell on the grid we find its ``neighbors'', that is, cells in the
same row, column, or box. Out of those neighbors we get a list of all the ``Known'' values. We can eliminate all of
these from our list of candidates for this cell. If we're lucky enough to eliminate all the candidates but one we have
a new ``Known'' value. If we're unlucky enough to have eliminates {\bf all} the possible candidates we have a new
``Impossible'' value.

After iterating though every cell we make one more pass looking for conflicting changes. {\tt sanitize} marks cells as
``Impossible'' if we have conflicting ``Known'' values.

\begin{code}
analyze :: Eq a => Sudoku a -> Maybe (Sudoku a)
analyze (Sudoku grid) = fmap Sudoku $ updateGrid grid $ nub [u |
            f <- map ($grid) [getRow,getCol,getBox],
            n <- [0..size grid - 1],
            u <- unique (f n)]
    where
        unique xs = foldr f [] $ foldr (union.snd) [] unknowns \\ map snd (justKnowns xs)
            where
                unknowns = justUnknowns xs
                f c = case filter ((c`elem`).snd) unknowns of
                    [(p,_)] -> ((p,Known c):)
                    _ -> id
\end{code}

The {\tt analyze} phase tries to turn ``Unknowns'' into ``Knowns'' when a certain ``Unknown'' is the only cell that
contains a value needed in a given row, column, or box. We apply each of the functions {\tt getRow}, {\tt getCol}, and
{\tt getBox} to all the indices on the grid, apply {\tt unique} to each group, and update the array with the
results. {\tt unique}  gets a list of all  the unknown cells in the group and finds all the unknown values in each of
those cells. Each of these values are iterated though looking for a value that is only contained in one cell. If such a
value is found the cell containing it must be that value.

\begin{code}
backtrack :: (MonadPlus m, Eq a) => Sudoku a -> m (Sudoku a)
backtrack (Sudoku grid) = case (justUnknowns (assocs grid)) of
    [] -> return $ Sudoku grid
    ((p,xs):_) -> msum $ map (\x -> solve $ Sudoku $ grid // [(p,Known x)]) xs
\end{code}

Sometimes the above two phases still aren't enough to solve a puzzle. For these rare puzzles backtracking is required.
We attempt to solve the puzzle by replacing the first ``Unknown'' value with each of the candidate values and solving
the resulting puzzles. Hopefully at least one of our choices will result in a solvable puzzle.

We could actually solve any puzzle using backtracking alone, although this would be very inefficient. The above
functions simplify most puzzles enough that the backtracking phase has to do hardly any work.

\begin{code}
solve :: (MonadPlus m, Eq a) => Sudoku a -> m (Sudoku a)
solve sudoku = 
    case eliminate sudoku of
        Just new 
            | any (==Impossible) (elems (unSudoku new))-> mzero
            | otherwise -> solve new
        Nothing -> case analyze sudoku of
            Just new -> solve new
            Nothing -> backtrack sudoku
\end{code}

{\tt solve} glues all the above phases together. First we run the {\tt eliminate} phase. If that found the puzzle  to
be unsolvable we abort immediately. If {\tt eliminate} changed the grid we go though the {\tt eliminate} phase again
hoping to eliminate more. Once {\tt eliminate} can do no more work we move on to the {\tt analyze} phase. If this
succeeds in doing some work we start over again with the {\tt eliminate} phase. Once {\tt analyze} can do no more work
we have no choice but to resort to backtracking. (However in most cases backtracking won't actually do anything because
the puzzle is already solved.)

\begin{code}
showsCell :: Show a => CellState a -> ShowS
showsCell (Known x) = shows x
showsCell (Impossible) = showChar 'X'
showsCell (Unknown xs) = \rest -> ('(':) 
                       $ foldr id (')':rest)
                       $ intersperse (showChar ' ')
                       $ map shows xs
\end{code}

{\tt showCell} shows a cell.

\begin{code}
showsGrid :: Show a => Grid a -> ShowS
showsGrid grid = showsTable [[grid!(r,c) | c <- [0..size grid-1]] | r <- [0..size grid-1]]
\end{code}

{\tt showGrid} show a grid.

\begin{code}
-- FEATURE: This is pretty inefficient
showsTable :: Show a => [[a]] -> ShowS
showsTable xs = (showChar '\n' .) $ showString $ unlines $ map (concat . intersperse " ") xs''
    where
        xs' = (map.map) show xs
        colWidths = map (max 2 . maximum . map length) (transpose xs')
        xs'' = map (zipWith (\n s -> s ++ (replicate (n - length s) ' ')) colWidths) xs'
\end{code}

{\tt showsTable} shows a table (or matrix). Every column has the same width so things line up.

\begin{code}
intSqrt :: Integral a => a -> a
intSqrt n
    | n < 0 = error "intSqrt: negative n"
    | otherwise = f n
    where
        f x = if y < x then f y else x
            where y = (x + (n `quot` x)) `quot` 2
\end{code}

{\tt intSqrt} is Newton`s Iteration for finding integral square roots.

\ignore{
\begin{code}
test :: Sudoku Int
test = makeSudoku [
    [0,6,0,1,0,4,0,5,0],
    [0,0,8,3,0,5,6,0,0],
    [2,0,0,0,0,0,0,0,1],
    [8,0,0,4,0,7,0,0,6],
    [0,0,6,0,0,0,3,0,0],
    [7,0,0,9,0,1,0,0,4],
    [5,0,0,0,0,0,0,0,2],
    [0,0,7,2,0,6,9,0,0],
    [0,4,0,5,0,8,0,7,0]]

test2 :: Sudoku Int
test2 = makeSudoku [
    [0,7,0,0,0,0,8,0,0],
    [0,0,0,2,0,4,0,0,0],
    [0,0,6,0,0,0,0,3,0],
    [0,0,0,5,0,0,0,0,6],
    [9,0,8,0,0,2,0,4,0],
    [0,5,0,0,3,0,9,0,0],
    [0,0,2,0,8,0,0,6,0],
    [0,6,0,9,0,0,7,0,1],
    [4,0,0,0,0,3,0,0,0]]

testSmall :: Sudoku Int
testSmall = makeSudoku [
    [1,0,0,0,0,0,0,0,0],
    [0,0,2,7,4,0,0,0,0],
    [0,0,0,5,0,0,0,0,4],
    [0,3,0,0,0,0,0,0,0],
    [7,5,0,0,0,0,0,0,0],
    [0,0,0,0,0,9,6,0,0],
    [0,4,0,0,0,6,0,0,0],
    [0,0,0,0,0,0,0,7,1],
    [0,0,0,0,0,1,0,3,0]]

testHard :: Sudoku Int
testHard = makeSudoku [
    [0,0,0,8,0,2,0,0,0],
    [5,0,0,0,0,0,0,0,1],
    [0,0,6,0,5,0,3,0,0],
    [0,0,9,0,1,0,8,0,0],
    [1,0,0,0,0,0,0,0,2],
    [0,0,0,9,0,7,0,0,0],
    [0,6,1,0,3,0,7,8,0],
    [0,5,0,0,0,0,0,4,0],
    [0,7,2,0,4,0,1,5,0]]

testHard2 :: Sudoku Int
testHard2 = makeSudoku [
    [3,0,0,2,0,0,9,0,0],
    [0,0,0,0,0,0,0,0,5],
    [0,7,0,1,0,4,0,0,0],
    [0,0,9,0,0,0,8,0,0],
    [5,0,0,0,7,0,0,0,6],
    [0,0,1,0,0,0,2,0,0],
    [0,0,0,3,0,9,0,4,0],
    [8,0,0,0,0,0,0,0,0],
    [0,0,6,0,0,5,0,0,7]]

testHW :: Sudoku Int
testHW = makeSudoku [
    [0,0,0,1,0,0,7,0,2],    
    [0,3,0,9,5,0,0,0,0],
    [0,0,1,0,0,2,0,0,3],
    [5,9,0,0,0,0,3,0,1],
    [0,2,0,0,0,0,0,7,0],
    [7,0,3,0,0,0,0,9,8],
    [8,0,0,2,0,0,1,0,0],
    [0,0,0,0,8,5,0,6,0],
    [6,0,5,0,0,9,0,0,0]]

testTough :: Sudoku Int
testTough = makeSudoku $ map (map read . words) $ lines $
 "8 3 0  0 0 0  0 4 6\n"++
 "0 2 0  1 0 4  0 3 0\n"++
 "0 0 0  0 0 0  0 0 0\n"++
 "0 0 2  9 0 6  5 0 0\n"++
 "1 4 0  0 0 0  0 2 3\n"++
 "0 0 5  4 0 3  1 0 0\n"++
 "0 0 0  0 0 0  0 0 0\n"++
 "0 6 0  3 0 8  0 7 0\n"++
 "9 5 0  0 0 0  0 6 2\n"

testDiabolical :: Sudoku Int 
testDiabolical = makeSudoku $ map (map read . words) $ lines $
  "8 0 0  7 0 1  0 0 2\n"++
  "0 0 6  0 0 0  7 0 0\n"++
  "0 1 7  0 0 0  8 9 0\n"++
  "0 0 0  1 7 3  0 0 0\n"++
  "7 0 0  0 0 0  0 0 6\n"++
  "0 0 0  9 5 6  0 0 0\n"++
  "0 9 5  0 0 0  4 1 0\n"++
  "0 0 8  0 0 0  5 0 0\n"++
  "3 0 0  6 0 5  0 0 7\n"

main :: IO ()
main = do
    let
        solve' p = case solve p of
            [] -> fail $ "couldn't solve: " ++ show p
            sols -> return sols
    mapM_ (\p -> solve' p >>= putStrLn.show) [test,test2,testSmall,testHard,testHard2,testHW,testTough,testDiabolical]
    return ()

\end{code}
}

\end{document}