Adds parallelism

package.yaml

@@ -14,6 +14,9 @@ description:         Please see the README on GitHub at <https://github.com/abhi
 dependencies:
 - base >= 4.7 && < 5
 - containers
+- vector
+- parallel
+- deepseq
 
 executables:
   sudoku:
@@ -21,6 +24,9 @@ executables:
     source-dirs:         src
     ghc-options:
     - -O2
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
     dependencies:
     - split
 

src/Sudoku.hs

@@ -2,14 +2,22 @@ module Main where
 
 import Control.Applicative ((<|>))
 import Data.Function ((&))
+import Data.Vector ((!))
 import qualified Control.Monad
+import qualified Control.Monad.ST
 import qualified Data.Char
 import qualified Data.Function
-import qualified Data.List.Split
 import qualified Data.List
 import qualified Data.Map.Strict as Map
 import qualified Data.Word
 import qualified Data.Bits
+import qualified Data.Vector
+import qualified Data.Vector.Unboxed
+import qualified Data.Vector.Unboxed.Mutable
+import qualified Data.STRef
+import qualified Data.Maybe
+import qualified Control.DeepSeq
+import Control.Parallel.Strategies (withStrategy, rdeepseq, parBuffer)
 
 fixM :: (Eq t, Monad m) => (t -> m t) -> t -> m t
 fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
@@ -21,8 +29,12 @@ data Cell = Fixed Data.Word.Word16
           | Possible Data.Word.Word16
           deriving (Show, Eq)
 
-type Row  = [Cell]
+instance Control.DeepSeq.NFData Cell where
-type Grid = [Row]
+  rnf (Fixed w)    = Control.DeepSeq.rnf w
+  rnf (Possible w) = Control.DeepSeq.rnf w
+
+type Grid = Data.Vector.Vector Cell
+type CellIxs = [Int]
 
 isPossible :: Cell -> Bool
 isPossible (Possible _) = True
@@ -30,7 +42,7 @@ isPossible _            = False
 
 readGrid :: String -> Maybe Grid
 readGrid s
-  | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
+  | length s == 81 = Data.Vector.fromList <$> traverse readCell s
   | otherwise      = Nothing
   where
     allBitsSet = 1022
@@ -40,34 +52,59 @@ readGrid s
       | Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Bits.bit . Data.Char.digitToInt $ c
       | otherwise = Nothing
 
+fromXY :: (Int, Int) -> Int
+fromXY (x, y) = x * 9 + y
+
+allRowIxs, allColIxs, allSubGridIxs :: [CellIxs]
+allRowIxs = [getRow i | i <- [0..8]]
+  where getRow n = [ fromXY (n, i) | i <- [0..8] ]
+
+allColIxs = [getCol i | i <- [0..8]]
+  where getCol n = [ fromXY (i, n) | i <- [0..8] ]
+
+allSubGridIxs = [getSubGrid i | i <- [0..8]]
+  where getSubGrid n = let (r, c) = (n `quot` 3, n `mod` 3)
+                       in [ fromXY (3 * r + i, 3 * c + j) | i <- [0..2], j <- [0..2] ]
+
+replaceCell :: Int -> Cell -> Grid -> Grid
+replaceCell i c g = g Data.Vector.// [(i, c)]
+
 showGrid :: Grid -> String
-showGrid = unlines . map (unwords . map showCell)
+showGrid grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
   where
     showCell (Fixed x) = show . Data.Bits.countTrailingZeros $ x
     showCell _         = "."
 
 showGridWithPossibilities :: Grid -> String
-showGridWithPossibilities = unlines . map (unwords . map showCell)
+showGridWithPossibilities grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
   where
     showCell (Fixed x)     = (show . Data.Bits.countTrailingZeros $ x) ++ "          "
     showCell (Possible xs) =
       "[" ++ map (\i -> if Data.Bits.testBit xs i then Data.Char.intToDigit i else ' ') [1..9] ++ "]"
 
+cellIndicesList :: [Cell] -> [Data.Word.Word16]
+cellIndicesList cells =
+  Data.Vector.Unboxed.toList $ Control.Monad.ST.runST $ do
+    vec <- Data.Vector.Unboxed.Mutable.replicate 9 Data.Bits.zeroBits
+    ref <- Data.STRef.newSTRef (1 :: Int)
+    Control.Monad.forM_ cells $ \cell -> do
+      i <- Data.STRef.readSTRef ref
+      case cell of
+        Fixed _ -> return ()
+        Possible xs -> Control.Monad.forM_ [0..8] $ \d ->
+          Control.Monad.when (Data.Bits.testBit xs (d+1)) $
+            Data.Vector.Unboxed.Mutable.unsafeModify vec (`Data.Bits.setBit` i) d
+      Data.STRef.writeSTRef ref (i+1)
+    Data.Vector.Unboxed.unsafeFreeze vec
+
 exclusivePossibilities :: [Cell] -> [Data.Word.Word16]
 exclusivePossibilities row =
   row
+  & cellIndicesList
   & zip [1..9]
-  & filter (isPossible . snd)
+  & filter (\(_, xs) -> let p = Data.Bits.popCount xs in p > 0 && p < 4)
-  & Data.List.foldl'
+  & Data.List.foldl' (\acc (x, is) -> Map.insertWith prepend is [x] acc) Map.empty
-      (\acc ~(i, Possible xs) ->
+  & Map.filterWithKey (\is xs -> Data.Bits.popCount is == length xs)
-        Data.List.foldl'
-          (\acc' n -> if Data.Bits.testBit xs n then Map.insertWith prepend n [i] acc' else acc')
-          acc
-          [1..9])
-      Map.empty
-  & Map.filter ((< 4) . length)
-  & Map.foldlWithKey'(\acc x is -> Map.insertWith prepend is [x] acc) Map.empty
-  & Map.filterWithKey (\is xs -> length is == length xs)
   & Map.elems
   & map (Data.List.foldl' Data.Bits.setBit Data.Bits.zeroBits)
   where
@@ -79,55 +116,51 @@ makeCell ys
   | Data.Bits.popCount ys == 1 = Just $ Fixed ys
   | otherwise                  = Just $ Possible ys
 
-pruneCellsByFixed :: [Cell] -> Maybe [Cell]
+pruneCells :: Grid -> CellIxs -> Maybe Grid
-pruneCellsByFixed cells = traverse pruneCell cells
+pruneCells grid cellIxs = Control.Monad.foldM pruneCell grid cellIxs
-  where
-    fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- cells]
-
-    pruneCell (Possible xs) = makeCell (xs Data.Bits..&. Data.Bits.complement fixeds)
-    pruneCell x             = Just x
-
-pruneCellsByExclusives :: [Cell] -> Maybe [Cell]
-pruneCellsByExclusives cells = case exclusives of
-  [] -> Just cells
-  _  -> traverse pruneCell cells
   where
+    cells         = map (grid !) cellIxs
     exclusives    = exclusivePossibilities cells
     allExclusives = setBits Data.Bits.zeroBits exclusives
+    fixeds        = setBits Data.Bits.zeroBits [x | Fixed x <- cells]
 
-    pruneCell cell@(Fixed _) = Just cell
+    pruneCell g i =
-    pruneCell cell@(Possible xs)
+      pruneCellByFixed g (i, g ! i) >>= \g' -> pruneCellByExclusives g' (i, g' ! i)
-      | intersection `elem` exclusives = makeCell intersection
+
-      | otherwise                      = Just cell
+    pruneCellByFixed g (_, Fixed _) = Just g
+    pruneCellByFixed g (i, Possible xs)
+      | xs' == xs = Just g
+      | otherwise = flip (replaceCell i) g <$> makeCell xs'
+      where
+        xs' = xs Data.Bits..&. Data.Bits.complement fixeds
+
+    pruneCellByExclusives g (_, Fixed _) = Just g
+    pruneCellByExclusives g (i, Possible xs)
+      | null exclusives                = Just g
+      | intersection == xs             = Just g
+      | intersection `elem` exclusives =
+          flip (replaceCell i) g <$> makeCell intersection
+      | otherwise                      = Just g
       where
         intersection = xs Data.Bits..&. allExclusives
 
-pruneCells :: [Cell] -> Maybe [Cell]
-pruneCells cells = fixM pruneCellsByFixed cells >>= fixM pruneCellsByExclusives
-
-subGridsToRows :: Grid -> Grid
-subGridsToRows =
-  concatMap (\rows -> let [r1, r2, r3] = map (Data.List.Split.chunksOf 3) rows
-                      in zipWith3 (\a b c -> a ++ b ++ c) r1 r2 r3)
-  . Data.List.Split.chunksOf 3
-
 pruneGrid' :: Grid -> Maybe Grid
 pruneGrid' grid =
-  traverse pruneCells grid
+  Control.Monad.foldM pruneCells grid allRowIxs
-  >>= fmap Data.List.transpose . traverse pruneCells . Data.List.transpose
+  >>= flip (Control.Monad.foldM pruneCells) allColIxs
-  >>= fmap subGridsToRows . traverse pruneCells . subGridsToRows
+  >>= flip (Control.Monad.foldM pruneCells) allSubGridIxs
 
 pruneGrid :: Grid -> Maybe Grid
 pruneGrid = fixM pruneGrid'
 
 isGridFilled :: Grid -> Bool
-isGridFilled grid = null [ () | Possible _ <- concat grid ]
+isGridFilled = not . Data.Vector.any isPossible
 
 isGridInvalid :: Grid -> Bool
 isGridInvalid grid =
-  any isInvalidRow grid
+  any isInvalidRow (map (map (grid !)) allRowIxs)
-  || any isInvalidRow (Data.List.transpose grid)
+  || any isInvalidRow (map (map (grid !)) allColIxs)
-  || any isInvalidRow (subGridsToRows grid)
+  || any isInvalidRow (map (map (grid !)) allSubGridIxs)
   where
     isInvalidRow row =
       let fixeds         = [x  | Fixed x <- row]
@@ -145,12 +178,10 @@ nextGrids :: Grid -> (Grid, Grid)
 nextGrids grid =
   let (i, first@(Fixed _), rest) =
         fixCell
-        . Data.List.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
+        . Data.Vector.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
-        . filter (isPossible . snd)
+        . Data.Vector.imapMaybe (\j cell -> if isPossible cell then Just (j, cell) else Nothing)
-        . zip [0..]
-        . concat
         $ grid
-  in (replace2D i first grid, replace2D i rest grid)
+  in (replaceCell i first grid, replaceCell i rest grid)
   where
     possibilityCount (Possible xs) = Data.Bits.popCount xs
     possibilityCount (Fixed _)     = 1
@@ -161,10 +192,6 @@ nextGrids grid =
         Nothing -> error "Impossible case"
         Just cell -> (i, Fixed (Data.Bits.bit x), cell)
 
-    replace2D :: Int -> a -> [[a]] -> [[a]]
-    replace2D i v = let (x, y) = (i `quot` 9, i `mod` 9) in replace x (replace y (const v))
-    replace p f xs = [if i == p then f x else x | (x, i) <- zip xs [0..]]
-
 solve :: Grid -> Maybe Grid
 solve grid = pruneGrid grid >>= solve'
   where
@@ -177,10 +204,14 @@ solve grid = pruneGrid grid >>= solve'
 
 main :: IO ()
 main = do
-  inputs <- lines <$> getContents
+  grids <- lines <$> getContents
-  Control.Monad.forM_ inputs $ \input ->
+  let solutions = parMap readAndSolve grids
-    case readGrid input of
+  putStrLn $
-      Nothing   -> putStrLn "Invalid input"
+    show (length $ filter Data.Maybe.isJust solutions) ++ "/" ++ show (length grids) ++ " solved"
-      Just grid -> case solve grid of
+  where
-        Nothing    -> putStrLn "No solution found"
+    readAndSolve grid = case readGrid grid of
-        Just grid' -> putStrLn $ showGrid grid'
+      Nothing -> Nothing
+      Just b  -> solve b
+
+    chunkSize = 1000
+    parMap f = withStrategy (parBuffer chunkSize rdeepseq) . map f