Split the Sudoku solver module into Board and Solver

master
Abhinav Sarkar 2012-11-03 17:55:20 +05:30
parent 9bd95eb2c4
commit f218493d6d
3 changed files with 118 additions and 108 deletions

View File

@ -1,37 +1,13 @@
{-
A solution to rubyquiz 43 (http://rubyquiz.com/quiz43.html).
A fast multi-threaded Sudoku solver using recursive depth-first backtracking
for searching and constraint propagation for solving.
Solves the 49191 puzzles at http://school.maths.uwa.edu.au/~gordon/sudoku17
in 32 seconds on a quad core machine with output switched off.
Each puzzle should be formatted as a single line of 81 character, top to bottom,
left to right, with digits 1 to 9 if the cell has a value else a dot (.).
Example:
4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......
Usage:
cat sudoku17 | bin/SudokuSolver +RTS -N4 -H800m -K50m
echo "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......" | bin/SudokuSolver
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net>
-}
{-# LANGUAGE BangPatterns, RecordWildCards #-} {-# LANGUAGE BangPatterns, RecordWildCards #-}
module SudokuSolver (Cell(..), Board, emptyBoard, boardCells, cellValues, module Sudoku.Board (Cell(..), Board(..), emptyBoard, boardCells, cellValues,
isBoardSolved, readBoard, showBoard, prettyShowBoard, firstSol, updateBoard, constrainBoard,
solveSudoku, main) isBoardSolved, readBoard, showBoard, prettyShowBoard)
where where
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Monad (foldM)
import Control.Concurrent.Chan (newChan, writeChan, getChanContents)
import Control.Monad (foldM, forM_, forM, (>=>))
import Data.Bits (testBit, (.&.), complement, popCount, bit) import Data.Bits (testBit, (.&.), complement, popCount, bit)
import Data.Char (digitToInt, intToDigit, isDigit) import Data.Char (digitToInt, intToDigit, isDigit)
import Data.List (foldl', intersperse, intercalate, find, sortBy) import Data.List (foldl', intersperse, intercalate, find, sortBy)
@ -39,8 +15,6 @@ import Data.List.Split (chunksOf)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Word (Word16) import Data.Word (Word16)
import System.CPUTime (getCPUTime)
import Text.Printf (printf)
-- A cell in the Sudoku. The fields are cell index, possible cell values as -- A cell in the Sudoku. The fields are cell index, possible cell values as
-- a bitset and number of possible cell values. -- a bitset and number of possible cell values.
@ -181,77 +155,3 @@ prettyShowBoard board =
. chunksOf 9 . chunksOf 9
. showBoard $ board . showBoard $ board
where line = "+-------+-------+-------+" where line = "+-------+-------+-------+"
-- Solves a Sudoku board using recursive backtracking DFS.
solveSudoku :: Board -> Maybe Board
solveSudoku board
-- if solved, return the board
| isBoardSolved board = Just board
-- if no more unsolved cells left then return Nothing
| S.null (ambCells board) = Nothing
-- if the current cell has no possible values, solve with rest cells
| val == 0 = solveSudoku $ board { ambCells = cs }
| otherwise = let
-- create two cells from current cell, one with only the smallest possible
-- value and second with the rest
fs = bit . firstSol $ val
nextPos = Cell ix fs 1
restPos = Cell ix (val .&. complement fs) (vl - 1)
boardR = updateBoard board restPos
-- try to constrain with the current cell with only one value
in case constrainBoard board nextPos of
-- if failed, continue with the current cell with the rest values
Nothing -> solveSudoku boardR
-- if solved, return the board
Just board' | isBoardSolved board' -> Just board'
-- else try to recursively solve the board further
| otherwise -> case solveSudoku board' of
-- if solved, return the board
Just board'' -> Just board''
-- else try to solve the board with the current cell
-- with the rest values
Nothing -> solveSudoku boardR
where
-- Finds the cell which has fewest possible values.
(Cell ix val vl, cs) = S.deleteFindMin (ambCells board)
-- Reads the puzzles from stdin and solves them
main :: IO ()
main = do
-- read the puzzles in chunks of 100
chunks <- fmap (chunksOf 100 . lines) getContents
solChan <- newChan
done <- newEmptyMVar
-- print the solutions (or errors) and wait for all thread to finish
forkIO $ do
solutions <- getChanContents solChan
printSolutions solutions (length chunks)
putMVar done ()
-- spawn a thread for each chunk
forM_ chunks $ \chunk -> forkIO $ do
-- for each line in the chunk, read it as a Sudoku board and solve it
-- return solution as a string represented by showBoard if solvable else "Unsolvable"
-- return an error if invalid board
forM_ chunk $ \line -> do
start <- getCPUTime
let sudoku = readBoard line
case sudoku of
Nothing -> writeChan solChan $ "Invalid input sudoku: " ++ line
Just board -> do
let !res = solveSudoku board
end <- getCPUTime
let diff = fromIntegral (end - start) / (10 ^ 9) :: Double
let !sol = printf "%s -> %s [%0.3f ms]" line
(maybe "Unsolvable" showBoard res) diff
writeChan solChan sol
writeChan solChan "DONE"
takeMVar done
where
printSolutions _ 0 = return ()
printSolutions ("DONE":xs) l = printSolutions xs (l - 1)
printSolutions (x:xs) l = putStrLn x >> printSolutions xs l

110
Sudoku/Solver.hs Normal file
View File

@ -0,0 +1,110 @@
{-
A solution to rubyquiz 43 (http://rubyquiz.com/quiz43.html).
A fast multi-threaded Sudoku solver using recursive depth-first backtracking
for searching and constraint propagation for solving.
Solves the 49191 puzzles at http://school.maths.uwa.edu.au/~gordon/sudoku17
in 32 seconds on a quad core machine with output switched off.
Each puzzle should be formatted as a single line of 81 character, top to bottom,
left to right, with digits 1 to 9 if the cell has a value else a dot (.).
Example:
4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......
Usage:
cat sudoku17 | bin/SudokuSolver +RTS -N4 -H800m -K50m
echo "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......" | bin/SudokuSolver
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net>
-}
{-# LANGUAGE BangPatterns, RecordWildCards #-}
module Sudoku.Solver (solveSudoku, main) where
import qualified Data.Set as S
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.Chan (newChan, writeChan, getChanContents)
import Control.Monad (forM_, forM)
import Data.Bits ((.&.), complement, bit)
import Data.List.Split (chunksOf)
import System.CPUTime (getCPUTime)
import Text.Printf (printf)
import Sudoku.Board
-- Solves a Sudoku board using recursive backtracking DFS.
solveSudoku :: Board -> Maybe Board
solveSudoku board
-- if solved, return the board
| isBoardSolved board = Just board
-- if no more unsolved cells left then return Nothing
| S.null (ambCells board) = Nothing
-- if the current cell has no possible values, solve with rest cells
| val == 0 = solveSudoku $ board { ambCells = cs }
| otherwise = let
-- create two cells from current cell, one with only the smallest possible
-- value and second with the rest
fs = bit . firstSol $ val
nextPos = Cell ix fs 1
restPos = Cell ix (val .&. complement fs) (vl - 1)
boardR = updateBoard board restPos
-- try to constrain with the current cell with only one value
in case constrainBoard board nextPos of
-- if failed, continue with the current cell with the rest values
Nothing -> solveSudoku boardR
-- if solved, return the board
Just board' | isBoardSolved board' -> Just board'
-- else try to recursively solve the board further
| otherwise -> case solveSudoku board' of
-- if solved, return the board
Just board'' -> Just board''
-- else try to solve the board with the current cell
-- with the rest values
Nothing -> solveSudoku boardR
where
-- Finds the cell which has fewest possible values.
(Cell ix val vl, cs) = S.deleteFindMin (ambCells board)
-- Reads the puzzles from stdin and solves them
main :: IO ()
main = do
-- read the puzzles in chunks of 100
chunks <- fmap (chunksOf 100 . lines) getContents
solChan <- newChan
done <- newEmptyMVar
-- print the solutions (or errors) and wait for all thread to finish
forkIO $ do
solutions <- getChanContents solChan
printSolutions solutions (length chunks)
putMVar done ()
-- spawn a thread for each chunk
forM_ chunks $ \chunk -> forkIO $ do
-- for each line in the chunk, read it as a Sudoku board and solve it
-- return solution as a string represented by showBoard if solvable else "Unsolvable"
-- return an error if invalid board
forM_ chunk $ \line -> do
start <- getCPUTime
let sudoku = readBoard line
case sudoku of
Nothing -> writeChan solChan $ "Invalid input sudoku: " ++ line
Just board -> do
let !res = solveSudoku board
end <- getCPUTime
let diff = fromIntegral (end - start) / (10 ^ 9) :: Double
let !sol = printf "%s -> %s [%0.3f ms]" line
(maybe "Unsolvable" showBoard res) diff
writeChan solChan sol
writeChan solChan "DONE"
takeMVar done
where
printSolutions _ 0 = return ()
printSolutions ("DONE":xs) l = printSolutions xs (l - 1)
printSolutions (x:xs) l = putStrLn x >> printSolutions xs l

View File

@ -16,8 +16,8 @@ source-repository head
library library
exposed-modules : AStar, TicTacToe, KnightsTravails, Cryptograms, EnglishNumerals, exposed-modules : AStar, TicTacToe, KnightsTravails, Cryptograms, EnglishNumerals,
GedcomParser, PhoneNumberWords, SolataireCipher, GedcomParser, PhoneNumberWords, SolataireCipher,
BarrelOfMonkeys, AmazingMazes, SudokuSolver, NumericMaze, BarrelOfMonkeys, AmazingMazes, Sudoku.Board, Sudoku.Solver,
DiceRoller NumericMaze, DiceRoller
build-depends : base == 4.*, build-depends : base == 4.*,
containers == 0.4.*, containers == 0.4.*,
mtl == 2.1.*, mtl == 2.1.*,
@ -114,8 +114,8 @@ executable SudokuSolver
mtl == 2.1.*, mtl == 2.1.*,
split == 0.2.1.*, split == 0.2.1.*,
unordered-containers == 0.2.1.* unordered-containers == 0.2.1.*
main-is : SudokuSolver.hs main-is : Sudoku/Solver.hs
ghc-options : -threaded -rtsopts -fllvm -main-is SudokuSolver ghc-options : -threaded -rtsopts -fllvm -main-is Sudoku.Solver
default-language : Haskell2010 default-language : Haskell2010
executable NumericMaze executable NumericMaze