Changes exclusivePossibilities to use mutable vector

src/Sudoku.hs

@@ -2,7 +2,9 @@ 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
@@ -10,7 +12,9 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Word
 import qualified Data.Bits
 import qualified Data.Vector
-import Data.Vector ((!))
+import qualified Data.Vector.Unboxed
+import qualified Data.Vector.Unboxed.Mutable
+import qualified Data.STRef
 
 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'
@@ -71,21 +75,29 @@ showGridWithPossibilities grid = unlines . map (unwords . map (showCell . (grid
     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)
-  & Data.List.foldl'
-      (\acc ~(i, Possible 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)
+  & filter (\(_, xs) -> let p = Data.Bits.popCount xs in p > 0 && p < 4)
+  & 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.elems
   & map (Data.List.foldl' Data.Bits.setBit Data.Bits.zeroBits)
   where