Moves to bitset for possibilities

src/Sudoku.hs

@@ -8,11 +8,19 @@ 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
 
 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'
 
-data Cell = Fixed Int | Possible [Int] deriving (Show, Eq)
+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 Row  = [Cell]
 type Grid = [Row]
 
@@ -25,54 +33,58 @@ readGrid s
   | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
   | otherwise      = Nothing
   where
-    readCell '.' = Just $ Possible [1..9]
+    allBitsSet = 1022
+
+    readCell '.' = Just $ Possible allBitsSet
     readCell c
-      | Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Char.digitToInt $ c
+      | Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Bits.bit . Data.Char.digitToInt $ c
       | otherwise = Nothing
 
 showGrid :: Grid -> String
 showGrid = unlines . map (unwords . map showCell)
   where
-    showCell (Fixed x) = show x
-    showCell _ = "."
+    showCell (Fixed x) = show . Data.Bits.countTrailingZeros $ x
+    showCell _         = "."
 
 showGridWithPossibilities :: Grid -> String
 showGridWithPossibilities = unlines . map (unwords . map showCell)
   where
-    showCell (Fixed x)     = show x ++ "          "
+    showCell (Fixed x)     = (show . Data.Bits.countTrailingZeros $ x) ++ "          "
     showCell (Possible xs) =
-      (++ "]")
-      . Data.List.foldl' (\acc x -> acc ++ if x `elem` xs then show x else " ") "["
-      $ [1..9]
+      "[" ++ map (\i -> if Data.Bits.testBit xs i then Data.Char.intToDigit i else ' ') [1..9] ++ "]"
 
-exclusivePossibilities :: [Cell] -> [[Int]]
+exclusivePossibilities :: [Cell] -> [Data.Word.Word16]
 exclusivePossibilities row =
   row
   & zip [1..9]
   & filter (isPossible . snd)
   & Data.List.foldl'
       (\acc ~(i, Possible xs) ->
-        Data.List.foldl' (\acc' x -> Map.insertWith prepend x [i] acc') acc 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
     prepend ~[y] ys = y:ys
 
-makeCell :: [Int] -> Maybe Cell
-makeCell ys = case ys of
-  []  -> Nothing
-  [y] -> Just $ Fixed y
-  _   -> Just $ Possible ys
+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
 
 pruneCellsByFixed :: [Cell] -> Maybe [Cell]
 pruneCellsByFixed cells = traverse pruneCell cells
   where
-    fixeds = [x | Fixed x <- cells]
+    fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- cells]
 
-    pruneCell (Possible xs) = makeCell (xs Data.List.\\ fixeds)
+    pruneCell (Possible xs) = makeCell (xs Data.Bits..&. Data.Bits.complement fixeds)
     pruneCell x             = Just x
 
 pruneCellsByExclusives :: [Cell] -> Maybe [Cell]
@@ -81,14 +93,14 @@ pruneCellsByExclusives cells = case exclusives of
   _  -> traverse pruneCell cells
   where
     exclusives    = exclusivePossibilities cells
-    allExclusives = concat exclusives
+    allExclusives = setBits Data.Bits.zeroBits exclusives
 
     pruneCell cell@(Fixed _) = Just cell
     pruneCell cell@(Possible xs)
       | intersection `elem` exclusives = makeCell intersection
       | otherwise                      = Just cell
       where
-        intersection = xs `Data.List.intersect` allExclusives
+        intersection = xs Data.Bits..&. allExclusives
 
 pruneCells :: [Cell] -> Maybe [Cell]
 pruneCells cells = fixM pruneCellsByFixed cells >>= fixM pruneCellsByExclusives
@@ -118,8 +130,8 @@ isGridInvalid grid =
   || any isInvalidRow (subGridsToRows grid)
   where
     isInvalidRow row =
-      let fixeds         = [x | Fixed x <- row]
-          emptyPossibles = [x | Possible x <- row, null x]
+      let fixeds         = [x  | Fixed x <- row]
+          emptyPossibles = [() | Possible x <- row, x == Data.Bits.zeroBits]
       in hasDups fixeds || not (null emptyPossibles)
 
     hasDups l = hasDups' l []
@@ -140,12 +152,14 @@ nextGrids grid =
         $ grid
   in (replace2D i first grid, replace2D i rest grid)
   where
-    possibilityCount (Possible xs) = length xs
+    possibilityCount (Possible xs) = Data.Bits.popCount xs
     possibilityCount (Fixed _)     = 1
 
-    fixCell (i, Possible [x, y]) = (i, Fixed x, Fixed y)
-    fixCell (i, Possible (x:xs)) = (i, Fixed x, Possible xs)
-    fixCell _                    = error "Impossible case"
+    fixCell ~(i, Possible 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))