Simple Sudoku Solver

In this post and the next, I will document my attempts in writing a sudoku solver in haskell. In the current post, I will present a native implementation..

1 Problem statement

Sudoku needs no introduction. A sample is given below.

	C0	C1	C2	C3	C4	C5	C6	C7	C8
r0			5		4		7	3	9
r1		7	6			9	5
r2					7		6	8
r3		8				7	3
r4	6		7		1		2		8
r5			3	2				1
r6		6	9		3
r7			8	1			4	7
r8	2	1	4		6		8

1.1 constraints

The idea is to fill the empty spaces with digits 1 to 9 so that the grid satisfies the following conditions:

1. each row contains exactly one occurence of each of the digits from 1 to 9.
2. each column contains exactly one occurence of each of the digits from 1 to9.
3. each block contains exactly one occurence of each of the digits from 1 to 9, where block is a 3X3 grid. An example block
   is the one at the top left corner containing the following cells – (0,0),(0,1),(0,2),(1,0),(1,1),
   (2,2),(2,0),(2,1),(2,2).
   There are nine such blocks. The ninth block comprising (6,6),(6,7),(6,8),
   (7,6),(7,7),(7,8),(8,6),(8,7) and (8,8).

2 Solution approach

2.1 Cell

The basic unit here is a cell. So let us consider a data-type Cell defined as below:

data Cell =  FilledCell Int
           | EmptyCell [Int]

where, the empty cell represents a list of possible values that cell can hold. Initially, the list of possible values is the list
[1,2,3,4,5,6,7,8,9] and when it becomes a single-celled list, the cell moves into a filledCell.

A two-dimensional array (or a list of lists) is an almost obvious choice as the data structure for representing the whole grid at various stages of the solution.

So, the type for Sudoku can be:

 type Sudoku = Array (Int,Int) Cell

We will be given with an initial Sudoku containing a lots of EmptyCells and a few FilledCells.

2.2 Algorithm

A naive algorithm for solving the Sudoku can be described as:

1. check the type of a cell.
2. if it is a filled cell, move to the next one
3. if the cell is an empty cell with a unary list, convert it into a FilledCell and move to the next one.
4. if the cell has more than one possible values,get the values from all the related cells.
   Narrow the scope of the cell by removing all these values from the list of the cell. And move on to the next cell.
5. repeat the step for all the cells.

3 Implementation

Starting off with a few lines about module and data definitions,

3.1 Data types and modules

module Sudoku where

import Data.Array

data Cell =  FilledCell Int
           | EmptyCell [Int]
           deriving Show

type Sudoku = Array (Int,Int) Cell

3.2 Input

Let’s say that we get the input in the form of a list of lists. An example is given below:

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

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

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

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

I need a function to convert this into a Sudoku.

But before that I need to construct a basic Grid containing all empty cells

getInitSudoku :: Sudoku
getInitSudoku = array ((0,0),(8,8)) ([((i,j),EmptyCell [1..9]) | i <- [0..8], j<-[0..8] ])

Now a function that takes a single dimensional list of Integers (easily obtained from something like puzzle above using a foldr and a ++ ).

fromList :: [Int]->(Int,Int)->Sudoku->Sudoku
fromList [] _ sudoku = sudoku
fromList (x:xs) (row,col) sudoku = let
                                    nextCol = mod (col + 1) 9
                                    nextRow = if (nextCol == 0 ) then row +1 else row
                                  in if x == 0  then fromList xs (nextRow,nextCol) sudoku
                                      else fromList xs (nextRow,nextCol) (sudoku // [((row,col),(FilledCell x))])

Here,I will define a function that takes two lists A and B as input and returns a list containing only those elements of A that are not there in B.
For example, if the input is [1,8,7,6,3] and [9,8,3] then the output should be [1,7,6] (8 and 3 being members in second list too.)
Since the lists that this function will be dealing with will have lengths of about 9 or 10, I will put a blind eye on
the fact that elem is of O(n) and is slow for large values of n. I am defining the function here as an operator.
So, here goes the function:

(#) :: Eq a =>[a] ->[a]->[a]
(#) [] b = []
(#) a [] = a
(#) (ah:atail) b = if ( ah `elem` b) then ((#) atail b)
       else (ah: ((#) atail b))

3.3 Identifying related cells

Now I’ll write a function to identify the related cells. That is given a pair of coordinates, I will get a list of (Int,Int)s containing
the indices of all the relevant cells.
For example, if my input is (0,0) the expected output is
[(0,1),(0,2),(0,3)…(0..8),(1,0),(2,0),(3,0) …(8,0),(0,0),(0,1),(0,2),(1,0),(1,1),
(2,2),(2,0),(2,1),(2,2)]

Let me divide into three simpler steps :

1. A function that takes the row-column pair and gives the list of all indices in the current row.
2. A function that takes the row-column pair and gives the list of all indices in the current row
3. A function that takes the row-column pair and gives the list of all indices in the current block

Functions for the first two are beautiful in a lazy functional language like haskell.

interestedRow :: (Int,Int) -> [(Int,Int)]
interestedRow (row,col) = zip [row,row..row] [0..8]

interestedColumn :: (Int,Int) -> [(Int,Int)]
interestedColumn (row,col) = zip [0..8] [col,col..col]

The third function is a bit agricultural compared to the above two. The idea here is to identify the “block-indices”.
In other words, there are nine blocks in a 3X3 matrix. Their indices are (0,0),(0,1),(0,2) …(2,1),(2,2).
If we know the block indices, the list is straight forward – (3*br,3*bc), (3*br + 1,3*bc) … (3*br +2,3*bc+2)

interestedBlock :: (Int,Int) -> [(Int,Int)]
interestedBlock (row,col) = let
                               br = 3 * (  row `div` 3 )
                               bc = 3 *( col `div` 3 )
                            in [(br,bc),(br,bc+1),(br,bc+2),
                                (br+1,bc),(br+1,bc+1),(br+1,bc+2),
                                (br+2,bc),(br+2,bc+1),(br+2,bc+2)]

With the above three functions in place, the function which gives all the relevant indices is straight forward.
We concatenate the lists from above functions and remove the current index.

relevantIndices = \x -> ( ( (interestedRow x) ++ (interestedColumn x) ++ (interestedBlock x) ) # [x] )

Now it is time to define a function that takes the Sudoku and a list of indices and returns a list of non-zero values at the indices

relatedVals :: Sudoku->[(Int,Int)]->[Int]
relatedVals sudoku []      = []
relatedVals sudoku (x:xs)  = case (sudoku ! x ) of
                                  (FilledCell v) -> ( v : (relatedVals sudoku xs) )
                                  (EmptyCell l)  -> (relatedVals sudoku xs)

4 Reduction

In this section, I’ll define the functions that try to reduce the scope of the empty cells.

4.1 At the cellular level

The first reduction function, simpleReduction operates at the level of a cell.
It takes the Sudoku and an index and returns a new Sudoku such that the cell at the index is updated either with a FilledCell or an emptyCell with reduced scope.

simpleReduction :: Sudoku ->(Int,Int) -> Sudoku
simpleReduction sudoku (row,col) = case (sudoku ! (row,col)) of
                                      FilledCell v       -> sudoku
                                      EmptyCell (solo:[])-> sudoku // [( (row,col),FilledCell solo)]
                                      EmptyCell list     -> sudoku // (getNewList sudoku (row,col) list)

getNewList :: Sudoku -> (Int,Int)-> [Int] -> [((Int,Int),Cell)]
getNewList sudoku (row,col) lst =  let
                                     neededIndices  = relevantIndices (row,col)
                                     otherValues    = relatedVals sudoku neededIndices
                                     newlst         = lst # otherValues
                                   in  case newlst of
                                          (h:[]) -> [((row,col),(FilledCell h))]
                                          (x:xs) -> [((row,col),(EmptyCell (x:xs)))]

4.2 A recursive function on the whole

Now I need a function that applies the function, simpleReduction on all the cells.

reduceSudoku1 sudoku (9,0)    = sudoku
reduceSudoku1 sudoku (row,col)= let
                                       nextCol = mod (col + 1) 9
                                       nextRow = if (nextCol == 0 ) then row + 1 else row
                                in
                                      reduceSudoku1 (simpleReduction sudoku (row,col)) (nextRow,nextCol)

Now a function to check if there are any empty cells still left in the grid.

hasEmptyCells sudoku (9,0)     = False
hasEmptyCells sudoku (row,col) = let
                                       nextCol = mod (col + 1) 9
                                       nextRow = if (nextCol == 0 ) then row + 1 else row
                                 in
                                      case (sudoku ! (row,col) ) of
                                        FilledCell v -> hasEmptyCells sudoku (nextRow,nextCol)
                                        EmptyCell l  -> True

numEmptyCells :: Sudoku ->(Int,Int)->Int->Int
numEmptyCells sudoku (9,0) count    = count
numEmptyCells sudoku (row,col)count = let
                                         nextCol = mod (col + 1) 9
                                         nextRow = if (nextCol == 0 ) then row + 1 else row
                                      in
                                       case (sudoku ! (row,col) ) of
                                          FilledCell v -> numEmptyCells sudoku (nextRow,nextCol) count
                                          EmptyCell l  -> numEmptyCells sudoku (nextRow,nextCol) (count + 1)

That leaves me with a function that applies the reduceSudoku1 function, a few times, say 10 times.
It breaks, if it encounters a completely filled sudoku before.

loop10Max sudoku count
         | (count < 10) &&  (hasEmptyCells sudoku (0,0))  = loop10Max (reduceSudoku1 sudoku (0,0)) (count + 1)
         | otherwise                                      = (sudoku,count)

A better function would be something that would apply reduceSudoku1 till it is useful.
Such a function will continue applying the naive algorithm as long as there is some improvement of applying the algo.The moment it finds no improvement, it breaks.

loopTillDone :: Sudoku -> Sudoku
loopTillDone sudoku = loopTillDoneHelper sudoku (numEmptyCells sudoku (0,0) 0)

loopTillDoneHelper :: Sudoku->Int -> Sudoku
loopTillDoneHelper sudoku count = let
                                     nextRound = reduceSudoku1 sudoku (0,0)
                                     countNext = numEmptyCells nextRound (0,0) 0
                                  in
                                    if (countNext < count) then loopTillDoneHelper nextRound countNext
                                    else nextRound

5 Trying it out

Now I can try the stuff out on some sample Sudokus. I will load the current file (Sudoku.lhs) in ghci and run the functions using:

let list = foldr (++) []  puzzle
let sudoku1 = fromList list (0,0) getInitSudoku
let (s,c) = loop10Max sudoku1 0

Just typing ‘s’ on the command prompt will print out the solved Sudoku. However, all is not well. Trying the problem on harder puzzles
(using ‘evil’ or ‘hard’ in place of ‘puzzle’ in the above), I can see that the naive algorithm I used so far is pretty inadequate for
complicated puzzles. We have been filling only those cells that can be filled because of data in related cells. This does not know how to make a guess and see if it is correct and backtrack if the guess happens to be a wrong one.
In the next chapter, I’ll see how I can rectify this.

PS: This page has been written in literate haskell and has been converted into html using hevea