-
Notifications
You must be signed in to change notification settings - Fork 3
/
problem97.ml
196 lines (161 loc) · 6.8 KB
/
problem97.ml
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
195
196
(* P97 (**) Sudoku
Sudoku puzzles go like this:
Problem statement Solution
. . 4 | 8 . . | . 1 7 9 3 4 | 8 2 5 | 6 1 7
| | | |
6 7 . | 9 . . | . . . 6 7 2 | 9 1 4 | 8 5 3
| | | |
5 . 8 | . 3 . | . . 4 5 1 8 | 6 3 7 | 9 2 4
--------+---------+-------- --------+---------+--------
3 . . | 7 4 . | 1 . . 3 2 5 | 7 4 8 | 1 6 9
| |
. 6 9 | . . . | 7 8 . 4 6 9 | 1 5 3 | 7 8 2
| | | |
. . 1 | . 6 9 | . . 5 7 8 1 | 2 6 9 | 4 3 5
--------+---------+-------- --------+---------+--------
1 . . | . 8 . | 3 . 6 1 9 7 | 5 8 2 | 3 4 6
| | | |
. . . | . . 6 | . 9 1 8 5 3 | 4 7 6 | 2 9 1
| | | |
2 4 . | . . 1 | 5 . . 2 4 6 | 3 9 1 | 5 7 8
Every spot in the puzzle belongs to a (horizontal) row and a (vertical)
column, as well as to one single 3x3 square (which we call "square" for
short). At the beginning, some of the spots carry a single-digit number
between 1 and 9. The problem is to fill the missing spots with digits in such
a way that every number between 1 and 9 appears exactly once in each row, in
each column, and in each square.*)
(*
DataTypes & Notation :
The board is implemented as a hash with int * int keys and int list values.
A position in the board is a pair of int's.
The field at a position is the list of possible values from [1-9].
A position is assigned a value, if the field at the position is the singleton of that value.
*)
(** General List Functions ***)
let remove_if t l = List.fold_right ( fun x l -> if ( t x ) then l else x::l ) l [] ;;
let remove_elt x l = remove_if ( fun y -> y = x ) l ;;
let remove_duplicates l = List.fold_right ( fun x l -> if ( List.mem x l ) then l else x::l ) l [];;
let list_diff l1 l2 = remove_if ( fun x -> List.mem x l2 ) l1 ;;
let rec head n l = if ( ( l = [] ) || ( n = 0 ) ) then [] else ( List.hd l ) :: ( head ( n - 1 ) ( List.tl l ) ) ;;
(** General Board Accessors ***)
let sample_board =
[ [ 0; 0; 4; 8; 0; 0; 0; 1; 7];
[ 6; 7; 0; 9; 0; 0; 0; 0; 0];
[ 5; 0; 8; 0; 3; 0; 0; 0; 4];
[ 3; 0; 0; 7; 4; 0; 1; 0; 0];
[ 0; 6; 9; 0; 0; 0; 7; 8; 0];
[ 0; 0; 1; 0; 6; 9; 0; 0; 5];
[ 1; 0; 0; 0; 8; 0; 3; 0; 6];
[ 0; 0; 0; 0; 0; 6; 0; 9; 1];
[ 2; 4; 0; 0; 0; 1; 5; 0; 0] ];;
(* a variation which gives multiple solutions *)
(*let sample_board =
[ [ 0; 0; 0; 8; 0; 0; 0; 1; 7];
[ 0; 0; 0; 9; 0; 0; 0; 0; 0];
[ 0; 0; 0; 0; 3; 0; 0; 0; 4];
[ 3; 0; 0; 7; 4; 0; 1; 0; 0];
[ 0; 6; 9; 0; 0; 0; 7; 8; 0];
[ 0; 0; 1; 0; 6; 9; 0; 0; 5];
[ 1; 0; 0; 0; 8; 0; 3; 0; 6];
[ 0; 0; 0; 0; 0; 6; 0; 9; 1];
[ 2; 4; 0; 0; 0; 1; 5; 0; 0] ];;*)
(* list all positions of the board *)
let get_all_positions = List.flatten ( List.map ( fun i -> List.map ( fun j -> (i,j) ) [0;1;2;3;4;5;6;7;8] ) [0;1;2;3;4;5;6;7;8] );;
(* list the positions in the same row *)
let get_row_positions (i,j) = List.map ( fun j2 -> (i,j2) ) [0;1;2;3;4;5;6;7;8];;
(* list the positions in the same column *)
let get_col_positions (i,j) = List.map ( fun i2 -> (i2,j) ) [0;1;2;3;4;5;6;7;8];;
(* list the positions in the same block *)
let get_block_positions (i,j) =
let rec get_block_positions (i,j) i2 j2 =
if ( j2 > ( ( j / 3 ) * 3 ) + 2 ) then get_block_positions (i,j) ( i2 + 1 ) ( ( j / 3 ) * 3) else
if ( i2 > ( ( i / 3 ) * 3 ) + 2 ) then [] else
(i2,j2) :: ( get_block_positions (i,j) i2 ( j2 + 1 ) )
in
get_block_positions (i,j) ( ( i / 3 ) * 3 ) ( ( j / 3 ) * 3 )
;;
(** Board I/O Functions ***)
(* reads a list of lists into the board hash *)
let read_board bl =
let bh = Hashtbl.create 81 in
let rec read_row rl i j =
match rl with
[] -> ()
| h::t ->
if ( h = 0 )
then Hashtbl.add bh (i,j) [1;2;3;4;5;6;7;8;9]
else Hashtbl.add bh (i,j) [h] ;
read_row t i ( j + 1 )
in
let rec read_board bl i =
match bl with
[] -> ()
| h::t ->
read_row h i 0 ;
read_board t ( i + 1 )
in
read_board bl 0 ;
bh
;;
(* prints a board hash *)
let rec print_board bh =
List.iter ( fun i ->
List.iter ( fun j ->
let poss = Hashtbl.find bh (i,j) in
if ( List.length poss > 5 )
then begin List.iter prerr_int ( head 3 poss ); prerr_string ".." end
else List.iter prerr_int poss ;
Printf.fprintf stderr "\t" )
[0;1;2;3;4;5;6;7;8] ;
Printf.fprintf stderr "\n" )
[0;1;2;3;4;5;6;7;8] ;
Printf.fprintf stderr "\n"
;;
(** Update Functions ***)
(* given a list of fields to update, this function removes all possible values which are assigned to a position in the neighbourhood, i.e. the positions in the same row, column, or block. *)
let rec update_fields bh lpos =
if ( lpos = [] ) then () else
let pos = List.hd lpos in
if ( List.length ( Hashtbl.find bh pos ) < 2 ) then ( update_fields bh ( List.tl lpos ) ) else
let neighbours = ( get_row_positions pos ) @ ( get_col_positions pos ) @ ( get_block_positions pos ) in
let assigned = List.flatten ( remove_if
( fun field -> ( ( List.length field ) > 1 ) )
( List.map ( Hashtbl.find bh ) neighbours ) )
in
let old_poss = Hashtbl.find bh pos in
let new_poss = list_diff old_poss assigned in
Hashtbl.replace bh pos new_poss;
if ( List.length old_poss ) = ( List.length new_poss )
then update_fields bh ( List.tl lpos )
else update_fields bh ( remove_duplicates ( ( List.tl lpos ) @ neighbours ) )
;;
(* update_board first calls update_fields to infer the valuation. it then tries all possible valuations in the least ambigious field ( a field of shortest length ) *)
let rec update_board board =
(* infer the valuation *)
update_fields board ( remove_if ( fun pos -> List.length ( Hashtbl.find board pos ) < 2 ) get_all_positions ) ;
(* the following lists the ambigious positions AFTER the inference *)
let ambigious = remove_if ( fun pos -> List.length ( Hashtbl.find board pos ) < 2 ) get_all_positions in
if ( List.exists ( fun field -> List.length ( Hashtbl.find board field ) < 1 ) ambigious )
then () (* inconsistent layout *)
else
if ( List.length ambigious = 0 )
then print_board board (* solved, then print *)
else
let ambigious = List.sort ( fun pos1 pos2 -> compare
( List.length ( Hashtbl.find board pos1 ) )
( List.length ( Hashtbl.find board pos2 ) )
) ambigious in
( List.iter (* try all possible values for a least ambigious field *)
( fun x ->
let new_board = board in
Hashtbl.replace new_board ( List.hd ambigious ) [x];
update_board new_board ;
)
( Hashtbl.find board ( List.hd ambigious ) ) )
;;
(** Main ***)
let board = read_board sample_board in
print_board board;
update_board board;
prerr_newline ();
;;