Uses custom accumulator in exclusivePossibilities for speedup

package.yaml

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

src/Sudoku.hs

@@ -2,22 +2,14 @@ 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'
@@ -29,12 +21,8 @@ data Cell = Fixed Data.Word.Word16
           | Possible Data.Word.Word16
           deriving (Show, Eq)
 
-instance Control.DeepSeq.NFData Cell where
-  rnf (Fixed w)    = Control.DeepSeq.rnf w
-  rnf (Possible w) = Control.DeepSeq.rnf w
-
-type Grid = Data.Vector.Vector Cell
-type CellIxs = [Int]
+type Row  = [Cell]
+type Grid = [Row]
 
 isPossible :: Cell -> Bool
 isPossible (Possible _) = True
@@ -42,7 +30,7 @@ isPossible _            = False
 
 readGrid :: String -> Maybe Grid
 readGrid s
-  | length s == 81 = Data.Vector.fromList <$> traverse readCell s
+  | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
   | otherwise      = Nothing
   where
     allBitsSet = 1022
@@ -52,59 +40,57 @@ 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 grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
+showGrid = unlines . map (unwords . map showCell)
   where
     showCell (Fixed x) = show . Data.Bits.countTrailingZeros $ x
     showCell _         = "."
 
 showGridWithPossibilities :: Grid -> String
-showGridWithPossibilities grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
+showGridWithPossibilities = unlines . map (unwords . map showCell)
   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
+-- 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
-  & cellIndicesList
-  & zip [1..9]
-  & filter (\(_, xs) -> let p = Data.Bits.popCount xs in p > 0 && p < 4)
+  & zip ([1..9] :: [Int])
+  & filter (isPossible . snd)
+  & Data.List.foldl'
+      (\acc ~(i, Possible xs) ->
+        Data.List.foldl'
+          (\acc' n -> if Data.Bits.testBit xs n then exPosAccInsert n i acc' else acc')
+          acc
+          [1..9])
+      exPosAccEmpty
+  & exPosAccToList
+  & filter ((< 4) . length . snd)
   & Data.List.foldl' (\acc (x, is) -> Map.insertWith prepend is [x] acc) Map.empty
-  & Map.filterWithKey (\is xs -> Data.Bits.popCount is == length xs)
+  & Map.filterWithKey (\is xs -> length is == length xs)
   & Map.elems
   & map (Data.List.foldl' Data.Bits.setBit Data.Bits.zeroBits)
   where
@@ -116,51 +102,55 @@ makeCell ys
   | Data.Bits.popCount ys == 1 = Just $ Fixed ys
   | otherwise                  = Just $ Possible ys
 
-pruneCells :: Grid -> CellIxs -> Maybe Grid
-pruneCells grid cellIxs = Control.Monad.foldM pruneCell grid cellIxs
+pruneCellsByFixed :: [Cell] -> Maybe [Cell]
+pruneCellsByFixed cells = traverse pruneCell cells
+  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 g i =
-      pruneCellByFixed g (i, g ! i) >>= \g' -> pruneCellByExclusives g' (i, g' ! i)
-
-    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
+    pruneCell cell@(Fixed _) = Just cell
+    pruneCell cell@(Possible xs)
+      | intersection `elem` exclusives = makeCell intersection
+      | otherwise                      = Just cell
       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 =
-  Control.Monad.foldM pruneCells grid allRowIxs
-  >>= flip (Control.Monad.foldM pruneCells) allColIxs
-  >>= flip (Control.Monad.foldM pruneCells) allSubGridIxs
+  traverse pruneCells grid
+  >>= fmap Data.List.transpose . traverse pruneCells . Data.List.transpose
+  >>= fmap subGridsToRows . traverse pruneCells . subGridsToRows
 
 pruneGrid :: Grid -> Maybe Grid
 pruneGrid = fixM pruneGrid'
 
 isGridFilled :: Grid -> Bool
-isGridFilled = not . Data.Vector.any isPossible
+isGridFilled grid = null [ () | Possible _ <- concat grid ]
 
 isGridInvalid :: Grid -> Bool
 isGridInvalid grid =
-  any isInvalidRow (map (map (grid !)) allRowIxs)
-  || any isInvalidRow (map (map (grid !)) allColIxs)
-  || any isInvalidRow (map (map (grid !)) allSubGridIxs)
+  any isInvalidRow grid
+  || any isInvalidRow (Data.List.transpose grid)
+  || any isInvalidRow (subGridsToRows grid)
   where
     isInvalidRow row =
       let fixeds         = [x  | Fixed x <- row]
@@ -178,10 +168,12 @@ nextGrids :: Grid -> (Grid, Grid)
 nextGrids grid =
   let (i, first@(Fixed _), rest) =
         fixCell
-        . Data.Vector.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
-        . Data.Vector.imapMaybe (\j cell -> if isPossible cell then Just (j, cell) else Nothing)
+        . Data.List.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
+        . filter (isPossible . snd)
+        . zip [0..]
+        . concat
         $ grid
-  in (replaceCell i first grid, replaceCell i rest grid)
+  in (replace2D i first grid, replace2D i rest grid)
   where
     possibilityCount (Possible xs) = Data.Bits.popCount xs
     possibilityCount (Fixed _)     = 1
@@ -192,6 +184,10 @@ 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
@@ -204,14 +200,10 @@ solve grid = pruneGrid grid >>= solve'
 
 main :: IO ()
 main = do
-  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
+  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'