Haskell Sudoku Solver
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