This is my first attempt to write a sudoku solver. It's aim is not to be short or efficient - instead I tried to make the logic behind it clear. It does no guessing. It does not branch (ie. if there is no way to figure out for sure where to put a number). Adding branching should be easy - I'll try that once I read more about parallel strategies. It has no validation (it will loop infinitely for an ill-formed problem or one that requires branching). It CAN solve some sudokus :)
Any comments welcome.
Usage: Save source as sudoku.hs, then:
irek-imac:sudoku irek$ ghci
Prelude> :l sudoku
*Main> pretty sampleProblem
. . . 1 . . . 7 3
. . 1 . 8 9 . 5 6
4 . 8 7 . 5 . . .
. . 6 . . . . 3 9
8 . 9 . . . 6 . 4
3 1 . . . . 5 . .
. . . 6 . 4 9 . 5
9 6 . 2 5 . 7 . .
2 5 . . . 7 . . .
*Main> pretty (solved sampleProblem)
6 9 5 1 4 2 8 7 3
0 2 1 3 8 9 4 5 6
4 3 8 7 6 5 1 9 2
5 4 6 8 7 1 0 3 9
8 0 9 5 7 3 6 1 4
3 1 2 4 9 6 5 0 7
1 8 7 6 3 4 9 2 5
9 6 3 2 5 0 7 4 8
2 5 4 0 1 7 3 6 8
-- sudoku.hs
import Data.List (intersperse)
import Char (intToDigit)
main = pretty (solved sampleProblem)
type Board a = [a]
type X = Int
type Y = Int
type Sq = (X, Y)
sampleProblem :: Board Char
sampleProblem = " 1 73 1 89 564 87 5 6 39"
++ "8 9 6 431 5 6 49 596 25 7 25 7 "
-- Transformations
to2d :: Int -> (Y, X)
to2d = flip divMod 9
xCoord :: Int -> X
xCoord = snd . to2d
yCoord :: Int -> Y
yCoord = fst . to2d
sqCoord :: Int -> Sq
sqCoord pos = (sq $ xCoord pos, sq $ yCoord pos)
where sq = flip div 3
-- Definitions
row, column, square :: Int -> Board a -> [a]
row = elementsWithPosition . equalOn yCoord
column = elementsWithPosition . equalOn xCoord
square = elementsWithPosition . equalOn sqCoord
affected = [column, row, square]
-- Axioms
isAllowed :: Char -> Board Char -> Int -> Bool
isAllowed ch problem pos = positionFree && notElem ch occurences
where occurences = concatMap (\f->f pos problem) affected
positionFree = problem!!pos == ' '
allowed :: Char -> Board Char -> Board Bool
allowed ch problem = map (isAllowed ch problem) (indices problem)
isUniquelyNeeded :: Char -> Board Bool -> Int -> Bool
isUniquelyNeeded ch problem pos = isAllowed && (or neededInAffected)
where neededInAffected = map (\f->count (True==) (f pos problem) == 1) affected
isAllowed = problem!!pos==True
uniquelyNeeded :: Char -> Board Char -> Board Bool
uniquelyNeeded ch problem = map (isUniquelyNeeded ch $ allowed ch problem) (indices problem)
isSolved :: Board Char -> Bool
isSolved = notElem ' '
-- Strategy
solved :: Board Char -> Board Char
solved problem | isSolved problem = problem
| otherwise = solved (replace0to9 9 problem)
replace0to9 :: Int -> Board Char -> Board Char
replace0to9 (-1) problem = problem
replace0to9 char problem = replace0to9 (char-1) (replaceChar (intToDigit char) problem)
replaceChar :: Char -> Board Char -> Board Char
replaceChar char problem = map rpl zipped
where zipped = zip (uniquelyNeeded char problem) problem
rpl (False, a) = a
rpl (True, a) = char
-- Helpers
elementsWithPosition :: (Int -> Bool) -> [a] -> [a]
elementsWithPosition predicate list = map (list!!) positions
where positions = filter predicate (indices list)
indices list = [0..((length list)-1)]
equalOn f a b = f a == f b
count p list = length (filter p list)
-- Printing
pretty :: Board Char -> IO ()
pretty problem = mapM_ putStrLn rows
where rows = map (\p->readable (row p problem)) [0,9..9*8]
readable = (intersperse ' ').dotted
dotted row = map rpl row
rpl ' ' = '.'
rpl c = c