33192
|
1 |
(* Title: HOL/Nitpick/Tools/kodkod.ML
|
|
2 |
Author: Jasmin Blanchette, TU Muenchen
|
|
3 |
Copyright 2008, 2009
|
|
4 |
|
|
5 |
ML interface on top of Kodkod.
|
|
6 |
*)
|
|
7 |
|
|
8 |
signature KODKOD =
|
|
9 |
sig
|
|
10 |
type n_ary_index = int * int
|
|
11 |
type setting = string * string
|
|
12 |
|
|
13 |
datatype tuple =
|
|
14 |
Tuple of int list |
|
|
15 |
TupleIndex of n_ary_index |
|
|
16 |
TupleReg of n_ary_index
|
|
17 |
|
|
18 |
datatype tuple_set =
|
|
19 |
TupleUnion of tuple_set * tuple_set |
|
|
20 |
TupleDifference of tuple_set * tuple_set |
|
|
21 |
TupleIntersect of tuple_set * tuple_set |
|
|
22 |
TupleProduct of tuple_set * tuple_set |
|
|
23 |
TupleProject of tuple_set * int |
|
|
24 |
TupleSet of tuple list |
|
|
25 |
TupleRange of tuple * tuple |
|
|
26 |
TupleArea of tuple * tuple |
|
|
27 |
TupleAtomSeq of int * int |
|
|
28 |
TupleSetReg of n_ary_index
|
|
29 |
|
|
30 |
datatype tuple_assign =
|
|
31 |
AssignTuple of n_ary_index * tuple |
|
|
32 |
AssignTupleSet of n_ary_index * tuple_set
|
|
33 |
|
|
34 |
type bound = (n_ary_index * string) list * tuple_set list
|
|
35 |
type int_bound = int option * tuple_set list
|
|
36 |
|
|
37 |
datatype formula =
|
|
38 |
All of decl list * formula |
|
|
39 |
Exist of decl list * formula |
|
|
40 |
FormulaLet of expr_assign list * formula |
|
|
41 |
FormulaIf of formula * formula * formula |
|
|
42 |
Or of formula * formula |
|
|
43 |
Iff of formula * formula |
|
|
44 |
Implies of formula * formula |
|
|
45 |
And of formula * formula |
|
|
46 |
Not of formula |
|
|
47 |
Acyclic of n_ary_index |
|
|
48 |
Function of n_ary_index * rel_expr * rel_expr |
|
|
49 |
Functional of n_ary_index * rel_expr * rel_expr |
|
|
50 |
TotalOrdering of n_ary_index * n_ary_index * n_ary_index * n_ary_index |
|
|
51 |
Subset of rel_expr * rel_expr |
|
|
52 |
RelEq of rel_expr * rel_expr |
|
|
53 |
IntEq of int_expr * int_expr |
|
|
54 |
LT of int_expr * int_expr |
|
|
55 |
LE of int_expr * int_expr |
|
|
56 |
No of rel_expr |
|
|
57 |
Lone of rel_expr |
|
|
58 |
One of rel_expr |
|
|
59 |
Some of rel_expr |
|
|
60 |
False |
|
|
61 |
True |
|
|
62 |
FormulaReg of int
|
|
63 |
and rel_expr =
|
|
64 |
RelLet of expr_assign list * rel_expr |
|
|
65 |
RelIf of formula * rel_expr * rel_expr |
|
|
66 |
Union of rel_expr * rel_expr |
|
|
67 |
Difference of rel_expr * rel_expr |
|
|
68 |
Override of rel_expr * rel_expr |
|
|
69 |
Intersect of rel_expr * rel_expr |
|
|
70 |
Product of rel_expr * rel_expr |
|
|
71 |
IfNo of rel_expr * rel_expr |
|
|
72 |
Project of rel_expr * int_expr list |
|
|
73 |
Join of rel_expr * rel_expr |
|
|
74 |
Closure of rel_expr |
|
|
75 |
ReflexiveClosure of rel_expr |
|
|
76 |
Transpose of rel_expr |
|
|
77 |
Comprehension of decl list * formula |
|
|
78 |
Bits of int_expr |
|
|
79 |
Int of int_expr |
|
|
80 |
Iden |
|
|
81 |
Ints |
|
|
82 |
None |
|
|
83 |
Univ |
|
|
84 |
Atom of int |
|
|
85 |
AtomSeq of int * int |
|
|
86 |
Rel of n_ary_index |
|
|
87 |
Var of n_ary_index |
|
|
88 |
RelReg of n_ary_index
|
|
89 |
and int_expr =
|
|
90 |
Sum of decl list * int_expr |
|
|
91 |
IntLet of expr_assign list * int_expr |
|
|
92 |
IntIf of formula * int_expr * int_expr |
|
|
93 |
SHL of int_expr * int_expr |
|
|
94 |
SHA of int_expr * int_expr |
|
|
95 |
SHR of int_expr * int_expr |
|
|
96 |
Add of int_expr * int_expr |
|
|
97 |
Sub of int_expr * int_expr |
|
|
98 |
Mult of int_expr * int_expr |
|
|
99 |
Div of int_expr * int_expr |
|
|
100 |
Mod of int_expr * int_expr |
|
|
101 |
Cardinality of rel_expr |
|
|
102 |
SetSum of rel_expr |
|
|
103 |
BitOr of int_expr * int_expr |
|
|
104 |
BitXor of int_expr * int_expr |
|
|
105 |
BitAnd of int_expr * int_expr |
|
|
106 |
BitNot of int_expr |
|
|
107 |
Neg of int_expr |
|
|
108 |
Absolute of int_expr |
|
|
109 |
Signum of int_expr |
|
|
110 |
Num of int |
|
|
111 |
IntReg of int
|
|
112 |
and decl =
|
|
113 |
DeclNo of n_ary_index * rel_expr |
|
|
114 |
DeclLone of n_ary_index * rel_expr |
|
|
115 |
DeclOne of n_ary_index * rel_expr |
|
|
116 |
DeclSome of n_ary_index * rel_expr |
|
|
117 |
DeclSet of n_ary_index * rel_expr
|
|
118 |
and expr_assign =
|
|
119 |
AssignFormulaReg of int * formula |
|
|
120 |
AssignRelReg of n_ary_index * rel_expr |
|
|
121 |
AssignIntReg of int * int_expr
|
|
122 |
|
|
123 |
type 'a fold_expr_funcs = {
|
|
124 |
formula_func: formula -> 'a -> 'a,
|
|
125 |
rel_expr_func: rel_expr -> 'a -> 'a,
|
|
126 |
int_expr_func: int_expr -> 'a -> 'a
|
|
127 |
}
|
|
128 |
|
|
129 |
val fold_formula : 'a fold_expr_funcs -> formula -> 'a -> 'a
|
|
130 |
val fold_rel_expr : 'a fold_expr_funcs -> rel_expr -> 'a -> 'a
|
|
131 |
val fold_int_expr : 'a fold_expr_funcs -> int_expr -> 'a -> 'a
|
|
132 |
val fold_decl : 'a fold_expr_funcs -> decl -> 'a -> 'a
|
|
133 |
val fold_expr_assign : 'a fold_expr_funcs -> expr_assign -> 'a -> 'a
|
|
134 |
|
|
135 |
type 'a fold_tuple_funcs = {
|
|
136 |
tuple_func: tuple -> 'a -> 'a,
|
|
137 |
tuple_set_func: tuple_set -> 'a -> 'a
|
|
138 |
}
|
|
139 |
|
|
140 |
val fold_tuple : 'a fold_tuple_funcs -> tuple -> 'a -> 'a
|
|
141 |
val fold_tuple_set : 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a
|
|
142 |
val fold_tuple_assign : 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a
|
|
143 |
val fold_bound :
|
|
144 |
'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a
|
|
145 |
val fold_int_bound : 'a fold_tuple_funcs -> int_bound -> 'a -> 'a
|
|
146 |
|
|
147 |
type problem = {
|
|
148 |
comment: string,
|
|
149 |
settings: setting list,
|
|
150 |
univ_card: int,
|
|
151 |
tuple_assigns: tuple_assign list,
|
|
152 |
bounds: bound list,
|
|
153 |
int_bounds: int_bound list,
|
|
154 |
expr_assigns: expr_assign list,
|
|
155 |
formula: formula}
|
|
156 |
|
|
157 |
type raw_bound = n_ary_index * int list list
|
|
158 |
|
|
159 |
datatype outcome =
|
|
160 |
Normal of (int * raw_bound list) list * int list |
|
|
161 |
TimedOut of int list |
|
|
162 |
Interrupted of int list option |
|
|
163 |
Error of string * int list
|
|
164 |
|
|
165 |
exception SYNTAX of string * string
|
|
166 |
|
|
167 |
val max_arity : int -> int
|
|
168 |
val arity_of_rel_expr : rel_expr -> int
|
|
169 |
val problems_equivalent : problem -> problem -> bool
|
|
170 |
val solve_any_problem :
|
|
171 |
bool -> Time.time option -> int -> int -> problem list -> outcome
|
|
172 |
end;
|
|
173 |
|
|
174 |
structure Kodkod : KODKOD =
|
|
175 |
struct
|
|
176 |
|
|
177 |
type n_ary_index = int * int
|
|
178 |
|
|
179 |
type setting = string * string
|
|
180 |
|
|
181 |
datatype tuple =
|
|
182 |
Tuple of int list |
|
|
183 |
TupleIndex of n_ary_index |
|
|
184 |
TupleReg of n_ary_index
|
|
185 |
|
|
186 |
datatype tuple_set =
|
|
187 |
TupleUnion of tuple_set * tuple_set |
|
|
188 |
TupleDifference of tuple_set * tuple_set |
|
|
189 |
TupleIntersect of tuple_set * tuple_set |
|
|
190 |
TupleProduct of tuple_set * tuple_set |
|
|
191 |
TupleProject of tuple_set * int |
|
|
192 |
TupleSet of tuple list |
|
|
193 |
TupleRange of tuple * tuple |
|
|
194 |
TupleArea of tuple * tuple |
|
|
195 |
TupleAtomSeq of int * int |
|
|
196 |
TupleSetReg of n_ary_index
|
|
197 |
|
|
198 |
datatype tuple_assign =
|
|
199 |
AssignTuple of n_ary_index * tuple |
|
|
200 |
AssignTupleSet of n_ary_index * tuple_set
|
|
201 |
|
|
202 |
type bound = (n_ary_index * string) list * tuple_set list
|
|
203 |
type int_bound = int option * tuple_set list
|
|
204 |
|
|
205 |
datatype formula =
|
|
206 |
All of decl list * formula |
|
|
207 |
Exist of decl list * formula |
|
|
208 |
FormulaLet of expr_assign list * formula |
|
|
209 |
FormulaIf of formula * formula * formula |
|
|
210 |
Or of formula * formula |
|
|
211 |
Iff of formula * formula |
|
|
212 |
Implies of formula * formula |
|
|
213 |
And of formula * formula |
|
|
214 |
Not of formula |
|
|
215 |
Acyclic of n_ary_index |
|
|
216 |
Function of n_ary_index * rel_expr * rel_expr |
|
|
217 |
Functional of n_ary_index * rel_expr * rel_expr |
|
|
218 |
TotalOrdering of n_ary_index * n_ary_index * n_ary_index * n_ary_index |
|
|
219 |
Subset of rel_expr * rel_expr |
|
|
220 |
RelEq of rel_expr * rel_expr |
|
|
221 |
IntEq of int_expr * int_expr |
|
|
222 |
LT of int_expr * int_expr |
|
|
223 |
LE of int_expr * int_expr |
|
|
224 |
No of rel_expr |
|
|
225 |
Lone of rel_expr |
|
|
226 |
One of rel_expr |
|
|
227 |
Some of rel_expr |
|
|
228 |
False |
|
|
229 |
True |
|
|
230 |
FormulaReg of int
|
|
231 |
and rel_expr =
|
|
232 |
RelLet of expr_assign list * rel_expr |
|
|
233 |
RelIf of formula * rel_expr * rel_expr |
|
|
234 |
Union of rel_expr * rel_expr |
|
|
235 |
Difference of rel_expr * rel_expr |
|
|
236 |
Override of rel_expr * rel_expr |
|
|
237 |
Intersect of rel_expr * rel_expr |
|
|
238 |
Product of rel_expr * rel_expr |
|
|
239 |
IfNo of rel_expr * rel_expr |
|
|
240 |
Project of rel_expr * int_expr list |
|
|
241 |
Join of rel_expr * rel_expr |
|
|
242 |
Closure of rel_expr |
|
|
243 |
ReflexiveClosure of rel_expr |
|
|
244 |
Transpose of rel_expr |
|
|
245 |
Comprehension of decl list * formula |
|
|
246 |
Bits of int_expr |
|
|
247 |
Int of int_expr |
|
|
248 |
Iden |
|
|
249 |
Ints |
|
|
250 |
None |
|
|
251 |
Univ |
|
|
252 |
Atom of int |
|
|
253 |
AtomSeq of int * int |
|
|
254 |
Rel of n_ary_index |
|
|
255 |
Var of n_ary_index |
|
|
256 |
RelReg of n_ary_index
|
|
257 |
and int_expr =
|
|
258 |
Sum of decl list * int_expr |
|
|
259 |
IntLet of expr_assign list * int_expr |
|
|
260 |
IntIf of formula * int_expr * int_expr |
|
|
261 |
SHL of int_expr * int_expr |
|
|
262 |
SHA of int_expr * int_expr |
|
|
263 |
SHR of int_expr * int_expr |
|
|
264 |
Add of int_expr * int_expr |
|
|
265 |
Sub of int_expr * int_expr |
|
|
266 |
Mult of int_expr * int_expr |
|
|
267 |
Div of int_expr * int_expr |
|
|
268 |
Mod of int_expr * int_expr |
|
|
269 |
Cardinality of rel_expr |
|
|
270 |
SetSum of rel_expr |
|
|
271 |
BitOr of int_expr * int_expr |
|
|
272 |
BitXor of int_expr * int_expr |
|
|
273 |
BitAnd of int_expr * int_expr |
|
|
274 |
BitNot of int_expr |
|
|
275 |
Neg of int_expr |
|
|
276 |
Absolute of int_expr |
|
|
277 |
Signum of int_expr |
|
|
278 |
Num of int |
|
|
279 |
IntReg of int
|
|
280 |
and decl =
|
|
281 |
DeclNo of n_ary_index * rel_expr |
|
|
282 |
DeclLone of n_ary_index * rel_expr |
|
|
283 |
DeclOne of n_ary_index * rel_expr |
|
|
284 |
DeclSome of n_ary_index * rel_expr |
|
|
285 |
DeclSet of n_ary_index * rel_expr
|
|
286 |
and expr_assign =
|
|
287 |
AssignFormulaReg of int * formula |
|
|
288 |
AssignRelReg of n_ary_index * rel_expr |
|
|
289 |
AssignIntReg of int * int_expr
|
|
290 |
|
|
291 |
type problem = {
|
|
292 |
comment: string,
|
|
293 |
settings: setting list,
|
|
294 |
univ_card: int,
|
|
295 |
tuple_assigns: tuple_assign list,
|
|
296 |
bounds: bound list,
|
|
297 |
int_bounds: int_bound list,
|
|
298 |
expr_assigns: expr_assign list,
|
|
299 |
formula: formula}
|
|
300 |
|
|
301 |
type raw_bound = n_ary_index * int list list
|
|
302 |
|
|
303 |
datatype outcome =
|
|
304 |
Normal of (int * raw_bound list) list * int list |
|
|
305 |
TimedOut of int list |
|
|
306 |
Interrupted of int list option |
|
|
307 |
Error of string * int list
|
|
308 |
|
|
309 |
exception SYNTAX of string * string
|
|
310 |
|
|
311 |
type 'a fold_expr_funcs = {
|
|
312 |
formula_func: formula -> 'a -> 'a,
|
|
313 |
rel_expr_func: rel_expr -> 'a -> 'a,
|
|
314 |
int_expr_func: int_expr -> 'a -> 'a
|
|
315 |
}
|
|
316 |
|
|
317 |
(* 'a fold_expr_funcs -> formula -> 'a -> 'a *)
|
|
318 |
fun fold_formula (F : 'a fold_expr_funcs) formula =
|
|
319 |
case formula of
|
|
320 |
All (ds, f) => fold (fold_decl F) ds #> fold_formula F f
|
|
321 |
| Exist (ds, f) => fold (fold_decl F) ds #> fold_formula F f
|
|
322 |
| FormulaLet (bs, f) => fold (fold_expr_assign F) bs #> fold_formula F f
|
|
323 |
| FormulaIf (f, f1, f2) =>
|
|
324 |
fold_formula F f #> fold_formula F f1 #> fold_formula F f2
|
|
325 |
| Or (f1, f2) => fold_formula F f1 #> fold_formula F f2
|
|
326 |
| Iff (f1, f2) => fold_formula F f1 #> fold_formula F f2
|
|
327 |
| Implies (f1, f2) => fold_formula F f1 #> fold_formula F f2
|
|
328 |
| And (f1, f2) => fold_formula F f1 #> fold_formula F f2
|
|
329 |
| Not f => fold_formula F f
|
|
330 |
| Acyclic x => fold_rel_expr F (Rel x)
|
|
331 |
| Function (x, r1, r2) =>
|
|
332 |
fold_rel_expr F (Rel x) #> fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
333 |
| Functional (x, r1, r2) =>
|
|
334 |
fold_rel_expr F (Rel x) #> fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
335 |
| TotalOrdering (x1, x2, x3, x4) =>
|
|
336 |
fold_rel_expr F (Rel x1) #> fold_rel_expr F (Rel x2)
|
|
337 |
#> fold_rel_expr F (Rel x3) #> fold_rel_expr F (Rel x4)
|
|
338 |
| Subset (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
339 |
| RelEq (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
340 |
| IntEq (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
341 |
| LT (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
342 |
| LE (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
343 |
| No r => fold_rel_expr F r
|
|
344 |
| Lone r => fold_rel_expr F r
|
|
345 |
| One r => fold_rel_expr F r
|
|
346 |
| Some r => fold_rel_expr F r
|
|
347 |
| False => #formula_func F formula
|
|
348 |
| True => #formula_func F formula
|
|
349 |
| FormulaReg _ => #formula_func F formula
|
|
350 |
(* 'a fold_expr_funcs -> rel_expr -> 'a -> 'a *)
|
|
351 |
and fold_rel_expr F rel_expr =
|
|
352 |
case rel_expr of
|
|
353 |
RelLet (bs, r) => fold (fold_expr_assign F) bs #> fold_rel_expr F r
|
|
354 |
| RelIf (f, r1, r2) =>
|
|
355 |
fold_formula F f #> fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
356 |
| Union (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
357 |
| Difference (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
358 |
| Override (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
359 |
| Intersect (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
360 |
| Product (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
361 |
| IfNo (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
362 |
| Project (r1, is) => fold_rel_expr F r1 #> fold (fold_int_expr F) is
|
|
363 |
| Join (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
|
|
364 |
| Closure r => fold_rel_expr F r
|
|
365 |
| ReflexiveClosure r => fold_rel_expr F r
|
|
366 |
| Transpose r => fold_rel_expr F r
|
|
367 |
| Comprehension (ds, f) => fold (fold_decl F) ds #> fold_formula F f
|
|
368 |
| Bits i => fold_int_expr F i
|
|
369 |
| Int i => fold_int_expr F i
|
|
370 |
| Iden => #rel_expr_func F rel_expr
|
|
371 |
| Ints => #rel_expr_func F rel_expr
|
|
372 |
| None => #rel_expr_func F rel_expr
|
|
373 |
| Univ => #rel_expr_func F rel_expr
|
|
374 |
| Atom _ => #rel_expr_func F rel_expr
|
|
375 |
| AtomSeq _ => #rel_expr_func F rel_expr
|
|
376 |
| Rel _ => #rel_expr_func F rel_expr
|
|
377 |
| Var _ => #rel_expr_func F rel_expr
|
|
378 |
| RelReg _ => #rel_expr_func F rel_expr
|
|
379 |
(* 'a fold_expr_funcs -> int_expr -> 'a -> 'a *)
|
|
380 |
and fold_int_expr F int_expr =
|
|
381 |
case int_expr of
|
|
382 |
Sum (ds, i) => fold (fold_decl F) ds #> fold_int_expr F i
|
|
383 |
| IntLet (bs, i) => fold (fold_expr_assign F) bs #> fold_int_expr F i
|
|
384 |
| IntIf (f, i1, i2) =>
|
|
385 |
fold_formula F f #> fold_int_expr F i1 #> fold_int_expr F i2
|
|
386 |
| SHL (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
387 |
| SHA (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
388 |
| SHR (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
389 |
| Add (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
390 |
| Sub (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
391 |
| Mult (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
392 |
| Div (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
393 |
| Mod (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
394 |
| Cardinality r => fold_rel_expr F r
|
|
395 |
| SetSum r => fold_rel_expr F r
|
|
396 |
| BitOr (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
397 |
| BitXor (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
398 |
| BitAnd (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
|
|
399 |
| BitNot i => fold_int_expr F i
|
|
400 |
| Neg i => fold_int_expr F i
|
|
401 |
| Absolute i => fold_int_expr F i
|
|
402 |
| Signum i => fold_int_expr F i
|
|
403 |
| Num _ => #int_expr_func F int_expr
|
|
404 |
| IntReg _ => #int_expr_func F int_expr
|
|
405 |
(* 'a fold_expr_funcs -> decl -> 'a -> 'a *)
|
|
406 |
and fold_decl F decl =
|
|
407 |
case decl of
|
|
408 |
DeclNo (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
|
|
409 |
| DeclLone (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
|
|
410 |
| DeclOne (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
|
|
411 |
| DeclSome (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
|
|
412 |
| DeclSet (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
|
|
413 |
(* 'a fold_expr_funcs -> expr_assign -> 'a -> 'a *)
|
|
414 |
and fold_expr_assign F assign =
|
|
415 |
case assign of
|
|
416 |
AssignFormulaReg (x, f) => fold_formula F (FormulaReg x) #> fold_formula F f
|
|
417 |
| AssignRelReg (x, r) => fold_rel_expr F (RelReg x) #> fold_rel_expr F r
|
|
418 |
| AssignIntReg (x, i) => fold_int_expr F (IntReg x) #> fold_int_expr F i
|
|
419 |
|
|
420 |
type 'a fold_tuple_funcs = {
|
|
421 |
tuple_func: tuple -> 'a -> 'a,
|
|
422 |
tuple_set_func: tuple_set -> 'a -> 'a
|
|
423 |
}
|
|
424 |
|
|
425 |
(* 'a fold_tuple_funcs -> tuple -> 'a -> 'a *)
|
|
426 |
fun fold_tuple (F : 'a fold_tuple_funcs) = #tuple_func F
|
|
427 |
(* 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a *)
|
|
428 |
fun fold_tuple_set F tuple_set =
|
|
429 |
case tuple_set of
|
|
430 |
TupleUnion (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
|
|
431 |
| TupleDifference (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
|
|
432 |
| TupleIntersect (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
|
|
433 |
| TupleProduct (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
|
|
434 |
| TupleProject (ts, _) => fold_tuple_set F ts
|
|
435 |
| TupleSet ts => fold (fold_tuple F) ts
|
|
436 |
| TupleRange (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
|
|
437 |
| TupleArea (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
|
|
438 |
| TupleAtomSeq _ => #tuple_set_func F tuple_set
|
|
439 |
| TupleSetReg _ => #tuple_set_func F tuple_set
|
|
440 |
(* 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a *)
|
|
441 |
fun fold_tuple_assign F assign =
|
|
442 |
case assign of
|
|
443 |
AssignTuple (x, t) => fold_tuple F (TupleReg x) #> fold_tuple F t
|
|
444 |
| AssignTupleSet (x, ts) =>
|
|
445 |
fold_tuple_set F (TupleSetReg x) #> fold_tuple_set F ts
|
|
446 |
(* 'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a *)
|
|
447 |
fun fold_bound expr_F tuple_F (zs, tss) =
|
|
448 |
fold (fold_rel_expr expr_F) (map (Rel o fst) zs)
|
|
449 |
#> fold (fold_tuple_set tuple_F) tss
|
|
450 |
(* 'a fold_tuple_funcs -> int_bound -> 'a -> 'a *)
|
|
451 |
fun fold_int_bound F (_, tss) = fold (fold_tuple_set F) tss
|
|
452 |
|
|
453 |
(* int -> int *)
|
|
454 |
fun max_arity univ_card = floor (Math.ln 2147483647.0
|
|
455 |
/ Math.ln (Real.fromInt univ_card))
|
|
456 |
(* rel_expr -> int *)
|
|
457 |
fun arity_of_rel_expr (RelLet (_, r)) = arity_of_rel_expr r
|
|
458 |
| arity_of_rel_expr (RelIf (_, r1, _)) = arity_of_rel_expr r1
|
|
459 |
| arity_of_rel_expr (Union (r1, _)) = arity_of_rel_expr r1
|
|
460 |
| arity_of_rel_expr (Difference (r1, _)) = arity_of_rel_expr r1
|
|
461 |
| arity_of_rel_expr (Override (r1, _)) = arity_of_rel_expr r1
|
|
462 |
| arity_of_rel_expr (Intersect (r1, _)) = arity_of_rel_expr r1
|
|
463 |
| arity_of_rel_expr (Product (r1, r2)) = sum_arities_of_rel_exprs r1 r2
|
|
464 |
| arity_of_rel_expr (IfNo (r1, _)) = arity_of_rel_expr r1
|
|
465 |
| arity_of_rel_expr (Project (r, is)) = length is
|
|
466 |
| arity_of_rel_expr (Join (r1, r2)) = sum_arities_of_rel_exprs r1 r2 - 2
|
|
467 |
| arity_of_rel_expr (Closure _) = 2
|
|
468 |
| arity_of_rel_expr (ReflexiveClosure _) = 2
|
|
469 |
| arity_of_rel_expr (Transpose _) = 2
|
|
470 |
| arity_of_rel_expr (Comprehension (ds, _)) =
|
|
471 |
fold (curry op + o arity_of_decl) ds 0
|
|
472 |
| arity_of_rel_expr (Bits _) = 1
|
|
473 |
| arity_of_rel_expr (Int _) = 1
|
|
474 |
| arity_of_rel_expr Iden = 2
|
|
475 |
| arity_of_rel_expr Ints = 1
|
|
476 |
| arity_of_rel_expr None = 1
|
|
477 |
| arity_of_rel_expr Univ = 1
|
|
478 |
| arity_of_rel_expr (Atom _) = 1
|
|
479 |
| arity_of_rel_expr (AtomSeq _) = 1
|
|
480 |
| arity_of_rel_expr (Rel (n, _)) = n
|
|
481 |
| arity_of_rel_expr (Var (n, _)) = n
|
|
482 |
| arity_of_rel_expr (RelReg (n, _)) = n
|
|
483 |
(* rel_expr -> rel_expr -> int *)
|
|
484 |
and sum_arities_of_rel_exprs r1 r2 = arity_of_rel_expr r1 + arity_of_rel_expr r2
|
|
485 |
(* decl -> int *)
|
|
486 |
and arity_of_decl (DeclNo ((n, _), _)) = n
|
|
487 |
| arity_of_decl (DeclLone ((n, _), _)) = n
|
|
488 |
| arity_of_decl (DeclOne ((n, _), _)) = n
|
|
489 |
| arity_of_decl (DeclSome ((n, _), _)) = n
|
|
490 |
| arity_of_decl (DeclSet ((n, _), _)) = n
|
|
491 |
|
|
492 |
(* string -> bool *)
|
|
493 |
val is_relevant_setting = not o member (op =) ["solver", "delay"]
|
|
494 |
|
|
495 |
(* problem -> problem -> bool *)
|
|
496 |
fun problems_equivalent (p1 : problem) (p2 : problem) =
|
|
497 |
#univ_card p1 = #univ_card p2
|
|
498 |
andalso #formula p1 = #formula p2
|
|
499 |
andalso #bounds p1 = #bounds p2
|
|
500 |
andalso #expr_assigns p1 = #expr_assigns p2
|
|
501 |
andalso #tuple_assigns p1 = #tuple_assigns p2
|
|
502 |
andalso #int_bounds p1 = #int_bounds p2
|
|
503 |
andalso filter (is_relevant_setting o fst) (#settings p1)
|
|
504 |
= filter (is_relevant_setting o fst) (#settings p2)
|
|
505 |
|
|
506 |
(* int -> string *)
|
|
507 |
fun base_name j = if j < 0 then Int.toString (~j - 1) ^ "'" else Int.toString j
|
|
508 |
|
|
509 |
(* n_ary_index -> string -> string -> string -> string *)
|
|
510 |
fun n_ary_name (1, j) prefix _ _ = prefix ^ base_name j
|
|
511 |
| n_ary_name (2, j) _ prefix _ = prefix ^ base_name j
|
|
512 |
| n_ary_name (n, j) _ _ prefix = prefix ^ Int.toString n ^ "_" ^ base_name j
|
|
513 |
|
|
514 |
(* int -> string *)
|
|
515 |
fun atom_name j = "A" ^ base_name j
|
|
516 |
fun atom_seq_name (k, 0) = "u" ^ base_name k
|
|
517 |
| atom_seq_name (k, j0) = "u" ^ base_name k ^ "@" ^ base_name j0
|
|
518 |
fun formula_reg_name j = "$f" ^ base_name j
|
|
519 |
fun rel_reg_name j = "$e" ^ base_name j
|
|
520 |
fun int_reg_name j = "$i" ^ base_name j
|
|
521 |
|
|
522 |
(* n_ary_index -> string *)
|
|
523 |
fun tuple_name x = n_ary_name x "A" "P" "T"
|
|
524 |
fun rel_name x = n_ary_name x "s" "r" "m"
|
|
525 |
fun var_name x = n_ary_name x "S" "R" "M"
|
|
526 |
fun tuple_reg_name x = n_ary_name x "$A" "$P" "$T"
|
|
527 |
fun tuple_set_reg_name x = n_ary_name x "$a" "$p" "$t"
|
|
528 |
|
|
529 |
(* string -> string *)
|
|
530 |
fun inline_comment "" = ""
|
|
531 |
| inline_comment comment =
|
|
532 |
" /* " ^ translate_string (fn "\n" => " " | "*" => "* " | s => s) comment ^
|
|
533 |
" */"
|
|
534 |
fun block_comment "" = ""
|
|
535 |
| block_comment comment = prefix_lines "// " comment ^ "\n"
|
|
536 |
|
|
537 |
(* (n_ary_index * string) -> string *)
|
|
538 |
fun commented_rel_name (x, s) = rel_name x ^ inline_comment s
|
|
539 |
|
|
540 |
(* tuple -> string *)
|
|
541 |
fun string_for_tuple (Tuple js) = "[" ^ commas (map atom_name js) ^ "]"
|
|
542 |
| string_for_tuple (TupleIndex x) = tuple_name x
|
|
543 |
| string_for_tuple (TupleReg x) = tuple_reg_name x
|
|
544 |
|
|
545 |
val no_prec = 100
|
|
546 |
val prec_TupleUnion = 1
|
|
547 |
val prec_TupleIntersect = 2
|
|
548 |
val prec_TupleProduct = 3
|
|
549 |
val prec_TupleProject = 4
|
|
550 |
|
|
551 |
(* tuple_set -> int *)
|
|
552 |
fun precedence_ts (TupleUnion _) = prec_TupleUnion
|
|
553 |
| precedence_ts (TupleDifference _) = prec_TupleUnion
|
|
554 |
| precedence_ts (TupleIntersect _) = prec_TupleIntersect
|
|
555 |
| precedence_ts (TupleProduct _) = prec_TupleProduct
|
|
556 |
| precedence_ts (TupleProject _) = prec_TupleProject
|
|
557 |
| precedence_ts _ = no_prec
|
|
558 |
|
|
559 |
(* tuple_set -> string *)
|
|
560 |
fun string_for_tuple_set tuple_set =
|
|
561 |
let
|
|
562 |
(* tuple_set -> int -> string *)
|
|
563 |
fun sub tuple_set outer_prec =
|
|
564 |
let
|
|
565 |
val prec = precedence_ts tuple_set
|
|
566 |
val need_parens = (prec < outer_prec)
|
|
567 |
in
|
|
568 |
(if need_parens then "(" else "") ^
|
|
569 |
(case tuple_set of
|
|
570 |
TupleUnion (ts1, ts2) => sub ts1 prec ^ " + " ^ sub ts2 (prec + 1)
|
|
571 |
| TupleDifference (ts1, ts2) =>
|
|
572 |
sub ts1 prec ^ " - " ^ sub ts1 (prec + 1)
|
|
573 |
| TupleIntersect (ts1, ts2) => sub ts1 prec ^ " & " ^ sub ts1 prec
|
|
574 |
| TupleProduct (ts1, ts2) => sub ts1 prec ^ "->" ^ sub ts2 prec
|
|
575 |
| TupleProject (ts, c) => sub ts prec ^ "[" ^ Int.toString c ^ "]"
|
|
576 |
| TupleSet ts => "{" ^ commas (map string_for_tuple ts) ^ "}"
|
|
577 |
| TupleRange (t1, t2) =>
|
|
578 |
"{" ^ string_for_tuple t1 ^
|
|
579 |
(if t1 = t2 then "" else " .. " ^ string_for_tuple t2) ^ "}"
|
|
580 |
| TupleArea (t1, t2) =>
|
|
581 |
"{" ^ string_for_tuple t1 ^ " # " ^ string_for_tuple t2 ^ "}"
|
|
582 |
| TupleAtomSeq x => atom_seq_name x
|
|
583 |
| TupleSetReg x => tuple_set_reg_name x) ^
|
|
584 |
(if need_parens then ")" else "")
|
|
585 |
end
|
|
586 |
in sub tuple_set 0 end
|
|
587 |
|
|
588 |
(* tuple_assign -> string *)
|
|
589 |
fun string_for_tuple_assign (AssignTuple (x, t)) =
|
|
590 |
tuple_reg_name x ^ " := " ^ string_for_tuple t ^ "\n"
|
|
591 |
| string_for_tuple_assign (AssignTupleSet (x, ts)) =
|
|
592 |
tuple_set_reg_name x ^ " := " ^ string_for_tuple_set ts ^ "\n"
|
|
593 |
|
|
594 |
(* bound -> string *)
|
|
595 |
fun string_for_bound (zs, tss) =
|
|
596 |
"bounds " ^ commas (map commented_rel_name zs) ^ ": " ^
|
|
597 |
(if length tss = 1 then "" else "[") ^ commas (map string_for_tuple_set tss) ^
|
|
598 |
(if length tss = 1 then "" else "]") ^ "\n"
|
|
599 |
|
|
600 |
(* int_bound -> string *)
|
|
601 |
fun int_string_for_bound (opt_n, tss) =
|
|
602 |
(case opt_n of
|
|
603 |
SOME n => Int.toString n ^ ": "
|
|
604 |
| NONE => "") ^ "[" ^ commas (map string_for_tuple_set tss) ^ "]"
|
|
605 |
|
|
606 |
val prec_All = 1
|
|
607 |
val prec_Or = 2
|
|
608 |
val prec_Iff = 3
|
|
609 |
val prec_Implies = 4
|
|
610 |
val prec_And = 5
|
|
611 |
val prec_Not = 6
|
|
612 |
val prec_Eq = 7
|
|
613 |
val prec_Some = 8
|
|
614 |
val prec_SHL = 9
|
|
615 |
val prec_Add = 10
|
|
616 |
val prec_Mult = 11
|
|
617 |
val prec_Override = 12
|
|
618 |
val prec_Intersect = 13
|
|
619 |
val prec_Product = 14
|
|
620 |
val prec_IfNo = 15
|
|
621 |
val prec_Project = 17
|
|
622 |
val prec_Join = 18
|
|
623 |
val prec_BitNot = 19
|
|
624 |
|
|
625 |
(* formula -> int *)
|
|
626 |
fun precedence_f (All _) = prec_All
|
|
627 |
| precedence_f (Exist _) = prec_All
|
|
628 |
| precedence_f (FormulaLet _) = prec_All
|
|
629 |
| precedence_f (FormulaIf _) = prec_All
|
|
630 |
| precedence_f (Or _) = prec_Or
|
|
631 |
| precedence_f (Iff _) = prec_Iff
|
|
632 |
| precedence_f (Implies _) = prec_Implies
|
|
633 |
| precedence_f (And _) = prec_And
|
|
634 |
| precedence_f (Not _) = prec_Not
|
|
635 |
| precedence_f (Acyclic _) = no_prec
|
|
636 |
| precedence_f (Function _) = no_prec
|
|
637 |
| precedence_f (Functional _) = no_prec
|
|
638 |
| precedence_f (TotalOrdering _) = no_prec
|
|
639 |
| precedence_f (Subset _) = prec_Eq
|
|
640 |
| precedence_f (RelEq _) = prec_Eq
|
|
641 |
| precedence_f (IntEq _) = prec_Eq
|
|
642 |
| precedence_f (LT _) = prec_Eq
|
|
643 |
| precedence_f (LE _) = prec_Eq
|
|
644 |
| precedence_f (No _) = prec_Some
|
|
645 |
| precedence_f (Lone _) = prec_Some
|
|
646 |
| precedence_f (One _) = prec_Some
|
|
647 |
| precedence_f (Some _) = prec_Some
|
|
648 |
| precedence_f False = no_prec
|
|
649 |
| precedence_f True = no_prec
|
|
650 |
| precedence_f (FormulaReg _) = no_prec
|
|
651 |
(* rel_expr -> int *)
|
|
652 |
and precedence_r (RelLet _) = prec_All
|
|
653 |
| precedence_r (RelIf _) = prec_All
|
|
654 |
| precedence_r (Union _) = prec_Add
|
|
655 |
| precedence_r (Difference _) = prec_Add
|
|
656 |
| precedence_r (Override _) = prec_Override
|
|
657 |
| precedence_r (Intersect _) = prec_Intersect
|
|
658 |
| precedence_r (Product _) = prec_Product
|
|
659 |
| precedence_r (IfNo _) = prec_IfNo
|
|
660 |
| precedence_r (Project _) = prec_Project
|
|
661 |
| precedence_r (Join _) = prec_Join
|
|
662 |
| precedence_r (Closure _) = prec_BitNot
|
|
663 |
| precedence_r (ReflexiveClosure _) = prec_BitNot
|
|
664 |
| precedence_r (Transpose _) = prec_BitNot
|
|
665 |
| precedence_r (Comprehension _) = no_prec
|
|
666 |
| precedence_r (Bits _) = no_prec
|
|
667 |
| precedence_r (Int _) = no_prec
|
|
668 |
| precedence_r Iden = no_prec
|
|
669 |
| precedence_r Ints = no_prec
|
|
670 |
| precedence_r None = no_prec
|
|
671 |
| precedence_r Univ = no_prec
|
|
672 |
| precedence_r (Atom _) = no_prec
|
|
673 |
| precedence_r (AtomSeq _) = no_prec
|
|
674 |
| precedence_r (Rel _) = no_prec
|
|
675 |
| precedence_r (Var _) = no_prec
|
|
676 |
| precedence_r (RelReg _) = no_prec
|
|
677 |
(* int_expr -> int *)
|
|
678 |
and precedence_i (Sum _) = prec_All
|
|
679 |
| precedence_i (IntLet _) = prec_All
|
|
680 |
| precedence_i (IntIf _) = prec_All
|
|
681 |
| precedence_i (SHL _) = prec_SHL
|
|
682 |
| precedence_i (SHA _) = prec_SHL
|
|
683 |
| precedence_i (SHR _) = prec_SHL
|
|
684 |
| precedence_i (Add _) = prec_Add
|
|
685 |
| precedence_i (Sub _) = prec_Add
|
|
686 |
| precedence_i (Mult _) = prec_Mult
|
|
687 |
| precedence_i (Div _) = prec_Mult
|
|
688 |
| precedence_i (Mod _) = prec_Mult
|
|
689 |
| precedence_i (Cardinality _) = no_prec
|
|
690 |
| precedence_i (SetSum _) = no_prec
|
|
691 |
| precedence_i (BitOr _) = prec_Intersect
|
|
692 |
| precedence_i (BitXor _) = prec_Intersect
|
|
693 |
| precedence_i (BitAnd _) = prec_Intersect
|
|
694 |
| precedence_i (BitNot _) = prec_BitNot
|
|
695 |
| precedence_i (Neg _) = prec_BitNot
|
|
696 |
| precedence_i (Absolute _) = prec_BitNot
|
|
697 |
| precedence_i (Signum _) = prec_BitNot
|
|
698 |
| precedence_i (Num _) = no_prec
|
|
699 |
| precedence_i (IntReg _) = no_prec
|
|
700 |
|
|
701 |
(* (string -> unit) -> problem list -> unit *)
|
|
702 |
fun write_problem_file out problems =
|
|
703 |
let
|
|
704 |
(* formula -> unit *)
|
|
705 |
fun out_outmost_f (And (f1, f2)) =
|
|
706 |
(out_outmost_f f1; out "\n && "; out_outmost_f f2)
|
|
707 |
| out_outmost_f f = out_f f prec_And
|
|
708 |
(* formula -> int -> unit *)
|
|
709 |
and out_f formula outer_prec =
|
|
710 |
let
|
|
711 |
val prec = precedence_f formula
|
|
712 |
val need_parens = (prec < outer_prec)
|
|
713 |
in
|
|
714 |
(if need_parens then out "(" else ());
|
|
715 |
(case formula of
|
|
716 |
All (ds, f) => (out "all ["; out_decls ds; out "] | "; out_f f prec)
|
|
717 |
| Exist (ds, f) =>
|
|
718 |
(out "some ["; out_decls ds; out "] | "; out_f f prec)
|
|
719 |
| FormulaLet (bs, f) =>
|
|
720 |
(out "let ["; out_assigns bs; out "] | "; out_f f prec)
|
|
721 |
| FormulaIf (f, f1, f2) =>
|
|
722 |
(out "if "; out_f f prec; out " then "; out_f f1 prec; out " else ";
|
|
723 |
out_f f2 prec)
|
|
724 |
| Or (f1, f2) => (out_f f1 prec; out " || "; out_f f2 prec)
|
|
725 |
| Iff (f1, f2) => (out_f f1 prec; out " <=> "; out_f f2 prec)
|
|
726 |
| Implies (f1, f2) => (out_f f1 (prec + 1); out " => "; out_f f2 prec)
|
|
727 |
| And (f1, f2) => (out_f f1 prec; out " && "; out_f f2 prec)
|
|
728 |
| Not f => (out "! "; out_f f prec)
|
|
729 |
| Acyclic x => out ("ACYCLIC(" ^ rel_name x ^ ")")
|
|
730 |
| Function (x, r1, r2) =>
|
|
731 |
(out ("FUNCTION(" ^ rel_name x ^ ", "); out_r r1 0; out " -> one ";
|
|
732 |
out_r r2 0; out ")")
|
|
733 |
| Functional (x, r1, r2) =>
|
|
734 |
(out ("FUNCTION(" ^ rel_name x ^ ", "); out_r r1 0; out " -> lone ";
|
|
735 |
out_r r2 0; out ")")
|
|
736 |
| TotalOrdering (x1, x2, x3, x4) =>
|
|
737 |
out ("TOTAL_ORDERING(" ^ rel_name x1 ^ ", " ^ rel_name x2 ^ ", "
|
|
738 |
^ rel_name x3 ^ ", " ^ rel_name x4 ^ ")")
|
|
739 |
| Subset (r1, r2) => (out_r r1 prec; out " in "; out_r r2 prec)
|
|
740 |
| RelEq (r1, r2) => (out_r r1 prec; out " = "; out_r r2 prec)
|
|
741 |
| IntEq (i1, i2) => (out_i i1 prec; out " = "; out_i i2 prec)
|
|
742 |
| LT (i1, i2) => (out_i i1 prec; out " < "; out_i i2 prec)
|
|
743 |
| LE (i1, i2) => (out_i i1 prec; out " <= "; out_i i2 prec)
|
|
744 |
| No r => (out "no "; out_r r prec)
|
|
745 |
| Lone r => (out "lone "; out_r r prec)
|
|
746 |
| One r => (out "one "; out_r r prec)
|
|
747 |
| Some r => (out "some "; out_r r prec)
|
|
748 |
| False => out "false"
|
|
749 |
| True => out "true"
|
|
750 |
| FormulaReg j => out (formula_reg_name j));
|
|
751 |
(if need_parens then out ")" else ())
|
|
752 |
end
|
|
753 |
(* rel_expr -> int -> unit *)
|
|
754 |
and out_r rel_expr outer_prec =
|
|
755 |
let
|
|
756 |
val prec = precedence_r rel_expr
|
|
757 |
val need_parens = (prec < outer_prec)
|
|
758 |
in
|
|
759 |
(if need_parens then out "(" else ());
|
|
760 |
(case rel_expr of
|
|
761 |
RelLet (bs, r) =>
|
|
762 |
(out "let ["; out_assigns bs; out "] | "; out_r r prec)
|
|
763 |
| RelIf (f, r1, r2) =>
|
|
764 |
(out "if "; out_f f prec; out " then "; out_r r1 prec;
|
|
765 |
out " else "; out_r r2 prec)
|
|
766 |
| Union (r1, r2) => (out_r r1 prec; out " + "; out_r r2 (prec + 1))
|
|
767 |
| Difference (r1, r2) =>
|
|
768 |
(out_r r1 prec; out " - "; out_r r2 (prec + 1))
|
|
769 |
| Override (r1, r2) => (out_r r1 prec; out " ++ "; out_r r2 prec)
|
|
770 |
| Intersect (r1, r2) => (out_r r1 prec; out " & "; out_r r2 prec)
|
|
771 |
| Product (r1, r2) => (out_r r1 prec; out "->"; out_r r2 prec)
|
|
772 |
| IfNo (r1, r2) => (out_r r1 prec; out "\\"; out_r r2 prec)
|
|
773 |
| Project (r1, is) => (out_r r1 prec; out "["; out_columns is; out "]")
|
|
774 |
| Join (r1, r2) => (out_r r1 prec; out "."; out_r r2 (prec + 1))
|
|
775 |
| Closure r => (out "^"; out_r r prec)
|
|
776 |
| ReflexiveClosure r => (out "*"; out_r r prec)
|
|
777 |
| Transpose r => (out "~"; out_r r prec)
|
|
778 |
| Comprehension (ds, f) =>
|
|
779 |
(out "{["; out_decls ds; out "] | "; out_f f 0; out "}")
|
|
780 |
| Bits i => (out "Bits["; out_i i 0; out "]")
|
|
781 |
| Int i => (out "Int["; out_i i 0; out "]")
|
|
782 |
| Iden => out "iden"
|
|
783 |
| Ints => out "ints"
|
|
784 |
| None => out "none"
|
|
785 |
| Univ => out "univ"
|
|
786 |
| Atom j => out (atom_name j)
|
|
787 |
| AtomSeq x => out (atom_seq_name x)
|
|
788 |
| Rel x => out (rel_name x)
|
|
789 |
| Var x => out (var_name x)
|
|
790 |
| RelReg (_, j) => out (rel_reg_name j));
|
|
791 |
(if need_parens then out ")" else ())
|
|
792 |
end
|
|
793 |
(* int_expr -> int -> unit *)
|
|
794 |
and out_i int_expr outer_prec =
|
|
795 |
let
|
|
796 |
val prec = precedence_i int_expr
|
|
797 |
val need_parens = (prec < outer_prec)
|
|
798 |
in
|
|
799 |
(if need_parens then out "(" else ());
|
|
800 |
(case int_expr of
|
|
801 |
Sum (ds, i) => (out "sum ["; out_decls ds; out "] | "; out_i i prec)
|
|
802 |
| IntLet (bs, i) =>
|
|
803 |
(out "let ["; out_assigns bs; out "] | "; out_i i prec)
|
|
804 |
| IntIf (f, i1, i2) =>
|
|
805 |
(out "if "; out_f f prec; out " then "; out_i i1 prec;
|
|
806 |
out " else "; out_i i2 prec)
|
|
807 |
| SHL (i1, i2) => (out_i i1 prec; out " << "; out_i i2 (prec + 1))
|
|
808 |
| SHA (i1, i2) => (out_i i1 prec; out " >> "; out_i i2 (prec + 1))
|
|
809 |
| SHR (i1, i2) => (out_i i1 prec; out " >>> "; out_i i2 (prec + 1))
|
|
810 |
| Add (i1, i2) => (out_i i1 prec; out " + "; out_i i2 (prec + 1))
|
|
811 |
| Sub (i1, i2) => (out_i i1 prec; out " - "; out_i i2 (prec + 1))
|
|
812 |
| Mult (i1, i2) => (out_i i1 prec; out " * "; out_i i2 (prec + 1))
|
|
813 |
| Div (i1, i2) => (out_i i1 prec; out " / "; out_i i2 (prec + 1))
|
|
814 |
| Mod (i1, i2) => (out_i i1 prec; out " % "; out_i i2 (prec + 1))
|
|
815 |
| Cardinality r => (out "#("; out_r r 0; out ")")
|
|
816 |
| SetSum r => (out "sum("; out_r r 0; out ")")
|
|
817 |
| BitOr (i1, i2) => (out_i i1 prec; out " | "; out_i i2 prec)
|
|
818 |
| BitXor (i1, i2) => (out_i i1 prec; out " ^ "; out_i i2 prec)
|
|
819 |
| BitAnd (i1, i2) => (out_i i1 prec; out " & "; out_i i2 prec)
|
|
820 |
| BitNot i => (out "~"; out_i i prec)
|
|
821 |
| Neg i => (out "-"; out_i i prec)
|
|
822 |
| Absolute i => (out "abs "; out_i i prec)
|
|
823 |
| Signum i => (out "sgn "; out_i i prec)
|
|
824 |
| Num k => out (Int.toString k)
|
|
825 |
| IntReg j => out (int_reg_name j));
|
|
826 |
(if need_parens then out ")" else ())
|
|
827 |
end
|
|
828 |
(* decl list -> unit *)
|
|
829 |
and out_decls [] = ()
|
|
830 |
| out_decls [d] = out_decl d
|
|
831 |
| out_decls (d :: ds) = (out_decl d; out ", "; out_decls ds)
|
|
832 |
(* decl -> unit *)
|
|
833 |
and out_decl (DeclNo (x, r)) =
|
|
834 |
(out (var_name x); out " : no "; out_r r 0)
|
|
835 |
| out_decl (DeclLone (x, r)) =
|
|
836 |
(out (var_name x); out " : lone "; out_r r 0)
|
|
837 |
| out_decl (DeclOne (x, r)) =
|
|
838 |
(out (var_name x); out " : one "; out_r r 0)
|
|
839 |
| out_decl (DeclSome (x, r)) =
|
|
840 |
(out (var_name x); out " : some "; out_r r 0)
|
|
841 |
| out_decl (DeclSet (x, r)) =
|
|
842 |
(out (var_name x); out " : set "; out_r r 0)
|
|
843 |
(* assign_expr list -> unit *)
|
|
844 |
and out_assigns [] = ()
|
|
845 |
| out_assigns [b] = out_assign b
|
|
846 |
| out_assigns (b :: bs) = (out_assign b; out ", "; out_assigns bs)
|
|
847 |
(* assign_expr -> unit *)
|
|
848 |
and out_assign (AssignFormulaReg (j, f)) =
|
|
849 |
(out (formula_reg_name j); out " := "; out_f f 0)
|
|
850 |
| out_assign (AssignRelReg ((_, j), r)) =
|
|
851 |
(out (rel_reg_name j); out " := "; out_r r 0)
|
|
852 |
| out_assign (AssignIntReg (j, i)) =
|
|
853 |
(out (int_reg_name j); out " := "; out_i i 0)
|
|
854 |
(* int_expr list -> unit *)
|
|
855 |
and out_columns [] = ()
|
|
856 |
| out_columns [i] = out_i i 0
|
|
857 |
| out_columns (i :: is) = (out_i i 0; out ", "; out_columns is)
|
|
858 |
(* problem -> unit *)
|
|
859 |
and out_problem {comment, settings, univ_card, tuple_assigns, bounds,
|
|
860 |
int_bounds, expr_assigns, formula} =
|
|
861 |
(out ("\n" ^ block_comment comment ^
|
|
862 |
implode (map (fn (key, value) => key ^ ": " ^ value ^ "\n")
|
|
863 |
settings) ^
|
|
864 |
"univ: " ^ atom_seq_name (univ_card, 0) ^ "\n" ^
|
|
865 |
implode (map string_for_tuple_assign tuple_assigns) ^
|
|
866 |
implode (map string_for_bound bounds) ^
|
|
867 |
(if int_bounds = [] then
|
|
868 |
""
|
|
869 |
else
|
|
870 |
"int_bounds: " ^
|
|
871 |
commas (map int_string_for_bound int_bounds) ^ "\n"));
|
|
872 |
map (fn b => (out_assign b; out ";")) expr_assigns;
|
|
873 |
out "solve "; out_outmost_f formula; out ";\n")
|
|
874 |
in
|
|
875 |
out ("// This file was generated by Isabelle (probably Nitpick)\n" ^
|
|
876 |
"// " ^ Date.fmt "%Y-%m-%d %H:%M:%S"
|
|
877 |
(Date.fromTimeLocal (Time.now ())) ^ "\n");
|
|
878 |
map out_problem problems
|
|
879 |
end
|
|
880 |
|
|
881 |
(* string -> bool *)
|
|
882 |
fun is_ident_char s =
|
|
883 |
Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s
|
|
884 |
orelse s = "_" orelse s = "'" orelse s = "$"
|
|
885 |
|
|
886 |
(* string list -> string list *)
|
|
887 |
fun strip_blanks [] = []
|
|
888 |
| strip_blanks (" " :: ss) = strip_blanks ss
|
|
889 |
| strip_blanks [s1, " "] = [s1]
|
|
890 |
| strip_blanks (s1 :: " " :: s2 :: ss) =
|
|
891 |
if is_ident_char s1 andalso is_ident_char s2 then
|
|
892 |
s1 :: " " :: strip_blanks (s2 :: ss)
|
|
893 |
else
|
|
894 |
strip_blanks (s1 :: s2 :: ss)
|
|
895 |
| strip_blanks (s :: ss) = s :: strip_blanks ss
|
|
896 |
|
|
897 |
(* (string list -> 'a * string list) -> string list -> 'a list * string list *)
|
|
898 |
fun scan_non_empty_list scan = scan ::: Scan.repeat ($$ "," |-- scan)
|
|
899 |
fun scan_list scan = scan_non_empty_list scan || Scan.succeed []
|
|
900 |
(* string list -> int * string list *)
|
|
901 |
val scan_nat = Scan.repeat1 (Scan.one Symbol.is_ascii_digit)
|
|
902 |
>> (the o Int.fromString o space_implode "")
|
|
903 |
(* string list -> (int * int) * string list *)
|
|
904 |
val scan_rel_name = $$ "s" |-- scan_nat >> pair 1
|
|
905 |
|| $$ "r" |-- scan_nat >> pair 2
|
|
906 |
|| ($$ "m" |-- scan_nat --| $$ "_") -- scan_nat
|
|
907 |
(* string list -> int * string list *)
|
|
908 |
val scan_atom = $$ "A" |-- scan_nat
|
|
909 |
(* string list -> int list * string list *)
|
|
910 |
val scan_tuple = $$ "[" |-- scan_list scan_atom --| $$ "]"
|
|
911 |
(* string list -> int list list * string list *)
|
|
912 |
val scan_tuple_set = $$ "[" |-- scan_list scan_tuple --| $$ "]"
|
|
913 |
(* string list -> ((int * int) * int list list) * string list *)
|
|
914 |
val scan_assignment = (scan_rel_name --| $$ "=") -- scan_tuple_set
|
|
915 |
(* string list -> ((int * int) * int list list) list * string list *)
|
|
916 |
val scan_instance = Scan.this_string "relations:" |--
|
|
917 |
$$ "{" |-- scan_list scan_assignment --| $$ "}"
|
|
918 |
|
|
919 |
(* string -> raw_bound list *)
|
|
920 |
fun parse_instance inst =
|
|
921 |
Scan.finite Symbol.stopper
|
|
922 |
(Scan.error (!! (fn _ => raise SYNTAX ("Kodkod.parse_instance",
|
|
923 |
"ill-formed Kodkodi output"))
|
|
924 |
scan_instance))
|
|
925 |
(strip_blanks (explode inst))
|
|
926 |
|> fst
|
|
927 |
|
|
928 |
val problem_marker = "*** PROBLEM "
|
|
929 |
val outcome_marker = "---OUTCOME---\n"
|
|
930 |
val instance_marker = "---INSTANCE---\n"
|
|
931 |
|
|
932 |
(* string -> substring -> string *)
|
|
933 |
fun read_section_body marker =
|
|
934 |
Substring.string o fst o Substring.position "\n\n"
|
|
935 |
o Substring.triml (size marker)
|
|
936 |
|
|
937 |
(* substring -> raw_bound list *)
|
|
938 |
fun read_next_instance s =
|
|
939 |
let val s = Substring.position instance_marker s |> snd in
|
|
940 |
if Substring.isEmpty s then
|
|
941 |
raise SYNTAX ("Kodkod.read_next_instance", "expected \"INSTANCE\" marker")
|
|
942 |
else
|
|
943 |
read_section_body instance_marker s |> parse_instance
|
|
944 |
end
|
|
945 |
|
|
946 |
(* int -> substring * (int * raw_bound list) list * int list
|
|
947 |
-> substring * (int * raw_bound list) list * int list *)
|
|
948 |
fun read_next_outcomes j (s, ps, js) =
|
|
949 |
let val (s1, s2) = Substring.position outcome_marker s in
|
|
950 |
if Substring.isEmpty s2
|
|
951 |
orelse not (Substring.isEmpty (Substring.position problem_marker s1
|
|
952 |
|> snd)) then
|
|
953 |
(s, ps, js)
|
|
954 |
else
|
|
955 |
let
|
|
956 |
val outcome = read_section_body outcome_marker s2
|
|
957 |
val s = Substring.triml (size outcome_marker) s2
|
|
958 |
in
|
|
959 |
if String.isSuffix "UNSATISFIABLE" outcome then
|
|
960 |
read_next_outcomes j (s, ps, j :: js)
|
|
961 |
else if String.isSuffix "SATISFIABLE" outcome then
|
|
962 |
read_next_outcomes j (s, (j, read_next_instance s2) :: ps, js)
|
|
963 |
else
|
|
964 |
raise SYNTAX ("Kodkod.read_next_outcomes",
|
|
965 |
"unknown outcome " ^ quote outcome)
|
|
966 |
end
|
|
967 |
end
|
|
968 |
|
|
969 |
(* substring * (int * raw_bound list) list * int list
|
|
970 |
-> (int * raw_bound list) list * int list *)
|
|
971 |
fun read_next_problems (s, ps, js) =
|
|
972 |
let val s = Substring.position problem_marker s |> snd in
|
|
973 |
if Substring.isEmpty s then
|
|
974 |
(ps, js)
|
|
975 |
else
|
|
976 |
let
|
|
977 |
val s = Substring.triml (size problem_marker) s
|
|
978 |
val j_plus_1 = s |> Substring.takel (not_equal #" ") |> Substring.string
|
|
979 |
|> Int.fromString |> the
|
|
980 |
val j = j_plus_1 - 1
|
|
981 |
in read_next_problems (read_next_outcomes j (s, ps, js)) end
|
|
982 |
end
|
|
983 |
handle Option.Option => raise SYNTAX ("Kodkod.read_next_problems",
|
|
984 |
"expected number after \"PROBLEM\"")
|
|
985 |
|
|
986 |
(* Path.T -> (int * raw_bound list) list * int list *)
|
|
987 |
fun read_output_file path =
|
|
988 |
read_next_problems (Substring.full (File.read path), [], []) |>> rev ||> rev
|
|
989 |
|
|
990 |
(* The fudge term below is to account for Kodkodi's slow start-up time, which
|
|
991 |
is partly due to the JVM and partly due to the ML "system" function. *)
|
|
992 |
val fudge_ms = 250
|
|
993 |
|
|
994 |
(* bool -> Time.time option -> int -> int -> problem list -> outcome *)
|
|
995 |
fun solve_any_problem overlord deadline max_threads max_solutions problems =
|
|
996 |
let
|
|
997 |
val j = find_index (equal True o #formula) problems
|
|
998 |
val indexed_problems = if j >= 0 then
|
|
999 |
[(j, nth problems j)]
|
|
1000 |
else
|
|
1001 |
filter (not_equal False o #formula o snd)
|
|
1002 |
(0 upto length problems - 1 ~~ problems)
|
|
1003 |
val triv_js = filter_out (AList.defined (op =) indexed_problems)
|
|
1004 |
(0 upto length problems - 1)
|
|
1005 |
(* int -> int *)
|
|
1006 |
val reindex = fst o nth indexed_problems
|
|
1007 |
in
|
|
1008 |
if null indexed_problems then
|
|
1009 |
Normal ([], triv_js)
|
|
1010 |
else
|
|
1011 |
let
|
|
1012 |
val (serial_str, tmp_path) =
|
|
1013 |
if overlord then
|
|
1014 |
("", Path.append (Path.variable "ISABELLE_HOME_USER") o Path.base)
|
|
1015 |
else
|
|
1016 |
(serial_string (), File.tmp_path)
|
|
1017 |
(* string -> string -> Path.T *)
|
|
1018 |
fun path_for base suf =
|
|
1019 |
tmp_path (Path.explode (base ^ serial_str ^ "." ^ suf))
|
|
1020 |
val in_path = path_for "isabelle" "kki"
|
|
1021 |
val in_buf = Unsynchronized.ref Buffer.empty
|
|
1022 |
(* string -> unit *)
|
|
1023 |
fun out s = Unsynchronized.change in_buf (Buffer.add s)
|
|
1024 |
val out_path = path_for "kodkodi" "out"
|
|
1025 |
val err_path = path_for "kodkodi" "err"
|
|
1026 |
val _ = write_problem_file out (map snd indexed_problems)
|
|
1027 |
val _ = File.write_buffer in_path (!in_buf)
|
|
1028 |
(* (int list -> outcome) -> outcome *)
|
|
1029 |
fun stopped constr =
|
|
1030 |
let val nontriv_js = map reindex (snd (read_output_file out_path)) in
|
|
1031 |
constr (triv_js @ nontriv_js)
|
|
1032 |
handle Exn.Interrupt => Interrupted NONE
|
|
1033 |
end
|
|
1034 |
in
|
|
1035 |
let
|
|
1036 |
val ms =
|
|
1037 |
case deadline of
|
|
1038 |
NONE => ~1
|
|
1039 |
| SOME time =>
|
|
1040 |
Int.max (0, Time.toMilliseconds (Time.- (time, Time.now ()))
|
|
1041 |
- fudge_ms)
|
|
1042 |
val outcome =
|
|
1043 |
let
|
|
1044 |
val code =
|
|
1045 |
system ("env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
|
|
1046 |
\\"$ISABELLE_TOOL\" java \
|
|
1047 |
\de.tum.in.isabelle.Kodkodi.Kodkodi" ^
|
|
1048 |
(if ms >= 0 then " -max-msecs " ^ Int.toString ms
|
|
1049 |
else "") ^
|
|
1050 |
(if max_solutions > 1 then " -solve-all" else "") ^
|
|
1051 |
" -max-solutions " ^ Int.toString max_solutions ^
|
|
1052 |
(if max_threads > 0 then
|
|
1053 |
" -max-threads " ^ Int.toString max_threads
|
|
1054 |
else
|
|
1055 |
"") ^
|
|
1056 |
" < " ^ Path.implode in_path ^
|
|
1057 |
" > " ^ Path.implode out_path ^
|
|
1058 |
" 2> " ^ Path.implode err_path)
|
|
1059 |
val (ps, nontriv_js) = read_output_file out_path
|
|
1060 |
|>> map (apfst reindex) ||> map reindex
|
|
1061 |
val js = triv_js @ nontriv_js
|
|
1062 |
val first_error =
|
|
1063 |
File.fold_lines (fn line => fn "" => line | s => s) err_path ""
|
|
1064 |
in
|
|
1065 |
if null ps then
|
|
1066 |
if code = 2 then
|
|
1067 |
TimedOut js
|
|
1068 |
else if first_error <> "" then
|
|
1069 |
Error (first_error |> perhaps (try (unsuffix "."))
|
|
1070 |
|> perhaps (try (unprefix "Error: ")), js)
|
|
1071 |
else if code <> 0 then
|
|
1072 |
Error ("Unknown error", js)
|
|
1073 |
else
|
|
1074 |
Normal ([], js)
|
|
1075 |
else
|
|
1076 |
Normal (ps, js)
|
|
1077 |
end
|
|
1078 |
in
|
|
1079 |
if overlord then ()
|
|
1080 |
else List.app File.rm [in_path, out_path, err_path];
|
|
1081 |
outcome
|
|
1082 |
end
|
|
1083 |
handle Exn.Interrupt => stopped (Interrupted o SOME)
|
|
1084 |
end
|
|
1085 |
end
|
|
1086 |
|
|
1087 |
end;
|