Haskell Sudoku solver

Sudoku.hs

import Data.List (intersect, (\\))
import Data.Maybe (catMaybes)

digits = ['1'..'9']
blank  = '0'

complexity = sum . map (length . filter (/= blank))

rows = id

cols [xs]       = [[x] | x <- xs]
cols (xs : xss) = zipWith (:) xs (cols xss)

group [] = []
group xs = take 3 xs : group (drop 3 xs)

boxes = map concat . concatMap cols . group . map group

choices = map (map choice)
    where choice d = if d == blank then digits else [d]

unchoices = map (concatMap unchoice)
    where unchoice x = if length x > 1 then [blank] else x

complete = all (all singleton)
    where singleton [d] = True
          singleton _   = False

safe m = all ok (rows m) && all ok (cols m) && all ok (boxes m)
    where ok row          = nodups [d | [d] <- row]
          nodups []       = True
          nodups (x : xs) = x `notElem` xs && nodups xs

uniqueRow row = map fix row
    where fix x   = let z = uniques `intersect` x
                    in if null z then x else z
          uniques = filter (\x -> length (filter (== x) $ concat row) == 1) digits

combinations 0 _ = [[]]
combinations _ [] = []
combinations n xs@(y:ys)
    | n < 0     = []
    | otherwise =
        case drop (n-1) xs of
          [ ] -> []
          [_] -> [xs]
          _   -> [y:c | c <- combinations (n-1) ys] ++ combinations n ys

pairs [] = []
pairs xs = zipWith (\ c1 c2 -> [c1, c2]) xs (tail xs)

localize pp x = zipWith g uu x
    where uu    = map (\z -> length $ pp `intersect` z) x
          len   = length pp
          ok    = all (\z -> z == 0 || z == len) uu && length (filter (== len) uu) ==  len
          g 0 z = z
          g n z = if ok then pp else z

pruneRow row = uniqueRow $ map (remove fixed) row
    where fixed         = [d | [d] <- row]
          singles       = digits \\ fixed
          remove xs [d] = [d]
          remove xs ds  = filter (`notElem` xs) ds
          g ps x = foldr localize x ps

simplifyRow row = g (pairs singles) row
    where fixed         = [d | [d] <- row]
          singles       = digits \\ fixed
          remove xs [d] = [d]
          remove xs ds  = filter (`notElem` xs) ds
          g ps x = foldr localize x ps

allSameRow digit = map z
    where h x = map (any (elem digit)) (group x)
          z x = if length (filter id hx) == 1
                then Just . length $ takeWhile not hx else Nothing
              where hx = h x

removeDigitInRow digit row box = concat $ left ++ (removeDigit r : right)
    where (left, r:right) = splitAt row (group box)
          removeDigit = map (filter (/= digit))

boxRowConstraint digit boxes = zipWith g known boxes
    where g Nothing z = foldr (removeDigitInRow digit) z (catMaybes known)
          g _       z = z
          known = allSameRow digit boxes

crossConstraint x = foldr f x digits
    where f d y = boxes $ concatMap (boxRowConstraint d) (group $ boxes y)

fixPoint f x
    | fx == x   = x
    | otherwise = fixPoint f fx
    where fx = f x

prune = reduce . simplAll . fixPoint pruneAll
    where pruneBy f = f . map pruneRow . f
          simplBy f = f . map simplifyRow . f
          pruneAll  = pruneBy boxes . pruneBy cols . pruneBy rows
          simplAll  = simplBy boxes . simplBy cols . simplBy rows
          reduce    = cols . crossConstraint . cols . crossConstraint

expand rows = [rows1 ++ [row1 ++ [c] : row2] ++ rows2 | c <- cs]
    where (rows1, row : rows2) = break (any smallest) rows
          (row1, cs : row2)    = break smallest row
          smallest cs          = length cs == n
          n                    = minimum (counts rows)
          counts               = filter (/= 1) . map length . concat

search m
    | not (safe m') = []
    | complete m'   = [unchoices m']
    | otherwise     = concatMap search (expand m')
    where m' = prune m

solve = search . choices

solveNoGuess = unchoices . prune . choices