Snowflake fractal

In this article, I will write a haskell program that displays a snowflake haskell. This is given as a problem in one of the best books on Haskell – The Haskell School of Expression, by Proffessor Paul Hudak. One can see a sample snowflake here on the math forum.
I am using a haskell package called gtk2hs ,which contains a special module needed for the code of that book.

module Snowflake where

import Graphics.SOE.Gtk

1 Setting the stage

I will start with a “command” (haskell expressions/functions that yield actions when they are applied) that is given in the book.
This command takes a window as an input and waits for the user to press the space bar. Once it is pressed, it will close the window.
This is used in a very elegant piece of code that displays Sierpinski’s triangle

spaceClose :: Window -> IO ()
spaceClose w
    = do k<- getKey w
         if k == ' ' then closeWindow w
                     else spaceClose w

Now a function that limits the size of the smallest ’star’.An example for how to define global constants in haskell

minSize :: Int
minSize = 8

2 Recursive star

The idea is to draw a Star of David – by overlapping two equilateral triangles such that
their circum-centers coincide. Now, in this Graphics module that I am using, one can draw a polygon by invoking a polygon command with a list of x-y co-ordinates.
But due to some sort of quirkiness with the definition of polygon this module, it is necessary that the last element in the list is the same as the first pair of co-ordinates.
Hence, in order to draw a triangle, I will have to invoke the polygon command using a list containing 4 co-ordinates.
So, I will define my data type as a record containing 2 sets of lists (one for each triangle) and also a size.

data StarOfDavid = SoD {trA :: [(Int,Int)],trB ::[(Int,Int)],szSoD::Int}

That done, I now need a function which takes a pair of x,y co-ordinates and the size (that is the radius of the circum-circle) and give me
This function is based on elementary trignometry and is pretty straight forward.
the StarOfDavid

getVertices :: (Int,Int) ->Int -> StarOfDavid
getVertices (x,y) r = SoD {trA = [(x,y-r), (x - (mulCos30 r), y + r `div` 2),(x + (mulCos30 r), y + r `div` 2 ),(x,y-r)],
                           trB = [(x,y+r),(x - (mulCos30 r), y - r `div` 2),(x + (mulCos30 r), y - r `div` 2),(x,y+r)],
                           szSoD = r}

mulCos30 ::Int -> Int
mulCos30 x = round ( (fromIntegral x) * 0.866 )

Now I need a command that takes a Window and a record corresponding to StarOfDavid, and draw it on the window, if and only if, the size is greater than the minSize defined earlier. Also, since the fractal can be drawn by drawing six stars at one-third the size at each of the six ‘corners’ of the Star and repeating the process till we reach the minimum size.
To implement all that in haskell is simple and elegant as below.

drawStarOfDavid :: Window -> StarOfDavid -> Color -> IO()
drawStarOfDavid w sod c =
 if (szSoD sod) <= minSize then return ()
 else do drawInWindow w (withColor c (polygon (trA sod)))
         drawInWindow w (withColor c (polygon (trB sod)))
         sequence_ (map (\x-> drawStarOfDavid w x c) (nextStarCenters sod))

nextCenters :: StarOfDavid -> [(Int,Int)]
nextCenters dos = (take 3 (trA dos) ) ++ (take 3 (trB dos))

nextStarCenters :: StarOfDavid -> [StarOfDavid]
nextStarCenters dos = map (\x-> getVertices x newsiz ) (nextCenters dos)
                        where newsiz = div (szSoD dos) 3

3 The main method

Finally, the main method, a command that invokes the drawStarOfDavid command.

main
 = runGraphics (
     do w <- openWindow
            "Snowflake Fractal" (400,400)
        drawStarOfDavid w (getVertices (250,250) 150)  Cyan
        spaceClose w
   )

That’s it. Of course the picture that is generated is mono-chromatic and not as colorful as the math-forum one that I linked earlier.
(Also, the site has been generated using latex and hevea).

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.

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

First steps into haskell Type Classes

A Generic Z Algorithm

As mentioned earlier, the biggest problem with the ZAlgo funtion defined in the previous blog is
that it works for only a fixed types of inputs. It takes a String and produces a ByteString (apart from ZAlgoDS). And that is a gross injustice to the algorithm which works for just about any sequences.
The algorithm works for sequences of all types – sequences of integers, characters, even sequences of Strings or any ADT for that matter.
In this chapter, we will make the ZAlgo function handle all types of data.

In this blog, I will make the ZAlgo function, generic enough to handle other types of sequences also.
That is, the new module which I will define now can be used for processing any kinds of sequences.

I’ll continue to use the Data.Array for holding the Z Array(and not consider any generic-ness here), for the sake of simplicity although there are other options available in Standard libraries of the haskell to hold similar structure with perhaps better performance.

module GenZ where


import Data.Array

import Data.ByteString.Char8 as B

The second import(Data.ByteString.Char8 ) is used only for the instance declaration (in the usage section). It is not used in the main algo


type Zs = Array Int Int


data ZAlgoDS = ZAlgoDS{  zeds ::Zs, rSoFar ::Int, lSoFar::Int} deriving Show

Now we need a class for which the functions can be defined. A class in haskell is a collection of related types.

1 Class Declaration

class MyString m  where
           zEqAtIndex  :: (m,Int)->(m,Int)->Bool
           zLength     :: m -> Int

This is the type we will use while defining the functions to create a generic algorithm.

2 Comparison of the sequences

compareStr :: (MyString m)=> (m,Int)->(m,Int)->Int->Int
compareStr (s1,pos1) (s2,pos2) soFar
            |  (pos1 < zLength  s1) || (pos2 < zLength s2) =  let
                                                                      compRes = zEqAtIndex (s1,pos1) (s2,pos2)
                                                                   in
                                                                      if compRes    then
                                                   compareStr (s1,(pos1 + 1)) (s2, (pos2 + 1)) (soFar + 1)
                                                                      else soFar

            |  otherwise                                        = soFar

As can be seen above, we barely made two changes :

1. We used zEqAtIndex to compare the items at respective positions
2. we are using zLength instead of B.length

3 getZAt

Moving on, getZAt method can be modified in similar fashion

getZAt :: (MyString m)=> m -> Int ->Int
getZAt str 0 =  zLength str
getZAt str pos
         |  (pos >0) && (pos < zLength str) = compareStr (str,0) (str,pos) 0
         |  otherwise = error Ïndex out of range"

4 Initializing the z array

There need not be any change in this function.

getInitZArray :: Int -> Zs
getInitZArray lngth = array (0,lngth) ( (0,(lngth+1)) : [(i,0)  -  i <- [1..lngth]])

5 zAlgo and its helper functions

In zAlgo and its helper functions, the only change we need to do is using the zLength instead of the library function

zAlgo str (ZAlgoDSzeds = zds,rSoFar=r,lSoFar = l)  pos
	 -  (pos >= zLength str) = ZAlgoDSzeds = zds, rSoFar =r , lSoFar =l
	 -  (pos >= r ) = zAlgo str (helper1 str pos zds r l) (pos +1)
	 -  otherwise = zAlgo str (helper2 str pos zds r l) (pos + 1)

Both the first of the helper functions

helper1 str pos zs r l = let
			   zpos = getZAt str pos
                           r' = pos + zpos - 1
                         in
                           if (zpos == 0 ) then ZAlgoDSzeds = zs,rSoFar =r,lSoFar =l
	                   else ZAlgoDS zeds = (zs // [(pos,zpos)]), rSoFar = r',lSoFar = pos

helper2 str pos zs r l = let
			   k' = pos - l
                           zk' = zs ! k'
                           beta = r - pos +1
                         in
                           if ( zk' <= beta ) then ZAlgoDSzeds = (zs//[(pos,zk')]),rSoFar =r,lSoFar =l
	                   else
                              let
				q  = compareStr (str,beta) (str,r) 0
                                r' = r + q
                                l' = pos
	                        zpos = r' - l' + 1
                               in ZAlgoDSzeds = (zs //[(pos,zpos)]),rSoFar =r',lSoFar=l'

remain largely unaltered.

That completes generalizing the algorithm, so that it can process any sequence of characters.Now comes the complicated part.

6 Usage

I’llo use the same functions above for two different types of sequences.

I’ll first define a couple of dummy functions to compare at indices – one for Binary Strings and one for Lists-Of-Strings

compAtIndices :: (B.ByteString,Int)->(B.ByteString,Int) -> Bool
compAtIndices (s1,pos1) (s2,pos2) = (B.index s1 pos1) == (B.index s2 pos2)

data LoS = LoS [String] deriving (Show)

compStrAtIndices :: (LoS,Int)->(LoS,Int)->Bool
compStrAtIndices (LoS sList1,pos1) (LoS sList2,pos2) = ((sList1 !! pos1) == (sList2 !! pos2))

getLength :: LoS -> Int
getLength (LoS slist) = Prelude.length slist

Now a couple of instances

instance MyString  B.ByteString  where
      zEqAtIndex    = compAtIndices
      zLength       = B.length

instance MyString  LoS  where
      zEqAtIndex    = compStrAtIndices
      zLength       = getLength

7 Wrapper Function

Now, the wrapper functions. One for ByteString and one for LoS

zMain :: String -> (B.ByteString,ZAlgoDS)
zMain str = let
              byteString  = B.pack str
              zinit       = getInitZArray ((B.length byteString) - 1)
              zDataStruct = ZAlgoDS zeds = zinit,rSoFar = 0,lSoFar = 0
            in
              (byteString,(zAlgo byteString zDataStruct 1))

zMain' :: [String] -> (LoS,ZAlgoDS)
zMain' strList = let
                   zinit       = getInitZArray ((Prelude.length strList) - 1)
                   zDataStruct = ZAlgoDS zeds = zinit,rSoFar = 0,lSoFar = 0
                 in
                     (LoS strList,(zAlgo (LoS strList) zDataStruct 1))

Now, we are done.
we can use zMain to process strings and zMain’ to process lists of strings.

In general, we can thus use the same algorithm to process a linear list/sequence of any data types. The OOPs equivalent of this is , perhaps the strategy design pattern.