· 4 years ago · May 13, 2021, 06:54 PM
1/* CLP(ℤ): Constraint Logic Programming over Integers.
2
3 Author: Markus Triska
4 E-mail: triska@metalevel.at
5 WWW: https://www.metalevel.at
6 Copyright (C): 2016-2020 Markus Triska
7
8 This library provides CLP(ℤ):
9
10 Constraint Logic Programming over Integers
11 ==========================================
12
13 Highlights:
14
15 -) DECLARATIVE implementation of integer arithmetic.
16 -) Fully relational, MONOTONIC execution mode.
17 -) Always TERMINATING labeling.
18
19
20 Permission is hereby granted, free of charge, to any person
21 obtaining a copy of this software and associated documentation
22 files (the "Software"), to deal in the Software without
23 restriction, including without limitation the rights to use, copy,
24 modify, merge, publish, distribute, sublicense, and/or sell copies
25 of the Software, and to permit persons to whom the Software is
26 furnished to do so, subject to the following conditions:
27
28 The above copyright notice and this permission notice shall be
29 included in all copies or substantial portions of the Software.
30
31 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
32 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
33 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
34 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
35 HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
36 WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
37 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
38 DEALINGS IN THE SOFTWARE.
39
40*/
41
42
43:- module(clpz, [
44 op(760, yfx, #<==>),
45 op(750, xfy, #==>),
46 op(750, yfx, #<==),
47 op(740, yfx, #\/),
48 op(730, yfx, #\),
49 op(720, yfx, #/\),
50 op(710, fy, #\),
51 op(700, xfx, #>),
52 op(700, xfx, #<),
53 op(700, xfx, #>=),
54 op(700, xfx, #=<),
55 op(700, xfx, #=),
56 op(700, xfx, #\=),
57 op(700, xfx, in),
58 op(700, xfx, ins),
59 op(450, xfx, ..), % should bind more tightly than \/
60 op(150, fx, #),
61 (#>)/2,
62 (#<)/2,
63 (#>=)/2,
64 (#=<)/2,
65 (#=)/2,
66 (#\=)/2,
67 (#\)/1,
68 (#<==>)/2,
69 (#==>)/2,
70 (#<==)/2,
71 (#\/)/2,
72 (#\)/2,
73 (#/\)/2,
74 (in)/2,
75 (ins)/2,
76 all_different/1,
77 all_distinct/1,
78 nvalue/2,
79 sum/3,
80 scalar_product/4,
81 tuples_in/2,
82 labeling/2,
83 label/1,
84 indomain/1,
85 lex_chain/1,
86 serialized/2,
87 global_cardinality/2,
88 global_cardinality/3,
89 circuit/1,
90 cumulative/1,
91 cumulative/2,
92 disjoint2/1,
93 element/3,
94 automaton/3,
95 automaton/8,
96 zcompare/3,
97 chain/2,
98 fd_var/1,
99 fd_inf/2,
100 fd_sup/2,
101 fd_size/2,
102 fd_dom/2,
103
104 % for use in predicates from library(reif)
105 (#=)/3,
106 (#<)/3
107
108 % called from goal_expansion
109 % clpz_equal/2,
110 % clpz_geq/2
111 ]).
112
113
114:- use_module(library(debug)).
115:- use_module(library(format)).
116
117:- use_module(library(assoc)).
118:- use_module(library(pairs)).
119:- use_module(library(between)).
120:- use_module(library(lists)).
121:- use_module(library(atts)).
122:- use_module(library(iso_ext)).
123:- use_module(library(dcgs)).
124:- use_module(library(terms)).
125:- use_module(library(error), [domain_error/3, type_error/3]).
126:- use_module(library(si)).
127:- use_module(library(freeze)).
128
129% :- use_module(library(types)).
130
131:- attribute
132 clpz/1,
133 clpz_aux/1,
134 clpz_relation/1,
135 edges/1,
136 flow/1,
137 parent/1,
138 free/1,
139 g0_edges/1,
140 used/1,
141 lowlink/1,
142 value/1,
143 visited/1,
144 index/1,
145 in_stack/1,
146 clpz_gcc_vs/1,
147 clpz_gcc_num/1,
148 clpz_gcc_occurred/1,
149 queue/2,
150 enabled/1.
151
152:- dynamic(monotonic/0).
153:- dynamic(clpz_equal_/2).
154:- dynamic(clpz_geq_/2).
155:- dynamic(clpz_neq/2).
156
157/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
158 Compatibility predicates.
159- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
160
161cyclic_term(T) :-
162 \+ acyclic_term(T).
163
164must_be(What, Term) :- must_be(What, unknown(Term)-1, Term).
165
166must_be(ground, _, Term) :- !,
167 ( ground(Term) -> true
168 ; format("ground\n", []), instantiation_error(Term)
169 ).
170must_be(acyclic, Where, Term) :- !,
171 ( acyclic_term(Term) ->
172 true
173 ; domain_error(acyclic_term, Term, Where)
174 ).
175must_be(list, Where, Term) :- !,
176 ( list_si(Term) -> true
177 ; type_error(list, Term, Where)
178 ).
179must_be(list(What), Where, Term) :- !,
180 must_be(list, Where, Term),
181 maplist(must_be(What, Where), Term).
182must_be(Type, _, Term) :-
183 error:must_be(Type, Term).
184
185
186instantiation_error(Term) :- instantiation_error(Term, unknown(Term)-1).
187
188instantiation_error(_, Goal-Arg) :-
189 throw(error(instantiation_error, instantiation_error(Goal, Arg))).
190
191
192domain_error(Expectation, Term) :-
193 domain_error(Expectation, Term, unknown(Term)-1).
194
195type_error(Expectation, Term) :-
196 type_error(Expectation, Term, unknown(Term)-1).
197
198
199partition(Pred, Ls0, As, Bs) :-
200 include(Pred, Ls0, As),
201 exclude(Pred, Ls0, Bs).
202
203
204partition(Pred, Ls0, Ls, Es, Gs) :-
205 partition_(Ls0, Pred, Ls, Es, Gs).
206
207partition_([], _, [], [], []).
208partition_([X|Xs], Pred, Ls0, Es0, Gs0) :-
209 call(Pred, X, Cmp),
210 ( Cmp = (<) -> Ls0 = [X|Rest], partition_(Xs, Pred, Rest, Es0, Gs0)
211 ; Cmp = (=) -> Es0 = [X|Rest], partition_(Xs, Pred, Ls0, Rest, Gs0)
212 ; Cmp = (>) -> Gs0 = [X|Rest], partition_(Xs, Pred, Ls0, Es0, Rest)
213 ).
214
215/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
216 include/3 and exclude/3
217- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
218
219include(Goal, Ls0, Ls) :-
220 include_(Ls0, Goal, Ls).
221
222include_([], _, []).
223include_([L|Ls0], Goal, Ls) :-
224 ( call(Goal, L) ->
225 Ls = [L|Rest]
226 ; Ls = Rest
227 ),
228 include_(Ls0, Goal, Rest).
229
230
231
232exclude(Goal, Ls0, Ls) :-
233 exclude_(Ls0, Goal, Ls).
234
235exclude_([], _, []).
236exclude_([L|Ls0], Goal, Ls) :-
237 ( call(Goal, L) ->
238 Ls = Rest
239 ; Ls = [L|Rest]
240 ),
241 exclude_(Ls0, Goal, Rest).
242
243
244%:- discontiguous clpz:goal_expansion/5.
245
246
247/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
248 Public operators.
249- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
250
251:- op(760, yfx, #<==>).
252:- op(750, xfy, #==>).
253:- op(750, yfx, #<==).
254:- op(740, yfx, #\/).
255:- op(730, yfx, #\).
256:- op(720, yfx, #/\).
257:- op(710, fy, #\).
258:- op(700, xfx, #>).
259:- op(700, xfx, #<).
260:- op(700, xfx, #>=).
261:- op(700, xfx, #=<).
262:- op(700, xfx, #=).
263:- op(700, xfx, #\=).
264:- op(700, xfx, in).
265:- op(700, xfx, ins).
266:- op(450, xfx, ..). % should bind more tightly than \/
267:- op(150, fx, #).
268
269/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
270 Privately needed operators.
271- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
272
273:- op(700, xfx, cis).
274:- op(700, xfx, cis_geq).
275:- op(700, xfx, cis_gt).
276:- op(700, xfx, cis_leq).
277:- op(700, xfx, cis_lt).
278:- op(1200, xfx, ++>).
279
280/** <module> Constraint Logic Programming over Integers
281
282## Introduction {#clpz-intro}
283
284This library provides CLP(ℤ): Constraint Logic Programming over
285Integers.
286
287CLP(ℤ) is an instance of the general CLP(.) scheme, extending logic
288programming with reasoning over specialised domains. CLP(ℤ) lets us
289reason about **integers** in a way that honors the relational nature
290of Prolog.
291
292There are two major use cases of CLP(ℤ) constraints:
293
294 1. [**declarative integer arithmetic**](<#clpz-integer-arith>)
295 2. solving **combinatorial problems** such as planning, scheduling
296 and allocation tasks.
297
298The predicates of this library can be classified as:
299
300 * _arithmetic_ constraints like #=/2, #>/2 and #\=/2 [](<#clpz-arithmetic>)
301 * the _membership_ constraints in/2 and ins/2 [](<#clpz-membership>)
302 * the _enumeration_ predicates indomain/1, label/1 and labeling/2 [](<#clpz-enumeration>)
303 * _combinatorial_ constraints like all_distinct/1 and global_cardinality/2 [](<#clpz-global>)
304 * _reification_ predicates such as #<==>/2 [](<#clpz-reification-predicates>)
305 * _reflection_ predicates such as fd_dom/2 [](<#clpz-reflection-predicates>)
306
307In most cases, [_arithmetic constraints_](<#clpz-arith-constraints>)
308are the only predicates you will ever need from this library. When
309reasoning over integers, simply replace low-level arithmetic
310predicates like `(is)/2` and `(>)/2` by the corresponding CLP(ℤ)
311constraints like #=/2 and #>/2 to honor and preserve declarative
312properties of your programs. For satisfactory performance, arithmetic
313constraints are implicitly rewritten at compilation time so that
314low-level fallback predicates are automatically used whenever
315possible.
316
317Almost all Prolog programs also reason about integers. Therefore, it
318is highly advisable that you make CLP(ℤ) constraints available in all
319your programs. One way to do this is to put the following directive in
320your =|~/.swiplrc|= initialisation file:
321
322==
323:- use_module(library(clpz)).
324==
325
326All example programs that appear in the CLP(ℤ) documentation assume
327that you have done this.
328
329Important concepts and principles of this library are illustrated by
330means of usage examples that are available in a public git repository:
331[**github.com/triska/clpz**](https://github.com/triska/clpz)
332
333If you are used to the complicated operational considerations that
334low-level arithmetic primitives necessitate, then moving to CLP(ℤ)
335constraints may, due to their power and convenience, at first feel to
336you excessive and almost like cheating. It _isn't_. Constraints are an
337integral part of all popular Prolog systems, and they are designed
338to help you eliminate and avoid the use of low-level and less general
339primitives by providing declarative alternatives that are meant to be
340used instead.
341
342When teaching Prolog, CLP(ℤ) constraints should be introduced
343_before_ explaining low-level arithmetic predicates and their
344procedural idiosyncrasies. This is because constraints are easy to
345explain, understand and use due to their purely relational nature. In
346contrast, the modedness and directionality of low-level arithmetic
347primitives are impure limitations that are better deferred to more
348advanced lectures.
349
350More information about CLP(ℤ) constraints and their implementation is
351contained in: [**metalevel.at/drt.pdf**](https://www.metalevel.at/drt.pdf)
352
353The best way to discuss applying, improving and extending CLP(ℤ)
354constraints is to use the dedicated `clpz` tag on
355[stackoverflow.com](http://stackoverflow.com). Several of the world's
356foremost CLP(ℤ) experts regularly participate in these discussions
357and will help you for free on this platform.
358
359## Arithmetic constraints {#clpz-arith-constraints}
360
361In modern Prolog systems, *arithmetic constraints* subsume and
362supersede low-level predicates over integers. The main advantage of
363arithmetic constraints is that they are true _relations_ and can be
364used in all directions. For most programs, arithmetic constraints are
365the only predicates you will ever need from this library.
366
367The most important arithmetic constraint is #=/2, which subsumes both
368`(is)/2` and `(=:=)/2` over integers. Use #=/2 to make your programs
369more general.
370
371In total, the arithmetic constraints are:
372
373 | Expr1 `#=` Expr2 | Expr1 equals Expr2 |
374 | Expr1 `#\=` Expr2 | Expr1 is not equal to Expr2 |
375 | Expr1 `#>=` Expr2 | Expr1 is greater than or equal to Expr2 |
376 | Expr1 `#=<` Expr2 | Expr1 is less than or equal to Expr2 |
377 | Expr1 `#>` Expr2 | Expr1 is greater than Expr2 |
378 | Expr1 `#<` Expr2 | Expr1 is less than Expr2 |
379
380`Expr1` and `Expr2` denote *arithmetic expressions*, which are:
381
382 | _integer_ | Given value |
383 | _variable_ | Unknown integer |
384 | ?(_variable_) | Unknown integer |
385 | -Expr | Unary minus |
386 | Expr + Expr | Addition |
387 | Expr * Expr | Multiplication |
388 | Expr - Expr | Subtraction |
389 | Expr ^ Expr | Exponentiation |
390 | min(Expr,Expr) | Minimum of two expressions |
391 | max(Expr,Expr) | Maximum of two expressions |
392 | Expr `mod` Expr | Modulo induced by floored division |
393 | Expr `rem` Expr | Modulo induced by truncated division |
394 | abs(Expr) | Absolute value |
395 | Expr // Expr | Truncated integer division |
396 | Expr div Expr | Floored integer division |
397
398where `Expr` again denotes an arithmetic expression.
399
400The bitwise operations `(\)/1`, `(/\)/2`, `(\/)/2`, `(>>)/2`,
401`(<<)/2`, `lsb/1`, `msb/1`, `popcount/1` and `(xor)/2` are also
402supported.
403
404## Declarative integer arithmetic {#clpz-integer-arith}
405
406The [_arithmetic constraints_](<#clpz-arith-constraints>) #=/2, #>/2
407etc. are meant to be used _instead_ of the primitives `(is)/2`,
408`(=:=)/2`, `(>)/2` etc. over integers. Almost all Prolog programs also
409reason about integers. Therefore, it is recommended that you put the
410following directive in your =|~/.swiplrc|= initialisation file to make
411CLP(ℤ) constraints available in all your programs:
412
413==
414:- use_module(library(clpz)).
415==
416
417Throughout the following, it is assumed that you have done this.
418
419The most basic use of CLP(ℤ) constraints is _evaluation_ of
420arithmetic expressions involving integers. For example:
421
422==
423?- X #= 1+2.
424X = 3.
425==
426
427This could in principle also be achieved with the lower-level
428predicate `(is)/2`. However, an important advantage of arithmetic
429constraints is their purely relational nature: Constraints can be used
430in _all directions_, also if one or more of their arguments are only
431partially instantiated. For example:
432
433==
434?- 3 #= Y+2.
435Y = 1.
436==
437
438This relational nature makes CLP(ℤ) constraints easy to explain and
439use, and well suited for beginners and experienced Prolog programmers
440alike. In contrast, when using low-level integer arithmetic, we get:
441
442==
443?- 3 is Y+2.
444ERROR: is/2: Arguments are not sufficiently instantiated
445
446?- 3 =:= Y+2.
447ERROR: =:=/2: Arguments are not sufficiently instantiated
448==
449
450Due to the necessary operational considerations, the use of these
451low-level arithmetic predicates is considerably harder to understand
452and should therefore be deferred to more advanced lectures.
453
454For supported expressions, CLP(ℤ) constraints are drop-in
455replacements of these low-level arithmetic predicates, often yielding
456more general programs. See [`n_factorial/2`](<#clpz-factorial>) for an
457example.
458
459This library uses goal_expansion/2 to automatically rewrite
460constraints at compilation time so that low-level arithmetic
461predicates are _automatically_ used whenever possible. For example,
462the predicate:
463
464==
465positive_integer(N) :- N #>= 1.
466==
467
468is executed as if it were written as:
469
470==
471positive_integer(N) :-
472 ( integer(N)
473 -> N >= 1
474 ; N #>= 1
475 ).
476==
477
478This illustrates why the performance of CLP(ℤ) constraints is almost
479always completely satisfactory when they are used in modes that can be
480handled by low-level arithmetic. To disable the automatic rewriting,
481set the Prolog flag `clpz_goal_expansion` to `false`.
482
483If you are used to the complicated operational considerations that
484low-level arithmetic primitives necessitate, then moving to CLP(ℤ)
485constraints may, due to their power and convenience, at first feel to
486you excessive and almost like cheating. It _isn't_. Constraints are an
487integral part of all popular Prolog systems, and they are designed
488to help you eliminate and avoid the use of low-level and less general
489primitives by providing declarative alternatives that are meant to be
490used instead.
491
492
493## Example: Factorial relation {#clpz-factorial}
494
495We illustrate the benefit of using #=/2 for more generality with a
496simple example.
497
498Consider first a rather conventional definition of `n_factorial/2`,
499relating each natural number _N_ to its factorial _F_:
500
501==
502n_factorial(0, 1).
503n_factorial(N, F) :-
504 N #> 0,
505 N1 #= N - 1,
506 n_factorial(N1, F1),
507 F #= N * F1.
508==
509
510This program uses CLP(ℤ) constraints _instead_ of low-level
511arithmetic throughout, and everything that _would have worked_ with
512low-level arithmetic _also_ works with CLP(ℤ) constraints, retaining
513roughly the same performance. For example:
514
515==
516?- n_factorial(47, F).
517F = 258623241511168180642964355153611979969197632389120000000000 ;
518false.
519==
520
521Now the point: Due to the increased flexibility and generality of
522CLP(ℤ) constraints, we are free to _reorder_ the goals as follows:
523
524==
525n_factorial(0, 1).
526n_factorial(N, F) :-
527 N #> 0,
528 N1 #= N - 1,
529 F #= N * F1,
530 n_factorial(N1, F1).
531==
532
533In this concrete case, _termination_ properties of the predicate are
534improved. For example, the following queries now both terminate:
535
536==
537?- n_factorial(N, 1).
538N = 0 ;
539N = 1 ;
540false.
541
542?- n_factorial(N, 3).
543false.
544==
545
546To make the predicate terminate if _any_ argument is instantiated, add
547the (implied) constraint `F #\= 0` before the recursive call.
548Otherwise, the query `n_factorial(N, 0)` is the only non-terminating
549case of this kind.
550
551The value of CLP(ℤ) constraints does _not_ lie in completely freeing
552us from _all_ procedural phenomena. For example, the two programs do
553not even have the same _termination properties_ in all cases.
554Instead, the primary benefit of CLP(ℤ) constraints is that they allow
555you to try different execution orders and apply [**declarative
556debugging**](https://www.metalevel.at/prolog/debugging.html)
557techniques _at all_! Reordering goals (and clauses) can significantly
558impact the performance of Prolog programs, and you are free to try
559different variants if you use declarative approaches. Moreover, since
560all CLP(ℤ) constraints _always terminate_, placing them earlier can
561at most _improve_, never worsen, the termination properties of your
562programs. An additional benefit of CLP(ℤ) constraints is that they
563eliminate the complexity of introducing `(is)/2` and `(=:=)/2` to
564beginners, since _both_ predicates are subsumed by #=/2 when reasoning
565over integers.
566
567## Combinatorial constraints {#clpz-combinatorial}
568
569In addition to subsuming and replacing low-level arithmetic
570predicates, CLP(ℤ) constraints are often used to solve combinatorial
571problems such as planning, scheduling and allocation tasks. Among the
572most frequently used *combinatorial constraints* are all_distinct/1,
573global_cardinality/2 and cumulative/2. This library also provides
574several other constraints like disjoint2/1 and automaton/8, which are
575useful in more specialized applications.
576
577## Domains {#clpz-domains}
578
579Each CLP(ℤ) variable has an associated set of admissible integers,
580which we call the variable's *domain*. Initially, the domain of each
581CLP(ℤ) variable is the set of _all_ integers. CLP(ℤ) constraints
582like #=/2, #>/2 and #\=/2 can at most reduce, and never extend, the
583domains of their arguments. The constraints in/2 and ins/2 let us
584explicitly state domains of CLP(ℤ) variables. The process of
585determining and adjusting domains of variables is called constraint
586*propagation*, and it is performed automatically by this library. When
587the domain of a variable contains only one element, then the variable
588is automatically unified to that element.
589
590Domains are taken into account when further constraints are stated,
591and by enumeration predicates like labeling/2.
592
593## Example: Sudoku {#clpz-sudoku}
594
595As another example, consider _Sudoku_: It is a popular puzzle
596over integers that can be easily solved with CLP(ℤ) constraints.
597
598==
599sudoku(Rows) :-
600 length(Rows, 9), maplist(same_length(Rows), Rows),
601 append(Rows, Vs), Vs ins 1..9,
602 maplist(all_distinct, Rows),
603 transpose(Rows, Columns),
604 maplist(all_distinct, Columns),
605 Rows = [As,Bs,Cs,Ds,Es,Fs,Gs,Hs,Is],
606 blocks(As, Bs, Cs),
607 blocks(Ds, Es, Fs),
608 blocks(Gs, Hs, Is).
609
610blocks([], [], []).
611blocks([N1,N2,N3|Ns1], [N4,N5,N6|Ns2], [N7,N8,N9|Ns3]) :-
612 all_distinct([N1,N2,N3,N4,N5,N6,N7,N8,N9]),
613 blocks(Ns1, Ns2, Ns3).
614
615problem(1, [[_,_,_,_,_,_,_,_,_],
616 [_,_,_,_,_,3,_,8,5],
617 [_,_,1,_,2,_,_,_,_],
618 [_,_,_,5,_,7,_,_,_],
619 [_,_,4,_,_,_,1,_,_],
620 [_,9,_,_,_,_,_,_,_],
621 [5,_,_,_,_,_,_,7,3],
622 [_,_,2,_,1,_,_,_,_],
623 [_,_,_,_,4,_,_,_,9]]).
624==
625
626Sample query:
627
628==
629?- problem(1, Rows), sudoku(Rows), maplist(writeln, Rows).
630[9,8,7,6,5,4,3,2,1]
631[2,4,6,1,7,3,9,8,5]
632[3,5,1,9,2,8,7,4,6]
633[1,2,8,5,3,7,6,9,4]
634[6,3,4,8,9,2,1,5,7]
635[7,9,5,4,6,1,8,3,2]
636[5,1,9,2,8,6,4,7,3]
637[4,7,2,3,1,9,5,6,8]
638[8,6,3,7,4,5,2,1,9]
639Rows = [[9, 8, 7, 6, 5, 4, 3, 2|...], ... , [...|...]].
640==
641
642In this concrete case, the constraint solver is strong enough to find
643the unique solution without any search.
644
645
646## Residual goals {#clpz-residual-goals}
647
648Here is an example session with a few queries and their answers:
649
650==
651?- X #> 3.
652X in 4..sup.
653
654?- X #\= 20.
655X in inf..19\/21..sup.
656
657?- 2*X #= 10.
658X = 5.
659
660?- X*X #= 144.
661X in -12\/12.
662
663?- 4*X + 2*Y #= 24, X + Y #= 9, [X,Y] ins 0..sup.
664X = 3,
665Y = 6.
666
667?- X #= Y #<==> B, X in 0..3, Y in 4..5.
668B = 0,
669X in 0..3,
670Y in 4..5.
671==
672
673The answers emitted by the toplevel are called _residual programs_,
674and the goals that comprise each answer are called **residual goals**.
675In each case above, and as for all pure programs, the residual program
676is declaratively equivalent to the original query. From the residual
677goals, it is clear that the constraint solver has deduced additional
678domain restrictions in many cases.
679
680To inspect residual goals, it is best to let the toplevel display them
681for us. Wrap the call of your predicate into call_residue_vars/2 to
682make sure that all constrained variables are displayed. To make the
683constraints a variable is involved in available as a Prolog term for
684further reasoning within your program, use copy_term/3. For example:
685
686==
687?- X #= Y + Z, X in 0..5, copy_term([X,Y,Z], [X,Y,Z], Gs).
688Gs = [clpz: (X in 0..5), clpz: (Y+Z#=X)],
689X in 0..5,
690Y+Z#=X.
691==
692
693This library also provides _reflection_ predicates (like fd_dom/2,
694fd_size/2 etc.) with which we can inspect a variable's current
695domain. These predicates can be useful if you want to implement your
696own labeling strategies.
697
698## Core relations and search {#clpz-search}
699
700Using CLP(ℤ) constraints to solve combinatorial tasks typically
701consists of two phases:
702
703 1. First, all relevant constraints are stated.
704 2. Second, if the domain of each involved variable is _finite_,
705 then _enumeration predicates_ can be used to search for
706 concrete solutions.
707
708It is good practice to keep the modeling part, via a dedicated
709predicate called the *core relation*, separate from the actual
710search for solutions. This lets us observe termination and
711determinism properties of the core relation in isolation from the
712search, and more easily try different search strategies.
713
714As an example of a constraint satisfaction problem, consider the
715cryptoarithmetic puzzle SEND + MORE = MONEY, where different letters
716denote distinct integers between 0 and 9. It can be modeled in CLP(ℤ)
717as follows:
718
719==
720puzzle([S,E,N,D] + [M,O,R,E] = [M,O,N,E,Y]) :-
721 Vars = [S,E,N,D,M,O,R,Y],
722 Vars ins 0..9,
723 all_different(Vars),
724 S*1000 + E*100 + N*10 + D +
725 M*1000 + O*100 + R*10 + E #=
726 M*10000 + O*1000 + N*100 + E*10 + Y,
727 M #\= 0, S #\= 0.
728==
729
730Notice that we are _not_ using labeling/2 in this predicate, so that
731we can first execute and observe the modeling part in isolation.
732Sample query and its result (actual variables replaced for
733readability):
734
735==
736?- puzzle(As+Bs=Cs).
737As = [9, A2, A3, A4],
738Bs = [1, 0, B3, A2],
739Cs = [1, 0, A3, A2, C5],
740A2 in 4..7,
741all_different([9, A2, A3, A4, 1, 0, B3, C5]),
74291*A2+A4+10*B3#=90*A3+C5,
743A3 in 5..8,
744A4 in 2..8,
745B3 in 2..8,
746C5 in 2..8.
747==
748
749From this answer, we see that this core relation _terminates_ and is in
750fact _deterministic_. Moreover, we see from the residual goals that
751the constraint solver has deduced more stringent bounds for all
752variables. Such observations are only possible if modeling and search
753parts are cleanly separated.
754
755Labeling can then be used to search for solutions in a separate
756predicate or goal:
757
758==
759?- puzzle(As+Bs=Cs), label(As).
760As = [9, 5, 6, 7],
761Bs = [1, 0, 8, 5],
762Cs = [1, 0, 6, 5, 2] ;
763false.
764==
765
766In this case, it suffices to label a subset of variables to find the
767puzzle's unique solution, since the constraint solver is strong enough
768to reduce the domains of remaining variables to singleton sets. In
769general though, it is necessary to label all variables to obtain
770ground solutions.
771
772## Example: Eight queens puzzle {#clpz-n-queens}
773
774We illustrate the concepts of the preceding sections by means of the
775so-called _eight queens puzzle_. The task is to place 8 queens on an
7768x8 chessboard such that none of the queens is under attack. This
777means that no two queens share the same row, column or diagonal.
778
779To express this puzzle via CLP(ℤ) constraints, we must first pick a
780suitable representation. Since CLP(ℤ) constraints reason over
781_integers_, we must find a way to map the positions of queens to
782integers. Several such mappings are conceivable, and it is not
783immediately obvious which we should use. On top of that, different
784constraints can be used to express the desired relations. For such
785reasons, _modeling_ combinatorial problems via CLP(ℤ) constraints
786often necessitates some creativity and has been described as more of
787an art than a science.
788
789In our concrete case, we observe that there must be exactly one queen
790per column. The following representation therefore suggests itself: We
791are looking for 8 integers, one for each column, where each integer
792denotes the _row_ of the queen that is placed in the respective
793column, and which are subject to certain constraints.
794
795In fact, let us now generalize the task to the so-called _N queens
796puzzle_, which is obtained by replacing 8 by _N_ everywhere it occurs
797in the above description. We implement the above considerations in the
798**core relation** `n_queens/2`, where the first argument is the number
799of queens (which is identical to the number of rows and columns of the
800generalized chessboard), and the second argument is a list of _N_
801integers that represents a solution in the form described above.
802
803==
804n_queens(N, Qs) :-
805 length(Qs, N),
806 Qs ins 1..N,
807 safe_queens(Qs).
808
809safe_queens([]).
810safe_queens([Q|Qs]) :- safe_queens(Qs, Q, 1), safe_queens(Qs).
811
812safe_queens([], _, _).
813safe_queens([Q|Qs], Q0, D0) :-
814 Q0 #\= Q,
815 abs(Q0 - Q) #\= D0,
816 D1 #= D0 + 1,
817 safe_queens(Qs, Q0, D1).
818==
819
820Note that all these predicates can be used in _all directions_: We
821can use them to _find_ solutions, _test_ solutions and _complete_
822partially instantiated solutions.
823
824The original task can be readily solved with the following query:
825
826==
827?- n_queens(8, Qs), label(Qs).
828Qs = [1, 5, 8, 6, 3, 7, 2, 4] .
829==
830
831Using suitable labeling strategies, we can easily find solutions with
83280 queens and more:
833
834==
835?- n_queens(80, Qs), labeling([ff], Qs).
836Qs = [1, 3, 5, 44, 42, 4, 50, 7, 68|...] .
837
838?- time((n_queens(90, Qs), labeling([ff], Qs))).
839% 5,904,401 inferences, 0.722 CPU in 0.737 seconds (98% CPU)
840Qs = [1, 3, 5, 50, 42, 4, 49, 7, 59|...] .
841==
842
843Experimenting with different search strategies is easy because we have
844separated the core relation from the actual search.
845
846
847
848## Optimisation {#clpz-optimisation}
849
850We can use labeling/2 to minimize or maximize the value of a CLP(ℤ)
851expression, and generate solutions in increasing or decreasing order
852of the value. See the labeling options `min(Expr)` and `max(Expr)`,
853respectively.
854
855Again, to easily try different labeling options in connection with
856optimisation, we recommend to introduce a dedicated predicate for
857posting constraints, and to use `labeling/2` in a separate goal. This
858way, we can observe properties of the core relation in isolation,
859and try different labeling options without recompiling our code.
860
861If necessary, we can use `once/1` to commit to the first optimal
862solution. However, it is often very valuable to see alternative
863solutions that are _also_ optimal, so that we can choose among optimal
864solutions by other criteria. For the sake of
865[**purity**](https://www.metalevel.at/prolog/purity.html) and
866completeness, we recommend to avoid `once/1` and other constructs that
867lead to impurities in CLP(ℤ) programs.
868
869Related to optimisation with CLP(ℤ) constraints are `library(simplex)`
870and CLP(Q) which reason about _linear_ constraints over rational
871numbers.
872
873## Reification {#clpz-reification}
874
875The constraints in/2, #=/2, #\=/2, #</2, #>/2, #=</2, and #>=/2 can be
876_reified_, which means reflecting their truth values into Boolean
877values represented by the integers 0 and 1. Let P and Q denote
878reifiable constraints or Boolean variables, then:
879
880 | #\ Q | True iff Q is false |
881 | P #\/ Q | True iff either P or Q |
882 | P #/\ Q | True iff both P and Q |
883 | P #\ Q | True iff either P or Q, but not both |
884 | P #<==> Q | True iff P and Q are equivalent |
885 | P #==> Q | True iff P implies Q |
886 | P #<== Q | True iff Q implies P |
887
888The constraints of this table are reifiable as well.
889
890When reasoning over Boolean variables, also consider using CLP(B)
891constraints as provided by `library(clpb)`.
892
893## Enabling monotonic CLP(ℤ) {#clpz-monotonicity}
894
895In the default execution mode, CLP(ℤ) constraints still exhibit some
896non-relational properties. For example, _adding_ constraints can yield
897new solutions:
898
899==
900?- X #= 2, X = 1+1.
901false.
902
903?- X = 1+1, X #= 2, X = 1+1.
904X = 1+1.
905==
906
907This behaviour is highly problematic from a logical point of view, and
908it may render declarative debugging techniques inapplicable.
909
910Assert `clpz:monotonic` to make CLP(ℤ) **monotonic**: This means
911that _adding_ new constraints _cannot_ yield new solutions. When this
912flag is `true`, we must wrap variables that occur in arithmetic
913expressions with the functor `(?)/1` or `(#)/1`. For example:
914
915==
916?- assertz(clpz:monotonic).
917true.
918
919?- #(X) #= #(Y) + #(Z).
920#(Y)+ #(Z)#= #(X).
921
922?- X #= 2, X = 1+1.
923ERROR: Arguments are not sufficiently instantiated
924==
925
926The wrapper can be omitted for variables that are already constrained
927to integers.
928
929## Custom constraints {#clpz-custom-constraints}
930
931We can define custom constraints. The mechanism to do this is not yet
932finalised, and we welcome suggestions and descriptions of use cases
933that are important to you.
934
935As an example of how it can be done currently, let us define a new
936custom constraint `oneground(X,Y,Z)`, where Z shall be 1 if at least
937one of X and Y is instantiated:
938
939==
940:- multifile clpz:run_propagator/2.
941
942oneground(X, Y, Z) :-
943 clpz:make_propagator(oneground(X, Y, Z), Prop),
944 clpz:init_propagator(X, Prop),
945 clpz:init_propagator(Y, Prop),
946 clpz:trigger_once(Prop).
947
948clpz:run_propagator(oneground(X, Y, Z), MState) :-
949 ( integer(X) -> clpz:kill(MState), Z = 1
950 ; integer(Y) -> clpz:kill(MState), Z = 1
951 ; true
952 ).
953==
954
955First, clpz:make_propagator/2 is used to transform a user-defined
956representation of the new constraint to an internal form. With
957clpz:init_propagator/2, this internal form is then attached to X and
958Y. From now on, the propagator will be invoked whenever the domains of
959X or Y are changed. Then, clpz:trigger_once/1 is used to give the
960propagator its first chance for propagation even though the variables'
961domains have not yet changed. Finally, clpz:run_propagator/2 is
962extended to define the actual propagator. As explained, this predicate
963is automatically called by the constraint solver. The first argument
964is the user-defined representation of the constraint as used in
965clpz:make_propagator/2, and the second argument is a mutable state
966that can be used to prevent further invocations of the propagator when
967the constraint has become entailed, by using clpz:kill/1. An example
968of using the new constraint:
969
970==
971?- oneground(X, Y, Z), Y = 5.
972Y = 5,
973Z = 1,
974X in inf..sup.
975==
976
977@author [Markus Triska](https://www.metalevel.at)
978*/
979
980/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
981 Duo DCGs
982 ========
983
984 A Duo DCG is like a DCG, except that it describes *two* lists at
985 the same time.
986
987 A Duo DCG rule has the form Head ++> Body. The language construct
988 As+Bs is used within Duo DCGs to describe that the elements in As
989 occur in the first list, and the elements in Bs occur in the second
990 list. Duo DCGs are compiled to Prolog code via term expansion. The
991 interface predicates are:
992
993 *) duophrase(NT, As, Bs)
994 *) duophrase(NT, As0, As, Bs0, Bs) (difference list version).
995
996 Duo DCGs could be used to efficiently describe scheduled
997 propagators, taking into account the two possible propagator
998 priorities. However, it turns out that passing around a single
999 argument is more efficient than passing around multiple arguments,
1000 and therefore regular DCGs are used for propagator scheduling.
1001
1002 Still, everything is completely pure: No global data structures are
1003 needed to schedule the propagators!
1004- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1005
1006duophrase(NT, As, Bs) :-
1007 duophrase(NT, As, [], Bs, []).
1008
1009duophrase(NT, As0, As, Bs0, Bs) :-
1010 call(NT, As0, As, Bs0, Bs).
1011
1012%:- multifile user:term_expansion/6.
1013term_expansion(Term0, Term) :-
1014 nonvar(Term0),
1015 Term0 = (Head0 ++> Body0),
1016 Term = (Head :- Body),
1017 duodcg_head(Head0, Head, As0, As, Bs0, Bs),
1018 once(duodcg_body(Body0, Body, As0, As, Bs0, Bs)).
1019
1020duodcg_body([], (As0=As,Bs0=Bs), As0, As, Bs0, Bs).
1021duodcg_body(Xs+Ys, (phrase(list(Xs), As0, As),
1022 phrase(list(Ys), Bs0, Bs)), As0, As, Bs0, Bs).
1023duodcg_body({Goal}, call(Goal), As, As, Bs, Bs).
1024duodcg_body((A0,B0), (A,B), As0, As, Bs0, Bs) :-
1025 duodcg_body(A0, A, As0, As1, Bs0, Bs1),
1026 duodcg_body(B0, B, As1, As, Bs1, Bs).
1027duodcg_body((A0->B0;C0), (A->B;C), As0, As, Bs0, Bs) :-
1028 duodcg_body(A0, A, As0, As1, Bs0, Bs1),
1029 duodcg_body(B0, B, As1, As, Bs1, Bs),
1030 duodcg_body(C0, C, As0, As, Bs0, Bs).
1031duodcg_body((A->B), Body, As0, As, Bs0, Bs) :-
1032 duodcg_body((A->B;false), Body, As0, As, Bs0, Bs).
1033duodcg_body((A0;B0), (A;B), As0, As, Bs0, Bs) :-
1034 duodcg_body(A0, A, As0, As, Bs0, Bs),
1035 duodcg_body(B0, B, As0, As, Bs0, Bs).
1036duodcg_body(NT0, NT, As0, As, Bs0, Bs) :-
1037 duodcg_head(NT0, NT, As0, As, Bs0, Bs).
1038
1039duodcg_head(Head0, Head, As0, As, Bs0, Bs) :-
1040 Head0 =.. [F|Args0],
1041 append(Args0, [As0,As,Bs0,Bs], Args),
1042 Head =.. [F|Args].
1043
1044
1045goal_expansion(get_attr(Var, Module, Value), (var(Var),get_atts(Var, Access))) :-
1046 Access =.. [Module,Value].
1047
1048goal_expansion(put_attr(Var, Module, Value), put_atts(Var, Access)) :-
1049 Access =.. [Module,Value].
1050
1051goal_expansion(del_attr(Var, Module), (var(Var) -> put_atts(Var, -Access);true)) :-
1052 Access =.. [Module,_].
1053
1054
1055goal_expansion(A cis B, Expansion) :-
1056 phrase(cis_goals(B, A), Goals),
1057 list_goal(Goals, Expansion).
1058goal_expansion(A cis_lt B, B cis_gt A).
1059goal_expansion(A cis_leq B, B cis_geq A).
1060goal_expansion(A cis_geq B, cis_leq_numeric(B, N)) :- nonvar(A), A = n(N).
1061goal_expansion(A cis_geq B, cis_geq_numeric(A, N)) :- nonvar(B), B = n(N).
1062goal_expansion(A cis_gt B, cis_lt_numeric(B, N)) :- nonvar(A), A = n(N).
1063goal_expansion(A cis_gt B, cis_gt_numeric(A, N)) :- nonvar(B), B = n(N).
1064
1065
1066/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1067 A bound is either:
1068
1069 n(N): integer N
1070 inf: infimum of Z (= negative infinity)
1071 sup: supremum of Z (= positive infinity)
1072- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1073
1074is_bound(n(N)) :- integer(N).
1075is_bound(inf).
1076is_bound(sup).
1077
1078defaulty_to_bound(D, P) :- ( integer(D) -> P = n(D) ; P = D ).
1079
1080/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1081 Compactified is/2 and predicates for several arithmetic expressions
1082 with infinities, tailored for the modes needed by this solver.
1083- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1084
1085% cis_gt only works for terms of depth 0 on both sides
1086cis_gt(sup, B0) :- B0 \== sup.
1087cis_gt(n(N), B) :- cis_lt_numeric(B, N).
1088
1089cis_lt_numeric(inf, _).
1090cis_lt_numeric(n(B), A) :- B < A.
1091
1092cis_gt_numeric(sup, _).
1093cis_gt_numeric(n(B), A) :- B > A.
1094
1095cis_geq(inf, inf).
1096cis_geq(sup, _).
1097cis_geq(n(N), B) :- cis_leq_numeric(B, N).
1098
1099cis_leq_numeric(inf, _).
1100cis_leq_numeric(n(B), A) :- B =< A.
1101
1102cis_geq_numeric(sup, _).
1103cis_geq_numeric(n(B), A) :- B >= A.
1104
1105cis_min(inf, _, inf).
1106cis_min(sup, B, B).
1107cis_min(n(N), B, Min) :- cis_min_(B, N, Min).
1108
1109cis_min_(inf, _, inf).
1110cis_min_(sup, N, n(N)).
1111cis_min_(n(B), A, n(M)) :- M is min(A,B).
1112
1113cis_max(sup, _, sup).
1114cis_max(inf, B, B).
1115cis_max(n(N), B, Max) :- cis_max_(B, N, Max).
1116
1117cis_max_(inf, N, n(N)).
1118cis_max_(sup, _, sup).
1119cis_max_(n(B), A, n(M)) :- M is max(A,B).
1120
1121cis_plus(inf, _, inf).
1122cis_plus(sup, _, sup).
1123cis_plus(n(A), B, Plus) :- cis_plus_(B, A, Plus).
1124
1125cis_plus_(sup, _, sup).
1126cis_plus_(inf, _, inf).
1127cis_plus_(n(B), A, n(S)) :- S is A + B.
1128
1129cis_minus(inf, _, inf).
1130cis_minus(sup, _, sup).
1131cis_minus(n(A), B, M) :- cis_minus_(B, A, M).
1132
1133cis_minus_(inf, _, sup).
1134cis_minus_(sup, _, inf).
1135cis_minus_(n(B), A, n(M)) :- M is A - B.
1136
1137cis_uminus(inf, sup).
1138cis_uminus(sup, inf).
1139cis_uminus(n(A), n(B)) :- B is -A.
1140
1141cis_abs(inf, sup).
1142cis_abs(sup, sup).
1143cis_abs(n(A), n(B)) :- B is abs(A).
1144
1145cis_times(inf, B, P) :-
1146 ( B cis_lt n(0) -> P = sup
1147 ; B cis_gt n(0) -> P = inf
1148 ; P = n(0)
1149 ).
1150cis_times(sup, B, P) :-
1151 ( B cis_gt n(0) -> P = sup
1152 ; B cis_lt n(0) -> P = inf
1153 ; P = n(0)
1154 ).
1155cis_times(n(N), B, P) :- cis_times_(B, N, P).
1156
1157cis_times_(inf, A, P) :- cis_times(inf, n(A), P).
1158cis_times_(sup, A, P) :- cis_times(sup, n(A), P).
1159cis_times_(n(B), A, n(P)) :- P is A * B.
1160
1161cis_exp(inf, n(Y), R) :-
1162 ( even(Y) -> R = sup
1163 ; R = inf
1164 ).
1165cis_exp(sup, _, sup).
1166cis_exp(n(N), Y, R) :- cis_exp_(Y, N, R).
1167
1168cis_exp_(n(Y), N, n(R)) :- R is N^Y.
1169cis_exp_(sup, _, sup).
1170cis_exp_(inf, _, inf).
1171
1172cis_goals(V, V) --> { var(V) }, !.
1173cis_goals(n(N), n(N)) --> [].
1174cis_goals(inf, inf) --> [].
1175cis_goals(sup, sup) --> [].
1176cis_goals(sign(A0), R) --> cis_goals(A0, A), [cis_sign(A, R)].
1177cis_goals(abs(A0), R) --> cis_goals(A0, A), [cis_abs(A, R)].
1178cis_goals(-A0, R) --> cis_goals(A0, A), [cis_uminus(A, R)].
1179cis_goals(A0+B0, R) -->
1180 cis_goals(A0, A),
1181 cis_goals(B0, B),
1182 [cis_plus(A, B, R)].
1183cis_goals(A0-B0, R) -->
1184 cis_goals(A0, A),
1185 cis_goals(B0, B),
1186 [cis_minus(A, B, R)].
1187cis_goals(min(A0,B0), R) -->
1188 cis_goals(A0, A),
1189 cis_goals(B0, B),
1190 [cis_min(A, B, R)].
1191cis_goals(max(A0,B0), R) -->
1192 cis_goals(A0, A),
1193 cis_goals(B0, B),
1194 [cis_max(A, B, R)].
1195cis_goals(A0*B0, R) -->
1196 cis_goals(A0, A),
1197 cis_goals(B0, B),
1198 [cis_times(A, B, R)].
1199cis_goals(div(A0,B0), R) -->
1200 cis_goals(A0, A),
1201 cis_goals(B0, B),
1202 [cis_div(A, B, R)].
1203cis_goals(A0//B0, R) -->
1204 cis_goals(A0, A),
1205 cis_goals(B0, B),
1206 [cis_slash(A, B, R)].
1207cis_goals(A0^B0, R) -->
1208 cis_goals(A0, A),
1209 cis_goals(B0, B),
1210 [cis_exp(A, B, R)].
1211
1212list_goal([], true).
1213list_goal([G|Gs], Goal) :- foldl(list_goal_, Gs, G, Goal).
1214
1215list_goal_(G, G0, (G0,G)).
1216
1217cis_sign(sup, n(1)).
1218cis_sign(inf, n(-1)).
1219cis_sign(n(N), n(S)) :- S is sign(N).
1220
1221cis_div(sup, Y, Z) :- ( Y cis_geq n(0) -> Z = sup ; Z = inf ).
1222cis_div(inf, Y, Z) :- ( Y cis_geq n(0) -> Z = inf ; Z = sup ).
1223cis_div(n(X), Y, Z) :- cis_div_(Y, X, Z).
1224
1225cis_div_(sup, _, n(0)).
1226cis_div_(inf, _, n(0)).
1227cis_div_(n(Y), X, Z) :-
1228 ( Y =:= 0 -> ( X >= 0 -> Z = sup ; Z = inf )
1229 ; Z0 is X // Y, Z = n(Z0)
1230 ).
1231
1232cis_slash(sup, _, sup).
1233cis_slash(inf, _, inf).
1234cis_slash(n(N), B, S) :- cis_slash_(B, N, S).
1235
1236cis_slash_(sup, _, n(0)).
1237cis_slash_(inf, _, n(0)).
1238cis_slash_(n(B), A, n(S)) :- S is A // B.
1239
1240
1241/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1242 A domain is a finite set of disjoint intervals. Internally, domains
1243 are represented as trees. Each node is one of:
1244
1245 empty: empty domain.
1246
1247 split(N, Left, Right)
1248 - split on integer N, with Left and Right domains whose elements are
1249 all less than and greater than N, respectively. The domain is the
1250 union of Left and Right, i.e., N is a hole.
1251
1252 from_to(From, To)
1253 - interval (From-1, To+1); From and To are bounds
1254
1255 Desiderata: rebalance domains; singleton intervals.
1256- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1257
1258/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1259 Type definition and inspection of domains.
1260- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1261
1262check_domain(D) :-
1263 ( var(D) -> instantiation_error(D)
1264 ; is_domain(D) -> true
1265 ; domain_error(clpz_domain, D)
1266 ).
1267
1268is_domain(empty).
1269is_domain(from_to(From,To)) :-
1270 is_bound(From), is_bound(To),
1271 From cis_leq To.
1272is_domain(split(S, Left, Right)) :-
1273 integer(S),
1274 is_domain(Left), is_domain(Right),
1275 all_less_than(Left, S),
1276 all_greater_than(Right, S).
1277
1278all_less_than(empty, _).
1279all_less_than(from_to(From,To), S) :-
1280 From cis_lt n(S), To cis_lt n(S).
1281all_less_than(split(S0,Left,Right), S) :-
1282 S0 < S,
1283 all_less_than(Left, S),
1284 all_less_than(Right, S).
1285
1286all_greater_than(empty, _).
1287all_greater_than(from_to(From,To), S) :-
1288 From cis_gt n(S), To cis_gt n(S).
1289all_greater_than(split(S0,Left,Right), S) :-
1290 S0 > S,
1291 all_greater_than(Left, S),
1292 all_greater_than(Right, S).
1293
1294default_domain(from_to(inf,sup)).
1295
1296domain_infimum(from_to(I, _), I).
1297domain_infimum(split(_, Left, _), I) :- domain_infimum(Left, I).
1298
1299domain_supremum(from_to(_, S), S).
1300domain_supremum(split(_, _, Right), S) :- domain_supremum(Right, S).
1301
1302domain_num_elements(empty, n(0)).
1303domain_num_elements(from_to(From,To), Num) :- Num cis To - From + n(1).
1304domain_num_elements(split(_, Left, Right), Num) :-
1305 domain_num_elements(Left, NL),
1306 domain_num_elements(Right, NR),
1307 Num cis NL + NR.
1308
1309domain_direction_element(from_to(n(From), n(To)), Dir, E) :-
1310 ( Dir == up -> between(From, To, E)
1311 ; between(From, To, E0),
1312 E is To - (E0 - From)
1313 ).
1314domain_direction_element(split(_, D1, D2), Dir, E) :-
1315 ( Dir == up ->
1316 ( domain_direction_element(D1, Dir, E)
1317 ; domain_direction_element(D2, Dir, E)
1318 )
1319 ; ( domain_direction_element(D2, Dir, E)
1320 ; domain_direction_element(D1, Dir, E)
1321 )
1322 ).
1323
1324/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1325 Test whether domain contains a given integer.
1326- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1327
1328domain_contains(from_to(From,To), I) :- From cis_leq n(I), n(I) cis_leq To.
1329domain_contains(split(S, Left, Right), I) :-
1330 ( I < S -> domain_contains(Left, I)
1331 ; I > S -> domain_contains(Right, I)
1332 ).
1333
1334/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1335 Test whether a domain contains another domain.
1336- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1337
1338domain_subdomain(Dom, Sub) :- domain_subdomain(Dom, Dom, Sub).
1339
1340domain_subdomain(from_to(_,_), Dom, Sub) :-
1341 domain_subdomain_fromto(Sub, Dom).
1342domain_subdomain(split(_, _, _), Dom, Sub) :-
1343 domain_subdomain_split(Sub, Dom, Sub).
1344
1345domain_subdomain_split(empty, _, _).
1346domain_subdomain_split(from_to(From,To), split(S,Left0,Right0), Sub) :-
1347 ( To cis_lt n(S) -> domain_subdomain(Left0, Left0, Sub)
1348 ; From cis_gt n(S) -> domain_subdomain(Right0, Right0, Sub)
1349 ).
1350domain_subdomain_split(split(_,Left,Right), Dom, _) :-
1351 domain_subdomain(Dom, Dom, Left),
1352 domain_subdomain(Dom, Dom, Right).
1353
1354domain_subdomain_fromto(empty, _).
1355domain_subdomain_fromto(from_to(From,To), from_to(From0,To0)) :-
1356 From0 cis_leq From, To0 cis_geq To.
1357domain_subdomain_fromto(split(_,Left,Right), Dom) :-
1358 domain_subdomain_fromto(Left, Dom),
1359 domain_subdomain_fromto(Right, Dom).
1360
1361/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1362 Remove an integer from a domain. The domain is traversed until an
1363 interval is reached from which the element can be removed, or until
1364 it is clear that no such interval exists.
1365- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1366
1367domain_remove(empty, _, empty).
1368domain_remove(from_to(L0, U0), X, D) :- domain_remove_(L0, U0, X, D).
1369domain_remove(split(S, Left0, Right0), X, D) :-
1370 ( X =:= S -> D = split(S, Left0, Right0)
1371 ; X < S ->
1372 domain_remove(Left0, X, Left1),
1373 ( Left1 == empty -> D = Right0
1374 ; D = split(S, Left1, Right0)
1375 )
1376 ; domain_remove(Right0, X, Right1),
1377 ( Right1 == empty -> D = Left0
1378 ; D = split(S, Left0, Right1)
1379 )
1380 ).
1381
1382%?- domain_remove(from_to(n(0),n(5)), 3, D).
1383
1384domain_remove_(inf, U0, X, D) :-
1385 ( U0 == n(X) -> U1 is X - 1, D = from_to(inf, n(U1))
1386 ; U0 cis_lt n(X) -> D = from_to(inf,U0)
1387 ; L1 is X + 1, U1 is X - 1,
1388 D = split(X, from_to(inf, n(U1)), from_to(n(L1),U0))
1389 ).
1390domain_remove_(n(N), U0, X, D) :- domain_remove_upper(U0, N, X, D).
1391
1392domain_remove_upper(sup, L0, X, D) :-
1393 ( L0 =:= X -> L1 is X + 1, D = from_to(n(L1),sup)
1394 ; L0 > X -> D = from_to(n(L0),sup)
1395 ; L1 is X + 1, U1 is X - 1,
1396 D = split(X, from_to(n(L0),n(U1)), from_to(n(L1),sup))
1397 ).
1398domain_remove_upper(n(U0), L0, X, D) :-
1399 ( L0 =:= U0, X =:= L0 -> D = empty
1400 ; L0 =:= X -> L1 is X + 1, D = from_to(n(L1), n(U0))
1401 ; U0 =:= X -> U1 is X - 1, D = from_to(n(L0), n(U1))
1402 ; between(L0, U0, X) ->
1403 U1 is X - 1, L1 is X + 1,
1404 D = split(X, from_to(n(L0), n(U1)), from_to(n(L1), n(U0)))
1405 ; D = from_to(n(L0),n(U0))
1406 ).
1407
1408/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1409 Remove all elements greater than / less than a constant.
1410- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1411
1412domain_remove_greater_than(empty, _, empty).
1413domain_remove_greater_than(from_to(From0,To0), G, D) :-
1414 ( From0 cis_gt n(G) -> D = empty
1415 ; To cis min(To0,n(G)), D = from_to(From0,To)
1416 ).
1417domain_remove_greater_than(split(S,Left0,Right0), G, D) :-
1418 ( S =< G ->
1419 domain_remove_greater_than(Right0, G, Right),
1420 ( Right == empty -> D = Left0
1421 ; D = split(S, Left0, Right)
1422 )
1423 ; domain_remove_greater_than(Left0, G, D)
1424 ).
1425
1426domain_remove_smaller_than(empty, _, empty).
1427domain_remove_smaller_than(from_to(From0,To0), V, D) :-
1428 ( To0 cis_lt n(V) -> D = empty
1429 ; From cis max(From0,n(V)), D = from_to(From,To0)
1430 ).
1431domain_remove_smaller_than(split(S,Left0,Right0), V, D) :-
1432 ( S >= V ->
1433 domain_remove_smaller_than(Left0, V, Left),
1434 ( Left == empty -> D = Right0
1435 ; D = split(S, Left, Right0)
1436 )
1437 ; domain_remove_smaller_than(Right0, V, D)
1438 ).
1439
1440
1441/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1442 Remove a whole domain from another domain. (Set difference.)
1443- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1444
1445domain_subtract(Dom0, Sub, Dom) :- domain_subtract(Dom0, Dom0, Sub, Dom).
1446
1447domain_subtract(empty, _, _, empty).
1448domain_subtract(from_to(From0,To0), Dom, Sub, D) :-
1449 ( Sub == empty -> D = Dom
1450 ; Sub = from_to(From,To) ->
1451 ( From == To -> From = n(X), domain_remove(Dom, X, D)
1452 ; From cis_gt To0 -> D = Dom
1453 ; To cis_lt From0 -> D = Dom
1454 ; From cis_leq From0 ->
1455 ( To cis_geq To0 -> D = empty
1456 ; From1 cis To + n(1),
1457 D = from_to(From1, To0)
1458 )
1459 ; To1 cis From - n(1),
1460 ( To cis_lt To0 ->
1461 From = n(S),
1462 From2 cis To + n(1),
1463 D = split(S,from_to(From0,To1),from_to(From2,To0))
1464 ; D = from_to(From0,To1)
1465 )
1466 )
1467 ; Sub = split(S, Left, Right) ->
1468 ( n(S) cis_gt To0 -> domain_subtract(Dom, Dom, Left, D)
1469 ; n(S) cis_lt From0 -> domain_subtract(Dom, Dom, Right, D)
1470 ; domain_subtract(Dom, Dom, Left, D1),
1471 domain_subtract(D1, D1, Right, D)
1472 )
1473 ).
1474domain_subtract(split(S, Left0, Right0), _, Sub, D) :-
1475 domain_subtract(Left0, Left0, Sub, Left),
1476 domain_subtract(Right0, Right0, Sub, Right),
1477 ( Left == empty -> D = Right
1478 ; Right == empty -> D = Left
1479 ; D = split(S, Left, Right)
1480 ).
1481
1482/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1483 Complement of a domain
1484- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1485
1486domain_complement(D, C) :-
1487 default_domain(Default),
1488 domain_subtract(Default, D, C).
1489
1490/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1491 Convert domain to a list of disjoint intervals From-To.
1492- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1493
1494domain_intervals(D, Is) :- phrase(domain_intervals(D), Is).
1495
1496domain_intervals(split(_, Left, Right)) -->
1497 domain_intervals(Left), domain_intervals(Right).
1498domain_intervals(empty) --> [].
1499domain_intervals(from_to(From,To)) --> [From-To].
1500
1501/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1502 To compute the intersection of two domains D1 and D2, we choose D1
1503 as the reference domain. For each interval of D1, we compute how
1504 far and to which values D2 lets us extend it.
1505- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1506
1507domains_intersection(D1, D2, Intersection) :-
1508 domains_intersection_(D1, D2, Intersection),
1509 Intersection \== empty.
1510
1511domains_intersection_(empty, _, empty).
1512domains_intersection_(from_to(L0,U0), D2, Dom) :-
1513 narrow(D2, L0, U0, Dom).
1514domains_intersection_(split(S,Left0,Right0), D2, Dom) :-
1515 domains_intersection_(Left0, D2, Left1),
1516 domains_intersection_(Right0, D2, Right1),
1517 ( Left1 == empty -> Dom = Right1
1518 ; Right1 == empty -> Dom = Left1
1519 ; Dom = split(S, Left1, Right1)
1520 ).
1521
1522narrow(empty, _, _, empty).
1523narrow(from_to(L0,U0), From0, To0, Dom) :-
1524 From1 cis max(From0,L0), To1 cis min(To0,U0),
1525 ( From1 cis_gt To1 -> Dom = empty
1526 ; Dom = from_to(From1,To1)
1527 ).
1528narrow(split(S, Left0, Right0), From0, To0, Dom) :-
1529 ( To0 cis_lt n(S) -> narrow(Left0, From0, To0, Dom)
1530 ; From0 cis_gt n(S) -> narrow(Right0, From0, To0, Dom)
1531 ; narrow(Left0, From0, To0, Left1),
1532 narrow(Right0, From0, To0, Right1),
1533 ( Left1 == empty -> Dom = Right1
1534 ; Right1 == empty -> Dom = Left1
1535 ; Dom = split(S, Left1, Right1)
1536 )
1537 ).
1538
1539/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1540 Union of 2 domains.
1541- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1542
1543domains_union(D1, D2, Union) :-
1544 domain_intervals(D1, Is1),
1545 domain_intervals(D2, Is2),
1546 append(Is1, Is2, IsU0),
1547 merge_intervals(IsU0, IsU1),
1548 intervals_to_domain(IsU1, Union).
1549
1550/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1551 Shift the domain by an offset.
1552- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1553
1554domain_shift(empty, _, empty).
1555domain_shift(from_to(From0,To0), O, from_to(From,To)) :-
1556 From cis From0 + n(O), To cis To0 + n(O).
1557domain_shift(split(S0, Left0, Right0), O, split(S, Left, Right)) :-
1558 S is S0 + O,
1559 domain_shift(Left0, O, Left),
1560 domain_shift(Right0, O, Right).
1561
1562/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1563 The new domain contains all values of the old domain,
1564 multiplied by a constant multiplier.
1565- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1566
1567domain_expand(D0, M, D) :-
1568 ( M < 0 ->
1569 domain_negate(D0, D1),
1570 M1 is abs(M),
1571 domain_expand_(D1, M1, D)
1572 ; M =:= 1 -> D = D0
1573 ; domain_expand_(D0, M, D)
1574 ).
1575
1576domain_expand_(empty, _, empty).
1577domain_expand_(from_to(From0, To0), M, from_to(From,To)) :-
1578 From cis From0*n(M),
1579 To cis To0*n(M).
1580domain_expand_(split(S0, Left0, Right0), M, split(S, Left, Right)) :-
1581 S is M*S0,
1582 domain_expand_(Left0, M, Left),
1583 domain_expand_(Right0, M, Right).
1584
1585/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1586 similar to domain_expand/3, tailored for truncated division: an
1587 interval [From,To] is extended to [From*M, ((To+1)*M - 1)], i.e.,
1588 to all values that truncated integer-divided by M yield a value
1589 from interval.
1590- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1591
1592domain_expand_more(D0, M, D) :-
1593 %format("expanding ~w by ~w\n", [D0,M]),
1594 ( M < 0 -> domain_negate(D0, D1), M1 is abs(M)
1595 ; D1 = D0, M1 = M
1596 ),
1597 domain_expand_more_(D1, M1, D).
1598 %format("yield: ~w\n", [D]).
1599
1600domain_expand_more_(empty, _, empty).
1601domain_expand_more_(from_to(From0, To0), M, from_to(From,To)) :-
1602 ( From0 cis_leq n(0) ->
1603 From cis (From0-n(1))*n(M) + n(1)
1604 ; From cis From0*n(M)
1605 ),
1606 ( To0 cis_lt n(0) ->
1607 To cis To0*n(M)
1608 ; To cis (To0+n(1))*n(M) - n(1)
1609 ).
1610domain_expand_more_(split(S0, Left0, Right0), M, split(S, Left, Right)) :-
1611 S is M*S0,
1612 domain_expand_more_(Left0, M, Left),
1613 domain_expand_more_(Right0, M, Right).
1614
1615/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1616 Scale a domain down by a constant multiplier. Assuming (//)/2.
1617- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1618
1619domain_contract(D0, M, D) :-
1620 %format("contracting ~w by ~w\n", [D0,M]),
1621 ( M < 0 -> domain_negate(D0, D1), M1 is abs(M)
1622 ; D1 = D0, M1 = M
1623 ),
1624 domain_contract_(D1, M1, D).
1625
1626domain_contract_(empty, _, empty).
1627domain_contract_(from_to(From0, To0), M, from_to(From,To)) :-
1628 ( From0 cis_geq n(0) ->
1629 From cis (From0 + n(M) - n(1)) // n(M)
1630 ; From cis From0 // n(M)
1631 ),
1632 ( To0 cis_geq n(0) ->
1633 To cis To0 // n(M)
1634 ; To cis (To0 - n(M) + n(1)) // n(M)
1635 ).
1636domain_contract_(split(_,Left0,Right0), M, D) :-
1637 % Scaled down domains do not necessarily retain any holes of
1638 % the original domain.
1639 domain_contract_(Left0, M, Left),
1640 domain_contract_(Right0, M, Right),
1641 domains_union(Left, Right, D).
1642
1643/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1644 Similar to domain_contract, tailored for division, i.e.,
1645 {21,23} contracted by 4 is 5. It contracts "less".
1646- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1647
1648domain_contract_less(D0, M, D) :-
1649 ( M < 0 -> domain_negate(D0, D1), M1 is abs(M)
1650 ; D1 = D0, M1 = M
1651 ),
1652 domain_contract_less_(D1, M1, D).
1653
1654domain_contract_less_(empty, _, empty).
1655domain_contract_less_(from_to(From0, To0), M, from_to(From,To)) :-
1656 From cis From0 // n(M), To cis To0 // n(M).
1657domain_contract_less_(split(_,Left0,Right0), M, D) :-
1658 % Scaled down domains do not necessarily retain any holes of
1659 % the original domain.
1660 domain_contract_less_(Left0, M, Left),
1661 domain_contract_less_(Right0, M, Right),
1662 domains_union(Left, Right, D).
1663
1664/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1665 Negate the domain. Left and Right sub-domains and bounds switch sides.
1666- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1667
1668domain_negate(empty, empty).
1669domain_negate(from_to(From0, To0), from_to(From, To)) :-
1670 From cis -To0, To cis -From0.
1671domain_negate(split(S0, Left0, Right0), split(S, Left, Right)) :-
1672 S is -S0,
1673 domain_negate(Left0, Right),
1674 domain_negate(Right0, Left).
1675
1676/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1677 Construct a domain from a list of integers. Try to balance it.
1678- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1679
1680list_to_disjoint_intervals([], []).
1681list_to_disjoint_intervals([N|Ns], Is) :-
1682 list_to_disjoint_intervals(Ns, N, N, Is).
1683
1684list_to_disjoint_intervals([], M, N, [n(M)-n(N)]).
1685list_to_disjoint_intervals([B|Bs], M, N, Is) :-
1686 ( B =:= N + 1 ->
1687 list_to_disjoint_intervals(Bs, M, B, Is)
1688 ; Is = [n(M)-n(N)|Rest],
1689 list_to_disjoint_intervals(Bs, B, B, Rest)
1690 ).
1691
1692list_to_domain(List0, D) :-
1693 ( List0 == [] -> D = empty
1694 ; sort(List0, List),
1695 list_to_disjoint_intervals(List, Is),
1696 intervals_to_domain(Is, D)
1697 ).
1698
1699intervals_to_domain([], empty) :- !.
1700intervals_to_domain([M-N], from_to(M,N)) :- !.
1701intervals_to_domain(Is, D) :-
1702 length(Is, L),
1703 FL is L // 2,
1704 length(Front, FL),
1705 append(Front, Tail, Is),
1706 Tail = [n(Start)-_|_],
1707 Hole is Start - 1,
1708 intervals_to_domain(Front, Left),
1709 intervals_to_domain(Tail, Right),
1710 D = split(Hole, Left, Right).
1711
1712%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1713
1714
1715%% ?Var in +Domain
1716%
1717% Var is an element of Domain. Domain is one of:
1718%
1719% * Integer
1720% Singleton set consisting only of _Integer_.
1721% * Lower..Upper
1722% All integers _I_ such that _Lower_ =< _I_ =< _Upper_.
1723% _Lower_ must be an integer or the atom *inf*, which
1724% denotes negative infinity. _Upper_ must be an integer or
1725% the atom *sup*, which denotes positive infinity.
1726% * Domain1 \/ Domain2
1727% The union of Domain1 and Domain2.
1728
1729Var in Dom :- clpz_in(Var, Dom).
1730
1731clpz_in(V, D) :-
1732 fd_variable(V),
1733 drep_to_domain(D, Dom),
1734 domain(V, Dom).
1735
1736fd_variable(V) :-
1737 ( var(V) -> true
1738 ; integer(V) -> true
1739 ; type_error(integer, V)
1740 ).
1741
1742%% +Vars ins +Domain
1743%
1744% The variables in the list Vars are elements of Domain.
1745
1746Vs ins D :-
1747 fd_must_be_list(Vs),
1748 maplist(fd_variable, Vs),
1749 drep_to_domain(D, Dom),
1750 domains(Vs, Dom).
1751
1752fd_must_be_list(Ls) :-
1753 ( fd_var(Ls) -> type_error(list, Ls)
1754 ; must_be(list, Ls)
1755 ).
1756
1757fd_must_be_list(Ls, Where) :-
1758 ( fd_var(Ls) -> type_error(list, Ls, Where)
1759 ; must_be(list, Where, Ls)
1760 ).
1761
1762%% indomain(?Var)
1763%
1764% Bind Var to all feasible values of its domain on backtracking. The
1765% domain of Var must be finite.
1766
1767indomain(Var) :- label([Var]).
1768
1769order_dom_next(up, Dom, Next) :- domain_infimum(Dom, n(Next)).
1770order_dom_next(down, Dom, Next) :- domain_supremum(Dom, n(Next)).
1771
1772
1773%% label(+Vars)
1774%
1775% Equivalent to labeling([], Vars).
1776
1777label(Vs) :- labeling([], Vs).
1778
1779%% labeling(+Options, +Vars)
1780%
1781% Assign a value to each variable in Vars. Labeling means systematically
1782% trying out values for the finite domain variables Vars until all of
1783% them are ground. The domain of each variable in Vars must be finite.
1784% Options is a list of options that let you exhibit some control over
1785% the search process. Several categories of options exist:
1786%
1787% The variable selection strategy lets you specify which variable of
1788% Vars is labeled next and is one of:
1789%
1790% * leftmost
1791% Label the variables in the order they occur in Vars. This is the
1792% default.
1793%
1794% * ff
1795% _|First fail|_. Label the leftmost variable with smallest domain next,
1796% in order to detect infeasibility early. This is often a good
1797% strategy.
1798%
1799% * ffc
1800% Of the variables with smallest domains, the leftmost one
1801% participating in most constraints is labeled next.
1802%
1803% * min
1804% Label the leftmost variable whose lower bound is the lowest next.
1805%
1806% * max
1807% Label the leftmost variable whose upper bound is the highest next.
1808%
1809% The value order is one of:
1810%
1811% * up
1812% Try the elements of the chosen variable's domain in ascending order.
1813% This is the default.
1814%
1815% * down
1816% Try the domain elements in descending order.
1817%
1818% The branching strategy is one of:
1819%
1820% * step
1821% For each variable X, a choice is made between X = V and X #\= V,
1822% where V is determined by the value ordering options. This is the
1823% default.
1824%
1825% * enum
1826% For each variable X, a choice is made between X = V_1, X = V_2
1827% etc., for all values V_i of the domain of X. The order is
1828% determined by the value ordering options.
1829%
1830% * bisect
1831% For each variable X, a choice is made between X #=< M and X #> M,
1832% where M is the midpoint of the domain of X.
1833%
1834% At most one option of each category can be specified, and an option
1835% must not occur repeatedly.
1836%
1837% The order of solutions can be influenced with:
1838%
1839% * min(Expr)
1840% * max(Expr)
1841%
1842% This generates solutions in ascending/descending order with respect
1843% to the evaluation of the arithmetic expression Expr. Labeling Vars
1844% must make Expr ground. If several such options are specified, they
1845% are interpreted from left to right, e.g.:
1846%
1847% ==
1848% ?- [X,Y] ins 10..20, labeling([max(X),min(Y)],[X,Y]).
1849% ==
1850%
1851% This generates solutions in descending order of X, and for each
1852% binding of X, solutions are generated in ascending order of Y. To
1853% obtain the incomplete behaviour that other systems exhibit with
1854% "maximize(Expr)" and "minimize(Expr)", use once/1, e.g.:
1855%
1856% ==
1857% once(labeling([max(Expr)], Vars))
1858% ==
1859%
1860% Labeling is always complete, always terminates, and yields no
1861% redundant solutions.
1862%
1863
1864labeling(Options, Vars) :-
1865 must_be(list, labeling(Options, Vars)-1, Options),
1866 fd_must_be_list(Vars, labeling(Options, Vars)-2),
1867 maplist(finite_domain(labeling(Options, Vars), 2), Vars),
1868 label(Options, Options, default(leftmost), default(up), default(step), [], upto_ground, Vars).
1869
1870
1871finite_domain(Goal, Arg, Var) :-
1872 ( fd_get(Var, Dom, _) ->
1873 ( domain_infimum(Dom, n(_)), domain_supremum(Dom, n(_)) -> true
1874 ; instantiation_error(Dom)
1875 )
1876 ; integer(Var) -> true
1877 ; must_be(integer, Goal-Arg, Var)
1878 ).
1879
1880finite_domain(Var) :-
1881 finite_domain(finite_domain(Var), 1, Var).
1882
1883
1884label([O|Os], Options, Selection, Order, Choice, Optim, Consistency, Vars) :-
1885 ( var(O)-> instantiation_error(O)
1886 ; override(selection, Selection, O, Options, S1) ->
1887 label(Os, Options, S1, Order, Choice, Optim, Consistency, Vars)
1888 ; override(order, Order, O, Options, O1) ->
1889 label(Os, Options, Selection, O1, Choice, Optim, Consistency, Vars)
1890 ; override(choice, Choice, O, Options, C1) ->
1891 label(Os, Options, Selection, Order, C1, Optim, Consistency, Vars)
1892 ; optimisation(O) ->
1893 label(Os, Options, Selection, Order, Choice, [O|Optim], Consistency, Vars)
1894 ; consistency(O, O1) ->
1895 label(Os, Options, Selection, Order, Choice, Optim, O1, Vars)
1896 ; domain_error(labeling_option, O)
1897 ).
1898label([], _, Selection, Order, Choice, Optim0, Consistency, Vars) :-
1899 maplist(arg(1), [Selection,Order,Choice], [S,O,C]),
1900 ( Optim0 == [] ->
1901 label(Vars, S, O, C, Consistency)
1902 ; reverse(Optim0, Optim),
1903 exprs_singlevars(Optim, SVs),
1904 call_cleanup(optimise(Vars, [S,O,C], SVs),
1905 retractall(extremum(_)))
1906 ).
1907
1908% Introduce new variables for each min/max expression to avoid
1909% reparsing expressions during optimisation.
1910
1911exprs_singlevars([], []).
1912exprs_singlevars([E|Es], [SV|SVs]) :-
1913 E =.. [F,Expr],
1914 ?(Single) #= Expr,
1915 SV =.. [F,Single],
1916 exprs_singlevars(Es, SVs).
1917
1918all_dead(fd_props(Bs,Gs,Os)) :-
1919 all_dead_(Bs),
1920 all_dead_(Gs),
1921 all_dead_(Os).
1922
1923all_dead_([]).
1924all_dead_([propagator(_, S)|Ps]) :- S == dead, all_dead_(Ps).
1925
1926label([], _, _, _, Consistency) :- !,
1927 ( Consistency = upto_in(I0,I) -> I0 = I
1928 ; true
1929 ).
1930label(Vars, Selection, Order, Choice, Consistency) :-
1931 ( Vars = [V|Vs], nonvar(V) -> label(Vs, Selection, Order, Choice, Consistency)
1932 ; select_var(Selection, Vars, Var, RVars),
1933 ( var(Var) ->
1934 ( Consistency = upto_in(I0,I), fd_get(Var, _, Ps), all_dead(Ps) ->
1935 fd_size(Var, Size),
1936 I1 is I0*Size,
1937 label(RVars, Selection, Order, Choice, upto_in(I1,I))
1938 ; Consistency = upto_in, fd_get(Var, _, Ps), all_dead(Ps) ->
1939 label(RVars, Selection, Order, Choice, Consistency)
1940 ; choice_order_variable(Choice, Order, Var, RVars, Vars, Selection, Consistency)
1941 )
1942 ; label(RVars, Selection, Order, Choice, Consistency)
1943 )
1944 ).
1945
1946choice_order_variable(step, Order, Var, Vars, Vars0, Selection, Consistency) :-
1947 fd_get(Var, Dom, _),
1948 order_dom_next(Order, Dom, Next),
1949 ( Var = Next,
1950 label(Vars, Selection, Order, step, Consistency)
1951 ; neq_num(Var, Next),
1952 do_queue,
1953 label(Vars0, Selection, Order, step, Consistency)
1954 ).
1955choice_order_variable(enum, Order, Var, Vars, _, Selection, Consistency) :-
1956 fd_get(Var, Dom0, _),
1957 domain_direction_element(Dom0, Order, Var),
1958 label(Vars, Selection, Order, enum, Consistency).
1959choice_order_variable(bisect, Order, Var, _, Vars0, Selection, Consistency) :-
1960 fd_get(Var, Dom, _),
1961 domain_infimum(Dom, n(I)),
1962 domain_supremum(Dom, n(S)),
1963 Mid0 is (I + S) // 2,
1964 ( Mid0 =:= S -> Mid is Mid0 - 1 ; Mid = Mid0 ),
1965 ( Order == up -> ( Var #=< Mid ; Var #> Mid )
1966 ; Order == down -> ( Var #> Mid ; Var #=< Mid )
1967 ; domain_error(bisect_up_or_down, Order)
1968 ),
1969 label(Vars0, Selection, Order, bisect, Consistency).
1970
1971override(What, Prev, Value, Options, Result) :-
1972 call(What, Value),
1973 override_(Prev, Value, Options, Result).
1974
1975override_(default(_), Value, _, user(Value)).
1976override_(user(Prev), Value, Options, _) :-
1977 ( Value == Prev ->
1978 domain_error(nonrepeating_labeling_options, Options)
1979 ; domain_error(consistent_labeling_options, Options)
1980 ).
1981
1982selection(ff).
1983selection(ffc).
1984selection(min).
1985selection(max).
1986selection(leftmost).
1987
1988choice(step).
1989choice(enum).
1990choice(bisect).
1991
1992order(up).
1993order(down).
1994
1995consistency(upto_in(I), upto_in(1, I)).
1996consistency(upto_in, upto_in).
1997consistency(upto_ground, upto_ground).
1998
1999optimisation(min(_)).
2000optimisation(max(_)).
2001
2002select_var(leftmost, [Var|Vars], Var, Vars).
2003select_var(min, [V|Vs], Var, RVars) :-
2004 find_min(Vs, V, Var),
2005 delete_eq([V|Vs], Var, RVars).
2006select_var(max, [V|Vs], Var, RVars) :-
2007 find_max(Vs, V, Var),
2008 delete_eq([V|Vs], Var, RVars).
2009select_var(ff, [V|Vs], Var, RVars) :-
2010 fd_size_(V, n(S)),
2011 find_ff(Vs, V, S, Var),
2012 delete_eq([V|Vs], Var, RVars).
2013select_var(ffc, [V|Vs], Var, RVars) :-
2014 find_ffc(Vs, V, Var),
2015 delete_eq([V|Vs], Var, RVars).
2016
2017find_min([], Var, Var).
2018find_min([V|Vs], CM, Min) :-
2019 ( min_lt(V, CM) ->
2020 find_min(Vs, V, Min)
2021 ; find_min(Vs, CM, Min)
2022 ).
2023
2024find_max([], Var, Var).
2025find_max([V|Vs], CM, Max) :-
2026 ( max_gt(V, CM) ->
2027 find_max(Vs, V, Max)
2028 ; find_max(Vs, CM, Max)
2029 ).
2030
2031find_ff([], Var, _, Var).
2032find_ff([V|Vs], CM, S0, FF) :-
2033 ( nonvar(V) -> find_ff(Vs, CM, S0, FF)
2034 ; ( fd_size_(V, n(S1)), S1 < S0 ->
2035 find_ff(Vs, V, S1, FF)
2036 ; find_ff(Vs, CM, S0, FF)
2037 )
2038 ).
2039
2040find_ffc([], Var, Var).
2041find_ffc([V|Vs], Prev, FFC) :-
2042 ( ffc_lt(V, Prev) ->
2043 find_ffc(Vs, V, FFC)
2044 ; find_ffc(Vs, Prev, FFC)
2045 ).
2046
2047
2048ffc_lt(X, Y) :-
2049 ( fd_get(X, XD, XPs) ->
2050 domain_num_elements(XD, n(NXD))
2051 ; NXD = 1, XPs = []
2052 ),
2053 ( fd_get(Y, YD, YPs) ->
2054 domain_num_elements(YD, n(NYD))
2055 ; NYD = 1, YPs = []
2056 ),
2057 ( NXD < NYD -> true
2058 ; NXD =:= NYD,
2059 props_number(XPs, NXPs),
2060 props_number(YPs, NYPs),
2061 NXPs > NYPs
2062 ).
2063
2064min_lt(X,Y) :- bounds(X,LX,_), bounds(Y,LY,_), LX < LY.
2065
2066max_gt(X,Y) :- bounds(X,_,UX), bounds(Y,_,UY), UX > UY.
2067
2068bounds(X, L, U) :-
2069 ( fd_get(X, Dom, _) ->
2070 domain_infimum(Dom, n(L)),
2071 domain_supremum(Dom, n(U))
2072 ; L = X, U = L
2073 ).
2074
2075delete_eq([], _, []).
2076delete_eq([X|Xs], Y, List) :-
2077 ( nonvar(X) -> delete_eq(Xs, Y, List)
2078 ; X == Y -> List = Xs
2079 ; List = [X|Tail],
2080 delete_eq(Xs, Y, Tail)
2081 ).
2082
2083/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2084 contracting/1 -- subject to change
2085
2086 This can remove additional domain elements from the boundaries.
2087- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2088
2089contracting(Vs) :-
2090 must_be(list, contracting(Vs)-1, Vs),
2091 maplist(finite_domain(contracting(Vs), 1), Vs),
2092 contracting(Vs, false, Vs).
2093
2094contracting([], Repeat, Vars) :-
2095 ( Repeat -> contracting(Vars, false, Vars)
2096 ; true
2097 ).
2098contracting([V|Vs], Repeat, Vars) :-
2099 fd_inf(V, Min),
2100 ( \+ \+ (V = Min) ->
2101 fd_sup(V, Max),
2102 ( \+ \+ (V = Max) ->
2103 contracting(Vs, Repeat, Vars)
2104 ; V #\= Max,
2105 contracting(Vs, true, Vars)
2106 )
2107 ; V #\= Min,
2108 contracting(Vs, true, Vars)
2109 ).
2110
2111/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2112 fds_sespsize(Vs, S).
2113
2114 S is an upper bound on the search space size with respect to finite
2115 domain variables Vs.
2116- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2117
2118fds_sespsize(Vs, S) :-
2119 must_be(list, Vs),
2120 maplist(fd_variable, Vs),
2121 fds_sespsize(Vs, n(1), S1),
2122 bound_portray(S1, S).
2123
2124fd_size_(V, S) :-
2125 ( fd_get(V, D, _) ->
2126 domain_num_elements(D, S)
2127 ; S = n(1)
2128 ).
2129
2130fds_sespsize([], S, S).
2131fds_sespsize([V|Vs], S0, S) :-
2132 fd_size_(V, S1),
2133 S2 cis S0*S1,
2134 fds_sespsize(Vs, S2, S).
2135
2136/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2137 Optimisation uses destructive assignment to save the computed
2138 extremum over backtracking. Failure is used to get rid of copies of
2139 attributed variables that are created in intermediate steps. At
2140 least that's the intention - it currently doesn't work in SWI:
2141
2142 %?- X in 0..3, call_residue_vars(labeling([min(X)], [X]), Vs).
2143 %@ X = 0,
2144 %@ Vs = [_G6174, _G6177],
2145 %@ _G6174 in 0..3
2146
2147- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2148
2149:- dynamic(extremum/1).
2150
2151optimise(Vars, Options, Whats) :-
2152 Whats = [What|WhatsRest],
2153 asserta(extremum(mark)),
2154 ( catch(store_extremum(Vars, Options, What),
2155 time_limit_exceeded,
2156 false)
2157 ; once(extremum(Val0)),
2158 retract_until_mark,
2159 Val0 = n(Val),
2160 arg(1, What, Expr),
2161 append(WhatsRest, Options, Options1),
2162 ( Expr #= Val,
2163 labeling(Options1, Vars)
2164 ; Expr #\= Val,
2165 optimise(Vars, Options, Whats)
2166 )
2167 ).
2168
2169retract_until_mark :-
2170 ( retract(extremum(E)), E == mark -> true
2171 ; retract_until_mark
2172 ).
2173
2174store_extremum(Vars, Options, What) :-
2175 catch((labeling(Options, Vars), throw(w(What))), w(What1), true),
2176 functor(What, Direction, _),
2177 maplist(arg(1), [What,What1], [Expr,Expr1]),
2178 optimise(Direction, Options, Vars, Expr1, Expr).
2179
2180optimise(Direction, Options, Vars, Expr0, Expr) :-
2181 must_be(ground, Expr0),
2182 update_extremum(Expr0),
2183 catch((tighten(Direction, Expr, Expr0),
2184 labeling(Options, Vars),
2185 throw(v(Expr))), v(Expr1), true),
2186 optimise(Direction, Options, Vars, Expr1, Expr).
2187
2188
2189update_extremum(Expr) :-
2190 ( once(extremum(Prev)),
2191 Prev = n(_) ->
2192 once(retract(extremum(_)))
2193 ; true
2194 ),
2195 asserta(extremum(n(Expr))).
2196
2197tighten(min, E, V) :- E #< V.
2198tighten(max, E, V) :- E #> V.
2199
2200%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2201
2202%% all_different(+Vars)
2203%
2204% Like all_distinct/1, but with weaker propagation.
2205
2206all_different(Ls) :-
2207 fd_must_be_list(Ls, all_different(Ls)-1),
2208 maplist(fd_variable, Ls),
2209 Orig = original_goal(_, all_different(Ls)),
2210 all_different(Ls, [], Orig),
2211 do_queue.
2212
2213all_different([], _, _).
2214all_different([X|Right], Left, Orig) :-
2215 ( var(X) ->
2216 make_propagator(pdifferent(Left,Right,X,Orig), Prop),
2217 init_propagator(X, Prop),
2218 trigger_prop(Prop)
2219 ; exclude_fire(Left, Right, X)
2220 ),
2221 all_different(Right, [X|Left], Orig).
2222
2223%% all_distinct(+Vars).
2224%
2225% True iff Vars are pairwise distinct. For example, all_distinct/1
2226% can detect that not all variables can assume distinct values given
2227% the following domains:
2228%
2229% ==
2230% ?- maplist(in, Vs,
2231% [1\/3..4, 1..2\/4, 1..2\/4, 1..3, 1..3, 1..6]),
2232% all_distinct(Vs).
2233% false.
2234% ==
2235
2236all_distinct(Ls) :-
2237 fd_must_be_list(Ls, all_distinct(Ls)-1),
2238 maplist(fd_variable, Ls),
2239 make_propagator(pdistinct(Ls), Prop),
2240 distinct_attach(Ls, Prop, []),
2241 trigger_once(Prop).
2242
2243%% nvalue(?N, +Vars).
2244%
2245% True if N is the number of distinct values taken by Vars. Vars is a
2246% list of domain variables, and N is a domain variable. Can be
2247% thought of as a relaxed version of all_distinct/1.
2248
2249nvalue(N, Vars) :-
2250 fd_must_be_list(Vars),
2251 maplist(fd_variable, Vars),
2252 length(Vars, Len),
2253 N in 0..Len,
2254 zero_or_more(Vars, N),
2255 propagator_init_trigger(Vars, pnvalue(N, Vars)).
2256
2257zero_or_more([], 0).
2258zero_or_more([_|_], N) :- N #> 0.
2259
2260%% sum(+Vars, +Rel, ?Expr)
2261%
2262% The sum of elements of the list Vars is in relation Rel to Expr.
2263% Rel is one of #=, #\=, #<, #>, #=< or #>=. For example:
2264%
2265% ==
2266% ?- [A,B,C] ins 0..sup, sum([A,B,C], #=, 100).
2267% A in 0..100,
2268% A+B+C#=100,
2269% B in 0..100,
2270% C in 0..100.
2271% ==
2272
2273sum(Vs, Op, Value) :-
2274 must_be(list, Vs),
2275 same_length(Vs, Ones),
2276 maplist(=(1), Ones),
2277 scalar_product(Ones, Vs, Op, Value).
2278
2279%% scalar_product(+Cs, +Vs, +Rel, ?Expr)
2280%
2281% True iff the scalar product of Cs and Vs is in relation Rel to Expr.
2282% Cs is a list of integers, Vs is a list of variables and integers.
2283% Rel is #=, #\=, #<, #>, #=< or #>=.
2284
2285scalar_product(Cs, Vs, Op, Value) :-
2286 must_be(list(integer), Cs),
2287 must_be(list, Vs),
2288 maplist(fd_variable, Vs),
2289 ( Op = (#=), single_value(Value, Right), ground(Vs) ->
2290 foldl(coeff_int_linsum, Cs, Vs, 0, Right)
2291 ; must_be(ground, Op),
2292 ( memberchk(Op, [#=,#\=,#<,#>,#=<,#>=]) -> true
2293 ; domain_error(scalar_product_relation, Op)
2294 ),
2295 must_be(acyclic, Value),
2296 foldl(coeff_var_plusterm, Cs, Vs, 0, Left),
2297 ( left_right_linsum_const(Left, Value, Cs1, Vs1, Const) ->
2298 scalar_product_(Op, Cs1, Vs1, Const)
2299 ; sum(Cs, Vs, 0, Op, Value)
2300 )
2301 ).
2302
2303single_value(V, V) :- var(V), !, non_monotonic(V).
2304single_value(V, V) :- integer(V).
2305single_value(?(V), V) :- fd_variable(V).
2306
2307coeff_var_plusterm(C, V, T0, T0+(C* ?(V))).
2308
2309coeff_int_linsum(C, I, S0, S) :- S is S0 + C*I.
2310
2311sum([], _, Sum, Op, Value) :- call(Op, Sum, Value).
2312sum([C|Cs], [X|Xs], Acc, Op, Value) :-
2313 ?(NAcc) #= Acc + C* ?(X),
2314 sum(Cs, Xs, NAcc, Op, Value).
2315
2316multiples([], [], _).
2317multiples([C|Cs], [V|Vs], Left) :-
2318 ( ( Cs = [N|_] ; Left = [N|_] ) ->
2319 ( N =\= 1, gcd(C,N) =:= 1 ->
2320 gcd(Cs, N, GCD0),
2321 gcd(Left, GCD0, GCD),
2322 ( GCD > 1 -> ?(V) #= GCD * ?(_)
2323 ; true
2324 )
2325 ; true
2326 )
2327 ; true
2328 ),
2329 multiples(Cs, Vs, [C|Left]).
2330
2331abs(N, A) :- A is abs(N).
2332
2333divide(D, N, R) :- R is N // D.
2334
2335scalar_product_(#=, Cs0, Vs, S0) :-
2336 ( Cs0 = [C|Rest] ->
2337 gcd(Rest, C, GCD),
2338 S0 mod GCD =:= 0,
2339 maplist(divide(GCD), [S0|Cs0], [S|Cs])
2340 ; S0 =:= 0, S = S0, Cs = Cs0
2341 ),
2342 ( S0 =:= 0 ->
2343 maplist(abs, Cs, As),
2344 multiples(As, Vs, [])
2345 ; true
2346 ),
2347 propagator_init_trigger(Vs, scalar_product_eq(Cs, Vs, S)).
2348scalar_product_(#\=, Cs, Vs, C) :-
2349 propagator_init_trigger(Vs, scalar_product_neq(Cs, Vs, C)).
2350scalar_product_(#=<, Cs, Vs, C) :-
2351 propagator_init_trigger(Vs, scalar_product_leq(Cs, Vs, C)).
2352scalar_product_(#<, Cs, Vs, C) :-
2353 C1 is C - 1,
2354 scalar_product_(#=<, Cs, Vs, C1).
2355scalar_product_(#>, Cs, Vs, C) :-
2356 C1 is C + 1,
2357 scalar_product_(#>=, Cs, Vs, C1).
2358scalar_product_(#>=, Cs, Vs, C) :-
2359 maplist(negative, Cs, Cs1),
2360 C1 is -C,
2361 scalar_product_(#=<, Cs1, Vs, C1).
2362
2363negative(X0, X) :- X is -X0.
2364
2365coeffs_variables_const([], [], [], [], I, I).
2366coeffs_variables_const([C|Cs], [V|Vs], Cs1, Vs1, I0, I) :-
2367 ( var(V) ->
2368 Cs1 = [C|CRest], Vs1 = [V|VRest], I1 = I0
2369 ; I1 is I0 + C*V,
2370 Cs1 = CRest, Vs1 = VRest
2371 ),
2372 coeffs_variables_const(Cs, Vs, CRest, VRest, I1, I).
2373
2374sum_finite_domains([], [], Inf, Sup, Inf, Sup) ++> [].
2375sum_finite_domains([C|Cs], [V|Vs], Inf0, Sup0, Inf, Sup) ++>
2376 { fd_get(V, _, Inf1, Sup1, _) },
2377 ( Inf1 = n(NInf) ->
2378 ( C < 0 ->
2379 Sup2 is Sup0 + C*NInf
2380 ; Inf2 is Inf0 + C*NInf
2381 )
2382 ; ( C < 0 ->
2383 Sup2 = Sup0,
2384 []+[C*V]
2385 ; Inf2 = Inf0,
2386 [C*V]+[]
2387 )
2388 ),
2389 ( Sup1 = n(NSup) ->
2390 ( C < 0 ->
2391 Inf2 is Inf0 + C*NSup
2392 ; Sup2 is Sup0 + C*NSup
2393 )
2394 ; ( C < 0 ->
2395 Inf2 = Inf0,
2396 [C*V]+[]
2397 ; Sup2 = Sup0,
2398 []+[C*V]
2399 )
2400 ),
2401 sum_finite_domains(Cs, Vs, Inf2, Sup2, Inf, Sup).
2402
2403remove_dist_upper_lower([], _, _, _).
2404remove_dist_upper_lower([C|Cs], [V|Vs], D1, D2) :-
2405 ( fd_get(V, VD, VPs) ->
2406 ( C < 0 ->
2407 domain_supremum(VD, n(Sup)),
2408 L is Sup + D1//C,
2409 domain_remove_smaller_than(VD, L, VD1),
2410 domain_infimum(VD1, n(Inf)),
2411 G is Inf - D2//C,
2412 domain_remove_greater_than(VD1, G, VD2)
2413 ; domain_infimum(VD, n(Inf)),
2414 G is Inf + D1//C,
2415 domain_remove_greater_than(VD, G, VD1),
2416 domain_supremum(VD1, n(Sup)),
2417 L is Sup - D2//C,
2418 domain_remove_smaller_than(VD1, L, VD2)
2419 ),
2420 fd_put(V, VD2, VPs)
2421 ; true
2422 ),
2423 remove_dist_upper_lower(Cs, Vs, D1, D2).
2424
2425
2426remove_dist_upper_leq([], _, _).
2427remove_dist_upper_leq([C|Cs], [V|Vs], D1) :-
2428 ( fd_get(V, VD, VPs) ->
2429 ( C < 0 ->
2430 domain_supremum(VD, n(Sup)),
2431 L is Sup + D1//C,
2432 domain_remove_smaller_than(VD, L, VD1)
2433 ; domain_infimum(VD, n(Inf)),
2434 G is Inf + D1//C,
2435 domain_remove_greater_than(VD, G, VD1)
2436 ),
2437 fd_put(V, VD1, VPs)
2438 ; true
2439 ),
2440 remove_dist_upper_leq(Cs, Vs, D1).
2441
2442
2443remove_dist_upper([], _).
2444remove_dist_upper([C*V|CVs], D) :-
2445 ( fd_get(V, VD, VPs) ->
2446 ( C < 0 ->
2447 ( domain_supremum(VD, n(Sup)) ->
2448 L is Sup + D//C,
2449 domain_remove_smaller_than(VD, L, VD1)
2450 ; VD1 = VD
2451 )
2452 ; ( domain_infimum(VD, n(Inf)) ->
2453 G is Inf + D//C,
2454 domain_remove_greater_than(VD, G, VD1)
2455 ; VD1 = VD
2456 )
2457 ),
2458 fd_put(V, VD1, VPs)
2459 ; true
2460 ),
2461 remove_dist_upper(CVs, D).
2462
2463remove_dist_lower([], _).
2464remove_dist_lower([C*V|CVs], D) :-
2465 ( fd_get(V, VD, VPs) ->
2466 ( C < 0 ->
2467 ( domain_infimum(VD, n(Inf)) ->
2468 G is Inf - D//C,
2469 domain_remove_greater_than(VD, G, VD1)
2470 ; VD1 = VD
2471 )
2472 ; ( domain_supremum(VD, n(Sup)) ->
2473 L is Sup - D//C,
2474 domain_remove_smaller_than(VD, L, VD1)
2475 ; VD1 = VD
2476 )
2477 ),
2478 fd_put(V, VD1, VPs)
2479 ; true
2480 ),
2481 remove_dist_lower(CVs, D).
2482
2483remove_upper([], _).
2484remove_upper([C*X|CXs], Max) :-
2485 ( fd_get(X, XD, XPs) ->
2486 D is Max//C,
2487 ( C < 0 ->
2488 domain_remove_smaller_than(XD, D, XD1)
2489 ; domain_remove_greater_than(XD, D, XD1)
2490 ),
2491 fd_put(X, XD1, XPs)
2492 ; true
2493 ),
2494 remove_upper(CXs, Max).
2495
2496remove_lower([], _).
2497remove_lower([C*X|CXs], Min) :-
2498 ( fd_get(X, XD, XPs) ->
2499 D is -Min//C,
2500 ( C < 0 ->
2501 domain_remove_greater_than(XD, D, XD1)
2502 ; domain_remove_smaller_than(XD, D, XD1)
2503 ),
2504 fd_put(X, XD1, XPs)
2505 ; true
2506 ),
2507 remove_lower(CXs, Min).
2508
2509%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2510
2511
2512/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2513 Parsing a CLP(ℤ) expression has two important side-effects: First,
2514 it constrains the variables occurring in the expression to
2515 integers. Second, it constrains some of them even more: For
2516 example, in X/Y and X mod Y, Y is constrained to be #\= 0.
2517- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2518
2519constrain_to_integer(Var) :-
2520 ( integer(Var) -> true
2521 ; fd_get(Var, D, Ps),
2522 fd_put(Var, D, Ps)
2523 ).
2524
2525power_var_num(P, X, N) :-
2526 ( var(P) -> X = P, N = 1
2527 ; P = Left*Right,
2528 power_var_num(Left, XL, L),
2529 power_var_num(Right, XR, R),
2530 XL == XR,
2531 X = XL,
2532 N is L + R
2533 ).
2534
2535/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2536 Given expression E, we obtain the finite domain variable R by
2537 interpreting a simple committed-choice language that is a list of
2538 conditions and bodies. In conditions, g(Goal) means literally Goal,
2539 and m(Match) means that E can be decomposed as stated. The
2540 variables are to be understood as the result of parsing the
2541 subexpressions recursively. In the body, g(Goal) means again Goal,
2542 and p(Propagator) means to attach and trigger once a propagator.
2543- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2544
2545:- op(800, xfx, =>).
2546
2547parse_clpz(E, R,
2548 [g(cyclic_term(E)) => [g(domain_error(clpz_expression, E))],
2549 g(var(E)) => [g(non_monotonic(E)),
2550 g(constrain_to_integer(E)), g(E = R)],
2551 g(integer(E)) => [g(R = E)],
2552 ?(E) => [g(must_be_fd_integer(E)), g(R = E)],
2553 #(E) => [g(must_be_fd_integer(E)), g(R = E)],
2554 m(A+B) => [p(pplus(A, B, R))],
2555 % power_var_num/3 must occur before */2 to be useful
2556 g(power_var_num(E, V, N)) => [p(pexp(V, N, R))],
2557 m(A*B) => [p(ptimes(A, B, R))],
2558 m(A-B) => [p(pplus(R,B,A))],
2559 m(-A) => [p(ptimes(-1,A,R))],
2560 m(max(A,B)) => [g(A #=< ?(R)), g(B #=< R), p(pmax(A, B, R))],
2561 m(min(A,B)) => [g(A #>= ?(R)), g(B #>= R), p(pmin(A, B, R))],
2562 m(A mod B) => [g(B #\= 0), p(pmod(A, B, R))],
2563 m(A rem B) => [g(B #\= 0), p(prem(A, B, R))],
2564 m(abs(A)) => [g(?(R) #>= 0), p(pabs(A, R))],
2565 m(A/B) => [g(B #\= 0), p(prdiv(A, B, R))],
2566 m(A//B) => [g(B #\= 0), p(ptzdiv(A, B, R))],
2567 m(A div B) => [g(?(R) #= (A - (A mod B)) // B)],
2568 m(A^B) => [p(pexp(A, B, R))],
2569 % bitwise operations
2570 m(\A) => [p(pfunction(\, A, R))],
2571 m(msb(A)) => [p(pfunction(msb, A, R))],
2572 m(lsb(A)) => [p(pfunction(lsb, A, R))],
2573 m(popcount(A)) => [p(pfunction(popcount, A, R))],
2574 m(A<<B) => [p(pfunction(<<, A, B, R))],
2575 m(A>>B) => [p(pfunction(>>, A, B, R))],
2576 m(A/\B) => [p(pfunction(/\, A, B, R))],
2577 m(A\/B) => [p(pfunction(\/, A, B, R))],
2578 m(xor(A, B)) => [p(pxor(A, B, R))],
2579 g(true) => [g(domain_error(clpz_expression, E))]
2580 ]).
2581
2582non_monotonic(X) :-
2583 ( \+ fd_var(X), monotonic ->
2584 instantiation_error(X)
2585 ; true
2586 ).
2587
2588% Here, we compile the committed choice language to a single
2589% predicate, parse_clpz/2.
2590
2591make_parse_clpz(Clauses) :-
2592 parse_clpz_clauses(Clauses0),
2593 maplist(goals_goal, Clauses0, Clauses).
2594
2595goals_goal((Head :- Goals), (Head :- Body)) :-
2596 list_goal(Goals, Body).
2597
2598parse_clpz_clauses(Clauses) :-
2599 parse_clpz(E, R, Matchers),
2600 maplist(parse_matcher(E, R), Matchers, Clauses).
2601
2602parse_matcher(E, R, Matcher, Clause) :-
2603 Matcher = (Condition0 => Goals0),
2604 phrase((parse_condition(Condition0, E, Head),
2605 parse_goals(Goals0)), Goals),
2606 Clause = (parse_clpz(Head, R) :- Goals).
2607
2608parse_condition(g(Goal), E, E) --> [Goal, !].
2609parse_condition(?(E), _, ?(E)) --> [!].
2610parse_condition(#(E), _, #(E)) --> [!].
2611parse_condition(m(Match), _, Match0) -->
2612 [!],
2613 { copy_term(Match, Match0),
2614 term_variables(Match0, Vs0),
2615 term_variables(Match, Vs)
2616 },
2617 parse_match_variables(Vs0, Vs).
2618
2619parse_match_variables([], []) --> [].
2620parse_match_variables([V0|Vs0], [V|Vs]) -->
2621 [parse_clpz(V0, V)],
2622 parse_match_variables(Vs0, Vs).
2623
2624parse_goals([]) --> [].
2625parse_goals([G|Gs]) --> parse_goal(G), parse_goals(Gs).
2626
2627parse_goal(g(Goal)) --> [Goal].
2628parse_goal(p(Prop)) -->
2629 [make_propagator(Prop, P)],
2630 { term_variables(Prop, Vs) },
2631 parse_init(Vs, P),
2632 [trigger_once(P)].
2633
2634parse_init([], _) --> [].
2635parse_init([V|Vs], P) --> [init_propagator(V, P)], parse_init(Vs, P).
2636
2637%?- set_prolog_flag(answer_write_options, [portray(true)]),
2638% clpz:parse_clpz_clauses(Clauses), maplist(portray_clause, Clauses).
2639
2640
2641%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2642%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2643trigger_once(Prop) :-
2644 new_queue(Q),
2645 % format("trigger_once: ~w\n", Prop),
2646 phrase((trigger_prop(Prop),do_queue), [Q], _).
2647
2648neq(A, B) :- propagator_init_trigger(pneq(A, B)).
2649
2650propagator_init_trigger(P) -->
2651 { term_variables(P, Vs) },
2652 propagator_init_trigger(Vs, P).
2653
2654propagator_init_trigger(Vs, P) -->
2655 [p(Prop)],
2656 { make_propagator(P, Prop),
2657 maplist(prop_init(Prop), Vs),
2658 variables_same_queue(Vs),
2659 trigger_once(Prop) }.
2660
2661variables_same_queue(Vs0) :-
2662 include(var, Vs0, Vs),
2663 new_queue(Q),
2664 maplist(variable_queue, Vs, Qs),
2665 phrase((collect_goal(Qs),
2666 collect_fast(Qs),
2667 collect_slow(Qs)), [Q], [Q]),
2668 maplist(clear_queue, Qs),
2669 maplist(=(Q), Qs).
2670
2671clear_queue(queue(Goals,Fast,Slow,Aux)) :-
2672 put_atts(Goals, -queue(_,_)),
2673 put_atts(Fast, -queue(_,_)),
2674 put_atts(Slow, -queue(_,_)),
2675 put_atts(Aux, -enabled(_)).
2676
2677collect_goal(Qs) --> collect_arg(Qs, 1).
2678collect_fast(Qs) --> collect_arg(Qs, 2).
2679collect_slow(Qs) --> collect_arg(Qs, 3).
2680
2681collect_arg([], _) --> [].
2682collect_arg([Q|Qs], Which) -->
2683 collect_all_(Q, Which),
2684 collect_arg(Qs, Which).
2685
2686collect_all_(Q, Which) -->
2687 ( { queue_get_arg_(Q, Which, Element) } ->
2688 insert_queue(Element, Which),
2689 collect_all_(Q, Which)
2690 ; []
2691 ).
2692
2693variable_queue(Var, Q) :-
2694 get_attr(Var, clpz, Attr),
2695 Attr = clpz_attr(_Left,_Right,_Spread,_Dom,_Ps,Q).
2696
2697propagator_init_trigger(P) :-
2698 phrase(propagator_init_trigger(P), _).
2699
2700propagator_init_trigger(Vs, P) :-
2701 phrase(propagator_init_trigger(Vs, P), _).
2702
2703prop_init(Prop, V) :- init_propagator(V, Prop).
2704
2705geq(A, B) :-
2706 ( fd_get(A, AD, APs) ->
2707 domain_infimum(AD, AI),
2708 ( fd_get(B, BD, _) ->
2709 domain_supremum(BD, BS),
2710 ( AI cis_geq BS -> true
2711 ; propagator_init_trigger(pgeq(A,B))
2712 )
2713 ; ( AI cis_geq n(B) -> true
2714 ; domain_remove_smaller_than(AD, B, AD1),
2715 fd_put(A, AD1, APs),
2716 do_queue
2717 )
2718 )
2719 ; fd_get(B, BD, BPs) ->
2720 domain_remove_greater_than(BD, A, BD1),
2721 fd_put(B, BD1, BPs),
2722 do_queue
2723 ; A >= B
2724 ).
2725
2726/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2727 Naive parsing of inequalities and disequalities can result in a lot
2728 of unnecessary work if expressions of non-trivial depth are
2729 involved: Auxiliary variables are introduced for sub-expressions,
2730 and propagation proceeds on them as if they were involved in a
2731 tighter constraint (like equality), whereas eventually only very
2732 little of the propagated information is actually used. For example,
2733 only extremal values are of interest in inequalities. Introducing
2734 auxiliary variables should be avoided when possible, and
2735 specialised propagators should be used for common constraints.
2736
2737 We again use a simple committed-choice language for matching
2738 special cases of constraints. m_c(M,C) means that M matches and C
2739 holds. d(X, Y) means decomposition, i.e., it is short for
2740 g(parse_clpz(X, Y)). r(X, Y) means to rematch with X and Y.
2741
2742 Two things are important: First, although the actual constraint
2743 functors (#\=2, #=/2 etc.) are used in the description, they must
2744 expand to the respective auxiliary predicates (match_expand/2)
2745 because the actual constraints are subject to goal expansion.
2746 Second, when specialised constraints (like scalar product) post
2747 simpler constraints on their own, these simpler versions must be
2748 handled separately and must occur before.
2749- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2750
2751match_expand(#>=, clpz_geq_).
2752match_expand(#=, clpz_equal_).
2753match_expand(#\=, clpz_neq).
2754
2755symmetric(#=).
2756symmetric(#\=).
2757
2758matches([
2759 m_c(any(X) #>= any(Y), left_right_linsum_const(X, Y, Cs, Vs, Const)) =>
2760 [g(( Cs = [1], Vs = [A] -> geq(A, Const)
2761 ; Cs = [-1], Vs = [A] -> Const1 is -Const, geq(Const1, A)
2762 ; Cs = [1,1], Vs = [A,B] -> ?(A) + ?(B) #= ?(S), geq(S, Const)
2763 ; Cs = [1,-1], Vs = [A,B] ->
2764 ( Const =:= 0 -> geq(A, B)
2765 ; C1 is -Const,
2766 propagator_init_trigger(x_leq_y_plus_c(B, A, C1))
2767 )
2768 ; Cs = [-1,1], Vs = [A,B] ->
2769 ( Const =:= 0 -> geq(B, A)
2770 ; C1 is -Const,
2771 propagator_init_trigger(x_leq_y_plus_c(A, B, C1))
2772 )
2773 ; Cs = [-1,-1], Vs = [A,B] ->
2774 ?(A) + ?(B) #= ?(S), Const1 is -Const, geq(Const1, S)
2775 ; scalar_product_(#>=, Cs, Vs, Const)
2776 ))],
2777 m(any(X) - any(Y) #>= integer(C)) => [d(X, X1), d(Y, Y1), g(C1 is -C), p(x_leq_y_plus_c(Y1, X1, C1))],
2778 m(integer(X) #>= any(Z) + integer(A)) => [g(C is X - A), r(C, Z)],
2779 m(abs(any(X)-any(Y)) #>= any(Z)) =>
2780 [d(X, X1), d(Y, Y1), d(Z, Z1), g((abs(?(A))#= ?(B),Y1+A#=X1,Z1#=<B))],
2781 m(abs(any(X)) #>= integer(I)) => [d(X, RX), g((I>0 -> I1 is -I, RX in inf..I1 \/ I..sup; true))],
2782 m(integer(I) #>= abs(any(X))) => [d(X, RX), g(I>=0), g(I1 is -I), g(RX in I1..I)],
2783 m(any(X) #>= any(Y)) => [d(X, RX), d(Y, RY), g(geq(RX, RY))],
2784
2785 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2786 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2787
2788 m(var(X) #= var(Y)) => [g(constrain_to_integer(X)), g(X=Y)],
2789 m(var(X) #= var(Y)+var(Z)) => [p(pplus(Y,Z,X))],
2790 m(var(X) #= var(Y)-var(Z)) => [p(pplus(X,Z,Y))],
2791 m(var(X) #= var(Y)*var(Z)) => [p(ptimes(Y,Z,X))],
2792 m(var(X) #= -var(Z)) => [p(ptimes(-1, Z, X))],
2793 m_c(any(X) #= any(Y), left_right_linsum_const(X, Y, Cs, Vs, S)) =>
2794 [g(scalar_product_(#=, Cs, Vs, S))],
2795 m_c(var(X) #= abs(var(Y)) + any(V0), X == Y) => [d(V0,V),p(x_eq_abs_plus_v(X,V))],
2796 m_c(var(X) #= abs(var(Y)) - any(V0), X == Y) => [d(-V0,V),p(x_eq_abs_plus_v(X,V))],
2797 m(var(X) #= any(Y)) => [d(Y,X)],
2798 m(any(X) #= any(Y)) => [d(X, RX), d(Y, RX)],
2799
2800 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2801 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2802
2803 m(var(X) #\= integer(Y)) => [g(neq_num(X, Y))],
2804 m(var(X) #\= var(Y)) => [g(neq(X,Y))],
2805 m(var(X) #\= var(Y) + var(Z)) => [p(x_neq_y_plus_z(X, Y, Z))],
2806 m(var(X) #\= var(Y) - var(Z)) => [p(x_neq_y_plus_z(Y, X, Z))],
2807 m(var(X) #\= var(Y)*var(Z)) => [p(ptimes(Y,Z,P)), g(neq(X,P))],
2808 m(integer(X) #\= abs(any(Y)-any(Z))) => [d(Y, Y1), d(Z, Z1), p(absdiff_neq(Y1, Z1, X))],
2809 m_c(any(X) #\= any(Y), left_right_linsum_const(X, Y, Cs, Vs, S)) =>
2810 [g(scalar_product_(#\=, Cs, Vs, S))],
2811 m(any(X) #\= any(Y) + any(Z)) => [d(X, X1), d(Y, Y1), d(Z, Z1), p(x_neq_y_plus_z(X1, Y1, Z1))],
2812 m(any(X) #\= any(Y) - any(Z)) => [d(X, X1), d(Y, Y1), d(Z, Z1), p(x_neq_y_plus_z(Y1, X1, Z1))],
2813 m(any(X) #\= any(Y)) => [d(X, RX), d(Y, RY), g(neq(RX, RY))]
2814 ]).
2815
2816/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2817 We again compile the committed-choice matching language to the
2818 intended auxiliary predicates. We now must take care not to
2819 unintentionally unify a variable with a complex term.
2820- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2821
2822make_matches(Clauses) :-
2823 matches(Ms),
2824 findall(F, (member(M=>_, Ms), arg(1, M, M1), functor(M1, F, _)), Fs0),
2825 sort(Fs0, Fs),
2826 maplist(prevent_cyclic_argument, Fs, PrevCyclicClauses),
2827 phrase(matchers(Ms), Clauses0),
2828 maplist(goals_goal, Clauses0, MatcherClauses),
2829 append(PrevCyclicClauses, MatcherClauses, Clauses1),
2830 sort_by_predicate(Clauses1, Clauses).
2831
2832sort_by_predicate(Clauses, ByPred) :-
2833 map_list_to_pairs(predname, Clauses, Keyed),
2834 keysort(Keyed, KeyedByPred),
2835 pairs_values(KeyedByPred, ByPred).
2836
2837predname((H:-_), Key) :- !, predname(H, Key).
2838predname(M:H, M:Key) :- !, predname(H, Key).
2839predname(H, Name/Arity) :- !, functor(H, Name, Arity).
2840
2841prevent_cyclic_argument(F0, Clause) :-
2842 match_expand(F0, F),
2843 Head =.. [F,X,Y],
2844 Clause = (Head :- ( cyclic_term(X) ->
2845 domain_error(clpz_expression, X)
2846 ; cyclic_term(Y) ->
2847 domain_error(clpz_expression, Y)
2848 ; false
2849 )).
2850
2851matchers([]) --> [].
2852matchers([Condition => Goals|Ms]) -->
2853 matcher(Condition, Goals),
2854 matchers(Ms).
2855
2856matcher(m(M), Gs) --> matcher(m_c(M,true), Gs).
2857matcher(m_c(Matcher,Cond), Gs) -->
2858 [(Head :- Goals0)],
2859 { Matcher =.. [F,A,B],
2860 match_expand(F, Expand),
2861 Head =.. [Expand,X,Y],
2862 phrase((match(A, X), match(B, Y)), Goals0, [Cond,!|Goals1]),
2863 phrase(match_goals(Gs, Expand), Goals1) },
2864 ( { symmetric(F), \+ (subsumes_term(A, B), subsumes_term(B, A)) } ->
2865 { Head1 =.. [Expand,Y,X] },
2866 [(Head1 :- Goals0)]
2867 ; []
2868 ).
2869
2870match(any(A), T) --> [A = T].
2871match(var(V), T) --> [( nonvar(T), ( T = ?(Var) ; T = #(Var) ) ->
2872 must_be_fd_integer(Var), V = Var
2873 ; v_or_i(T), V = T
2874 )].
2875match(integer(I), T) --> [integer(T), I = T].
2876match(-X, T) --> [nonvar(T), T = -A], match(X, A).
2877match(abs(X), T) --> [nonvar(T), T = abs(A)], match(X, A).
2878match(X+Y, T) --> [nonvar(T), T = A + B], match(X, A), match(Y, B).
2879match(X-Y, T) --> [nonvar(T), T = A - B], match(X, A), match(Y, B).
2880match(X*Y, T) --> [nonvar(T), T = A * B], match(X, A), match(Y, B).
2881
2882match_goals([], _) --> [].
2883match_goals([G|Gs], F) --> match_goal(G, F), match_goals(Gs, F).
2884
2885match_goal(r(X,Y), F) --> { G =.. [F,X,Y] }, [G].
2886match_goal(d(X,Y), _) --> [parse_clpz(X, Y)].
2887match_goal(g(Goal), _) --> [Goal].
2888match_goal(p(Prop), _) -->
2889 [make_propagator(Prop, P)],
2890 { term_variables(Prop, Vs) },
2891 parse_init(Vs, P),
2892 [trigger_once(P)].
2893
2894
2895%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2896
2897
2898
2899%% ?X #>= ?Y
2900%
2901% Same as Y #=< X. When reasoning over integers, replace >=/2 by #>=/2
2902% to obtain more general relations.
2903
2904X #>= Y :- clpz_geq(X, Y).
2905
2906clpz_geq(X, Y) :- clpz_geq_(X, Y), reinforce(X), reinforce(Y).
2907
2908%% ?X #=< ?Y
2909%
2910% The arithmetic expression X is less than or equal to Y. When
2911% reasoning over integers, replace =</2 by #=</2 to obtain more
2912% general relations.
2913
2914X #=< Y :- Y #>= X.
2915
2916%% ?X #= ?Y
2917%
2918% The arithmetic expression X equals Y. When reasoning over integers,
2919% replace is/2 by #=/2 to obtain more general relations.
2920
2921X #= Y :- clpz_equal(X, Y).
2922
2923clpz_equal(X, Y) :- clpz_equal_(X, Y), reinforce(X).
2924
2925/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2926 Conditions under which an equality can be compiled to built-in
2927 arithmetic. Their order is significant. (/)/2 becomes (//)/2.
2928- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2929
2930expr_conds(E, E) --> [integer(E)],
2931 { var(E), !, \+ monotonic }.
2932expr_conds(E, E) --> { integer(E) }.
2933expr_conds(?(E), E) --> [integer(E)].
2934expr_conds(#(E), E) --> [integer(E)].
2935expr_conds(-E0, -E) --> expr_conds(E0, E).
2936expr_conds(abs(E0), abs(E)) --> expr_conds(E0, E).
2937expr_conds(A0+B0, A+B) --> expr_conds(A0, A), expr_conds(B0, B).
2938expr_conds(A0*B0, A*B) --> expr_conds(A0, A), expr_conds(B0, B).
2939expr_conds(A0-B0, A-B) --> expr_conds(A0, A), expr_conds(B0, B).
2940expr_conds(A0//B0, A//B) -->
2941 expr_conds(A0, A), expr_conds(B0, B),
2942 [B =\= 0].
2943%expr_conds(A0/B0, AB) --> expr_conds(A0//B0, AB).
2944expr_conds(min(A0,B0), min(A,B)) --> expr_conds(A0, A), expr_conds(B0, B).
2945expr_conds(max(A0,B0), max(A,B)) --> expr_conds(A0, A), expr_conds(B0, B).
2946expr_conds(A0 mod B0, A mod B) -->
2947 expr_conds(A0, A), expr_conds(B0, B),
2948 [B =\= 0].
2949expr_conds(A0^B0, A^B) -->
2950 expr_conds(A0, A), expr_conds(B0, B),
2951 [(B >= 0 ; A =:= -1)].
2952% Bitwise operations, added to make CLP(ℤ) usable in more cases
2953expr_conds(\ A0, \ A) --> expr_conds(A0, A).
2954expr_conds(A0<<B0, A<<B) --> expr_conds(A0, A), expr_conds(B0, B).
2955expr_conds(A0>>B0, A>>B) --> expr_conds(A0, A), expr_conds(B0, B).
2956expr_conds(A0/\B0, A/\B) --> expr_conds(A0, A), expr_conds(B0, B).
2957expr_conds(A0\/B0, A\/B) --> expr_conds(A0, A), expr_conds(B0, B).
2958expr_conds(xor(A0,B0), xor(A,B)) --> expr_conds(A0, A), expr_conds(B0, B).
2959expr_conds(lsb(A0), lsb(A)) --> expr_conds(A0, A).
2960expr_conds(msb(A0), msb(A)) --> expr_conds(A0, A).
2961expr_conds(popcount(A0), popcount(A)) --> expr_conds(A0, A).
2962
2963clpz_expandable(_ in _).
2964clpz_expandable(_ #= _).
2965clpz_expandable(_ #>= _).
2966clpz_expandable(_ #=< _).
2967clpz_expandable(_ #> _).
2968clpz_expandable(_ #< _).
2969clpz_expandable(_ #\= _).
2970
2971clpz_expansion(Var in Dom, In) :-
2972 ( ground(Dom), Dom = L..U, integer(L), integer(U) ->
2973 expansion_simpler(
2974 ( integer(Var) ->
2975 between:between(L, U, Var)
2976 ; clpz:clpz_in(Var, Dom)
2977 ), In)
2978 ; In = clpz:clpz_in(Var, Dom)
2979 ).
2980clpz_expansion(X0 #= Y0, Equal) :-
2981 phrase(expr_conds(X0, X), CsX),
2982 phrase(expr_conds(Y0, Y), CsY),
2983 list_goal(CsX, CondX),
2984 list_goal(CsY, CondY),
2985 expansion_simpler(
2986 ( CondX ->
2987 ( var(Y) -> Y is X
2988 ; CondY -> X =:= Y
2989 ; T is X, clpz:clpz_equal(T, Y0)
2990 )
2991 ; CondY ->
2992 ( var(X) -> X is Y
2993 ; T is Y, clpz:clpz_equal(X0, T)
2994 )
2995 ; clpz:clpz_equal(X0, Y0)
2996 ), Equal).
2997clpz_expansion(X0 #>= Y0, Geq) :-
2998 phrase(expr_conds(X0, X), CsX),
2999 phrase(expr_conds(Y0, Y), CsY),
3000 list_goal(CsX, CondX),
3001 list_goal(CsY, CondY),
3002 expansion_simpler(
3003 ( CondX ->
3004 ( CondY -> X >= Y
3005 ; T is X, clpz:clpz_geq(T, Y0)
3006 )
3007 ; CondY -> T is Y, clpz:clpz_geq(X0, T)
3008 ; clpz:clpz_geq(X0, Y0)
3009 ), Geq).
3010clpz_expansion(X #=< Y, Leq) :- clpz_expansion(Y #>= X, Leq).
3011clpz_expansion(X #> Y, Gt) :- clpz_expansion(X #>= Y+1, Gt).
3012clpz_expansion(X #< Y, Lt) :- clpz_expansion(Y #> X, Lt).
3013clpz_expansion(X0 #\= Y0, Neq) :-
3014 phrase(expr_conds(X0, X), CsX),
3015 phrase(expr_conds(Y0, Y), CsY),
3016 list_goal(CsX, CondX),
3017 list_goal(CsY, CondY),
3018 expansion_simpler(
3019 ( CondX ->
3020 ( CondY -> X =\= Y
3021 ; T is X, clpz:clpz_neq(T, Y0)
3022 )
3023 ; CondY -> T is Y, clpz:clpz_neq(X0, T)
3024 ; clpz:clpz_neq(X0, Y0)
3025 ), Neq).
3026
3027
3028expansion_simpler((True->Then0;_), Then) :-
3029 is_true(True), !,
3030 expansion_simpler(Then0, Then).
3031expansion_simpler((False->_;Else0), Else) :-
3032 is_false(False), !,
3033 expansion_simpler(Else0, Else).
3034expansion_simpler((If->Then0;Else0), (If->Then;Else)) :- !,
3035 expansion_simpler(Then0, Then),
3036 expansion_simpler(Else0, Else).
3037expansion_simpler((A0,B0), (A,B)) :- !,
3038 expansion_simpler(A0, A),
3039 expansion_simpler(B0, B).
3040expansion_simpler(Var is Expr0, Goal) :-
3041 ground(Expr0), !,
3042 phrase(expr_conds(Expr0, Expr), Gs),
3043 ( maplist(call, Gs) -> Value is Expr, Goal = (Var = Value)
3044 ; Goal = false
3045 ).
3046expansion_simpler(Var =:= Expr0, Goal) :-
3047 ground(Expr0), !,
3048 phrase(expr_conds(Expr0, Expr), Gs),
3049 ( maplist(call, Gs) -> Value is Expr, Goal = (Var =:= Value)
3050 ; Goal = false
3051 ).
3052expansion_simpler(between:between(L,U,V), Goal) :-
3053 maplist(integer, [L,U,V]),
3054 !,
3055 ( between(L,U,V) -> Goal = true
3056 ; Goal = false
3057 ).
3058expansion_simpler(Goal, Goal).
3059
3060is_true(true).
3061is_true(integer(I)) :- integer(I).
3062% :- if(current_predicate(var_property/2)).
3063% is_true(var(X)) :- var(X), var_property(X, fresh(true)).
3064% is_false(integer(X)) :- var(X), var_property(X, fresh(true)).
3065% :- endif.
3066is_false((A,B)) :- is_false(A) ; is_false(B).
3067is_false(var(X)) :- nonvar(X).
3068
3069:- dynamic(goal_expansion/1).
3070
3071user:goal_expansion(Goal0, Goal) :-
3072 \+ goal_expansion(false),
3073 clpz_expandable(Goal0),
3074 clpz_expansion(Goal0, Goal).
3075
3076%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3077
3078linsum(X, S, S) --> { var(X), !, non_monotonic(X) }, [vn(X,1)].
3079linsum(I, S0, S) --> { integer(I), S is S0 + I }.
3080linsum(?(X), S, S) --> { must_be_fd_integer(X) }, [vn(X,1)].
3081linsum(#(X), S, S) --> { must_be_fd_integer(X) }, [vn(X,1)].
3082linsum(-A, S0, S) --> mulsum(A, -1, S0, S).
3083linsum(N*A, S0, S) --> { integer(N) }, !, mulsum(A, N, S0, S).
3084linsum(A*N, S0, S) --> { integer(N) }, !, mulsum(A, N, S0, S).
3085linsum(A+B, S0, S) --> linsum(A, S0, S1), linsum(B, S1, S).
3086linsum(A-B, S0, S) --> linsum(A, S0, S1), mulsum(B, -1, S1, S).
3087
3088mulsum(A, M, S0, S) -->
3089 { phrase(linsum(A, 0, CA), As), S is S0 + M*CA },
3090 lin_mul(As, M).
3091
3092lin_mul([], _) --> [].
3093lin_mul([vn(X,N0)|VNs], M) --> { N is N0*M }, [vn(X,N)], lin_mul(VNs, M).
3094
3095v_or_i(V) :- var(V), !, non_monotonic(V).
3096v_or_i(I) :- integer(I).
3097
3098must_be_fd_integer(X) :-
3099 ( var(X) -> constrain_to_integer(X)
3100 ; must_be(integer, X)
3101 ).
3102
3103samsort(Ls0, Ls) :-
3104 maplist(as_key, Ls0, LKs0),
3105 keysort(LKs0, LKs),
3106 maplist(as_key, Ls, LKs).
3107
3108as_key(E, E-t).
3109
3110left_right_linsum_const(Left, Right, Cs, Vs, Const) :-
3111 phrase(linsum(Left, 0, CL), Lefts0, Rights),
3112 phrase(linsum(Right, 0, CR), Rights0),
3113 maplist(linterm_negate, Rights0, Rights),
3114 samsort(Lefts0, Lefts),
3115 Lefts = [vn(First,N)|LeftsRest],
3116 vns_coeffs_variables(LeftsRest, N, First, Cs0, Vs0),
3117 filter_linsum(Cs0, Vs0, Cs, Vs),
3118 Const is CR - CL.
3119 %format("linear sum: ~w ~w ~w\n", [Cs,Vs,Const]).
3120
3121linterm_negate(vn(V,N0), vn(V,N)) :- N is -N0.
3122
3123vns_coeffs_variables([], N, V, [N], [V]).
3124vns_coeffs_variables([vn(V,N)|VNs], N0, V0, Ns, Vs) :-
3125 ( V == V0 ->
3126 N1 is N0 + N,
3127 vns_coeffs_variables(VNs, N1, V0, Ns, Vs)
3128 ; Ns = [N0|NRest],
3129 Vs = [V0|VRest],
3130 vns_coeffs_variables(VNs, N, V, NRest, VRest)
3131 ).
3132
3133filter_linsum([], [], [], []).
3134filter_linsum([C0|Cs0], [V0|Vs0], Cs, Vs) :-
3135 ( C0 =:= 0 ->
3136 constrain_to_integer(V0),
3137 filter_linsum(Cs0, Vs0, Cs, Vs)
3138 ; Cs = [C0|Cs1], Vs = [V0|Vs1],
3139 filter_linsum(Cs0, Vs0, Cs1, Vs1)
3140 ).
3141
3142gcd([], G, G).
3143gcd([N|Ns], G0, G) :-
3144 G1 is gcd(N, G0),
3145 gcd(Ns, G1, G).
3146
3147even(N) :- N mod 2 =:= 0.
3148
3149odd(N) :- \+ even(N).
3150
3151/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3152 k-th root of N, if N is a k-th power.
3153
3154 TODO: Replace this when the GMP function becomes available.
3155- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3156
3157integer_kth_root(N, K, R) :-
3158 ( even(K) ->
3159 N >= 0
3160 ; true
3161 ),
3162 ( K < 0 ->
3163 ( N =:= 1 -> R = 1
3164 ; N =:= -1 -> odd(K), R = -1
3165 ; false
3166 )
3167 ; ( N < 0 ->
3168 odd(K),
3169 integer_kroot(N, 0, N, K, R)
3170 ; integer_kroot(0, N, N, K, R)
3171 )
3172 ).
3173
3174integer_kroot(L, U, N, K, R) :-
3175 ( L =:= U -> N =:= L^K, R = L
3176 ; L + 1 =:= U ->
3177 ( L^K =:= N -> R = L
3178 ; U^K =:= N -> R = U
3179 ; false
3180 )
3181 ; Mid is (L + U)//2,
3182 ( Mid^K > N ->
3183 integer_kroot(L, Mid, N, K, R)
3184 ; integer_kroot(Mid, U, N, K, R)
3185 )
3186 ).
3187
3188integer_log_b(N, B, Log0, Log) :-
3189 T is B^Log0,
3190 ( T =:= N -> Log = Log0
3191 ; T < N,
3192 Log1 is Log0 + 1,
3193 integer_log_b(N, B, Log1, Log)
3194 ).
3195
3196floor_integer_log_b(N, B, Log0, Log) :-
3197 T is B^Log0,
3198 ( T > N -> Log is Log0 - 1
3199 ; T =:= N -> Log = Log0
3200 ; T < N,
3201 Log1 is Log0 + 1,
3202 floor_integer_log_b(N, B, Log1, Log)
3203 ).
3204
3205/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3206 Largest R such that R^K =< N.
3207
3208 TODO: Replace this when the GMP function becomes available.
3209- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3210
3211integer_kth_root_leq(N, K, R) :-
3212 ( even(K) ->
3213 N >= 0
3214 ; true
3215 ),
3216 ( N < 0 ->
3217 odd(K),
3218 integer_kroot_leq(N, 0, N, K, R)
3219 ; integer_kroot_leq(0, N, N, K, R)
3220 ).
3221
3222integer_kroot_leq(L, U, N, K, R) :-
3223 ( L =:= U -> R = L
3224 ; L + 1 =:= U ->
3225 ( U^K =< N -> R = U
3226 ; R = L
3227 )
3228 ; Mid is (L + U)//2,
3229 ( Mid^K > N ->
3230 integer_kroot_leq(L, Mid, N, K, R)
3231 ; integer_kroot_leq(Mid, U, N, K, R)
3232 )
3233 ).
3234
3235%% ?X #\= ?Y
3236%
3237% The arithmetic expressions X and Y evaluate to distinct integers.
3238% When reasoning over integers, replace =\=/2 by #\=/2 to obtain more
3239% general relations.
3240
3241X #\= Y :- clpz_neq(X, Y), do_queue.
3242
3243% X #\= Y + Z
3244
3245x_neq_y_plus_z(X, Y, Z) :-
3246 propagator_init_trigger(x_neq_y_plus_z(X,Y,Z)).
3247
3248% X is distinct from the number N. This is used internally, and does
3249% not reinforce other constraints.
3250
3251neq_num(X, N) :-
3252 ( fd_get(X, XD, XPs) ->
3253 domain_remove(XD, N, XD1),
3254 fd_put(X, XD1, XPs)
3255 ; X =\= N
3256 ).
3257
3258neq_num(X, N) -->
3259 ( { fd_get(X, XD, XPs) } ->
3260 { domain_remove(XD, N, XD1) },
3261 fd_put(X, XD1, XPs)
3262 ; X =\= N
3263 ).
3264
3265
3266%% ?X #> ?Y
3267%
3268% Same as Y #< X.
3269
3270X #> Y :- X #>= Y + 1.
3271
3272%% #<(?X, ?Y)
3273%
3274% The arithmetic expression X is less than Y. When reasoning over
3275% integers, replace </2 by #</2 to obtain more general relations.
3276%
3277% In addition to its regular use in tasks that require it, this
3278% constraint can also be useful to eliminate uninteresting symmetries
3279% from a problem. For example, all possible matches between pairs
3280% built from four players in total:
3281%
3282% ==
3283% ?- Vs = [A,B,C,D], Vs ins 1..4,
3284% all_different(Vs),
3285% A #< B, C #< D, A #< C,
3286% findall(pair(A,B)-pair(C,D), label(Vs), Ms).
3287% Ms = [ pair(1, 2)-pair(3, 4),
3288% pair(1, 3)-pair(2, 4),
3289% pair(1, 4)-pair(2, 3)].
3290% ==
3291
3292X #< Y :- Y #> X.
3293
3294%% #\ +Q
3295%
3296% The reifiable constraint Q does _not_ hold. For example, to obtain
3297% the complement of a domain:
3298%
3299% ==
3300% ?- #\ X in -3..0\/10..80.
3301% X in inf.. -4\/1..9\/81..sup.
3302% ==
3303
3304#\ Q :- reify(Q, 0), do_queue.
3305
3306%% ?P #<==> ?Q
3307%
3308% P and Q are equivalent. For example:
3309%
3310% ==
3311% ?- X #= 4 #<==> B, X #\= 4.
3312% B = 0,
3313% X in inf..3\/5..sup.
3314% ==
3315% The following example uses reified constraints to relate a list of
3316% finite domain variables to the number of occurrences of a given value:
3317%
3318% ==
3319% vs_n_num(Vs, N, Num) :-
3320% maplist(eq_b(N), Vs, Bs),
3321% sum(Bs, #=, Num).
3322%
3323% eq_b(X, Y, B) :- X #= Y #<==> B.
3324% ==
3325%
3326% Sample queries and their results:
3327%
3328% ==
3329% ?- Vs = [X,Y,Z], Vs ins 0..1, vs_n_num(Vs, 4, Num).
3330% Vs = [X, Y, Z],
3331% Num = 0,
3332% X in 0..1,
3333% Y in 0..1,
3334% Z in 0..1.
3335%
3336% ?- vs_n_num([X,Y,Z], 2, 3).
3337% X = 2,
3338% Y = 2,
3339% Z = 2.
3340% ==
3341
3342L #<==> R :- reify(L, B), reify(R, B), do_queue.
3343
3344%% ?P #==> ?Q
3345%
3346% P implies Q.
3347
3348/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3349 Implication is special in that created auxiliary constraints can be
3350 retracted when the implication becomes entailed, for example:
3351
3352 %?- X + 1 #= Y #==> Z, Z #= 1.
3353 %@ Z = 1,
3354 %@ X in inf..sup,
3355 %@ Y in inf..sup.
3356
3357 We cannot use propagator_init_trigger/1 here because the states of
3358 auxiliary propagators are themselves part of the propagator.
3359- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3360
3361L #==> R :-
3362 reify(L, LB, LPs),
3363 reify(R, RB, RPs),
3364 append(LPs, RPs, Ps),
3365 propagator_init_trigger([LB,RB], pimpl(LB,RB,Ps)).
3366
3367%% ?P #<== ?Q
3368%
3369% Q implies P.
3370
3371L #<== R :- R #==> L.
3372
3373%% ?P #/\ ?Q
3374%
3375% P and Q hold.
3376
3377L #/\ R :- reify(L, 1), reify(R, 1), do_queue.
3378
3379conjunctive_neqs_var_drep(Eqs, Var, Drep) :-
3380 conjunctive_neqs_var(Eqs, Var),
3381 phrase(conjunctive_neqs_vals(Eqs), Vals),
3382 list_to_domain(Vals, Dom),
3383 domain_complement(Dom, C),
3384 domain_to_drep(C, Drep).
3385
3386conjunctive_neqs_var(V, _) :- var(V), !, false.
3387conjunctive_neqs_var(L #\= R, Var) :-
3388 ( var(L), integer(R) -> Var = L
3389 ; integer(L), var(R) -> Var = R
3390 ; false
3391 ).
3392conjunctive_neqs_var(A #/\ B, VA) :-
3393 conjunctive_neqs_var(A, VA),
3394 conjunctive_neqs_var(B, VB),
3395 VA == VB.
3396
3397conjunctive_neqs_vals(L #\= R) --> ( { integer(L) } -> [L] ; [R] ).
3398conjunctive_neqs_vals(A #/\ B) -->
3399 conjunctive_neqs_vals(A),
3400 conjunctive_neqs_vals(B).
3401
3402%% ?P #\/ ?Q
3403%
3404% P or Q holds. For example, the sum of natural numbers below 1000
3405% that are multiples of 3 or 5:
3406%
3407% ==
3408% ?- findall(N, (N mod 3 #= 0 #\/ N mod 5 #= 0, N in 0..999,
3409% indomain(N)),
3410% Ns),
3411% sum(Ns, #=, Sum).
3412% Ns = [0, 3, 5, 6, 9, 10, 12, 15, 18|...],
3413% Sum = 233168.
3414% ==
3415
3416L #\/ R :-
3417 ( disjunctive_eqs_var_drep(L #\/ R, Var, Drep) -> Var in Drep
3418 ; reify(L, X, Ps1),
3419 reify(R, Y, Ps2),
3420 propagator_init_trigger([X,Y], reified_or(X,Ps1,Y,Ps2,1))
3421 ).
3422
3423disjunctive_eqs_var_drep(Eqs, Var, Drep) :-
3424 disjunctive_eqs_var(Eqs, Var),
3425 phrase(disjunctive_eqs_vals(Eqs), Vals),
3426 list_to_drep(Vals, Drep).
3427
3428disjunctive_eqs_var(V, _) :- var(V), !, false.
3429disjunctive_eqs_var(V in I, V) :- var(V), integer(I).
3430disjunctive_eqs_var(L #= R, Var) :-
3431 ( var(L), integer(R) -> Var = L
3432 ; integer(L), var(R) -> Var = R
3433 ; false
3434 ).
3435disjunctive_eqs_var(A #\/ B, VA) :-
3436 disjunctive_eqs_var(A, VA),
3437 disjunctive_eqs_var(B, VB),
3438 VA == VB.
3439
3440disjunctive_eqs_vals(L #= R) --> ( { integer(L) } -> [L] ; [R] ).
3441disjunctive_eqs_vals(_ in I) --> [I].
3442disjunctive_eqs_vals(A #\/ B) -->
3443 disjunctive_eqs_vals(A),
3444 disjunctive_eqs_vals(B).
3445
3446%% ?P #\ ?Q
3447%
3448% Either P holds or Q holds, but not both.
3449
3450L #\ R :- (L #\/ R) #/\ #\ (L #/\ R).
3451
3452/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3453 A constraint that is being reified need not hold. Therefore, in
3454 X/Y, Y can as well be 0, for example. Note that it is OK to
3455 constrain the *result* of an expression (which does not appear
3456 explicitly in the expression and is not visible to the outside),
3457 but not the operands, except for requiring that they be integers.
3458
3459 In contrast to parse_clpz/2, the result of an expression can now
3460 also be undefined, in which case the constraint cannot hold.
3461 Therefore, the committed-choice language is extended by an element
3462 d(D) that states D is 1 iff all subexpressions are defined. a(V)
3463 means that V is an auxiliary variable that was introduced while
3464 parsing a compound expression. a(X,V) means V is auxiliary unless
3465 it is ==/2 X, and a(X,Y,V) means V is auxiliary unless it is ==/2 X
3466 or Y. l(L) means the literal L occurs in the described list.
3467
3468 When a constraint becomes entailed or subexpressions become
3469 undefined, created auxiliary constraints are killed, and the
3470 "clpz" attribute is removed from auxiliary variables.
3471
3472 For (/)/2, mod/2 and rem/2, we create a skeleton propagator and
3473 remember it as an auxiliary constraint. The pskeleton propagator
3474 can use the skeleton when the constraint is defined.
3475- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3476
3477parse_reified(E, R, D,
3478 [g(cyclic_term(E)) => [g(domain_error(clpz_expression, E))],
3479 g(var(E)) => [g(non_monotonic(E)),
3480 g(constrain_to_integer(E)), g(R = E), g(D=1)],
3481 g(integer(E)) => [g(R=E), g(D=1)],
3482 ?(E) => [g(must_be_fd_integer(E)), g(R=E), g(D=1)],
3483 #(E) => [g(must_be_fd_integer(E)), g(R=E), g(D=1)],
3484 m(A+B) => [d(D), p(pplus(A,B,R)), a(A,B,R)],
3485 m(A*B) => [d(D), p(ptimes(A,B,R)), a(A,B,R)],
3486 m(A-B) => [d(D), p(pplus(R,B,A)), a(A,B,R)],
3487 m(-A) => [d(D), p(ptimes(-1,A,R)), a(R)],
3488 m(max(A,B)) => [d(D), p(pgeq(R, A)), p(pgeq(R, B)), p(pmax(A,B,R)), a(A,B,R)],
3489 m(min(A,B)) => [d(D), p(pgeq(A, R)), p(pgeq(B, R)), p(pmin(A,B,R)), a(A,B,R)],
3490 m(abs(A)) => [g(?(R)#>=0), d(D), p(pabs(A, R)), a(A,R)],
3491 m(A/B) => [skeleton(A,B,D,R,prdiv)],
3492 m(A//B) => [skeleton(A,B,D,R,ptzdiv)],
3493 m(A div B) => [skeleton(A,B,D,R,pdiv)],
3494 m(A mod B) => [skeleton(A,B,D,R,pmod)],
3495 m(A rem B) => [skeleton(A,B,D,R,prem)],
3496 m(A^B) => [d(D), p(pexp(A,B,R)), a(A,B,R)],
3497 % bitwise operations
3498 m(\A) => [function(D,\,A,R)],
3499 m(msb(A)) => [function(D,msb,A,R)],
3500 m(lsb(A)) => [function(D,lsb,A,R)],
3501 m(popcount(A)) => [function(D,popcount,A,R)],
3502 m(A<<B) => [function(D,<<,A,B,R)],
3503 m(A>>B) => [function(D,>>,A,B,R)],
3504 m(A/\B) => [function(D,/\,A,B,R)],
3505 m(A\/B) => [function(D,\/,A,B,R)],
3506 m(xor(A, B)) => [skeleton(A,B,D,R,pxor)],
3507 g(true) => [g(domain_error(clpz_expression, E))]]
3508 ).
3509
3510% Again, we compile this to a predicate, parse_reified_clpz//3. This
3511% time, it is a DCG that describes the list of auxiliary variables and
3512% propagators for the given expression, in addition to relating it to
3513% its reified (Boolean) finite domain variable and its Boolean
3514% definedness.
3515
3516make_parse_reified(Clauses) :-
3517 parse_reified_clauses(Clauses0),
3518 maplist(goals_goal_dcg, Clauses0, Clauses).
3519
3520goals_goal_dcg((Head --> Goals), Clause) :-
3521 list_goal(Goals, Body),
3522 expand_term((Head --> Body), Clause).
3523
3524parse_reified_clauses(Clauses) :-
3525 parse_reified(E, R, D, Matchers),
3526 maplist(parse_reified(E, R, D), Matchers, Clauses).
3527
3528parse_reified(E, R, D, Matcher, Clause) :-
3529 Matcher = (Condition0 => Goals0),
3530 phrase((reified_condition(Condition0, E, Head, Ds),
3531 reified_goals(Goals0, Ds)), Goals, [a(D)]),
3532 Clause = (parse_reified_clpz(Head, R, D) --> Goals).
3533
3534reified_condition(g(Goal), E, E, []) --> [{Goal}, !].
3535reified_condition(?(E), _, ?(E), []) --> [!].
3536reified_condition(#(E), _, #(E), []) --> [!].
3537reified_condition(m(Match), _, Match0, Ds) -->
3538 [!],
3539 { copy_term(Match, Match0),
3540 term_variables(Match0, Vs0),
3541 term_variables(Match, Vs)
3542 },
3543 reified_variables(Vs0, Vs, Ds).
3544
3545reified_variables([], [], []) --> [].
3546reified_variables([V0|Vs0], [V|Vs], [D|Ds]) -->
3547 [parse_reified_clpz(V0, V, D)],
3548 reified_variables(Vs0, Vs, Ds).
3549
3550reified_goals([], _) --> [].
3551reified_goals([G|Gs], Ds) --> reified_goal(G, Ds), reified_goals(Gs, Ds).
3552
3553reified_goal(d(D), Ds) -->
3554 ( { Ds = [X] } -> [{D=X}]
3555 ; { Ds = [X,Y] } ->
3556 { phrase(reified_goal(p(reified_and(X,[],Y,[],D)), _), Gs),
3557 list_goal(Gs, Goal) },
3558 [( {X==1, Y==1} -> {D = 1} ; Goal )]
3559 ; { domain_error(one_or_two_element_list, Ds) }
3560 ).
3561reified_goal(g(Goal), _) --> [{Goal}].
3562reified_goal(p(Vs, Prop), _) -->
3563 [{make_propagator(Prop, P)}],
3564 parse_init_dcg(Vs, P),
3565 [{trigger_once(P)}],
3566 [( { propagator_state(P, S), S == dead } -> [] ; [p(P)])].
3567reified_goal(p(Prop), Ds) -->
3568 { term_variables(Prop, Vs) },
3569 reified_goal(p(Vs,Prop), Ds).
3570reified_goal(function(D,Op,A,B,R), Ds) -->
3571 reified_goals([d(D),p(pfunction(Op,A,B,R)),a(A,B,R)], Ds).
3572reified_goal(function(D,Op,A,R), Ds) -->
3573 reified_goals([d(D),p(pfunction(Op,A,R)),a(A,R)], Ds).
3574reified_goal(skeleton(A,B,D,R,F), Ds) -->
3575 { Prop =.. [F,X,Y,Z] },
3576 reified_goals([d(D1),l(p(P)),g(make_propagator(Prop, P)),
3577 p([A,B,D2,R], pskeleton(A,B,D2,[X,Y,Z]-P,R,F)),
3578 p(reified_and(D1,[],D2,[],D)),a(D2),a(A,B,R)], Ds).
3579reified_goal(a(V), _) --> [a(V)].
3580reified_goal(a(X,V), _) --> [a(X,V)].
3581reified_goal(a(X,Y,V), _) --> [a(X,Y,V)].
3582reified_goal(l(L), _) --> [[L]].
3583
3584parse_init_dcg([], _) --> [].
3585parse_init_dcg([V|Vs], P) --> [{init_propagator(V, P)}], parse_init_dcg(Vs, P).
3586
3587%?- set_prolog_flag(answer_write_options, [portray(true)]),
3588% clpz:parse_reified_clauses(Cs), maplist(portray_clause, Cs).
3589
3590reify(E, B) :- reify(E, B, _).
3591
3592reify(Expr, B, Ps) :-
3593 ( acyclic_term(Expr), reifiable(Expr) -> phrase(reify(Expr, B), Ps)
3594 ; domain_error(clpz_reifiable_expression, Expr)
3595 ).
3596
3597reifiable(E) :- var(E), non_monotonic(E).
3598reifiable(E) :- integer(E), E in 0..1.
3599reifiable(?(E)) :- must_be_fd_integer(E).
3600reifiable(#(E)) :- must_be_fd_integer(E).
3601reifiable(V in _) :- fd_variable(V).
3602reifiable(Expr) :-
3603 Expr =.. [Op,Left,Right],
3604 ( memberchk(Op, [#>=,#>,#=<,#<,#=,#\=])
3605 ; memberchk(Op, [#==>,#<==,#<==>,#/\,#\/,#\]),
3606 reifiable(Left),
3607 reifiable(Right)
3608 ).
3609reifiable(#\ E) :- reifiable(E).
3610reifiable(tuples_in(Tuples, Relation)) :-
3611 must_be(list(list), Tuples),
3612 maplist(maplist(fd_variable), Tuples),
3613 must_be(list(list(integer)), Relation).
3614reifiable(finite_domain(V)) :- fd_variable(V).
3615
3616reify(E, B) --> { B in 0..1 }, reify_(E, B).
3617
3618reify_(E, B) --> { var(E), !, E = B }.
3619reify_(E, B) --> { integer(E), E = B }.
3620reify_(?(B), B) --> [].
3621reify_(#(B), B) --> [].
3622reify_(V in Drep, B) -->
3623 { drep_to_domain(Drep, Dom) },
3624 propagator_init_trigger(reified_in(V,Dom,B)),
3625 a(B).
3626reify_(tuples_in(Tuples, Relation), B) -->
3627 { maplist(relation_tuple_b_prop(Relation), Tuples, Bs, Ps),
3628 maplist(monotonic, Bs, Bs1),
3629 fold_statement(conjunction, Bs1, And),
3630 ?(B) #<==> And },
3631 propagator_init_trigger([B], tuples_not_in(Tuples, Relation, B)),
3632 kill_reified_tuples(Bs, Ps, Bs),
3633 list(Ps),
3634 as([B|Bs]).
3635reify_(finite_domain(V), B) -->
3636 propagator_init_trigger(reified_fd(V,B)),
3637 a(B).
3638reify_(L #>= R, B) --> arithmetic(L, R, B, reified_geq).
3639reify_(L #= R, B) --> arithmetic(L, R, B, reified_eq).
3640reify_(L #\= R, B) --> arithmetic(L, R, B, reified_neq).
3641reify_(L #> R, B) --> reify_(L #>= (R+1), B).
3642reify_(L #=< R, B) --> reify_(R #>= L, B).
3643reify_(L #< R, B) --> reify_(R #>= (L+1), B).
3644reify_(L #==> R, B) --> reify_((#\ L) #\/ R, B).
3645reify_(L #<== R, B) --> reify_(R #==> L, B).
3646reify_(L #<==> R, B) --> reify_((L #==> R) #/\ (R #==> L), B).
3647reify_(L #\ R, B) --> reify_((L #\/ R) #/\ #\ (L #/\ R), B).
3648reify_(L #/\ R, B) -->
3649 ( { conjunctive_neqs_var_drep(L #/\ R, V, D) } -> reify_(V in D, B)
3650 ; boolean(L, R, B, reified_and)
3651 ).
3652reify_(L #\/ R, B) -->
3653 ( { disjunctive_eqs_var_drep(L #\/ R, V, D) } -> reify_(V in D, B)
3654 ; boolean(L, R, B, reified_or)
3655 ).
3656reify_(#\ Q, B) -->
3657 reify(Q, QR),
3658 propagator_init_trigger(reified_not(QR,B)),
3659 a(B).
3660
3661arithmetic(L, R, B, Functor) -->
3662 { phrase((parse_reified_clpz(L, LR, LD),
3663 parse_reified_clpz(R, RR, RD)), Ps),
3664 Prop =.. [Functor,LD,LR,RD,RR,Ps,B] },
3665 list(Ps),
3666 propagator_init_trigger([LD,LR,RD,RR,B], Prop),
3667 a(B).
3668
3669boolean(L, R, B, Functor) -->
3670 { reify(L, LR, Ps1), reify(R, RR, Ps2),
3671 Prop =.. [Functor,LR,Ps1,RR,Ps2,B] },
3672 list(Ps1), list(Ps2),
3673 propagator_init_trigger([LR,RR,B], Prop),
3674 a(LR, RR, B).
3675
3676list([]) --> [].
3677list([L|Ls]) --> [L], list(Ls).
3678
3679a(X,Y,B) -->
3680 ( nonvar(X) -> a(Y, B)
3681 ; nonvar(Y) -> a(X, B)
3682 ; [a(X,Y,B)]
3683 ).
3684
3685a(X, B) -->
3686 ( { var(X) } -> [a(X, B)]
3687 ; a(B)
3688 ).
3689
3690a(B) -->
3691 ( { var(B) } -> [a(B)]
3692 ; []
3693 ).
3694
3695as([]) --> [].
3696as([B|Bs]) --> a(B), as(Bs).
3697
3698kill_reified_tuples([], _, _) --> [].
3699kill_reified_tuples([B|Bs], Ps, All) -->
3700 propagator_init_trigger([B], kill_reified_tuples(B, Ps, All)),
3701 kill_reified_tuples(Bs, Ps, All).
3702
3703relation_tuple_b_prop(Relation, Tuple, B, p(Prop)) :-
3704 put_attr(R, clpz_relation, Relation),
3705 make_propagator(reified_tuple_in(Tuple, R, B), Prop),
3706 tuple_freeze_(Tuple, Prop),
3707 init_propagator(B, Prop).
3708
3709
3710tuples_in_conjunction(Tuples, Relation, Conj) :-
3711 maplist(tuple_in_disjunction(Relation), Tuples, Disjs),
3712 fold_statement(conjunction, Disjs, Conj).
3713
3714tuple_in_disjunction(Relation, Tuple, Disj) :-
3715 maplist(tuple_in_conjunction(Tuple), Relation, Conjs),
3716 fold_statement(disjunction, Conjs, Disj).
3717
3718tuple_in_conjunction(Tuple, Element, Conj) :-
3719 maplist(var_eq, Tuple, Element, Eqs),
3720 fold_statement(conjunction, Eqs, Conj).
3721
3722fold_statement(Operation, List, Statement) :-
3723 ( List = [] -> Statement = 1
3724 ; List = [First|Rest],
3725 foldl(Operation, Rest, First, Statement)
3726 ).
3727
3728conjunction(E, Conj, Conj #/\ E).
3729
3730disjunction(E, Disj, Disj #\/ E).
3731
3732var_eq(V, N, ?(V) #= N).
3733
3734% Match variables to created skeleton.
3735
3736skeleton(Vs, Vs-Prop) :-
3737 maplist(prop_init(Prop), Vs),
3738 trigger_once(Prop).
3739
3740/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3741 A drep is a user-accessible and visible domain representation. N,
3742 N..M, and D1 \/ D2 are dreps, if D1 and D2 are dreps.
3743- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3744
3745is_drep(N) :- integer(N).
3746is_drep(N..M) :- drep_bound(N), drep_bound(M), N \== sup, M \== inf.
3747is_drep(D1\/D2) :- is_drep(D1), is_drep(D2).
3748is_drep({AI}) :- is_and_integers(AI).
3749is_drep(\D) :- is_drep(D).
3750
3751is_and_integers(I) :- integer(I).
3752is_and_integers((A,B)) :- is_and_integers(A), is_and_integers(B).
3753
3754drep_bound(I) :- integer(I).
3755drep_bound(sup).
3756drep_bound(inf).
3757
3758drep_to_intervals(I) --> { integer(I) }, [n(I)-n(I)].
3759drep_to_intervals(N..M) -->
3760 ( { defaulty_to_bound(N, N1), defaulty_to_bound(M, M1),
3761 N1 cis_leq M1} -> [N1-M1]
3762 ; []
3763 ).
3764drep_to_intervals(D1 \/ D2) -->
3765 drep_to_intervals(D1), drep_to_intervals(D2).
3766drep_to_intervals(\D0) -->
3767 { drep_to_domain(D0, D1),
3768 domain_complement(D1, D),
3769 domain_to_drep(D, Drep) },
3770 drep_to_intervals(Drep).
3771drep_to_intervals({AI}) -->
3772 and_integers_(AI).
3773
3774and_integers_(I) --> { integer(I) }, [n(I)-n(I)].
3775and_integers_((A,B)) --> and_integers_(A), and_integers_(B).
3776
3777drep_to_domain(DR, D) :-
3778 must_be(ground, DR),
3779 ( is_drep(DR) -> true
3780 ; domain_error(clpz_domain, DR)
3781 ),
3782 phrase(drep_to_intervals(DR), Is0),
3783 merge_intervals(Is0, Is1),
3784 intervals_to_domain(Is1, D).
3785
3786merge_intervals(Is0, Is) :-
3787 keysort(Is0, Is1),
3788 merge_overlapping(Is1, Is).
3789
3790merge_overlapping([], []).
3791merge_overlapping([A-B0|ABs0], [A-B|ABs]) :-
3792 merge_remaining(ABs0, B0, B, Rest),
3793 merge_overlapping(Rest, ABs).
3794
3795merge_remaining([], B, B, []).
3796merge_remaining([N-M|NMs], B0, B, Rest) :-
3797 Next cis B0 + n(1),
3798 ( N cis_gt Next -> B = B0, Rest = [N-M|NMs]
3799 ; B1 cis max(B0,M),
3800 merge_remaining(NMs, B1, B, Rest)
3801 ).
3802
3803domain(V, Dom) :-
3804 ( fd_get(V, Dom0, VPs) ->
3805 domains_intersection(Dom, Dom0, Dom1),
3806 %format("intersected\n: ~w\n ~w\n==> ~w\n\n", [Dom,Dom0,Dom1]),
3807 fd_put(V, Dom1, VPs),
3808 do_queue,
3809 reinforce(V)
3810 ; domain_contains(Dom, V)
3811 ).
3812
3813domains([], _).
3814domains([V|Vs], D) :- domain(V, D), domains(Vs, D).
3815
3816props_number(fd_props(Gs,Bs,Os), N) :-
3817 length(Gs, N1),
3818 length(Bs, N2),
3819 length(Os, N3),
3820 N is N1 + N2 + N3.
3821
3822fd_get(X, Dom, Ps) :-
3823 ( get_attr(X, clpz, Attr) -> Attr = clpz_attr(_,_,_,Dom,Ps,_)
3824 ; var(X) -> default_domain(Dom), Ps = fd_props([],[],[])
3825 ).
3826
3827fd_get(X, Dom, Inf, Sup, Ps) :-
3828 fd_get(X, Dom, Ps),
3829 domain_infimum(Dom, Inf),
3830 domain_supremum(Dom, Sup).
3831
3832/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3833 Constraint propagation always terminates. Currently, this is
3834 ensured by allowing the left and right boundaries, as well as the
3835 distance between the smallest and largest number occurring in the
3836 domain representation to be changed at most once after a constraint
3837 is posted, unless the domain is bounded.
3838- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3839
3840fd_put(X, Dom, Ps) --> put_terminating(X, Dom, Ps).
3841
3842fd_put(X, Dom, Ps) :-
3843 { format("New queue\n", []) },
3844 new_queue(Q),
3845 phrase((put_terminating(X, Dom, Ps),
3846% { portray_clause(done_terminating) },
3847 do_queue), [Q], _).
3848
3849put_terminating(X, Dom, Ps) -->
3850 Dom \== empty,
3851 ( Dom = from_to(F, F) ->
3852 state(S),
3853 { format("put_terminating state: ~w\n", [S]) },
3854 queue_goal(F = n(X))
3855 ; ( { get_attr(X, clpz, Attr) } ->
3856 { Attr = clpz_attr(Left,Right,Spread,OldDom, _OldPs,Q),
3857 put_attr(X, clpz, clpz_attr(Left,Right,Spread,Dom,Ps,Q)) },
3858 ( { OldDom == Dom } -> []
3859 ; { ( Left == (.) -> Bounded = yes
3860 ; domain_infimum(Dom, Inf),
3861 domain_supremum(Dom, Sup),
3862 ( Inf = n(_), Sup = n(_) ->
3863 Bounded = yes
3864 ; Bounded = no
3865 )
3866 ) },
3867 ( { Bounded == yes } ->
3868 { put_attr(X, clpz, clpz_attr(.,.,.,Dom,Ps,Q)) },
3869 { format("put_terminating: ~w ~w ~w ~w\n", [X, Dom, Ps, Q]) },
3870 trigger_props(Ps, X, OldDom, Dom)
3871 ; % infinite domain; consider border and spread changes
3872 { domain_infimum(OldDom, OldInf),
3873 ( Inf == OldInf -> LeftP = Left
3874 ; LeftP = yes
3875 ),
3876 domain_supremum(OldDom, OldSup),
3877 ( Sup == OldSup -> RightP = Right
3878 ; RightP = yes
3879 ),
3880 domain_spread(OldDom, OldSpread),
3881 domain_spread(Dom, NewSpread),
3882 ( NewSpread == OldSpread -> SpreadP = Spread
3883 ; NewSpread cis_lt OldSpread -> SpreadP = no
3884 ; SpreadP = yes
3885 ),
3886 put_attr(X, clpz, clpz_attr(LeftP,RightP,SpreadP,Dom,Ps,Q)) },
3887 ( { RightP == yes, Right = yes } -> []
3888 ; { LeftP == yes, Left = yes } -> []
3889 ; { SpreadP == yes, Spread = yes } -> []
3890 ; trigger_props(Ps, X, OldDom, Dom)
3891 )
3892 )
3893 )
3894 ; { var(X) } ->
3895 { new_queue(Q),
3896 put_attr(X, clpz, clpz_attr(no,no,no,Dom,Ps,Q)) }
3897 ; []
3898 )
3899 ).
3900
3901new_queue(queue(Goals,Fast,Slow,_Aux)) :-
3902 put_atts(Goals, +queue([],_)),
3903 put_atts(Fast, +queue([],_)),
3904 put_atts(Slow, +queue([],_)).
3905
3906queue_goal(Goal) --> { format("goal ~q\n", [Goal]) }, insert_queue(Goal, 1).
3907queue_fast(Prop) --> { format("fast ~q\n", [Prop]) }, insert_queue(Prop, 2).
3908queue_slow(Prop) --> { format("slow ~q\n", [Prop]) }, insert_queue(Prop, 3).
3909
3910insert_queue(Element, Which) -->
3911 state(Queue),
3912 { format("insert_queue ~q\n", [Queue]) },
3913 { ((var(Which) ; var(Queue)) -> throw(bad) ; true), arg(Which, Queue, Arg),
3914 get_atts(Arg, queue(Head0,Tail0)),
3915 ( Head0 == [] ->
3916 Head = [Element|Tail]
3917 ; Head = Head0,
3918 Tail0 = [Element|Tail]
3919 ),
3920 put_atts(Arg, +queue(Head,Tail)) }.
3921
3922
3923domain_spread(Dom, Spread) :-
3924 domain_smallest_finite(Dom, S),
3925 domain_largest_finite(Dom, L),
3926 Spread cis L - S.
3927
3928smallest_finite(inf, Y, Y).
3929smallest_finite(n(N), _, n(N)).
3930
3931domain_smallest_finite(from_to(F,T), S) :- smallest_finite(F, T, S).
3932domain_smallest_finite(split(_, L, _), S) :- domain_smallest_finite(L, S).
3933
3934largest_finite(sup, Y, Y).
3935largest_finite(n(N), _, n(N)).
3936
3937domain_largest_finite(from_to(F,T), L) :- largest_finite(T, F, L).
3938domain_largest_finite(split(_, _, R), L) :- domain_largest_finite(R, L).
3939
3940/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3941 All relevant constraints get a propagation opportunity whenever a
3942 new constraint is posted.
3943- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3944
3945reinforce(X) :-
3946 term_variables(X, Vs),
3947 maplist(reinforce_, Vs).
3948
3949reinforce_(X) :-
3950 ( fd_var(X), fd_get(X, Dom, Ps) ->
3951 put_full(X, Dom, Ps)
3952 ; true
3953 ).
3954
3955put_full(X, Dom, Ps) :-
3956 Dom \== empty,
3957 ( Dom = from_to(F, F) -> F = n(X)
3958 ; ( get_attr(X, clpz, Attr) ->
3959 Attr = clpz_attr(_,_,_,OldDom, _OldPs,Q),
3960 put_attr(X, clpz, clpz_attr(no,no,no,Dom,Ps,Q)),
3961 %format("putting dom: ~w\n", [Dom]),
3962 ( OldDom == Dom -> true
3963 ; new_queue(Q), % TODO: queue?
3964 phrase((trigger_props(Ps, X, OldDom, Dom),
3965 do_queue), [Q], _)
3966 )
3967 ; var(X) -> %format('\t~w in ~w .. ~w\n',[X,L,U]),
3968 new_queue(Q),
3969 put_attr(X, clpz, clpz_attr(no,no,no,Dom,Ps,Q))
3970 ; true
3971 )
3972 ).
3973
3974/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3975 A propagator is a term of the form propagator(C, State), where C
3976 represents a constraint, and State is a free variable that can be
3977 used to destructively change the state of the propagator via
3978 attributes. This can be used to avoid redundant invocation of the
3979 same propagator, or to disable the propagator.
3980- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3981
3982make_propagator(C, propagator(C, _)).
3983
3984propagator_state(propagator(_,S), S).
3985
3986trigger_props(fd_props(Gs,Bs,Os), X, D0, D) -->
3987 ( { ground(X) } ->
3988 trigger_props_(Gs),
3989 trigger_props_(Bs)
3990 ; Bs \== [] ->
3991 { domain_infimum(D0, I0),
3992 domain_infimum(D, I) },
3993 ( { I == I0 } ->
3994 { domain_supremum(D0, S0),
3995 domain_supremum(D, S) },
3996 ( { S == S0 } -> []
3997 ; trigger_props_(Bs)
3998 )
3999 ; trigger_props_(Bs)
4000 )
4001 ; [],
4002 { format("trigger_props: ~w ~w ~w ~w ~w ~w\n", [Gs, Bs, Os, X, D0, D]) }
4003 ),
4004 trigger_props_(Os).
4005
4006trigger_props(fd_props(Gs,Bs,Os), X) -->
4007 trigger_props_(Os),
4008 trigger_props_(Bs),
4009 ( { ground(X) } ->
4010 trigger_props_(Gs)
4011 ; []
4012 ).
4013
4014trigger_props(fd_props(Gs,Bs,Os)) -->
4015 trigger_props_(Gs),
4016 trigger_props_(Bs),
4017 trigger_props_(Os).
4018
4019trigger_props_([]) --> [].
4020trigger_props_([P|Ps]) --> { format("here\n", []) }, trigger_prop(P), trigger_props_(Ps).
4021
4022trigger_prop(_P) :- true. % TODO: What to do?
4023
4024trigger_prop(Propagator) -->
4025 { propagator_state(Propagator, State) },
4026 ( { State == dead } -> []
4027 ; { get_attr(State, clpz_aux, queued) } -> []
4028 ; % passive
4029 % { format("triggering: ~w\n", [Propagator]) },
4030 { put_attr(State, clpz_aux, queued) },
4031 ( { arg(1, Propagator, C), functor(C, F, _), global_constraint(F) } ->
4032 queue_slow(Propagator)
4033 ; queue_fast(Propagator)
4034 )
4035 ).
4036
4037all_propagators(fd_props(Gs,Bs,Os)) -->
4038 propagators_(Gs),
4039 propagators_(Bs),
4040 propagators_(Os).
4041
4042propagators_([]) --> [].
4043propagators_([P|Ps]) --> propagator_(P), propagators_(Ps).
4044
4045propagator_(Propagator) -->
4046 { propagator_state(Propagator, State) },
4047 ( { State == dead } -> []
4048 ; { get_attr(State, clpz_aux, queued) } -> []
4049 ; % passive
4050 % format("triggering: ~w\n", [Propagator]),
4051 [clpz:trigger_prop(Propagator)]
4052 ).
4053
4054% DCG variants
4055
4056kill(State) --> { kill(State) }.
4057
4058kill(State, Ps) --> { kill(State, Ps) }.
4059
4060T =.. Ls --> { T =.. Ls }.
4061
4062A = A --> [].
4063
4064A == B --> { A == B }.
4065
4066A \== B --> { A \== B }.
4067
4068integer(I) --> { integer(I) }.
4069nonvar(X) --> { nonvar(X) }.
4070var(V) --> { var(V) }.
4071ground(T) --> { ground(T) }.
4072
4073true --> [].
4074
4075X >= Y --> { X >= Y }.
4076X =< Y --> { X =< Y }.
4077X =:= Y --> { X =:= Y }.
4078X =\= Y --> { X =\= Y }.
4079X is E --> { X is E }.
4080X > Y --> { X > Y }.
4081X < Y --> { X < Y }.
4082
4083/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4084 Duo DCG variants
4085- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4086
4087A = B ++> { A = B }.
4088A < B ++> { A < B }.
4089A is B ++> { A is B }.
4090
4091kill(State) :- del_attr(State, clpz_aux), State = dead.
4092
4093kill(State, Ps) :-
4094 kill(State),
4095 maplist(kill_entailed, Ps).
4096
4097kill_entailed(p(Prop)) :-
4098 propagator_state(Prop, State),
4099 kill(State).
4100kill_entailed(a(V)) :-
4101 del_attr(V, clpz).
4102kill_entailed(a(X,B)) :-
4103 ( X == B -> true
4104 ; del_attr(B, clpz)
4105 ).
4106kill_entailed(a(X,Y,B)) :-
4107 ( X == B -> true
4108 ; Y == B -> true
4109 ; del_attr(B, clpz)
4110 ).
4111
4112no_reactivation(rel_tuple(_,_)).
4113no_reactivation(pdistinct(_)).
4114no_reactivation(pnvalue(_)).
4115no_reactivation(pgcc(_,_,_)).
4116no_reactivation(pgcc_single(_,_)).
4117%no_reactivation(scalar_product(_,_,_,_)).
4118
4119activate_propagator(propagator(P,State)) -->
4120 ( State == dead -> []
4121 ; { del_attr(State, clpz_aux) },
4122 ( { no_reactivation(P) } ->
4123 %b_setval('$clpz_current_propagator', State), TODO
4124 run_propagator(P, State)
4125 %b_setval('$clpz_current_propagator', [])
4126 ; run_propagator(P, State)
4127 )
4128 ).
4129
4130enable_queue :- true. % NOP
4131disable_queue :- true. % NOP
4132do_queue. % NOP
4133
4134do_queue --> print_queue, { false }.
4135do_queue -->
4136 ( queue_enabled ->
4137 ( queue_get_goal(Goal) -> { call(Goal) }, do_queue
4138 ; queue_get_fast(Fast) -> activate_propagator(Fast), do_queue
4139 ; queue_get_slow(Slow) -> activate_propagator(Slow), do_queue
4140 ; true
4141 )
4142 ; true
4143 ).
4144
4145print_queue -->
4146 state(queue(Goal,Fast,Slow,_)),
4147 { get_atts(Goal, +queue(GHs,_)),
4148 get_atts(Fast, +queue(FHs,_)),
4149 get_atts(Slow, +queue(SHs,_)),
4150 format("Current queue:~n goal: ~q~n fast: ~q~n slow: ~q~n~n", [GHs,FHs,SHs]) }.
4151
4152
4153
4154queue_get_goal(Goal) --> queue_get_arg(1, Goal).
4155queue_get_fast(Fast) --> queue_get_arg(2, Fast).
4156queue_get_slow(Slow) --> queue_get_arg(3, Slow).
4157
4158queue_get_arg(Which, Element) -->
4159 state(Queue),
4160 { queue_get_arg_(Queue, Which, Element) }.
4161
4162queue_get_arg_(Queue, Which, Element) :-
4163 arg(Which, Queue, Arg),
4164 get_atts(Arg, +queue([Element|Elements],Tail)),
4165 ( var(Elements) ->
4166 put_atts(Arg, +queue([],_))
4167 ; put_atts(Arg, +queue(Elements,Tail))
4168 ).
4169
4170queue_enabled --> state(queue(_,_,_,Aux)), { \+ get_atts(Aux, +enabled(false)) }.
4171
4172
4173portray_propagator(propagator(P,_), F) :- functor(P, F, _).
4174
4175init_propagator(Var, Prop) :-
4176 ( fd_get(Var, Dom, Ps0) ->
4177 % format("init_propagator: ~w ~w ~w ~w ~w\n", [Var, Dom, Ps0, Prop]),
4178 insert_propagator(Prop, Ps0, Ps),
4179 format("init_propagator: ~w ~w ~w ~w ~w\n", [Var, Dom, Ps0, Ps, Prop]),
4180 fd_put(Var, Dom, Ps)
4181 ; true,
4182 format("init_propagator: ~w ~w\n", [Var, Prop])
4183 ).
4184
4185constraint_wake(pneq, ground).
4186constraint_wake(x_neq_y_plus_z, ground).
4187constraint_wake(absdiff_neq, ground).
4188constraint_wake(pdifferent, ground).
4189constraint_wake(pexclude, ground).
4190constraint_wake(scalar_product_neq, ground).
4191constraint_wake(x_eq_abs_plus_v, ground).
4192
4193constraint_wake(x_leq_y_plus_c, bounds).
4194constraint_wake(scalar_product_eq, bounds).
4195constraint_wake(scalar_product_leq, bounds).
4196constraint_wake(pplus, bounds).
4197constraint_wake(pgeq, bounds).
4198constraint_wake(pgcc_single, bounds).
4199constraint_wake(pgcc_check_single, bounds).
4200
4201global_constraint(pdistinct).
4202global_constraint(pnvalue).
4203global_constraint(pgcc).
4204global_constraint(pgcc_single).
4205global_constraint(pcircuit).
4206%global_constraint(rel_tuple).
4207%global_constraint(scalar_product_eq).
4208
4209insert_propagator(Prop, Ps0, Ps) :-
4210 Ps0 = fd_props(Gs,Bs,Os),
4211 arg(1, Prop, Constraint),
4212 functor(Constraint, F, _),
4213 ( constraint_wake(F, ground) ->
4214 Ps = fd_props([Prop|Gs], Bs, Os)
4215 ; constraint_wake(F, bounds) ->
4216 Ps = fd_props(Gs, [Prop|Bs], Os)
4217 ; Ps = fd_props(Gs, Bs, [Prop|Os])
4218 ).
4219
4220%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4221
4222%% lex_chain(+Lists)
4223%
4224% Lists are lexicographically non-decreasing.
4225
4226lex_chain(Lss) :-
4227 must_be(list(list), lex_chain(Lss)-1, Lss),
4228 maplist(maplist(fd_variable), Lss),
4229 ( Lss == [] -> true
4230 ; Lss = [First|Rest],
4231 make_propagator(presidual(lex_chain(Lss)), Prop),
4232 foldl(lex_chain_(Prop), Rest, First, _)
4233 ).
4234
4235lex_chain_(Prop, Ls, Prev, Ls) :-
4236 maplist(prop_init(Prop), Ls),
4237 lex_le(Prev, Ls).
4238
4239lex_le([], []).
4240lex_le([V1|V1s], [V2|V2s]) :-
4241 ?(V1) #=< ?(V2),
4242 ( integer(V1) ->
4243 ( integer(V2) ->
4244 ( V1 =:= V2 -> lex_le(V1s, V2s) ; true )
4245 ; freeze(V2, lex_le([V1|V1s], [V2|V2s]))
4246 )
4247 ; freeze(V1, lex_le([V1|V1s], [V2|V2s]))
4248 ).
4249
4250%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4251
4252
4253%% tuples_in(+Tuples, +Relation).
4254%
4255% True iff all Tuples are elements of Relation. Each element of the
4256% list Tuples is a list of integers or finite domain variables.
4257% Relation is a list of lists of integers. Arbitrary finite relations,
4258% such as compatibility tables, can be modeled in this way. For
4259% example, if 1 is compatible with 2 and 5, and 4 is compatible with 0
4260% and 3:
4261%
4262% ==
4263% ?- tuples_in([[X,Y]], [[1,2],[1,5],[4,0],[4,3]]), X = 4.
4264% X = 4,
4265% Y in 0\/3.
4266% ==
4267%
4268% As another example, consider a train schedule represented as a list
4269% of quadruples, denoting departure and arrival places and times for
4270% each train. In the following program, Ps is a feasible journey of
4271% length 3 from A to D via trains that are part of the given schedule.
4272%
4273% ==
4274% trains([[1,2,0,1],
4275% [2,3,4,5],
4276% [2,3,0,1],
4277% [3,4,5,6],
4278% [3,4,2,3],
4279% [3,4,8,9]]).
4280%
4281% threepath(A, D, Ps) :-
4282% Ps = [[A,B,_T0,T1],[B,C,T2,T3],[C,D,T4,_T5]],
4283% T2 #> T1,
4284% T4 #> T3,
4285% trains(Ts),
4286% tuples_in(Ps, Ts).
4287% ==
4288%
4289% In this example, the unique solution is found without labeling:
4290%
4291% ==
4292% ?- threepath(1, 4, Ps).
4293% Ps = [[1, 2, 0, 1], [2, 3, 4, 5], [3, 4, 8, 9]].
4294% ==
4295
4296tuples_in(Tuples, Relation) :-
4297 must_be(list(list), Tuples),
4298 maplist(maplist(fd_variable), Tuples),
4299 must_be(list(list(integer)), Relation),
4300 maplist(relation_tuple(Relation), Tuples),
4301 do_queue.
4302
4303relation_tuple(Relation, Tuple) :-
4304 relation_unifiable(Relation, Tuple, Us, _, _),
4305 ( ground(Tuple) -> memberchk(Tuple, Relation)
4306 ; phrase(tuple_domain(Tuple, Us), _),
4307 % ( Tuple = [_,_|_] -> tuple_freeze(Tuple, Us)
4308 ( length(Tuple, N), N > 1 -> tuple_freeze(Tuple, Us)
4309 ; true
4310 )
4311 ).
4312
4313list_first_rest([L|Ls], L, Ls).
4314
4315tuple_domain([], _) --> [].
4316tuple_domain([T|Ts], Relation0) -->
4317 { maplist(list_first_rest, Relation0, Firsts, Relation1) },
4318 ( var(T) ->
4319 ( Firsts = [Unique] -> T = Unique
4320 ; { list_to_domain(Firsts, FDom),
4321 fd_get(T, TDom, TPs),
4322 domains_intersection(TDom, FDom, TDom1) },
4323 { format("tuple_domain: ~w ~w ~w\n", [T, TDom1, TPs]) },
4324 fd_put(T, TDom1, TPs)
4325 )
4326 ; []
4327 ),
4328 tuple_domain(Ts, Relation1).
4329
4330tuple_freeze(Tuple, Relation) :-
4331 put_attr(R, clpz_relation, Relation),
4332 make_propagator(rel_tuple(R, Tuple), Prop),
4333 tuple_freeze_(Tuple, Prop).
4334
4335tuple_freeze_([], _).
4336tuple_freeze_([T|Ts], Prop) :-
4337 ( var(T) ->
4338 init_propagator(T, Prop),
4339 trigger_prop(Prop)
4340 ; true
4341 ),
4342 tuple_freeze_(Ts, Prop).
4343
4344relation_unifiable([], _, [], Changed, Changed).
4345relation_unifiable([R|Rs], Tuple, Us, Changed0, Changed) :-
4346 ( all_in_domain(R, Tuple) ->
4347 Us = [R|Rest],
4348 relation_unifiable(Rs, Tuple, Rest, Changed0, Changed)
4349 ; relation_unifiable(Rs, Tuple, Us, true, Changed)
4350 ).
4351
4352all_in_domain([], []).
4353all_in_domain([A|As], [T|Ts]) :-
4354 ( fd_get(T, Dom, _) ->
4355 domain_contains(Dom, A)
4356 ; T =:= A
4357 ),
4358 all_in_domain(As, Ts).
4359
4360%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4361
4362%run_propagator(P, _) --> { portray_clause(run_propagator(P)), false }.
4363% trivial propagator, used only to remember pending constraints
4364run_propagator(presidual(_), _) --> [].
4365
4366%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4367run_propagator(pdifferent(Left,Right,X,_), MState) -->
4368 run_propagator(pexclude(Left,Right,X), MState).
4369
4370run_propagator(pexclude(Left,Right,X), _) -->
4371 { ( ground(X) ->
4372 disable_queue,
4373 exclude_fire(Left, Right, X),
4374 enable_queue
4375 ; true
4376 ) }.
4377
4378run_propagator(pdistinct(Ls), _MState) --> { distinct(Ls) }.
4379
4380run_propagator(pnvalue(N, Vars), _MState) --> { propagate_nvalue(N, Vars) }.
4381
4382run_propagator(check_distinct(Left,Right,X), _) -->
4383 { \+ list_contains(Left, X),
4384 \+ list_contains(Right, X) }.
4385
4386%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4387
4388run_propagator(pelement(N, Is, V), MState) -->
4389 ( { fd_get(N, NDom, _) } ->
4390 ( { fd_get(V, VDom, VPs) } ->
4391 { integers_remaining(Is, 1, NDom, empty, VDom1),
4392 domains_intersection(VDom, VDom1, VDom2) },
4393 fd_put(V, VDom2, VPs)
4394 ; []
4395 )
4396 ; { kill(MState), nth1(N, Is, V) }
4397 ).
4398
4399%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4400
4401run_propagator(pgcc_single(Vs, Pairs), _) --> { gcc_global(Vs, Pairs) }.
4402
4403run_propagator(pgcc_check_single(Pairs), _) --> { gcc_check(Pairs) }.
4404
4405run_propagator(pgcc_check(Pairs), _) --> { gcc_check(Pairs) }.
4406
4407run_propagator(pgcc(Vs, _, Pairs), _) --> { gcc_global(Vs, Pairs) }.
4408
4409%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4410
4411run_propagator(pcircuit(Vs), _MState) -->
4412 { distinct(Vs),
4413 propagate_circuit(Vs) }.
4414
4415
4416%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4417run_propagator(pgeq(A,B), MState) -->
4418 ( A == B -> kill(MState)
4419 ; nonvar(A) ->
4420 ( nonvar(B) -> kill(MState), A >= B
4421 ; { fd_get(B, BD, BPs),
4422 domain_remove_greater_than(BD, A, BD1) },
4423 kill(MState),
4424 fd_put(B, BD1, BPs)
4425 )
4426 ; nonvar(B) ->
4427 { fd_get(A, AD, APs),
4428 domain_remove_smaller_than(AD, B, AD1) },
4429 kill(MState),
4430 fd_put(A, AD1, APs)
4431 ; { fd_get(A, AD, AL, AU, APs),
4432 fd_get(B, _, BL, BU, _),
4433 AU cis_geq BL },
4434 ( { AL cis_geq BU } -> kill(MState)
4435 ; AU == BL -> kill(MState), A = B
4436 ; { NAL cis max(AL,BL),
4437 domains_intersection(AD, from_to(NAL,AU), NAD) },
4438 fd_put(A, NAD, APs),
4439 ( { fd_get(B, BD2, BL2, BU2, BPs2) } ->
4440 { NBU cis min(BU2, AU),
4441 domains_intersection(BD2, from_to(BL2,NBU), NBD) },
4442 fd_put(B, NBD, BPs2)
4443 ; []
4444 )
4445 )
4446 ).
4447
4448%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4449
4450run_propagator(rel_tuple(R, Tuple), MState) -->
4451 { get_attr(R, clpz_relation, Relation) },
4452 ( { ground(Tuple) } -> kill(MState), { memberchk(Tuple, Relation) }
4453 ; { relation_unifiable(Relation, Tuple, Us, false, Changed),
4454 Us = [_|_] },
4455 ( { Tuple = [First,Second], ( ground(First) ; ground(Second) ) } ->
4456 kill(MState)
4457 ; []
4458 ),
4459 ( { Us = [Single] } -> kill(MState), Single = Tuple
4460 ; { Changed } ->
4461 { put_attr(R, clpz_relation, Us),
4462 disable_queue },
4463 tuple_domain(Tuple, Us),
4464 { enable_queue }
4465 ; []
4466 )
4467 ).
4468
4469%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4470
4471run_propagator(pserialized(S_I, D_I, S_J, D_J, _), MState) -->
4472 ( nonvar(S_I), nonvar(S_J) ->
4473 kill(MState),
4474 ( S_I + D_I =< S_J -> []
4475 ; S_J + D_J =< S_I -> []
4476 ; { false }
4477 )
4478 ; serialize_lower_upper(S_I, D_I, S_J, D_J, MState),
4479 serialize_lower_upper(S_J, D_J, S_I, D_I, MState)
4480 ).
4481
4482%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4483% X #\= Y
4484run_propagator(pneq(A, B), MState) -->
4485 ( nonvar(A) ->
4486 ( nonvar(B) -> A =\= B, kill(MState)
4487 ; { fd_get(B, BD0, BExp0),
4488 domain_remove(BD0, A, BD1),
4489 kill(MState) },
4490 fd_put(B, BD1, BExp0)
4491 )
4492 ; nonvar(B) -> run_propagator(pneq(B, A), MState)
4493 ; A \== B,
4494 { fd_get(A, _, AI, AS, _),
4495 fd_get(B, _, BI, BS, _) },
4496 ( { AS cis_lt BI } -> kill(MState)
4497 ; { AI cis_gt BS } -> kill(MState)
4498 ; []
4499 )
4500 ).
4501
4502%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4503% Y = abs(X)
4504run_propagator(pabs(X,Y), MState) -->
4505 ( nonvar(X) -> kill(MState), Y is abs(X)
4506 ; nonvar(Y) ->
4507 kill(MState),
4508 Y >= 0,
4509 YN is -Y,
4510 { X in YN \/ Y }
4511 ; X == Y -> kill(MState)
4512 ; { fd_get(X, XD, XPs),
4513 fd_get(Y, YD, _),
4514 domain_negate(YD, YDNegative),
4515 domains_union(YD, YDNegative, XD1),
4516 domains_intersection(XD, XD1, XD2) },
4517 fd_put(X, XD2, XPs),
4518 ( { fd_get(Y, YD1, YPs1) } ->
4519 { domain_negate(XD2, XD2Neg),
4520 domains_union(XD2, XD2Neg, YD2),
4521 domain_remove_smaller_than(YD2, 0, YD3),
4522 domains_intersection(YD1, YD3, YD4) },
4523 fd_put(Y, YD4, YPs1)
4524 ; []
4525 )
4526 ).
4527%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4528% abs(X-Y) #\= C
4529run_propagator(absdiff_neq(X,Y,C), MState) -->
4530 ( C < 0 -> kill(MState)
4531 ; nonvar(X) ->
4532 kill(MState),
4533 ( nonvar(Y) -> abs(X - Y) =\= C
4534 ; V1 is X - C, neq_num(Y, V1),
4535 V2 is C + X, neq_num(Y, V2)
4536 )
4537 ; nonvar(Y) -> kill(MState),
4538 V1 is C + Y, neq_num(X, V1),
4539 V2 is Y - C, neq_num(X, V2)
4540 ; []
4541 ).
4542
4543
4544% X #= abs(X) + V
4545run_propagator(x_eq_abs_plus_v(X,V), MState) -->
4546 ( nonvar(V) ->
4547 ( V =:= 0 -> kill(MState), { X in 0..sup }
4548 ; V < 0 -> kill(MState), { X #= V / 2 }
4549 ; V > 0 -> { false }
4550 )
4551 ; nonvar(X) ->
4552 kill(MState),
4553 { V #= X - abs(X) }
4554 ; true
4555 ).
4556
4557% X #\= Y + Z
4558run_propagator(x_neq_y_plus_z(X,Y,Z), MState) -->
4559 ( nonvar(X) ->
4560 ( nonvar(Y) ->
4561 ( nonvar(Z) -> kill(MState), X =\= Y + Z
4562 ; kill(MState), XY is X - Y, neq_num(Z, XY)
4563 )
4564 ; nonvar(Z) -> kill(MState), XZ is X - Z, neq_num(Y, XZ)
4565 ; []
4566 )
4567 ; nonvar(Y) ->
4568 ( nonvar(Z) ->
4569 kill(MState), YZ is Y + Z, neq_num(X, YZ)
4570 ; Y =:= 0 -> kill(MState), { neq(X, Z) }
4571 ; []
4572 )
4573 ; Z == 0 -> kill(MState), { neq(X, Y) }
4574 ; true
4575 ).
4576
4577% X #=< Y + C
4578run_propagator(x_leq_y_plus_c(X,Y,C), MState) -->
4579 ( nonvar(X) ->
4580 ( nonvar(Y) -> kill(MState), X =< Y + C
4581 ; kill(MState),
4582 R is X - C,
4583 { fd_get(Y, YD, YPs),
4584 domain_remove_smaller_than(YD, R, YD1) },
4585 fd_put(Y, YD1, YPs)
4586 )
4587 ; nonvar(Y) ->
4588 kill(MState),
4589 R is Y + C,
4590 { fd_get(X, XD, XPs),
4591 domain_remove_greater_than(XD, R, XD1) },
4592 fd_put(X, XD1, XPs)
4593 ; ( X == Y -> C >= 0, kill(MState)
4594 ; { fd_get(Y, YD, _) },
4595 ( { domain_supremum(YD, n(YSup)) } ->
4596 YS1 is YSup + C,
4597 { fd_get(X, XD, XPs),
4598 domain_remove_greater_than(XD, YS1, XD1) },
4599 fd_put(X, XD1, XPs)
4600 ; []
4601 ),
4602 ( { fd_get(X, XD2, _), domain_infimum(XD2, n(XInf)) } ->
4603 XI1 is XInf - C,
4604 ( { fd_get(Y, YD1, YPs1) } ->
4605 { domain_remove_smaller_than(YD1, XI1, YD2),
4606 ( domain_infimum(YD2, n(YInf)),
4607 domain_supremum(XD2, n(XSup)),
4608 XSup =< YInf + C ->
4609 kill(MState)
4610 ; true
4611 ) },
4612 fd_put(Y, YD2, YPs1)
4613 ; []
4614 )
4615 ; []
4616 )
4617 )
4618 ).
4619
4620run_propagator(scalar_product_neq(Cs0,Vs0,P0), MState) -->
4621 { coeffs_variables_const(Cs0, Vs0, Cs, Vs, 0, I),
4622 P is P0 - I,
4623 ( Vs = [] -> kill(MState), P =\= 0
4624 ; Vs = [V], Cs = [C] ->
4625 kill(MState),
4626 ( C =:= 1 -> neq_num(V, P)
4627 ; C*V #\= P
4628 )
4629 ; Cs == [1,-1] -> kill(MState), Vs = [A,B], x_neq_y_plus_z(A, B, P)
4630 ; Cs == [-1,1] -> kill(MState), Vs = [A,B], x_neq_y_plus_z(B, A, P)
4631 ; P =:= 0, Cs = [1,1,-1] ->
4632 kill(MState), Vs = [A,B,C], x_neq_y_plus_z(C, A, B)
4633 ; P =:= 0, Cs = [1,-1,1] ->
4634 kill(MState), Vs = [A,B,C], x_neq_y_plus_z(B, A, C)
4635 ; P =:= 0, Cs = [-1,1,1] ->
4636 kill(MState), Vs = [A,B,C], x_neq_y_plus_z(A, B, C)
4637 ; true
4638 ) }.
4639
4640run_propagator(scalar_product_leq(Cs0,Vs0,P0), MState) -->
4641 { coeffs_variables_const(Cs0, Vs0, Cs, Vs, 0, I),
4642 P is P0 - I,
4643 ( Vs = [] -> kill(MState), P >= 0
4644 ; duophrase(sum_finite_domains(Cs, Vs, 0, 0, Inf, Sup), Infs, Sups),
4645 D1 is P - Inf,
4646 disable_queue,
4647 ( Infs == [], Sups == [] ->
4648 Inf =< P,
4649 ( Sup =< P -> kill(MState)
4650 ; remove_dist_upper_leq(Cs, Vs, D1)
4651 )
4652 ; Infs == [] -> Inf =< P, remove_dist_upper(Sups, D1)
4653 ; Infs = [_] -> remove_upper(Infs, D1)
4654 ; true
4655 ),
4656 enable_queue
4657 ) }.
4658
4659run_propagator(scalar_product_eq(Cs0,Vs0,P0), MState) -->
4660 { coeffs_variables_const(Cs0, Vs0, Cs, Vs, 0, I),
4661 P is P0 - I,
4662 ( Vs = [] -> kill(MState), P =:= 0
4663 ; Vs = [V], Cs = [C] -> kill(MState), P mod C =:= 0, V is P // C
4664 ; Cs == [1,1] -> kill(MState), Vs = [A,B], A + B #= P
4665 ; Cs == [1,-1] -> kill(MState), Vs = [A,B], A #= P + B
4666 ; Cs == [-1,1] -> kill(MState), Vs = [A,B], B #= P + A
4667 ; Cs == [-1,-1] -> kill(MState), Vs = [A,B], P1 is -P, A + B #= P1
4668 ; P =:= 0, Cs == [1,1,-1] -> kill(MState), Vs = [A,B,C], A + B #= C
4669 ; P =:= 0, Cs == [1,-1,1] -> kill(MState), Vs = [A,B,C], A + C #= B
4670 ; P =:= 0, Cs == [-1,1,1] -> kill(MState), Vs = [A,B,C], B + C #= A
4671 ; duophrase(sum_finite_domains(Cs, Vs, 0, 0, Inf, Sup), Infs, Sups),
4672 % nl, writeln(Infs-Sups-Inf-Sup),
4673 D1 is P - Inf,
4674 D2 is Sup - P,
4675 disable_queue,
4676 ( Infs == [], Sups == [] ->
4677 between(Inf, Sup, P),
4678 remove_dist_upper_lower(Cs, Vs, D1, D2)
4679 ; Sups = [] -> P =< Sup, remove_dist_lower(Infs, D2)
4680 ; Infs = [] -> Inf =< P, remove_dist_upper(Sups, D1)
4681 ; Sups = [_], Infs = [_] ->
4682 remove_lower(Sups, D2),
4683 remove_upper(Infs, D1)
4684 ; Infs = [_] -> remove_upper(Infs, D1)
4685 ; Sups = [_] -> remove_lower(Sups, D2)
4686 ; true
4687 ),
4688 enable_queue
4689 ) }.
4690
4691% X + Y = Z
4692run_propagator(pplus(X,Y,Z), MState) -->
4693 ( nonvar(X) ->
4694 ( X =:= 0 -> kill(MState), Y = Z
4695 ; Y == Z -> kill(MState), X =:= 0
4696 ; nonvar(Y) -> kill(MState), Z is X + Y
4697 ; nonvar(Z) -> kill(MState), Y is Z - X
4698 ; { fd_get(Z, ZD, ZPs),
4699 fd_get(Y, YD, _),
4700 domain_shift(YD, X, Shifted_YD),
4701 domains_intersection(ZD, Shifted_YD, ZD1) },
4702 fd_put(Z, ZD1, ZPs),
4703 ( { fd_get(Y, YD1, YPs) } ->
4704 O is -X,
4705 { domain_shift(ZD1, O, YD2),
4706 domains_intersection(YD1, YD2, YD3) },
4707 fd_put(Y, YD3, YPs)
4708 ; []
4709 )
4710 )
4711 ; nonvar(Y) -> run_propagator(pplus(Y,X,Z), MState)
4712 ; nonvar(Z) ->
4713 ( X == Y -> kill(MState), { even(Z), X is Z // 2 }
4714 ; { fd_get(X, XD, _),
4715 fd_get(Y, YD, YPs),
4716 domain_negate(XD, XDN),
4717 domain_shift(XDN, Z, YD1),
4718 domains_intersection(YD, YD1, YD2) },
4719 fd_put(Y, YD2, YPs),
4720 ( { fd_get(X, XD1, XPs) } ->
4721 { domain_negate(YD2, YD2N),
4722 domain_shift(YD2N, Z, XD2),
4723 domains_intersection(XD1, XD2, XD3) },
4724 fd_put(X, XD3, XPs)
4725 ; []
4726 )
4727 )
4728 ; ( X == Y -> { kill(MState), 2*X #= Z }
4729 ; X == Z -> kill(MState), Y = 0
4730 ; Y == Z -> kill(MState), X = 0
4731 ; { fd_get(X, XD, XL, XU, XPs),
4732 fd_get(Y, _, YL, YU, _),
4733 fd_get(Z, _, ZL, ZU, _),
4734 NXL cis max(XL, ZL-YU),
4735 NXU cis min(XU, ZU-YL) },
4736 update_bounds(X, XD, XPs, XL, XU, NXL, NXU),
4737 ( { fd_get(Y, YD2, YL2, YU2, YPs2) } ->
4738 { NYL cis max(YL2, ZL-NXU),
4739 NYU cis min(YU2, ZU-NXL) },
4740 update_bounds(Y, YD2, YPs2, YL2, YU2, NYL, NYU)
4741 ; NYL = n(Y), NYU = n(Y)
4742 ),
4743 ( { fd_get(Z, ZD2, ZL2, ZU2, ZPs2) } ->
4744 { NZL cis max(ZL2,NXL+NYL),
4745 NZU cis min(ZU2,NXU+NYU) },
4746 update_bounds(Z, ZD2, ZPs2, ZL2, ZU2, NZL, NZU)
4747 ; []
4748 )
4749 )
4750 ).
4751
4752%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4753
4754run_propagator(ptimes(X,Y,Z), MState) -->
4755 ( nonvar(X) ->
4756 ( nonvar(Y) -> kill(MState), Z is X * Y
4757 ; X =:= 0 -> kill(MState), Z = 0
4758 ; X =:= 1 -> kill(MState), Z = Y
4759 ; nonvar(Z) -> kill(MState), 0 =:= Z mod X, Y is Z // X
4760 ; ( Y == Z -> kill(MState), Y = 0
4761 ; { fd_get(Y, YD, _),
4762 fd_get(Z, ZD, ZPs),
4763 domain_expand(YD, X, Scaled_YD),
4764 domains_intersection(ZD, Scaled_YD, ZD1) },
4765 fd_put(Z, ZD1, ZPs),
4766 ( { fd_get(Y, YDom2, YPs2) } ->
4767 { domain_contract(ZD1, X, Contract),
4768 domains_intersection(YDom2, Contract, NYDom) },
4769 fd_put(Y, NYDom, YPs2)
4770 ; kill(MState), Z is X * Y
4771 )
4772 )
4773 )
4774 ; nonvar(Y) -> run_propagator(ptimes(Y,X,Z), MState)
4775 ; nonvar(Z) ->
4776 ( X == Y ->
4777 kill(MState),
4778 { integer_kth_root(Z, 2, R),
4779 NR is -R,
4780 X in NR \/ R }
4781 ; { fd_get(X, XD, XL, XU, XPs),
4782 fd_get(Y, YD, YL, YU, _),
4783 min_max_factor(n(Z), n(Z), YL, YU, XL, XU, NXL, NXU) },
4784 update_bounds(X, XD, XPs, XL, XU, NXL, NXU),
4785 ( { fd_get(Y, YD2, YL2, YU2, YPs2) } ->
4786 { min_max_factor(n(Z), n(Z), NXL, NXU, YL2, YU2, NYL, NYU) },
4787 update_bounds(Y, YD2, YPs2, YL2, YU2, NYL, NYU)
4788 ; ( Y =\= 0 -> 0 =:= Z mod Y, kill(MState), X is Z // Y
4789 ; kill(MState), Z = 0
4790 )
4791 ),
4792 ( Z =:= 0 ->
4793 ( { \+ domain_contains(XD, 0) } -> kill(MState), Y = 0
4794 ; { \+ domain_contains(YD, 0) } -> kill(MState), X = 0
4795 ; []
4796 )
4797 ; neq_num(X, 0), neq_num(Y, 0)
4798 )
4799 )
4800 ; ( X == Y -> kill(MState), { X^2 #= Z }
4801 ; { fd_get(X, XD, XL, XU, XPs),
4802 fd_get(Y, _, YL, YU, _),
4803 fd_get(Z, ZD, ZL, ZU, _) },
4804 ( { Y == Z, \+ domain_contains(ZD, 0) } -> kill(MState), X = 1
4805 ; { X == Z, \+ domain_contains(ZD, 0) } -> kill(MState), Y = 1
4806 ; { min_max_factor(ZL, ZU, YL, YU, XL, XU, NXL, NXU) },
4807 update_bounds(X, XD, XPs, XL, XU, NXL, NXU),
4808 ( { fd_get(Y, YD2, YL2, YU2, YPs2) } ->
4809 { min_max_factor(ZL, ZU, NXL, NXU, YL2, YU2, NYL, NYU) },
4810 update_bounds(Y, YD2, YPs2, YL2, YU2, NYL, NYU)
4811 ; NYL = n(Y), NYU = n(Y)
4812 ),
4813 ( { fd_get(Z, ZD2, ZL2, ZU2, ZPs2) } ->
4814 { min_product(NXL, NXU, NYL, NYU, NZL),
4815 max_product(NXL, NXU, NYL, NYU, NZU) },
4816 ( { NZL cis_leq ZL2, NZU cis_geq ZU2 } -> ZD3 = ZD2
4817 ; { domains_intersection(ZD2, from_to(NZL,NZU), ZD3) },
4818 fd_put(Z, ZD3, ZPs2)
4819 ),
4820 ( { domain_contains(ZD3, 0) } -> []
4821 ; neq_num(X, 0), neq_num(Y, 0)
4822 )
4823 ; []
4824 )
4825 )
4826 )
4827 ).
4828
4829%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4830
4831% X div Y = Z
4832run_propagator(pdiv(X,Y,Z), MState) -->
4833 { kill(MState), Z #= (X-(X mod Y)) // Y }.
4834
4835% X rdiv Y = Z
4836run_propagator(prdiv(X,Y,Z), MState) -->
4837 { kill(MState), Z*Y #= X }.
4838
4839
4840% X // Y = Z (round towards zero)
4841run_propagator(ptzdiv(X,Y,Z), MState) -->
4842 ( nonvar(X) ->
4843 ( nonvar(Y) -> kill(MState), Y =\= 0, Z is X // Y
4844 ; { fd_get(Y, YD, YL, YU, YPs) },
4845 ( nonvar(Z) ->
4846 ( Z =:= 0 ->
4847 NYL is -abs(X) - 1,
4848 NYU is abs(X) + 1,
4849 { domains_intersection(YD, split(0, from_to(inf,n(NYL)),
4850 from_to(n(NYU), sup)),
4851 NYD) },
4852 fd_put(Y, NYD, YPs)
4853 ; ( sign(X) =:= sign(Z) ->
4854 { NYL cis max(n(X) // (n(Z)+sign(n(Z))) + n(1), YL),
4855 NYU cis min(n(X) // n(Z), YU) }
4856 ; { NYL cis max(n(X) // n(Z), YL),
4857 NYU cis min(n(X) // (n(Z)+sign(n(Z))) - n(1), YU) }
4858 ),
4859 update_bounds(Y, YD, YPs, YL, YU, NYL, NYU)
4860 )
4861 ; { fd_get(Z, ZD, ZL, ZU, ZPs),
4862 ( X >= 0, ( YL cis_gt n(0) ; YU cis_lt n(0) )->
4863 NZL cis max(n(X)//YU, ZL),
4864 NZU cis min(n(X)//YL, ZU)
4865 ; X < 0, ( YL cis_gt n(0) ; YU cis_lt n(0) ) ->
4866 NZL cis max(n(X)//YL, ZL),
4867 NZU cis min(n(X)//YU, ZU)
4868 ; % TODO: more stringent bounds, cover Y
4869 NZL cis max(-abs(n(X)), ZL),
4870 NZU cis min(abs(n(X)), ZU)
4871 ) },
4872 update_bounds(Z, ZD, ZPs, ZL, ZU, NZL, NZU),
4873 ( { X >= 0, NZL cis_gt n(0), fd_get(Y, YD1, YPs1) } ->
4874 { NYL cis n(X) // (NZU + n(1)) + n(1),
4875 NYU cis n(X) // NZL,
4876 domains_intersection(YD1, from_to(NYL, NYU), NYD1) },
4877 fd_put(Y, NYD1, YPs1)
4878 ; true
4879 )
4880 )
4881 )
4882 ; nonvar(Y) ->
4883 Y =\= 0,
4884 ( Y =:= 1 -> kill(MState), X = Z
4885 ; Y =:= -1 -> kill(MState), { Z #= -X }
4886 ; { fd_get(X, XD, XL, XU, XPs) },
4887 ( nonvar(Z) ->
4888 kill(MState),
4889 ( sign(Z) =:= sign(Y) ->
4890 { NXL cis max(n(Z)*n(Y), XL),
4891 NXU cis min((abs(n(Z))+n(1))*abs(n(Y))-n(1), XU) }
4892 ; Z =:= 0 ->
4893 { NXL cis max(-abs(n(Y)) + n(1), XL),
4894 NXU cis min(abs(n(Y)) - n(1), XU) }
4895 ; { NXL cis max((n(Z)+sign(n(Z)))*n(Y)+n(1), XL),
4896 NXU cis min(n(Z)*n(Y), XU) }
4897 ),
4898 update_bounds(X, XD, XPs, XL, XU, NXL, NXU)
4899 ; { fd_get(Z, ZD, ZPs),
4900 domain_contract_less(XD, Y, Contracted),
4901 domains_intersection(ZD, Contracted, NZD) },
4902 fd_put(Z, NZD, ZPs),
4903 ( { fd_get(X, XD2, XPs2) } ->
4904 { domain_expand_more(NZD, Y, Expanded),
4905 domains_intersection(XD2, Expanded, NXD2) },
4906 fd_put(X, NXD2, XPs2)
4907 ; true
4908 )
4909 )
4910 )
4911 ; nonvar(Z) ->
4912 { fd_get(X, XD, XL, XU, XPs),
4913 fd_get(Y, _, YL, YU, _),
4914 ( YL cis_geq n(0), XL cis_geq n(0) ->
4915 NXL cis max(YL*n(Z), XL),
4916 NXU cis min(YU*(n(Z)+n(1))-n(1), XU)
4917 ; %TODO: cover more cases
4918 NXL = XL, NXU = XU
4919 ) },
4920 update_bounds(X, XD, XPs, XL, XU, NXL, NXU)
4921 ; ( X == Y -> kill(MState), Z = 1
4922 ; { fd_get(X, _, XL, XU, _),
4923 fd_get(Y, _, YL, _, _),
4924 fd_get(Z, ZD, ZPs),
4925 NZU cis max(abs(XL), XU),
4926 NZL cis -NZU,
4927 domains_intersection(ZD, from_to(NZL,NZU), NZD0),
4928 ( XL cis_geq n(0), YL cis_geq n(0) ->
4929 domain_remove_smaller_than(NZD0, 0, NZD1)
4930 ; % TODO: cover more cases
4931 NZD1 = NZD0
4932 ) },
4933 fd_put(Z, NZD1, ZPs)
4934 )
4935 ).
4936
4937
4938%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4939%% % Z = X mod Y
4940
4941run_propagator(pmod(X,Y,Z), MState) -->
4942 ( Y == 0 -> { false }
4943 ; Y == Z -> { false }
4944 % ; nonvar(Y), Z == X -> true
4945 ; X == Y -> kill(MState), queue_goal(Z = 0)
4946 ; true
4947 ),
4948 ( nonvar(X), nonvar(Y) ->
4949 kill(MState),
4950 Z is X mod Y
4951 ; nonvar(Y), nonvar(Z) ->
4952 ( Y > 0 -> Z >= 0, Z < Y
4953 ; Y < 0 -> Z =< 0, Z > Y
4954 ),
4955 ( { fd_get(X, _, n(XL), _, _) } ->
4956 ( (XL - Z) mod Y =\= 0 ->
4957 XMin is Z + Y * ((XL - Z) div Y + 1)
4958 ; XMin is XL
4959 ),
4960 { fd_get(X, XD0, XPs),
4961 domain_remove_smaller_than(XD0, XMin, XD2) },
4962 fd_put(X, XD2, XPs)
4963 % queue_goal(X #>= XMin)
4964 ; true
4965 ),
4966 ( { fd_get(X, _, _, n(XU), _) } ->
4967 XMax is Z + Y * ((XU - Z) div Y),
4968 { fd_get(X, XD1, XPs),
4969 domain_remove_greater_than(XD1, XMax, XD3) },
4970 fd_put(X, XD3, XPs)
4971 % queue_goal(X #=< XMax)
4972 ; true
4973 )
4974 % kill(MState),
4975 % queue_goal(X #= Z + Y * _) % Add a variable to be efficient.
4976 ; nonvar(Z), nonvar(X) ->
4977 ( Z > 0 ->
4978 ( X < 0 -> true
4979 ; X >= Z
4980 )
4981 ; Z < 0 ->
4982 ( X > 0 -> true
4983 ; X =< Z
4984 )
4985 ; Z =:= 0 % Multiple solutions so do nothing special.
4986 ),
4987 ( { fd_get(Y, _, _, n(YU), _),
4988 YU < X, X =< 0 } -> kill(MState), Z =:= X
4989 ; { fd_get(Y, _, n(YL), _, _),
4990 YL > X, X >= 0 } -> kill(MState), Z =:= X
4991 ; ( Z > 0 ->
4992 { fd_get(Y, YD, YPs),
4993 YMin is Z + 1,
4994 domain_remove_smaller_than(YD, YMin, YD1) },
4995 fd_put(Y, YD1, YPs)
4996 % queue_goal(Y #> Z)
4997 ; Z < 0 ->
4998 { fd_get(Y, YD, YPs),
4999 YMax is Z - 1,
5000 domain_remove_greater_than(YD, YMax, YD1) },
5001 fd_put(Y, YD1, YPs)
5002 % queue_goal(Y #< Z)
5003 ; true
5004 )
5005 )
5006 ; run_propagator(pmodz(X,Y,Z), MState),
5007 run_propagator(pmody(X,Y,Z), MState),
5008 true
5009 ).
5010
5011run_propagator(pmodz(X,Y,Z), MState) -->
5012 ( nonvar(Z) -> true % Nothing to do.
5013 ; nonvar(X) ->
5014 ( X =:= 0 -> kill(MState), queue_goal(Z = X)
5015 ; ( X > 0 ->
5016 ( { fd_get(Y, _, n(YL), _, _), YL > X } ->
5017 kill(MState),
5018 queue_goal(Z = X)
5019 ; { fd_get(Z, ZD0, ZPs),
5020 domain_remove_greater_than(ZD0, X, ZD2) },
5021 fd_put(Z, ZD2, ZPs)
5022 % queue_goal(Z #=< X)
5023 )
5024 ; X < 0 ->
5025 ( { fd_get(Y, _, _, n(YU), _), YU < X } ->
5026 kill(MState),
5027 queue_goal(Z = X)
5028 ; { fd_get(Z, ZD0, ZPs),
5029 domain_remove_smaller_than(ZD0, X, ZD2) },
5030 fd_put(Z, ZD2, ZPs)
5031 % queue_goal(Z #>= X)
5032 )
5033 ),
5034 ( { fd_get(Y, _, n(YL), n(YU), _), YL > 0 } ->
5035 ZMax is YU - 1,
5036 { fd_get(Z, ZD1, ZPs),
5037 domain_remove_smaller_than(ZD1, 0, ZD3),
5038 domain_remove_greater_than(ZD3, ZMax, ZD5) },
5039 fd_put(Z, ZD5, ZPs)
5040 % queue_goal(Z in 0..ZMax)
5041 ; { fd_get(Y, _, n(YL), n(YU), _), YU < 0 } ->
5042 ZMin is YL + 1,
5043 { fd_get(Z, ZD1, ZPs),
5044 domain_remove_greater_than(ZD1, 0, ZD3),
5045 domain_remove_smaller_than(ZD3, ZMin, ZD5) },
5046 fd_put(Z, ZD5, ZPs)
5047 % queue_goal(Z in ZMin..0)
5048 ; true
5049 )
5050 )
5051 ; nonvar(Y) ->
5052 ( abs(Y) =:= 1 -> kill(MState), queue_goal(Z = 0)
5053 ; Y < 0 ->
5054 ( { fd_get(X, _, n(XL), n(XU), _), XU =< 0, Y < XL } ->
5055 kill(MState),
5056 queue_goal(Z = X)
5057 ; ZMin is Y + 1,
5058 { fd_get(Z, ZD1, ZPs),
5059 domain_remove_greater_than(ZD1, 0, ZD3),
5060 domain_remove_smaller_than(ZD3, ZMin, ZD5) },
5061 fd_put(Z, ZD5, ZPs)
5062 % queue_goal(Z in ZMin..0)
5063 )
5064 ; Y > 0 ->
5065 ( { fd_get(X, _, n(XL), n(XU), _), XL >= 0, Y > XU } ->
5066 kill(MState),
5067 queue_goal(Z = X)
5068 ; ZMax is Y - 1,
5069 { fd_get(Z, ZD1, ZPs),
5070 domain_remove_smaller_than(ZD1, 0, ZD3),
5071 domain_remove_greater_than(ZD3, ZMax, ZD5) },
5072 fd_put(Z, ZD5, ZPs)
5073 % queue_goal(Z in 0..ZMax)
5074 )
5075 )
5076 ; ( { fd_get(X, _, n(XL), n(XU), _), XL >= 0,
5077 fd_get(Y, _, n(YL), _, _), XU < YL } ->
5078 kill(MState),
5079 queue_goal(Z = X)
5080 ; { fd_get(X, _, n(XL), n(XU), _), XU =< 0,
5081 fd_get(Y, _, _, n(YU), _), XL > YU } ->
5082 kill(MState),
5083 queue_goal(Z = X)
5084 ; ( { fd_get(X, _, n(XL), n(XU), _), XL >= 0 } ->
5085 { fd_get(Z, ZD0, ZPs),
5086 domain_remove_greater_than(ZD0, XU, ZD2) },
5087 fd_put(Z, ZD2, ZPs)
5088 % queue_goal(Z #=< XU)
5089 ; { fd_get(X, _, n(XL), n(XU), _), XU =< 0 } ->
5090 { fd_get(Z, ZD0, ZPs),
5091 domain_remove_smaller_than(ZD0, XL, ZD2) },
5092 fd_put(Z, ZD2, ZPs)
5093 % queue_goal(Z #>= XL)
5094 ; true
5095 ),
5096 ( { fd_get(Y, _, n(YL), n(YU), _), YL > 0 } ->
5097 ZMax is YU - 1,
5098 { fd_get(Z, ZD1, ZPs),
5099 domain_remove_smaller_than(ZD1, 0, ZD3),
5100 domain_remove_greater_than(ZD3, ZMax, ZD5) },
5101 fd_put(Z, ZD5, ZPs)
5102 % queue_goal(Z in 0..ZMax)
5103 ; { fd_get(Y, _, n(YL), n(YU), _), YU < 0 } ->
5104 ZMin is YL + 1,
5105 { fd_get(Z, ZD1, ZPs),
5106 domain_remove_greater_than(ZD1, 0, ZD3),
5107 domain_remove_smaller_than(ZD3, ZMin, ZD5) },
5108 fd_put(Z, ZD5, ZPs)
5109 % queue_goal(Z in ZMin..0)
5110 ; { fd_get(Y, _, n(YL), n(YU), _) } ->
5111 ZMin is YL + 1,
5112 ZMax is YU - 1,
5113 { fd_get(Z, ZD1, ZPs),
5114 domain_remove_greater_than(ZD1, ZMax, ZD3),
5115 domain_remove_smaller_than(ZD3, ZMin, ZD5) },
5116 fd_put(Z, ZD5, ZPs)
5117 % queue_goal(Z in ZMin..ZMax)
5118 %/* This doesn't work very well.
5119 ; { fd_get(Y, _, _, n(YU), _), YU > 0 } ->
5120 { fd_get(Z, ZD1, ZPs),
5121 ZMax is YU - 1,
5122 domain_remove_greater_than(ZD1, ZMax, ZD3) },
5123 fd_put(Z, ZD3, ZPs)
5124 % queue_goal(Z #< YU)
5125 ; { fd_get(Y, _, n(YL), _, _), YL < 0 } ->
5126 { fd_get(Z, ZD1, ZPs),
5127 ZMin is YL + 1,
5128 domain_remove_smaller_than(ZD1, ZMin, ZD3) },
5129 fd_put(Z, ZD3, ZPs)
5130 % queue_goal(Z #> YL)
5131 % * /
5132 ; true
5133 )
5134 )
5135 ).
5136
5137run_propagator(pmody(X,Y,Z), MState) -->
5138 ( nonvar(Y) -> true % Nothing to do.
5139 % ; nonvar(X) -> true
5140 ; nonvar(Z) ->
5141 ( Z > 0 -> % queue_goal(Y #> Z)
5142 { fd_get(Y, YD, YPs),
5143 YMin is Z + 1,
5144 domain_remove_smaller_than(YD, YMin, YD1) },
5145 fd_put(Y, YD1, YPs)
5146 ; Z < 0 -> % queue_goal(Y #< Z)
5147 { fd_get(Y, YD, YPs),
5148 YMax is Z - 1,
5149 domain_remove_greater_than(YD, YMax, YD1) },
5150 fd_put(Y, YD1, YPs)
5151 ; Z =:= 0 -> kill(MState), queue_goal(X / Y #= _)
5152 )
5153 ; ( { fd_get(Z, _, n(ZL), _, _), ZL > 0 } ->
5154 { fd_get(Y, YD, YPs),
5155 YMin is ZL + 1,
5156 domain_remove_smaller_than(YD, YMin, YD1) },
5157 fd_put(Y, YD1, YPs)
5158 % queue_goal(Y #> ZL)
5159 ; { fd_get(Z, _, _, n(ZU), _), ZU < 0 } ->
5160 { fd_get(Y, YD, YPs),
5161 YMax is ZU - 1,
5162 domain_remove_greater_than(YD, YMax, YD1) },
5163 fd_put(Y, YD1, YPs)
5164 % queue_goal(Y #< ZU)
5165 ; true
5166 )
5167 ).
5168
5169
5170%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5171%% % Z = X rem Y
5172
5173run_propagator(prem(X,Y,Z), MState) -->
5174 ( nonvar(X) ->
5175 ( nonvar(Y) -> kill(MState), Y =\= 0, Z is X rem Y
5176 ; U is abs(X),
5177 { fd_get(Y, YD, _) },
5178 ( X >=0, { domain_infimum(YD, n(Min)), Min >= 0 } -> L = 0
5179 ; L is -U
5180 ),
5181 { Z in L..U }
5182 )
5183 ; nonvar(Y) ->
5184 Y =\= 0,
5185 ( abs(Y) =:= 1 -> kill(MState), Z = 0
5186 ; var(Z) ->
5187 YP is abs(Y) - 1,
5188 YN is -YP,
5189 ( Y > 0, { fd_get(X, _, n(XL), n(XU), _) } ->
5190 ( abs(XL) < Y, XU < Y -> kill(MState), Z = X, ZL = XL
5191 ; XL < 0, abs(XL) < Y -> ZL = XL
5192 ; XL >= 0 -> ZL = 0
5193 ; ZL = YN
5194 ),
5195 ( XU > 0, XU < Y -> ZU = XU
5196 ; XU < 0 -> ZU = 0
5197 ; ZU = YP
5198 )
5199 ; ZL = YN, ZU = YP
5200 ),
5201 ( { fd_get(Z, ZD, ZPs) } ->
5202 { domains_intersection(ZD, from_to(n(ZL), n(ZU)), ZD1) },
5203 fd_put(Z, ZD1, ZPs)
5204 ; ZD1 = from_to(n(Z), n(Z))
5205 ),
5206 ( { fd_get(X, XD, _), domain_infimum(XD, n(Min)) } ->
5207 Z1 is Min rem Y,
5208 ( { domain_contains(ZD1, Z1) } -> true
5209 ; neq_num(X, Min)
5210 )
5211 ; true
5212 ),
5213 ( { fd_get(X, XD1, _), domain_supremum(XD1, n(Max)) } ->
5214 Z2 is Max rem Y,
5215 ( { domain_contains(ZD1, Z2) } -> true
5216 ; neq_num(X, Max)
5217 )
5218 ; true
5219 )
5220 ; { fd_get(X, XD1, XPs1) },
5221 % if possible, propagate at the boundaries
5222 ( { domain_infimum(XD1, n(Min)) } ->
5223 ( Min rem Y =:= Z -> true
5224 ; Y > 0, Min > 0 ->
5225 Next is ((Min - Z + Y - 1) div Y)*Y + Z,
5226 { domain_remove_smaller_than(XD1, Next, XD2) },
5227 fd_put(X, XD2, XPs1)
5228 ; % TODO: bigger steps in other cases as well
5229 neq_num(X, Min)
5230 )
5231 ; true
5232 ),
5233 ( { fd_get(X, XD3, XPs3) } ->
5234 ( { domain_supremum(XD3, n(Max)) } ->
5235 ( Max rem Y =:= Z -> true
5236 ; Y > 0, Max > 0 ->
5237 Prev is ((Max - Z) div Y)*Y + Z,
5238 { domain_remove_greater_than(XD3, Prev, XD4) },
5239 fd_put(X, XD4, XPs3)
5240 ; % TODO: bigger steps in other cases as well
5241 neq_num(X, Max)
5242 )
5243 ; true
5244 )
5245 ; true
5246 )
5247 )
5248 ; X == Y -> kill(MState), Z = 0
5249 ; { fd_get(Z, ZD, ZPs) } ->
5250 { fd_get(Y, _, YInf, YSup, _),
5251 fd_get(X, _, XInf, XSup, _),
5252 M cis max(abs(YInf),YSup),
5253 ( XInf cis_geq n(0) -> Inf0 = n(0)
5254 ; Inf0 = XInf
5255 ),
5256 ( XSup cis_leq n(0) -> Sup0 = n(0)
5257 ; Sup0 = XSup
5258 ),
5259 NInf cis max(max(Inf0, -M + n(1)), min(XInf,-XSup)),
5260 NSup cis min(min(Sup0, M - n(1)), max(abs(XInf),XSup)),
5261 domains_intersection(ZD, from_to(NInf,NSup), ZD1) },
5262 fd_put(Z, ZD1, ZPs)
5263 ; true % TODO: propagate more
5264 ).
5265
5266%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5267% Z = max(X,Y)
5268
5269run_propagator(pmax(X,Y,Z), MState) -->
5270 ( nonvar(X) ->
5271 ( nonvar(Y) -> kill(MState), queue_goal(Z is max(X,Y))
5272 ; nonvar(Z) ->
5273 ( Z =:= X -> kill(MState), queue_goal(X #>= Y)
5274 ; Z > X -> queue_goal(Z = Y)
5275 ; { false } % Z < X
5276 )
5277 ; { fd_get(Y, _, YInf, YSup, _) },
5278 ( { YInf cis_gt n(X) } -> queue_goal(Z = Y)
5279 ; { YSup cis_lt n(X) } -> queue_goal(Z = X)
5280 ; YSup = n(M) ->
5281 { fd_get(Z, ZD, ZPs),
5282 domain_remove_greater_than(ZD, M, ZD1) },
5283 fd_put(Z, ZD1, ZPs)
5284 ; []
5285 )
5286 )
5287 ; nonvar(Y) -> run_propagator(pmax(Y,X,Z), MState)
5288 ; { fd_get(Z, ZD, ZPs) } ->
5289 { fd_get(X, _, XInf, XSup, _),
5290 fd_get(Y, _, YInf, YSup, _) },
5291 ( { YInf cis_gt YSup } -> kill(MState), queue_goal(Z = Y)
5292 ; { YSup cis_lt XInf } -> kill(MState), queue_goal(Z = X)
5293 ; { n(M) cis max(XSup, YSup) } ->
5294 { domain_remove_greater_than(ZD, M, ZD1) },
5295 fd_put(Z, ZD1, ZPs)
5296 ; []
5297 )
5298 ; []
5299 ).
5300
5301%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5302% Z = min(X,Y)
5303
5304run_propagator(pmin(X,Y,Z), MState) -->
5305 ( nonvar(X) ->
5306 ( nonvar(Y) -> kill(MState), Z is min(X,Y)
5307 ; nonvar(Z) ->
5308 ( Z =:= X -> kill(MState), { X #=< Y }
5309 ; Z < X -> Z = Y
5310 ; { false } % Z > X
5311 )
5312 ; { fd_get(Y, _, YInf, YSup, _) },
5313 ( { YSup cis_lt n(X) } -> Z = Y
5314 ; { YInf cis_gt n(X) } -> Z = X
5315 ; YInf = n(M) ->
5316 { fd_get(Z, ZD, ZPs),
5317 domain_remove_smaller_than(ZD, M, ZD1) },
5318 fd_put(Z, ZD1, ZPs)
5319 ; []
5320 )
5321 )
5322 ; nonvar(Y) -> run_propagator(pmin(Y,X,Z), MState)
5323 ; { fd_get(Z, ZD, ZPs) } ->
5324 { fd_get(X, _, XInf, XSup, _),
5325 fd_get(Y, _, YInf, YSup, _) },
5326 ( { YSup cis_lt YInf } -> kill(MState), Z = Y
5327 ; { YInf cis_gt XSup } -> kill(MState), Z = X
5328 ; { n(M) cis min(XInf, YInf) } ->
5329 { domain_remove_smaller_than(ZD, M, ZD1) },
5330 fd_put(Z, ZD1, ZPs)
5331 ; []
5332 )
5333 ; []
5334 ).
5335%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5336%% % Z = X ^ Y
5337
5338run_propagator(pexp(X,Y,Z), MState) -->
5339 ( X == 1 -> kill(MState), Z = 1
5340 ; X == 0 -> kill(MState), queue_goal((Z in 0..1, Y #>= 0, Z #<==> Y #= 0))
5341 ; Y == 0 -> kill(MState), Z = 1
5342 ; Y == 1 -> kill(MState), Z = X
5343 ; nonvar(X) ->
5344 ( nonvar(Y) ->
5345 ( Y >= 0 -> true ; X =:= -1 ),
5346 kill(MState),
5347 Z is X^Y
5348 ; nonvar(Z) ->
5349 ( Z > 1 ->
5350 abs(X) > 1,
5351 kill(MState),
5352 { integer_log_b(Z, X, 1, Y) }
5353 ; true
5354 )
5355 ; { fd_get(Y, _, YL, YU, _),
5356 fd_get(Z, ZD, ZPs) },
5357 ( { X > 0, YL cis_geq n(0) } ->
5358 { NZL cis n(X)^YL,
5359 NZU cis n(X)^YU,
5360 domains_intersection(ZD, from_to(NZL,NZU), NZD) },
5361 fd_put(Z, NZD, ZPs)
5362 ; true
5363 ),
5364 ( { X > 0,
5365 fd_get(Z, _, _, n(ZMax), _),
5366 ZMax > 0 } ->
5367 { floor_integer_log_b(ZMax, X, 1, YCeil) },
5368 queue_goal(Y in inf..YCeil)
5369 ; true
5370 )
5371 )
5372 ; nonvar(Z) ->
5373 ( nonvar(Y) ->
5374 { integer_kth_root(Z, Y, R) },
5375 kill(MState),
5376 ( { even(Y) } ->
5377 N is -R,
5378 { X in N \/ R }
5379 ; X = R
5380 )
5381 ; { fd_get(X, _, n(NXL), _, _), NXL > 1 } ->
5382 ( { Z > 1, between(NXL, Z, Exp), NXL^Exp > Z } ->
5383 Exp1 is Exp - 1,
5384 { fd_get(Y, YD, YPs),
5385 domains_intersection(YD, from_to(n(1),n(Exp1)), YD1) },
5386 fd_put(Y, YD1, YPs),
5387 ( { fd_get(X, XD, XPs) } ->
5388 { domain_infimum(YD1, n(YL)),
5389 integer_kth_root_leq(Z, YL, RU),
5390 domains_intersection(XD, from_to(n(NXL),n(RU)), XD1) },
5391 fd_put(X, XD1, XPs)
5392 ; true
5393 )
5394 ; true
5395 )
5396 ; true
5397 )
5398 ; nonvar(Y), Y > 0 ->
5399 ( { even(Y) } ->
5400 { geq(Z, 0) }
5401 ; true
5402 ),
5403 ( { fd_get(X, XD, XL, XU, _), fd_get(Z, ZD, ZL, ZU, ZPs) } ->
5404 ( { domain_contains(ZD, 0) } -> XD1 = XD
5405 ; { domain_remove(XD, 0, XD1) }
5406 ),
5407 ( { domain_contains(XD, 0) } -> ZD1 = ZD
5408 ; { domain_remove(ZD, 0, ZD1) }
5409 ),
5410 ( { even(Y) } ->
5411 ( { XL cis_geq n(0) } ->
5412 { NZL cis XL^n(Y) }
5413 ; { XU cis_leq n(0) } ->
5414 { NZL cis XU^n(Y) }
5415 ; NZL = n(0)
5416 ),
5417 { NZU cis max(abs(XL),abs(XU))^n(Y),
5418 domains_intersection(ZD1, from_to(NZL,NZU), ZD2) }
5419 ; ( { finite(XL) } ->
5420 { NZL cis XL^n(Y),
5421 NZU cis XU^n(Y) },
5422 { domains_intersection(ZD1, from_to(NZL,NZU), ZD2) }
5423 ; ZD2 = ZD1
5424 )
5425 ),
5426 fd_put(Z, ZD2, ZPs),
5427 { ( even(Y), ZU = n(Num) ->
5428 integer_kth_root_leq(Num, Y, RU),
5429 ( XL cis_geq n(0), ZL = n(Num1) ->
5430 integer_kth_root_leq(Num1, Y, RL0),
5431 ( RL0^Y < Num1 -> RL is RL0 + 1
5432 ; RL = RL0
5433 )
5434 ; RL is -RU
5435 ),
5436 RL =< RU,
5437 NXD = from_to(n(RL),n(RU))
5438 ; odd(Y), ZL cis_geq n(0), ZU = n(Num) ->
5439 integer_kth_root_leq(Num, Y, RU),
5440 ZL = n(Num1),
5441 integer_kth_root_leq(Num1, Y, RL0),
5442 ( RL0^Y < Num1 -> RL is RL0 + 1
5443 ; RL = RL0
5444 ),
5445 RL =< RU,
5446 NXD = from_to(n(RL),n(RU))
5447 ; NXD = XD1 % TODO: propagate more
5448 ) },
5449 ( { fd_get(X, XD2, XPs) } ->
5450 { domains_intersection(XD2, XD1, XD3),
5451 domains_intersection(XD3, NXD, XD4) },
5452 fd_put(X, XD4, XPs)
5453 ; true
5454 )
5455 ; true
5456 )
5457 ; { fd_get(X, _, XL, _, _),
5458 XL cis_gt n(0),
5459 fd_get(Y, _, YL, _, _),
5460 YL cis_gt n(0),
5461 fd_get(Z, ZD, ZPs) } ->
5462 { n(NZL) cis XL^YL,
5463 domain_remove_smaller_than(ZD, NZL, ZD1) },
5464 fd_put(Z, ZD1, ZPs)
5465 ; true
5466 ).
5467%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5468%% % Z = X xor Y
5469
5470run_propagator(pxor(X,Y,Z), MState) -->
5471 ( nonvar(X), nonvar(Y) ->
5472 kill(MState),
5473 Z is xor(X, Y)
5474 ; nonvar(Y), nonvar(Z) ->
5475 kill(MState),
5476 X is xor(Y, Z)
5477 ; nonvar(Z), nonvar(X) ->
5478 kill(MState),
5479 Y is xor(Z, X)
5480 ; X == Y ->
5481 kill(MState),
5482 queue_goal(Z = 0)
5483 ; Y == Z ->
5484 kill(MState),
5485 queue_goal(X = 0)
5486 ; Z == X ->
5487 kill(MState),
5488 queue_goal(Y = 0)
5489 ; X == 0 ->
5490 kill(MState),
5491 queue_goal(Y = Z)
5492 ; Y == 0 ->
5493 kill(MState),
5494 queue_goal(Z = X)
5495 ; Z == 0 ->
5496 kill(MState),
5497 queue_goal(X = Y)
5498 ; true
5499 ).
5500
5501%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5502run_propagator(pzcompare(Order, A, B), MState) -->
5503 ( A == B -> kill(MState), Order = (=)
5504 ; ( nonvar(A) ->
5505 ( nonvar(B) ->
5506 kill(MState),
5507 ( A > B -> Order = (>)
5508 ; Order = (<)
5509 )
5510 ; { fd_get(B, _, BL, BU, _) },
5511 ( { BL cis_gt n(A) } -> kill(MState), Order = (<)
5512 ; { BU cis_lt n(A) } -> kill(MState), Order = (>)
5513 ; []
5514 )
5515 )
5516 ; nonvar(B) ->
5517 { fd_get(A, _, AL, AU, _) },
5518 ( { AL cis_gt n(B) } -> kill(MState), Order = (>)
5519 ; { AU cis_lt n(B) } -> kill(MState), Order = (<)
5520 ; []
5521 )
5522 ; { fd_get(A, _, AL, AU, _),
5523 fd_get(B, _, BL, BU, _) },
5524 ( { AL cis_gt BU } -> kill(MState), Order = (>)
5525 ; { AU cis_lt BL } -> kill(MState), Order = (<)
5526 ; []
5527 )
5528 )
5529 ).
5530
5531%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5532
5533% reified constraints
5534
5535%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5536
5537run_propagator(reified_in(V,Dom,B), MState) -->
5538 ( integer(V) ->
5539 kill(MState),
5540 ( { domain_contains(Dom, V) } -> B = 1
5541 ; B = 0
5542 )
5543 ; B == 1 -> kill(MState), { domain(V, Dom) }
5544 ; B == 0 ->
5545 kill(MState), { domain_complement(Dom, C), domain(V, C) }
5546 ; { fd_get(V, VD, _) },
5547 ( { domains_intersection(VD, Dom, I) } ->
5548 ( I == VD -> kill(MState), B = 1
5549 ; []
5550 )
5551 ; kill(MState), B = 0
5552 )
5553 ).
5554
5555run_propagator(reified_tuple_in(Tuple, R, B), MState) -->
5556 { get_attr(R, clpz_relation, Relation) },
5557 ( B == 1 -> kill(MState), { tuples_in([Tuple], Relation) }
5558 ; ( ground(Tuple) ->
5559 kill(MState),
5560 ( { memberchk(Tuple, Relation) } -> B = 1
5561 ; B = 0
5562 )
5563 ; { relation_unifiable(Relation, Tuple, Us, _, _) },
5564 ( Us = [] -> kill(MState), B = 0
5565 ; []
5566 )
5567 )
5568 ).
5569
5570run_propagator(tuples_not_in(Tuples, Relation, B), MState) -->
5571 ( B == 0 ->
5572 kill(MState),
5573 { tuples_in_conjunction(Tuples, Relation, Conj),
5574 #\ Conj }
5575 ; []
5576 ).
5577
5578run_propagator(kill_reified_tuples(B, Ps, Bs), _) -->
5579 ( B == 0 ->
5580 { maplist(kill_entailed, Ps),
5581 phrase(as(Bs), As),
5582 maplist(kill_entailed, As) }
5583 ; []
5584 ).
5585
5586run_propagator(reified_fd(V,B), MState) -->
5587 ( { fd_inf(V, I), I \== inf, fd_sup(V, S), S \== sup } ->
5588 kill(MState),
5589 B = 1
5590 ; { B == 0 } ->
5591 ( { fd_inf(V, inf) } -> []
5592 ; { fd_sup(V, sup) } -> []
5593 ; { false }
5594 )
5595 ; []
5596 ).
5597
5598% The result of X/Y, X mod Y, and X rem Y is undefined iff Y is 0.
5599
5600run_propagator(pskeleton(X,Y,D,Skel,Z,_), MState) -->
5601 ( Y == 0 -> kill(MState), D = 0
5602 ; D == 1 ->
5603 kill(MState), neq_num(Y, 0), { skeleton([X,Y,Z], Skel) }
5604 ; integer(Y), Y =\= 0 ->
5605 kill(MState), D = 1, { skeleton([X,Y,Z], Skel) }
5606 ; { fd_get(Y, YD, _), \+ domain_contains(YD, 0) } ->
5607 kill(MState), D = 1, { skeleton([X,Y,Z], Skel) }
5608 ; []
5609 ).
5610
5611/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5612 Propagators for arithmetic functions that only propagate
5613 functionally. These are currently the bitwise operations.
5614- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5615
5616run_propagator(pfunction(Op,A,B,R), MState) -->
5617 ( integer(A), integer(B) ->
5618 kill(MState),
5619 Expr =.. [Op,A,B],
5620 R is Expr
5621 ; []
5622 ).
5623run_propagator(pfunction(Op,A,R), MState) -->
5624 ( integer(A) ->
5625 kill(MState),
5626 Expr =.. [Op,A],
5627 R is Expr
5628 ; []
5629 ).
5630
5631%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5632
5633run_propagator(reified_geq(DX,X,DY,Y,Ps,B), MState) -->
5634 ( DX == 0 -> kill(MState, Ps), B = 0
5635 ; DY == 0 -> kill(MState, Ps), B = 0
5636 ; B == 1 -> kill(MState), DX = 1, DY = 1, { geq(X, Y) }
5637 ; DX == 1, DY == 1 ->
5638 ( var(B) ->
5639 ( nonvar(X) ->
5640 ( nonvar(Y) ->
5641 kill(MState),
5642 ( X >= Y -> B = 1 ; B = 0 )
5643 ; { fd_get(Y, _, YL, YU, _) },
5644 ( { n(X) cis_geq YU } -> kill(MState, Ps), B = 1
5645 ; { n(X) cis_lt YL } -> kill(MState, Ps), B = 0
5646 ; []
5647 )
5648 )
5649 ; nonvar(Y) ->
5650 { fd_get(X, _, XL, XU, _) },
5651 ( { XL cis_geq n(Y) } -> kill(MState, Ps), B = 1
5652 ; { XU cis_lt n(Y) } -> kill(MState, Ps), B = 0
5653 ; []
5654 )
5655 ; X == Y -> kill(MState, Ps), B = 1
5656 ; { fd_get(X, _, XL, XU, _),
5657 fd_get(Y, _, YL, YU, _) },
5658 ( { XL cis_geq YU } -> kill(MState, Ps), B = 1
5659 ; { XU cis_lt YL } -> kill(MState, Ps), B = 0
5660 ; []
5661 )
5662 )
5663 ; B =:= 0 -> { kill(MState), X #< Y }
5664 ; []
5665 )
5666 ; []
5667 ).
5668
5669%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5670run_propagator(reified_eq(DX,X,DY,Y,Ps,B), MState) -->
5671 ( DX == 0 -> kill(MState, Ps), B = 0
5672 ; DY == 0 -> kill(MState, Ps), B = 0
5673 ; B == 1 -> kill(MState), DX = 1, DY = 1, X = Y
5674 ; DX == 1, DY == 1 ->
5675 ( var(B) ->
5676 ( nonvar(X) ->
5677 ( nonvar(Y) ->
5678 kill(MState),
5679 ( X =:= Y -> B = 1 ; B = 0)
5680 ; { fd_get(Y, YD, _) },
5681 ( { domain_contains(YD, X) } -> []
5682 ; kill(MState, Ps), B = 0
5683 )
5684 )
5685 ; nonvar(Y) ->
5686 run_propagator(reified_eq(DY,Y,DX,X,Ps,B), MState)
5687 ; X == Y -> kill(MState), B = 1
5688 ; { fd_get(X, _, XL, XU, _),
5689 fd_get(Y, _, YL, YU, _) },
5690 ( { XL cis_gt YU } -> kill(MState, Ps), B = 0
5691 ; { YL cis_gt XU } -> kill(MState, Ps), B = 0
5692 ; []
5693 )
5694 )
5695 ; B =:= 0 -> kill(MState), { X #\= Y }
5696 ; []
5697 )
5698 ; []
5699 ).
5700%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5701run_propagator(reified_neq(DX,X,DY,Y,Ps,B), MState) -->
5702 ( DX == 0 -> kill(MState, Ps), B = 0
5703 ; DY == 0 -> kill(MState, Ps), B = 0
5704 ; B == 1 -> { kill(MState), DX = 1, DY = 1, X #\= Y }
5705 ; DX == 1, DY == 1 ->
5706 ( var(B) ->
5707 ( nonvar(X) ->
5708 ( nonvar(Y) ->
5709 kill(MState),
5710 ( X =\= Y -> B = 1 ; B = 0)
5711 ; { fd_get(Y, YD, _) },
5712 ( { domain_contains(YD, X) } -> []
5713 ; kill(MState, Ps), B = 1
5714 )
5715 )
5716 ; nonvar(Y) ->
5717 run_propagator(reified_neq(DY,Y,DX,X,Ps,B), MState)
5718 ; X == Y -> kill(MState), B = 0
5719 ; { fd_get(X, _, XL, XU, _),
5720 fd_get(Y, _, YL, YU, _) },
5721 ( { XL cis_gt YU } -> kill(MState, Ps), B = 1
5722 ; { YL cis_gt XU } -> kill(MState, Ps), B = 1
5723 ; []
5724 )
5725 )
5726 ; B =:= 0 -> kill(MState), X = Y
5727 ; []
5728 )
5729 ; []
5730 ).
5731%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5732run_propagator(reified_and(X,Ps1,Y,Ps2,B), MState) -->
5733 ( nonvar(X) ->
5734 kill(MState),
5735 ( X =:= 0 -> { maplist(kill_entailed, Ps2), B = 0 }
5736 ; B = Y
5737 )
5738 ; nonvar(Y) -> run_propagator(reified_and(Y,Ps2,X,Ps1,B), MState)
5739 ; B == 1 -> kill(MState), X = 1, Y = 1
5740 ; []
5741 ).
5742
5743%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5744run_propagator(reified_or(X,Ps1,Y,Ps2,B), MState) -->
5745 ( nonvar(X) ->
5746 kill(MState),
5747 ( X =:= 1 -> { maplist(kill_entailed, Ps2), B = 1 }
5748 ; B = Y
5749 )
5750 ; nonvar(Y) -> run_propagator(reified_or(Y,Ps2,X,Ps1,B), MState)
5751 ; B == 0 -> kill(MState), X = 0, Y = 0
5752 ; []
5753 ).
5754
5755%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5756run_propagator(reified_not(X,Y), MState) -->
5757 ( X == 0 -> kill(MState), Y = 1
5758 ; X == 1 -> kill(MState), Y = 0
5759 ; Y == 0 -> kill(MState), X = 1
5760 ; Y == 1 -> kill(MState), X = 0
5761 ; []
5762 ).
5763
5764%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5765run_propagator(pimpl(X, Y, Ps), MState) -->
5766 ( nonvar(X) ->
5767 kill(MState),
5768 ( X =:= 1 -> Y = 1
5769 ; { maplist(kill_entailed, Ps) }
5770 )
5771 ; nonvar(Y) ->
5772 kill(MState),
5773 ( Y =:= 0 -> X = 0
5774 ; { maplist(kill_entailed, Ps) }
5775 )
5776 ; []
5777 ).
5778
5779%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5780%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5781
5782update_bounds(X, XD, XPs, XL, XU, NXL, NXU) -->
5783 ( NXL == XL, NXU == XU -> []
5784 ; { domains_intersection(XD, from_to(NXL, NXU), NXD) },
5785 fd_put(X, NXD, XPs)
5786 ).
5787
5788min_product(L1, U1, L2, U2, Min) :-
5789 Min cis min(min(L1*L2,L1*U2),min(U1*L2,U1*U2)).
5790max_product(L1, U1, L2, U2, Max) :-
5791 Max cis max(max(L1*L2,L1*U2),max(U1*L2,U1*U2)).
5792
5793finite(n(_)).
5794
5795in_(L, U, X) :-
5796 fd_get(X, XD, XPs),
5797 domains_intersection(XD, from_to(L,U), NXD),
5798 fd_put(X, NXD, XPs).
5799
5800min_max_factor(L1, U1, L2, U2, L3, U3, Min, Max) :-
5801 ( U1 cis_lt n(0),
5802 L2 cis_lt n(0), U2 cis_gt n(0),
5803 L3 cis_lt n(0), U3 cis_gt n(0) ->
5804 maplist(in_(L1,U1), [Z1,Z2]),
5805 in_(L2, n(-1), X1), in_(n(1), U3, Y1),
5806 ( X1*Y1 #= Z1 ->
5807 ( fd_get(Y1, _, Inf1, Sup1, _) -> true
5808 ; Inf1 = n(Y1), Sup1 = n(Y1)
5809 )
5810 ; Inf1 = inf, Sup1 = n(-1)
5811 ),
5812 in_(n(1), U2, X2), in_(L3, n(-1), Y2),
5813 ( X2*Y2 #= Z2 ->
5814 ( fd_get(Y2, _, Inf2, Sup2, _) -> true
5815 ; Inf2 = n(Y2), Sup2 = n(Y2)
5816 )
5817 ; Inf2 = n(1), Sup2 = sup
5818 ),
5819 Min cis max(min(Inf1,Inf2), L3),
5820 Max cis min(max(Sup1,Sup2), U3)
5821 ; L1 cis_gt n(0),
5822 L2 cis_lt n(0), U2 cis_gt n(0),
5823 L3 cis_lt n(0), U3 cis_gt n(0) ->
5824 maplist(in_(L1,U1), [Z1,Z2]),
5825 in_(L2, n(-1), X1), in_(L3, n(-1), Y1),
5826 ( X1*Y1 #= Z1 ->
5827 ( fd_get(Y1, _, Inf1, Sup1, _) -> true
5828 ; Inf1 = n(Y1), Sup1 = n(Y1)
5829 )
5830 ; Inf1 = n(1), Sup1 = sup
5831 ),
5832 in_(n(1), U2, X2), in_(n(1), U3, Y2),
5833 ( X2*Y2 #= Z2 ->
5834 ( fd_get(Y2, _, Inf2, Sup2, _) -> true
5835 ; Inf2 = n(Y2), Sup2 = n(Y2)
5836 )
5837 ; Inf2 = inf, Sup2 = n(-1)
5838 ),
5839 Min cis max(min(Inf1,Inf2), L3),
5840 Max cis min(max(Sup1,Sup2), U3)
5841 ; min_factor(L1, U1, L2, U2, Min0),
5842 Min cis max(L3,Min0),
5843 max_factor(L1, U1, L2, U2, Max0),
5844 Max cis min(U3,Max0)
5845 ).
5846
5847min_factor(L1, U1, L2, U2, Min) :-
5848 ( L1 cis_geq n(0), L2 cis_gt n(0), finite(U2) ->
5849 Min cis div(L1+U2-n(1),U2)
5850 ; L1 cis_gt n(0), U2 cis_lt n(0) -> Min cis div(U1,U2)
5851 ; L1 cis_gt n(0), L2 cis_geq n(0) -> Min = n(1)
5852 ; L1 cis_gt n(0) -> Min cis -U1
5853 ; U1 cis_lt n(0), U2 cis_leq n(0) ->
5854 ( finite(L2) -> Min cis div(U1+L2+n(1),L2)
5855 ; Min = n(1)
5856 )
5857 ; U1 cis_lt n(0), L2 cis_geq n(0) -> Min cis div(L1,L2)
5858 ; U1 cis_lt n(0) -> Min = L1
5859 ; L2 cis_leq n(0), U2 cis_geq n(0) -> Min = inf
5860 ; Min cis min(min(div(L1,L2),div(L1,U2)),min(div(U1,L2),div(U1,U2)))
5861 ).
5862max_factor(L1, U1, L2, U2, Max) :-
5863 ( L1 cis_geq n(0), L2 cis_geq n(0) -> Max cis div(U1,L2)
5864 ; L1 cis_gt n(0), U2 cis_leq n(0) ->
5865 ( finite(L2) -> Max cis div(L1-L2-n(1),L2)
5866 ; Max = n(-1)
5867 )
5868 ; L1 cis_gt n(0) -> Max = U1
5869 ; U1 cis_lt n(0), U2 cis_lt n(0) -> Max cis div(L1,U2)
5870 ; U1 cis_lt n(0), L2 cis_geq n(0) ->
5871 ( finite(U2) -> Max cis div(U1-U2+n(1),U2)
5872 ; Max = n(-1)
5873 )
5874 ; U1 cis_lt n(0) -> Max cis -L1
5875 ; L2 cis_leq n(0), U2 cis_geq n(0) -> Max = sup
5876 ; Max cis max(max(div(L1,L2),div(L1,U2)),max(div(U1,L2),div(U1,U2)))
5877 ).
5878
5879%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5880/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5881 J-C. Régin: "A filtering algorithm for constraints of difference in
5882 CSPs", AAAI-94, Seattle, WA, USA, pp 362--367, 1994
5883- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5884
5885distinct_attach([], _, _).
5886distinct_attach([X|Xs], Prop, Right) :-
5887 ( var(X) ->
5888 init_propagator(X, Prop),
5889 make_propagator(pexclude(Xs,Right,X), P1),
5890 init_propagator(X, P1),
5891 trigger_prop(P1)
5892 ; exclude_fire(Xs, Right, X)
5893 ),
5894 distinct_attach(Xs, Prop, [X|Right]).
5895
5896/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5897 For each integer of the union of domains, an attributed variable is
5898 introduced, to benefit from constant-time access. Attributes are:
5899
5900 value ... integer corresponding to the node
5901 free ... whether this (right) node is still free
5902 edges ... [flow_from(F,From)] and [flow_to(F,To)] where F has an
5903 attribute "flow" that is either 0 or 1 and an attribute "used"
5904 if it is part of a maximum matching
5905 parent ... used in breadth-first search
5906 g0_edges ... [flow_to(F,To)] as above
5907 visited ... true if node was visited in DFS
5908 index, in_stack, lowlink ... used in Tarjan's SCC algorithm
5909- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5910
5911difference_arcs(Vars, FreeLeft, FreeRight) :-
5912 empty_assoc(E),
5913 phrase(difference_arcs(Vars, FreeLeft), [E], [NumVar]),
5914 assoc_to_list(NumVar, LsNumVar),
5915 pairs_values(LsNumVar, FreeRight).
5916
5917domain_to_list(Domain, List) :- phrase(domain_to_list(Domain), List).
5918
5919domain_to_list(split(_, Left, Right)) -->
5920 domain_to_list(Left), domain_to_list(Right).
5921domain_to_list(empty) --> [].
5922domain_to_list(from_to(n(F),n(T))) --> { numlist(F, T, Ns) }, list(Ns).
5923
5924difference_arcs([], []) --> [].
5925difference_arcs([V|Vs], FL0) -->
5926 ( { fd_get(V, Dom, _), domain_to_list(Dom, Ns) } ->
5927 { FL0 = [V|FL] },
5928 enumerate(Ns, V),
5929 difference_arcs(Vs, FL)
5930 ; difference_arcs(Vs, FL0)
5931 ).
5932
5933writeln(T) :- write(T), nl.
5934
5935:- meta_predicate must_succeed(0).
5936
5937must_succeed(G) :-
5938 ( G -> true
5939 ; throw(failed-G)
5940 ).
5941
5942enumerate([], _) --> [].
5943enumerate([N|Ns], V) -->
5944 state(NumVar0, NumVar),
5945 { ( get_assoc(N, NumVar0, Y) -> NumVar0 = NumVar
5946 ; put_assoc(N, NumVar0, Y, NumVar),
5947 put_attr(Y, value, N)
5948 ),
5949 put_attr(F, flow, 0),
5950 must_succeed(append_edge(Y, edges, flow_from(F,V))),
5951 must_succeed(append_edge(V, edges, flow_to(F,Y))) },
5952 enumerate(Ns, V).
5953
5954append_edge(V, Attr, E) :-
5955 ( get_attr_(Attr, V, Es) ->
5956 put_attr_(Attr, V, [E|Es])
5957 ; put_attr_(Attr, V, [E])
5958 ).
5959
5960get_attr_(edges, V, Es) :- get_attr(V, edges, Es).
5961get_attr_(g0_edges, V, Es) :- get_attr(V, g0_edges, Es).
5962
5963put_attr_(edges, V, E) :- put_attr(V, edges, E).
5964put_attr_(g0_edges, V, E) :- put_attr(V, g0_edges, E).
5965
5966/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5967 Strategy: Breadth-first search until we find a free right vertex in
5968 the value graph, then find an augmenting path in reverse.
5969- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5970
5971clear_parent(V) :- del_attr(V, parent).
5972
5973maximum_matching([]).
5974maximum_matching([FL|FLs]) :-
5975 augmenting_path_to([[FL]], Levels, To),
5976 phrase(augmenting_path(FL, To), Path),
5977 maplist(maplist(clear_parent), Levels),
5978 del_attr(To, free),
5979 adjust_alternate_1(Path),
5980 maximum_matching(FLs).
5981
5982reachables([]) --> [].
5983reachables([V|Vs]) -->
5984 { get_attr(V, edges, Es) },
5985 reachables_(Es, V),
5986 reachables(Vs).
5987
5988reachables_([], _) --> [].
5989reachables_([E|Es], V) -->
5990 edge_reachable(E, V),
5991 reachables_(Es, V).
5992
5993edge_reachable(flow_to(F,To), V) -->
5994 ( { get_attr(F, flow, 0),
5995 \+ get_attr(To, parent, _) } ->
5996 { put_attr(To, parent, V-F) },
5997 [To]
5998 ; []
5999 ).
6000edge_reachable(flow_from(F,From), V) -->
6001 ( { get_attr(F, flow, 1),
6002 \+ get_attr(From, parent, _) } ->
6003 { put_attr(From, parent, V-F) },
6004 [From]
6005 ; []
6006 ).
6007
6008augmenting_path_to(Levels0, Levels, Right) :-
6009 Levels0 = [Vs|_],
6010 Levels1 = [Tos|Levels0],
6011 phrase(reachables(Vs), Tos),
6012 Tos = [_|_],
6013 ( member(Right, Tos), get_attr(Right, free, true) ->
6014 Levels = Levels1
6015 ; augmenting_path_to(Levels1, Levels, Right)
6016 ).
6017
6018augmenting_path(S, V) -->
6019 ( { V == S } -> []
6020 ; { get_attr(V, parent, V1-Augment) },
6021 [Augment],
6022 augmenting_path(S, V1)
6023 ).
6024
6025adjust_alternate_1([A|Arcs]) :-
6026 put_attr(A, flow, 1),
6027 adjust_alternate_0(Arcs).
6028
6029adjust_alternate_0([]).
6030adjust_alternate_0([A|Arcs]) :-
6031 put_attr(A, flow, 0),
6032 adjust_alternate_1(Arcs).
6033
6034% Instead of applying Berge's property directly, we can translate the
6035% problem in such a way, that we have to search for the so-called
6036% strongly connected components of the graph.
6037
6038g_g0(V) :-
6039 get_attr(V, edges, Es),
6040 maplist(g_g0_(V), Es).
6041
6042g_g0_(V, flow_to(F,To)) :-
6043 ( get_attr(F, flow, 1) ->
6044 append_edge(V, g0_edges, flow_to(F,To))
6045 ; append_edge(To, g0_edges, flow_to(F,V))
6046 ).
6047
6048
6049g0_successors(V, Tos) :-
6050 ( get_attr(V, g0_edges, Tos0) ->
6051 maplist(arg(2), Tos0, Tos)
6052 ; Tos = []
6053 ).
6054
6055put_free(F) :- put_attr(F, free, true).
6056
6057free_node(F) :- get_attr(F, free, true).
6058
6059del_vars_attr(Vars, Attr) :- maplist(del_attr(Attr), Vars).
6060
6061%del_attr_(Attr, Var) :- del_attr(Var, Attr).
6062
6063/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6064 This needs to be spelt out.
6065- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6066
6067% del_attr_(edges, Var) :- del_attr(Var, edges).
6068% del_attr_(parent, Var) :- del_attr(Var, parent).
6069% del_attr_(g0_edges, Var) :- del_attr(Var, g0_edges).
6070% del_attr_(index, Var) :- del_attr(Var, index).
6071% del_attr_(visited, Var) :- del_attr(Var, visited).
6072
6073del_all_attrs(Var) :-
6074 ( var(Var) ->
6075 Atts = [clpz,
6076 clpz_aux,
6077 clpz_relation,
6078 edges,
6079 flow,
6080 parent,
6081 free,
6082 g0_edges,
6083 used,
6084 lowlink,
6085 value,
6086 visited,
6087 index,
6088 in_stack,
6089 clpz_gcc_vs,
6090 clpz_gcc_num,
6091 clpz_gcc_occurred],
6092 maplist(remove_attr(Var), Atts)
6093 ; true
6094 ).
6095
6096remove_attr(Var, Attr) :-
6097 functor(Term, Attr, 1),
6098 put_atts(Var, -Term).
6099
6100:- meta_predicate with_local_attributes(?, 0, ?).
6101
6102with_local_attributes(Vars, Goal, Result) :-
6103 catch((Goal,
6104 maplist(del_all_attrs, Vars),
6105 % reset all attributes, only the result matters
6106 throw(local_attributes(Result,Vars))),
6107 local_attributes(Result,Vars),
6108 true).
6109
6110distinct(Vars) :-
6111 with_local_attributes(Vars,
6112 ( difference_arcs(Vars, FreeLeft, FreeRight0),
6113 length(FreeLeft, LFL),
6114 length(FreeRight0, LFR),
6115 LFL =< LFR,
6116 maplist(put_free, FreeRight0),
6117 maximum_matching(FreeLeft),
6118 include(free_node, FreeRight0, FreeRight),
6119 maplist(g_g0, FreeLeft),
6120 scc(FreeLeft, g0_successors),
6121 maplist(dfs_used, FreeRight),
6122 phrase(distinct_goals(FreeLeft), Gs)), Gs),
6123 disable_queue,
6124 maplist(call, Gs),
6125 enable_queue.
6126
6127distinct_goals([]) --> [].
6128distinct_goals([V|Vs]) -->
6129 { get_attr(V, edges, Es) },
6130 distinct_goals_(Es, V),
6131 distinct_goals(Vs).
6132
6133distinct_goals_([], _) --> [].
6134distinct_goals_([flow_to(F,To)|Es], V) -->
6135 ( { get_attr(F, flow, 0),
6136 \+ get_attr(F, used, true),
6137 get_attr(V, lowlink, L1),
6138 get_attr(To, lowlink, L2),
6139 L1 =\= L2 } ->
6140 { get_attr(To, value, N) },
6141 [neq_num(V, N)]
6142 ; []
6143 ),
6144 distinct_goals_(Es, V).
6145
6146/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6147 Mark used edges.
6148- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6149
6150dfs_used(V) :-
6151 ( get_attr(V, visited, true) -> true
6152 ; put_attr(V, visited, true),
6153 ( get_attr(V, g0_edges, Es) ->
6154 dfs_used_edges(Es)
6155 ; true
6156 )
6157 ).
6158
6159dfs_used_edges([]).
6160dfs_used_edges([flow_to(F,To)|Es]) :-
6161 put_attr(F, used, true),
6162 dfs_used(To),
6163 dfs_used_edges(Es).
6164
6165/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6166 Tarjan's strongly connected components algorithm.
6167
6168 DCGs are used to implicitly pass around the global index, stack
6169 and the predicate relating a vertex to its successors.
6170
6171 For more information about this technique, see:
6172
6173 https://www.metalevel.at/prolog/dcg
6174 ===================================
6175
6176 A Prolog implementation of this algorithm is also available as a
6177 standalone library from:
6178
6179 https://www.metalevel.at/scc.pl
6180- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6181
6182scc(Vs, Succ) :- phrase(scc(Vs), [s(0,[],Succ)], _).
6183
6184scc([]) --> [].
6185scc([V|Vs]) -->
6186 ( vindex_defined(V) -> scc(Vs)
6187 ; scc_(V), scc(Vs)
6188 ).
6189
6190vindex_defined(V) --> { get_attr(V, index, _) }.
6191
6192vindex_is_index(V) -->
6193 state(s(Index,_,_)),
6194 { put_attr(V, index, Index) }.
6195
6196vlowlink_is_index(V) -->
6197 state(s(Index,_,_)),
6198 { put_attr(V, lowlink, Index) }.
6199
6200index_plus_one -->
6201 state(s(I,Stack,Succ), s(I1,Stack,Succ)),
6202 { I1 is I+1 }.
6203
6204s_push(V) -->
6205 state(s(I,Stack,Succ), s(I,[V|Stack],Succ)),
6206 { put_attr(V, in_stack, true) }.
6207
6208vlowlink_min_lowlink(V, VP) -->
6209 { get_attr(V, lowlink, VL),
6210 get_attr(VP, lowlink, VPL),
6211 VL1 is min(VL, VPL),
6212 put_attr(V, lowlink, VL1) }.
6213
6214successors(V, Tos) --> state(s(_,_,Succ)), { call(Succ, V, Tos) }.
6215
6216scc_(V) -->
6217 vindex_is_index(V),
6218 vlowlink_is_index(V),
6219 index_plus_one,
6220 s_push(V),
6221 successors(V, Tos),
6222 each_edge(Tos, V),
6223 ( { get_attr(V, index, VI),
6224 get_attr(V, lowlink, VI) } -> pop_stack_to(V, VI)
6225 ; []
6226 ).
6227
6228pop_stack_to(V, N) -->
6229 state(s(I,[First|Stack],Succ), s(I,Stack,Succ)),
6230 { del_attr(First, in_stack) },
6231 ( { First == V } -> []
6232 ; { put_attr(First, lowlink, N) },
6233 pop_stack_to(V, N)
6234 ).
6235
6236each_edge([], _) --> [].
6237each_edge([VP|VPs], V) -->
6238 ( vindex_defined(VP) ->
6239 ( v_in_stack(VP) ->
6240 vlowlink_min_lowlink(V, VP)
6241 ; []
6242 )
6243 ; scc_(VP),
6244 vlowlink_min_lowlink(V, VP)
6245 ),
6246 each_edge(VPs, V).
6247
6248state(S), [S] --> [S].
6249
6250state(S0, S), [S] --> [S0].
6251
6252v_in_stack(V) --> { get_attr(V, in_stack, true) }.
6253
6254node_lowlink(V, L) :- get_attr(V, lowlink, L).
6255
6256/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6257 nvalue/2: A relaxed version of all_distinct/1.
6258- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6259
6260
6261maximal_matching([]) --> [].
6262maximal_matching([FL|FLs]) -->
6263 ( { augmenting_path_to([[FL]], Levels, To) } ->
6264 { phrase(augmenting_path(FL, To), Path),
6265 maplist(maplist(clear_parent), Levels),
6266 del_attr(To, free),
6267 adjust_alternate_1(Path) },
6268 [FL]
6269 ; []
6270 ),
6271 maximal_matching(FLs).
6272
6273propagate_nvalue(N, Vars0) :-
6274 sort(Vars0, Vars),
6275 include(integer, Vars, Ints),
6276 length(Ints, Distinct),
6277 vars_num_infinite(Vars, NumInfinite),
6278 N #>= Distinct,
6279 with_local_attributes(Vars,
6280 ( difference_arcs(Vars, FreeLeft, FreeRight0),
6281 maplist(put_free, FreeRight0),
6282 phrase(maximal_matching(FreeLeft), MatchedLeft),
6283 length(MatchedLeft, MaxFurther) ),
6284 MaxFurther),
6285 N #=< NumInfinite + Distinct + MaxFurther.
6286
6287vars_num_infinite(Vars, Num) :-
6288 foldl(num_infinite, Vars, 0, Num).
6289
6290num_infinite(Var, N0, N) :-
6291 ( integer(Var) -> N = N0
6292 ; fd_get(Var, Dom, _),
6293 ( domain_infimum(Dom, n(_)),
6294 domain_supremum(Dom, n(_)) -> N = N0
6295 ; N #= N0 + 1
6296 )
6297 ).
6298
6299/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6300 Weak arc consistent constraint of difference, currently only
6301 available internally. Candidate for all_different/2 option.
6302
6303 See Neng-Fa Zhou: "Programming Finite-Domain Constraint Propagators
6304 in Action Rules", Theory and Practice of Logic Programming, Vol.6,
6305 No.5, pp 483-508, 2006
6306- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6307
6308weak_arc_all_distinct(Ls) :-
6309 must_be(list, Ls),
6310 Orig = original_goal(_, weak_arc_all_distinct(Ls)),
6311 all_distinct(Ls, [], Orig),
6312 do_queue.
6313
6314all_distinct([], _, _).
6315all_distinct([X|Right], Left, Orig) :-
6316 %\+ list_contains(Right, X),
6317 ( var(X) ->
6318 make_propagator(weak_distinct(Left,Right,X,Orig), Prop),
6319 init_propagator(X, Prop),
6320 trigger_prop(Prop)
6321% make_propagator(check_distinct(Left,Right,X), Prop2),
6322% init_propagator(X, Prop2),
6323% trigger_prop(Prop2)
6324 ; exclude_fire(Left, Right, X)
6325 ),
6326 outof_reducer(Left, Right, X),
6327 all_distinct(Right, [X|Left], Orig).
6328
6329exclude_fire(Left, Right, E) :-
6330 all_neq(Left, E),
6331 all_neq(Right, E).
6332
6333list_contains([X|Xs], Y) :-
6334 ( X == Y -> true
6335 ; list_contains(Xs, Y)
6336 ).
6337
6338kill_if_isolated(Left, Right, X, MState) :-
6339 append(Left, Right, Others),
6340 fd_get(X, XDom, _),
6341 ( all_empty_intersection(Others, XDom) -> kill(MState)
6342 ; true
6343 ).
6344
6345all_empty_intersection([], _).
6346all_empty_intersection([V|Vs], XDom) :-
6347 ( fd_get(V, VDom, _) ->
6348 domains_intersection_(VDom, XDom, empty),
6349 all_empty_intersection(Vs, XDom)
6350 ; all_empty_intersection(Vs, XDom)
6351 ).
6352
6353outof_reducer(Left, Right, Var) :-
6354 ( fd_get(Var, Dom, _) ->
6355 append(Left, Right, Others),
6356 domain_num_elements(Dom, N),
6357 num_subsets(Others, Dom, 0, Num, NonSubs),
6358 ( n(Num) cis_geq N -> false
6359 ; n(Num) cis N - n(1) ->
6360 reduce_from_others(NonSubs, Dom)
6361 ; true
6362 )
6363 ; %\+ list_contains(Right, Var),
6364 %\+ list_contains(Left, Var)
6365 true
6366 ).
6367
6368reduce_from_others([], _).
6369reduce_from_others([X|Xs], Dom) :-
6370 ( fd_get(X, XDom, XPs) ->
6371 domain_subtract(XDom, Dom, NXDom),
6372 fd_put(X, NXDom, XPs)
6373 ; true
6374 ),
6375 reduce_from_others(Xs, Dom).
6376
6377num_subsets([], _Dom, Num, Num, []).
6378num_subsets([S|Ss], Dom, Num0, Num, NonSubs) :-
6379 ( fd_get(S, SDom, _) ->
6380 ( domain_subdomain(Dom, SDom) ->
6381 Num1 is Num0 + 1,
6382 num_subsets(Ss, Dom, Num1, Num, NonSubs)
6383 ; NonSubs = [S|Rest],
6384 num_subsets(Ss, Dom, Num0, Num, Rest)
6385 )
6386 ; num_subsets(Ss, Dom, Num0, Num, NonSubs)
6387 ).
6388
6389%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6390
6391%% serialized(+Starts, +Durations)
6392%
6393% Describes a set of non-overlapping tasks.
6394% Starts = [S_1,...,S_n], is a list of variables or integers,
6395% Durations = [D_1,...,D_n] is a list of non-negative integers.
6396% Constrains Starts and Durations to denote a set of
6397% non-overlapping tasks, i.e.: S_i + D_i =< S_j or S_j + D_j =<
6398% S_i for all 1 =< i < j =< n. Example:
6399%
6400% ==
6401% ?- length(Vs, 3),
6402% Vs ins 0..3,
6403% serialized(Vs, [1,2,3]),
6404% label(Vs).
6405% Vs = [0, 1, 3] ;
6406% Vs = [2, 0, 3] ;
6407% false.
6408% ==
6409%
6410% @see Dorndorf et al. 2000, "Constraint Propagation Techniques for the
6411% Disjunctive Scheduling Problem"
6412
6413serialized(Starts, Durations) :-
6414 must_be(list(integer), Durations),
6415 pairs_keys_values(SDs, Starts, Durations),
6416 Orig = original_goal(_, serialized(Starts, Durations)),
6417 serialize(SDs, Orig).
6418
6419serialize([], _).
6420serialize([S-D|SDs], Orig) :-
6421 D >= 0,
6422 serialize(SDs, S, D, Orig),
6423 serialize(SDs, Orig).
6424
6425serialize([], _, _, _).
6426serialize([S-D|Rest], S0, D0, Orig) :-
6427 D >= 0,
6428 propagator_init_trigger([S0,S], pserialized(S,D,S0,D0,Orig)),
6429 serialize(Rest, S0, D0, Orig).
6430
6431% consistency check / propagation
6432% Currently implements 2-b-consistency
6433
6434earliest_start_time(Start, EST) :-
6435 ( fd_get(Start, D, _) ->
6436 domain_infimum(D, EST)
6437 ; EST = n(Start)
6438 ).
6439
6440latest_start_time(Start, LST) :-
6441 ( fd_get(Start, D, _) ->
6442 domain_supremum(D, LST)
6443 ; LST = n(Start)
6444 ).
6445
6446serialize_lower_upper(S_I, D_I, S_J, D_J, MState) -->
6447 ( { var(S_I) } ->
6448 serialize_lower_bound(S_I, D_I, S_J, D_J, MState),
6449 ( { var(S_I) } ->
6450 serialize_upper_bound(S_I, D_I, S_J, D_J, MState)
6451 ; []
6452 )
6453 ; []
6454 ).
6455
6456serialize_lower_bound(I, D_I, J, D_J, MState) -->
6457 { fd_get(I, DomI, Ps) },
6458 ( { domain_infimum(DomI, n(EST_I)),
6459 latest_start_time(J, n(LST_J)),
6460 EST_I + D_I > LST_J,
6461 earliest_start_time(J, n(EST_J)) } ->
6462 ( nonvar(J) -> kill(MState)
6463 ; []
6464 ),
6465 { EST is EST_J+D_J,
6466 domain_remove_smaller_than(DomI, EST, DomI1) },
6467 fd_put(I, DomI1, Ps)
6468 ; []
6469 ).
6470
6471serialize_upper_bound(I, D_I, J, D_J, MState) -->
6472 { fd_get(I, DomI, Ps) },
6473 ( { domain_supremum(DomI, n(LST_I)),
6474 earliest_start_time(J, n(EST_J)),
6475 EST_J + D_J > LST_I,
6476 latest_start_time(J, n(LST_J)) } ->
6477 ( nonvar(J) -> kill(MState)
6478 ; []
6479 ),
6480 { LST is LST_J-D_I,
6481 domain_remove_greater_than(DomI, LST, DomI1) },
6482 fd_put(I, DomI1, Ps)
6483 ; []
6484 ).
6485
6486%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6487
6488%% element(?N, +Vs, ?V)
6489%
6490% The N-th element of the list of finite domain variables Vs is V.
6491% Analogous to nth1/3.
6492
6493element(N, Is, V) :-
6494 must_be(list, Is),
6495 length(Is, L),
6496 N in 1..L,
6497 element_(Is, 1, N, V),
6498 propagator_init_trigger([N|Is], pelement(N,Is,V)).
6499
6500element_domain(V, VD) :-
6501 ( fd_get(V, VD, _) -> true
6502 ; VD = from_to(n(V), n(V))
6503 ).
6504
6505element_([], _, _, _).
6506element_([I|Is], N0, N, V) :-
6507 ?(I) #\= ?(V) #==> ?(N) #\= N0,
6508 N1 is N0 + 1,
6509 element_(Is, N1, N, V).
6510
6511integers_remaining([], _, _, D, D).
6512integers_remaining([V|Vs], N0, Dom, D0, D) :-
6513 ( domain_contains(Dom, N0) ->
6514 element_domain(V, VD),
6515 domains_union(D0, VD, D1)
6516 ; D1 = D0
6517 ),
6518 N1 is N0 + 1,
6519 integers_remaining(Vs, N1, Dom, D1, D).
6520
6521%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6522
6523%% global_cardinality(+Vs, +Pairs)
6524%
6525% Global Cardinality constraint. Equivalent to
6526% global_cardinality(Vs, Pairs, []). Example:
6527%
6528% ==
6529% ?- Vs = [_,_,_], global_cardinality(Vs, [1-2,3-_]), label(Vs).
6530% Vs = [1, 1, 3] ;
6531% Vs = [1, 3, 1] ;
6532% Vs = [3, 1, 1].
6533% ==
6534
6535global_cardinality(Xs, Pairs) :- global_cardinality(Xs, Pairs, []).
6536
6537%% global_cardinality(+Vs, +Pairs, +Options)
6538%
6539% Global Cardinality constraint. Vs is a list of finite domain
6540% variables, Pairs is a list of Key-Num pairs, where Key is an
6541% integer and Num is a finite domain variable. The constraint holds
6542% iff each V in Vs is equal to some key, and for each Key-Num pair
6543% in Pairs, the number of occurrences of Key in Vs is Num. Options
6544% is a list of options. Supported options are:
6545%
6546% * consistency(value)
6547% A weaker form of consistency is used.
6548%
6549% * cost(Cost, Matrix)
6550% Matrix is a list of rows, one for each variable, in the order
6551% they occur in Vs. Each of these rows is a list of integers, one
6552% for each key, in the order these keys occur in Pairs. When
6553% variable v_i is assigned the value of key k_j, then the
6554% associated cost is Matrix_{ij}. Cost is the sum of all costs.
6555
6556global_cardinality(Xs, Pairs, Options) :-
6557 must_be(list(list), [Xs,Pairs,Options]),
6558 maplist(fd_variable, Xs),
6559 maplist(gcc_pair, Pairs),
6560 pairs_keys_values(Pairs, Keys, Nums),
6561 ( sort(Keys, Keys1), same_length(Keys, Keys1) -> true
6562 ; domain_error(gcc_unique_key_pairs, Pairs)
6563 ),
6564 length(Xs, L),
6565 Nums ins 0..L,
6566 list_to_drep(Keys, Drep),
6567 Xs ins Drep,
6568 gcc_pairs(Pairs, Xs, Pairs1),
6569 % pgcc_check must be installed before triggering other
6570 % propagators
6571 propagator_init_trigger(Xs, pgcc_check(Pairs1)),
6572 propagator_init_trigger(Nums, pgcc_check_single(Pairs1)),
6573 ( member(OD, Options), OD == consistency(value) -> true
6574 ; propagator_init_trigger(Nums, pgcc_single(Xs, Pairs1)),
6575 propagator_init_trigger(Xs, pgcc(Xs, Pairs, Pairs1))
6576 ),
6577 ( member(OC, Options), functor(OC, cost, 2) ->
6578 OC = cost(Cost, Matrix),
6579 must_be(list(list(integer)), Matrix),
6580 maplist(keys_costs(Keys), Xs, Matrix, Costs),
6581 sum(Costs, #=, Cost)
6582 ; true
6583 ).
6584
6585keys_costs(Keys, X, Row, C) :-
6586 element(N, Keys, X),
6587 element(N, Row, C).
6588
6589gcc_pair(Pair) :-
6590 ( Pair = Key-Val ->
6591 must_be(integer, Key),
6592 fd_variable(Val)
6593 ; domain_error(gcc_pair, Pair)
6594 ).
6595
6596/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6597 For each Key-Num0 pair, we introduce an auxiliary variable Num and
6598 attach the following attributes to it:
6599
6600 clpz_gcc_num: equal Num0, the user-visible counter variable
6601 clpz_gcc_vs: the remaining variables in the constraint that can be
6602 equal Key.
6603 clpz_gcc_occurred: stores how often Key already occurred in vs.
6604- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6605
6606gcc_pairs([], _, []).
6607gcc_pairs([Key-Num0|KNs], Vs, [Key-Num|Rest]) :-
6608 put_attr(Num, clpz_gcc_num, Num0),
6609 put_attr(Num, clpz_gcc_vs, Vs),
6610 put_attr(Num, clpz_gcc_occurred, 0),
6611 gcc_pairs(KNs, Vs, Rest).
6612
6613/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6614 J.-C. Régin: "Generalized Arc Consistency for Global Cardinality
6615 Constraint", AAAI-96 Portland, OR, USA, pp 209--215, 1996
6616- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6617
6618gcc_global(Vs, KNs) :-
6619 gcc_check(KNs),
6620 % reach fix-point: all elements of clpz_gcc_vs must be variables
6621 do_queue,
6622 with_local_attributes(Vs,
6623 (gcc_arcs(KNs, S, Vals),
6624 variables_with_num_occurrences(Vs, VNs),
6625 maplist(target_to_v(T), VNs),
6626 ( get_attr(S, edges, Es) ->
6627 put_attr(S, parent, none), % Mark S as seen to avoid going back to S.
6628 feasible_flow(Es, S, T), % First construct a feasible flow (if any)
6629 maximum_flow(S, T), % only then, maximize it.
6630 gcc_consistent(T),
6631 scc(Vals, gcc_successors),
6632 phrase(gcc_goals(Vals), Gs)
6633 ; Gs = [] )), Gs),
6634 disable_queue,
6635 maplist(call, Gs),
6636 enable_queue.
6637
6638gcc_consistent(T) :-
6639 get_attr(T, edges, Es),
6640 maplist(saturated_arc, Es).
6641
6642saturated_arc(arc_from(_,U,_,Flow)) :- get_attr(Flow, flow, U).
6643
6644gcc_goals([]) --> [].
6645gcc_goals([Val|Vals]) -->
6646 { get_attr(Val, edges, Es) },
6647 gcc_edges_goals(Es, Val),
6648 gcc_goals(Vals).
6649
6650gcc_edges_goals([], _) --> [].
6651gcc_edges_goals([E|Es], Val) -->
6652 gcc_edge_goal(E, Val),
6653 gcc_edges_goals(Es, Val).
6654
6655gcc_edge_goal(arc_from(_,_,_,_), _) --> [].
6656gcc_edge_goal(arc_to(_,_,V,F), Val) -->
6657 ( { get_attr(F, flow, 0),
6658 get_attr(V, lowlink, L1),
6659 get_attr(Val, lowlink, L2),
6660 L1 =\= L2,
6661 get_attr(Val, value, Value) } ->
6662 [neq_num(V, Value)]
6663 ; []
6664 ).
6665
6666/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6667 Like in all_distinct/1, first use breadth-first search, then
6668 construct an augmenting path in reverse.
6669- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6670
6671maximum_flow(S, T) :-
6672 ( gcc_augmenting_path([[S]], Levels, T) ->
6673 phrase(augmenting_path(S, T), Path),
6674 Path = [augment(_,First,_)|Rest],
6675 path_minimum(Rest, First, Min),
6676 maplist(gcc_augment(Min), Path),
6677 maplist(maplist(clear_parent), Levels),
6678 maximum_flow(S, T)
6679 ; true
6680 ).
6681
6682feasible_flow([], _, _).
6683feasible_flow([A|As], S, T) :-
6684 make_arc_feasible(A, S, T),
6685 feasible_flow(As, S, T).
6686
6687make_arc_feasible(A, S, T) :-
6688 A = arc_to(L,_,V,F),
6689 get_attr(F, flow, Flow),
6690 ( Flow >= L -> true
6691 ; Diff is L - Flow,
6692 put_attr(V, parent, S-augment(F,Diff,+)),
6693 gcc_augmenting_path([[V]], Levels, T),
6694 phrase(augmenting_path(S, T), Path),
6695 path_minimum(Path, Diff, Min),
6696 maplist(gcc_augment(Min), Path),
6697 maplist(maplist(clear_parent), Levels),
6698 make_arc_feasible(A, S, T)
6699 ).
6700
6701gcc_augmenting_path(Levels0, Levels, T) :-
6702 Levels0 = [Vs|_],
6703 Levels1 = [Tos|Levels0],
6704 phrase(gcc_reachables(Vs), Tos),
6705 Tos = [_|_],
6706 ( member(To, Tos), To == T -> Levels = Levels1
6707 ; gcc_augmenting_path(Levels1, Levels, T)
6708 ).
6709
6710gcc_reachables([]) --> [].
6711gcc_reachables([V|Vs]) -->
6712 { get_attr(V, edges, Es) },
6713 gcc_reachables_(Es, V),
6714 gcc_reachables(Vs).
6715
6716gcc_reachables_([], _) --> [].
6717gcc_reachables_([E|Es], V) -->
6718 gcc_reachable(E, V),
6719 gcc_reachables_(Es, V).
6720
6721gcc_reachable(arc_from(_,_,V,F), P) -->
6722 ( { \+ get_attr(V, parent, _),
6723 get_attr(F, flow, Flow),
6724 Flow > 0 } ->
6725 { put_attr(V, parent, P-augment(F,Flow,-)) },
6726 [V]
6727 ; []
6728 ).
6729gcc_reachable(arc_to(_L,U,V,F), P) -->
6730 ( { \+ get_attr(V, parent, _),
6731 get_attr(F, flow, Flow),
6732 Flow < U } ->
6733 { Diff is U - Flow,
6734 put_attr(V, parent, P-augment(F,Diff,+)) },
6735 [V]
6736 ; []
6737 ).
6738
6739
6740path_minimum([], Min, Min).
6741path_minimum([augment(_,A,_)|As], Min0, Min) :-
6742 Min1 is min(Min0,A),
6743 path_minimum(As, Min1, Min).
6744
6745gcc_augment(Min, augment(F,_,Sign)) :-
6746 get_attr(F, flow, Flow0),
6747 gcc_flow_(Sign, Flow0, Min, Flow),
6748 put_attr(F, flow, Flow).
6749
6750gcc_flow_(+, F0, A, F) :- F is F0 + A.
6751gcc_flow_(-, F0, A, F) :- F is F0 - A.
6752
6753/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6754 Build value network for global cardinality constraint.
6755- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6756
6757gcc_arcs([], _, []).
6758gcc_arcs([Key-Num0|KNs], S, Vals) :-
6759 ( get_attr(Num0, clpz_gcc_vs, Vs) ->
6760 get_attr(Num0, clpz_gcc_num, Num),
6761 get_attr(Num0, clpz_gcc_occurred, Occ),
6762 ( nonvar(Num) -> U is Num - Occ, U = L
6763 ; fd_get(Num, _, n(L0), n(U0), _),
6764 L is L0 - Occ, U is U0 - Occ
6765 ),
6766 put_attr(Val, value, Key),
6767 Vals = [Val|Rest],
6768 put_attr(F, flow, 0),
6769 append_edge(S, edges, arc_to(L, U, Val, F)),
6770 put_attr(Val, edges, [arc_from(L, U, S, F)]),
6771 variables_with_num_occurrences(Vs, VNs),
6772 maplist(val_to_v(Val), VNs)
6773 ; Vals = Rest
6774 ),
6775 gcc_arcs(KNs, S, Rest).
6776
6777variables_with_num_occurrences(Vs0, VNs) :-
6778 include(var, Vs0, Vs1),
6779 samsort(Vs1, Vs),
6780 ( Vs == [] -> VNs = []
6781 ; Vs = [V|Rest],
6782 variables_with_num_occurrences(Rest, V, 1, VNs)
6783 ).
6784
6785variables_with_num_occurrences([], Prev, Count, [Prev-Count]).
6786variables_with_num_occurrences([V|Vs], Prev, Count0, VNs) :-
6787 ( V == Prev ->
6788 Count1 is Count0 + 1,
6789 variables_with_num_occurrences(Vs, Prev, Count1, VNs)
6790 ; VNs = [Prev-Count0|Rest],
6791 variables_with_num_occurrences(Vs, V, 1, Rest)
6792 ).
6793
6794
6795target_to_v(T, V-Count) :-
6796 put_attr(F, flow, 0),
6797 append_edge(V, edges, arc_to(0, Count, T, F)),
6798 append_edge(T, edges, arc_from(0, Count, V, F)).
6799
6800val_to_v(Val, V-Count) :-
6801 put_attr(F, flow, 0),
6802 append_edge(V, edges, arc_from(0, Count, Val, F)),
6803 append_edge(Val, edges, arc_to(0, Count, V, F)).
6804
6805
6806gcc_successors(V, Tos) :-
6807 get_attr(V, edges, Tos0),
6808 phrase(gcc_successors_(Tos0), Tos).
6809
6810gcc_successors_([]) --> [].
6811gcc_successors_([E|Es]) --> gcc_succ_edge(E), gcc_successors_(Es).
6812
6813gcc_succ_edge(arc_to(_,U,V,F)) -->
6814 ( { get_attr(F, flow, Flow),
6815 Flow < U } -> [V]
6816 ; []
6817 ).
6818gcc_succ_edge(arc_from(_,_,V,F)) -->
6819 ( { get_attr(F, flow, Flow),
6820 Flow > 0 } -> [V]
6821 ; []
6822 ).
6823
6824/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6825 Simple consistency check, run before global propagation.
6826 Importantly, it removes all ground values from clpz_gcc_vs.
6827
6828 The pgcc_check/1 propagator in itself suffices to ensure
6829 consistency.
6830- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6831
6832gcc_check(Pairs) :-
6833 disable_queue,
6834 gcc_check_(Pairs),
6835 enable_queue.
6836
6837gcc_done(Num) :-
6838 del_attr(Num, clpz_gcc_vs),
6839 del_attr(Num, clpz_gcc_num),
6840 del_attr(Num, clpz_gcc_occurred).
6841
6842gcc_check_([]).
6843gcc_check_([Key-Num0|KNs]) :-
6844 ( get_attr(Num0, clpz_gcc_vs, Vs) ->
6845 get_attr(Num0, clpz_gcc_num, Num),
6846 get_attr(Num0, clpz_gcc_occurred, Occ0),
6847 vs_key_min_others(Vs, Key, 0, Min, Os),
6848 put_attr(Num0, clpz_gcc_vs, Os),
6849 put_attr(Num0, clpz_gcc_occurred, Occ1),
6850 Occ1 is Occ0 + Min,
6851 geq(Num, Occ1),
6852 % The queue is disabled for efficiency here in any case.
6853 % If it were enabled, make sure to retain the invariant
6854 % that gcc_global is never triggered during an
6855 % inconsistent state (after gcc_done/1 but before all
6856 % relevant constraints are posted).
6857 ( Occ1 == Num -> all_neq(Os, Key), gcc_done(Num0)
6858 ; Os == [] -> gcc_done(Num0), Num = Occ1
6859 ; length(Os, L),
6860 Max is Occ1 + L,
6861 geq(Max, Num),
6862 ( nonvar(Num) -> Diff is Num - Occ1
6863 ; fd_get(Num, ND, _),
6864 domain_infimum(ND, n(NInf)),
6865 Diff is NInf - Occ1
6866 ),
6867 L >= Diff,
6868 ( L =:= Diff ->
6869 Num is Occ1 + Diff,
6870 maplist(=(Key), Os),
6871 gcc_done(Num0)
6872 ; true
6873 )
6874 )
6875 ; true
6876 ),
6877 gcc_check_(KNs).
6878
6879vs_key_min_others([], _, Min, Min, []).
6880vs_key_min_others([V|Vs], Key, Min0, Min, Others) :-
6881 ( fd_get(V, VD, _) ->
6882 ( domain_contains(VD, Key) ->
6883 Others = [V|Rest],
6884 vs_key_min_others(Vs, Key, Min0, Min, Rest)
6885 ; vs_key_min_others(Vs, Key, Min0, Min, Others)
6886 )
6887 ; ( V =:= Key ->
6888 Min1 is Min0 + 1,
6889 vs_key_min_others(Vs, Key, Min1, Min, Others)
6890 ; vs_key_min_others(Vs, Key, Min0, Min, Others)
6891 )
6892 ).
6893
6894all_neq([], _).
6895all_neq([X|Xs], C) :-
6896 neq_num(X, C),
6897 all_neq(Xs, C).
6898
6899%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6900
6901%% circuit(+Vs)
6902%
6903% True iff the list Vs of finite domain variables induces a
6904% Hamiltonian circuit. The k-th element of Vs denotes the
6905% successor of node k. Node indexing starts with 1. Examples:
6906%
6907% ==
6908% ?- length(Vs, _), circuit(Vs), label(Vs).
6909% Vs = [] ;
6910% Vs = [1] ;
6911% Vs = [2, 1] ;
6912% Vs = [2, 3, 1] ;
6913% Vs = [3, 1, 2] ;
6914% Vs = [2, 3, 4, 1] .
6915% ==
6916
6917circuit(Vs) :-
6918 must_be(list, Vs),
6919 maplist(fd_variable, Vs),
6920 length(Vs, L),
6921 Vs ins 1..L,
6922 ( L =:= 1 -> true
6923 ; neq_index(Vs, 1),
6924 make_propagator(pcircuit(Vs), Prop),
6925 distinct_attach(Vs, Prop, []),
6926 trigger_once(Prop)
6927 ).
6928
6929neq_index([], _).
6930neq_index([X|Xs], N) :-
6931 neq_num(X, N),
6932 N1 is N + 1,
6933 neq_index(Xs, N1).
6934
6935/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6936 Necessary condition for existence of a Hamiltonian circuit: The
6937 graph has a single strongly connected component. If the list is
6938 ground, the condition is also sufficient.
6939
6940 Ts are used as temporary variables to attach attributes:
6941
6942 lowlink, index: used for SCC
6943 [arc_to(V)]: possible successors
6944- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
6945
6946propagate_circuit(Vs) :-
6947 with_local_attributes([],
6948 (same_length(Vs, Ts),
6949 circuit_graph(Vs, Ts, Ts),
6950 scc(Ts, circuit_successors),
6951 maplist(single_component, Ts)), _).
6952
6953single_component(V) :- get_attr(V, lowlink, 0).
6954
6955circuit_graph([], _, _).
6956circuit_graph([V|Vs], Ts0, [T|Ts]) :-
6957 ( nonvar(V) -> Ns = [V]
6958 ; fd_get(V, Dom, _),
6959 domain_to_list(Dom, Ns)
6960 ),
6961 phrase(circuit_edges(Ns, Ts0), Es),
6962 put_attr(T, edges, Es),
6963 circuit_graph(Vs, Ts0, Ts).
6964
6965circuit_edges([], _) --> [].
6966circuit_edges([N|Ns], Ts) -->
6967 { nth1(N, Ts, T) },
6968 [arc_to(T)],
6969 circuit_edges(Ns, Ts).
6970
6971circuit_successors(V, Tos) :-
6972 get_attr(V, edges, Tos0),
6973 maplist(arg(1), Tos0, Tos).
6974
6975%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6976
6977%% cumulative(+Tasks)
6978%
6979% Equivalent to cumulative(Tasks, [limit(1)]).
6980
6981cumulative(Tasks) :- cumulative(Tasks, [limit(1)]).
6982
6983%% cumulative(+Tasks, +Options)
6984%
6985% Schedule with a limited resource. Tasks is a list of tasks, each of
6986% the form task(S_i, D_i, E_i, C_i, T_i). S_i denotes the start time,
6987% D_i the positive duration, E_i the end time, C_i the non-negative
6988% resource consumption, and T_i the task identifier. Each of these
6989% arguments must be a finite domain variable with bounded domain, or
6990% an integer. The constraint holds iff at each time slot during the
6991% start and end of each task, the total resource consumption of all
6992% tasks running at that time does not exceed the global resource
6993% limit. Options is a list of options. Currently, the only supported
6994% option is:
6995%
6996% * limit(L)
6997% The integer L is the global resource limit. Default is 1.
6998%
6999% For example, given the following predicate that relates three tasks
7000% of durations 2 and 3 to a list containing their starting times:
7001%
7002% ==
7003% tasks_starts(Tasks, [S1,S2,S3]) :-
7004% Tasks = [task(S1,3,_,1,_),
7005% task(S2,2,_,1,_),
7006% task(S3,2,_,1,_)].
7007% ==
7008%
7009% We can use cumulative/2 as follows, and obtain a schedule:
7010%
7011% ==
7012% ?- tasks_starts(Tasks, Starts), Starts ins 0..10,
7013% cumulative(Tasks, [limit(2)]), label(Starts).
7014% Tasks = [task(0, 3, 3, 1, _G36), task(0, 2, 2, 1, _G45), ...],
7015% Starts = [0, 0, 2] .
7016% ==
7017
7018cumulative(Tasks, Options) :-
7019 must_be(list(list), [Tasks,Options]),
7020 ( Options = [] -> L = 1
7021 ; Options = [limit(L)] -> must_be(integer, L)
7022 ; domain_error(cumulative_options_empty_or_limit, Options)
7023 ),
7024 ( Tasks = [] -> true
7025 ; fully_elastic_relaxation(Tasks, L),
7026 maplist(task_bs, Tasks, Bss),
7027 maplist(arg(1), Tasks, Starts),
7028 maplist(fd_inf, Starts, MinStarts),
7029 maplist(arg(3), Tasks, Ends),
7030 maplist(fd_sup, Ends, MaxEnds),
7031 MinStarts = [Min|Mins],
7032 foldl(min_, Mins, Min, Start),
7033 MaxEnds = [Max|Maxs],
7034 foldl(max_, Maxs, Max, End),
7035 resource_limit(Start, End, Tasks, Bss, L)
7036 ).
7037
7038/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7039 Trivial lower and upper bounds, assuming no gaps and not necessarily
7040 retaining the rectangular shape of each task.
7041- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7042
7043fully_elastic_relaxation(Tasks, Limit) :-
7044 maplist(task_duration_consumption, Tasks, Ds, Cs),
7045 maplist(area, Ds, Cs, As),
7046 sum(As, #=, ?(Area)),
7047 ?(MinTime) #= (Area + Limit - 1) // Limit,
7048 tasks_minstart_maxend(Tasks, MinStart, MaxEnd),
7049 MaxEnd #>= MinStart + MinTime.
7050
7051task_duration_consumption(task(_,D,_,C,_), D, C).
7052
7053area(X, Y, Area) :- ?(Area) #= ?(X) * ?(Y).
7054
7055tasks_minstart_maxend(Tasks, Start, End) :-
7056 maplist(task_start_end, Tasks, [Start0|Starts], [End0|Ends]),
7057 foldl(min_, Starts, Start0, Start),
7058 foldl(max_, Ends, End0, End).
7059
7060max_(E, M0, M) :- ?(M) #= max(E, M0).
7061
7062min_(E, M0, M) :- ?(M) #= min(E, M0).
7063
7064task_start_end(task(Start,_,End,_,_), ?(Start), ?(End)).
7065
7066/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7067 All time slots must respect the resource limit.
7068- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7069
7070resource_limit(T, T, _, _, _) :- !.
7071resource_limit(T0, T, Tasks, Bss, L) :-
7072 maplist(contribution_at(T0), Tasks, Bss, Cs),
7073 sum(Cs, #=<, L),
7074 T1 is T0 + 1,
7075 resource_limit(T1, T, Tasks, Bss, L).
7076
7077task_bs(Task, InfStart-Bs) :-
7078 Task = task(Start,D,End,_,_Id),
7079 ?(D) #> 0,
7080 ?(End) #= ?(Start) + ?(D),
7081 maplist(finite_domain, [End,Start,D]),
7082 fd_inf(Start, InfStart),
7083 fd_sup(End, SupEnd),
7084 L is SupEnd - InfStart,
7085 length(Bs, L),
7086 task_running(Bs, Start, End, InfStart).
7087
7088task_running([], _, _, _).
7089task_running([B|Bs], Start, End, T) :-
7090 ((T #>= Start) #/\ (T #< End)) #<==> ?(B),
7091 T1 is T + 1,
7092 task_running(Bs, Start, End, T1).
7093
7094contribution_at(T, Task, Offset-Bs, Contribution) :-
7095 Task = task(Start,_,End,C,_),
7096 ?(C) #>= 0,
7097 fd_inf(Start, InfStart),
7098 fd_sup(End, SupEnd),
7099 ( T < InfStart -> Contribution = 0
7100 ; T >= SupEnd -> Contribution = 0
7101 ; Index is T - Offset,
7102 nth0(Index, Bs, B),
7103 ?(Contribution) #= B*C
7104 ).
7105
7106nth1(I, Es, E) :-
7107 I0 is I-1,
7108 nth0(I0, Es, E).
7109
7110%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7111
7112%% disjoint2(+Rectangles)
7113%
7114% True iff Rectangles are not overlapping. Rectangles is a list of
7115% terms of the form F(X_i, W_i, Y_i, H_i), where F is any functor,
7116% and the arguments are finite domain variables or integers that
7117% denote, respectively, the X coordinate, width, Y coordinate and
7118% height of each rectangle.
7119
7120disjoint2(Rs0) :-
7121 must_be(list, Rs0),
7122 maplist(=.., Rs0, Rs),
7123 non_overlapping(Rs).
7124
7125non_overlapping([]).
7126non_overlapping([R|Rs]) :-
7127 maplist(non_overlapping_(R), Rs),
7128 non_overlapping(Rs).
7129
7130non_overlapping_(A, B) :-
7131 a_not_in_b(A, B),
7132 a_not_in_b(B, A).
7133
7134a_not_in_b([_,AX,AW,AY,AH], [_,BX,BW,BY,BH]) :-
7135 ?(AX) #=< ?(BX) #/\ ?(BX) #< ?(AX) + ?(AW) #==>
7136 ?(AY) + ?(AH) #=< ?(BY) #\/ ?(BY) + ?(BH) #=< ?(AY),
7137 ?(AY) #=< ?(BY) #/\ ?(BY) #< ?(AY) + ?(AH) #==>
7138 ?(AX) + ?(AW) #=< ?(BX) #\/ ?(BX) + ?(BW) #=< ?(AX).
7139
7140%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7141
7142%% automaton(+Vs, +Nodes, +Arcs)
7143%
7144% Describes a list of finite domain variables with a finite
7145% automaton. Equivalent to automaton(Vs, _, Vs, Nodes, Arcs,
7146% [], [], _), a common use case of automaton/8. In the following
7147% example, a list of binary finite domain variables is constrained to
7148% contain at least two consecutive ones:
7149%
7150% ==
7151% two_consecutive_ones(Vs) :-
7152% automaton(Vs, [source(a),sink(c)],
7153% [arc(a,0,a), arc(a,1,b),
7154% arc(b,0,a), arc(b,1,c),
7155% arc(c,0,c), arc(c,1,c)]).
7156% ==
7157%
7158% Example query:
7159%
7160% ==
7161% ?- length(Vs, 3), two_consecutive_ones(Vs), label(Vs).
7162% Vs = [0, 1, 1] ;
7163% Vs = [1, 1, 0] ;
7164% Vs = [1, 1, 1].
7165% ==
7166
7167automaton(Sigs, Ns, As) :- automaton(_, _, Sigs, Ns, As, [], [], _).
7168
7169
7170%% automaton(+Sequence, ?Template, +Signature, +Nodes, +Arcs, +Counters, +Initials, ?Finals)
7171%
7172% Describes a list of finite domain variables with a finite
7173% automaton. True iff the finite automaton induced by Nodes and Arcs
7174% (extended with Counters) accepts Signature. Sequence is a list of
7175% terms, all of the same shape. Additional constraints must link
7176% Sequence to Signature, if necessary. Nodes is a list of
7177% source(Node) and sink(Node) terms. Arcs is a list of
7178% arc(Node,Integer,Node) and arc(Node,Integer,Node,Exprs) terms that
7179% denote the automaton's transitions. Each node is represented by an
7180% arbitrary term. Transitions that are not mentioned go to an
7181% implicit failure node. `Exprs` is a list of arithmetic expressions,
7182% of the same length as Counters. In each expression, variables
7183% occurring in Counters symbolically refer to previous counter
7184% values, and variables occurring in Template refer to the current
7185% element of Sequence. When a transition containing arithmetic
7186% expressions is taken, each counter is updated according to the
7187% result of the corresponding expression. When a transition without
7188% arithmetic expressions is taken, all counters remain unchanged.
7189% Counters is a list of variables. Initials is a list of finite
7190% domain variables or integers denoting, in the same order, the
7191% initial value of each counter. These values are related to Finals
7192% according to the arithmetic expressions of the taken transitions.
7193%
7194% The following example is taken from Beldiceanu, Carlsson, Debruyne
7195% and Petit: "Reformulation of Global Constraints Based on
7196% Constraints Checkers", Constraints 10(4), pp 339-362 (2005). It
7197% relates a sequence of integers and finite domain variables to its
7198% number of inflexions, which are switches between strictly ascending
7199% and strictly descending subsequences:
7200%
7201% ==
7202% sequence_inflexions(Vs, N) :-
7203% variables_signature(Vs, Sigs),
7204% automaton(Sigs, _, Sigs,
7205% [source(s),sink(i),sink(j),sink(s)],
7206% [arc(s,0,s), arc(s,1,j), arc(s,2,i),
7207% arc(i,0,i), arc(i,1,j,[C+1]), arc(i,2,i),
7208% arc(j,0,j), arc(j,1,j),
7209% arc(j,2,i,[C+1])],
7210% [C], [0], [N]).
7211%
7212% variables_signature([], []).
7213% variables_signature([V|Vs], Sigs) :-
7214% variables_signature_(Vs, V, Sigs).
7215%
7216% variables_signature_([], _, []).
7217% variables_signature_([V|Vs], Prev, [S|Sigs]) :-
7218% V #= Prev #<==> S #= 0,
7219% Prev #< V #<==> S #= 1,
7220% Prev #> V #<==> S #= 2,
7221% variables_signature_(Vs, V, Sigs).
7222% ==
7223%
7224% Example queries:
7225%
7226% ==
7227% ?- sequence_inflexions([1,2,3,3,2,1,3,0], N).
7228% N = 3.
7229%
7230% ?- length(Ls, 5), Ls ins 0..1,
7231% sequence_inflexions(Ls, 3), label(Ls).
7232% Ls = [0, 1, 0, 1, 0] ;
7233% Ls = [1, 0, 1, 0, 1].
7234% ==
7235
7236template_var_path(V, Var, []) :- var(V), !, V == Var.
7237template_var_path(T, Var, [N|Ns]) :-
7238 arg(N, T, Arg),
7239 template_var_path(Arg, Var, Ns).
7240
7241path_term_variable([], V, V).
7242path_term_variable([P|Ps], T, V) :-
7243 arg(P, T, Arg),
7244 path_term_variable(Ps, Arg, V).
7245
7246initial_expr(_, []-1).
7247
7248automaton(Seqs, Template, Sigs, Ns, As0, Cs, Is, Fs) :-
7249 must_be(list(list), [Sigs,Ns,As0,Cs,Is]),
7250 ( var(Seqs) ->
7251 ( monotonic ->
7252 instantiation_error(Seqs)
7253 ; Seqs = Sigs
7254 )
7255 ; must_be(list, Seqs)
7256 ),
7257 maplist(monotonic, Cs, CsM),
7258 maplist(arc_normalized(CsM), As0, As),
7259 include_args1(sink, Ns, Sinks),
7260 include_args1(source, Ns, Sources),
7261 maplist(initial_expr, Cs, Exprs0),
7262 phrase((arcs_relation(As, Relation),
7263 nodes_nums(Sinks, SinkNums0),
7264 nodes_nums(Sources, SourceNums0)),
7265 [s([]-0, Exprs0)], [s(_,Exprs1)]),
7266 maplist(expr0_expr, Exprs1, Exprs),
7267 phrase(transitions(Seqs, Template, Sigs, Start, End, Exprs, Cs, Is, Fs), Tuples),
7268 list_to_drep(SourceNums0, SourceDrep),
7269 Start in SourceDrep,
7270 list_to_drep(SinkNums0, SinkDrep),
7271 End in SinkDrep,
7272 tuples_in(Tuples, Relation).
7273
7274expr0_expr(Es0-_, Es) :-
7275 pairs_keys(Es0, Es1),
7276 reverse(Es1, Es).
7277
7278transitions([], _, [], S, S, _, _, Cs, Cs) --> [].
7279transitions([Seq|Seqs], Template, [Sig|Sigs], S0, S, Exprs, Counters, Cs0, Cs) -->
7280 [[S0,Sig,S1|Is]],
7281 { phrase(exprs_next(Exprs, Is, Cs1), [s(Seq,Template,Counters,Cs0)], _) },
7282 transitions(Seqs, Template, Sigs, S1, S, Exprs, Counters, Cs1, Cs).
7283
7284exprs_next([], [], []) --> [].
7285exprs_next([Es|Ess], [I|Is], [C|Cs]) -->
7286 exprs_values(Es, Vs),
7287 { element(I, Vs, C) },
7288 exprs_next(Ess, Is, Cs).
7289
7290exprs_values([], []) --> [].
7291exprs_values([E0|Es], [V|Vs]) -->
7292 { term_variables(E0, EVs0),
7293 copy_term(E0, E),
7294 term_variables(E, EVs),
7295 ?(V) #= E },
7296 match_variables(EVs0, EVs),
7297 exprs_values(Es, Vs).
7298
7299match_variables([], _) --> [].
7300match_variables([V0|Vs0], [V|Vs]) -->
7301 state(s(Seq,Template,Counters,Cs0)),
7302 { ( template_var_path(Template, V0, Ps) ->
7303 path_term_variable(Ps, Seq, V)
7304 ; template_var_path(Counters, V0, Ps) ->
7305 path_term_variable(Ps, Cs0, V)
7306 ; domain_error(variable_from_template_or_counters, V0)
7307 ) },
7308 match_variables(Vs0, Vs).
7309
7310nodes_nums([], []) --> [].
7311nodes_nums([Node|Nodes], [Num|Nums]) -->
7312 node_num(Node, Num),
7313 nodes_nums(Nodes, Nums).
7314
7315arcs_relation([], []) --> [].
7316arcs_relation([arc(S0,L,S1,Es)|As], [[From,L,To|Ns]|Rs]) -->
7317 node_num(S0, From),
7318 node_num(S1, To),
7319 state(s(Nodes, Exprs0), s(Nodes, Exprs)),
7320 { exprs_nums(Es, Ns, Exprs0, Exprs) },
7321 arcs_relation(As, Rs).
7322
7323exprs_nums([], [], [], []).
7324exprs_nums([E|Es], [N|Ns], [Ex0-C0|Exs0], [Ex-C|Exs]) :-
7325 ( member(Exp-N, Ex0), Exp == E -> C = C0, Ex = Ex0
7326 ; N = C0, C is C0 + 1, Ex = [E-C0|Ex0]
7327 ),
7328 exprs_nums(Es, Ns, Exs0, Exs).
7329
7330node_num(Node, Num) -->
7331 state(s(Nodes0-C0, Exprs), s(Nodes-C, Exprs)),
7332 { ( member(N-Num, Nodes0), N == Node -> C = C0, Nodes = Nodes0
7333 ; Num = C0, C is C0 + 1, Nodes = [Node-C0|Nodes0]
7334 )
7335 }.
7336
7337include_args1(Goal, Ls0, As) :-
7338 include(Goal, Ls0, Ls),
7339 maplist(arg(1), Ls, As).
7340
7341source(source(_)).
7342
7343sink(sink(_)).
7344
7345monotonic(Var, ?(Var)).
7346
7347arc_normalized(Cs, Arc0, Arc) :- arc_normalized_(Arc0, Cs, Arc).
7348
7349arc_normalized_(arc(S0,L,S,Cs), _, arc(S0,L,S,Cs)).
7350arc_normalized_(arc(S0,L,S), Cs, arc(S0,L,S,Cs)).
7351
7352%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7353
7354%% zcompare(?Order, ?A, ?B)
7355%
7356% Analogous to compare/3, with finite domain variables A and B.
7357%
7358% This predicate allows you to make several predicates over integers
7359% deterministic while preserving their generality and completeness.
7360% For example:
7361%
7362% ==
7363% n_factorial(N, F) :-
7364% zcompare(C, N, 0),
7365% n_factorial_(C, N, F).
7366%
7367% n_factorial_(=, _, 1).
7368% n_factorial_(>, N, F) :-
7369% F #= F0*N, N1 #= N - 1,
7370% n_factorial(N1, F0).
7371% ==
7372%
7373% This version is deterministic if the first argument is instantiated,
7374% because first argument indexing can distinguish the two different
7375% clauses:
7376%
7377% ==
7378% ?- n_factorial(30, F).
7379% F = 265252859812191058636308480000000.
7380% ==
7381%
7382% The predicate can still be used in all directions, including the
7383% most general query:
7384%
7385% ==
7386% ?- n_factorial(N, F).
7387% N = 0,
7388% F = 1 ;
7389% N = F, F = 1 ;
7390% N = F, F = 2 .
7391% ==
7392
7393zcompare(Order, A, B) :-
7394 ( nonvar(Order) ->
7395 zcompare_(Order, A, B)
7396 ; integer(A), integer(B) ->
7397 compare(Order, A, B)
7398 ; freeze(Order, zcompare_(Order, A, B)),
7399 fd_variable(A),
7400 fd_variable(B),
7401 propagator_init_trigger([A,B], pzcompare(Order, A, B))
7402 ).
7403
7404zcompare_(=, A, B) :- ?(A) #= ?(B).
7405zcompare_(<, A, B) :- ?(A) #< ?(B).
7406zcompare_(>, A, B) :- ?(A) #> ?(B).
7407
7408%% chain(+Relation, +Zs)
7409%
7410% Zs form a chain with respect to Relation. Zs is a list of finite
7411% domain variables that are a chain with respect to the partial order
7412% Relation, in the order they appear in the list. Relation must be #=,
7413% #=<, #>=, #< or #>. For example:
7414%
7415% ==
7416% ?- chain(#>=, [X,Y,Z]).
7417% X#>=Y,
7418% Y#>=Z.
7419% ==
7420
7421chain(Relation, Zs) :-
7422 must_be(list, Zs),
7423 maplist(fd_variable, Zs),
7424 must_be(ground, Relation),
7425 ( chain_relation(Relation) -> true
7426 ; domain_error(chain_relation, Relation)
7427 ),
7428 chain_(Zs, Relation).
7429
7430chain_([], _).
7431chain_([X|Xs], Relation) :- foldl(chain(Relation), Xs, X, _).
7432
7433chain_relation(#=).
7434chain_relation(#<).
7435chain_relation(#=<).
7436chain_relation(#>).
7437chain_relation(#>=).
7438
7439chain(Relation, X, Prev, X) :- call(Relation, ?(Prev), ?(X)).
7440
7441%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7442/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7443 Reflection predicates
7444- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7445
7446%% fd_var(+Var)
7447%
7448% True iff Var is a CLP(ℤ) variable.
7449
7450fd_var(X) :- get_attr(X, clpz, _).
7451
7452%% fd_inf(+Var, -Inf)
7453%
7454% Inf is the infimum of the current domain of Var.
7455
7456fd_inf(X, Inf) :-
7457 ( fd_get(X, XD, _) ->
7458 domain_infimum(XD, Inf0),
7459 bound_portray(Inf0, Inf)
7460 ; must_be(integer, X),
7461 Inf = X
7462 ).
7463
7464%% fd_sup(+Var, -Sup)
7465%
7466% Sup is the supremum of the current domain of Var.
7467
7468fd_sup(X, Sup) :-
7469 ( fd_get(X, XD, _) ->
7470 domain_supremum(XD, Sup0),
7471 bound_portray(Sup0, Sup)
7472 ; must_be(integer, X),
7473 Sup = X
7474 ).
7475
7476%% fd_size(+Var, -Size)
7477%
7478% Size is the number of elements of the current domain of Var, or the
7479% atom *sup* if the domain is unbounded.
7480
7481fd_size(X, S) :-
7482 ( fd_get(X, XD, _) ->
7483 domain_num_elements(XD, S0),
7484 bound_portray(S0, S)
7485 ; must_be(integer, X),
7486 S = 1
7487 ).
7488
7489%% fd_dom(+Var, -Dom)
7490%
7491% Dom is the current domain (see in/2) of Var. This predicate is
7492% useful if you want to reason about domains. It is _not_ needed if
7493% you only want to display remaining domains; instead, separate your
7494% model from the search part and let the toplevel display this
7495% information via residual goals.
7496%
7497% For example, to implement a custom labeling strategy, you may need
7498% to inspect the current domain of a finite domain variable. With the
7499% following code, you can convert a _finite_ domain to a list of
7500% integers:
7501%
7502% ==
7503% dom_integers(D, Is) :- phrase(dom_integers_(D), Is).
7504%
7505% dom_integers_(I) --> { integer(I) }, [I].
7506% dom_integers_(L..U) --> { numlist(L, U, Is) }, Is.
7507% dom_integers_(D1\/D2) --> dom_integers_(D1), dom_integers_(D2).
7508% ==
7509%
7510% Example:
7511%
7512% ==
7513% ?- X in 1..5, X #\= 4, fd_dom(X, D), dom_integers(D, Is).
7514% D = 1..3\/5,
7515% Is = [1,2,3,5],
7516% X in 1..3\/5.
7517% ==
7518
7519fd_dom(X, Drep) :-
7520 ( fd_get(X, XD, _) ->
7521 domain_to_drep(XD, Drep)
7522 ; must_be(integer, X),
7523 Drep = X..X
7524 ).
7525
7526/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7527 Entailment detection. Subject to change.
7528
7529 Currently, Goals entail E if posting ({#\ E} U Goals), then
7530 labeling all variables, fails. E must be reifiable. Examples:
7531
7532 %?- clpz:goals_entail([X#>2], X #> 3).
7533 %@ false.
7534
7535 %?- clpz:goals_entail([X#>1, X#<3], X #= 2).
7536 %@ true.
7537
7538 %?- clpz:goals_entail([X#=Y+1], X #= Y+1).
7539 %@ ERROR: Arguments are not sufficiently instantiated
7540 %@ Exception: (15) throw(error(instantiation_error, _G2680)) ?
7541
7542 %?- clpz:goals_entail([[X,Y] ins 0..10, X#=Y+1], X #= Y+1).
7543 %@ true.
7544
7545- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7546
7547goals_entail(Goals, E) :-
7548 must_be(list, Goals),
7549 \+ ( maplist(call, Goals), #\ E,
7550 term_variables(Goals-E, Vs),
7551 label(Vs)
7552 ).
7553
7554/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7555 Unification hook and constraint projection
7556- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7557
7558verify_attributes(Var, Other, Gs) :-
7559 % portray_clause(Var = Other),
7560 ( get_atts(Var, clpz(CLPZ)) ->
7561 CLPZ = clpz_attr(_,_,_,Dom,Ps,Q),
7562 ( nonvar(Other) ->
7563 ( integer(Other) -> true
7564 ; type_error(integer, Other)
7565 ),
7566 domain_contains(Dom, Other),
7567 phrase(trigger_props(Ps), [Q], [_]),
7568 Gs = [phrase(do_queue, [Q], _)]
7569 ; ( get_atts(Other, clpz(clpz_attr(_,_,_,OD,OPs,_))) ->
7570 domains_intersection(OD, Dom, Dom1),
7571 append_propagators(Ps, OPs, Ps1),
7572 new_queue(Q0),
7573 variables_same_queue([Var,Other]),
7574 phrase((fd_put(Other,Dom1,Ps1),
7575 trigger_props(Ps1)), [Q0], _),
7576 Gs = [phrase(do_queue, [Q0], _)]
7577 ; put_atts(Other, clpz(CLPZ)),
7578 Gs = []
7579 )
7580 )
7581 ; Gs = []
7582 ).
7583
7584append_propagators(fd_props(Gs0,Bs0,Os0), fd_props(Gs1,Bs1,Os1), fd_props(Gs,Bs,Os)) :-
7585 maplist(append, [Gs0,Bs0,Os0], [Gs1,Bs1,Os1], [Gs,Bs,Os]).
7586
7587bound_portray(inf, inf).
7588bound_portray(sup, sup).
7589bound_portray(n(N), N).
7590
7591list_to_drep(List, Drep) :-
7592 list_to_domain(List, Dom),
7593 domain_to_drep(Dom, Drep).
7594
7595domain_to_drep(Dom, Drep) :-
7596 domain_intervals(Dom, [A0-B0|Rest]),
7597 bound_portray(A0, A),
7598 bound_portray(B0, B),
7599 ( A == B -> Drep0 = A
7600 ; Drep0 = A..B
7601 ),
7602 intervals_to_drep(Rest, Drep0, Drep).
7603
7604intervals_to_drep([], Drep, Drep).
7605intervals_to_drep([A0-B0|Rest], Drep0, Drep) :-
7606 bound_portray(A0, A),
7607 bound_portray(B0, B),
7608 ( A == B -> D1 = A
7609 ; D1 = A..B
7610 ),
7611 intervals_to_drep(Rest, Drep0 \/ D1, Drep).
7612
7613attribute_goals(X) -->
7614 { get_atts(X, queue(_,_)) },
7615 !,
7616 { put_atts(X, -queue(_,_)) }.
7617attribute_goals(X) -->
7618 % { get_attr(X, clpz, Attr), format("A: ~w\n", [Attr]) },
7619 { get_attr(X, clpz, clpz_attr(_,_,_,Dom,fd_props(Gs,Bs,Os),_)),
7620 append(Gs, Bs, Ps0),
7621 append(Ps0, Os, Ps),
7622 domain_to_drep(Dom, Drep) },
7623 ( { default_domain(Dom), \+ all_dead_(Ps) } -> []
7624 ; [clpz:(X in Drep)]
7625 ),
7626 attributes_goals(Ps),
7627 { del_attr(X, clpz) }.
7628
7629attributes_goals([]) --> [].
7630attributes_goals([propagator(P, State)|As]) -->
7631 ( { ground(State) } -> []
7632 ; { phrase(attribute_goal_(P), Gs) } ->
7633 { % del_attr(State, clpz_aux), State = processed,
7634 ( monotonic ->
7635 maplist(unwrap_with(bare_integer), Gs, Gs1)
7636 ; maplist(unwrap_with(=), Gs, Gs1)
7637 ),
7638 maplist(with_clpz, Gs1, Gs2) },
7639 list(Gs2)
7640 ; [P] % possibly user-defined constraint
7641 ),
7642 attributes_goals(As).
7643
7644with_clpz(G, clpz:G).
7645
7646unwrap_with(_, V, V) :- var(V), !.
7647unwrap_with(Goal, ?(V0), V) :- !, call(Goal, V0, V).
7648unwrap_with(Goal, Term0, Term) :-
7649 Term0 =.. [F|Args0],
7650 maplist(unwrap_with(Goal), Args0, Args),
7651 Term =.. [F|Args].
7652
7653bare_integer(V0, V) :- ( integer(V0) -> V = V0 ; V = #(V0) ).
7654
7655attribute_goal_(presidual(Goal)) --> [Goal].
7656attribute_goal_(pgeq(A,B)) --> [?(A) #>= ?(B)].
7657attribute_goal_(pplus(X,Y,Z)) --> [?(X) + ?(Y) #= ?(Z)].
7658attribute_goal_(pneq(A,B)) --> [?(A) #\= ?(B)].
7659attribute_goal_(ptimes(X,Y,Z)) --> [?(X) * ?(Y) #= ?(Z)].
7660attribute_goal_(absdiff_neq(X,Y,C)) --> [abs(?(X) - ?(Y)) #\= C].
7661attribute_goal_(x_eq_abs_plus_v(X,V)) --> [?(X) #= abs(?(X)) + ?(V)].
7662attribute_goal_(x_neq_y_plus_z(X,Y,Z)) --> [?(X) #\= ?(Y) + ?(Z)].
7663attribute_goal_(x_leq_y_plus_c(X,Y,C)) --> [?(X) #=< ?(Y) + C].
7664attribute_goal_(ptzdiv(X,Y,Z)) --> [?(X) // ?(Y) #= ?(Z)].
7665attribute_goal_(pdiv(X,Y,Z)) --> [?(X) div ?(Y) #= ?(Z)].
7666attribute_goal_(prdiv(X,Y,Z)) --> [?(X) / ?(Y) #= ?(Z)].
7667attribute_goal_(pexp(X,Y,Z)) --> [?(X) ^ ?(Y) #= ?(Z)].
7668attribute_goal_(pabs(X,Y)) --> [?(Y) #= abs(?(X))].
7669attribute_goal_(pmod(X,M,K)) --> [?(X) mod ?(M) #= ?(K)].
7670attribute_goal_(prem(X,Y,Z)) --> [?(X) rem ?(Y) #= ?(Z)].
7671attribute_goal_(pmax(X,Y,Z)) --> [?(Z) #= max(?(X),?(Y))].
7672attribute_goal_(pmin(X,Y,Z)) --> [?(Z) #= min(?(X),?(Y))].
7673attribute_goal_(pxor(X,Y,Z)) --> [?(Z) #= xor(?(X), ?(Y))].
7674attribute_goal_(scalar_product_neq(Cs,Vs,C)) -->
7675 [Left #\= Right],
7676 { scalar_product_left_right([-1|Cs], [C|Vs], Left, Right) }.
7677attribute_goal_(scalar_product_eq(Cs,Vs,C)) -->
7678 [Left #= Right],
7679 { scalar_product_left_right([-1|Cs], [C|Vs], Left, Right) }.
7680attribute_goal_(scalar_product_leq(Cs,Vs,C)) -->
7681 [Left #=< Right],
7682 { scalar_product_left_right([-1|Cs], [C|Vs], Left, Right) }.
7683attribute_goal_(pdifferent(_,_,_,O)) --> original_goal(O).
7684attribute_goal_(weak_distinct(_,_,_,O)) --> original_goal(O).
7685attribute_goal_(pdistinct(Vs)) --> [all_distinct(Vs)].
7686attribute_goal_(pnvalue(N, Vs)) --> [nvalue(N, Vs)].
7687attribute_goal_(pexclude(_,_,_)) --> [].
7688attribute_goal_(pelement(N,Is,V)) --> [element(N, Is, V)].
7689attribute_goal_(pgcc(Vs, Pairs, _)) --> [global_cardinality(Vs, Pairs)].
7690attribute_goal_(pgcc_single(_,_)) --> [].
7691attribute_goal_(pgcc_check_single(_)) --> [].
7692attribute_goal_(pgcc_check(Pairs)) -->
7693 { pairs_values(Pairs, Nums),
7694 maplist(gcc_done, Nums) }.
7695attribute_goal_(pcircuit(Vs)) --> [circuit(Vs)].
7696attribute_goal_(pserialized(_,_,_,_,O)) --> original_goal(O).
7697attribute_goal_(rel_tuple(R, Tuple)) -->
7698 { get_attr(R, clpz_relation, Rel) },
7699 [tuples_in([Tuple], Rel)].
7700attribute_goal_(pzcompare(O,A,B)) --> [zcompare(O,A,B)].
7701% reified constraints
7702attribute_goal_(reified_in(V, D, B)) -->
7703 [V in Drep #<==> ?(B)],
7704 { domain_to_drep(D, Drep) }.
7705attribute_goal_(reified_tuple_in(Tuple, R, B)) -->
7706 { get_attr(R, clpz_relation, Rel) },
7707 [tuples_in([Tuple], Rel) #<==> ?(B)].
7708attribute_goal_(kill_reified_tuples(_,_,_)) --> [].
7709attribute_goal_(tuples_not_in(_,_,_)) --> [].
7710attribute_goal_(reified_fd(V,B)) --> [finite_domain(V) #<==> ?(B)].
7711attribute_goal_(pskeleton(X,Y,D,_,Z,F)) -->
7712 { Prop =.. [F,X,Y,Z],
7713 phrase(attribute_goal_(Prop), Goals), list_goal(Goals, Goal) },
7714 [?(D) #= 1 #==> Goal, ?(Y) #\= 0 #==> ?(D) #= 1].
7715attribute_goal_(reified_neq(DX,X,DY,Y,_,B)) -->
7716 conjunction(DX, DY, ?(X) #\= ?(Y), B).
7717attribute_goal_(reified_eq(DX,X,DY,Y,_,B)) -->
7718 conjunction(DX, DY, ?(X) #= ?(Y), B).
7719attribute_goal_(reified_geq(DX,X,DY,Y,_,B)) -->
7720 conjunction(DX, DY, ?(X) #>= ?(Y), B).
7721attribute_goal_(reified_and(X,_,Y,_,B)) --> [?(X) #/\ ?(Y) #<==> ?(B)].
7722attribute_goal_(reified_or(X, _, Y, _, B)) --> [?(X) #\/ ?(Y) #<==> ?(B)].
7723attribute_goal_(reified_not(X, Y)) --> [#\ ?(X) #<==> ?(Y)].
7724attribute_goal_(pimpl(X, Y, _)) --> [?(X) #==> ?(Y)].
7725attribute_goal_(pfunction(Op, A, B, R)) -->
7726 { Expr =.. [Op,?(A),?(B)] },
7727 [?(R) #= Expr].
7728attribute_goal_(pfunction(Op, A, R)) -->
7729 { Expr =.. [Op,?(A)] },
7730 [?(R) #= Expr].
7731
7732conjunction(A, B, G, D) -->
7733 ( { A == 1, B == 1 } -> [G #<==> ?(D)]
7734 ; { A == 1 } -> [(?(B) #/\ G) #<==> ?(D)]
7735 ; { B == 1 } -> [(?(A) #/\ G) #<==> ?(D)]
7736 ; [(?(A) #/\ ?(B) #/\ G) #<==> ?(D)]
7737 ).
7738
7739original_goal(original_goal(State, Goal)) -->
7740 ( { var(State) } ->
7741% { State = processed },
7742 [Goal]
7743 ; []
7744 ).
7745
7746/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7747 Projection of scalar product.
7748- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7749
7750scalar_product_left_right(Cs, Vs, Left, Right) :-
7751 pairs_keys_values(Pairs0, Cs, Vs),
7752 partition(ground, Pairs0, Grounds, Pairs),
7753 maplist(pair_product, Grounds, Prods),
7754 sum_list(Prods, Const),
7755 NConst is -Const,
7756 partition(compare_coeff0, Pairs, Negatives, _, Positives),
7757 maplist(negate_coeff, Negatives, Rights),
7758 scalar_plusterm(Rights, Right0),
7759 scalar_plusterm(Positives, Left0),
7760 ( Const =:= 0 -> Left = Left0, Right = Right0
7761 ; Right0 == 0 -> Left = Left0, Right = NConst
7762 ; Left0 == 0 -> Left = Const, Right = Right0
7763 ; ( Const < 0 ->
7764 Left = Left0, Right = Right0+NConst
7765 ; Left = Left0+Const, Right = Right0
7766 )
7767 ).
7768
7769negate_coeff(A0-B, A-B) :- A is -A0.
7770
7771pair_product(A-B, Prod) :- Prod is A*B.
7772
7773compare_coeff0(Coeff-_, Compare) :- compare(Compare, Coeff, 0).
7774
7775scalar_plusterm([], 0).
7776scalar_plusterm([CV|CVs], T) :-
7777 coeff_var_term(CV, T0),
7778 foldl(plusterm_, CVs, T0, T).
7779
7780plusterm_(CV, T0, T0+T) :- coeff_var_term(CV, T).
7781
7782coeff_var_term(C-V, T) :- ( C =:= 1 -> T = ?(V) ; T = C * ?(V) ).
7783
7784/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7785 Reified predicates for use with predicates from library(reif).
7786- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7787
7788#=(X, Y, T) :-
7789 X #= Y #<==> B,
7790 zo_t(B, T).
7791
7792#<(X, Y, T) :-
7793 X #< Y #<==> B,
7794 zo_t(B, T).
7795
7796zo_t(0, false).
7797zo_t(1, true).
7798
7799/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
7800 Generated predicates
7801- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
7802
7803term_expansion(make_parse_clpz, Clauses) :- make_parse_clpz(Clauses).
7804term_expansion(make_parse_reified, Clauses) :- make_parse_reified(Clauses).
7805term_expansion(make_matches, Clauses) :- make_matches(Clauses).
7806
7807make_parse_clpz.
7808make_parse_reified.
7809make_matches.
7810