Browse Source

Adds pruning for exclusive possibilities

Abhinav Sarkar 1 year ago
parent
commit
9d6eb18229
2 changed files with 54 additions and 15 deletions
  1. 1
    3
      package.yaml
  2. 53
    12
      src/Sudoku.hs

+ 1
- 3
package.yaml View File

@@ -13,15 +13,13 @@ description:         Please see the README on GitHub at <https://github.com/abhi
13 13
 
14 14
 dependencies:
15 15
 - base >= 4.7 && < 5
16
+- containers
16 17
 
17 18
 executables:
18 19
   sudoku:
19 20
     main:                Sudoku.hs
20 21
     source-dirs:         src
21 22
     ghc-options:
22
-    - -threaded
23
-    - -rtsopts
24
-    - -with-rtsopts=-N
25 23
     - -O2
26 24
     dependencies:
27 25
     - split

+ 53
- 12
src/Sudoku.hs View File

@@ -1,16 +1,25 @@
1 1
 module Main where
2 2
 
3 3
 import Control.Applicative ((<|>))
4
+import Data.Function ((&))
4 5
 import qualified Control.Monad
5 6
 import qualified Data.Char
6 7
 import qualified Data.Function
7 8
 import qualified Data.List.Split
8 9
 import qualified Data.List
10
+import qualified Data.Map.Strict as Map
11
+
12
+fixM :: (Eq t, Monad m) => (t -> m t) -> t -> m t
13
+fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
9 14
 
10 15
 data Cell = Fixed Int | Possible [Int] deriving (Show, Eq)
11 16
 type Row  = [Cell]
12 17
 type Grid = [Row]
13 18
 
19
+isPossible :: Cell -> Bool
20
+isPossible (Possible _) = True
21
+isPossible _            = False
22
+
14 23
 readGrid :: String -> Maybe Grid
15 24
 readGrid s
16 25
   | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
@@ -36,16 +45,53 @@ showGridWithPossibilities = unlines . map (unwords . map showCell)
36 45
       . Data.List.foldl' (\acc x -> acc ++ if x `elem` xs then show x else " ") "["
37 46
       $ [1..9]
38 47
 
39
-pruneCells :: [Cell] -> Maybe [Cell]
40
-pruneCells cells = traverse pruneCell cells
48
+exclusivePossibilities :: [Cell] -> [[Int]]
49
+exclusivePossibilities row =
50
+  row
51
+  & zip [1..9]
52
+  & filter (isPossible . snd)
53
+  & Data.List.foldl'
54
+      (\acc ~(i, Possible xs) ->
55
+        Data.List.foldl' (\acc' x -> Map.insertWith prepend x [i] acc') acc xs)
56
+      Map.empty
57
+  & Map.filter ((< 4) . length)
58
+  & Map.foldlWithKey'(\acc x is -> Map.insertWith prepend is [x] acc) Map.empty
59
+  & Map.filterWithKey (\is xs -> length is == length xs)
60
+  & Map.elems
61
+  where
62
+    prepend ~[y] ys = y:ys
63
+
64
+makeCell :: [Int] -> Maybe Cell
65
+makeCell ys = case ys of
66
+  []  -> Nothing
67
+  [y] -> Just $ Fixed y
68
+  _   -> Just $ Possible ys
69
+
70
+pruneCellsByFixed :: [Cell] -> Maybe [Cell]
71
+pruneCellsByFixed cells = traverse pruneCell cells
41 72
   where
42 73
     fixeds = [x | Fixed x <- cells]
43 74
 
44
-    pruneCell (Possible xs) = case xs Data.List.\\ fixeds of
45
-      []  -> Nothing
46
-      [y] -> Just $ Fixed y
47
-      ys  -> Just $ Possible ys
48
-    pruneCell x = Just x
75
+    pruneCell (Possible xs) = makeCell (xs Data.List.\\ fixeds)
76
+    pruneCell x             = Just x
77
+
78
+pruneCellsByExclusives :: [Cell] -> Maybe [Cell]
79
+pruneCellsByExclusives cells = case exclusives of
80
+  [] -> Just cells
81
+  _  -> traverse pruneCell cells
82
+  where
83
+    exclusives    = exclusivePossibilities cells
84
+    allExclusives = concat exclusives
85
+
86
+    pruneCell cell@(Fixed _) = Just cell
87
+    pruneCell cell@(Possible xs)
88
+      | intersection `elem` exclusives = makeCell intersection
89
+      | otherwise                      = Just cell
90
+      where
91
+        intersection = xs `Data.List.intersect` allExclusives
92
+
93
+pruneCells :: [Cell] -> Maybe [Cell]
94
+pruneCells cells = fixM pruneCellsByFixed cells >>= fixM pruneCellsByExclusives
49 95
 
50 96
 subGridsToRows :: Grid -> Grid
51 97
 subGridsToRows =
@@ -61,8 +107,6 @@ pruneGrid' grid =
61 107
 
62 108
 pruneGrid :: Grid -> Maybe Grid
63 109
 pruneGrid = fixM pruneGrid'
64
-  where
65
-    fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
66 110
 
67 111
 isGridFilled :: Grid -> Bool
68 112
 isGridFilled grid = null [ () | Possible _ <- concat grid ]
@@ -96,9 +140,6 @@ nextGrids grid =
96 140
         $ grid
97 141
   in (replace2D i first grid, replace2D i rest grid)
98 142
   where
99
-    isPossible (Possible _) = True
100
-    isPossible _            = False
101
-
102 143
     possibilityCount (Possible xs) = length xs
103 144
     possibilityCount (Fixed _)     = 1
104 145
 

Loading…
Cancel
Save