diff --git a/package.yaml b/package.yaml index c835399..b1710aa 100644 --- a/package.yaml +++ b/package.yaml @@ -14,6 +14,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - containers +- vector executables: sudoku: diff --git a/src/Sudoku.hs b/src/Sudoku.hs index ff9e737..c85541c 100644 --- a/src/Sudoku.hs +++ b/src/Sudoku.hs @@ -5,11 +5,12 @@ 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 import qualified Data.Word import qualified Data.Bits +import qualified Data.Vector +import Data.Vector ((!)) 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' @@ -21,8 +22,8 @@ data Cell = Fixed Data.Word.Word16 | Possible Data.Word.Word16 deriving (Show, Eq) -type Row = [Cell] -type Grid = [Row] +type Grid = Data.Vector.Vector Cell +type CellIxs = [Int] isPossible :: Cell -> Bool isPossible (Possible _) = True @@ -30,7 +31,7 @@ isPossible _ = False readGrid :: String -> Maybe Grid readGrid s - | length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s + | length s == 81 = Data.Vector.fromList <$> traverse readCell s | otherwise = Nothing where allBitsSet = 1022 @@ -40,14 +41,31 @@ readGrid s | Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Bits.bit . Data.Char.digitToInt $ c | otherwise = Nothing +fromXY :: (Int, Int) -> Int +fromXY (x, y) = x * 9 + y + +allRowIxs, allColIxs, allSubGridIxs :: [CellIxs] +allRowIxs = [getRow i | i <- [0..8]] + where getRow n = [ fromXY (n, i) | i <- [0..8] ] + +allColIxs = [getCol i | i <- [0..8]] + where getCol n = [ fromXY (i, n) | i <- [0..8] ] + +allSubGridIxs = [getSubGrid i | i <- [0..8]] + 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] ] + +replaceCell :: Int -> Cell -> Grid -> Grid +replaceCell i c g = g Data.Vector.// [(i, c)] + showGrid :: Grid -> String -showGrid = unlines . map (unwords . map showCell) +showGrid grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs where showCell (Fixed x) = show . Data.Bits.countTrailingZeros $ x showCell _ = "." showGridWithPossibilities :: Grid -> String -showGridWithPossibilities = unlines . map (unwords . map showCell) +showGridWithPossibilities grid = unlines . map (unwords . map (showCell . (grid !))) $ allRowIxs where showCell (Fixed x) = (show . Data.Bits.countTrailingZeros $ x) ++ " " showCell (Possible xs) = @@ -79,55 +97,59 @@ makeCell ys | Data.Bits.popCount ys == 1 = Just $ Fixed ys | otherwise = Just $ Possible ys -pruneCellsByFixed :: [Cell] -> Maybe [Cell] -pruneCellsByFixed cells = traverse pruneCell cells +pruneCellsByFixed :: Grid -> CellIxs -> Maybe Grid +pruneCellsByFixed grid cellIxs = + Control.Monad.foldM pruneCell grid . map (\i -> (i, grid ! i)) $ cellIxs where - fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- cells] + fixeds = setBits Data.Bits.zeroBits [x | Fixed x <- map (grid !) cellIxs] - pruneCell (Possible xs) = makeCell (xs Data.Bits..&. Data.Bits.complement fixeds) - pruneCell x = Just x + pruneCell g (_, Fixed _) = Just g + pruneCell g (i, Possible xs) + | xs' == xs = Just g + | otherwise = flip (replaceCell i) g <$> makeCell xs' + where + xs' = xs Data.Bits..&. Data.Bits.complement fixeds -pruneCellsByExclusives :: [Cell] -> Maybe [Cell] -pruneCellsByExclusives cells = case exclusives of - [] -> Just cells - _ -> traverse pruneCell cells +pruneCellsByExclusives :: Grid -> CellIxs -> Maybe Grid +pruneCellsByExclusives grid cellIxs = case exclusives of + [] -> Just grid + _ -> Control.Monad.foldM pruneCell grid . zip cellIxs $ cells where + cells = map (grid !) cellIxs exclusives = exclusivePossibilities cells allExclusives = setBits Data.Bits.zeroBits exclusives - pruneCell cell@(Fixed _) = Just cell - pruneCell cell@(Possible xs) - | intersection `elem` exclusives = makeCell intersection - | otherwise = Just cell + pruneCell g (_, Fixed _) = Just g + pruneCell g (i, Possible xs) + | intersection == xs = Just g + | intersection `elem` exclusives = + flip (replaceCell i) g <$> makeCell intersection + | otherwise = Just g where intersection = xs Data.Bits..&. allExclusives -pruneCells :: [Cell] -> Maybe [Cell] -pruneCells cells = fixM pruneCellsByFixed cells >>= fixM pruneCellsByExclusives - -subGridsToRows :: Grid -> Grid -subGridsToRows = - concatMap (\rows -> let [r1, r2, r3] = map (Data.List.Split.chunksOf 3) rows - in zipWith3 (\a b c -> a ++ b ++ c) r1 r2 r3) - . Data.List.Split.chunksOf 3 +pruneCells :: Grid -> CellIxs -> Maybe Grid +pruneCells grid cellIxs = + fixM (flip pruneCellsByFixed cellIxs) grid + >>= fixM (flip pruneCellsByExclusives cellIxs) pruneGrid' :: Grid -> Maybe Grid pruneGrid' grid = - traverse pruneCells grid - >>= fmap Data.List.transpose . traverse pruneCells . Data.List.transpose - >>= fmap subGridsToRows . traverse pruneCells . subGridsToRows + Control.Monad.foldM pruneCells grid allRowIxs + >>= flip (Control.Monad.foldM pruneCells) allColIxs + >>= flip (Control.Monad.foldM pruneCells) allSubGridIxs pruneGrid :: Grid -> Maybe Grid pruneGrid = fixM pruneGrid' isGridFilled :: Grid -> Bool -isGridFilled grid = null [ () | Possible _ <- concat grid ] +isGridFilled = not . Data.Vector.any isPossible isGridInvalid :: Grid -> Bool isGridInvalid grid = - any isInvalidRow grid - || any isInvalidRow (Data.List.transpose grid) - || any isInvalidRow (subGridsToRows grid) + any isInvalidRow (map (map (grid !)) allRowIxs) + || any isInvalidRow (map (map (grid !)) allColIxs) + || any isInvalidRow (map (map (grid !)) allSubGridIxs) where isInvalidRow row = let fixeds = [x | Fixed x <- row] @@ -145,12 +167,10 @@ nextGrids :: Grid -> (Grid, Grid) nextGrids grid = let (i, first@(Fixed _), rest) = fixCell - . Data.List.minimumBy (compare `Data.Function.on` (possibilityCount . snd)) - . filter (isPossible . snd) - . zip [0..] - . concat + . Data.Vector.minimumBy (compare `Data.Function.on` (possibilityCount . snd)) + . Data.Vector.imapMaybe (\j cell -> if isPossible cell then Just (j, cell) else Nothing) $ grid - in (replace2D i first grid, replace2D i rest grid) + in (replaceCell i first grid, replaceCell i rest grid) where possibilityCount (Possible xs) = Data.Bits.popCount xs possibilityCount (Fixed _) = 1 @@ -161,10 +181,6 @@ nextGrids grid = 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)) - replace p f xs = [if i == p then f x else x | (x, i) <- zip xs [0..]] - solve :: Grid -> Maybe Grid solve grid = pruneGrid grid >>= solve' where