Lefants haskell sudoku solver

Sometime in autumn 2009 i created a sudoku solver in haskell as a programming exercise for myself. I am pretty happy with the result, it took no more than an afternoon to implement and has been able to solve everything I tried in a couple of seconds. Now I can happily smile to myself whenever I see someone solving sudokus from the newspaper ;)

Below is a commented and syntax highlighted version of the main module, the complete code in git is also online.

If you are interested in more haskell solutions to the sudoku problem, make sure to check out the Sudoku page on haskellwiki

-- Lefants haskell sudoku solver
-- -----------------------------

{-# OPTIONS -O2 -Wall -Werror -Wwarn #-}

-- This is the main module, containing the actual logic.

module Sudoku (
               solveOne,
              ) where
import Data.List


{-
There are two helpers:

 * sudoku-test runs some (very very basic) tests.
 * sudoku-run is the binary for normal invocation, it will read from
   stdin and output to stdout. use it like this:

$ cat <<EOF | ./sudoku-run
.98......
....7....
....15...
1........
...2....9
...9.6.82
.......3.
5.1......
...4...2.
EOF

798624315
315879246
264315978
129587463
683241759
457936182
942158637
531762894
876493521
-}




{-
The Coord type is a three-dimensional coordinate, the 3rd one is the
box the field is in, like indicated here:

+-----------+
|111|222|333|
|111|222|333|
|111|222|333|
+-----------+
|444|555|666|
|444|555|666|
|444|555|666|
+-----------+
|777|888|999|
|777|888|999|
|777|888|999|
+-----------+
-}

type Coord = (Int, Int, Int)



-- Value holds a solution value or a list of remaining valid
-- candidates for the field.

data Value = Element Int | Options [Int]
           deriving (Show)

-- An actual field consists of a coordinate and a Value (as described
-- above).

type Pair = (Coord, Value)



-- This is the main exported function. It will read in a string of
-- digits or . and feed it to the solve' function which will find a
-- solution using solve and then return a prettified string
-- representation.

solveOne :: String -> String
solveOne ls =
    concatMap pretty $
    sortBy compareC $
    solve' $
    zip triples $
    map readOne ls


-- This will return a list of three-dimensional coordinates as
-- explained with the Coord type above.

triples :: [Coord]
triples = 
    zip3 a b $ map z pairs
    where
      pairs = [(a', b') | b' <- [1..9], a' <- [1..9]]
      (a, b) = unzip pairs

      z :: (Int, Int) -> Int
      z (x, y) =
          x2z + y2z
          where
            x2z = ((x - 1) `div` 3) + 1
            y2z = ((y - 1) `div` 3) * 3


-- Pretty representation of field values

pretty :: (t, Value) -> String
pretty (_, Element e) = show e
pretty (_, Options _) = ""


-- Used for sorting coordinates from left to right and top to bottom.

compareC :: (Ord t2, Ord t3) =>
            ((t2, t3, t4), t) -> ((t2, t3, t5), t1) -> Ordering
compareC (c1, _) (c2, _) =
    compareT c1 c2
    where
      compareT (a1, b1, _) (a2, b2, _)
          | b1 == b2  = compare a1 a2
          | otherwise = compare b1 b2



-- Read in a predefined single value or failing that initialize the
-- list of options.

readOne :: Char -> Value
readOne c =
    case c `elem` (map (head.show) ([1..9] :: [Int])) of
      True -> Element (read [c])
      False -> Options [1..9]



-- solve' and solve contain the actual solving logic. solve' will
-- partition the initial list of fields into ones containing single
-- elements (already defined / solved) and those containing a list of
-- remaining options.

solve' :: [Pair] -> [Pair]
solve' ls =
    solution
    where
      Just solution = solve done todo
      (done, todo) = partition isElement ls
      isElement :: (t, Value) -> Bool
      isElement (_, Element _) = True
      isElement (_, Options _) = False


-- solve takes two lists of coordinate / value pairs as parameters:
-- the first one contains solved single element fields, the second all
-- the lists with remaining options.

solve :: [Pair] -> [Pair] -> Maybe [Pair]
-- if all the fields have one element we are done.
solve es [] = Just es
solve es os =
    case as of
      -- no more Options, no solutions possible
      [] -> Nothing
      -- try first option
      (a : as') ->
          -- recurse using backtracking, if we can solve it
          case solve ((c, Element a) : es) os' of
            -- we are done
            Just es' ->
                Just es'
            -- this branch contains no solutions, retry without it
            Nothing ->
                solve es ((c, Options as') : os')

    where
      -- first prune all Options list at the current level, then order
      -- branches with *few* options first
      ((c, Options as) : os') = sortBy lessOptions $ map revaluate os

      lessOptions (_, Options xs) (_, Options ys) =
          compare (length xs) (length ys)
      lessOptions (_, Element _) _ =
          error "illegal lessOptions call"
      lessOptions (_, Options _) (_, Element _) =
          error "illegal lessOptions call"

      -- filter out other Options from list that are made impossible
      -- by choosing a certain one
      revaluate :: Pair -> Pair
      revaluate (c'@(x, y, z), Options aas) =
          {-# SCC "revaluate" #-}
          (c', Options aas')
          where
            aas' = aas \\ otherValues
            otherValues = map (\(_, Element e) -> e)
                          ((filter (\e -> x == px e) es) ++ 
                           (filter (\e -> y == py e) es) ++
                           (filter (\e -> z == pz e) es))
      revaluate ((_, _, _), Element _) =
          error "illegal revaluate call"


-- helper functions to project a single coordinate from a Pair

px :: Pair -> Int
px ((x, _, _), _) = x
py :: Pair -> Int
py ((_, y, _), _) = y
pz :: Pair -> Int
pz ((_, _, z), _) = z