Split the Sudoku solver module into Board and Solver
parent
9bd95eb2c4
commit
f218493d6d
@ -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
|
||||
Loading…
Reference in New Issue