Select and Sudoku
I was going through hackage until I found SelectT, a special Monad transformer that is used in search algorithms.
It is defined as follows:
newtype SelectT r m a = SelectT {
}
type Select r = SelectT r Identity
The idea is to inject a function that will be used to pick a value among many; it all comes with the following helpers:
Let's try to use it to solve a Sudoku board.
Sudoku is a game in which we have cells holding a value from 1 to 9.
Boards are 9x9 grids in which each value is unique in three areas: line, column, and 3x3 sub-grid.
As early optimizations, we can, during the board creation, store missing cells and represent missing cells as remaining possible solutions.
We can draft the following types:
data Position = Position
{ column :: Int,
}
deriving stock (Eq, Ord, Show)
newtype Solution
= Solution {unSolution :: Int}
deriving newtype (Eq, Ord, Show, Num, Enum)
newtype RemainingPossibilities
= RemainingPossibilities {unRemainingPossibilities :: Set Solution}
deriving stock (Eq, Show)
data Board = Board
{ cells :: Map Position (Either RemainingPossibilities Solution),
}
We can start building our functions by listing each area's positions as follows:
areas Position {..} =
Set.fromList [Position column row' | row' <- [1 .. 9], row' /= row]
:| [ Set.fromList [Position column' row | column' <- [1 .. 9], column' /= column],
Set.fromList
[ Position column' row'
| let baseColumn = 1 + ((column - 1) `div` 3) * 3,
let baseRow = 1 + ((row - 1) `div` 3) * 3,
column' <- (baseColumn +) <$> [0 .. 2],
row' <- (baseRow +) <$> [0 .. 2],
column' /= column || row' /= row
]
]
Each area gets it own element and computation method.
The next step is to start building the board as follows:
mkBoard sols = do
let allPossibilities = Set.fromDistinctAscList [1 .. 9]
emptyCells =
Set.fromDistinctAscList [Position column row | column <- [1 .. 9], row <- [1 .. 9]]
`Set.difference` Map.keysSet sols
cells =
foldr
(\p -> Map.alter (Just . maybe (Left $ RemainingPossibilities $ listRemainings p) id) p)
(Right <$> sols)
emptyCells
listRemainings p = allPossibilities `Set.difference` Set.unions (Set.fromList . mapMaybe (sols Map.!?) . Set.toList <$> areas p)
guard $ all (either (\(RemainingPossibilities xs) -> not $ Set.null xs) (const True)) cells
pure $ Board cells emptyCells
We go through each possible, if it's not in the solutions list, we go through the areas, collecting solutions to remove it from all the possible solutions.
The next step is to set a solution in the board, defined as follows:
setSolution p s board = do
let updateTarget ::
Maybe (Either RemainingPossibilities Solution) ->
Maybe (Maybe (Either RemainingPossibilities Solution))
updateTarget cellM = do
Left (RemainingPossibilities possibilities) <- cellM
guard $ Set.member s possibilities
pure $ Just $ Right s
cells0 <- Map.alterF updateTarget p board.cells
let updateInArea ::
Either RemainingPossibilities Solution ->
Maybe (Either RemainingPossibilities Solution)
updateInArea =
bimapM
removePossibility
(mfilter (/= s) . Just)
removePossibility (RemainingPossibilities ps) = do
let ps' = Set.delete s ps
guard $ not $ Set.null ps'
pure $ RemainingPossibilities ps'
cells1 <- foldM (flip $ Map.alterF $ maybe Nothing (fmap Just . updateInArea)) cells0 (Set.unions $ areas p)
pure $ Board cells1 (Set.delete p board.emptyCells)
It is a bit involved, as we check that the solution is in the remaining ones of the cell, if so, we update the remaining ones from the other cells of the areas.
Then, to iterate, we need to pick a position from the remaining empty cells, starting with the ones with the fewest remaining possibilities, as follows:
nextEmptyCell board =
listToMaybe $
sortOn (Set.size . (.unRemainingPossibilities) . snd) $
mapMaybe (\p -> (p,) <$> (board.cells Map.!? p >>= either Just (const Nothing))) $
Set.toList board.emptyCells
With all of these helpers, we can write a first solver which eliminate cells with only one possibility, as follows:
solveTrivial board = do
case nextEmptyCell board of
Just (p, RemainingPossibilities ps)
| Set.size ps == 1 ->
setSolution p (Set.findMin ps) board >>= solveTrivial
_ -> Just board
It could be enough for entry-level boards, but for some, we will need more advanced strategies.
We will start by running solveTrivial, then pick the next empty cell and try every possibility.
This is where we can use the regular list monad as follows:
-- We use the List monad to represent multiple possible search paths
solveList board = case solveTrivial board of
Nothing -> [] -- Constraint violation found by trivial solver
Just board' -> case nextEmptyCell board' of
Nothing -> [board'] -- No more empty cells: solution found!
Just (pos, possibilities) -> do
-- Non-deterministically pick a solution from the set
val <- Set.toList possibilities.unRemainingPossibilities
-- Try to set it. If it returns Nothing (invalid), the list monad
-- effectively 'kills' this branch (empty list).
case setSolution pos val board' of
Nothing -> []
Just next -> solveList next
The alternative version is to finally use Select, as follows:
solveSelect board = runSelect (go board) id
where
-- We select the Board that is the eventual result of the search.
-- The 'r' (return type of the judge) is Maybe Board.
go board = case solveTrivial board of
Nothing -> pure Nothing -- Should not happen if logic is correct
Just board' -> case nextEmptyCell board' of
Nothing -> pure (Just board') -- Base case: Success
Just (pos, possibilities) -> do
-- The 'select' call captures the rest of the 'solveSelect' ('go')
-- recursion as the 'judge' function.
val <- select $ \judge ->
-- The judge :: Maybe Solution -> Maybe Board
-- It tells us: "If you pick this Solution, here is the final outcome."
let candidates = Set.toList possibilities.unRemainingPossibilities
in -- Find the first candidate that results in a solved board (Just)
find (isJust . judge . Just) candidates
-- Now we execute the path with the value we selected.
case val >>= \val' -> setSolution pos val' board' of
Nothing -> pure Nothing
Just next -> go next
Leveraging Select is supposed to help improve when the solution of a problem is dependent on upcoming sub-parts of this problem. Let's take a look at performances:
benchmarking Sudoku/ListT
time 416.1 ms (376.2 ms .. 455.1 ms)
0.999 R² (0.996 R² .. 1.000 R²)
mean 409.4 ms (403.6 ms .. 418.0 ms)
std dev 8.178 ms (242.5 μs .. 10.13 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking Sudoku/SelectT
time 2.912 s (2.793 s .. 2.977 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 2.779 s (2.712 s .. 2.835 s)
std dev 69.32 ms (39.40 ms .. 89.73 ms)
variance introduced by outliers: 19% (moderately inflated)
Well, pretty disappointing.
I have few hypotheses at this point:
- I did not use it correctly; I'm injecting
id, making the use ofSelectuseless Selectis great at injecting filters, disregarding the performances- This implementation of Sudoku is not a good fit