# Lefants haskell sudoku solver

07 Jan 2010Sometime 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