3
\$\begingroup\$

While trying to understand monad transformers in Haskell I came up with a sudoku solver based on a combination of the ST and Reader monad. I am positively surprised with the performance, however solving particularly difficult sudokus still takes about 3 - 4 seconds on my computer while using the same strategy in Java takes under 1 second. This leads me to thinking I stepped into some kind of performance-related beginner trap I do not know of yet and to submitting this question.

I am aware that some passages might exhibit questionable design decisions but I would ask you to only comment on performance related issues, not exclusively design related issues.

Some additional notes:

  • the program resides in module Main exporting main only
  • candidates are stored per-row, per-column and per-square using set and unset bits in mutable Int arrays
  • strategy: find field with lowest candidate count (fill in single candidates immediately) and try all possible candidates (using a copy of SudokuData to allow backtracking)
  • compiled using ghc -O2 -funfolding-use-threshold=32 -funfolding-creation-threshold=60 -optc-O3 sudoku.hs
  • puzzles used for testing

All instances of $! I used appeared to improve performance. Please tell me if I incorrectly used or missed out using $! at some point.

import Control.Applicative (Alternative, (<|>))
import Control.Monad (liftM, forM, forM_, unless, liftM2)
import Control.Monad.ST (ST, runST)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, withReaderT)
import Data.Array.ST (STUArray, readArray, writeArray, getElems, newArray, newListArray, mapArray)
import Data.Bits (countTrailingZeros, popCount, clearBit, (.&.))
import Data.Char (intToDigit, digitToInt, isDigit)
import Data.List (unwords, unlines)
import System.IO (isEOF)

type Index = Int
type Value = Int
type BitField = Int

type EnvST s a = ReaderT (SudokuData s) (ST s) a
type ExceptST s a = ExceptT SudokuError (ST s) a

type Candidates s = STUArray s Index BitField
type Sudoku s = STUArray s Index Value
data SudokuError = NotADigit Char | InvalidLength

type Selector s = SudokuData s -> Candidates s
data SudokuData s = SudokuData {
    sudoku :: Sudoku s,
    row :: Candidates s,
    column :: Candidates s,
    square :: Candidates s
}

instance Show SudokuError where
    show (NotADigit c) = "Parse error: '" ++ [c] ++ "' is not a digit"
    show InvalidLength = "Parse error: Input has to be 81 characters long"

-- sudoku access
getS :: Index -> EnvST s Int
getS i = ask >>= \d -> lift $ readArray (sudoku d) i
setS :: Index -> Value -> EnvST s ()
setS i v = removeC i v >> ask >>= \d -> lift $ writeArray (sudoku d) i v

-- candidate access
fetchC :: Selector s -> Index -> EnvST s BitField
fetchC sel i = ask >>= \d -> lift $ readArray (sel d) i
modifyC :: Selector s -> Index -> (BitField -> BitField) -> EnvST s ()
modifyC sel i f = ask >>= \d -> lift $ readArray (sel d) i >>= writeArray (sel d) i . f

-- remove candidate for field
removeC :: Index -> Value -> EnvST s ()
removeC i v = modifyC row r elim >> modifyC column c elim >> modifyC square sq elim
    where elim = flip clearBit (v - 1)
          (r, c, sq) = rcsq i
-- fetch candidates for field
getC :: Index -> EnvST s BitField
getC i = ((.).(.)) (.&.) (.&.) <$> fetchC row r <*> fetchC column c <*> fetchC square sq
    where (r, c, sq) = rcsq i
-- first candidate for field
firstC :: Index -> EnvST s BitField
firstC i = firstSet <$> getC i
-- field candidate count
countC :: Index -> EnvST s Int
countC i = popCount <$> getC i

-- "find first set" operation
firstSet :: BitField -> BitField
firstSet x = 1 + countTrailingZeros x
-- row, column, square of specified index
rcsq :: Index -> (Index, Index, Index)
rcsq i = (r, c, div r 3 * 3 + div c 3)
    where (r, c) = divMod i 9
-- lifted alternative operator
(<||>) :: (Monad m, Alternative f) => m (f a) -> m (f a) -> m (f a)
(<||>) = liftM2 (<|>)

-- string representation
stringify :: Sudoku s -> ST s String
stringify s = map intToDigit <$> getElems s

-- allow for possible failure
repr :: Maybe (Sudoku s) -> ST s String
repr = maybe (return "No solution found.") stringify

-- parser
parse :: String -> ExceptST s (SudokuData s)
parse str = do
    unless (length str == 81) (throwE InvalidLength)
    let sudoku = mapM convert str >>= lift . newListArray (0, 80)
    SudokuData <$> sudoku <*> make <*> make <*> make
    where convert c = unless (isDigit c) (throwE (NotADigit c)) >> return (digitToInt c)
          make = lift $ newArray (0, 8) 0x01ff :: ExceptST s (Candidates s)

-- eliminate preset candidates
setup :: EnvST s ()
setup = forM_ [0..80] $ \i -> getS i >>= \v -> unless (v == 0) $ removeC i v

-- solve algorithm: attempt to solve current state
solve :: EnvST s (Maybe (Sudoku s))
solve = findSingle 0 (10, 0)

-- find single candidate fields
findSingle :: Index -> (Int, Index) -> EnvST s (Maybe (Sudoku s))
findSingle 81  (10, _) = Just . sudoku <$> ask
findSingle 81  (_,  i) = getC i >>= tryAll i
findSingle pos opt = do
    value <- getS pos
    count <- countC pos
    case (value, count) of
        (0, 0) -> return Nothing
        (0, 1) -> firstC pos >>= setS pos >> solve
        (0, _) -> findSingle (pos + 1) $! min opt (count, pos)
        _      -> findSingle (pos + 1) opt

-- try all candidates in c on field i
tryAll :: Index -> BitField -> EnvST s (Maybe (Sudoku s))
tryAll _ 0   = return Nothing
tryAll i c = copyEnv >>= \copy ->
    withReaderT (const copy) (setS i (firstSet c) >> solve) <||> recurse
    where recurse = tryAll i $! clearBit c $! firstSet c - 1

-- provide a copy of the environment
copyEnv :: EnvST s (SudokuData s)
copyEnv = ask >>= \(SudokuData sudo row column square) ->
    SudokuData <$> clone sudo <*> clone row <*> clone column <*> clone square
    where clone = lift . mapArray id

main = isEOF >>= \done -> unless done $ getLine >>= \x -> putStrLn x >> putStrLn (process x) >> main
    where process str = either show id $ runST $ runExceptT $ parse str >>= \sudo -> lift $ runReaderT (setup >> solve) sudo >>= repr
\$\endgroup\$
  • 1
    \$\begingroup\$ Don't have time for a complete analysis, but according to a short profiling test, about 23% of the time is spent in getC, and 15% in fetchC, at least according to a short tests. \$\endgroup\$ – Zeta Apr 17 '17 at 18:36

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.