diff options
Diffstat (limited to 'tests/examplefiles/Sudoku.lhs')
| -rw-r--r-- | tests/examplefiles/Sudoku.lhs | 382 |
1 files changed, 0 insertions, 382 deletions
diff --git a/tests/examplefiles/Sudoku.lhs b/tests/examplefiles/Sudoku.lhs deleted file mode 100644 index 6829cf6c..00000000 --- a/tests/examplefiles/Sudoku.lhs +++ /dev/null @@ -1,382 +0,0 @@ -% 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} |