Compare commits
7 Commits
master
...
unboxed-ve
Author | SHA1 | Date |
---|---|---|
Abhinav Sarkar | c6cc365151 | |
Abhinav Sarkar | f8aa4d7766 | |
Abhinav Sarkar | 73aee36b4d | |
Abhinav Sarkar | bf80a77cd8 | |
Abhinav Sarkar | fbdb50078d | |
Abhinav Sarkar | 567a9dcaf2 | |
Abhinav Sarkar | 0377999561 |
212
src/Sudoku.hs
212
src/Sudoku.hs
|
@ -1,8 +1,8 @@
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
import Data.Vector ((!))
|
|
||||||
import qualified Control.Monad
|
import qualified Control.Monad
|
||||||
import qualified Control.Monad.ST
|
import qualified Control.Monad.ST
|
||||||
import qualified Data.Char
|
import qualified Data.Char
|
||||||
|
@ -11,12 +11,10 @@ import qualified Data.List
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import qualified Data.Word
|
import qualified Data.Word
|
||||||
import qualified Data.Bits
|
import qualified Data.Bits
|
||||||
import qualified Data.Vector
|
import Data.Vector.Unboxed ((!))
|
||||||
import qualified Data.Vector.Unboxed
|
|
||||||
import qualified Data.Vector.Unboxed.Mutable
|
import qualified Data.Vector.Unboxed.Mutable
|
||||||
import qualified Data.STRef
|
import qualified Data.Vector.Unboxed
|
||||||
import qualified Data.Maybe
|
import qualified Data.Maybe
|
||||||
import qualified Control.DeepSeq
|
|
||||||
import Control.Parallel.Strategies (withStrategy, rdeepseq, parBuffer)
|
import Control.Parallel.Strategies (withStrategy, rdeepseq, parBuffer)
|
||||||
|
|
||||||
fixM :: (Eq t, Monad m) => (t -> m t) -> t -> m t
|
fixM :: (Eq t, Monad m) => (t -> m t) -> t -> m t
|
||||||
|
@ -25,37 +23,35 @@ fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
|
||||||
setBits :: Data.Word.Word16 -> [Data.Word.Word16] -> Data.Word.Word16
|
setBits :: Data.Word.Word16 -> [Data.Word.Word16] -> Data.Word.Word16
|
||||||
setBits = Data.List.foldl' (Data.Bits..|.)
|
setBits = Data.List.foldl' (Data.Bits..|.)
|
||||||
|
|
||||||
data Cell = Fixed Data.Word.Word16
|
type Cell = Data.Word.Word16
|
||||||
| Possible Data.Word.Word16
|
type Grid = Data.Vector.Unboxed.Vector Cell
|
||||||
deriving (Show, Eq)
|
type MGrid s = Data.Vector.Unboxed.Mutable.STVector s Cell
|
||||||
|
|
||||||
instance Control.DeepSeq.NFData Cell where
|
|
||||||
rnf (Fixed w) = Control.DeepSeq.rnf w
|
|
||||||
rnf (Possible w) = Control.DeepSeq.rnf w
|
|
||||||
|
|
||||||
type Grid = Data.Vector.Vector Cell
|
|
||||||
type CellIxs = [Int]
|
type CellIxs = [Int]
|
||||||
|
|
||||||
isPossible :: Cell -> Bool
|
isPossible, isFixed :: Cell -> Bool
|
||||||
isPossible (Possible _) = True
|
isPossible = flip Data.Bits.testBit 15
|
||||||
isPossible _ = False
|
isFixed = not . isPossible
|
||||||
|
|
||||||
|
makePossible, makeFixed :: Data.Word.Word16 -> Cell
|
||||||
|
makePossible = flip Data.Bits.setBit 15
|
||||||
|
makeFixed = flip Data.Bits.clearBit 15
|
||||||
|
|
||||||
readGrid :: String -> Maybe Grid
|
readGrid :: String -> Maybe Grid
|
||||||
readGrid s
|
readGrid s
|
||||||
| length s == 81 = Data.Vector.fromList <$> traverse readCell s
|
| length s == 81 = Data.Vector.Unboxed.fromList <$> traverse readCell s
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
allBitsSet = 1022
|
allBitsSet = 1022
|
||||||
|
|
||||||
readCell '.' = Just $ Possible allBitsSet
|
readCell '.' = Just $ makePossible allBitsSet
|
||||||
readCell c
|
readCell c
|
||||||
| Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Bits.bit . Data.Char.digitToInt $ c
|
| Data.Char.isDigit c && c > '0' = Just . Data.Bits.bit . Data.Char.digitToInt $ c
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
|
|
||||||
fromXY :: (Int, Int) -> Int
|
fromXY :: (Int, Int) -> Int
|
||||||
fromXY (x, y) = x * 9 + y
|
fromXY (x, y) = x * 9 + y
|
||||||
|
|
||||||
allRowIxs, allColIxs, allSubGridIxs :: [CellIxs]
|
allRowIxs, allColIxs, allSubGridIxs, allIxs :: [CellIxs]
|
||||||
allRowIxs = [getRow i | i <- [0..8]]
|
allRowIxs = [getRow i | i <- [0..8]]
|
||||||
where getRow n = [ fromXY (n, i) | i <- [0..8] ]
|
where getRow n = [ fromXY (n, i) | i <- [0..8] ]
|
||||||
|
|
||||||
|
@ -66,45 +62,64 @@ allSubGridIxs = [getSubGrid i | i <- [0..8]]
|
||||||
where getSubGrid n = let (r, c) = (n `quot` 3, n `mod` 3)
|
where getSubGrid n = let (r, c) = (n `quot` 3, n `mod` 3)
|
||||||
in [ fromXY (3 * r + i, 3 * c + j) | i <- [0..2], j <- [0..2] ]
|
in [ fromXY (3 * r + i, 3 * c + j) | i <- [0..2], j <- [0..2] ]
|
||||||
|
|
||||||
|
allIxs = concat [allRowIxs, allColIxs, allSubGridIxs]
|
||||||
|
|
||||||
replaceCell :: Int -> Cell -> Grid -> Grid
|
replaceCell :: Int -> Cell -> Grid -> Grid
|
||||||
replaceCell i c g = g Data.Vector.// [(i, c)]
|
replaceCell i c = Data.Vector.Unboxed.modify (\v -> Data.Vector.Unboxed.Mutable.unsafeWrite v i c)
|
||||||
|
|
||||||
showGrid :: Grid -> String
|
showGrid :: Grid -> String
|
||||||
showGrid grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
|
showGrid grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
|
||||||
where
|
where
|
||||||
showCell (Fixed x) = show . Data.Bits.countTrailingZeros $ x
|
showCell xs
|
||||||
showCell _ = "."
|
| isPossible xs = "."
|
||||||
|
| otherwise = show . Data.Bits.countTrailingZeros $ xs
|
||||||
|
|
||||||
showGridWithPossibilities :: Grid -> String
|
showGridWithPossibilities :: Grid -> String
|
||||||
showGridWithPossibilities grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
|
showGridWithPossibilities grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs
|
||||||
where
|
where
|
||||||
showCell (Fixed x) = (show . Data.Bits.countTrailingZeros $ x) ++ " "
|
showCell xs
|
||||||
showCell (Possible xs) =
|
| isPossible xs =
|
||||||
"[" ++ map (\i -> if Data.Bits.testBit xs i then Data.Char.intToDigit i else ' ') [1..9] ++ "]"
|
"[" ++ map (\i -> if Data.Bits.testBit xs i then Data.Char.intToDigit i else ' ') [1..9] ++ "]"
|
||||||
|
| otherwise = (show . Data.Bits.countTrailingZeros $ xs) ++ " "
|
||||||
|
|
||||||
cellIndicesList :: [Cell] -> [Data.Word.Word16]
|
-- Exclusive Possibilities Accumulator
|
||||||
cellIndicesList cells =
|
data ExPosAcc = ExPosAcc ![Int] ![Int] ![Int] ![Int] ![Int] ![Int] ![Int] ![Int] ![Int]
|
||||||
Data.Vector.Unboxed.toList $ Control.Monad.ST.runST $ do
|
|
||||||
vec <- Data.Vector.Unboxed.Mutable.replicate 9 Data.Bits.zeroBits
|
exPosAccEmpty :: ExPosAcc
|
||||||
ref <- Data.STRef.newSTRef (1 :: Int)
|
exPosAccEmpty = ExPosAcc [] [] [] [] [] [] [] [] []
|
||||||
Control.Monad.forM_ cells $ \cell -> do
|
|
||||||
i <- Data.STRef.readSTRef ref
|
exPosAccInsert :: Int -> Int -> ExPosAcc -> ExPosAcc
|
||||||
case cell of
|
exPosAccInsert 1 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc (i:v1) v2 v3 v4 v5 v6 v7 v8 v9
|
||||||
Fixed _ -> return ()
|
exPosAccInsert 2 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 (i:v2) v3 v4 v5 v6 v7 v8 v9
|
||||||
Possible xs -> Control.Monad.forM_ [0..8] $ \d ->
|
exPosAccInsert 3 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 (i:v3) v4 v5 v6 v7 v8 v9
|
||||||
Control.Monad.when (Data.Bits.testBit xs (d+1)) $
|
exPosAccInsert 4 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 (i:v4) v5 v6 v7 v8 v9
|
||||||
Data.Vector.Unboxed.Mutable.unsafeModify vec (`Data.Bits.setBit` i) d
|
exPosAccInsert 5 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 (i:v5) v6 v7 v8 v9
|
||||||
Data.STRef.writeSTRef ref (i+1)
|
exPosAccInsert 6 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 (i:v6) v7 v8 v9
|
||||||
Data.Vector.Unboxed.unsafeFreeze vec
|
exPosAccInsert 7 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 v6 (i:v7) v8 v9
|
||||||
|
exPosAccInsert 8 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 v6 v7 (i:v8) v9
|
||||||
|
exPosAccInsert 9 i (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) = ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 (i:v9)
|
||||||
|
exPosAccInsert _ _ _ = error "Impossible"
|
||||||
|
|
||||||
|
exPosAccToList :: ExPosAcc -> [(Int, [Int])]
|
||||||
|
exPosAccToList (ExPosAcc v1 v2 v3 v4 v5 v6 v7 v8 v9) =
|
||||||
|
[(1, v1), (2, v2), (3, v3), (4, v4), (5, v5), (6, v6), (7, v7), (8, v8), (9, v9)]
|
||||||
|
|
||||||
exclusivePossibilities :: [Cell] -> [Data.Word.Word16]
|
exclusivePossibilities :: [Cell] -> [Data.Word.Word16]
|
||||||
exclusivePossibilities row =
|
exclusivePossibilities cells =
|
||||||
row
|
cells
|
||||||
& cellIndicesList
|
& zip ([1..9] :: [Int])
|
||||||
& zip [1..9]
|
& filter (isPossible . snd)
|
||||||
& filter (\(_, xs) -> let p = Data.Bits.popCount xs in p > 0 && p < 4)
|
& Data.List.foldl'
|
||||||
|
(\acc (i, xs) ->
|
||||||
|
Data.List.foldl'
|
||||||
|
(\acc' n -> if Data.Bits.testBit xs n then exPosAccInsert n i acc' else acc')
|
||||||
|
acc
|
||||||
|
[1..9])
|
||||||
|
exPosAccEmpty
|
||||||
|
& exPosAccToList
|
||||||
|
& filter ((< 4) . length . snd)
|
||||||
& Data.List.foldl' (\acc (x, is) -> Map.insertWith prepend is [x] acc) Map.empty
|
& Data.List.foldl' (\acc (x, is) -> Map.insertWith prepend is [x] acc) Map.empty
|
||||||
& Map.filterWithKey (\is xs -> Data.Bits.popCount is == length xs)
|
& Map.filterWithKey (\is xs -> length is == length xs)
|
||||||
& Map.elems
|
& Map.elems
|
||||||
& map (Data.List.foldl' Data.Bits.setBit Data.Bits.zeroBits)
|
& map (Data.List.foldl' Data.Bits.setBit Data.Bits.zeroBits)
|
||||||
where
|
where
|
||||||
|
@ -112,49 +127,81 @@ exclusivePossibilities row =
|
||||||
|
|
||||||
makeCell :: Data.Word.Word16 -> Maybe Cell
|
makeCell :: Data.Word.Word16 -> Maybe Cell
|
||||||
makeCell ys
|
makeCell ys
|
||||||
| ys == Data.Bits.zeroBits = Nothing
|
| ys == Data.Bits.zeroBits = Nothing
|
||||||
| Data.Bits.popCount ys == 1 = Just $ Fixed ys
|
| Data.Bits.popCount (makeFixed ys) == 1 = Just $ makeFixed ys
|
||||||
| otherwise = Just $ Possible ys
|
| otherwise = Just $ makePossible ys
|
||||||
|
|
||||||
pruneCells :: Grid -> CellIxs -> Maybe Grid
|
pruneCells :: MGrid s -> CellIxs -> Control.Monad.ST.ST s (Maybe Bool)
|
||||||
pruneCells grid cellIxs = Control.Monad.foldM pruneCell grid cellIxs
|
pruneCells grid cellIxs = do
|
||||||
|
cells <- traverse (Data.Vector.Unboxed.Mutable.unsafeRead grid) cellIxs
|
||||||
|
pruneCells' grid cells cellIxs
|
||||||
|
|
||||||
|
pruneCells' :: MGrid s -> [Cell] -> CellIxs -> Control.Monad.ST.ST s (Maybe Bool)
|
||||||
|
pruneCells' grid cells = Control.Monad.foldM pruneCell' (Just False)
|
||||||
where
|
where
|
||||||
cells = map (grid !) cellIxs
|
pruneCell' Nothing _ = return Nothing
|
||||||
|
pruneCell' (Just changed) i = pruneCell i >>= \case
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just changed' -> return $ Just (changed || changed')
|
||||||
|
|
||||||
exclusives = exclusivePossibilities cells
|
exclusives = exclusivePossibilities cells
|
||||||
allExclusives = setBits Data.Bits.zeroBits exclusives
|
allExclusives = setBits Data.Bits.zeroBits exclusives
|
||||||
fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- cells]
|
fixeds = setBits Data.Bits.zeroBits . filter isFixed $ cells
|
||||||
|
|
||||||
pruneCell g i =
|
pruneCell i = do
|
||||||
pruneCellByFixed g (i, g ! i) >>= \g' -> pruneCellByExclusives g' (i, g' ! i)
|
cell <- Data.Vector.Unboxed.Mutable.unsafeRead grid i
|
||||||
|
pruneCellByFixed (i, cell) >>= \case
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just changed -> do
|
||||||
|
cell' <- Data.Vector.Unboxed.Mutable.unsafeRead grid i
|
||||||
|
pruneCellByExclusives (i, cell') >>= \case
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just changed' -> return $ Just (changed || changed')
|
||||||
|
|
||||||
pruneCellByFixed g (_, Fixed _) = Just g
|
pruneCellByFixed (i, xs)
|
||||||
pruneCellByFixed g (i, Possible xs)
|
| isFixed xs = return $ Just False
|
||||||
| xs' == xs = Just g
|
| xs' == xs = return $ Just False
|
||||||
| otherwise = flip (replaceCell i) g <$> makeCell xs'
|
| otherwise = case makeCell xs' of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just cell' -> do
|
||||||
|
Data.Vector.Unboxed.Mutable.unsafeWrite grid i cell'
|
||||||
|
return $ Just True
|
||||||
where
|
where
|
||||||
xs' = xs Data.Bits..&. Data.Bits.complement fixeds
|
xs' = xs Data.Bits..&. Data.Bits.complement fixeds
|
||||||
|
|
||||||
pruneCellByExclusives g (_, Fixed _) = Just g
|
pruneCellByExclusives (i, xs)
|
||||||
pruneCellByExclusives g (i, Possible xs)
|
| isFixed xs = return $ Just False
|
||||||
| null exclusives = Just g
|
| null exclusives = return $ Just False
|
||||||
| intersection == xs = Just g
|
| makePossible intersection == xs = return $ Just False
|
||||||
| intersection `elem` exclusives =
|
| intersection `elem` exclusives = case makeCell intersection of
|
||||||
flip (replaceCell i) g <$> makeCell intersection
|
Nothing -> return Nothing
|
||||||
| otherwise = Just g
|
Just cell' -> do
|
||||||
|
Data.Vector.Unboxed.Mutable.unsafeWrite grid i cell'
|
||||||
|
return $ Just True
|
||||||
|
| otherwise = return $ Just False
|
||||||
where
|
where
|
||||||
intersection = xs Data.Bits..&. allExclusives
|
intersection = xs Data.Bits..&. allExclusives
|
||||||
|
|
||||||
pruneGrid' :: Grid -> Maybe Grid
|
pruneGrid' :: MGrid s -> Control.Monad.ST.ST s (Maybe Bool)
|
||||||
pruneGrid' grid =
|
pruneGrid' grid = Control.Monad.foldM pruneCells' (Just False) allIxs
|
||||||
Control.Monad.foldM pruneCells grid allRowIxs
|
where
|
||||||
>>= flip (Control.Monad.foldM pruneCells) allColIxs
|
pruneCells' Nothing _ = return Nothing
|
||||||
>>= flip (Control.Monad.foldM pruneCells) allSubGridIxs
|
pruneCells' (Just changed) ixs = pruneCells grid ixs >>= \case
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just changed' -> return $ Just (changed || changed')
|
||||||
|
|
||||||
pruneGrid :: Grid -> Maybe Grid
|
pruneGrid :: Grid -> Maybe Grid
|
||||||
pruneGrid = fixM pruneGrid'
|
pruneGrid grid = Control.Monad.ST.runST $ do
|
||||||
|
mGrid <- Data.Vector.Unboxed.unsafeThaw grid
|
||||||
|
fix mGrid
|
||||||
|
where
|
||||||
|
fix mg = pruneGrid' mg >>= \case
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just True -> fix mg
|
||||||
|
Just False -> Just <$> Data.Vector.Unboxed.unsafeFreeze mg
|
||||||
|
|
||||||
isGridFilled :: Grid -> Bool
|
isGridFilled :: Grid -> Bool
|
||||||
isGridFilled = not . Data.Vector.any isPossible
|
isGridFilled = not . Data.Vector.Unboxed.any isPossible
|
||||||
|
|
||||||
isGridInvalid :: Grid -> Bool
|
isGridInvalid :: Grid -> Bool
|
||||||
isGridInvalid grid =
|
isGridInvalid grid =
|
||||||
|
@ -163,8 +210,8 @@ isGridInvalid grid =
|
||||||
|| any isInvalidRow (map (map (grid !)) allSubGridIxs)
|
|| any isInvalidRow (map (map (grid !)) allSubGridIxs)
|
||||||
where
|
where
|
||||||
isInvalidRow row =
|
isInvalidRow row =
|
||||||
let fixeds = [x | Fixed x <- row]
|
let fixeds = filter isFixed row
|
||||||
emptyPossibles = [() | Possible x <- row, x == Data.Bits.zeroBits]
|
emptyPossibles = filter (== 32768) . filter isPossible $ row
|
||||||
in hasDups fixeds || not (null emptyPossibles)
|
in hasDups fixeds || not (null emptyPossibles)
|
||||||
|
|
||||||
hasDups l = hasDups' l []
|
hasDups l = hasDups' l []
|
||||||
|
@ -176,21 +223,22 @@ isGridInvalid grid =
|
||||||
|
|
||||||
nextGrids :: Grid -> (Grid, Grid)
|
nextGrids :: Grid -> (Grid, Grid)
|
||||||
nextGrids grid =
|
nextGrids grid =
|
||||||
let (i, first@(Fixed _), rest) =
|
let (i, first, rest) =
|
||||||
fixCell
|
fixCell
|
||||||
. Data.Vector.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
|
. Data.Vector.Unboxed.minimumBy (compare `Data.Function.on` (possibilityCount . snd))
|
||||||
. Data.Vector.imapMaybe (\j cell -> if isPossible cell then Just (j, cell) else Nothing)
|
. Data.Vector.Unboxed.imapMaybe (\j cell -> if isPossible cell then Just (j, cell) else Nothing)
|
||||||
$ grid
|
$ grid
|
||||||
in (replaceCell i first grid, replaceCell i rest grid)
|
in (replaceCell i first grid, replaceCell i rest grid)
|
||||||
where
|
where
|
||||||
possibilityCount (Possible xs) = Data.Bits.popCount xs
|
possibilityCount xs
|
||||||
possibilityCount (Fixed _) = 1
|
| isPossible xs = Data.Bits.popCount xs - 1
|
||||||
|
| otherwise = 1
|
||||||
|
|
||||||
fixCell ~(i, Possible xs) =
|
fixCell (i, xs) =
|
||||||
let x = Data.Bits.countTrailingZeros xs
|
let x = Data.Bits.countTrailingZeros xs
|
||||||
in case makeCell (Data.Bits.clearBit xs x) of
|
in case makeCell (Data.Bits.clearBit xs x) of
|
||||||
Nothing -> error "Impossible case"
|
Nothing -> error "Impossible case"
|
||||||
Just cell -> (i, Fixed (Data.Bits.bit x), cell)
|
Just cell -> (i, Data.Bits.bit x, cell)
|
||||||
|
|
||||||
solve :: Grid -> Maybe Grid
|
solve :: Grid -> Maybe Grid
|
||||||
solve grid = pruneGrid grid >>= solve'
|
solve grid = pruneGrid grid >>= solve'
|
||||||
|
|
Loading…
Reference in New Issue