content: % 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}
  