[99p]SudokuSolver

-- This sudoku solver is based on the fuctional pearls from Richard Bird
-- Available at ttp://www.cs.tufts.edu/~nr/comp150fp/archive/richard-bird/sudoku.pdf

import Data.List
import Data.List.Split

----- predefined consts and inputs
type Matrix a = [[a]]
type Board = Matrix Integer
blktest = [ [1,2,3,4],
            [5,6,7,8],
            [1,3,5,7],
            [2,4,6,8] ]
sudokuq1 = [ [2, 0, 0, 0, 0, 1, 0, 3, 8],
             [0, 0, 0, 0, 0, 0, 0, 0, 5],
             [0, 7, 0, 0, 0, 6, 0, 0, 0],
             [0, 0, 0, 0, 0, 0, 0, 1, 3],
             [0, 9, 8, 1, 0, 0, 2, 5, 7],
             [3, 1, 0, 0, 0, 0, 8, 0, 0],
             [9, 0, 0, 8, 0, 0, 0, 2, 0],
             [0, 5, 0, 0, 6, 9, 7, 8, 4],
             [4, 0, 0, 2, 5, 0, 0, 0, 0] ]
sudokuq2 = [ [0, 1, 0, 4, 2, 0, 0, 0, 5],
             [0, 0, 2, 0, 7, 1, 0, 3, 9],
             [0, 0, 0, 0, 0, 0, 0, 4, 0],
             [2, 0, 7, 1, 0, 0, 0, 0, 6],
             [0, 0, 0, 0, 4, 0, 0, 0, 0],
             [6, 0, 0, 0, 0, 7, 4, 0, 3],
             [0, 7, 0, 0, 0, 0, 0, 0, 0],
             [1, 2, 0, 7, 3, 0, 5, 0, 0],
             [3, 0, 0, 0, 8, 2, 0, 7, 0] ]
sudokuq3 = [ [0, 9, 0, 7, 0, 0, 8, 6, 0],
             [0, 3, 1, 0, 0, 5, 0, 2, 0],
             [8, 0, 6, 0, 0, 0, 0, 0, 0],
             [0, 0, 7, 0, 5, 0, 0, 0, 6],
             [0, 0, 0, 3, 0, 7, 0, 0, 0],
             [5, 0, 0, 0, 1, 0, 7, 0, 0],
             [0, 0, 0, 0, 0, 0, 1, 0, 9],
             [0, 2, 0, 6, 0, 0, 3, 5, 0],
             [0, 5, 4, 0, 0, 8, 0, 7, 0] ]
sudokuq4 = [ [1, 0, 0, 9, 0, 7, 0, 3, 0],
             [0, 8, 0, 0, 0, 0, 0, 7, 0],
             [0, 0, 9, 0, 0, 0, 6, 0, 0],
             [0, 0, 7, 2, 0, 9, 4, 0, 0],
             [4, 1, 0, 0, 0, 0, 0, 9, 5],
             [0, 0, 8, 5, 0, 4, 3, 0, 0],
             [0, 0, 3, 0, 0, 0, 7, 0, 0],
             [0, 5, 0, 0, 0, 0, 0, 4, 0],
             [2, 0, 0, 8, 0, 6, 0, 0, 9] ]
sudokuq5 = [ [0, 9, 8, 0, 0, 0, 0, 0, 0],
             [0, 0, 0, 0, 7, 0, 0, 0, 0],
             [0, 0, 0, 0, 1, 5, 0, 0, 0],
             [1, 0, 0, 0, 0, 0, 0, 0, 0],
             [0, 0, 0, 2, 0, 0, 0, 0, 9],
             [0, 0, 0, 9, 0, 6, 0, 8, 2],
             [0, 0, 0, 0, 0, 0, 0, 3, 0],
             [5, 0, 1, 0, 0, 0, 0, 0, 0],
             [0, 0, 0, 4, 0, 0, 0, 2, 0] ]

----- solution verification
brdtoBlk :: Matrix a -> Matrix a
brdtoBlk [] = []
brdtoBlk brd = map concat $ concat $ map transpose $ splitEvery 3 $ map (splitEvery 3) brd
noDup :: Eq a => [a] -> Bool
noDup [] = True
noDup (x:xs) = (x `notElem` xs) && (noDup xs)
veriSol :: Board -> Bool
veriSol sol = and (map noDup sol) &&
              and (map noDup $ transpose sol) &&
              and (map noDup $ brdtoBlk sol)

----- solution permutation
choices :: Board -> Matrix [Integer]
choices brd = map (map choice) brd
              where choice e = if (e == 0) then [1..9] else [e]
matCart :: Matrix [a] -> [Matrix a]
matCart = cartProd . (map cartProd)
          where cartProd :: [[a]] -> [[a]]
                cartProd [] = [[]]
                cartProd (ls:lss) = [ x:xs | x <- ls, xs <- cartProd lss ]

----- prune solutions
single :: [a] -> Bool
single [_] = True
single _ = False
reduce :: [[Integer]] -> [[Integer]]
reduce chomat = [ if (single chorow) then chorow else (chorow \\ (concat (filter single chomat))) | chorow <- chomat ]
pruSol :: Matrix [Integer] -> Matrix [Integer]
pruSol = pruneBy brdtoBlk . pruneBy transpose . pruneBy id
         where pruneBy f = f . map reduce . f

----- solution properties
compSol :: Matrix [Integer] -> Bool
compSol chomat = and (map (all single) chomat)
voidSol :: Matrix [Integer] -> Bool
voidSol chomat = or (map (any null) chomat)
safeSol :: Matrix [Integer] -> Bool
safeSol chomat = and (map (noDup . concat . filter single)  chomat) &&
                 and (map (noDup . concat . filter single) $ transpose chomat) &&
                 and (map (noDup . concat . filter single) $ brdtoBlk chomat)
ridSol :: Matrix [Integer] -> Bool
ridSol chomat = voidSol chomat || not (safeSol chomat)

----- solver algorithm
expand :: Matrix [Integer] -> [Matrix [Integer]]
expand chomat = [chorows1 ++ [chorow1 ++ [c]:chorow2] ++ chorows2 | c <- cs]
                where
                  (chorows1, chorow:chorows2) = break (any best) chomat
                  (chorow1, cs:chorow2) = break best chorow
                  best cs = (length cs == n)
                  n = minchoice chomat
minchoice = minimum . filter (>1) . concat . map (map length)
search :: Matrix [Integer] -> [Board]
search chomat
       | ridSol chomat     = []
       | compSol chomat    = matCart chomat
       | otherwise         = [ sol | chom <- expand chomat, sol <- search (pruSol chom) ]
sudoku :: Board -> [Board]
sudoku = search . pruSol . choices