Adds pruning for exclusive possibilities

package.yaml

@@ -13,15 +13,13 @@ description:         Please see the README on GitHub at <https://github.com/abhi
 
 dependencies:
 - base >= 4.7 && < 5
+- containers
 
 executables:
   sudoku:
     main:                Sudoku.hs
     source-dirs:         src
     ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
     - -O2
     dependencies:
     - split

src/Sudoku.hs

@@ -1,16 +1,25 @@
 module Main where
 
 import Control.Applicative ((<|>))
+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
+
+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)
 type Row  = [Cell]
 type Grid = [Row]
 
+isPossible :: Cell -> Bool
+isPossible (Possible _) = True
+isPossible _            = False
+
 readGrid :: String -> Maybe Grid
 readGrid s
   | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
@@ -36,16 +45,53 @@ showGridWithPossibilities = unlines . map (unwords . map showCell)
       . Data.List.foldl' (\acc x -> acc ++ if x `elem` xs then show x else " ") "["
       $ [1..9]
 
-pruneCells :: [Cell] -> Maybe [Cell]
-pruneCells cells = traverse pruneCell cells
+exclusivePossibilities :: [Cell] -> [[Int]]
+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)
+      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
+  where
+    prepend ~[y] ys = y:ys
+
+makeCell :: [Int] -> Maybe Cell
+makeCell ys = case ys of
+  []  -> Nothing
+  [y] -> Just $ Fixed y
+  _   -> Just $ Possible ys
+
+pruneCellsByFixed :: [Cell] -> Maybe [Cell]
+pruneCellsByFixed cells = traverse pruneCell cells
   where
     fixeds = [x | Fixed x <- cells]
 
-    pruneCell (Possible xs) = case xs Data.List.\\ fixeds of
-      []  -> Nothing
-      [y] -> Just $ Fixed y
-      ys  -> Just $ Possible ys
-    pruneCell x = Just x
+    pruneCell (Possible xs) = makeCell (xs Data.List.\\ fixeds)
+    pruneCell x             = Just x
+
+pruneCellsByExclusives :: [Cell] -> Maybe [Cell]
+pruneCellsByExclusives cells = case exclusives of
+  [] -> Just cells
+  _  -> traverse pruneCell cells
+  where
+    exclusives    = exclusivePossibilities cells
+    allExclusives = concat 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
+
+pruneCells :: [Cell] -> Maybe [Cell]
+pruneCells cells = fixM pruneCellsByFixed cells >>= fixM pruneCellsByExclusives
 
 subGridsToRows :: Grid -> Grid
 subGridsToRows =
@@ -61,8 +107,6 @@ pruneGrid' grid =
 
 pruneGrid :: Grid -> Maybe Grid
 pruneGrid = fixM pruneGrid'
-  where
-    fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
 
 isGridFilled :: Grid -> Bool
 isGridFilled grid = null [ () | Possible _ <- concat grid ]
@@ -96,9 +140,6 @@ nextGrids grid =
         $ grid
   in (replace2D i first grid, replace2D i rest grid)
   where
-    isPossible (Possible _) = True
-    isPossible _            = False
-
     possibilityCount (Possible xs) = length xs
     possibilityCount (Fixed _)     = 1