Replaces list with vector, naively

package.yaml

@@ -14,6 +14,7 @@ description:         Please see the README on GitHub at <https://github.com/abhi
 dependencies:
 - base >= 4.7 && < 5
 - containers
+- vector
 
 executables:
   sudoku:

src/Sudoku.hs

@@ -5,11 +5,14 @@ import Data.Function ((&))
 import qualified Control.Monad
 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.Foldable
+import qualified Data.Vector
+import Data.Vector ((!))
+import qualified Data.Vector.Mutable
 
 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 +24,8 @@ data Cell = Fixed {-# UNPACK #-} !Data.Word.Word16
           | Possible {-# UNPACK #-} !Data.Word.Word16
           deriving (Show, Eq)
 
-type Row  = [Cell]
-type Grid = [Row]
+type Grid = Data.Vector.Vector Cell
+type CellIxs = [Int]
 
 isPossible :: Cell -> Bool
 isPossible (Possible _) = True
@@ -30,7 +33,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,14 +43,31 @@ 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 = Data.Vector.modify (\v -> Data.Vector.Mutable.write 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 _         = "."
 
 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) =
@@ -75,9 +95,10 @@ 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
+exclusivePossibilities :: Grid -> CellIxs -> [Data.Word.Word16]
+exclusivePossibilities grid cellIxs =
+  cellIxs
+  & map (grid !)
   & zip ([1..9] :: [Int])
   & filter (isPossible . snd)
   & Data.List.foldl'
@@ -102,55 +123,58 @@ makeCell ys
   | Data.Bits.popCount ys == 1 = Just $ Fixed ys
   | otherwise                  = Just $ Possible ys
 
-pruneCellsByFixed :: [Cell] -> Maybe [Cell]
-pruneCellsByFixed cells = traverse pruneCell cells
+pruneCellsByFixed :: Grid -> CellIxs -> Maybe Grid
+pruneCellsByFixed grid cellIxs =
+  Control.Monad.foldM pruneCell grid . map (\i -> (i, grid ! i)) $ cellIxs
   where
-    fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- cells]
+    fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- map (grid !) cellIxs]
 
-    pruneCell (Possible xs) = makeCell (xs Data.Bits..&. Data.Bits.complement fixeds)
-    pruneCell x             = Just x
+    pruneCell g (_, Fixed _) = Just g
+    pruneCell g (i, Possible xs)
+      | xs' == xs = Just g
+      | otherwise = flip (replaceCell i) g <$> makeCell xs'
+      where
+        xs' = xs Data.Bits..&. Data.Bits.complement fixeds
 
-pruneCellsByExclusives :: [Cell] -> Maybe [Cell]
-pruneCellsByExclusives cells = case exclusives of
-  [] -> Just cells
-  _  -> traverse pruneCell cells
+pruneCellsByExclusives :: Grid -> CellIxs -> Maybe Grid
+pruneCellsByExclusives grid cellIxs = case exclusives of
+  [] -> Just grid
+  _  -> Control.Monad.foldM pruneCell grid . map (\i -> (i, grid ! i)) $ cellIxs
   where
-    exclusives    = exclusivePossibilities cells
+    exclusives    = exclusivePossibilities grid cellIxs
     allExclusives = setBits Data.Bits.zeroBits exclusives
 
-    pruneCell cell@(Fixed _) = Just cell
-    pruneCell cell@(Possible xs)
-      | intersection `elem` exclusives = makeCell intersection
-      | otherwise                      = Just cell
+    pruneCell g (_, Fixed _) = Just g
+    pruneCell g (i, Possible xs)
+      | 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
+pruneCells :: Grid -> CellIxs -> Maybe Grid
+pruneCells grid cellIxs =
+  fixM (flip pruneCellsByFixed cellIxs) grid
+  >>= fixM (flip pruneCellsByExclusives cellIxs)
 
 pruneGrid' :: Grid -> Maybe Grid
 pruneGrid' grid =
-  traverse pruneCells grid
-  >>= fmap Data.List.transpose . traverse pruneCells . Data.List.transpose
-  >>= fmap subGridsToRows . traverse pruneCells . subGridsToRows
+  Control.Monad.foldM pruneCells grid allRowIxs
+  >>= flip (Control.Monad.foldM pruneCells) allColIxs
+  >>= 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.Foldable.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]
@@ -168,12 +192,10 @@ nextGrids :: Grid -> (Grid, Grid)
 nextGrids grid =
   let (i, first@(Fixed _), rest) =
         fixCell
-        . Data.List.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
-        . filter (isPossible . snd)
-        . zip [0..]
-        . concat
+        . Data.Foldable.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
+        . Data.Vector.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
@@ -184,10 +206,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