Haskell Sudoku Solver

Sudoku.hs

module Sudoku where

import Control.Monad
import Data.List

type Grid = [[Int]]

solveSudoku :: Grid -> [Grid]
solveSudoku = foldr (<=<) return go where
    go :: [Grid -> [Grid]]
    go = do
        r <- [0 .. 8]
        c <- [0 .. 8]
        return $ \grid -> do
            if grid !! r !! c == 0
                then do
                    let rows = [ grid !! r !! j | j <- [0 .. 8] ]
                        cols = [ grid !! i !! c | i <- [0 .. 8] ]
                        boxes = [ grid !! (3 * (r `div` 3) + (k `div` 3)) !! (3 * (c `div` 3) + (k `mod` 3)) | k <- [0 .. 8] ]
                        possiblites = [1 .. 9] \\ (rows ++ cols ++ boxes)
                    upd grid (r, c) <$> possiblites
                else return grid
    upd :: Grid -> (Int, Int) -> Int -> Grid
    upd grid (r, c) x' = [ [ if (i, j) == (r, c) then x' else x | (j, x) <- zip [0 .. 8] xs ] | (i, xs) <- zip [0 .. 8] grid ]

test1 :: Grid
test1 =
    [ [1, 0, 0, 4, 8, 9, 0, 0, 6]
    , [7, 3, 0, 0, 0, 0, 0, 4, 0]
    , [0, 0, 0, 0, 0, 1, 2, 9, 5]
    , [0, 0, 7, 1, 2, 0, 6, 0, 0]
    , [5, 0, 0, 7, 0, 3, 0, 0, 8]
    , [0, 0, 6, 0, 9, 5, 7, 0, 0]
    , [9, 1, 4, 6, 0, 0, 0, 0, 0]
    , [0, 2, 0, 0, 0, 0, 0, 3, 7]
    , [8, 0, 0, 5, 1, 2, 0, 0, 4]
    ]

test2 :: Grid
test2 =
    [ [0, 0, 0, 8, 0, 1, 0, 0, 0]
    , [0, 0, 0, 0, 0, 0, 0, 4, 3]
    , [5, 0, 0, 0, 0, 0, 0, 0, 0]
    , [0, 0, 0, 0, 7, 0, 8, 0, 0]
    , [0, 0, 0, 0, 0, 0, 1, 0, 0]
    , [0, 2, 0, 0, 3, 0, 0, 0, 0]
    , [6, 0, 0, 0, 0, 0, 0, 7, 5]
    , [0, 0, 3, 4, 0, 0, 0, 0, 0]
    , [0, 0, 0, 2, 0, 0, 6, 0, 0]
    ]

main :: IO ()
main = print (solveSudoku test1)

Sudoku2.hs

module Sudoku2 where

import Control.Monad
import Data.List

type Board = [[Int]]

type Kont = (Int, Int) -> Int

szparam :: Int
szparam = 3

n :: Int
n = szparam * szparam

arange :: Int -> Int -> [Int]
arange beg end = [beg, succ beg .. pred end]

newKontFromBoard :: Board -> Kont
newKontFromBoard board = uncurry $ \i -> \j -> board !! i !! j

evalKont :: Kont -> Board
evalKont kont = [ [ kont (y, x) | x <- arange 0 n ] | y <- arange 0 n ]

updKont :: Kont -> (Int, Int) -> Int -> Kont
updKont kont yx z ij = if yx == ij then z else kont ij

solveSudoku :: Board -> [Board]
solveSudoku = map evalKont . foldr (<=<) return (go <$> arange 0 n <*> arange 0 n) . newKontFromBoard where
    go :: Int -> Int -> Kont -> [Kont]
    go y x kont
        | kont (y, x) == 0 = do         
            let rows = [ kont (y, j) | j <- arange 0 n ]
                cols = [ kont (i, x) | i <- arange 0 n ]
                boxs = [ kont (szparam * (y `div` szparam) + (k `div` szparam), szparam * (x `div` szparam) + (k `mod` szparam)) | k <- arange 0 n ]
            updKont kont (y, x) <$> foldl' (\\) [1 .. n] [rows, cols, boxs]          
        | otherwise = return kont

test1 :: Board
test1 =
    [ [1, 0, 0, 4, 8, 9, 0, 0, 6]
    , [7, 3, 0, 0, 0, 0, 0, 4, 0]
    , [0, 0, 0, 0, 0, 1, 2, 9, 5]
    , [0, 0, 7, 1, 2, 0, 6, 0, 0]
    , [5, 0, 0, 7, 0, 3, 0, 0, 8]
    , [0, 0, 6, 0, 9, 5, 7, 0, 0]
    , [9, 1, 4, 6, 0, 0, 0, 0, 0]
    , [0, 2, 0, 0, 0, 0, 0, 3, 7]
    , [8, 0, 0, 5, 1, 2, 0, 0, 4]
    ]

test2 :: Board
test2 =
    [ [0, 0, 0, 8, 0, 1, 0, 0, 0]
    , [0, 0, 0, 0, 0, 0, 0, 4, 3]
    , [5, 0, 0, 0, 0, 0, 0, 0, 0]
    , [0, 0, 0, 0, 7, 0, 8, 0, 0]
    , [0, 0, 0, 0, 0, 0, 1, 0, 0]
    , [0, 2, 0, 0, 3, 0, 0, 0, 0]
    , [6, 0, 0, 0, 0, 0, 0, 7, 5]
    , [0, 0, 3, 4, 0, 0, 0, 0, 0]
    , [0, 0, 0, 2, 0, 0, 6, 0, 0]
    ]

main :: IO ()
main = print (solveSudoku test2) -- GHCi took 15[min] to find the first answer; total-runtime = 36[min].