Another Sudoku solver

Sudo.hs

{-# OPTIONS_GHC -Wall #-}

-- http://www.cs.tufts.edu/~nr/cs257/archive/richard-bird/sudoku.pdf

import Data.List (delete)
import Data.List.Split
import Debug.Trace

type Matrix a = [[a]]
type Board = Matrix Char

example :: Board
example = [
    "2....1.38",
    "........5",
    ".7...6...",
    ".......13",
    ".981..257",
    "31....8..",
    "9..8...2.",
    ".5..69784",
    "4..25...."]

-- fully blank.
example2 :: Board
example2 = [
    ".........",
    ".........",
    ".........",
    ".........",
    ".........",
    ".........",
    ".........",
    ".........",    
    "........."]

-- default parameters
boardsize :: Int
boardsize = 9

boxsize :: Int
boxsize   = 3

cellvals :: [Char]
cellvals  = "123456789"

blank :: Char -> Bool
blank     = (=='.')

-- get rows of matrix
rows :: Matrix a -> Matrix a
rows = id

-- get columns of matrix
cols :: Matrix a -> Matrix a
cols []         = []
cols [xs]       = [[x] | x <- xs]
cols (xs:xss)   = zipWith (:) xs (cols xss)

-- get boxs of matrix
boxs :: Matrix a -> Matrix a
boxs = map ungroup . ungroup . map cols . group . map group

-- group a list into component lists of length boxs
group :: [a] -> [[a]]
group = chunksOf boxsize

-- takes a grouped list and ungroup it.
ungroup :: [[a]] -> [a]
ungroup = concat

-- no duplicates in given list
nodups :: Eq a => [a] -> Bool
nodups [] = True
nodups (x:xs) = and [notElem x xs, nodups xs]

-- test whether a filled board is correct
correct :: Board -> Bool
correct b = and [ all nodups (rows b), all nodups (cols b), all nodups (boxs b)]

-- ### Generating choices and matrix cartesian product

type Choices = [Char]

choices :: Board -> Matrix Choices
choices = map (map choose) where choose e = if blank e then cellvals else [e]

-- generate a list of all possible boards from a given matrix of choices.
mcp :: Matrix [a] -> [Matrix a]
mcp = cp . map cp

-- compute the cartesian product of a list of lists.
cp :: [[a]] -> [[a]]
cp []       = [[]]
cp (xs:xss) = [x:ys | x<-xs, ys <- cp xss]

--
sudoku :: Board -> [Board]
sudoku = filter correct . mcp . choices

-- ### Pruning the choices

single :: [a] -> Bool
single [_] = True
single _  = False

fixed :: [Choices] -> Choices
fixed = concat . filter single

-- delete all elements of list a that in list b
delete' :: Eq a => [a] -> [a] -> [a]
delete' ds xs = foldr delete xs ds

reduce :: [Choices] -> [Choices]
reduce css = map (remove (fixed css)) css where
    remove fs cs = if single cs then cs else delete' fs cs

-- prune the matrix of choices
prune :: Matrix Choices -> Matrix Choices
prune = pruneBy boxs . pruneBy cols . pruneBy rows

pruneBy :: (Matrix Choices -> Matrix Choices) -> (Matrix Choices -> Matrix Choices)
pruneBy f = f . map reduce . f

sudoku' :: Board -> [Board]
sudoku' = filter correct . mcp . prune . choices

-- == One choice at a time
{-

A matrix of choices can be blocked in that:

- One or more cells may contain zero choices. In such a case
  mcp will return an empty list;

- The same fixed choice may occur in two or more positions in the same row,
  column or box. In such a case mcp will still compute all the completed boards,
  but the correctness test will throw all of them away.
-}
blocked :: Matrix Choices -> Bool
blocked cm = or [void cm, not (safe cm)]

void :: Matrix Choices -> Bool
void = any (any null)

safe :: Matrix Choices -> Bool
safe cm = and [all (nodups . fixed) (rows cm),
               all (nodups . fixed) (cols cm),
               all (nodups . fixed) (boxs cm)]

{-
A good choice of cell on which to perform expansion is one with the
smallest number of choices (greater than one of course). We will need a function
that breaks up a matrix on the first entry with the smallest number of choices.

A matrix that is not blocked is broken into five pieces:
    cm = rows1 ++ [row1 ++ cs : row2] ++ rows2]
-}
expand :: Matrix Choices -> [Matrix Choices]
expand cm = [rows1 ++ [row1 ++ [c]:row2] ++ rows2 | c <- cs] 
            where (rows1, row:rows2) = break (any best) cm
                  (row1, cs : row2)  = break best row
                  best cx            = (length cx == n)
                  n                  = minchoice cm
                  minchoice          = minimum . filter (>1) . concat . map (map length)

{-
With this definition of expand we have

    mcp = concat . map mcp . expand

Hence:
        filter correct . mcp 
    = filter correct . concat . map mcp . expand
    = concat . map (filter correct . mcp) . expand
    = concat . map (filled correct . mcp . prune) . expand

Writing search = filter correct . mcp we therefore have
    search = concat . map (search . prune) . expand
-}

search :: Matrix Choices -> [Matrix Choices]
search cm
    | blocked cm            = []
    | all (all single) cm   = [cm]
    | otherwise             = (concat . map (search . prune) . expand ) cm

sudoku'' :: Board -> [Board]
sudoku'' = map (map (map head)) . search . prune . choices

-- display the result
shrow :: [Char] -> [Char]
shrow = ('\t' :) . unwords . map (: [])

prt :: [[Char]] -> IO ()
prt = putStr . ('\n' :) . unlines . map shrow

disp :: Int -> Board -> IO ()
disp n = mapM_ prt . take n . sudoku''