Haskell Sudoku Solver

Sudoku.hs

import Data.List

--2)

type Row    = [Integer]
type Sudoku = [Row]

data Variant = Basic | Cross | Color deriving (Eq,Show)

isRowValid :: Row -> Bool
isRowValid [] = True
isRowValid (r:rs) = (r == 0 || (notElem r rs)) && isRowValid rs

getSmallField :: Sudoku -> (Int, Int) -> Row
getSmallField sudoku (x, y) = [(sudoku!!(i + (y * 3))!!(j + (x * 3))) | i <- [0 .. 2], j <- [0 .. 2]]

getColorField :: Sudoku -> Int -> Row
getColorField sudoku index = [(sudoku!!j)!!i | i <- [mod index 3, (mod index 3) + 3 .. 8], j <- [div index 3, (div index 3) + 3 .. 8]]

isValid :: Sudoku -> Variant -> Bool
isValid sudoku Basic =
    let 
        transposedSudoku = transpose sudoku
    in 
        and [(isRowValid (sudoku!!i)) && (isRowValid (transposedSudoku!!i)) | i <- [0 .. 8]] &&
        and [(isRowValid (getSmallField sudoku (x, y))) | x <- [0 .. 2], y <- [0 .. 2]]
isValid sudoku Cross =
    (isValid sudoku Basic) &&
	(isRowValid [(sudoku!!i)!!i | i <- [0 .. 8]]) &&
    (isRowValid [(sudoku!!(8 - i))!!i | i <- [0 .. 8]])
isValid sudoku Color =
    (isValid sudoku Basic) &&
	and [(isRowValid (getColorField sudoku i)) | i <- [0 .. 8]]

getEmptyCells :: Row -> (Int, Int) -> [(Int, Int)]
getEmptyCells (0:xs) (x,y) = ((x,y):(getEmptyCells xs ((x + 1), y)))
getEmptyCells (_:xs) (x,y) = getEmptyCells xs ((x + 1), y)
getEmptyCells _ _= []

getEmptyRows :: Sudoku -> Int -> [[(Int, Int)]]
getEmptyRows (x:xs) i = (getEmptyCells x (0, i)) : (getEmptyRows xs (i + 1))
getEmptyRows _ _ = []

getAllEmptyPlaces :: Sudoku -> [(Int, Int)]
getAllEmptyPlaces sudoku = concat (getEmptyRows sudoku 0)

checkSimpleIfValid :: Sudoku -> Variant -> (Int, Int) -> Integer -> Bool
checkSimpleIfValid sudoku variant xy val = 
    checkIfValid sudoku (transpose sudoku) variant xy val

checkIfValid :: Sudoku -> Sudoku -> Variant -> (Int, Int) -> Integer -> Bool
checkIfValid sudoku transposedSudoku Basic (x,y) val =
    (notElem val (sudoku!!y)) &&
    (notElem val (transposedSudoku!!x)) &&
    (notElem val (getSmallField sudoku ((div x 3), (div y 3))))
checkIfValid sudoku transposedSudoku Color (x,y) val = 
    (checkIfValid sudoku transposedSudoku Basic (x,y) val) &&
    (notElem val (getColorField sudoku (((mod x 3) * 3) + (mod y 3))))
checkIfValid sudoku transposedSudoku Cross (x,y) val =
    (checkIfValid sudoku transposedSudoku Basic (x,y) val) &&
    ((x /= y) || (notElem val [(sudoku!!i)!!i | i <- [0 .. 8]])) &&
    (((x + y) /= 8) || (notElem val [(sudoku!!(8 - i))!!i | i <- [0 .. 8]]))

getPossibleValues :: Sudoku -> Sudoku -> Variant -> (Int, Int) -> [Integer]
getPossibleValues sudoku transposedSudoku variant xy = 
    [i | i <- [1 .. 9], (checkIfValid sudoku transposedSudoku variant xy i)]

maskValues :: [(Int,Int,[Integer])] -> [(Int,Int,[Integer])]
maskValues ((x,y,[v]):vals) = ((x,y,[v]):(maskValues [(vx,vy, (if (vs == [v]) then ([0,v]) else vs)) | (vx,vy,vs) <- vals]))
maskValues (v:vs) = (v:(maskValues vs))
maskValues [] = []

getAllPossibleValues :: Sudoku -> Variant -> [(Int, Int)] -> [(Int, Int, [Integer])]
getAllPossibleValues sudoku variant freeCells = 
    let transposedSudoku = transpose sudoku
    in [(x, y, (getPossibleValues sudoku transposedSudoku variant (x,y))) | (x,y) <- freeCells]

updateRow :: Row -> [(Int, Int, [Integer])] -> (Int, Int) -> Row
updateRow (r:rs) ((vx, vy, [v]):values) (x,y)
    | (vx == x && vy == y) = (v:(updateRow rs values ((x+1), y)))
    | (vy > y) = (r:rs)
    | otherwise = (r:(updateRow rs ((vx, vy, [v]):values) ((x+1), y)))
updateRow (r:rs) ((vx, vy, vals):values) (x,y)
    | (vy > y) = (r:rs)
    | otherwise = (r:(updateRow rs values ((x+1), y)))
updateRow row _ _ = row

updateSudoku :: Sudoku -> [(Int, Int, [Integer])] -> Int -> Sudoku
updateSudoku (r:rows) ((vx, vy, vals):values) y
    | (vy < y) = updateSudoku (r:rows) values y
    | (vy == y) = 
        let row = (updateRow r ((vx, vy, vals):values) (0,y)) 
        in (row:(updateSudoku rows values (y+1)))
    | otherwise = (r:(updateSudoku rows ((vx, vy, vals):values) (y+1)))
updateSudoku rows _ _ = rows

simpleSolvePossible :: [(Int, Int, [Integer])] -> Bool
simpleSolvePossible values = or [(length vals) == 1 | (_, _, vals) <- values]

eachPlaceFillable :: [(Int, Int, [Integer])] -> Bool
eachPlaceFillable values = and [vals /= [] | (_,_,vals) <- values]

findHiddenValue :: Sudoku -> Variant -> [(Int, Int, [Integer])] -> [(Int, Int, [Integer])]
findHiddenValue sudoku Basic allValues =
    [(x, y, [v]) | (x, y, vs) <- allValues, v <- vs, 
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, x /= x2 && y == y2]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, x == x2 && y /= y2]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, (x /= x2 || y /= y2) && 
                                        (((div x 3) == (div x2 3)) && ((div y 3) == (div y2 3)))])]
findHiddenValue sudoku Color allValues =
    [(x, y, [v]) | (x, y, vs) <- allValues, v <- vs, 
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, x /= x2 && y == y2]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, x == x2 && y /= y2]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, (x /= x2 || y /= y2) && 
                                        (((div x 3) == (div x2 3)) && ((div y 3) == (div y2 3)))]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, (x /= x2 || y /= y2) &&
                                        (((mod x 3) == (mod x2 3)) && ((mod y 3) == (mod y2 3)))])]
findHiddenValue sudoku Cross allValues =
    [(x, y, [v]) | (x, y, vs) <- allValues, v <- vs, 
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, x /= x2 && y == y2]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, x == x2 && y /= y2]) ||
                    (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, (x /= x2 || y /= y2) && 
                                        (((div x 3) == (div x2 3)) && ((div y 3) == (div y2 3)))]) ||
                    ((x /= y) || 
                        (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, (x /= x2 && x2 == y2)])) ||
                    (((x + y) /= 8) ||
                        (notElem v [v2 | (x2,y2,vs2) <- allValues, v2 <- vs2, (x /= x2 && (x2 + y2) == 8)]))]

startGuessing :: Sudoku -> Variant -> (Int, Int, [Integer]) -> Maybe Sudoku
startGuessing sudoku variant (x,y,(v:vs)) =
    let 
        sudokuNew = updateSudoku sudoku [(x,y,[v])] 0
        sudokuNew2 = trySolve sudokuNew variant (getAllEmptyPlaces sudokuNew)
    in
        case sudokuNew2 of
            Nothing -> startGuessing sudoku variant (x,y,vs)
            _ -> sudokuNew2
startGuessing _ _ _ = Nothing

getGessingPossibleValues :: [(Int, Int, [Integer])] -> (Int, Int, [Integer]) -> (Int, Int, [Integer])
getGessingPossibleValues [] val = val
getGessingPossibleValues ((x,y,v):vals) (_,_,[])
    | ((length v) == 2) = (x,y,v)
    | otherwise = getGessingPossibleValues vals (x,y,v)
getGessingPossibleValues ((x,y,v):vals) (xl, yl, vl)
    | ((length v) == 2) = (x,y,v)
    | ((length v) < (length vl)) = getGessingPossibleValues vals (x,y,v)
    | otherwise = getGessingPossibleValues vals (xl,yl,vl)

trySolve :: Sudoku -> Variant -> [(Int, Int)] -> Maybe Sudoku
trySolve sudoku variant [] 
    | (isValid sudoku variant) = (Just sudoku)
    | otherwise = case getAllEmptyPlaces sudoku of 
                    [] -> (Just sudoku)
                    _ -> Nothing
trySolve sudoku variant emptyPlaces = 
    let possibleVals = getAllPossibleValues sudoku variant emptyPlaces
    in
        if (eachPlaceFillable possibleVals) then (
            if (simpleSolvePossible possibleVals) then (
                let sudokuNew = updateSudoku sudoku possibleVals 0
                in trySolve sudokuNew variant (getAllEmptyPlaces sudokuNew)
            ) else (
                let 
                    vals = findHiddenValue sudoku variant possibleVals
                in
                    case vals of
                        [] -> (
                            let 
                                y = getGessingPossibleValues possibleVals (-1,-1,[])
                                sudokuNew = startGuessing sudoku variant y
                            in
                                case sudokuNew of
                                    Nothing -> Nothing
                                    (Just s) -> (if (isValid s variant) then sudokuNew else Nothing)
                            )
                        _ -> (
                            let sudokuNew = updateSudoku sudoku vals 0
                            in trySolve sudokuNew variant (getAllEmptyPlaces sudokuNew)
                            )
            )
        ) else (Nothing)

solve :: Sudoku -> Variant -> Maybe Sudoku
solve sudoku variant
    | isValid sudoku variant = trySolve sudoku variant (getAllEmptyPlaces sudoku)
    | otherwise = Nothing