Adds pruning for exclusive possibilities

custom-accumulator
Abhinav Sarkar 2018-06-27 22:36:30 +05:30
parent 0ef77341a1
commit 9d6eb18229
2 changed files with 54 additions and 15 deletions

View File

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

View File

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