From f218493d6d064fddf3f757bba326550c34762043 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sat, 3 Nov 2012 17:55:20 +0530 Subject: [PATCH] Split the Sudoku solver module into Board and Solver --- SudokuSolver.hs => Sudoku/Board.hs | 108 ++-------------------------- Sudoku/Solver.hs | 110 +++++++++++++++++++++++++++++ rubyquiz.cabal | 8 +-- 3 files changed, 118 insertions(+), 108 deletions(-) rename SudokuSolver.hs => Sudoku/Board.hs (58%) create mode 100644 Sudoku/Solver.hs diff --git a/SudokuSolver.hs b/Sudoku/Board.hs similarity index 58% rename from SudokuSolver.hs rename to Sudoku/Board.hs index 3eb1104..f36ffbf 100644 --- a/SudokuSolver.hs +++ b/Sudoku/Board.hs @@ -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 --} - {-# 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 diff --git a/Sudoku/Solver.hs b/Sudoku/Solver.hs new file mode 100644 index 0000000..37454dd --- /dev/null +++ b/Sudoku/Solver.hs @@ -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 +-} + +{-# 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 diff --git a/rubyquiz.cabal b/rubyquiz.cabal index b6d6c97..4b66037 100644 --- a/rubyquiz.cabal +++ b/rubyquiz.cabal @@ -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