Moves to bitset for possibilities

custom-accumulator
Abhinav Sarkar 2018-06-30 12:57:01 +05:30
parent 9d6eb18229
commit 5a3044e09c
1 changed files with 40 additions and 26 deletions

View File

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