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

@@ -1,15 +1,21 @@
+{-# LANGUAGE LambdaCase #-}
 module Main where
 
 import Control.Applicative ((<|>))
 import Data.Function ((&))
 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 Data.Vector.Unboxed ((!))
+import qualified Data.Vector.Unboxed.Mutable
+import qualified Data.Vector.Unboxed
+import qualified Data.Maybe
+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'
@@ -17,56 +23,102 @@ fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
 setBits :: Data.Word.Word16 -> [Data.Word.Word16] -> Data.Word.Word16
 setBits = Data.List.foldl' (Data.Bits..|.)
 
-data Cell = Fixed Data.Word.Word16
-          | Possible Data.Word.Word16
-          deriving (Show, Eq)
+type Cell = Data.Word.Word16
+type Grid = Data.Vector.Unboxed.Vector Cell
+type MGrid s = Data.Vector.Unboxed.Mutable.STVector s Cell
+type CellIxs = [Int]
 
-type Row  = [Cell]
-type Grid = [Row]
+isPossible, isFixed :: Cell -> Bool
+isPossible = flip Data.Bits.testBit 15
+isFixed = not . isPossible
 
-isPossible :: Cell -> Bool
-isPossible (Possible _) = True
-isPossible _            = False
+makePossible, makeFixed :: Data.Word.Word16 -> Cell
+makePossible = flip Data.Bits.setBit 15
+makeFixed = flip Data.Bits.clearBit 15
 
 readGrid :: String -> Maybe Grid
 readGrid s
-  | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
+  | length s == 81 = Data.Vector.Unboxed.fromList <$> traverse readCell s
   | otherwise      = Nothing
   where
     allBitsSet = 1022
 
-    readCell '.' = Just $ Possible allBitsSet
+    readCell '.' = Just $ makePossible allBitsSet
     readCell c
-      | Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Bits.bit . Data.Char.digitToInt $ c
+      | Data.Char.isDigit c && c > '0' = Just . Data.Bits.bit . Data.Char.digitToInt $ c
       | otherwise = Nothing
 
+fromXY :: (Int, Int) -> Int
+fromXY (x, y) = x * 9 + y
+
+allRowIxs, allColIxs, allSubGridIxs, allIxs :: [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] ]
+
+allIxs = concat [allRowIxs, allColIxs, allSubGridIxs]
+
+replaceCell :: Int -> Cell -> Grid -> Grid
+replaceCell i c = Data.Vector.Unboxed.modify (\v -> Data.Vector.Unboxed.Mutable.unsafeWrite v 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 _         = "."
+    showCell xs
+      | isPossible xs = "."
+      | otherwise     = show . Data.Bits.countTrailingZeros $ xs
 
 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) =
+    showCell xs
+      | isPossible xs =
       "[" ++ map (\i -> if Data.Bits.testBit xs i then Data.Char.intToDigit i else ' ') [1..9] ++ "]"
+      | otherwise     = (show . Data.Bits.countTrailingZeros $ xs) ++ "          "
+
+-- Exclusive Possibilities Accumulator
+data ExPosAcc = ExPosAcc ![Int] ![Int] ![Int] ![Int] ![Int] ![Int] ![Int] ![Int] ![Int]
+
+exPosAccEmpty :: ExPosAcc
+exPosAccEmpty = ExPosAcc [] [] [] [] [] [] [] [] []
+
+exPosAccInsert :: Int -> Int -> ExPosAcc -> ExPosAcc
+exPosAccInsert 1 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc (i:v1) v2 v3 v4 v5 v6 v7 v8 v9
+exPosAccInsert 2 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 (i:v2) v3 v4 v5 v6 v7 v8 v9
+exPosAccInsert 3 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 (i:v3) v4 v5 v6 v7 v8 v9
+exPosAccInsert 4 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 (i:v4) v5 v6 v7 v8 v9
+exPosAccInsert 5 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 (i:v5) v6 v7 v8 v9
+exPosAccInsert 6 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 (i:v6) v7 v8 v9
+exPosAccInsert 7 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 v6 (i:v7) v8 v9
+exPosAccInsert 8 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 v6 v7 (i:v8) v9
+exPosAccInsert 9 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 (i:v9)
+exPosAccInsert _ _ _                                     = error "Impossible"
+
+exPosAccToList :: ExPosAcc -> [(Int, [Int])]
+exPosAccToList (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) =
+  [(1, v1), (2, v2), (3, v3), (4, v4), (5, v5), (6, v6), (7, v7), (8, v8), (9, v9)]
 
 exclusivePossibilities :: [Cell] -> [Data.Word.Word16]
-exclusivePossibilities row =
-  row
-  & zip [1..9]
+exclusivePossibilities cells =
+  cells
+  & zip ([1..9] :: [Int])
   & filter (isPossible . snd)
   & Data.List.foldl'
-      (\acc ~(i, Possible xs) ->
+      (\acc (i, xs) ->
         Data.List.foldl'
-          (\acc' n -> if Data.Bits.testBit xs n then Map.insertWith prepend n [i] acc' else acc')
+          (\acc' n -> if Data.Bits.testBit xs n then exPosAccInsert 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
+      exPosAccEmpty
+  & exPosAccToList
+  & filter ((< 4) . length . snd)
+  & Data.List.foldl' (\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)
@@ -75,63 +127,91 @@ exclusivePossibilities row =
 
 makeCell :: Data.Word.Word16 -> Maybe Cell
 makeCell ys
-  | ys == Data.Bits.zeroBits   = Nothing
-  | Data.Bits.popCount ys == 1 = Just $ Fixed ys
-  | otherwise                  = Just $ Possible ys
+  | ys == Data.Bits.zeroBits               = Nothing
+  | Data.Bits.popCount (makeFixed ys) == 1 = Just $ makeFixed ys
+  | otherwise                              = Just $ makePossible ys
 
-pruneCellsByFixed :: [Cell] -> Maybe [Cell]
-pruneCellsByFixed cells = traverse pruneCell cells
+pruneCells :: MGrid s -> CellIxs -> Control.Monad.ST.ST s (Maybe Bool)
+pruneCells grid cellIxs = do
+  cells <- traverse (Data.Vector.Unboxed.Mutable.unsafeRead grid) cellIxs
+  pruneCells' grid cells cellIxs
+
+pruneCells' :: MGrid s -> [Cell] -> CellIxs -> Control.Monad.ST.ST s (Maybe Bool)
+pruneCells' grid cells = Control.Monad.foldM pruneCell' (Just False)
   where
-    fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- cells]
+    pruneCell' Nothing _ = return Nothing
+    pruneCell' (Just changed) i = pruneCell i >>= \case
+      Nothing -> return Nothing
+      Just changed' -> return $ Just (changed || changed')
 
-    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
     exclusives    = exclusivePossibilities cells
     allExclusives = setBits Data.Bits.zeroBits exclusives
+    fixeds        = setBits Data.Bits.zeroBits . filter isFixed $ cells
 
-    pruneCell cell@(Fixed _) = Just cell
-    pruneCell cell@(Possible xs)
-      | intersection `elem` exclusives = makeCell intersection
-      | otherwise                      = Just cell
+    pruneCell i = do
+      cell <- Data.Vector.Unboxed.Mutable.unsafeRead grid i
+      pruneCellByFixed (i, cell) >>= \case
+        Nothing -> return Nothing
+        Just changed -> do
+          cell' <- Data.Vector.Unboxed.Mutable.unsafeRead grid i
+          pruneCellByExclusives (i, cell') >>= \case
+            Nothing       -> return Nothing
+            Just changed' -> return $ Just (changed || changed')
+
+    pruneCellByFixed (i, xs)
+      | isFixed xs = return $ Just False
+      | xs' == xs  = return $ Just False
+      | otherwise  = case makeCell xs' of
+          Nothing -> return Nothing
+          Just cell' -> do
+            Data.Vector.Unboxed.Mutable.unsafeWrite grid i cell'
+            return $ Just True
+      where
+        xs' = xs Data.Bits..&. Data.Bits.complement fixeds
+
+    pruneCellByExclusives (i, xs)
+      | isFixed xs                       = return $ Just False
+      | null exclusives                  = return $ Just False
+      | makePossible intersection == xs  = return $ Just False
+      | intersection `elem` exclusives   = case makeCell intersection of
+          Nothing -> return Nothing
+          Just cell' -> do
+            Data.Vector.Unboxed.Mutable.unsafeWrite grid i cell'
+            return $ Just True
+      | otherwise                        = return $ Just False
       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
-  >>= fmap Data.List.transpose . traverse pruneCells . Data.List.transpose
-  >>= fmap subGridsToRows . traverse pruneCells . subGridsToRows
+pruneGrid' :: MGrid s -> Control.Monad.ST.ST s (Maybe Bool)
+pruneGrid' grid = Control.Monad.foldM pruneCells' (Just False) allIxs
+  where
+    pruneCells' Nothing _ = return Nothing
+    pruneCells' (Just changed) ixs = pruneCells grid ixs >>= \case
+      Nothing       -> return Nothing
+      Just changed' -> return $ Just (changed || changed')
 
 pruneGrid :: Grid -> Maybe Grid
-pruneGrid = fixM pruneGrid'
+pruneGrid grid = Control.Monad.ST.runST $ do
+  mGrid <- Data.Vector.Unboxed.unsafeThaw grid
+  fix mGrid
+  where
+    fix mg = pruneGrid' mg >>= \case
+      Nothing -> return Nothing
+      Just True -> fix mg
+      Just False -> Just <$> Data.Vector.Unboxed.unsafeFreeze mg
 
 isGridFilled :: Grid -> Bool
-isGridFilled grid = null [ () | Possible _ <- concat grid ]
+isGridFilled = not . Data.Vector.Unboxed.any isPossible
 
 isGridInvalid :: Grid -> Bool
 isGridInvalid grid =
-  any isInvalidRow grid
-  || any isInvalidRow (Data.List.transpose grid)
-  || any isInvalidRow (subGridsToRows grid)
+  any isInvalidRow (map (map (grid !)) allRowIxs)
+  || any isInvalidRow (map (map (grid !)) allColIxs)
+  || any isInvalidRow (map (map (grid !)) allSubGridIxs)
   where
     isInvalidRow row =
-      let fixeds         = [x  | Fixed x <- row]
-          emptyPossibles = [() | Possible x <- row, x == Data.Bits.zeroBits]
+      let fixeds         = filter isFixed row
+          emptyPossibles = filter (== 32768) . filter isPossible $ row
       in hasDups fixeds || not (null emptyPossibles)
 
     hasDups l = hasDups' l []
@@ -143,27 +223,22 @@ isGridInvalid grid =
 
 nextGrids :: Grid -> (Grid, Grid)
 nextGrids grid =
-  let (i, first@(Fixed _), rest) =
+  let (i, first, rest) =
         fixCell
-        . Data.List.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
-        . filter (isPossible . snd)
-        . zip [0..]
-        . concat
+        . Data.Vector.Unboxed.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
+        . Data.Vector.Unboxed.imapMaybe (\j cell -> if isPossible cell then Just (j, cell) else Nothing)
         $ 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
+    possibilityCount xs
+      | isPossible xs = Data.Bits.popCount xs - 1
+      | otherwise     = 1
 
-    fixCell ~(i, Possible xs) =
+    fixCell (i, xs) =
       let x = Data.Bits.countTrailingZeros xs
       in case makeCell (Data.Bits.clearBit xs x) of
         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..]]
+        Just cell -> (i, Data.Bits.bit x, cell)
 
 solve :: Grid -> Maybe Grid
 solve grid = pruneGrid grid >>= solve'
@@ -177,10 +252,14 @@ solve grid = pruneGrid grid >>= solve'
 
 main :: IO ()
 main = do
-  inputs <- lines <$> getContents
-  Control.Monad.forM_ inputs $ \input ->
-    case readGrid input of
-      Nothing   -> putStrLn "Invalid input"
-      Just grid -> case solve grid of
-        Nothing    -> putStrLn "No solution found"
-        Just grid' -> putStrLn $ showGrid grid'
+  grids <- lines <$> getContents
+  let solutions = parMap readAndSolve grids
+  putStrLn $
+    show (length $ filter Data.Maybe.isJust solutions) ++ "/" ++ show (length grids) ++ " solved"
+  where
+    readAndSolve grid = case readGrid grid of
+      Nothing -> Nothing
+      Just b  -> solve b
+
+    chunkSize = 1000
+    parMap f = withStrategy (parBuffer chunkSize rdeepseq) . map f