Adds pruning for exclusive possibilities

custom-accumulator
Abhinav Sarkar 2018-06-27 22:36:30 +05:30
父节点 0ef77341a1
当前提交 9d6eb18229
共有 2 个文件被更改,包括 54 次插入15 次删除

查看文件

@ -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

查看文件

@ -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