Lecture 21: NState Example: Sudoku
Control.Monad.NState
Recall the Parser monad, and our sense that it was a mashup of a State String monad and a []. This intuition was ultimately rewarded by our discovery that we could define Parser as StateT String [], understanding parsing objects as non-deterministic state-based functions, realized via the type String -> [(a,String)], and thereby gaining the automatic derivation of instances of the most important Haskell typeclasses for Parser. We can further exploit this observation by generalizing the Parser type by abstracting out its reliance on String:
type NState s = StateT s []
With this, a great deal of functionality comes along for free, including the functions put, get, state, and modify. We add functions nstate
and branch for building building non-deterministic state-based computations, and provide functions runNState, evalNState and execNState for running non-deterministic computations.
We'll provide an nstate function, analogous to state, which allows us to convert a non-deterministic state-based function realized as a function of type s -> [(a,s)] as NState s value, which simply puts the non-deterministic function into a StateT box:
nstate :: (s -> [(a,s)]) -> NState s a
nstate = StateT
The branch function is interesting, both for what it does, and how it's implemented. The idea behind branch is that we'll provide a list, and the computation will non-deterministically select an item from that list:
branch :: [a] -> NState s a
A naïve implementation uses nstate:
branch as = nstate $ \s -> [(a,s) | a <- as]
This works, but there is a more sophisticated, but in the end more natural approach. The type of branch is a function that takes a value of type [a], i.e., the “inner monad” [] applied to a base type a, and “lifts” it a value in the transformed monad StateT s [] a. This is a very common thing to want to do. When possible, which is almost always, monad transformers belong to the MonadTrans type class (defined in Control.Monad.Trans.Class), and so define the corresponding lift function:
class MonadTrans t where
lift :: Monad m => m a -> t m a
With this, we have a simplified implementation of branch:
branch :: [a] -> NState s a
branch = lift
The other functions are just re-namings of the corresponding functions from Control.Monad.State, associating them with our specific type. This code, which I expect to reuse, was then packaged as a cabal project, installed in the usual way, and is available on github.com. Note the use of -- ^ to document something after it appears in the source.
Sudoku
Sudoku is a popular puzzle, based on filling in a 3x3 grid of 3x3 grids, partially filled with the numbers 1, 2,..., 9, e.g.,
| 6 | 9 | 2 | 8 | |||||
| 8 | 5 | 6 | 9 | |||||
| 4 | 2 | |||||||
| 3 | ||||||||
| 9 | 4 | |||||||
| 4 | 6 | 8 | 3 | 1 | ||||
| 1 | 7 | 6 | ||||||
| 7 | 3 | 9 | ||||||
| 7 |
The rules to Sudoku are simple: each digit must appear exactly once in each row, column, and bold-edged 3x3 square. Solving Sudokus is not so simple, and writing a Sudoku solver is a common programming exercise, one that we'll do twice in this course, in very different ways, and to very different ends. The traditional approach involves building a data structure that contains a representation of the board, and then for making recursive calls to a solver function on each empty cell, trying every possible way to fill that cell in. That's the basic approach we're going to take here, but because this is Haskell, the punchline to the code is going to be unexpected and breathtakingly succinct.
We'll first define some basic types around which we'll organize the computation:
import Data.Map (Map,(!))
import qualified Data.Map as Map
type Position = (Int,Int)
type Board = Map Position Int
type Solver = Board -> [Board]
A Position indexes a cell on a Sudoku board, in (row,col) form, with row and column indices in the range [1..9]. A Board represents a Sudoku puzzle. Remember that a Map is a finite partial function, and as such, we can and will represent a blank cell at a position p by not including p as a key in the Map. Finally, a Solver is an algorithm that tries to solve a Sudoku puzzle. Note that it returns a list of results, allowing for the possibility that the particular puzzle we're working on has 0, 1, or a multiplicity of solutions. This type is a good hint that we can approach the problem of solving a Sudoku via non-determinism.
We'll often need the list of valid Position values, and so define:
positions :: [Position]
positions = [(row,col) | row <- [1..9], col <- [1..9]]
Of course, the code transformation fairy never sleeps, and realizes that this can be written in a way that eliminates the local variables row and col within the list comprehension.
positions = liftM2 (,) [1..9] [1..9]
or better still,
positions = (,) <$> [1..9] <*> [1..9]
There are those who think the code transformation fairy needs to get a life. She'd tell you she has one.
The key function in our code is extend, a function that takes a position, and tries to non-deterministically extend its state, a Board, by defining it at that position:
extend :: Position -> NState Board ()
extend pos = do
board <- get
val <- branch $ viable pos board
put $ Map.insert pos val board
The computational idea is very simple: we'll get the board (which is the underlying state), branch on the list of distinct ways we can assign value to the indicated cell without creating a conflict, and save the updated state. Note that if there are no viable assignments, this call fails in the sense that the returned value packs up the empty list of boards.
To calculate the conflicts, we'll first build neighbors :: Map Position [Position], which will map a position on the board to all of the positions that aren't allowed to hold the same value. Looked at this way, a Sudoku problem amounts to extending a partial 9-coloring of a particular graph to a total 9-coloring.
neighbors = Map.fromList [(p,neighborf p) | p <- positions] where
neighborf pos = delete pos . nub . concatMap ($ pos) $ [rowOf,colOf,blockOf]
rowOf (row,col) = map ((,) row) [1..9]
colOf (row,col) = map (flip (,) col) [1..9]
blockOf (row,col) = [(trunc row + rx,trunc col + cx) | rx <- [1..3], cx <- [1..3]]
trunc x = nx - nx `mod` 3 where nx = x-1
The neighbors map memoizes the encapsulated function neighborf, which we do because even though there are only 81 positions on a Sudoku puzzle, we may need to determine the neighbors of various positions thousands of times as we try different alternatives, and the neighborhood calculation is just a bit intricate. Basically, we build the list of cells (including the argument) that are on the same row, column, and block, concatenating the results, using nub to prune duplicates, and delete to remove the argument from the resulting list of neighbors. The nub function is actually a bit problematic from a complexity-theoretic point of view, as it is quadratic in the length of the input list. In this case, it's going to be called on 27 element lists (3x9) 81 times, and this isn't really worth improving, especially as there are ongoing discussions in the Haskell community as to how to do nub better.
Next, we need to implement the viable functions that lists the values that we can assign to a particular cell:
viable :: Position -> Board -> [Int]
viable pos board = candidates \\ conflicts where
candidates = case Map.lookup pos board of
Just x -> [x]
Nothing -> [1..9]
conflicts = mapMaybe (`Map.lookup` board) $ neighbors pos
This is a bit tricky. The candidate values for a cell are going to be [1..9] if the cell is empty (in which case Map.lookup pos board returns Nothing), and x if the cell contains x (in which case Map.lookup pos board returns Just x). And the values that our cell conflicts with is determined by mapping (`Map.lookup` board) across the neighbor list, obtain a list of Maybe Int's, which is then collapsed down via catMaybes. Except that mapMaybe collapses the calls to map and catMaybes down into a single call.
Finally, we're ready for the punchline. Our solver can now be written as:
backtrack :: Solver
backtrack = execNState $ mapM_ extend positions
Yup. We just build a list of NState objects each of which tries to extend the board at a single position, and sequence our way through that list.
There is a little more (actually more than a little more) code involved in parsing and formatting Sudoku boards, and the final version does a few encapsulations, but now if we have a Sudoku problem in a text file like this:
6 . 9 . 2 . . . 8
. 8 . 5 . 6 . . 9
4 . . . . . . 2 .
. . . . . 3 . . .
9 . . . . . . . 4
. . . 4 6 . 8 3 1
. . . . 1 . . 7 6
. . 7 . . . 3 9 .
. . . . 7 . . . .
We can solve it using this program:
$ ./sudoku < sudoku-1.txt
problem:
6 . 9 . 2 . . . 8
. 8 . 5 . 6 . . 9
4 . . . . . . 2 .
. . . . . 3 . . .
9 . . . . . . . 4
. . . 4 6 . 8 3 1
. . . . 1 . . 7 6
. . 7 . . . 3 9 .
. . . . 7 . . . .
solution:
6 3 9 7 2 4 5 1 8
2 8 1 5 3 6 7 4 9
4 7 5 8 9 1 6 2 3
8 1 4 2 5 3 9 6 7
9 6 3 1 8 7 2 5 4
7 5 2 4 6 9 8 3 1
5 9 8 3 1 2 4 7 6
1 2 7 6 4 8 3 9 5
3 4 6 9 7 5 1 8 2
$
The source for this program (modified so as to not require installing Control.Monad.NState), can be found in the following two files:
And here are some files containing Sudoku puzzles in the appropriate format for solution by our sudoku program.
- sudoku-1.txt — 1 solution.
- sudoku-2.txt — 1 solution.
- sudoku-3.txt — no solutions.
- sudoku-4.txt — multiple solutions.
- sudoku-5.txt — 1 solution.