1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
import Data.Maybe
import Data.List
import Data.Char
import Test.QuickCheck
data Sudoku = Sudoku [[Maybe Int]]
showElement :: Maybe Int -> String
showElement (Nothing) = "."
showElement (Just a) = show a
showSudoku :: Sudoku -> String
showSudoku (Sudoku s) = concatMap (\x->(concatMap showElement x)++"\n") s
instance Show Sudoku where
show = showSudoku
example :: Sudoku
example =
Sudoku
[ [Just 3, Just 6, Nothing,Nothing,Just 7, Just 1, Just 2, Nothing,Nothing]
, [Nothing,Just 5, Nothing,Nothing,Nothing,Nothing,Just 1, Just 8, Nothing]
, [Nothing,Nothing,Just 9, Just 2, Nothing,Just 4, Just 7, Nothing,Nothing]
, [Nothing,Nothing,Nothing,Nothing,Just 1, Just 3, Nothing,Just 2, Just 8]
, [Just 4, Nothing,Nothing,Just 5, Nothing,Just 2, Nothing,Nothing,Just 9]
, [Just 2, Just 7, Nothing,Just 4, Just 6, Nothing,Nothing,Nothing,Nothing]
, [Nothing,Nothing,Just 5, Just 3, Nothing,Just 8, Just 9, Nothing,Nothing]
, [Nothing,Just 8, Just 3, Nothing,Nothing,Nothing,Nothing,Just 6, Nothing]
, [Nothing,Nothing,Just 7, Just 6, Just 9, Nothing,Nothing,Just 4, Just 3]
]
-- rows extracts the actual rows from the Sudoku
rows :: Sudoku -> [[Maybe Int]]
rows (Sudoku rs) = rs
-- allBlankSudoku represents a Sudoku that only contains blank cells
allBlankSudoku :: Sudoku
allBlankSudoku = Sudoku $ take 9 (repeat ( take 9 (repeat Nothing) ))
-- isSudoku
isSudoku :: Sudoku -> Bool
isSudoku (Sudoku s) | length s /= 9 = False
isSudoku (Sudoku s) | map length s /= take 9 (repeat 9) = False
isSudoku (Sudoku s) = and (map (\x->(isNothing x || fromJust x `elem` [1..9])) (concat s))
-- isSolved
isSolved :: Sudoku -> Bool
isSolved (Sudoku s) = not $ elem Nothing (concat s)
-- printSudoku: print the Sudoku on the screen
printSudoku :: Sudoku -> IO ()
printSudoku s = putStr (show s)
-- readSudoku
readSudoku :: FilePath -> IO Sudoku
readSudoku fn =
do sudokuData <- readFile fn
return (Sudoku (map
(map (\x->(if x=='.' then Nothing else Just $ digitToInt x)))
$ lines sudokuData))
-- generate a cell
cell :: Gen (Maybe Int)
cell = frequency
[ (1, do a <- elements [1..9]
return (Just a)),
(9, return Nothing)
]
-- C2. Make Sudokus an instance of the class Arbitrary.
instance Arbitrary Sudoku where
arbitrary = do grid <- sequence (replicate 9 (sequence (replicate 9 cell)))
return (Sudoku grid)
prop_Sudoku :: Sudoku -> Bool
prop_Sudoku s = isSudoku s
type Block = [Maybe Int]
-- isOkayBlock
isOkayBlock :: Block -> Bool
isOkayBlock b = length (nub y) == length y where y = [ x | x <- b, isJust x ]
groupn :: Int -> [a] -> [[a]]
groupn _ [] = []
groupn n xs = (take n xs):(groupn n (drop n xs))
-- blocks
linesSudoku (Sudoku s) = s
columnsSudoku (Sudoku s) = transpose s
gridsSudoku (Sudoku s) = map concat $ concatMap (groupn 3) (map transpose (groupn 3 s))
blocks :: Sudoku -> [Block]
blocks s = linesSudoku s ++ columnsSudoku s ++ gridsSudoku s
prop_Blocks s = length (blocks s) == 27 && and (map (==9) (map length (blocks s)))
-- isOkay
isOkay :: Sudoku -> Bool
isOkay s = and (map isOkayBlock (blocks s))
type Pos = (Int,Int)
-- blank returns a blank position
hasBlank :: Sudoku -> Maybe Int
hasBlank (Sudoku s) = findIndex isNothing (concat s)
toPos :: Int -> Pos
toPos n = (n `div` 9, n `mod` 9)
blank :: Sudoku -> Pos
blank (Sudoku s) = toPos $ (fromJust (findIndex isNothing (drop n (concat s))))+n
where n = 9*fewestNothingLine s
blank (Sudoku s) = toPos (fromJust (findIndex (isNothing) (concat s)))
fewestNothingLine :: [[Maybe Int]] -> Int
fewestNothingLine s = snd $ minimum (filter (\x->fst x/=0)
(zip
(map length (map (filter isNothing) s))
[0..8]))
fewestNothingCol s = fewestNothingLine (transpose s)
prop_Blankcell :: Sudoku -> Property
prop_Blankcell ss@(Sudoku s) =
elem Nothing (concat s) ==> (s !! x) !! y == Nothing where (x,y)=blank ss
-- (!!=) updates a list
(!!=) :: [a] -> (Int,a) -> [a]
(!!=) [] _ = []
(!!=) (x:xs) (0,a) = a:xs
(!!=) (x:xs) (n,a) = x:(xs !!= (n-1,a))
prop_idxReplacs xs (n,x) =
n >=0 && length xs > n ==> (xs !!= (n,x)) !! n == x
prop_ReplaceTake xs (n,x) =
n >=0 ==> take n (xs !!= (n,x)) == take n xs
prop_ReplaceDrop xs (n,x) =
n >=0 ==> drop (n+1) (xs !!= (n,x)) == drop (n+1) xs
-- update update a Sudoku
update :: Sudoku -> Pos -> Maybe Int -> Sudoku
update (Sudoku s) (x,y) a = Sudoku (s !!= (x, (s !! x) !!= (y, a)))
data Position = Position (Int,Int) deriving Show
instance Arbitrary Position where
arbitrary = do x <- elements [0..8]
y <- elements [0..8]
return (Position (x,y))
prop_update :: Sudoku -> Position -> Maybe Int -> Property
prop_update s (Position pos@(x,y)) a =
x `elem` [0..8] && y `elem` [0..8] ==>
getElem (update s pos a) pos == a
where getElem (Sudoku s) (x,y) = (s !! x) !! y
solve :: Sudoku -> Maybe Sudoku
solve s | not (isOkay s) = Nothing
solve s | isNothing (hasBlank s) = Just s
solve s = solveAux s (blank s) 1
solveAux :: Sudoku -> Pos -> Int -> Maybe Sudoku
solveAux _ _ 10 = Nothing
solveAux s (x,y) a = if isNothing result then
solveAux s (x,y) (a+1)
else
result
where news = update s (x,y) (Just a)
result = solve news
readAndSolve :: FilePath -> IO ()
readAndSolve fn =
do su <- readSudoku fn
let result = solve su
if isNothing result then
putStrLn "(no solution)"
else
printSudoku (fromJust result)
-- isSolutionOf checks, given two Sudokus,
-- whether the first one is a solution (i.e. all blocks are okay, there are no blanks),
-- and also whether the first one is a solution of the second one
isSolutionOf :: Sudoku -> Sudoku -> Bool
isSolutionOf s1 _ | not (isOkay s1) = False
isSolutionOf s1 _ | isJust (hasBlank s1) = False
isSolutionOf (Sudoku s1) (Sudoku s2) =
f s1 == f s2 where
f xs = [ (xs !! x) !! y | x <- [0..8], y <- [0..8], isJust ((s2 !! x) !! y) ]
prop_SolveSound :: Sudoku -> Property
prop_SolveSound s =
collect
s
$ isJust (solve s) ==> isSolutionOf (fromJust (solve s)) s
fewerCheck prop = quickCheckWith stdArgs{ maxSuccess = 30 } prop
|
