1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): ECRC GmbH 21% Contributor(s): IC-Parc, Imperal College London 22% 23% END LICENSE BLOCK 24% 25% System: ECLiPSe Constraint Logic Programming System 26% Version: $Id: fd_domain.pl,v 1.4 2013/02/12 17:53:36 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29/* 30 * SEPIA PROLOG SOURCE MODULE 31 */ 32 33/* 34 * FINITE DOMAINS 35 * 36 * IDENTIFICATION: fd_domain.pl 37 * 38 * AUTHOR: Micha Meier 39 * 40 * DESCRIPTION: Finite domain data type and the handling of 41 the 'fd' attribute. 42 */ 43 44 45:- module(fd_domain). 46 47:- export syntax_option(dense_output). 48 49:- reexport 50 % domain access 51 dom_range/3, 52 dom_check_in/2, 53 54 % domain modification 55 dvar_replace/2, 56 dvar_remove_element/2, 57 dvar_remove_greater/2, 58 dvar_remove_smaller/2, 59 60 % domain processing 61 dom_compare/3, 62 dom_intersection/4, 63 dom_union/4, 64 dom_difference/4, 65 66 integer_list_to_dom/2 67 from sepia_kernel. 68 69 /***************************************************************** 70 * A domain variable that apears in some constraints is represented 71 * by a metaterm. 72 * The metaterm is represented by 73 */ 74 75:- export struct(fd(domain, min, max, any)). 76 /* 77 * 78 * where 79 * 80 * min - goals to be woken if the domain minimum changes 81 * max - goals to be woken if the domain maximum changes 82 * any - the delayed goals woken if the domain is changed 83 * 84 * domain - the representation of the domain itself dom(List, Size) 85 * 86 * A structure declaration is used so that e.g. 87 * 88 * fd with domain:D 89 * 90 * represents 91 * 92 * fd(_, _, _, D) 93 * and 94 * min of fd 95 * is 3. All operations on the fd/4 structure should be done 96 * with these macros so that the access is independent of the 97 * actual structure. 98 */ 99 100%---------------------------------------------------------------- 101% Attribute definition 102%---------------------------------------------------------------- 103 104:- meta_attribute(fd, [ 105 unify: unify_domain/3, 106 test_unify: test_unify_domain/2, 107 compare_instances: compare_instances_domain/3, 108 copy_term: copy_term_domain/2, 109 suspensions: suspensions_domain/3, 110 delayed_goals_number: delayed_goals_number_domain/2, 111 get_bounds: get_fd_bounds/3, 112 set_bounds: set_fd_bounds/3, 113 print: tr_fd_domain_out/2, 114 suspension_lists: [min:(min of fd), 115 max:(max of fd), 116 any:(any of fd), 117 domain:(any of fd), 118 bounds:[min of fd,max of fd] ] 119 ]). 120 121% Export transformation routines. 122:- export 123 fd_dom_simple/2, 124 fd_dom_simple/3, 125 tr_fd_domain_in/2, 126 tr_fd_domain_out/2. 127 128% Output Macros 129% Hide the attribute structure on output 130% print the metaterm alone as [Domain] 131 132:- export macro(property(functor) of fd, tr_fd_domain_out/2, [write, protect_arg]). 133:- export macro(dom/2, tr_fd_domain_out/2, [write, protect_arg]). 134:- export macro(dom_ent/3, tr_fd_domain_out/2, [write, goal]). 135:- export macro(fd_dom_simple/2, tr_fd_domain_out/2, [write, goal]). 136:- export macro(fd_dom_simple/3, tr_fd_domain_out/2, [write, goal]). 137 138:- export op(700, xfx, #::). 139 140% Goal Macros 141:- inline((::)/2, tr_fd_domain_in/2). 142:- inline((::)/3, tr_fd_domain_in/2). 143:- inline((#::)/2, tr_fd_domain_in/2). 144:- inline((#::)/3, tr_fd_domain_in/2). 145 146:- export 147 :: /2, 148 :: /3, 149 #:: /2, 150 #:: /3, 151 indomain/1, 152 is_domain/1, 153 is_integer_domain/1, 154 par_indomain/1, 155 156 % domain access 157 dom_member/2, 158 dom_size/2, 159 new_domain_var/1, 160 161 % domain processing 162 dom_copy/2, 163 dom_to_list/2, 164 list_to_dom/2, 165 sorted_list_to_dom/2, 166 167 % various 168 var_fd/2, 169 dvar_attribute/2, 170 dvar_domain/2, 171 constraints_number/2, 172 173 % var modification 174 dvar_update/2, 175 dvar_update_nocheck/3, 176 177 dvar_msg/3. 178 179:- local get_attribute/2. 180 181:- import 182 check_dom/1 % should really be defined here... 183 from fd_arith. 184 185:- import 186 % general-purpose predicates 187 add_attribute/3, 188 fd_init/0, 189 get_bip_error/1, 190 remove_element/3, 191 setarg/3, 192 set_bip_error/1, 193 suspensions_to_goals/3, 194 trprotect/2, 195 196 % FD-specific predicates 197 attr_instantiate/2 198 from sepia_kernel. 199 200 201% Initialize the C variables 202:- fd_init. 203 204:- pragma(nodebug). 205:- pragma(system). 206 207fderror(N, G) :- 208 error(N, G, _). 209 210% 211% Transformation routines 212% 213 214%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 215% Input goal transformation 216%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 217 218% Goal Source Transformation 219tr_fd_domain_in(V #:: D, G) :- 220 tr_fd_domain_in(V :: D, G). 221tr_fd_domain_in(#::(V, D, B), G) :- 222 tr_fd_domain_in(::(V, D, B), G). 223tr_fd_domain_in(V :: D, G) :- 224 -?-> 225 !, 226 varset(V), 227 ground(D), 228 make_domain(D, Dom, _), 229 G = fd_domain:fd_dom_simple(V, Dom). 230tr_fd_domain_in(::(V, D, B), G) :- 231 -?-> 232 !, 233 var(V), 234 ground(D), 235 make_domain(D, Dom, _), 236 G = fd_domain:fd_dom_simple(V, Dom, B). 237 238 varset(V) :- var(V), !. 239 varset([_|_]). 240 varset(subscript(_,_)). 241 242% Domain Output Transformation 243tr_fd_domain_out(_{fd:(fd with domain:dom(D, _))}, T) :- 244 -?-> 245 T = D. 246tr_fd_domain_out(fd with domain:dom(D, _), T) :- 247 -?-> 248 T = D. 249tr_fd_domain_out(dom(D, S), T) :- 250 -?-> 251 (is_finite(D) -> 252 T = dom(D, S) 253 ; 254 D = [T] -> 255 true 256 ; 257 T = D 258 ). 259tr_fd_domain_out(dom_ent(X, Dom, B), T) :- 260 -?-> 261 T = ::(X, Dom, B). 262tr_fd_domain_out(fd_dom_simple(X, Dom), T) :- 263 -?-> 264 T = ::(X, Dom). 265tr_fd_domain_out(fd_dom_simple(X, Dom, B), T) :- 266 -?-> 267 T = ::(X, Dom, B). 268 269%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 270% 271% THE FD EXTENSION 272% 273%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 274 275%---------------------------------------------------------------- 276% unification 277%---------------------------------------------------------------- 278 279% unify_domain(+Term, ?Attribute, ?XSuspAttr) 280unify_domain(Term, Attr, XSuspAttr) :- 281 /*** ANY + VAR ***/ 282 var(Attr), 283 % Nothing to do unless there's a constrained list for X and Term is an 284 % FD variable. 285 ( nonvar(XSuspAttr), is_domain(Term) -> 286 schedule_suspensions(constrained of suspend, XSuspAttr) 287 ; 288 true 289 ). 290unify_domain(Term, Attr, XSuspAttr) :- 291 compound(Attr), 292 unify_term_domain(Term, Attr, XSuspAttr). 293 294% We wake every time a variable is touched. 295:- mode unify_term_domain(?, +, ?). 296unify_term_domain(Term, Attr, _XSuspAttr) :- 297 nonvar(Term), % The metaterm was instantiated, wake all 298 /*** NONVAR + META ***/ 299 Attr = fd with [], 300 attr_instantiate(Attr, Term). 301unify_term_domain(Y{fd:AttrY}, AttrX, XSuspAttr) :- 302 -?-> 303 unify_domain_domain(Y, AttrX, AttrY, XSuspAttr). 304 305unify_domain_domain(Y, AttrX, AttrY, _XSuspAttr) :- 306 var(AttrY), % no attribute for this extension 307 /*** VAR + META ***/ 308 AttrY = AttrX, % share the attribute 309 notify_constrained(Y). 310unify_domain_domain(Y, AttrX, AttrY, XSuspAttr) :- 311 nonvar(AttrY), 312 /*** META + META ***/ 313 AttrY = fd with domain:DomY, 314 AttrX = fd with domain:DomX, 315 dom_intersection(DomX, DomY, NewDom, Size), 316 (Size = 1 -> 317 NewDom = dom([Y|_], _), % bind Y, wake inst,bound,constrained 318 attr_instantiate(AttrX, Y) % wake the fd lists 319 ; 320 attr_bind(AttrX, NewDom, _, XSuspAttr), % empties the woken lists 321 attr_bind(AttrY, NewDom, Y, _), 322 dvar_replace(Y, NewDom), 323 merge_suspension_lists(min of fd, AttrX, min of fd, AttrY), 324 merge_suspension_lists(max of fd, AttrX, max of fd, AttrY), 325 merge_suspension_lists(any of fd, AttrX, any of fd, AttrY) 326 ). 327 328 329% Do the wakings that result from changing Attr's domain to NewDom 330attr_bind(Attr, NewDom, Var, SuspAttr) :- 331 Attr = fd with [domain:D], 332 dom_size(D, S), 333 dom_size(NewDom, NewS), 334 (NewS < S -> 335 ( nonvar(SuspAttr) -> 336 schedule_suspensions(constrained of suspend, SuspAttr) 337 ; 338 notify_constrained(Var) 339 ), 340 schedule_suspensions(any of fd, Attr), 341 (dom_range(D, Min, Max), 342 dom_range(NewDom, NewMin, NewMax) -> 343 (NewMin > Min -> 344 schedule_suspensions(min of fd, Attr) 345 ; 346 true 347 ), 348 (NewMax < Max -> 349 schedule_suspensions(max of fd, Attr) 350 ; 351 true 352 ) 353 ; 354 true 355 ) 356 ; 357 true 358 ). 359 360 361%---------------------------------------------------------------- 362% unification test 363%---------------------------------------------------------------- 364 365% test_unify_domain(+Term, Attribute) 366test_unify_domain(_, Attr) :- 367 /*** ANY + VAR ***/ 368 var(Attr). % Ignore if no attribute for this extension 369test_unify_domain(Term, Attr) :- 370 nonvar(Attr), 371 test_unify_term_domain(Term, Attr). 372 373% We wake every time a variable is touched. 374:- mode test_unify_term_domain(?, +). 375test_unify_term_domain(Term, fd with domain:D) :- 376 -?-> 377 /*** NONVAR + META ***/ 378 nonvar(Term), % Check here if the instantiation is accepted. 379 dom_check_in(Term, D). 380test_unify_term_domain(Y{fd:AttrY}, AttrX) :- 381 -?-> 382 test_unify_domain_domain(Y, AttrX, AttrY). 383 384test_unify_domain_domain(_, _, AttrY) :- 385 /*** VAR + META ***/ 386 var(AttrY). % no attribute for this extension 387test_unify_domain_domain(Y, fd with domain:DomX, fd with domain:DomY) :- 388 -?-> 389 /*** META + META ***/ 390 dom_intersection(DomX, DomY, NewDom, _), 391 dvar_replace(Y, NewDom). % may create a singleton domain; 392 % but there is no easy way to bind 393 % and invoke other handlers 394 395%---------------------------------------------------------------- 396% instances 397%---------------------------------------------------------------- 398 399% compare_instances_domain(-Res, ?TermL, ?TermR) 400% One or both Terms are attributed variables 401compare_instances_domain(Res, _X{fd:AttrX}, Y) ?- 402 compare_instances_attr_any(Res, AttrX, Y). 403compare_instances_domain(Res, X, _Y{fd:AttrY}) ?- free(X), 404 compare_instances_free_attr(Res, AttrY). % Y must be meta! 405compare_instances_domain(Res, X, _Y{fd:AttrY}) ?- nonvar(X), 406 compare_instances_const_attr(Res, X, AttrY). % Y must be meta! 407 408 compare_instances_attr_any(Res, AttrX, _Y{fd:AttrY}) ?- 409 compare_instances_attr_attr(Res, AttrX, AttrY). 410 compare_instances_attr_any(Res, AttrX, Y) :- free(Y), 411 compare_instances_attr_free(Res, AttrX). 412 compare_instances_attr_any(Res, AttrX, Y) :- nonvar(Y), 413 compare_instances_attr_const(Res, AttrX, Y). 414 415 compare_instances_attr_free(Res, AttrX) :- var(AttrX), 416 Res = (=). 417 compare_instances_attr_free(Res, AttrX) :- nonvar(AttrX), 418 Res = (<). 419 420 compare_instances_free_attr(Res, AttrY) :- var(AttrY), 421 Res = (=). 422 compare_instances_free_attr(Res, AttrY) :- nonvar(AttrY), 423 Res = (>). 424 425 compare_instances_attr_attr(Res, AttrX, AttrY) :- var(AttrX), 426 compare_instances_free_attr(Res, AttrY). 427 compare_instances_attr_attr(Res, AttrX, AttrY) :- nonvar(AttrX), 428 compare_instances_iattr_attr(Res, AttrX, AttrY). 429 430 compare_instances_iattr_attr(Res, _AttrX, AttrY) :- var(AttrY), !, 431 Res = (<). 432 compare_instances_iattr_attr(Res, fd{domain:DX}, fd{domain:DY}) ?- 433 dom_compare(Res, DX, DY). 434 435 compare_instances_const_attr(Res, _X, AttrY) :- var(AttrY), !, 436 Res = (<). 437 compare_instances_const_attr(Res, X, fd{domain:DY}) ?- 438 dom_check_in(X, DY), 439 Res = (<). 440 441 compare_instances_attr_const(Res, AttrX, _Y) :- var(AttrX), !, 442 Res = (>). 443 compare_instances_attr_const(Res, fd{domain:DX}, Y) ?- 444 dom_check_in(Y, DX), 445 Res = (>). 446 447 448%---------------------------------------------------------------- 449% copy_term 450%---------------------------------------------------------------- 451 452copy_term_domain(X{fd:AttrX}, Copy) :- 453 -?-> 454 copy_term_domain(X, Copy, AttrX). 455 456 457copy_term_domain(_, _, AttrX) :- 458 /*** VAR ***/ 459 var(AttrX). 460copy_term_domain(_, Copy, fd with domain:dom(D, S)) :- 461 -?-> 462 /*** META ***/ 463 empty_domain(dom(D, S), ND), 464 add_attribute(Copy, ND, fd). 465 466empty_domain(D, fd with [domain:D, any:[], min:[], max:[]]). 467 468%---------------------------------------------------------------- 469% suspensions 470%---------------------------------------------------------------- 471 472suspensions_domain(_{fd:AttrX}, Susps, Susps0) :- 473 -?-> 474 susp_domain(AttrX, Susps, Susps0). 475 476susp_domain(AttrX, Susps, Susps) :- var(AttrX), !. 477susp_domain(fd with [min:Mi, max:Ma, any:B], [Mi,Ma,B|Susps], Susps). 478 479 480%---------------------------------------------------------------- 481% delayed goals number 482%---------------------------------------------------------------- 483 484delayed_goals_number_domain(_{fd:AttrX}, N) :- 485 -?-> 486 dgn_domain(AttrX, N). 487 488dgn_domain(AttrX, 0) :- 489 /*** VAR ***/ 490 var(AttrX). 491dgn_domain(fd with [any:B, min:Mi, max:Ma], N) :- 492 -?-> 493 /*** META ***/ 494 count_active_suspensions(B, 0, N0), 495 count_active_suspensions(Mi, N0, N1), 496 count_active_suspensions(Ma, N1, N). 497 498 499count_active_suspensions([Susp|Susps], N0, N) :- 500 -?-> 501 !, 502 ( is_suspension(Susp) -> 503 N1 is N0 + 1 504 ; 505 N1 = N0 506 ), 507 count_active_suspensions(Susps, N1, N). 508count_active_suspensions(_, N, N). 509 510% Due to the implementation, it may happen that a metaterm 511% occurs in a predicate even if it should not, namely in the case that 512% the metaterm is instantiated and a simple goal follows; then 513% the domain_unify/1 handler is called only *after* the simple goal. 514 515 516%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 517% 518% Attaching and querying the domain 519% 520%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 521 522% ?Vars :: ?Domain 523% The variable(s) Vars have the domain Domain 524Varset #:: Domain :- 525 Varset :: Domain. 526Varset :: Domain :- 527 var(Domain), 528 get_domain(Varset, Domain). 529Varset :: Domain :- 530 nonvar(Domain), 531 make_domain(Domain, DomRep, Varset), 532 fd_dom_simple(Varset, DomRep). 533 534:- mode get_domain(?,-). 535get_domain(X, Domain) :- var(X), !, 536 (dvar_domain(X, dom(Domain, _)) -> true; fderror(4, X::Domain)). 537get_domain(X, Domain) :- 538 varset(X), !, 539 fderror(5, X::Domain). 540get_domain(X, [X]). 541 542% fd_dom_simple(+varset, +domain) 543fd_dom_simple(Var, Dom) :- var(Var), !, 544 var_fd(Var, Dom). 545fd_dom_simple([], _) :- !. 546fd_dom_simple([X|Xs], Dom) :- !, 547 fd_dom_simple(X, Dom), 548 fd_dom_simple(Xs, Dom). 549fd_dom_simple(subscript(Array,Index), Dom) :- !, 550 subscript(Array, Index, Varset), 551 fd_dom_simple(Varset, Dom). 552fd_dom_simple(Val, Dom) :- 553 dom_check_in(Val, Dom). 554 555var_fd(Var, Domain) :- 556 dom_size(Domain, Size), 557 ( Size > 1 -> 558 dom_copy(Domain, D), 559 empty_domain(D, Dom), 560 set_domain_var1(Var, Dom) 561 ; 562 singleton_dom(Var, Domain) 563 ). 564 565set_domain_var1(Var{fd:(fd with [])}, Dom) :- 566 -?-> 567 !, 568 add_attribute(Var, Dom, fd). % will be notified in the handler 569set_domain_var1(Var, Dom) :- 570 add_attribute(Var, Dom, fd), 571 new_domain_var(Var), 572 notify_constrained(Var), 573 wake. 574 575new_domain_var(_). % primitive hook for extensions 576 577% 578% entailment 579% 580#::(Var, Int, B) :- 581 ::(Var, Int, B). 582::(Var, Int, B) :- 583 nonvar(Int), 584 make_domain(Int, DomEnt, Var), 585 fd_dom_simple(Var, DomEnt, B). 586::(Var, Int, B) :- 587 var(Int), 588 fderror(4, ::(Var, Int, B)). 589 590dom_ent(Var, DomEnt, B) :- 591 dvar_domain(Var, Dom), 592 dom_ent(Var, DomEnt, B, Dom). 593 594dom_ent(Var, DomEnt, 0, Dom) :- 595 -?-> 596 dom_difference(Dom, DomEnt, NewDom, _), 597 dvar_update(Var, NewDom). 598dom_ent(Var, DomEnt, 1, Dom) :- 599 -?-> 600 dom_intersection(Dom, DomEnt, NewDom, _), 601 dvar_update(Var, NewDom). 602dom_ent(Var, DomEnt, B, Dom) :- 603 var(B), 604 dom_size(Dom, Size), 605 (dom_intersection(Dom, DomEnt, _, SizeInt) -> 606 (Size = SizeInt -> 607 B = 1 608 ; 609 make_suspension(dom_ent(Var, DomEnt, B), 3, Susp), 610 insert_suspension(Var, Susp, any of fd, fd), 611 insert_suspension(B, Susp, inst of suspend, suspend) 612 ) 613 ; 614 B = 0 615 ). 616 617%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 618% 619% Conversion to the internal representation 620% 621%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 622 623% Create a representation of the domain. 624make_domain([H|T], Domain, Var) :- 625 !, 626 make_dom([H|T], Domain, Var). 627% Only for Chip compatibility 628make_domain(Start:End, Domain, Var) :- 629 !, 630 make_dom([Start..End], Domain, Var). 631make_domain([], Domain, _Var) :- 632 !, 633 empty_dom(Domain). 634make_domain(Value, Domain, Var) :- 635 make_dom([Value], Domain, Var). 636 637make_dom(List, dom(Domain, Size), _) :- 638 make_ground_dom(List, Domain, Size), 639 !, 640 Size > 0. 641make_dom(List, _, Var) :- 642 get_bip_error(Err), 643 fderror(Err, Var :: List). 644 645empty_dom(dom([], 0)). 646singleton_dom(Value, dom([Value], 1)). 647 648sorted_list_to_dom(List, dom(D, _)) :- 649 -?-> 650 List = D. 651sorted_list_to_dom(List, Dom) :- 652 var(Dom), 653 Dom = dom(List, Size), 654 list_size(List, 0, Size). 655 656list_size([], S, S). 657list_size([H|T], S0, S) :- 658 el_size(H, S1), 659 S2 is S0 + S1, 660 list_size(T, S2, S). 661 662el_size(M..N, S) :- 663 !, 664 S is N - M + 1. 665el_size(_, 1). 666 667list_to_dom(List, dom(Domain, Size)) :- 668 make_ground_dom(List, Domain, Size), 669 !, 670 Size > 0. 671list_to_dom(List, Domain) :- 672 get_bip_error(Err), 673 fderror(Err, list_to_dom(List, Domain)). 674 675make_ground_dom(List, Domain, Size) :- 676 sort(List, SList), 677 domain_types(SList, Domain, FL, Integers, Intervals, AfterInt, 0, S), 678 make_integer_subdom(Integers, Intervals, DI, SU), 679 append(DI, AfterInt, FL), 680 Size is S + SU, 681 (Size > 16'7fffffff -> 682 set_bip_error(6) 683 ; 684 true 685 ). 686 687% 688% domain_types(List, Floats, FC, Integers, Intervals, Atomic, Ac, ASize) 689% Split the sorted input list into a list of different types: 690% Floats (they are smaller than any other atomic type) 691% Integers and intervals 692% Other atomic types (greater than integers and floats) 693% FC is the tail of the Floats list, it is used for appending the integers 694% and the rest. 695 696:- mode domain_types(+,-,-,-,-,-,+,-). 697domain_types([], F, F, [], [], [], N, N) :- !. 698domain_types([H|T], F, F0, I, S, A, N0, N) :- 699 domain_types1(H, F, F0, I, S, A, N0, N, T). 700 701/* domain_types1(-,-,-,-,-,-,+,-,+) */ 702 703 domain_types1(Var, _, _, _, _, _, _, _, _) :- 704 var(Var), 705 !, 706 set_bip_error(4). 707 domain_types1(H, [H|F1], F0, I, S, A, N0, N, T) :- 708 float(H), 709 !, 710 N1 is N0 + 1, 711 domain_types(T, F1, F0, I, S, A, N1, N). 712 domain_types1(H, F, F0, [H|I], S, A, N0, N, T) :- 713 integer(H), 714 !, 715 domain_types(T, F, F0, I, S, A, N0, N). 716 domain_types1(K..M, F, F0, I, S, A, N0, N, T) :- 717 !, 718 ( integer(K) -> N1 = K 719 ; nonvar(K) -> N1 is K, ( integer(N1) -> true ; set_bip_error(5) ) 720 ; set_bip_error(4) ), 721 ( integer(M) -> N2 = M 722 ; nonvar(M) -> N2 is M, ( integer(N2) -> true ; set_bip_error(5) ) 723 ; set_bip_error(4) ), 724 ( N1 =< N2 -> 725 S = [N1..N2 | S1] 726 ; 727 S1 = S 728 ), 729 domain_types(T, F, F0, I, S1, A, N0, N). 730 domain_types1(Str, _, _, _, _, _, _, _, _) :- 731 nonground(Str), 732 !, 733 set_bip_error(4). 734 domain_types1(H, F, F0, I, S, [H|A], N0, N, T) :- 735 N1 is N0 + 1, 736 domain_types(T, F, F0, I, S, A, N1, N). 737 738 739% Make an integer domain out of sorted integer and interval lists. 740make_integer_subdom(Integers, Intervals, Dom, SU) :- 741 integer_list_to_dom(Intervals, DS), 742 integer_list_to_dom(Integers, DI), 743 (dom_union(DS, DI, dom(Dom, SU), SU) -> 744 true 745 ; 746 Dom = [], 747 SU = 0 748 ). 749 750%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 751% 752% Domain querying and updates 753% 754%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 755 756is_domain(_{fd:(fd with [])}) :- -?-> true. 757 758is_finite(_{fd:(fd with [])}) :- -?-> true. 759is_finite(I) :- 760 integer(I). 761 762is_integer_domain(_{fd:(fd with domain:D)}) :- 763 -?-> 764 dom_range(D, _, _). 765 766% Var is guaranteed to have an fd attribute! 767get_fd_bounds(_{fd:(fd with [domain:D])}, L, H) :- -?-> !, 768 dom_range(D, L, H). 769 770% Var is guaranteed to have an fd attribute! 771set_fd_bounds(Var, Lwb, Upb) :- 772 L is fix(ceiling(Lwb)), 773 U is fix(floor(Upb)), 774 dvar_remove_smaller(Var, L), 775 dvar_remove_greater(Var, U), 776 wake. 777 778 779dvar_domain(_{fd:(fd with [domain:D])}, Domain) :- 780 -?-> 781 !, 782 Domain = D. 783dvar_domain(Var, D) :- 784 nonvar(Var), 785 singleton_dom(Var, D). 786 787get_attribute(_{fd:Attr}, Meta) :- 788 -?-> 789 compound(Attr), 790 Attr = Meta. 791 792dvar_attribute(_{fd:Attr}, DS) :- 793 -?-> 794 !, 795 nonvar(Attr), 796 Attr = DS. 797dvar_attribute(Var, _) :- var(Var), !, fail. 798dvar_attribute(Value, Dom) :- 799 nonvar(Value), 800 singleton_dom(Value, D), 801 empty_domain(D, Dom). 802 803% Replace the domain by another one, do all checks 804:- mode dvar_update(?, ++). 805dvar_update(A, Dom) :- 806 nonvar(A), 807 Dom = dom([A], 1). 808dvar_update(Var{fd:DS}, NewDom) :- 809 -?-> 810 NewDom = dom(_, Size), 811 dvar_update(Var, NewDom, DS, Size). 812 813:- mode dvar_update(?, ++, ++, ++). 814dvar_update(Var, dom([Var|_], _), _, 1) :- !. 815dvar_update(Var, NewDom, DS, Size) :- 816% integer(Size), 817% Size > 1, 818 DS = fd with domain:dom(_, OldSize), 819 (Size < OldSize -> 820 attr_bind(DS, NewDom, Var, _), 821 dvar_replace(Var, NewDom) 822 ; 823 Size = OldSize -> 824 true 825 ; 826 error(6, dvar_update(Var, NewDom)) 827 ). 828 829:- mode dvar_update_nocheck(?, ++, ++). 830dvar_update_nocheck(Var, [Var|_], 1) :- !. 831dvar_update_nocheck(Var{fd:DS}, ND, Size) :- 832 -?-> 833% integer(Size), 834% Size > 1, 835 NewDom = dom(ND, Size), 836 attr_bind(DS, NewDom, Var, _), 837 dvar_replace(Var, NewDom). 838 839constraints_number(Var, Number) :- 840 delayed_goals_number(Var, Number). 841 842:- mode dvar_msg(?, ?, -). 843dvar_msg(_A{fd:fd{domain:DA}}, B, M) ?- !, 844 msg_domain(DA, B, M). 845dvar_msg(A, _B{fd:fd{domain:DB}}, M) ?- !, 846 msg_domain(DB, A, M). 847dvar_msg(A, B, M) :- 848 ground(A), !, 849 msg_atomic(A, B, M). 850dvar_msg(_A, _B, _M). 851 852% even if B is an atomic term, A is neither an atomic term nor a domain variable 853 854% A is a domain variable 855msg_domain(DA, _B{fd:fd{domain:DB}}, M) ?- !, 856 dom_union(DA, DB, DM, _), 857 empty_domain(DM, Dom), 858 add_attribute(M, Dom, fd). 859msg_domain(DA, B, M) :- 860 ground(B), !, 861 ( dom_check_in(B, DA) -> 862 empty_domain(DA, Dom), 863 add_attribute(M, Dom, fd) 864 ; singleton_dom(B, DB), 865 dom_union(DA, DB, DM, _), 866 empty_domain(DM, Dom), 867 add_attribute(M, Dom, fd) 868 ). 869msg_domain(_DA, _B, _M). 870 871% A is a nonvar term 872% B is not a domain variable 873msg_atomic(A, B, M) :- 874 ground(B), !, 875 ( A = B -> 876 M = A 877 ; sort([A, B], D), 878 M :: D 879 ). 880msg_atomic(_A, _B, _M). 881 882indomain(Var{fd:(fd with domain:D)}) :- 883 -?-> 884 !, 885 dom_member(Var, D). 886indomain(Val) :- 887 nonvar(Val). 888indomain(Var) :- 889 var(Var), 890 error(4, indomain(Var)). 891 892par_indomain(Var{fd:(fd with domain:D)}) :- 893 -?-> 894 !, 895 par_dom_member(Var, D). 896par_indomain(Val) :- 897 nonvar(Val). 898par_indomain(Var) :- 899 var(Var), 900 error(4, par_indomain(Var)). 901 902% Enumerate the elements of a domain. 903:- mode dom_member(?, ++). 904dom_member(Val, dom([H|T], _)) :- 905 dom_member(Val, H, T). 906 907:- mode dom_member(?, ++, ++). 908dom_member(Val, Start..End, T) :- !, 909 interv_member(Val, Start, End, T). 910dom_member(Val, Elem, T) :- 911 elem_member(Val, Elem, T). 912 913:- mode elem_member(?, ++, ++). 914elem_member(Val, Val, _). 915elem_member(Var, Val, [H|T]) :- 916 remove_element(Var, Val, _), 917 dom_member(Var, H, T). 918 919:- mode interv_member(?, ++, ++, ++). 920interv_member(Val, Start, End, _) :- 921 between(Start, End, 1, Val). 922interv_member(Var, _, _, [H|T]) :- 923 dom_member(Var, H, T). 924 925 926% Enumerate the elements of a domain (in parallel). 927:- mode par_dom_member(?, ++). 928par_dom_member(Val, dom([H|T], _)) :- 929 par_dom_member(Val, H, T). 930 931:- mode par_dom_member(?, ++, ++). 932par_dom_member(Val, Start..End, T) :- !, 933 par_interv_member(Val, Start, End, T). 934par_dom_member(Val, Elem, T) :- 935 par_elem_member(Val, Elem, T). 936 937:- parallel par_elem_member/3. 938:- mode par_elem_member(?, ++, ++). 939par_elem_member(Val, Val, _). 940par_elem_member(Var, Val, [H|T]) :- 941 remove_element(Var, Val, _), 942 par_dom_member(Var, H, T). 943 944:- parallel par_interv_member/4. 945:- mode par_interv_member(?, ++, ++, ++). 946par_interv_member(Val, Start, End, _) :- 947 End1 is End+1, 948 N is End1-Start, 949 fork(N, I), 950 Val is End1-I. 951par_interv_member(Var, _, _, [H|T]) :- 952 par_dom_member(Var, H, T). 953 954% must be after the make_domain/3 definition which is needed to expand :: 955fd_dom_simple(Var, Dom, B) :- 956 check_dom(Var), 957 B :: 0..1, 958 dom_ent(Var, Dom, B). 959 960%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 961% 962% Operations on domains (others are written in C) 963% 964%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 965 966% Convert a domain to a list of its elements. 967dom_to_list(dom(D, _), L) :- 968 dom_to_list2(D, L). 969 970dom_to_list2([], []). 971dom_to_list2([Inter|Intervs], List) :- 972 inter1_to_list(Inter, List, Last), 973 dom_to_list2(Intervs, Last). 974 975:- mode inter1_to_list(++, ?, ?). 976inter1_to_list(Low..Up, List, Last) :- 977 !, 978 gen_list(Low, Up, List, Last). 979inter1_to_list(One, [One|Last], Last). 980 981% Make a partial list of integers from M to N 982gen_list(Up, Up, [Up|Last], Last) :- !. 983gen_list(Low, Up, [Low|Next], Last) :- 984 NextLow is Low + 1, 985 gen_list(NextLow, Up, Next, Last). 986 987 988 989dom_size(dom(_, Size), Size). 990 991dom_copy(dom(Dom, Size), dom(Dom, Size)). 992 993 994:- untraceable 995 unify_domain/3, 996 unify_term_domain/3, 997 test_unify_domain/2, 998 compare_instances_domain/3, 999 copy_term_domain/2, 1000 suspensions_domain/3, 1001 delayed_goals_number_domain/2, 1002 tr_fd_domain_in/2, 1003 tr_fd_domain_out/2. 1004