{- |
Description: Sudoku
Copyright: Copyright (C) 2023 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P97" of Ninety-Nine Haskell "Problems".
-}
module Solutions.P97 (sudoku, randomSudoku) where

import           Data.Array    (Array, array)
import qualified Data.Array    as Array
import           Data.Ix       (inRange)
import           Data.List     (sortOn)
import qualified Data.List     as List
import           Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import           Data.Maybe    (isNothing, mapMaybe)
import           Data.Set      (Set)
import qualified Data.Set      as Set
import           System.Random

{- | Returns a solution for a given Sudoku puzzle.

Both will be expressed as a list of 9 rows.
Each row will be a list of 9 numbers from 0 to 9, where 0 signifies a blank spot.
-}
sudoku :: [[Int]] -> Maybe [[Int]]
sudoku :: [[Int]] -> Maybe [[Int]]
sudoku [[Int]]
puzzle = (Maybe [[Int]], StdGen) -> Maybe [[Int]]
forall a b. (a, b) -> a
fst ((Maybe [[Int]], StdGen) -> Maybe [[Int]])
-> (Maybe [[Int]], StdGen) -> Maybe [[Int]]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> StdGen -> (Maybe [[Int]], StdGen)
forall g. RandomGen g => [[Int]] -> g -> (Maybe [[Int]], g)
randomSudoku [[Int]]
puzzle StdGen
gen
  where gen :: StdGen
gen = Int -> StdGen
mkStdGen Int
111111  -- arbitrary but deterministic

-- | Solves Sudoku puzzles.
--
-- Uses the given source of randomness when choosing among multiple possibilities.
-- This underlies the 'sudoku' function, which uses a fixed source of randomness.
--
-- The overall approach is thus:
--
-- 1. Prune possible values for blank spots so that values which are not possible
--    are pruned.  This is determined by what numbers have been definitely determined
--    for other positions in the same row, column, and square.
--
--      * Some blank spots may end up with a single possible value.
--        In this case, it has become a position with a definite value.
--
-- 2. Repeat pruning until there are no more possibilities to be pruned.
--    If all positions have definite values, we have found a solution.
--
-- 3. If we can't prune enough possibilities to get a solution,
--    pick a random position.  For each of its possible values,
--    pretend it is definite, i.e., part of the solution,
--    and repeat the pruning from step 1.
randomSudoku :: RandomGen g => [[Int]] -> g -> (Maybe [[Int]], g)
randomSudoku :: forall g. RandomGen g => [[Int]] -> g -> (Maybe [[Int]], g)
randomSudoku [[Int]]
puzzle g
gen
  | Bool
valid     = ((Board -> [[Int]]) -> Maybe Board -> Maybe [[Int]]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Board -> [[Int]]
fromBoard Maybe Board
solution, g
gen')
  | Bool
otherwise = (Maybe [[Int]]
forall a. Maybe a
Nothing, g
gen)
  where (Maybe Board
solution, g
gen') = Board -> Pending -> g -> (Maybe Board, g)
forall g. RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
solve Board
board Pending
pending g
gen
        (Board
board, Pending
pending) = [[Int]] -> (Board, Pending)
toBoard [[Int]]
puzzle
        valid :: Bool
valid = Bool
validNumbers Bool -> Bool -> Bool
&& Bool
validSize Bool -> Bool -> Bool
&& Board -> Pending -> Bool
validateConflicts Board
board Pending
pending
        validSize :: Bool
validSize = ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
puzzle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9) Bool -> Bool -> Bool
&& ([Int] -> Bool) -> [[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int
9 ==) (Int -> Bool) -> ([Int] -> Int) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[Int]]
puzzle
        validNumbers :: Bool
validNumbers = ([Int] -> Bool) -> [[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Bool) -> [Int] -> Bool) -> (Int -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
0,Int
9)) [[Int]]
puzzle

-- | Stores the definite value for each position that has one.
type Board = Array (Int,Int) (Maybe Int)

-- | Maps positions to its multiple possible values.
-- Intended to hold positions that are still blank, not all positions.
type Pending = Map (Int,Int) (Set Int)

-- | Converts a puzzle or solution represented as a Board into a list of lists.
fromBoard :: Board -> [[Int]]
fromBoard :: Board -> [[Int]]
fromBoard Board
b = [ [Int]
l | Int
i <- [Int
1..Int
9], let l :: [Int]
l = [ Maybe Int -> Int
forall {a}. Num a => Maybe a -> a
toInt (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Board
b Board -> (Int, Int) -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i,Int
j) | Int
j <- [Int
1..Int
9] ] ]
  where toInt :: Maybe a -> a
toInt Maybe a
Nothing  = a
0
        toInt (Just a
n) = a
n

-- | Turn the list of lists into a form more convenient to finding a solution.
toBoard :: [[Int]] -> (Board, Pending)
toBoard :: [[Int]] -> (Board, Pending)
toBoard [[Int]]
p = (((Int, Int), (Int, Int)) -> [((Int, Int), Maybe Int)] -> Board
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array ((Int
1,Int
1), (Int
9,Int
9)) [((Int, Int), Maybe Int)]
list, [((Int, Int), Maybe Int)] -> Pending
toPending [((Int, Int), Maybe Int)]
list)
  where list :: [((Int, Int), Maybe Int)]
list = [[Int]] -> [((Int, Int), Maybe Int)]
toBoardList [[Int]]
p

-- | Converts to association list for use by toBoard.
toBoardList :: [[Int]] -> [((Int, Int), Maybe Int)]
toBoardList :: [[Int]] -> [((Int, Int), Maybe Int)]
toBoardList [[Int]]
p = ((Int, [(Int, Int)]) -> [((Int, Int), Maybe Int)])
-> [(Int, [(Int, Int)])] -> [((Int, Int), Maybe Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
i, [(Int, Int)]
l) -> ((Int, Int) -> ((Int, Int), Maybe Int))
-> [(Int, Int)] -> [((Int, Int), Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
j, Int
n) -> ((Int
i, Int
j), Int -> Maybe Int
forall {a}. (Eq a, Num a) => a -> Maybe a
maybeN Int
n)) [(Int, Int)]
l) [(Int, [(Int, Int)])]
indexed
  where indexed :: [(Int, [(Int, Int)])]
indexed = [Int] -> [[(Int, Int)]] -> [(Int, [(Int, Int)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..Int
9] ([[(Int, Int)]] -> [(Int, [(Int, Int)])])
-> [[(Int, Int)]] -> [(Int, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ ([Int] -> [(Int, Int)]) -> [[Int]] -> [[(Int, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..Int
9]) [[Int]]
p
        maybeN :: a -> Maybe a
maybeN a
0 = Maybe a
forall a. Maybe a
Nothing
        maybeN a
n = a -> Maybe a
forall a. a -> Maybe a
Just a
n

-- | Fill in the possibilities for blank spots.
toPending :: [((Int, Int), Maybe Int)] -> Pending
toPending :: [((Int, Int), Maybe Int)] -> Pending
toPending [((Int, Int), Maybe Int)]
list = [((Int, Int), Set Int)] -> Pending
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Int, Int), Set Int)] -> Pending)
-> [((Int, Int), Set Int)] -> Pending
forall a b. (a -> b) -> a -> b
$ (((Int, Int), Maybe Int) -> ((Int, Int), Set Int))
-> [((Int, Int), Maybe Int)] -> [((Int, Int), Set Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\((Int, Int)
pos, Maybe Int
_) -> ((Int, Int)
pos, [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int
1..Int
9])) [((Int, Int), Maybe Int)]
positions
  where positions :: [((Int, Int), Maybe Int)]
positions = (((Int, Int), Maybe Int) -> Bool)
-> [((Int, Int), Maybe Int)] -> [((Int, Int), Maybe Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((Int, Int)
_, Maybe Int
n) -> Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
n) [((Int, Int), Maybe Int)]
list

-- | Given a board with definite values and the possible values for blank spots,
-- search for a solution to the puzzle.
--
-- This is the high-level function doing the main work of finding a solution.
solve :: RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
solve :: forall g. RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
solve Board
b Pending
p g
gen
  | Bool
isImpossible   = (Maybe Board
forall a. Maybe a
Nothing, g
gen)
  | Bool
isSolution     = (Board -> Maybe Board
forall a. a -> Maybe a
Just (Board -> Maybe Board) -> Board -> Maybe Board
forall a b. (a -> b) -> a -> b
$ (Board, Pending) -> Board
forall a b. (a, b) -> a
fst ((Board, Pending) -> Board) -> (Board, Pending) -> Board
forall a b. (a -> b) -> a -> b
$ Board -> Pending -> (Board, Pending)
incorporatePending Board
b Pending
p, g
gen)
  -- Prune until there is nothing more to prune.
  | Bool
pruned         = Board -> Pending -> g -> (Maybe Board, g)
forall g. RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
solve Board
b Pending
p' g
gen
  -- We have reached a point where we cannot definitely prune possibilities.
  -- Try guessing which possibilities lead to a solution.
  | Bool
otherwise      = Board -> Pending -> g -> (Maybe Board, g)
forall g. RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
guess Board
b Pending
p' g
gen
  where (Pending
p', Bool
pruned) = Board -> Pending -> (Pending, Bool)
prune Board
b Pending
p
        isSolution :: Bool
isSolution = (Set Int -> Bool) -> Pending -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
1 (Int -> Bool) -> (Set Int -> Int) -> Set Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> Int
forall a. Set a -> Int
Set.size) Pending
p
        isImpossible :: Bool
isImpossible = (Set Int -> Bool) -> Pending -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Set Int -> Bool
forall a. Set a -> Bool
Set.null Pending
p

-- | Verifies that no positions with a definite value are inconsistent with a solution.
-- I.e., that there are no other positions in the same row, column, or square with the same definite value.
validateConflicts :: Board -> Pending -> Bool
validateConflicts :: Board -> Pending -> Bool
validateConflicts Board
b Pending
p = ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int, Int)
e -> (Int, Int) -> Maybe Int -> Bool
validatePosition (Int, Int)
e (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ Board
b Board -> (Int, Int) -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int, Int)
e) ([(Int, Int)] -> Bool) -> [(Int, Int)] -> Bool
forall a b. (a -> b) -> a -> b
$ Board -> [(Int, Int)]
forall i e. Ix i => Array i e -> [i]
Array.indices Board
b
  where validatePosition :: (Int, Int) -> Maybe Int -> Bool
validatePosition (Int, Int)
_ Maybe Int
Nothing  = Bool
True
        validatePosition (Int, Int)
e (Just Int
n) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Int
n (Set Int -> Bool) -> Set Int -> Bool
forall a b. (a -> b) -> a -> b
$ Board -> Pending -> (Int, Int) -> Set Int
conflicting Board
b Pending
p (Int, Int)
e

-- | Incorporate pending positions with definite values into the board itself.
-- Returns the resulting board and the pending positions which remain.
incorporatePending :: Board -> Pending -> (Board, Pending)
incorporatePending :: Board -> Pending -> (Board, Pending)
incorporatePending Board
b Pending
p = (Board
b Board -> [((Int, Int), Maybe Int)] -> Board
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
Array.// [((Int, Int), Maybe Int)]
assocs', Pending
p')
  where ([((Int, Int), Maybe Int)]
assocs', Pending
p') = (([((Int, Int), Maybe Int)], Pending)
 -> (Int, Int) -> Set Int -> ([((Int, Int), Maybe Int)], Pending))
-> ([((Int, Int), Maybe Int)], Pending)
-> Pending
-> ([((Int, Int), Maybe Int)], Pending)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey ([((Int, Int), Maybe Int)], Pending)
-> (Int, Int) -> Set Int -> ([((Int, Int), Maybe Int)], Pending)
forall {k} {a} {a}.
Ord k =>
([(k, Maybe a)], Map k a)
-> k -> Set a -> ([(k, Maybe a)], Map k a)
incorporate ([], Pending
p) Pending
p
        incorporate :: ([(k, Maybe a)], Map k a)
-> k -> Set a -> ([(k, Maybe a)], Map k a)
incorporate ([(k, Maybe a)]
assocs'', Map k a
p'') k
e Set a
cs
          | Set a -> Int
forall a. Set a -> Int
Set.size Set a
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = ((k
e, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Set a -> a
forall a. Set a -> a
Set.findMin Set a
cs) (k, Maybe a) -> [(k, Maybe a)] -> [(k, Maybe a)]
forall a. a -> [a] -> [a]
: [(k, Maybe a)]
assocs'', k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
e Map k a
p'')
          | Bool
otherwise        = ([(k, Maybe a)]
assocs'', Map k a
p'')

-- | Prune possible values which cannot lead to a solution.
-- I.e., values which already exist in the same row, column, or square.
--
-- Also returns a boolean value signaling whether anything has been pruned.
prune :: Board -> Pending -> (Pending, Bool)
prune :: Board -> Pending -> (Pending, Bool)
prune Board
b Pending
p = ((Pending, Bool) -> (Int, Int) -> Set Int -> (Pending, Bool))
-> (Pending, Bool) -> Pending -> (Pending, Bool)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey (Pending, Bool) -> (Int, Int) -> Set Int -> (Pending, Bool)
step (Pending
p, Bool
False) Pending
p
  where step :: (Pending, Bool) -> (Int, Int) -> Set Int -> (Pending, Bool)
step s :: (Pending, Bool)
s@(Pending
p', Bool
_) (Int, Int)
e Set Int
cs = (Pending, Bool) -> (Pending, Bool) -> (Pending, Bool)
forall {a} {a}. (a, Bool) -> (a, Bool) -> (a, Bool)
merge (Pending, Bool)
s ((Pending, Bool) -> (Pending, Bool))
-> (Pending, Bool) -> (Pending, Bool)
forall a b. (a -> b) -> a -> b
$ Board -> Pending -> (Int, Int) -> Set Int -> (Pending, Bool)
prunePosition Board
b Pending
p' (Int, Int)
e Set Int
cs
        merge :: (a, Bool) -> (a, Bool) -> (a, Bool)
merge (a
_, Bool
changed) (a
p', Bool
changed') = (a
p', Bool
changed Bool -> Bool -> Bool
|| Bool
changed')

-- | Prune possible values for a particular position.
--
-- Also returns a boolean value signaling whether anything has been pruned.
prunePosition :: Board -> Pending -> (Int,Int) -> Set Int -> (Pending, Bool)
prunePosition :: Board -> Pending -> (Int, Int) -> Set Int -> (Pending, Bool)
prunePosition Board
b Pending
p (Int, Int)
e Set Int
candidates
  | Set Int
candidates Set Int -> Set Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set Int
candidates' = (Pending
p, Bool
False)
  | Bool
otherwise                 = (Pending
p', Bool
True)
  where candidates' :: Set Int
candidates' = Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Int
candidates (Set Int -> Set Int) -> Set Int -> Set Int
forall a b. (a -> b) -> a -> b
$ Board -> Pending -> (Int, Int) -> Set Int
conflicting Board
b Pending
p (Int, Int)
e
        p' :: Pending
p' = (Int, Int) -> Set Int -> Pending -> Pending
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Int, Int)
e Set Int
candidates' Pending
p

-- | Collect values that exist in the same row, column, or square.
conflicting :: Board -> Pending -> (Int,Int) -> Set Int
conflicting :: Board -> Pending -> (Int, Int) -> Set Int
conflicting Board
b Pending
p (Int, Int)
e = [Set Int] -> Set Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Int] -> Set Int) -> [Set Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ ((Board -> Pending -> (Int, Int) -> Set Int) -> Set Int)
-> [Board -> Pending -> (Int, Int) -> Set Int] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Board -> Pending -> (Int, Int) -> Set Int
f -> Board -> Pending -> (Int, Int) -> Set Int
f Board
b Pending
p (Int, Int)
e) [Board -> Pending -> (Int, Int) -> Set Int
definiteInRow, Board -> Pending -> (Int, Int) -> Set Int
definiteInColumn, Board -> Pending -> (Int, Int) -> Set Int
definiteInSquare]

-- | Definite values in the same row.
definiteInRow :: Board -> Pending -> (Int,Int) -> Set Int
definiteInRow :: Board -> Pending -> (Int, Int) -> Set Int
definiteInRow Board
b Pending
p (Int, Int)
e = Board -> Pending -> [(Int, Int)] -> Set Int
getDefinite Board
b Pending
p ([(Int, Int)] -> Set Int) -> [(Int, Int)] -> Set Int
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [(Int, Int)]
rowPositions Map (Int, Int) [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
forall k a. Ord k => Map k a -> k -> a
Map.! (Int, Int)
e

-- | Definite values in the same column.
definiteInColumn :: Board -> Pending -> (Int,Int) -> Set Int
definiteInColumn :: Board -> Pending -> (Int, Int) -> Set Int
definiteInColumn Board
b Pending
p (Int, Int)
e = Board -> Pending -> [(Int, Int)] -> Set Int
getDefinite Board
b Pending
p ([(Int, Int)] -> Set Int) -> [(Int, Int)] -> Set Int
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [(Int, Int)]
columnPositions Map (Int, Int) [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
forall k a. Ord k => Map k a -> k -> a
Map.! (Int, Int)
e

-- | Definite values in the same square.
definiteInSquare :: Board -> Pending -> (Int,Int) -> Set Int
definiteInSquare :: Board -> Pending -> (Int, Int) -> Set Int
definiteInSquare Board
b Pending
p (Int, Int)
e = Board -> Pending -> [(Int, Int)] -> Set Int
getDefinite Board
b Pending
p ([(Int, Int)] -> Set Int) -> [(Int, Int)] -> Set Int
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [(Int, Int)]
squarePositions Map (Int, Int) [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
forall k a. Ord k => Map k a -> k -> a
Map.! (Int, Int)
e

-- | Collects the definite values from the given positions.
getDefinite :: Board -> Pending -> [(Int,Int)] -> Set Int
getDefinite :: Board -> Pending -> [(Int, Int)] -> Set Int
getDefinite Board
b Pending
p [(Int, Int)]
l = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int) -> [Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Maybe Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Board -> Pending -> (Int, Int) -> Maybe Int
lookupDefinite Board
b Pending
p) [(Int, Int)]
l

-- | Returns a definite value from a position.
-- If the position does not have a definite value, returns Nothing.
lookupDefinite :: Board -> Pending -> (Int,Int) -> Maybe Int
lookupDefinite :: Board -> Pending -> (Int, Int) -> Maybe Int
lookupDefinite Board
b Pending
p (Int, Int)
e = Maybe Int -> Maybe Int
onBoard (Board
b Board -> (Int, Int) -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int, Int)
e)
  where onBoard :: Maybe Int -> Maybe Int
onBoard Maybe Int
Nothing  = Maybe (Set Int) -> Maybe Int
forall {a}. Maybe (Set a) -> Maybe a
onPending (Maybe (Set Int) -> Maybe Int) -> Maybe (Set Int) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Pending -> Maybe (Set Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int, Int)
e Pending
p
        onBoard (Just Int
n) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
        onPending :: Maybe (Set a) -> Maybe a
onPending Maybe (Set a)
Nothing = Maybe a
forall a. Maybe a
Nothing
        onPending (Just Set a
s)
          | Set a -> Int
forall a. Set a -> Int
Set.size Set a
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Set a -> a
forall a. Set a -> a
Set.findMin Set a
s
          | Bool
otherwise       = Maybe a
forall a. Maybe a
Nothing

-- | For each position, maps the other positions which reside in the same row.
rowPositions :: Map (Int,Int) [(Int,Int)]
rowPositions :: Map (Int, Int) [(Int, Int)]
rowPositions =  [((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)])
-> [((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> ((Int, Int), [(Int, Int)]))
-> [(Int, Int)] -> [((Int, Int), [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int)
pos -> ((Int, Int)
pos, (Int, Int) -> [(Int, Int)]
forall {a} {t}. (Eq a, Num a, Enum a) => (t, a) -> [(t, a)]
row (Int, Int)
pos)) [(Int, Int)]
boardLocations
  where row :: (t, a) -> [(t, a)]
row (t
x,a
y) = (a -> (t, a)) -> [a] -> [(t, a)]
forall a b. (a -> b) -> [a] -> [b]
map (t
x,) ([a] -> [(t, a)]) -> [a] -> [(t, a)]
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
List.delete a
y [a
1..a
9]

-- | For each position, maps the other positions which reside in the same column.
columnPositions :: Map (Int,Int) [(Int,Int)]
columnPositions :: Map (Int, Int) [(Int, Int)]
columnPositions = [((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)])
-> [((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> ((Int, Int), [(Int, Int)]))
-> [(Int, Int)] -> [((Int, Int), [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int)
pos -> ((Int, Int)
pos, (Int, Int) -> [(Int, Int)]
forall {a} {t}. (Eq a, Num a, Enum a) => (a, t) -> [(a, t)]
column (Int, Int)
pos)) [(Int, Int)]
boardLocations
  where column :: (a, t) -> [(a, t)]
column (a
x,t
y) = (a -> (a, t)) -> [a] -> [(a, t)]
forall a b. (a -> b) -> [a] -> [b]
map (,t
y) ([a] -> [(a, t)]) -> [a] -> [(a, t)]
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
List.delete a
x [a
1..a
9]

-- | For each position, maps the other positions which reside in the same square.
squarePositions :: Map (Int,Int) [(Int,Int)]
squarePositions :: Map (Int, Int) [(Int, Int)]
squarePositions = [((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)])
-> [((Int, Int), [(Int, Int)])] -> Map (Int, Int) [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> ((Int, Int), [(Int, Int)]))
-> [(Int, Int)] -> [((Int, Int), [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int)
pos -> ((Int, Int)
pos, (Int, Int) -> [(Int, Int)]
forall {a} {b}. (Integral a, Integral b) => (a, b) -> [(a, b)]
xys (Int, Int)
pos)) [(Int, Int)]
boardLocations
  where xys :: (a, b) -> [(a, b)]
xys (a
x,b
y) = [(a
x',b
y') | a
x' <- a -> [a]
forall {a}. Integral a => a -> [a]
bucket a
x, b
y' <- b -> [b]
forall {a}. Integral a => a -> [a]
bucket b
y, (a
x',b
y') (a, b) -> (a, b) -> Bool
forall a. Eq a => a -> a -> Bool
/= (a
x,b
y)]
        bucket :: a -> [a]
bucket a
z = [a
3 a -> a -> a
forall a. Num a => a -> a -> a
* ((a
za -> a -> a
forall a. Num a => a -> a -> a
-a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
3) a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 .. a
3 a -> a -> a
forall a. Num a => a -> a -> a
* ((a
za -> a -> a
forall a. Num a => a -> a -> a
-a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
3) a -> a -> a
forall a. Num a => a -> a -> a
+ a
3]

boardLocations :: [(Int,Int)]
boardLocations :: [(Int, Int)]
boardLocations = [(Int
x,Int
y) | Int
x <- [Int
1..Int
9], Int
y <- [Int
1..Int
9]]

-- | When pruning no longer works, try guessing through possibilities at a random position.
guess :: RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
guess :: forall g. RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
guess Board
b Pending
p g
g
  | ((((Int, Int), Set Int)
candidate, (Int, Int)
_) : [(((Int, Int), Set Int), (Int, Int))]
_) <- [(((Int, Int), Set Int), (Int, Int))]
ranked = Board -> Pending -> ((Int, Int), Set Int) -> g -> (Maybe Board, g)
forall g.
RandomGen g =>
Board -> Pending -> ((Int, Int), Set Int) -> g -> (Maybe Board, g)
guessWithPosition Board
b' Pending
p' ((Int, Int), Set Int)
candidate g
g''
  | Bool
otherwise = (Maybe Board
forall a. Maybe a
Nothing, g
g'')
  where
    -- Incorporate possibilities that have become definite into the board itself.
    (Board
b', Pending
p') = Board -> Pending -> (Board, Pending)
incorporatePending Board
b Pending
p
    -- We will pick a position with the smallest number of possibilities to constrain the search space more.
    ranked :: [(((Int, Int), Set Int), (Int, Int))]
ranked = ((((Int, Int), Set Int), (Int, Int)) -> (Int, Int))
-> [(((Int, Int), Set Int), (Int, Int))]
-> [(((Int, Int), Set Int), (Int, Int))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (((Int, Int), Set Int), (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd [(((Int, Int), Set Int), (Int, Int))]
candidates
    -- Associate each position with a random number as well.  It will serve as a random tiebreaker.
    candidates :: [(((Int, Int), Set Int), (Int, Int))]
candidates = (((Int, Int), Set Int)
 -> Int -> (((Int, Int), Set Int), (Int, Int)))
-> [((Int, Int), Set Int)]
-> [Int]
-> [(((Int, Int), Set Int), (Int, Int))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((((Int, Int), Set Int), Int)
 -> (((Int, Int), Set Int), (Int, Int)))
-> ((Int, Int), Set Int)
-> Int
-> (((Int, Int), Set Int), (Int, Int))
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (\(((Int, Int)
e, Set Int
s), Int
r) -> (((Int, Int)
e, Set Int
s), (Set Int -> Int
forall a. Set a -> Int
Set.size Set Int
s, Int
r)))) (Pending -> [((Int, Int), Set Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Pending
p') (g -> [Int]
forall g. RandomGen g => g -> [Int]
forall a g. (Random a, RandomGen g) => g -> [a]
randoms g
g' :: [Int])
    (g
g', g
g'') = g -> (g, g)
forall g. RandomGen g => g -> (g, g)
split g
g

-- | Guess the definite value for a particular position which will result in a solution.
guessWithPosition :: RandomGen g => Board -> Pending -> ((Int,Int), Set Int) -> g -> (Maybe Board, g)
guessWithPosition :: forall g.
RandomGen g =>
Board -> Pending -> ((Int, Int), Set Int) -> g -> (Maybe Board, g)
guessWithPosition Board
b Pending
p ((Int, Int)
e,Set Int
s) g
g
  | Set Int -> Bool
forall a. Set a -> Bool
Set.null Set Int
s = (Maybe Board
forall a. Maybe a
Nothing, g
g)
  | Bool
otherwise  = (Maybe Board, g) -> (Maybe Board, g)
forall {g}. RandomGen g => (Maybe Board, g) -> (Maybe Board, g)
continue ((Maybe Board, g) -> (Maybe Board, g))
-> (Maybe Board, g) -> (Maybe Board, g)
forall a b. (a -> b) -> a -> b
$ Board -> Pending -> g -> (Maybe Board, g)
forall g. RandomGen g => Board -> Pending -> g -> (Maybe Board, g)
solve Board
b Pending
p' g
g'
  where (Int
i, g
g') = (Int, Int) -> g -> (Int, g)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Set Int -> Int
forall a. Set a -> Int
Set.size Set Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) g
g
        n :: Int
n = Int -> Set Int -> Int
forall a. Int -> Set a -> a
Set.elemAt Int
i Set Int
s
        s' :: Set Int
s' = Int -> Set Int -> Set Int
forall a. Int -> Set a -> Set a
Set.deleteAt Int
i Set Int
s
        p' :: Pending
p' = (Int, Int) -> Set Int -> Pending -> Pending
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Int, Int)
e (Int -> Set Int
forall a. a -> Set a
Set.singleton Int
n) Pending
p
        continue :: (Maybe Board, g) -> (Maybe Board, g)
continue (Maybe Board
Nothing, g
gen)  = Board -> Pending -> ((Int, Int), Set Int) -> g -> (Maybe Board, g)
forall g.
RandomGen g =>
Board -> Pending -> ((Int, Int), Set Int) -> g -> (Maybe Board, g)
guessWithPosition Board
b Pending
p ((Int, Int)
e, Set Int
s') g
gen
        continue (Maybe Board
solution, g
gen) = (Maybe Board
solution, g
gen)