Replaces list with vector, naively
parent
5a3044e09c
commit
08f51aa82e
|
|
@ -14,6 +14,7 @@ description: Please see the README on GitHub at <https://github.com/abhi
|
|||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- containers
|
||||
- vector
|
||||
|
||||
executables:
|
||||
sudoku:
|
||||
|
|
|
|||
102
src/Sudoku.hs
102
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue