Split the Sudoku solver module into Board and Solver

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 <abhinav@abhinavsarkar.net>
--}
-
 {-# 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
 
 import qualified Data.Set as S
 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.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

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 <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

rubyquiz.cabal

@@ -16,8 +16,8 @@ source-repository head
 library
   exposed-modules   : AStar, TicTacToe, KnightsTravails, Cryptograms, EnglishNumerals,
                       GedcomParser, PhoneNumberWords, SolataireCipher,
-                      BarrelOfMonkeys, AmazingMazes, SudokuSolver, NumericMaze,
+                      BarrelOfMonkeys, AmazingMazes, Sudoku.Board, Sudoku.Solver,
-                      DiceRoller
+                      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
+  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
 
 executable NumericMaze