-
Notifications
You must be signed in to change notification settings - Fork 1
/
Main.hs
125 lines (105 loc) · 3.57 KB
/
Main.hs
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
import Data.List (intersect)
import GHC.Exts (sortWith)
type Value = Int
type Board = [Value]
type Col = Int
type Row = Int
type Index = Int
type Block = Int
easy, hard, evil :: String
easy = "530070000600195000098000060800060003400803001700020006060000280000419005000080079"
hard = "000003020200019000001008097600000070709601804030000006360800700000950003080100000"
evil = "502000008000800030000407060700010600040206090006040001050701000080002000900000806"
colValues :: Col -> Board -> [Value]
colValues _ [] = []
colValues col board =
board !! col : colValues col (drop 9 board)
rowValues :: Row -> Board -> [Value]
rowValues row board =
take 9 $ drop (row * 9) board
blockValues :: Block -> Board -> [Value]
blockValues block board =
let cells = [0, 1, 2, 9, 10, 11, 18, 19, 20]
offset = block `quot` 3 * 27 + (block `mod` 3 * 3)
offsetCells = map (+offset) cells
in map (board !!) offsetCells
blockNum :: Col -> Row -> Block
blockNum col row =
let x = col `quot` 3
y = row `quot` 3
in y * 3 + x
freeByCol :: Col -> Board -> [Value]
freeByCol col board =
let vs = colValues col board
in filter (`notElem` vs) [1..9]
freeByRow :: Row -> Board -> [Value]
freeByRow row board =
let vs = rowValues row board
in filter (`notElem` vs) [1..9]
freeByBlock :: Block -> Board -> [Value]
freeByBlock block board =
let vs = blockValues block board
in filter (`notElem` vs) [1..9]
freeByIndex :: Index -> Board -> [Value]
freeByIndex i board =
let col = i `mod` 9
row = i `quot` 9
block = blockNum col row
colFree = freeByCol col board
rowFree = freeByRow row board
blockFree = freeByBlock block board
in intersect colFree $ intersect rowFree blockFree
moveList :: Board -> [(Index, [Value])]
moveList board =
let freeIndexes = map fst $ filter ((==0) . snd) $ zip [0..] board
movesAt i = (i, freeByIndex i board)
moves = map movesAt freeIndexes
in sortWith (length . snd) moves
applyMove :: Index -> Value -> Board -> Board
applyMove i value board =
take i board ++ [value] ++ drop (i + 1) board
solveWith :: [(Index, [Value])] -> Board -> [Board]
solveWith [] board = [board]
solveWith ((_, []):_) _ = []
solveWith ((i, [v]):_) board =
let board' = applyMove i v board
moves = moveList board'
in solveWith moves board'
solveWith ((i, v:vs):_) board =
solveWith [(i, [v])] board ++ solveWith [(i, vs)] board
solve :: Board -> [Board]
solve board = solveWith (moveList board) board
boardStr :: Board -> String
boardStr [] = []
boardStr board =
boardStr' 0 board
where boardStr' _ [] = "|\n+---+---+---+"
boardStr' i (v:vs) =
decorationAt i ++ valueStr v ++ boardStr' (i + 1) vs
valueStr 0 = " "
valueStr v = show v
decorationAt :: Index -> String
decorationAt n
| n == 0 = "+---+---+---+\n|"
| n `mod` 27 == 0 = "|\n+---+---+---+\n|"
| n `mod` 9 == 0 = "|\n|"
| n `mod` 3 == 0 = "|"
| otherwise = ""
printBoard :: Board -> IO ()
printBoard board =
putStrLn $ boardStr board
readBoard :: String -> Board
readBoard = map (\c -> read [c])
doSolve :: String -> IO ()
doSolve s = do
let board = readBoard s
putStrLn "Initial:"
printBoard board
putStrLn "Solutions:"
mapM_ printBoard $ solve board
putStrLn ""
main :: IO ()
main = do
doSolve easy
doSolve hard
doSolve evil