{-# OPTIONS_GHC -Wall -Werror #-}
module Documentation.SBV.Examples.Puzzles.Sudoku where
import Data.List (transpose)
import Data.Maybe (fromJust)
import Data.SBV
type Row = [SWord8]
type Board = [Row]
check :: [SWord8] -> SBool
check :: [SWord8] -> SBool
check [SWord8]
grp = [SBool] -> SBool
sAnd forall a b. (a -> b) -> a -> b
$ forall a. EqSymbolic a => [a] -> SBool
distinct [SWord8]
grp forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (OrdSymbolic a, Num a) => a -> SBool
rangeFine [SWord8]
grp
where rangeFine :: a -> SBool
rangeFine a
x = a
x forall a. OrdSymbolic a => a -> a -> SBool
.> a
0 SBool -> SBool -> SBool
.&& a
x forall a. OrdSymbolic a => a -> a -> SBool
.<= a
9
valid :: Board -> SBool
valid :: Board -> SBool
valid Board
rows = [SBool] -> SBool
sAnd forall a b. (a -> b) -> a -> b
$ forall a. SymVal a => a -> SBV a
literal Bool
sizesOK forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map [SWord8] -> SBool
check (Board
rows forall a. [a] -> [a] -> [a]
++ Board
columns forall a. [a] -> [a] -> [a]
++ Board
squares)
where sizesOK :: Bool
sizesOK = forall (t :: * -> *) a. Foldable t => t a -> Int
length Board
rows forall a. Eq a => a -> a -> Bool
== Int
9 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[SWord8]
r -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [SWord8]
r forall a. Eq a => a -> a -> Bool
== Int
9) Board
rows
columns :: Board
columns = forall a. [[a]] -> [[a]]
transpose Board
rows
regions :: [Board]
regions = forall a. [[a]] -> [[a]]
transpose [forall a. Int -> [a] -> [[a]]
chunk Int
3 [SWord8]
row | [SWord8]
row <- Board
rows]
squares :: Board
squares = [forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Board
sq | Board
sq <- forall a. Int -> [a] -> [[a]]
chunk Int
3 (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Board]
regions)]
chunk :: Int -> [a] -> [[a]]
chunk :: forall a. Int -> [a] -> [[a]]
chunk Int
_ [] = []
chunk Int
i [a]
xs = let ([a]
f, [a]
r) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs in [a]
f forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [[a]]
chunk Int
i [a]
r
type Puzzle = (Int, [SWord8] -> Board)
sudoku :: Puzzle -> IO ()
sudoku :: Puzzle -> IO ()
sudoku p :: Puzzle
p@(Int
i, [SWord8] -> Board
f) = do String -> IO ()
putStrLn String
"Solving the puzzle.."
Either String (Bool, [Word8])
model <- forall a b.
(Modelable a, SatModel b) =>
a -> Either String (Bool, b)
getModelAssignment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. Provable a => a -> IO SatResult
sat ((Board -> SBool
valid forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SWord8] -> Board
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. SymVal a => Int -> Symbolic [SBV a]
mkExistVars Int
i)
case Either String (Bool, [Word8])
model of
Right (Bool, [Word8])
sln -> Puzzle -> (Bool, [Word8]) -> IO ()
dispSolution Puzzle
p (Bool, [Word8])
sln
Left String
m -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Unsolvable puzzle: " forall a. [a] -> [a] -> [a]
++ String
m
dispSolution :: Puzzle -> (Bool, [Word8]) -> IO ()
dispSolution :: Puzzle -> (Bool, [Word8]) -> IO ()
dispSolution (Int
i, [SWord8] -> Board
f) (Bool
_, [Word8]
fs)
| Int
lmod forall a. Eq a => a -> a -> Bool
/= Int
i = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible! Backend solver returned " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
lmod forall a. [a] -> [a] -> [a]
++ String
" values, was expecting: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
| Bool
True = do String -> IO ()
putStrLn String
"Final board:"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {t :: * -> *} {a}.
(Foldable t, Show a, SymVal a) =>
t (SBV a) -> IO ()
printRow Board
final
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Valid Check: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Board -> SBool
valid Board
final)
String -> IO ()
putStrLn String
"Done."
where lmod :: Int
lmod = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
fs
final :: Board
final = [SWord8] -> Board
f (forall a b. (a -> b) -> [a] -> [b]
map forall a. SymVal a => a -> SBV a
literal [Word8]
fs)
printRow :: t (SBV a) -> IO ()
printRow t (SBV a)
r = String -> IO ()
putStr String
" " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\SBV a
x -> String -> IO ()
putStr (forall a. Show a => a -> String
show (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. SymVal a => SBV a -> Maybe a
unliteral SBV a
x)) forall a. [a] -> [a] -> [a]
++ String
" ")) t (SBV a)
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
""
solveAll :: Puzzle -> IO ()
solveAll :: Puzzle -> IO ()
solveAll p :: Puzzle
p@(Int
i, [SWord8] -> Board
f) = do String -> IO ()
putStrLn String
"Finding all solutions.."
AllSatResult
res <- forall a. Provable a => a -> IO AllSatResult
allSat forall a b. (a -> b) -> a -> b
$ (Board -> SBool
valid forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SWord8] -> Board
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. SymVal a => Int -> Symbolic [SBV a]
mkExistVars Int
i
Int
cnt <- forall a.
SatModel a =>
([(Bool, a)] -> [(Bool, a)])
-> (Int -> (Bool, a) -> IO ()) -> AllSatResult -> IO Int
displayModels forall a. a -> a
id forall {a}. Show a => a -> (Bool, [Word8]) -> IO ()
disp AllSatResult
res
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
cnt forall a. [a] -> [a] -> [a]
++ String
" solution(s)."
where disp :: a -> (Bool, [Word8]) -> IO ()
disp a
n (Bool, [Word8])
s = do String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Solution #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n
Puzzle -> (Bool, [Word8]) -> IO ()
dispSolution Puzzle
p (Bool, [Word8])
s
puzzle0 :: Puzzle
puzzle0 :: Puzzle
puzzle0 = (Int
81, forall {a}. [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a1, a
a2, a
a3, a
a4, a
a5, a
a6, a
a7, a
a8, a
a9,
a
b1, a
b2, a
b3, a
b4, a
b5, a
b6, a
b7, a
b8, a
b9,
a
c1, a
c2, a
c3, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9,
a
d1, a
d2, a
d3, a
d4, a
d5, a
d6, a
d7, a
d8, a
d9,
a
e1, a
e2, a
e3, a
e4, a
e5, a
e6, a
e7, a
e8, a
e9,
a
f1, a
f2, a
f3, a
f4, a
f5, a
f6, a
f7, a
f8, a
f9,
a
g1, a
g2, a
g3, a
g4, a
g5, a
g6, a
g7, a
g8, a
g9,
a
h1, a
h2, a
h3, a
h4, a
h5, a
h6, a
h7, a
h8, a
h9,
a
i1, a
i2, a
i3, a
i4, a
i5, a
i6, a
i7, a
i8, a
i9 ]
= [ [a
a1, a
a2, a
a3, a
a4, a
a5, a
a6, a
a7, a
a8, a
a9],
[a
b1, a
b2, a
b3, a
b4, a
b5, a
b6, a
b7, a
b8, a
b9],
[a
c1, a
c2, a
c3, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9],
[a
d1, a
d2, a
d3, a
d4, a
d5, a
d6, a
d7, a
d8, a
d9],
[a
e1, a
e2, a
e3, a
e4, a
e5, a
e6, a
e7, a
e8, a
e9],
[a
f1, a
f2, a
f3, a
f4, a
f5, a
f6, a
f7, a
f8, a
f9],
[a
g1, a
g2, a
g3, a
g4, a
g5, a
g6, a
g7, a
g8, a
g9],
[a
h1, a
h2, a
h3, a
h4, a
h5, a
h6, a
h7, a
h8, a
h9],
[a
i1, a
i2, a
i3, a
i4, a
i5, a
i6, a
i7, a
i8, a
i9] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle0 needs exactly 81 elements!"
puzzle1 :: Puzzle
puzzle1 :: Puzzle
puzzle1 = (Int
49, forall {a}. Num a => [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a1, a
a3, a
a4, a
a5, a
a6, a
a7, a
a9,
a
b1, a
b2, a
b3, a
b7, a
b8, a
b9,
a
c2, a
c4, a
c5, a
c6, a
c8,
a
d3, a
d5, a
d7,
a
e1, a
e2, a
e4, a
e5, a
e6, a
e8, a
e9,
a
f3, a
f5, a
f7,
a
g2, a
g4, a
g5, a
g6, a
g8,
a
h1, a
h2, a
h3, a
h7, a
h8, a
h9,
a
i1, a
i3, a
i4, a
i5, a
i6, a
i7, a
i9 ]
= [ [a
a1, a
6, a
a3, a
a4, a
a5, a
a6, a
a7, a
1, a
a9],
[a
b1, a
b2, a
b3, a
6, a
5, a
1, a
b7, a
b8, a
b9],
[ a
1, a
c2, a
7, a
c4, a
c5, a
c6, a
6, a
c8, a
2],
[ a
6, a
2, a
d3, a
3, a
d5, a
5, a
d7, a
9, a
4],
[a
e1, a
e2, a
3, a
e4, a
e5, a
e6, a
2, a
e8, a
e9],
[ a
4, a
8, a
f3, a
9, a
f5, a
7, a
f7, a
3, a
6],
[ a
9, a
g2, a
6, a
g4, a
g5, a
g6, a
4, a
g8, a
8],
[a
h1, a
h2, a
h3, a
7, a
9, a
4, a
h7, a
h8, a
h9],
[a
i1, a
5, a
i3, a
i4, a
i5, a
i6, a
i7, a
7, a
i9] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle1 needs exactly 49 elements!"
puzzle2 :: Puzzle
puzzle2 :: Puzzle
puzzle2 = (Int
55, forall {a}. Num a => [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a2, a
a4, a
a5, a
a6, a
a7, a
a9,
a
b1, a
b2, a
b4, a
b7, a
b8, a
b9,
a
c1, a
c3, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9,
a
d2, a
d3, a
d4, a
d8, a
d9,
a
e1, a
e3, a
e5, a
e7, a
e9,
a
f1, a
f2, a
f6, a
f7, a
f8,
a
g1, a
g2, a
g3, a
g4, a
g5, a
g6, a
g7, a
g9,
a
h1, a
h2, a
h3, a
h6, a
h8, a
h9,
a
i1, a
i3, a
i4, a
i5, a
i6, a
i8 ]
= [ [ a
1, a
a2, a
3, a
a4, a
a5, a
a6, a
a7, a
8, a
a9],
[a
b1, a
b2, a
6, a
b4, a
4, a
8, a
b7, a
b8, a
b9],
[a
c1, a
4, a
c3, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9],
[ a
2, a
d2, a
d3, a
d4, a
9, a
6, a
1, a
d8, a
d9],
[a
e1, a
9, a
e3, a
8, a
e5, a
1, a
e7, a
4, a
e9],
[a
f1, a
f2, a
4, a
3, a
2, a
f6, a
f7, a
f8, a
8],
[a
g1, a
g2, a
g3, a
g4, a
g5, a
g6, a
g7, a
7, a
g9],
[a
h1, a
h2, a
h3, a
1, a
5, a
h6, a
4, a
h8, a
h9],
[a
i1, a
6, a
i3, a
i4, a
i5, a
i6, a
2, a
i8, a
3] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle2 needs exactly 55 elements!"
puzzle3 :: Puzzle
puzzle3 :: Puzzle
puzzle3 = (Int
56, forall {a}. Num a => [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a2, a
a3, a
a4, a
a6, a
a8, a
a9,
a
b2, a
b4, a
b5, a
b6, a
b7, a
b8, a
b9,
a
c1, a
c2, a
c3, a
c4, a
c6, a
c7, a
c9,
a
d1, a
d3, a
d5, a
d7, a
d9,
a
e2, a
e3, a
e4, a
e6, a
e7, a
e8,
a
f1, a
f3, a
f5, a
f7, a
f9,
a
g1, a
g3, a
g4, a
g6, a
g7, a
g8, a
g9,
a
h1, a
h2, a
h3, a
h4, a
h5, a
h6, a
h8,
a
i1, a
i2, a
i4, a
i6, a
i7, a
i8 ]
= [ [ a
6, a
a2, a
a3, a
a4, a
1, a
a6, a
5, a
a8, a
a9],
[ a
8, a
b2, a
3, a
b4, a
b5, a
b6, a
b7, a
b8, a
b9],
[a
c1, a
c2, a
c3, a
c4, a
6, a
c6, a
c7, a
2, a
c9],
[a
d1, a
3, a
d3, a
1, a
d5, a
8, a
d7, a
9, a
d9],
[ a
1, a
e2, a
e3, a
e4, a
9, a
e6, a
e7, a
e8, a
4],
[a
f1, a
5, a
f3, a
2, a
f5, a
3, a
f7, a
1, a
f9],
[a
g1, a
7, a
g3, a
g4, a
3, a
g6, a
g7, a
g8, a
g9],
[a
h1, a
h2, a
h3, a
h4, a
h5, a
h6, a
3, a
h8, a
6],
[a
i1, a
i2, a
4, a
i4, a
5, a
i6, a
i7, a
i8, a
9] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle3 needs exactly 56 elements!"
puzzle4 :: Puzzle
puzzle4 :: Puzzle
puzzle4 = (Int
58, forall {a}. Num a => [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a2, a
a3, a
a4, a
a5, a
a7, a
a9,
a
b1, a
b3, a
b4, a
b6, a
b7, a
b8,
a
c1, a
c2, a
c5, a
c6, a
c8, a
c9,
a
d1, a
d2, a
d5, a
d6, a
d8, a
d9,
a
e1, a
e3, a
e4, a
e6, a
e7, a
e8,
a
f2, a
f3, a
f4, a
f5, a
f7, a
f8, a
f9,
a
g2, a
g3, a
g4, a
g5, a
g6, a
g7, a
g9,
a
h1, a
h3, a
h4, a
h5, a
h6, a
h7, a
h8,
a
i1, a
i2, a
i4, a
i5, a
i6, a
i8, a
i9 ]
= [ [ a
1, a
a2, a
a3, a
a4, a
a5, a
7, a
a7, a
9, a
a9],
[a
b1, a
3, a
b3, a
b4, a
2, a
b6, a
b7, a
b8, a
8],
[a
c1, a
c2, a
9, a
6, a
c5, a
c6, a
5, a
c8, a
c9],
[a
d1, a
d2, a
5, a
3, a
d5, a
d6, a
9, a
d8, a
d9],
[a
e1, a
1, a
e3, a
e4, a
8, a
e6, a
e7, a
e8, a
2],
[ a
6, a
f2, a
f3, a
f4, a
f5, a
4, a
f7, a
f8, a
f9],
[ a
3, a
g2, a
g3, a
g4, a
g5, a
g6, a
g7, a
1, a
g9],
[a
h1, a
4, a
h3, a
h4, a
h5, a
h6, a
h7, a
h8, a
7],
[a
i1, a
i2, a
7, a
i4, a
i5, a
i6, a
3, a
i8, a
i9] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle4 needs exactly 58 elements!"
puzzle5 :: Puzzle
puzzle5 :: Puzzle
puzzle5 = (Int
53, forall {a}. Num a => [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a1, a
a3, a
a5, a
a6, a
a9,
a
b1, a
b4, a
b5, a
b7, a
b9,
a
c2, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9,
a
d1, a
d2, a
d4, a
d6, a
d7, a
d8,
a
e1, a
e2, a
e3, a
e5, a
e7, a
e8, a
e9,
a
f2, a
f3, a
f4, a
f6, a
f8, a
f9,
a
g1, a
g2, a
g3, a
g4, a
g5, a
g6, a
g8,
a
h1, a
h3, a
h5, a
h6, a
h9,
a
i1, a
i4, a
i5, a
i7, a
i9 ]
= [ [a
a1, a
9, a
a3, a
7, a
a5, a
a6, a
8, a
6, a
a9],
[a
b1, a
3, a
1, a
b4, a
b5, a
5, a
b7, a
2, a
b9],
[ a
8, a
c2, a
6, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9],
[a
d1, a
d2, a
7, a
d4, a
5, a
d6, a
d7, a
d8, a
6],
[a
e1, a
e2, a
e3, a
3, a
e5, a
7, a
e7, a
e8, a
e9],
[ a
5, a
f2, a
f3, a
f4, a
1, a
f6, a
7, a
f8, a
f9],
[a
g1, a
g2, a
g3, a
g4, a
g5, a
g6, a
1, a
g8, a
9],
[a
h1, a
2, a
h3, a
6, a
h5, a
h6, a
3, a
5, a
h9],
[a
i1, a
5, a
4, a
i4, a
i5, a
8, a
i7, a
7, a
i9] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle5 needs exactly 53 elements!"
puzzle6 :: Puzzle
puzzle6 :: Puzzle
puzzle6 = (Int
64, forall {a}. Num a => [a] -> [[a]]
f)
where f :: [a] -> [[a]]
f [ a
a1, a
a2, a
a3, a
a4, a
a6, a
a7, a
a9,
a
b1, a
b3, a
b4, a
b5, a
b6, a
b7, a
b8, a
b9,
a
c1, a
c2, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9,
a
d1, a
d3, a
d4, a
d5, a
d6, a
d8,
a
e2, a
e3, a
e4, a
e6, a
e7, a
e8, a
e9,
a
f1, a
f2, a
f3, a
f4, a
f5, a
f6, a
f8, a
f9,
a
g1, a
g2, a
g5, a
g7, a
g8, a
g9,
a
h2, a
h3, a
h5, a
h6, a
h8, a
h9,
a
i1, a
i2, a
i3, a
i4, a
i5, a
i6, a
i7, a
i9 ]
= [ [a
a1, a
a2, a
a3, a
a4, a
6, a
a6, a
a7, a
8, a
a9],
[a
b1, a
2, a
b3, a
b4, a
b5, a
b6, a
b7, a
b8, a
b9],
[a
c1, a
c2, a
1, a
c4, a
c5, a
c6, a
c7, a
c8, a
c9],
[a
d1, a
7, a
d3, a
d4, a
d5, a
d6, a
1, a
d8, a
2],
[ a
5, a
e2, a
e3, a
e4, a
3, a
e6, a
e7, a
e8, a
e9],
[a
f1, a
f2, a
f3, a
f4, a
f5, a
f6, a
4, a
f8, a
f9],
[a
g1, a
g2, a
4, a
2, a
g5, a
1, a
g7, a
g8, a
g9],
[ a
3, a
h2, a
h3, a
7, a
h5, a
h6, a
6, a
h8, a
h9],
[a
i1, a
i2, a
i3, a
i4, a
i5, a
i6, a
i7, a
5, a
i9] ]
f [a]
_ = forall a. HasCallStack => String -> a
error String
"puzzle6 needs exactly 64 elements!"
allPuzzles :: IO ()
allPuzzles :: IO ()
allPuzzles = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Puzzle -> IO ()
sudoku [Puzzle
puzzle0, Puzzle
puzzle1, Puzzle
puzzle2, Puzzle
puzzle3, Puzzle
puzzle4, Puzzle
puzzle5, Puzzle
puzzle6]