Lecture 26: StateT Example: Sudoku
Today, we're going to continue our exploration of monad transformers by considering a different transformer, StateT, and a different base monad, []. Let's first consider StateT.
newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
Note that the transformed monad doesn't wrap the state transformation function (if we wanted to do that, we could just do it directly), but instead wraps its result.
Today's project will be to write a sudoku solver.
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 GameState a = StateT Board [] a
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.
But the main act here is GameState a, a type alias that is equivalent to
StateT { runStateT :: Board -> [(a,Board)] }
A function that returns a list of results can be thought of as a non-deterministic function, i.e., a function that returns multiple results. The nice thing that comes from thinking about this monadically is that we get to deal with one computational branch at a time, and we can rely on the monad to assemble the computations along different branches into a single list.
To introduce non-deterministic choice into a computation, we want to define
branch :: [a] -> GameState a
or, expanding GameState,
branch :: [a] -> StateT Board [] a
We already have a function at this type... lift! And indeed, the definition
branch = lift
does exactly what we want. Ordinarily, we'd simply eliminate branch at this point in favor of lift, in accordance with a general principle of naming parsimony, but in this case, the name adds clarity to our intent, and clarity takes priority over parsimony/concision.
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 pos = do
val <- gets (viable pos) >>= branch
modify $ Map.insert pos val
The computational idea is very simple: given a position on the board, we'll use gets to
extract a list of possible ways to fill in a given position that aren't present in the row, column, or minor block containing pos. We'll then use branch to create a computation path for each of
those possibilities. Within that branch, we'll modify the hidden Board by setting the
current position to be the current possibility.
Note that this code relies very much on the purity of Haskell, as these inserts leave the unaltered original map available for alternative branches.
To calculate the viable ways to fill in a particular square, we'll need to be able to compute the neighbors of a square.
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 :: GameState ()
backtrack = traverse_ extend positions
Yup. We just build a list of GameState () objects each of which tries to extend the board at a single position, and traverse our way through the list of positions, returning (). But the return value doesn't matter! It's the states, the completed boards, that do.
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 can be found in the following file:
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.