Monadic combinators for Sudoku

In this blog, I try to get a few monadic combinators to solve Sudokus and see if they can get any better than what I got earlier.  Again, the focus is very narrow – only to understand monads.

I am too lazy to start afresh. , along with the array module, I will also import the Sudoku module that I defined earlier.
And of course I will have to include the Monad module.

module MonSudoku where

import Data.Array
import Sudoku
import Control.Monad

Now I will define a new data type called State to hold the array and the current position.
But I will define it as a generic record that can hold any pair of data structure and position combination. Ideally, I should also
store the access method (for example the ‘!’ operator in case of an array, and a ‘!!’ in case of list). But I will pass it one for
now. The focus of the blog is very narrow – to be able to implement a non-trivial instance of monad.
Coming back to the data types, I will define a new type called GenericSolver using the newtype construction.
This ‘newtype’ defines a new container for all the functions that take a given state and returns a list of triplets.
We will see later, what the triplet is composed of.
Also, I will define a ‘type’ called “Solver a” that has Sudoku as the data structure and (row,col) as the position.

type Solver a = GenSolver Sudoku (Int,Int) a

newtype GenSolver ds pos a = Solver ( State ds pos -> [(a,pos,ds)] )

data State ds pos = State {
       dataStruct :: ds,
       thePosition :: pos
     }

1 The first monad

Now I will define two functions – solveReturn and SolveBind so as to make GenSolver ds pos an instance of Monad.
The very purpose of this blog (and ,in fact, for this approach for solving Sudokus) is creation of an instance of Monad.

solveReturn  :: a -> GenSolver ds pos a
solveReturn x
    = Solver (\state ->[(x,(thePosition state),(dataStruct state))] )

solveBind :: GenSolver ds pos a -> (a -> GenSolver ds pos b) -> GenSolver ds pos b
solveBind (Solver s) f
   = Solver (\state ->
      concat ( solveBind' (s state) f )
            )

solveBind' :: [(a,pos,ds)] ->(a -> GenSolver ds pos b)->[[(b,pos,ds)]]
solveBind' []   f            = []
solveBind' ((a,pos,ds):xs) f  =  ((f2 (State ds pos)):(solveBind' xs f))
                                where Solver f2 = f a

Now, I can proudly define the GenSolver as an instance of Monad using:

instance Monad (GenSolver ds pos) where
  return x   = solveReturn x
  p >>= f    = solveBind p f

Now that I have my monad, I will be able to use the do notation.

2 Primitive solvers

A few primitive functions first.

2.1 Item solver

Item solver takes a Sudoku and a position and gives a new sudoku such that :

1. if the cell at the position is filled, then returns the same Sudoku with an empty list
2. if the cell is not filled, it provides a list of all the possible values that cell can take

As of now, I am not sure if there can be a solver which is more primitive than this – that which I can use to define this.
But that is beside the point.

item :: Solver [Int]
item = Solver ( \state ->
                     let
                           sudoku = dataStruct state
                           pos    = thePosition state
                      in
                      case ( sudoku ! pos) of
                            FilledCell v -> [([v],pos, sudoku)]
                            EmptyCell (x:xs) -> [((x:xs),pos,sudoku)]
                            EmptyCell []  -> []
               )

2.2 Propogator

I will need a function that can be bound to the item solver. That is, a function of type

 [Int]->Solver ()

To help me out in that I will first write a function that takes an Int first

prop1 :: Int->Solver ()
prop1 x = Solver (\state ->
                            let
                               sudoku = dataStruct state
                               pos    = thePosition state
                               sudoku' = sudoku // [(pos,FilledCell x)]
                            in
                             [((),pos,sudoku')]
                 )

propogate :: [Int] ->Solver()
propogate  []      = Solver (\state -> [])
propogate  [h]     = prop1 h
propogate  (x:xs)  = Solver (\state->
                            let
                              Solver f1 = prop1 x
                              Solver frest = propogate xs
                            in
                              (f1 state)  ++ (frest state)
                            )

There now, I have most things that I need.
Firstly, I have an “item” function that given a Sudoku and an unfilled position, gives me a list of values that position can take.
Secondly, I have a function ‘propogate’ that can take a list of values for a Sudoku-position pair and gives me a list
of Sudokus such that each of them have the same same position updated with one of the values of the list.
Then, one of the sudokus from this list should lead me to the solution.
Thirdly, by virtue of the fact that the “Solver” is an instance of Monad, I should be able to use the “do” notation.

3 New Algorithm

It is now easy to imagine a small enhancement to the naive algorithm for solving sudokus:

1. Apply the naive algorithm on a given Sudoku.
2. Check if the Sudoku is filled. If filled, that is the answer. Stop
3. Find the position of the cell containing only two possible values.
4. If there is no such a position, return an empty list. Either it is a wrong “thread” or I am up against some devilishly evil puzzle
   that I cannot solve.
5. Apply the item function on the Sudoku at the position gives me a list of possible values for that position.
6. Using propogate, we get two sudokus, each of which takes one of the possible values at that position.
7. Take one of these sudokus and go to step 3. If it returns a Sudoku, then it is the answer. Stop.
   If it returns an empty list, then try the next one.
8. If I have no more sudokus to try, raise your hands

3.1 A few more primitives

For the sake of simplicity, let me call the cell that can have only two possible values in an unfilled Sudoku as a “forker”.
I now need a function to get a forker. I will also write a small wrapper over loopTillDone that applies the naive algorithm as
best as possible.

getNextForker :: Sudoku->(Int,Int) -> (Int,Int)
getNextForker _ (9,0) = error "NoSuchCell"
getNextForker 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 -> getNextForker sudoku (nextRow,nextCol)
                                      EmptyCell l  -> if ( (length l) == 2) then (row,col)
                                                      else getNextForker sudoku (nextRow,nextCol)

naiveAlgo :: Sudoku -> (Bool,Sudoku)
naiveAlgo sudoku = let
                    sudoku' = loopTillDone sudoku
                   in
                       ( not (hasEmptyCells sudoku' (0,0)),sudoku')

naSolves :: a -> Solver Bool
naSolves    x         = Solver (\state ->
                                  let
                                     sudoku = dataStruct state
                                     pos    = thePosition state
                                     (yOrN,sudoku') = naiveAlgo sudoku
                                  in
                                   [(yOrN , pos, sudoku')]
                               )

resetPos :: a -> Solver ()
resetPos x = Solver (\state ->
                          let
                            sudoku = dataStruct state
                            pos = getNextForker sudoku (0,0)
                          in
                            [( (),pos,sudoku)]
                    )

The function naSolves and resetPos are Solvers that ignore the input. naSolves checks if any of the Sudoku has already been solved.
resetPos updates the state so that the position is pointing to the next forker.

4 Combinators

I am now all set to write a few combinators.
Let me imaginatively name the combinators as oneRound, twoRounds.threeRounds and fourRounds
As their corny names suggest, they apply the enhanced algorithm once, twice ,thrice and four times respectively.
They are as below:

oneRound  :: Solver Bool
oneRound              = do{
                             x <- item;
                             y <- propogate x;
                             v <- naSolves y;
                             return v
                          }

twoRounds  :: Solver Bool
twoRounds             = do{
                             v <- oneRound;
                             if v then
                                 return v
                             else
                                do
                                  resetPos v;
                                  v' <- oneRound;
                                  return v'
                          }

threeRounds ::Solver ()
threeRounds            = do{
                             v <- oneRound;
                             if v then
                                 return ()
                             else
                                do
                                  resetPos v;
                                  twoRounds;
                                  return ();
                           }

fourRounds :: Solver Bool
fourRounds         = do{
                             v <- twoRounds;
                             if v then
                                 return v
                             else
                                do
                                  resetPos v;
                                  v' <-twoRounds;
                                  return v';
                         }

eightRounds :: Solver Bool
eightRounds         = do{
                             v <- fourRounds;
                             if v then
                                 return v
                             else
                                do
                                  resetPos v;
                                  v' <-fourRounds;
                                  return v';
                         }

5 Testing them out

Now a function that takes the input as a list (list of list of Ints) and runs one of the combinators and returns the Sudoku

5.1 To apply the combinators

scanListForFilled :: [(a,b,Sudoku)]-> Int -> Int
scanListForFilled [] pos = pos
scanListForFilled ((_,_,sudoku):xs) pos = if (hasEmptyCells sudoku (0,0))  then scanListForFilled xs (pos + 1)
                                          else  pos

runThreeRound :: [Int] -> IO()
runThreeRound list = let
                        sudoku1             = fromList list (0,0) getInitSudoku
                        (p,sudNaive)        = naiveAlgo sudoku1
                        Solver solverFun    = threeRounds
                     in
                     if p then
                         do {
                             print sudNaive;
                             return ()
                            }
                     else
                       let
                         x = solverFun (State sudNaive (getNextForker sudNaive (0::Int,0::Int)) )
                         pos = scanListForFilled x (0)
                         (_,_,endSud) = x !! pos
                       in
                         do{
                            print $ showSudoku endSud;
                            print endSud;
                            return ()
                           }

runEightRound :: [Int] -> IO()
runEightRound list = let
                        sudoku1             = fromList list (0,0) getInitSudoku
                        (p,sudNaive)        = naiveAlgo sudoku1
                        Solver solverFun    = eightRounds
                     in
                     if p then
                         do {
                             print sudNaive;
                             return ()
                            }
                     else
                       let
                         x = solverFun (State sudNaive (getNextForker sudNaive (0::Int,0::Int)) )
                         pos = scanListForFilled x (0)
                         (_,_,endSud) = x !! pos
                       in
                         do{
                            print $ showSudoku endSud;
                            print endSud;
                            return ()
                           }

runFourRound :: [Int] -> IO()
runFourRound list = let
                        sudoku1             = fromList list (0,0) getInitSudoku
                        (p,sudNaive)        = naiveAlgo sudoku1
                        Solver solverFun    = fourRounds
                     in
                     if p then
                         do {
                             print sudNaive;
                             return ()
                            }
                     else
                       let
                         x = solverFun (State sudNaive (getNextForker sudNaive (0::Int,0::Int)) )
                         pos = scanListForFilled x (0)
                         (_,_,endSud) = x !! pos
                       in
                         do{
                            print $ showSudoku endSud;
                            print endSud;
                            return ()
                           }

5.2 Testdata

A few sample puzzles from websudoku.com

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

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

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

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

It did manage to give a correct answer for evil1 above and also the evil puzzle that I used in the earlier blog.
However It gave a wrong answer (containing two 4s in a row!) and it thinks it solves the problem. I haven’t investigated it completely.
Am more interested in understanding the monads than solving Sudokus.