Split the Sudoku solver module into Board and Solver
This commit is contained in:
parent
9bd95eb2c4
commit
f218493d6d
@ -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 #-}
|
||||
|
||||
module SudokuSolver (Cell(..), Board, emptyBoard, boardCells, cellValues,
|
||||
isBoardSolved, readBoard, showBoard, prettyShowBoard,
|
||||
solveSudoku, main)
|
||||
module Sudoku.Board (Cell(..), Board(..), emptyBoard, boardCells, cellValues,
|
||||
firstSol, updateBoard, constrainBoard,
|
||||
isBoardSolved, readBoard, showBoard, prettyShowBoard)
|
||||
where
|
||||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
|
||||
import Control.Concurrent.Chan (newChan, writeChan, getChanContents)
|
||||
import Control.Monad (foldM, forM_, forM, (>=>))
|
||||
import Control.Monad (foldM)
|
||||
import Data.Bits (testBit, (.&.), complement, popCount, bit)
|
||||
import Data.Char (digitToInt, intToDigit, isDigit)
|
||||
import Data.List (foldl', intersperse, intercalate, find, sortBy)
|
||||
@ -39,8 +15,6 @@ import Data.List.Split (chunksOf)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Ord (comparing)
|
||||
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 bitset and number of possible cell values.
|
||||
@ -181,77 +155,3 @@ prettyShowBoard board =
|
||||
. chunksOf 9
|
||||
. showBoard $ board
|
||||
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
110
Sudoku/Solver.hs
Normal 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
|
||||
@ -16,8 +16,8 @@ source-repository head
|
||||
library
|
||||
exposed-modules : AStar, TicTacToe, KnightsTravails, Cryptograms, EnglishNumerals,
|
||||
GedcomParser, PhoneNumberWords, SolataireCipher,
|
||||
BarrelOfMonkeys, AmazingMazes, SudokuSolver, NumericMaze,
|
||||
DiceRoller
|
||||
BarrelOfMonkeys, AmazingMazes, Sudoku.Board, Sudoku.Solver,
|
||||
NumericMaze, DiceRoller
|
||||
build-depends : base == 4.*,
|
||||
containers == 0.4.*,
|
||||
mtl == 2.1.*,
|
||||
@ -114,8 +114,8 @@ executable SudokuSolver
|
||||
mtl == 2.1.*,
|
||||
split == 0.2.1.*,
|
||||
unordered-containers == 0.2.1.*
|
||||
main-is : SudokuSolver.hs
|
||||
ghc-options : -threaded -rtsopts -fllvm -main-is SudokuSolver
|
||||
main-is : Sudoku/Solver.hs
|
||||
ghc-options : -threaded -rtsopts -fllvm -main-is Sudoku.Solver
|
||||
default-language : Haskell2010
|
||||
|
||||
executable NumericMaze
|
||||
|
||||
Loading…
Reference in New Issue
Block a user