Solve sudoku puzzles with functional programming.

sudoku_solver.hs

-- This program finds and prints all solutions to a sudoku puzzle.

-- To run:
-- $ ghc sudoku_solver.hs
-- $ ./sudoku_solver

-- To profile:
-- $ ghc -prof -fprof-auto -rtsopts sudoku_solver.hs
-- $ time ./sudoku_solver +RTS -p

import Data.List
import Data.Maybe (fromJust)
import Data.Containers.ListUtils (nubOrd)

-- A sudoku puzzle is really a matrix, but we represent it as a list (taking
-- values from left to right, then top to bottom). Empty squares have a value of
-- zero. We refer to a square's index in the list as its position.

type Puzzle = [Int]
empty = 0 :: Int

-- The dimension describes the size of the puzzle. A puzzle composed of 3x3
-- regions (each with 3x3 squares) has a dimension of 3. Reduce this value to 2
-- to solve the mini puzzles below.

dimension = 3 :: Int
size = dimension^2
all_possible_values = [1..size]

-- Some puzzles.

mini_incomplete = [
    0, 0,  0, 0,
    3, 4,  1, 2,

    2, 3,  4, 1,
    4, 1,  2, 3
    ] :: Puzzle

mini_invalid = [
    1, 0,  0, 0,
    0, 1,  0, 0,

    0, 0,  0, 0,
    0, 0,  0, 0
    ] :: Puzzle

mini_complete = [
    1, 2,  3, 4,
    3, 4,  1, 2,

    2, 3,  4, 1,
    4, 1,  2, 3
    ] :: Puzzle

gentle = [
    0, 7, 2,  0, 8, 0,  5, 3, 0,
    0, 0, 0,  0, 2, 0,  0, 0, 0,
    0, 0, 4,  1, 9, 7,  8, 0, 0,

    1, 2, 8,  0, 4, 0,  6, 5, 7,
    5, 0, 0,  7, 1, 8,  0, 0, 3,
    0, 0, 0,  0, 0, 0,  0, 0, 0,

    2, 3, 1,  8, 5, 9,  4, 7, 6,
    0, 8, 5,  6, 7, 1,  3, 2, 0,
    6, 9, 7,  2, 3, 4,  1, 8, 5
    ] :: Puzzle

tough = [
    0, 0, 0,  0, 0, 0,  0, 0, 0,
    0, 0, 0,  0, 0, 2,  0, 0, 8,
    5, 3, 0,  0, 0, 0,  0, 9, 0,

    0, 1, 0,  0, 0, 4,  0, 0, 0,
    0, 4, 0,  0, 1, 0,  8, 3, 0,
    0, 0, 0,  5, 0, 0,  0, 0, 0,

    0, 0, 8,  0, 5, 0,  0, 0, 3,
    0, 9, 1,  6, 0, 0,  2, 0, 0,
    0, 0, 4,  0, 9, 8,  0, 6, 0
    ] :: Puzzle

diabolical = [
    0, 5, 8,  0, 0, 0,  0, 0, 0,
    0, 0, 6,  0, 0, 0,  0, 7, 0,
    0, 0, 0,  5, 0, 0,  0, 8, 0,

    6, 0, 0,  0, 0, 0,  0, 3, 5,
    0, 3, 0,  0, 0, 0,  0, 9, 1,
    4, 0, 5,  0, 0, 6,  0, 0, 0,

    0, 0, 1,  0, 0, 4,  0, 0, 0,
    0, 0, 9,  3, 0, 0,  2, 1, 0,
    0, 0, 0,  8, 2, 0,  0, 6, 0
    ] :: Puzzle

-- In sudoku, the rules are that you cannot have two of the same values in any
-- one column, row or region (we collectively refer to these as "groups").
-- Each function below takes a position of a square and return the identifier
-- of the group it belongs to.

column position = mod position size
row position = div position size
region position = (
    div (column position) dimension,
    div (row position) dimension
    )

-- A puzzle is invalid if it contains a duplicate value in any column, row or
-- region. This function returns a list containing values which would be
-- illegal if placed in 'position'.

forbidden_values_at puzzle position = concat [in_row, in_column, in_region]
    where
        the_column = column position
        the_row = row position
        the_region = region position
        squares = zip puzzle [0..]
        in_row = [value | (value, pos) <- squares, row pos == the_row]
        in_column = [value | (value, pos) <- squares, column pos == the_column]
        in_region = [value | (value, pos) <- squares, region pos == the_region]

-- 'stringify' formats a Puzzle as a human-readable string. 'stringify_many'
-- joins several together.

stringify puzzle = foldl append "" squares ++ "\n"
    where
        squares = zip puzzle [0..]
        pipe = " | "
        hr = replicate (size + (length pipe) * (dimension - 1)) '-'
        needs_pipe position = mod (column position) dimension == 0
        needs_hr position = (
            (mod position size == 0) &&
            (mod (row position) dimension == 0)
            )
        needs_newline position = column position == 0
        stringify_square (value, position)
            | (position == 0) = show value
            | needs_hr position = "\n" ++ hr ++ "\n" ++ show value
            | needs_newline position = "\n" ++ show value
            | needs_pipe position = pipe ++ show value
            | otherwise = show value
        append string square = string ++ stringify_square square

stringify_many puzzles = concat [
    "\n",
    intercalate "\n" (map stringify puzzles),
    "\n\n"
    ]

-- 'fill_square' returns a Puzzle like the original, except the square at
-- 'position' now contains 'replacement'.

fill_square [] _ _ = []
fill_square (value:squares) position replacement
    | position == 0 = replacement:squares
    | otherwise = value:fill_square squares (position - 1) replacement

-- 'solve' finds every possible solution for a given puzzle.

solve puzzle

-- Find the next empty square — if one exists, fill it with each allowed value
-- and recursively try to solve the resulting puzzles. A list of valid solutions
-- will be returned.

    | (next_empty /= Nothing) = concat (
        map solve (map make_guess allowed_values)
        )

-- If there are no more empty squares, the puzzle is solved.

    | otherwise = [puzzle]
    where
        next_empty = elemIndex empty puzzle
        make_guess value = fill_square puzzle (fromJust next_empty) value
        forbidden_values = (forbidden_values_at puzzle (fromJust next_empty))
        allowed_values = all_possible_values \\ forbidden_values

-- Write solutions for the puzzle to stdout. 

main = putStr (stringify_many (solve diabolical))