From 11c234c4aca407cf1479c1105cca59e3984d0a66 Mon Sep 17 00:00:00 2001
From: Abhinav Sarkar <abhinav.sarkar@gmail.com>
Date: Wed, 24 Oct 2012 22:27:50 +0530
Subject: [PATCH] Fixed the bugs.

Made solution check more stringent.
Fixed the out of order display bug in showBoard because of using HashMap.
---
 SudokuSolver.hs | 39 ++++++++++++++++++++++++++++-----------
 1 file changed, 28 insertions(+), 11 deletions(-)

diff --git a/SudokuSolver.hs b/SudokuSolver.hs
index 6c6198a..524c31e 100644
--- a/SudokuSolver.hs
+++ b/SudokuSolver.hs
@@ -30,9 +30,10 @@ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
 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)
+import Data.List (foldl', intersperse, intercalate, find, sortBy)
 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)
@@ -66,6 +67,26 @@ instance Ord Cell where
 firstSol :: Word16 -> Int
 firstSol val = fromJust . find (testBit val) $ [1..9]
 
+cells :: Board -> [Int] -> [Cell]
+cells board = map (fromJust . flip M.lookup (ixMap board))
+
+rowIxs, columnIxs, boxIxs, unitIxs :: [[Int]]
+rowIxs = chunksOf 9 [0..80]
+columnIxs = map (\i -> take 9 [i, i + 9 ..]) [0..8]
+boxIxs = concatMap (\(x:y:z:_) -> zipWith3 (\a b c -> a ++ b ++ c) x y z)
+        . chunksOf 3 . map (chunksOf 3) $ rowIxs
+unitIxs = rowIxs ++ columnIxs ++ boxIxs
+
+-- Checks if a Sudoku board is solved.
+-- A board is solved if all the cells have only one possible value and all rows,
+-- columns and boxes follow the rule of Sudoku.
+isBoardSolved :: Board -> Bool
+isBoardSolved board =
+  (all (\(Cell _ _ vl) -> vl == 1) . M.elems . ixMap $ board)
+  && all (isUnitSolved . cells board) unitIxs
+  where
+    isUnitSolved unit = S.size (S.fromList unit) == 9
+
 -- An empty Sudoku board where all cells have all possible values.
 emptyBoard :: Board
 emptyBoard =
@@ -114,7 +135,6 @@ constrainBoard board cell@(Cell ix _ _) =
     (rowIx, colIx) = ix `divMod` 9
     (rowIx', colIx') = ((rowIx `div` 3) * 3, (colIx `div` 3) * 3)
 
-    cells board = map (fromJust . flip M.lookup (ixMap board))
     row board = cells board $ take 9 [rowIx * 9 ..]
     column board = cells board $ take 9 [colIx, colIx + 9 ..]
     box board =
@@ -138,7 +158,7 @@ showBoard :: Board -> String
 showBoard board =
   zipWith (\(Cell _ val vl) dot ->
               if vl == 1 then intToDigit . firstSol $ val else dot)
-          (M.elems . ixMap $ board)
+          (map snd . sortBy (comparing fst) . M.toList . ixMap $ board)
           (repeat '.')
 
 -- Pretty prints a Sudoku board.
@@ -157,7 +177,7 @@ printBoard board =
 solveSudoku :: Board -> Maybe Board
 solveSudoku board
     -- if solved, return the board
-  | isSolved board          = Just 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
@@ -175,21 +195,18 @@ solveSudoku board
            -- if failed, continue with the current cell with the rest values
            Nothing                       -> solveSudoku boardR
                          -- if solved, return the board
-           Just board' | isSolved board' -> Just board'
+           Just board' | isBoardSolved board' -> Just board'
                          -- else try to recursively solve the board further
-                       | otherwise       -> case solveSudoku board' of
+                       | otherwise            -> case solveSudoku board' of
                            -- if solved, return the board
-                           Just board''  -> Just board''
+                           Just board''       -> Just board''
                            -- else try to solve the board with the current cell
                            -- with the rest values
-                           Nothing       -> solveSudoku boardR
+                           Nothing            -> solveSudoku boardR
   where
     -- Finds the cell which has fewest possible values.
     (Cell ix val vl, cs) = S.deleteFindMin (ambCells board)
 
-    -- A Sudoku is solved if all the cells have only one possible value.
-    isSolved = all (\(Cell _ _ vl) -> vl == 1) . M.elems . ixMap
-
 -- Reads the puzzles from stdin and solves them
 main :: IO ()
 main = do