1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1993-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * VERSION $Id: bip_domain.c,v 1.3 2010/03/19 05:52:16 jschimpf Exp $ 25 */ 26 27/**************************************************************************** 28 * 29 * SEPIA Auxiliary Predicates for Finite Domain Constraints. 30 * 31 * 32 ***************************************************************************** 33 * 34 * Author: Micha Meier 35 * 36 * History: 37 * Jan 1993 Created the file. It contains hardcoded pieces that have 38 * shown to be vital to the finite domain constraints. 39 * 40 */ 41 42/* 43 * INCLUDES: 44 */ 45#include "config.h" 46#include "sepia.h" 47#include "types.h" 48#include "embed.h" 49#include "mem.h" 50#include "dict.h" 51#include "error.h" 52#include "emu_export.h" 53#include "fd.h" 54 55/* 56 * LOCAL MACROS 57 */ 58#define DOM_NONE 0 59#define DOM_BOTH 3 60#define DOM_1 1 61#define DOM_2 2 62 63#define NOT_MOVED 0 64#define MOVED 1 65#define MOVE_BOTH 2 66 67#define INPUT_ATOMIC 1 68#define OUTPUT_ATOMIC 2 69#define OUTPUT_INTERVAL 1 70 71#define LT 1 72#define GT 2 73#define EQ 3 74 75#define WAIT_1 1 76#define WAIT_2 2 77 78#define RANGE_EQ 0 79#define RANGE_GE 1 80#define RANGE_ONLY 2 81 82/* 83 * EXTERNAL VARIABLE DEFINITIONS: 84 */ 85 86int domain_slot; 87 88/* 89 * EXTERNAL VARIABLE DECLARATIONS: 90 */ 91 92/* 93 * STATIC VARIABLE DEFINITIONS: 94 */ 95static int p_dom_range(value vd, type td, value vmi, type tmi, value vma, type tma), 96 p_dom_check_in(value ve, type te, value vd, type td), 97 p_fd_init(void), 98 p_lt_test(value vh, type th, value vmi, type tmi, value vma, type tma), 99 p_make_extreme(value vt, type tt, value vm, type tm), 100 p_linear_term_range_ge(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff), 101 p_linear_term_range_eq(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff), 102 p_linear_term_range_only(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff), 103 _linear_term_range(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff, int ge), 104 p_ex_insert_suspension(value vt, type tt, value vs, type ts, value vl, type tl), 105 p_gec_insert_suspension(value vx, type tx, value vk, type tk, value vy, type ty, value vs, type ts), 106 p_gec_start(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vd, type td, value ve, type te, value vres, type tres), 107 p_gec_ent_start(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vd, type td, value ve, type te, value vres, type tres), 108 p_gec_test(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vres, type tres), 109 p_gec_comp(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vres, type tres), 110 p_ineq_test(value vt, type tt, value vres, type tres, value vvar, type tvar, value vval, type tval), 111 p_index_values(value vi, type ti, value vt, type tt, value vv, type tv, value vsi, type tsi, value vsv, type tsv, value vres, type tres, value vnewi, type tnewi, value vnewv, type tnewv, value vs, type ts, value vnsv, type tnsv), 112 p_attr_instantiate(value va, type ta, value vc, type tc), 113 p_prune_woken_goals(value val, type tag), 114 p_dvar_remove_smaller(value vvar, type tvar, value vm, type tm), 115 p_dvar_remove_greater(value vvar, type tvar, value vm, type tm), 116 p_dom_union(value vd1, type td1, value vd2, type td2, value vu, type tu, value vs, type ts), 117 p_dom_intersection(value vd1, type td1, value vd2, type td2, value vi, type ti, value vs, type ts), 118 p_dom_difference(value vd1, type td1, value vd2, type td2, value vi, type ti, value vs, type ts), 119 p_dom_compare(value vc, type tc, value vd1, type td1, value vd2, type td2), 120 p_dvar_replace(value vvar, type tvar, value vn, type tn), 121 p_dvar_remove_element(value vvar, type tvar, value vel, type tel), 122 p_integer_list_to_dom(value vl, type tl, value vd, type td), 123 p_sdelta(value l1, type t1, value l2, type t2, value l3, type t3), 124 p_remove_element(value vvar, type tvar, value vel, type tel, value vres, type tres); 125 126static int dom_remove_smaller(pword*,word); 127static int dom_remove_greater(pword*,word); 128static pword *insert_interval(word,word,pword*); 129static pword *_dom_intersection(pword*,pword*,word*); 130static word _dom_value(pword*); 131static int _domain_changed(pword*,word,int); 132static int _remove_element(pword*,word,word); 133 134static dident d_interval, 135 d_delay, 136 d_dom, 137 d_fd_par, 138 d_min0, 139 d_max0; 140 141 142void 143bip_domain_init(int flags) 144{ 145 d_interval = in_dict("..", 2); 146 d_delay = in_dict("delay", 2); 147 d_dom = in_dict("dom", 2); 148 d_max0 = in_dict("max", 0); 149 d_min0 = in_dict("min", 0); 150 d_fd_par = in_dict("fd_parameters",1); 151 152 if (flags & INIT_SHARED) 153 { 154 /* this array is used to save the slot parameters in saved states */ 155 (void) make_kernel_array(d_fd_par, 1, d_.integer0, d_.local0); 156 } 157 else /* get the slot parameters from the saved state */ 158 { 159 word *fd_parameters = (word *) (get_kernel_array(d_fd_par)->val.ptr + 1); 160 domain_slot = fd_parameters[0]; 161 } 162 163 if (!(flags & INIT_SHARED)) 164 return; 165 166 (void) exported_built_in(in_dict("fd_init", 0), p_fd_init, B_SAFE); 167 (void) exported_built_in(in_dict("dom_check_in", 2), p_dom_check_in, B_UNSAFE); 168 exported_built_in(in_dict("dom_compare", 3), p_dom_compare, B_UNSAFE) 169 -> mode = BoundArg(1, CONSTANT); 170 exported_built_in(in_dict("dvar_remove_smaller", 2), p_dvar_remove_smaller, 171 B_UNSAFE|U_SIMPLE) -> mode = BoundArg(2, CONSTANT); 172 exported_built_in(in_dict("dvar_remove_greater", 2), p_dvar_remove_greater, 173 B_UNSAFE|U_SIMPLE) -> mode = BoundArg(2, CONSTANT); 174 exported_built_in(in_dict("dom_range", 3), p_dom_range, B_UNSAFE|U_GROUND) 175 -> mode = BoundArg(2, CONSTANT)|BoundArg(3, CONSTANT); 176 exported_built_in(in_dict("dom_intersection", 4), p_dom_intersection, 177 B_UNSAFE|U_GROUND) -> mode = BoundArg(3, GROUND)|BoundArg(4, CONSTANT); 178 exported_built_in(in_dict("dom_union", 4), p_dom_union, 179 B_UNSAFE|U_GROUND) -> mode = BoundArg(3, GROUND)|BoundArg(4, CONSTANT); 180 exported_built_in(in_dict("dom_difference", 4), p_dom_difference, 181 B_UNSAFE|U_GROUND) -> mode = BoundArg(3, GROUND)|BoundArg(4, CONSTANT); 182 (void) exported_built_in(in_dict("lt_test", 3), p_lt_test, 183 B_UNSAFE|U_UNIFY); 184 exported_built_in(in_dict("linear_term_range_only", 6), 185 p_linear_term_range_only, B_UNSAFE|U_UNIFY) -> mode = 186 BoundArg(2, CONSTANT); 187 exported_built_in(in_dict("linear_term_range_eq", 6), 188 p_linear_term_range_eq, B_UNSAFE|U_UNIFY) -> mode = 189 BoundArg(2, CONSTANT); 190 exported_built_in(in_dict("linear_term_range_ge", 6), 191 p_linear_term_range_ge, B_UNSAFE|U_UNIFY) -> mode = 192 BoundArg(2, CONSTANT); 193 exported_built_in(in_dict("make_extreme", 2), p_make_extreme, B_UNSAFE|U_UNIFY) 194 -> mode = BoundArg(1, NONVAR); 195 (void) exported_built_in(in_dict("prune_woken_goals", 1), 196 p_prune_woken_goals, B_UNSAFE); 197 (void) exported_built_in(in_dict("ex_insert_suspension", 3), 198 p_ex_insert_suspension, B_UNSAFE); 199 exported_built_in(in_dict("gec_start", 7), p_gec_start, B_UNSAFE|U_GROUND) 200 -> mode = BoundArg(5, CONSTANT); 201 exported_built_in(in_dict("gec_ent_start", 7), p_gec_ent_start, 202 B_UNSAFE|U_GROUND) -> mode = BoundArg(5, CONSTANT); 203 exported_built_in(in_dict("gec_test", 5), p_gec_test, B_UNSAFE|U_GROUND) 204 -> mode = BoundArg(5, CONSTANT); 205 exported_built_in(in_dict("gec_comp", 5), p_gec_comp, B_UNSAFE|U_GROUND) 206 -> mode = BoundArg(5, CONSTANT); 207 (void) exported_built_in(in_dict("gec_insert_suspension", 4), 208 p_gec_insert_suspension, B_UNSAFE); 209 exported_built_in(in_dict("ineq_test", 4), p_ineq_test, B_UNSAFE|U_UNIFY) 210 -> mode = BoundArg(2, CONSTANT) | BoundArg(3, NONVAR) | 211 BoundArg(4, CONSTANT); 212 exported_built_in(in_dict("index_values", 10), p_index_values, 213 B_UNSAFE|U_UNIFY) -> mode = BoundArg(6, CONSTANT) | BoundArg(7, NONVAR); 214 (void) exported_built_in(in_dict("attr_instantiate", 2), p_attr_instantiate, 215 B_UNSAFE); 216 exported_built_in(in_dict("remove_element", 3), p_remove_element, 217 B_UNSAFE|U_SIMPLE) -> mode = BoundArg(3, CONSTANT); 218 exported_built_in(in_dict("dvar_remove_element", 2), p_dvar_remove_element, 219 B_UNSAFE|U_SIMPLE) -> mode = BoundArg(3, CONSTANT); 220 exported_built_in(in_dict("integer_list_to_dom", 2), p_integer_list_to_dom, 221 B_UNSAFE|U_GROUND) -> mode = BoundArg(2, CONSTANT); 222 (void) exported_built_in(in_dict("dvar_replace", 2), p_dvar_replace, 223 B_UNSAFE); 224 exported_built_in(in_dict("sdelta", 3), p_sdelta, 225 B_UNSAFE|U_GROUND) -> mode = BoundArg(3, GROUND); 226} 227 228static int 229p_fd_init(void) 230{ 231 word *fd_parameters = (word *) (get_kernel_array(d_fd_par)->val.ptr + 1); 232 domain_slot = fd_parameters[0] = meta_index(in_dict("fd", 0)); 233 Succeed_; 234} 235 236static int 237p_dom_range(value vd, type td, value vmi, type tmi, value vma, type tma) 238{ 239 word min, max; 240 Prepare_Requests; 241 242 Check_Domain(vd, td) 243 Check_Output_Integer(tmi) 244 Check_Output_Integer(tma) 245 if (dom_range(vd.ptr, &min, &max)) { 246 Fail_ 247 } 248 Request_Unify_Integer(vmi, tmi, min) 249 Request_Unify_Integer(vma, tma, max) 250 Return_Unify 251} 252 253static int 254p_dom_check_in(value ve, type te, value vd, type td) 255{ 256 Check_Domain(vd, td) 257 Check_Element(ve, te) 258 Succeed_If(!dom_check_in(ve.nint, te, vd.ptr)) 259} 260 261/* attr_instantiate(Attr, Val) */ 262/*ARGSUSED*/ 263static int 264p_attr_instantiate(value va, type ta, value vc, type tc) 265{ 266 register pword *d; 267 word min, max; 268 int res; 269 int atomic; 270 271 d = va.ptr + DOMAIN_OFF; 272 Dereference_(d); 273 d = d->val.ptr; 274 if (dom_check_in(vc.nint, tc, d)) { 275 Fail_; 276 } 277 atomic = dom_range(d, &min, &max); 278 d = va.ptr + ANY_OFF; 279 Dereference_(d); 280 res = p_schedule_woken(d->val, d->tag); 281 if (res != PSUCCEED) { 282 Bip_Error(res) 283 } 284 if (!atomic) { 285 d = va.ptr + MIN_OFF; 286 Dereference_(d); 287 if (vc.nint > min) { 288 res = p_schedule_woken(d->val, d->tag); 289 } else { 290 res = p_schedule_postponed(d->val, d->tag); 291 } 292 if (res != PSUCCEED) { 293 Bip_Error(res) 294 } 295 296 d = va.ptr + MAX_OFF; 297 Dereference_(d); 298 if (vc.nint < max) { 299 res = p_schedule_woken(d->val, d->tag); 300 } else { 301 res = p_schedule_postponed(d->val, d->tag); 302 } 303 if (res != PSUCCEED) { 304 Bip_Error(res) 305 } 306 } 307 Succeed_ 308} 309 310 311/* lt_test(+H, +Min, +Max) */ 312/*ARGSUSED*/ 313static int 314p_lt_test(value vh, type th, value vmi, type tmi, value vma, type tma) 315{ 316 word min, max, n, n1, k; 317 pword *p; 318 pword *var; 319 int res = RES_NO_CHANGE; 320 321 if (IsInteger(th)) { 322 Succeed_ 323 } 324 325 p = vh.ptr + 1; 326 Dereference_(p); 327 k = p->val.nint; 328 p = vh.ptr + 2; 329 Dereference_(p); 330 if (IsInteger(p->tag)) { 331 Succeed_ 332 } 333 var = p->val.ptr; 334 Var_Domain(var, p); 335 (void) dom_range(p, &min, &max); 336 if (k > 0) { 337 n = -vma.nint/k + max; 338 if (n <= min) 339 ; 340 else if (n < max) { 341 res |= RES_MIN; 342 } 343 else /* if (n == max) */ 344 { 345 Bind_Var(var->val, var->tag, n, TINT) 346 Succeed_; 347 } 348 if (vmi.nint < vma.nint) { /* equality */ 349 n1 = -vmi.nint/k + min; 350 if (n1 >= max) 351 ; 352 else if (n1 > min) { 353 if (res & RES_MIN) { 354 if (n == n1) { 355 Bind_Var(var->val, var->tag, n, TINT) 356 Succeed_; 357 } 358 } 359 res |= RES_MAX; 360 } 361 else /* if (n1 == max) */ 362 { 363 Bind_Var(var->val, var->tag, n1, TINT) 364 Succeed_; 365 } 366 } 367 } 368 else { 369 if (vmi.nint < vma.nint) { /* equality */ 370 n1 = -vmi.nint/k + max; 371 if (n1 <= min) 372 ; 373 else if (n1 < max) { 374 res |= RES_MIN; 375 } 376 else /* if (n1 == max) */ 377 { 378 Bind_Var(var->val, var->tag, n1, TINT) 379 Succeed_; 380 } 381 } 382 n = -vma.nint/k + min; 383 if (n >= max) 384 ; 385 else if (n > min) { 386 if (res & RES_MIN) { 387 if (n == n1) { 388 Bind_Var(var->val, var->tag, n, TINT) 389 Succeed_; 390 } 391 } 392 res |= RES_MAX; 393 } 394 else /* if (n == max) */ 395 { 396 Bind_Var(var->val, var->tag, n, TINT) 397 Succeed_; 398 } 399 } 400 if (res & RES_MIN) { 401 min = dom_remove_smaller(p, k > 0 ? n : n1); 402 if (!min) { 403 Fail_ 404 } 405 } 406 if (res & RES_MAX) { 407 min = dom_remove_greater(p, k > 0 ? n1 : n); 408 if (!min) { 409 Fail_ 410 } 411 } 412 if (res) { 413 k = _domain_changed(var, min, res); 414 Check_Return(k) 415 } 416 Succeed_; 417} 418 419static int 420p_make_extreme(value vt, type tt, value vm, type tm) 421{ 422 register pword *p, *s, *t; 423 pword *unif1, *l1, *unif2, *l2; 424 pword *var; 425 word k; 426 word min, max; 427 int minimize; 428 429 if (IsNil(tt)) { 430 Succeed_ 431 } 432 Check_List(tt) 433 Check_Atom(tm) 434 if (vm.did == d_min0) 435 minimize = 1; 436 else if (vm.did == d_max0) 437 minimize = 0; 438 else { 439 Bip_Error(RANGE_ERROR) 440 } 441 unif1 = l1 = TG++; 442 unif2 = l2 = TG++; 443 Check_Gc; 444 p = vt.ptr; 445 for (;;) 446 { 447 s = p++; 448 Dereference_(s); 449 if (IsStructure(s->tag)) { 450 s = s->val.ptr + 1; 451 t = s + 1; 452 Dereference_(t); 453 if (!IsInteger(t->tag)) { 454 Dereference_(s); 455 k = s->val.nint; 456 var = t->val.ptr; 457 Var_Domain(var, t); 458 (void) dom_range(t, &min, &max); 459 l1->tag.kernel = TLIST; 460 l1->val.ptr = TG; 461 l2->tag.kernel = TLIST; 462 l2->val.ptr = TG + 2; 463 l1 = TG; 464 TG += 4; 465 Check_Gc; 466 l2 = l1 + 2; 467 l1->val.ptr = var; 468 (l1++)->tag.kernel = TREF; 469 l2->tag.kernel = TINT; 470 if (k > 0 && minimize || k < 0 && !minimize) 471 (l2++)->val.nint = min; 472 else 473 (l2++)->val.nint = max; 474 } 475 } 476 Dereference_(p) 477 if (!IsList(p->tag)) 478 break; 479 p = p->val.ptr; 480 } 481 l1->tag.kernel = TNIL; 482 l2->tag.kernel = TNIL; 483 Return_Unify_Pw(unif1->val, unif1->tag, unif2->val, unif2->tag) 484} 485 486/* linear_term_range_ge(+Term, -Res, -Min, -Max, -NewTerm, -Offset) */ 487static int 488p_linear_term_range_ge(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff) 489{ 490 return _linear_term_range(vt, tt, vres, tres, vmi, tmi, vma, tma, 491 vnew, tnew, voff, toff, RANGE_GE); 492} 493 494/* linear_term_range_eq(+Term, -Res, -Min, -Max, -NewTerm, -Offset) */ 495static int 496p_linear_term_range_eq(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff) 497{ 498 return _linear_term_range(vt, tt, vres, tres, vmi, tmi, vma, tma, 499 vnew, tnew, voff, toff, RANGE_EQ); 500} 501 502/* linear_term_range_only(+Term, -Res, -Min, -Max, -NewTerm, -Offset) */ 503static int 504p_linear_term_range_only(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff) 505{ 506 return _linear_term_range(vt, tt, vres, tres, vmi, tmi, vma, tma, 507 vnew, tnew, voff, toff, RANGE_ONLY); 508} 509 510static int 511_linear_term_range(value vt, type tt, value vres, type tres, value vmi, type tmi, value vma, type tma, value vnew, type tnew, value voff, type toff, int ge) 512{ 513 register word min = 0; 514 register word max = 0; 515 register pword *p; 516 register pword *s; 517 register pword *r; 518 register word k; 519 register word maxel = 0; 520 word vars = 0; 521 pword *var; 522 pword *var1; 523 pword *var2; 524 word k1, k2; 525 word sum = 0; 526 pword *last = 0; 527 int constno = 0; 528 529 if (!IsNil(tt)) { 530 p = vt.ptr; 531 for (;;) 532 { 533 s = p++; 534 Dereference_(s); 535 if (IsInteger(s->tag)) { 536 k = s->val.nint; 537 min += k; 538 max += k; 539 sum += k; 540 } 541 else { 542 s = s->val.ptr + 2; 543 r = s - 1; 544 Dereference_(r); 545 k = r->val.nint; 546 Dereference_(s); 547 if (IsInteger(s->tag)) { 548 k *= s->val.nint; 549 min += k; 550 max += k; 551 sum += k; 552 constno++; 553 } 554 else { 555 word mi, ma; 556 557 if (k) { 558 if (!(vars++)) { 559 k1 = k; 560 var = p - 1; 561 var1 = s; 562 } 563 else if (vars == 2) { 564 k2 = k; 565 var2 = s; 566 } 567 } 568 if (!IsMeta(s->tag)) { 569 Bind_Var(vres, tres, RES_EVAL, TINT) 570 Bind_Var(vnew, tnew, vt.ptr, tt.kernel) 571 Succeed_ 572 } 573 Var_Attr(s->val.ptr, s) 574 if (!IsStructure(s->tag)) { 575 Bind_Var(vres, tres, IsRef(s->tag) ? RES_EVAL : RES_ERROR, TINT) 576 Bind_Var(vnew, tnew, vt.ptr, tt.kernel) 577 Succeed_ 578 } 579 Attr_Domain(s, s) 580 if (dom_range(s, &mi, &ma)) { 581 Bind_Var(vres, tres, RES_ERROR, TINT) 582 Bind_Var(vnew, tnew, vt.ptr, tt.kernel) 583 Succeed_ 584 } 585 if (k > 0) { 586 min += k * mi; 587 max += k * ma; 588 k = k * (ma - mi); 589 if (k > maxel) 590 maxel = k; 591 } else if (k < 0) { 592 min += k * ma; 593 max += k * mi; 594 k = k * (mi - ma); 595 if (k > maxel) 596 maxel = k; 597 } 598 if (constno > 0 && last) { 599 if (last < GB && last->val.ptr < GB) { 600 Trail_Pword(last) 601 } 602 last->val.ptr = p - 1; 603 last->tag.kernel = TLIST; 604 } 605 constno = 0; 606 if (ge != RANGE_ONLY) 607 last = p; 608 } 609 } 610 Dereference_(p); 611 if (!IsList(p->tag)) 612 break; 613 p = p->val.ptr; 614 } 615 if (constno && last) { 616 if (last < GB && last->val.ptr < GB) { 617 Trail_Pword(last) 618 } 619 last->tag.kernel = TNIL; 620 } 621 } 622 if (ge == RANGE_ONLY) { 623 Bind_Var(vmi, tmi, min, TINT) 624 Bind_Var(vma, tma, max, TINT) 625 Bind_Var(vres, tres, RES_SOLVED, TINT) 626 Succeed_; 627 } 628 if (max < 0) { 629 Fail_ 630 } 631 else if (max == 0 && min < 0) { /* maximum */ 632 /* create a term because of entailment variant */ 633 p = TG; 634 TG += 2; 635 Check_Gc; 636 p[0].val.nint = sum; 637 p[0].tag.kernel = TINT; 638 p[1].val.ptr = var; 639 p[1].tag.kernel = TLIST; 640 Bind_Var(vnew, tnew, p, TLIST) 641 Bind_Var(vres, tres, 0, TINT) 642 } 643 else if (max == 0) { /* = 0 */ 644 Bind_Var(vres, tres, 1, TINT) 645 } 646 else if (min == 0) { /* >= 0 */ 647 /* create a term because of entailment variant */ 648 p = TG; 649 TG += 2; 650 Check_Gc; 651 p[0].val.nint = sum; 652 p[0].tag.kernel = TINT; 653 p[1].val.ptr = var; 654 p[1].tag.kernel = TLIST; 655 Bind_Var(vnew, tnew, p, TLIST) 656 Bind_Var(vres, tres, 2, TINT) 657 } 658 else if (min > 0) { /* > 0 */ 659 Bind_Var(vres, tres, 3, TINT) 660 } 661 else if (ge == RANGE_GE && vars == 2 && (k1 == 1 || k2 == 1)) { 662 if (k1 != 1) { 663 s = var1; 664 var1 = var2; 665 var2 = s; 666 k2 = k1; 667 } 668 Bind_Var(vnew, tnew, var1, TREF) 669 Bind_Var(vma, tma, var2, TREF) 670 Bind_Var(vmi, tmi, k2, TINT) 671 Bind_Var(voff, toff, sum, TINT) 672 Bind_Var(vres, tres, RES_SIMPLE, TINT) 673 } 674 else if (ge == RANGE_EQ && vars == 2 && sum == 0 && k1*k2 == -1) { 675 Bind_Var(vmi, tmi, var1, TREF) 676 Bind_Var(vma, tma, var2, TREF) 677 Bind_Var(vres, tres, RES_SIMPLE, TINT) 678 } 679 else 680 { 681 p = TG; 682 TG += 2; 683 Check_Gc; 684 p[0].val.nint = sum; 685 p[0].tag.kernel = TINT; 686 p[1].val.ptr = var; 687 p[1].tag.kernel = TLIST; 688 Bind_Var(vnew, tnew, p, TLIST) 689 if (vars == 1) { 690 /* one variable left */ 691 Bind_Var(vmi, tmi, min, TINT) 692 Bind_Var(vma, tma, max, TINT) 693 Bind_Var(vres, tres, 4, TINT) 694 } 695 else if (maxel <= max && maxel <= -min) /* nothing to update */ 696 { 697 Bind_Var(vres, tres, 5, TINT) 698 } 699 else { /* something to update */ 700 Bind_Var(vmi, tmi, min, TINT) 701 Bind_Var(vma, tma, max, TINT) 702 Bind_Var(vres, tres, maxel <= max ? 7 : 8, TINT) 703 } 704 } 705 Succeed_ 706} 707 708/* p is the val.ptr of dom/2 */ 709int 710dom_range(register pword *p, word *mi, word *ma) 711{ 712 register pword *s; 713 register pword *t; 714 register word max; 715 716 p++; 717 Dereference_(p); 718 p = p->val.ptr; 719 s = p++; 720 Dereference_(s); 721 if (IsInteger(s->tag)) 722 *mi = max = s->val.nint; 723 else if (!IsFdInterval(s->val, s->tag)) 724 return 1; 725 else { 726 s = s->val.ptr + 1; 727 t = s++; 728 Dereference_(t); 729 *mi = t->val.nint; 730 Dereference_(s); 731 max = s->val.nint; 732 } 733 Dereference_(p); 734 while (IsList(p->tag)) 735 { 736 p = p->val.ptr; 737 s = p++; 738 Dereference_(s); 739 if (IsInteger(s->tag)) 740 max = s->val.nint; 741 else if (IsFdInterval(s->val, s->tag)){ 742 s = s->val.ptr + 2; 743 Dereference_(s); 744 max = s->val.nint; 745 } else 746 return 1; 747 Dereference_(p); 748 } 749 if (!IsInteger(s->tag)) 750 return 1; 751 *ma = max; 752 return 0; 753} 754 755/* ex_insert_suspension(List, Susp, Ge) */ 756/*ARGSUSED*/ 757static int 758p_ex_insert_suspension(value vt, type tt, value vs, type ts, value vl, type tl) 759{ 760 register pword *p; 761 register pword *s; 762 register pword *r; 763 register word k; 764 int res; 765 766 if (!IsNil(tt)) { 767 p = vt.ptr; 768 for (;;) 769 { 770 s = p++; 771 Dereference_(s); 772 if (!IsInteger(s->tag)) { 773 s = s->val.ptr + 2; 774 r = s - 1; 775 Dereference_(r); 776 k = r->val.nint; 777 Dereference_(s); 778 if (!IsInteger(s->tag)) { 779 if (vl.nint == 0) { 780 res = insert_suspension(s, k > 0 ? MAX_OFF : MIN_OFF, 781 vs.ptr, domain_slot); 782 Check_Return(res) 783 } else { /* equality */ 784 res = insert_suspension(s, MIN_OFF, 785 vs.ptr, domain_slot); 786 Check_Return(res) 787 res = insert_suspension(s, MAX_OFF, 788 vs.ptr, domain_slot); 789 Check_Return(res) 790 } 791 } 792 } 793 Dereference_(p); 794 if (!IsList(p->tag)) 795 break; 796 p = p->val.ptr; 797 } 798 } 799 Succeed_ 800} 801 802/* gec_insert_suspension(X, K, Y, Susp) */ 803/*ARGSUSED*/ 804static int 805p_gec_insert_suspension(value vx, type tx, value vk, type tk, value vy, type ty, value vs, type ts) 806{ 807 int res; 808 809 if (IsRef(tx)) { 810 res = insert_suspension(vx.ptr, MAX_OFF, vs.ptr, domain_slot); 811 Check_Return(res) 812 } 813 if (IsRef(ty)) { 814 res = insert_suspension(vy.ptr, vk.nint > 0 ? MAX_OFF : MIN_OFF, 815 vs.ptr, domain_slot); 816 Check_Return(res) 817 } 818 Succeed_ 819} 820 821/* 822 X + K*Y + C >= D 823 824 K is known to be an integer, X, Y, C, and D may be anything. 825 If we can convert it to the form Var1 + K*Var2 + C >= 0, we continue, 826 otherwise we signal an error. 827*/ 828static int 829p_gec_start(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vd, type td, value ve, type te, value vres, type tres) 830{ 831 register pword *p; 832 833 if (!IsInteger(tc) || !IsInteger(td)) { 834 goto _gec_err_; 835 } 836 if (IsMeta(tx)) { 837 Var_Domain_Check(vx.ptr, p) 838 if (!p) goto _gec_err_; 839 } else if (!IsInteger(tx)) { 840 goto _gec_err_; 841 } 842 if (IsMeta(ty)) { 843 Var_Domain_Check(vy.ptr, p) 844 if (!p) goto _gec_err_; 845 } else if (!IsInteger(ty)) { 846 goto _gec_err_; 847 } 848 vc.nint -= vd.nint; 849 Bind_Var(ve, te, vc.nint, TINT) 850 return p_gec_comp(vx, tx, vk, tk, vy, ty, vc, tc, vres, tres); 851 852_gec_err_: 853 if (!IsInteger(tc) || vd.nint == 0) { 854 Bind_Var(ve, te, vc.ptr, tc.kernel) 855 Bind_Var(vres, tres, RES_AGAIN, TINT) 856 } else { 857 Bind_Var(ve, te, vd.ptr, td.kernel) 858 Bind_Var(vres, tres, RES_AGAIN_NEG, TINT) 859 } 860 Succeed_ 861} 862 863/* 864 >=(X + K*Y + C, D, Bool) 865 866 K is known to be an integer, X, Y, C, and D may be anything. 867 If we can convert it to the form Var1 + K*Var2 + C >= 0, we continue, 868 otherwise we signal an error. 869*/ 870static int 871p_gec_ent_start(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vd, type td, value ve, type te, value vres, type tres) 872{ 873 register pword *p; 874 875 if (!IsInteger(tc) || !IsInteger(td)) { 876 goto _gec_ent_err_; 877 } 878 if (IsMeta(tx)) { 879 Var_Domain_Check(vx.ptr, p) 880 if (!p) goto _gec_ent_err_; 881 } else if (!IsInteger(tx)) { 882 goto _gec_ent_err_; 883 } 884 if (IsMeta(ty)) { 885 Var_Domain_Check(vy.ptr, p) 886 if (!p) goto _gec_ent_err_; 887 } else if (!IsInteger(ty)) { 888 goto _gec_ent_err_; 889 } 890 vc.nint -= vd.nint; 891 Bind_Var(ve, te, vc.nint, TINT) 892 return p_gec_test(vx, tx, vk, tk, vy, ty, vc, tc, vres, tres); 893 894_gec_ent_err_: 895 if (!IsInteger(tc) || vd.nint == 0) { 896 Bind_Var(ve, te, vc.ptr, tc.kernel) 897 Bind_Var(vres, tres, RES_AGAIN, TINT) 898 } else { 899 Bind_Var(ve, te, vd.ptr, td.kernel) 900 Bind_Var(vres, tres, RES_AGAIN_NEG, TINT) 901 } 902 Succeed_ 903} 904 905/*ARGSUSED*/ 906static int 907p_gec_comp(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vres, type tres) 908{ 909 register word c; 910 register pword *dom1, *dom2; 911 register word k = vk.nint; 912 register word m; 913 word minx, maxx, miny, maxy; 914 word newminx; 915 int ret = RES_SOLVED; 916 917 if (IsInteger(tx)) { 918 c = vx.nint + vc.nint; 919 if (IsInteger(ty)) { 920 if (c + k * vy.nint >= 0) { 921 Bind_Var(vres, tres, RES_SOLVED, TINT) 922 Succeed_ 923 } else { 924 Fail_ 925 } 926 } 927 Var_Domain(vy.ptr, dom2); 928_x_inst_: 929 if (dom_range(dom2, &miny, &maxy)) { 930 Bind_Var(vres, tres, RES_ERROR, TINT) 931 Succeed_ 932 } 933 if (k < 0) { 934 /* don't divide negative numbers */ 935 c = (c >= 0) ? c / (-k) : -((-c - k - 1)/(-k)); 936 if (c < miny) { 937 Fail_ 938 } else if (c < maxy) { 939 if (c == miny) { 940 Bind_Var(vy, ty, c, TINT) 941 Bind_Var(vres, tres, ret, TINT) 942 } else { 943 miny = dom_remove_greater(dom2, c); 944 if (!miny) { 945 Fail_ 946 } 947 m = _domain_changed(vy.ptr, miny, RES_MAX); 948 Check_Return(m) 949 Bind_Var(vres, tres, RES_WAKE, TINT) 950 } 951 } else { 952 Bind_Var(vres, tres, ret, TINT) 953 } 954 } else { 955 c = (c >= 0) ? -(c/k) : (-c + k - 1) / k; 956 if (c > maxy) { 957 Fail_ 958 } else if (c > miny) { 959 if (c == maxy) { 960 Bind_Var(vy, ty, c, TINT) 961 Bind_Var(vres, tres, ret, TINT) 962 } else { 963 miny = dom_remove_smaller(dom2, c); 964 if (!miny) { 965 Fail_ 966 } 967 m = _domain_changed(vy.ptr, miny, RES_MIN); 968 Check_Return(m) 969 Bind_Var(vres, tres, RES_WAKE, TINT) 970 } 971 } else { 972 Bind_Var(vres, tres, ret, TINT) 973 } 974 } 975 Succeed_ 976 } 977 else if (IsInteger(ty)) { 978 c = -k * vy.nint - vc.nint; 979 Var_Domain(vx.ptr, dom1); 980_y_inst_: 981 if (dom_range(dom1, &minx, &maxx)) { 982 Bind_Var(vres, tres, RES_ERROR, TINT) 983 Succeed_ 984 } 985 if (c > maxx) { 986 Fail_ 987 } else if (c > minx) { 988 if (c == maxx) { 989 Bind_Var(vx, tx, c, TINT) 990 Bind_Var(vres, tres, ret, TINT) 991 } else { 992 minx = dom_remove_smaller(dom1, c); 993 if (!minx) { 994 Fail_ 995 } 996 m = _domain_changed(vx.ptr, minx, RES_MIN); 997 Check_Return(m) 998 Bind_Var(vres, tres, RES_WAKE, TINT) 999 } 1000 } else { 1001 Bind_Var(vres, tres, ret, TINT) 1002 } 1003 Succeed_ 1004 } 1005 /* both variables */ 1006 c = vc.nint; 1007 Var_Domain(vy.ptr, dom2); 1008 if (vx.ptr == vy.ptr) { 1009 /* equal */ 1010 k++; 1011 if (k == 0) { 1012 if (c >= 0) { 1013 Bind_Var(vres, tres, RES_SOLVED, TINT) 1014 Succeed_; 1015 } else { 1016 Fail_ 1017 } 1018 } 1019 goto _x_inst_; 1020 } 1021 if (dom_range(dom2, &miny, &maxy)) { 1022 Bind_Var(vres, tres, RES_ERROR, TINT) 1023 Succeed_ 1024 } 1025 Var_Domain(vx.ptr, dom1); 1026 if (dom_range(dom1, &minx, &maxx)) { 1027 Bind_Var(vres, tres, RES_ERROR, TINT) 1028 Succeed_ 1029 } 1030 if (k > 0) 1031 m = (maxx + c >= 0) ? -((maxx + c)/k) : (-maxx -c + k - 1) / k; 1032 else 1033 m = (maxx + c >= 0) ? (maxx + c) / (-k) : -((-maxx - c - k - 1)/(-k)); 1034 newminx = -k * (k > 0 ? maxy : miny) - c; 1035 if (m > miny && m < maxy) 1036 { 1037 register word s; 1038 1039 if (k > 0) 1040 s = dom_remove_smaller(dom2, m); 1041 else 1042 s = dom_remove_greater(dom2, m); 1043 if (!s) { 1044 Fail_ 1045 } 1046 if (s == 1) { /* there was a hole in the domain */ 1047 miny = _dom_value(dom2); 1048 Bind_Var(vy, ty, miny, TINT) 1049 c = -k * miny - vc.nint; 1050 goto _y_inst_; 1051 } 1052 m = _domain_changed(vy.ptr, s, k > 0 ? RES_MIN : RES_MAX); 1053 Check_Return(m) 1054 if (newminx > minx) { 1055 s = dom_remove_smaller(dom1, newminx); 1056 if (!s) { 1057 Fail_ 1058 } 1059 if (s == 1) { 1060 minx = _dom_value(dom1); 1061 Bind_Var(vx, tx, minx, TINT) 1062 c = minx + vc.nint; 1063 ret = RES_WAKE; 1064 goto _x_inst_; 1065 } 1066 m = _domain_changed(vx.ptr, s, RES_MIN); 1067 Check_Return(m) 1068 Bind_Var(vres, tres, RES_DELAY_WAKE, TINT) 1069 } else { 1070 Bind_Var(vres, tres, RES_DELAY_WAKE, TINT) 1071 } 1072 } 1073 else if (k > 0 && m == maxy || k < 0 && m == miny) { 1074 Bind_Var(vy, ty, m, TINT) 1075 c = -k * m - vc.nint; 1076 goto _y_inst_; 1077 } 1078 else if (newminx > maxx) { 1079 Fail_ 1080 } 1081 else if (newminx > minx) { 1082 minx = dom_remove_smaller(dom1, newminx); 1083 if (!minx) { 1084 Fail_ 1085 } 1086 m = _domain_changed(vx.ptr, minx, RES_MIN); 1087 Check_Return(m) 1088 Bind_Var(vres, tres, RES_DELAY_WAKE, TINT) 1089 } 1090 else if (minx + k * (k > 0 ? miny : maxy) + c >= 0) { 1091 Bind_Var(vres, tres, RES_SOLVED, TINT) 1092 } 1093 else { 1094 Bind_Var(vres, tres, RES_NO_CHANGE, TINT) 1095 } 1096 Succeed_ 1097} 1098 1099/*ARGSUSED*/ 1100static int 1101p_gec_test(value vx, type tx, value vk, type tk, value vy, type ty, value vc, type tc, value vres, type tres) 1102{ 1103 register word c; 1104 register pword *dom1, *dom2; 1105 register word k = vk.nint; 1106 register word m; 1107 word minx, maxx, miny, maxy; 1108 word newminx; 1109 int ret = RES_SOLVED; 1110 1111 if (IsInteger(tx)) { 1112 c = vx.nint + vc.nint; 1113 if (IsInteger(ty)) { 1114 if (c + k * vy.nint < 0) 1115 ret = RES_FAIL; 1116 Bind_Var(vres, tres, ret, TINT) 1117 Succeed_ 1118 } 1119 Var_Domain(vy.ptr, dom2); 1120_x_inst_test_: 1121 if (dom_range(dom2, &miny, &maxy)) { 1122 Bind_Var(vres, tres, RES_ERROR, TINT) 1123 Succeed_ 1124 } 1125 if (k < 0) { 1126 /* don't divide negative numbers */ 1127 c = (c >= 0) ? c / (-k) : -((-c - k - 1)/(-k)); 1128 if (c < miny) { 1129 ret = RES_FAIL; 1130 } else if (c < maxy) { 1131 ret = RES_DELAY; 1132 } 1133 } else { 1134 c = (c >= 0) ? -(c/k) : (-c + k - 1) / k; 1135 if (c > maxy) { 1136 ret = RES_FAIL; 1137 } else if (c > miny) { 1138 ret = RES_DELAY; 1139 } 1140 } 1141 Bind_Var(vres, tres, ret, TINT) 1142 Succeed_ 1143 } 1144 else if (IsInteger(ty)) { 1145 c = -k * vy.nint - vc.nint; 1146 Var_Domain(vx.ptr, dom1); 1147 if (dom_range(dom1, &minx, &maxx)) { 1148 Bind_Var(vres, tres, RES_ERROR, TINT) 1149 Succeed_ 1150 } 1151 if (c > maxx) { 1152 ret = RES_FAIL; 1153 } else if (c > minx) { 1154 ret = RES_DELAY; 1155 } 1156 Bind_Var(vres, tres, ret, TINT) 1157 Succeed_ 1158 } 1159 /* both variables */ 1160 c = vc.nint; 1161 Var_Domain(vy.ptr, dom2); 1162 if (vx.ptr == vy.ptr) { 1163 /* equal */ 1164 k++; 1165 if (k == 0) { 1166 if (c < 0) 1167 ret = RES_FAIL; 1168 Bind_Var(vres, tres, ret, TINT) 1169 Succeed_; 1170 } 1171 goto _x_inst_test_; 1172 } 1173 if (dom_range(dom2, &miny, &maxy)) { 1174 Bind_Var(vres, tres, RES_ERROR, TINT) 1175 Succeed_ 1176 } 1177 Var_Domain(vx.ptr, dom1); 1178 if (dom_range(dom1, &minx, &maxx)) { 1179 Bind_Var(vres, tres, RES_ERROR, TINT) 1180 Succeed_ 1181 } 1182 if (k > 0) 1183 m = (maxx + c >= 0) ? -((maxx + c)/k) : (-maxx -c + k - 1) / k; 1184 else 1185 m = (maxx + c >= 0) ? (maxx + c) / (-k) : -((-maxx - c - k - 1)/(-k)); 1186 newminx = -k * (k > 0 ? maxy : miny) - c; 1187 if (m > miny && m < maxy) 1188 ret = RES_DELAY; 1189 else if (newminx > maxx) 1190 ret = RES_FAIL; 1191 else if (minx + k * (k > 0 ? miny : maxy) + c >= 0) 1192 ret = RES_SOLVED; 1193 else 1194 ret = RES_DELAY; 1195 Bind_Var(vres, tres, ret, TINT) 1196 Succeed_ 1197} 1198 1199/* ineq_test(+Term, -Res, -Var, -Val) */ 1200static int 1201p_ineq_test(value vt, type tt, value vres, type tres, value vvar, type tvar, value vval, type tval) 1202{ 1203 register word sum = 0; 1204 register pword *p; 1205 register pword *s; 1206 register pword *r; 1207 register word k; 1208 pword *var; 1209 word kvar = 0; 1210 1211 if (IsNil(tt)) { 1212 Bind_Var(vres, tres, RES_SOLVED, TINT) 1213 Succeed_ 1214 } 1215 p = vt.ptr; 1216 for (;;) 1217 { 1218 s = p++; 1219 Dereference_(s); 1220 if (IsInteger(s->tag)) { 1221 sum += s->val.nint; 1222 } 1223 else { 1224 s = s->val.ptr + 2; 1225 r = s - 1; 1226 Dereference_(r); 1227 k = r->val.nint; 1228 Dereference_(s); 1229 if (IsInteger(s->tag)) 1230 sum += k * s->val.nint; 1231 else if (!IsMeta(s->tag)) { 1232 Bind_Var(vres, tres, RES_EVAL, TINT) 1233 Succeed_ 1234 } else { 1235 Var_Attr(s->val.ptr, r) 1236 if (!IsStructure(r->tag)) { 1237 Bind_Var(vres, tres, IsRef(r->tag) ? RES_EVAL : RES_ERROR, TINT) 1238 Succeed_ 1239 } 1240 if (kvar) { 1241 Bind_Var(vvar, tvar, var, TREF) 1242 Bind_Var(vval, tval, s, TREF) 1243 Bind_Var(vres, tres, RES_DELAY, TINT) 1244 Succeed_ 1245 } 1246 else { 1247 kvar = k; 1248 var = s; 1249 } 1250 } 1251 } 1252 Dereference_(p); 1253 if (!IsList(p->tag)) 1254 break; 1255 p = p->val.ptr; 1256 } 1257 if (kvar == 0) { 1258 if (sum != 0) { 1259 Bind_Var(vres, tres, RES_SOLVED, TINT) 1260 Succeed_ 1261 } else { 1262 Fail_ 1263 } 1264 } 1265 k = sum/kvar; 1266 if (k * kvar == sum) { 1267 k = _remove_element(var, -k, (word) TINT); 1268 Check_Return(k); 1269 if (k == RES_FAIL) { 1270 Fail_ 1271 } 1272 Bind_Var(vres, tres, k, TINT) 1273 Succeed_ 1274 } 1275 else { 1276 Bind_Var(vres, tres, RES_SOLVED, TINT) 1277 } 1278 Succeed_ 1279} 1280 1281/* for element/3: 1282 index_values(Index, Term, Value, SI, SV, Res, NewI, NewV, SizeI, SizeV) */ 1283/*ARGSUSED*/ 1284static int 1285p_index_values(value vi, type ti, value vt, type tt, value vv, type tv, value vsi, type tsi, value vsv, type tsv, value vres, type tres, value vnewi, type tnewi, value vnewv, type tnewv, value vs, type ts, value vnsv, type tnsv) 1286{ 1287 word size = 0; 1288 word sizev = 0; 1289 pword *p; 1290 pword *v; 1291 pword *s; 1292 pword *t; 1293 pword *newi; 1294 pword *newv; 1295 pword dom[5]; 1296 pword *vlist, *ilist; 1297 word from, to; 1298 word i; 1299 word firsti, lasti; 1300 int updi, updv; 1301 word isize, vsize; 1302 int res = 0; 1303 word lastv; 1304 word lastv2; 1305 word lastiv; 1306 word lastiv2; 1307 uword lastt = TEND; 1308 uword lastt2 = TEND; 1309 uword lastit = TEND; 1310 uword lastit2 = TEND; 1311 1312 if (IsInteger(ti)) { 1313 Bind_Var(vnewi, tnewi, vi.nint, TINT) 1314 p = &vt.ptr[vi.nint]; 1315 Dereference_(p); 1316 Bind_Var(vnewv, tnewv, p->val.nint, p->tag.all) 1317 Bind_Var(vres, tres, RES_INSTANTIATED, TINT) 1318 Succeed_ 1319 } 1320 Var_Domain(vi.ptr, p); 1321 p++; 1322 s = p + 1; 1323 Dereference_(p); /* I domain list */ 1324 Dereference_(s); 1325 isize = s->val.nint; 1326 if (!IsMeta(tv)) { 1327 v = dom; 1328 dom[1].val.ptr = dom + 3; 1329 dom[1].tag.kernel = TLIST; 1330 dom[3].val.nint = vv.nint; 1331 dom[3].tag.kernel = tv.kernel; 1332 dom[4].tag.kernel = TNIL; 1333 vsize = 1; 1334 } else { 1335 Var_Domain(vv.ptr, v); 1336 s = v + 2; 1337 Dereference_(s); 1338 vsize = s->val.nint; 1339 } 1340 if (vsize != vsv.nint) { 1341 updi = 1; 1342 newi = ilist = Gbl_Tg++; 1343 } else 1344 updi = 0; 1345 if (isize != vsi.nint) { 1346 updv = 1; 1347 newv = vlist = Gbl_Tg++; 1348 } else 1349 updv = 0; 1350 Check_Gc 1351 while (IsList(p->tag)) 1352 { 1353 p = p->val.ptr; 1354 s = p++; 1355 Dereference_(s); 1356 if (IsInteger(s->tag)) 1357 from = to = s->val.nint; 1358 else { 1359 s = s->val.ptr + 1; 1360 t = s++; 1361 Dereference_(t); 1362 Dereference_(s); 1363 from = t->val.nint; 1364 to = s->val.nint; 1365 } 1366 lasti = to + 1; 1367 for (i = from; i <= to; i++) { 1368 pword *argp = &vt.ptr[i]; 1369 Dereference_(argp); 1370 /* lasti* used to speed up domain inclusion */ 1371 if (updi && (ElemEq(argp, lastiv, lastit) || 1372 ElemEq(argp, lastiv2, lastit2) || 1373 !dom_check_in(argp->val.nint, argp->tag, v))) 1374 { 1375 /* add to the new index domain */ 1376 if (i - 1 == lasti) 1377 lasti++; 1378 else if (i - 1 > lasti) { 1379 newi = insert_interval(firsti, lasti, newi); 1380 firsti = lasti = i; 1381 } 1382 else 1383 firsti = lasti = i; 1384 size++; 1385 if (!ElemEq(argp, lastiv, lastit) && 1386 !ElemEq(argp, lastiv2, lastit2)) 1387 { 1388 lastiv2 = lastiv; 1389 lastit2 = lastit; 1390 lastiv = argp->val.nint; 1391 lastit = argp->tag.kernel; 1392 } 1393 } 1394 if (updv && !(updi && !ElemEq(argp, lastiv, lastit) && 1395 !ElemEq(argp, lastv, lastt) && 1396 !ElemEq(argp, lastv2, lastt2))) 1397 { 1398 /* add to the value list */ 1399 newv->val.ptr = Gbl_Tg; 1400 newv->tag.kernel = TLIST; 1401 newv = Gbl_Tg; 1402 Gbl_Tg += 2; 1403 Check_Gc; 1404 newv->val.nint = argp->val.nint; 1405 newv++->tag.kernel = argp->tag.kernel; 1406 lastv2 = lastv; 1407 lastt2 = lastt; 1408 lastv = argp->val.nint; 1409 lastt = argp->tag.kernel; 1410 sizev++; 1411 } 1412 } 1413 if (lasti <= to) 1414 newi = insert_interval(firsti, lasti, newi); 1415 Dereference_(p); 1416 } 1417 if (updi && size == 0 || updv && sizev == 0) { 1418 Fail_ 1419 } 1420 if (updv) 1421 newv->tag.kernel = TNIL; 1422 if (updi) 1423 newi->tag.kernel = TNIL; 1424 if (!updi) 1425 size = isize; 1426 else if (size == isize) 1427 updi = 0; 1428 Bind_Var(vs, ts, size, TINT) 1429 if (!updi && sizev <= 3 && sizev == vsize) { 1430 Bind_Var(vnsv, tnsv, sizev, TINT) 1431 Bind_Var(vres, tres, 0, TINT) 1432 Succeed_ 1433 } 1434 if (size == 1) { 1435 Bind_Var(vnewi, tnewi, firsti, TINT) 1436 p = &vt.ptr[firsti]; 1437 Dereference_(p); 1438 Bind_Var(vnewv, tnewv, p->val.nint, p->tag.all) 1439 Bind_Var(vres, tres, RES_INSTANTIATED, TINT) 1440 Succeed_ 1441 } 1442 if (updi) { 1443 Bind_Var(vnewi, tnewi, ilist->val.all, ilist->tag.all) 1444 res += 1; 1445 } 1446 if (updv && !(updi && sizev <= 3 && sizev == vsize)) { 1447 value v1; 1448 int err; 1449 word ssv; 1450 pword *vints; 1451 pword sorted; 1452 pword key; 1453 1454 if (!updi && sizev == 1) { 1455 Bind_Var(vnewv, tnewv, lastv, lastt) 1456 Bind_Var(vres, tres, RES_INSTANTIATED, TINT) 1457 Succeed_ 1458 } 1459 v1.ptr = vlist->val.ptr; 1460 p = v + 1; 1461 Dereference_(p); 1462 key.val.nint = 0; 1463 key.tag.kernel = TINT; 1464 sorted.val.ptr = ec_keysort(v1, key.val, key.tag, 0, 0, 0, &err); 1465 sorted.tag.kernel = TLIST; 1466 vints = _dom_intersection(p, &sorted, &ssv); 1467 if (ssv == 0) { 1468 Fail_ 1469 } else { 1470 Bind_Var(vnsv, tnsv, ssv, TINT) 1471 } 1472 if (ssv != vsize || ssv == 1) { 1473 if (!updi && ssv == 1) { 1474 Bind_Var(vnewv, tnewv, lastv, lastt) 1475 res = RES_INSTANTIATED; 1476 } else { 1477 Bind_Var(vnewv, tnewv, vints->val.all, vints->tag.all) 1478 res += 2; 1479 } 1480 } 1481 } else { 1482 Bind_Var(vnsv, tnsv, vsize, TINT) 1483 } 1484 Bind_Var(vres, tres, res, TINT) 1485 Succeed_ 1486} 1487 1488/* p is the val.ptr of dom/2 */ 1489int 1490dom_check_in(word e, type tag, register pword *p) 1491{ 1492 register pword *s; 1493 register pword *t; 1494 register int res; 1495 value v1; 1496 1497 p++; 1498 Dereference_(p); 1499 v1.nint = e; 1500 if (IsInteger(tag)) 1501 { 1502 while (IsList(p->tag)) 1503 { 1504 p = p->val.ptr; 1505 s = p++; 1506 Dereference_(s); 1507 if (!IsFdInterval(s->val, s->tag)) { 1508 if (IsInteger(s->tag)) { 1509 if (s->val.nint == e) 1510 return 0; 1511 else if (s->val.nint > e) 1512 return 1; 1513 } else { 1514 res = ec_compare_terms(s->val, s->tag, v1, tag); 1515 if (res == 0) 1516 return 0; 1517 else if (res > 0) 1518 return 1; 1519 } 1520 } else { 1521 s = s->val.ptr + 1; 1522 t = s++; 1523 Dereference_(t); 1524 Dereference_(s); 1525 if (t->val.nint > e) 1526 return 1; 1527 else if (s->val.nint >= e) 1528 return 0; 1529 } 1530 Dereference_(p); 1531 } 1532 } 1533 else 1534 { 1535 while (IsList(p->tag)) 1536 { 1537 p = p->val.ptr; 1538 s = p++; 1539 Dereference_(s); 1540 if (!IsFdInterval(s->val, s->tag)) { 1541 res = ec_compare_terms(s->val, s->tag, v1, tag); 1542 if (res == 0) 1543 return 0; 1544 else if (res > 0) 1545 return 1; 1546 } 1547 Dereference_(p); 1548 } 1549 } 1550 return 1; 1551} 1552 1553pword * 1554insert_interval(word first, word last, pword *newi) 1555{ 1556 newi->val.ptr = Gbl_Tg; 1557 newi->tag.kernel = TLIST; 1558 newi = Gbl_Tg; 1559 Gbl_Tg += 2; 1560 Check_Gc 1561 if (first == last) { 1562 newi->val.nint = first; 1563 newi++->tag.kernel = TINT; 1564 } else if (first + 1 == last) { 1565 newi->val.nint = first; 1566 newi++->tag.kernel = TINT; 1567 newi->val.ptr = Gbl_Tg; 1568 newi->tag.kernel = TLIST; 1569 newi = Gbl_Tg; 1570 Gbl_Tg += 2; 1571 Check_Gc 1572 newi->val.nint = last; 1573 newi++->tag.kernel = TINT; 1574 } else if (first < last) { 1575 pword *p = Gbl_Tg; 1576 1577 Gbl_Tg += 3; 1578 Check_Gc 1579 newi->val.ptr = p; 1580 newi++->tag.kernel = TCOMP; 1581 p[0].val.did = d_interval; 1582 p[0].tag.kernel = TDICT; 1583 p[1].val.nint = first; 1584 p[1].tag.kernel = TINT; 1585 p[2].val.nint = last; 1586 p[2].tag.kernel = TINT; 1587 } 1588 return newi; 1589} 1590 1591/* dom_intersection(Dom1, Dom2, Inters, NewSize) */ 1592static int 1593p_dom_intersection(value vd1, type td1, value vd2, type td2, value vi, type ti, value vs, type ts) 1594{ 1595 register pword *d1, *d2; /* list pointers */ 1596 register pword *p; 1597 word size; 1598 dident dd; 1599 Prepare_Requests; 1600 1601 Check_Domain(vd1, td1) 1602 Check_Domain(vd2, td2) 1603 dd = vd1.ptr->val.did; 1604 d1 = vd1.ptr + 1; 1605 Dereference_(d1); 1606 d2 = vd2.ptr + 1; 1607 Dereference_(d2); 1608 if (IsNil(d1->tag) || IsNil(d2->tag)) { 1609 Fail_; 1610 } 1611 d1 = _dom_intersection(d1, d2, &size); 1612 if (size == 0) { 1613 Fail_; 1614 } 1615 p = Gbl_Tg; 1616 Gbl_Tg += 3; 1617 Check_Gc; 1618 p[0].val.did = dd; 1619 p[0].tag.all = TDICT; 1620 p[1].val.ptr = d1->val.ptr; 1621 p[1].tag.all = d1->tag.all; 1622 p[2].val.nint = size; 1623 p[2].tag.all = TINT; 1624 Request_Unify_Integer(vs, ts, size); 1625 Request_Unify_Structure(vi, ti, p); 1626 Return_Unify; 1627} 1628 1629static pword * 1630_dom_intersection( 1631 register pword *d1, /* input: list pointers */ 1632 register pword *d2, 1633 word *dsize) /* output: intersection size */ 1634 1635{ 1636 register pword *s1, *s2; 1637 register pword *t1, *t2; 1638 register pword *p; 1639 word from1, from2, fromi, fromj; 1640 word to1, to2, toi, toj; 1641 word tag1, tag2; 1642 word size = 0; 1643 pword *ints; /* result */ 1644 int res; 1645 int was_int = 0; 1646 1647 p = ints = Gbl_Tg; 1648 Gbl_Tg++; 1649 Check_Gc; 1650 d1 = d1->val.ptr; 1651 s1 = d1++; 1652 Dereference_(s1); 1653 if (IsInteger(s1->tag)) { 1654 tag1 = TINT; 1655 from1 = to1 = s1->val.nint; 1656 } else if (!IsFdInterval(s1->val, s1->tag)) { 1657 tag1 = s1->tag.kernel; 1658 } else { 1659 s1 = s1->val.ptr + 1; 1660 t1 = s1++; 1661 Dereference_(t1); 1662 Dereference_(s1); 1663 from1 = t1->val.nint; 1664 to1 = s1->val.nint; 1665 tag1 = TINT; 1666 } 1667 d2 = d2->val.ptr; 1668 s2 = d2++; 1669 Dereference_(s2); 1670 if (IsInteger(s2->tag)) { 1671 tag2 = TINT; 1672 from2 = to2 = s2->val.nint; 1673 } else if (!IsFdInterval(s2->val, s2->tag)) { 1674 tag2 = s2->tag.kernel; 1675 } else { 1676 s2 = s2->val.ptr + 1; 1677 t2 = s2++; 1678 Dereference_(t2); 1679 Dereference_(s2); 1680 from2 = t2->val.nint; 1681 to2 = s2->val.nint; 1682 tag2 = TINT; 1683 } 1684 for (;;) 1685 { 1686 if (IsTag(tag1, TINT) && IsTag(tag2, TINT)) { 1687 fromi = from1 > from2 ? from1 : from2; 1688 if (to1 > to2) { 1689 toi = to2; 1690 res = 1; 1691 } else { 1692 res = to1 < to2 ? -1 : 0; 1693 toi = to1; 1694 } 1695 if (fromi <= toi) { 1696 if (was_int) { 1697 if (fromi <= toj + 1) { /* merge */ 1698 if (toi > toj) 1699 toj = toi; 1700 } 1701 else { 1702 p = insert_interval(fromj, toj, p); 1703 size += toj - fromj + 1; 1704 fromj = fromi; 1705 toj = toi; 1706 } 1707 } else { 1708 fromj = fromi; 1709 toj = toi; 1710 was_int = 1; 1711 } 1712 } 1713 } else { 1714 res = ec_compare_terms(s1->val, s1->tag, s2->val, s2->tag); 1715 if (!res) { 1716 if (was_int) { 1717 p = insert_interval(fromj, toj, p); 1718 size += toj - fromj + 1; 1719 was_int = 0; 1720 } 1721 p->val.ptr = Gbl_Tg; 1722 p->tag.kernel = TLIST; 1723 p = Gbl_Tg; 1724 Gbl_Tg += 2; 1725 Check_Gc 1726 p->val.all = s1->val.all; 1727 p++->tag.kernel = s1->tag.kernel; 1728 size++; 1729 } 1730 } 1731 if (res <= 0) { 1732 Dereference_(d1); 1733 if (IsNil(d1->tag)) 1734 break; 1735 d1 = d1->val.ptr; 1736 s1 = d1++; 1737 Dereference_(s1); 1738 if (IsInteger(s1->tag)) { 1739 tag1 = TINT; 1740 from1 = to1 = s1->val.nint; 1741 } else if (!IsFdInterval(s1->val, s1->tag)) { 1742 tag1 = s1->tag.kernel; 1743 } else { 1744 s1 = s1->val.ptr + 1; 1745 t1 = s1++; 1746 Dereference_(t1); 1747 Dereference_(s1); 1748 from1 = t1->val.nint; 1749 to1 = s1->val.nint; 1750 tag1 = TINT; 1751 } 1752 } 1753 if (res >= 0) { 1754 Dereference_(d2); 1755 if (IsNil(d2->tag)) 1756 break; 1757 d2 = d2->val.ptr; 1758 s2 = d2++; 1759 Dereference_(s2); 1760 if (IsInteger(s2->tag)) { 1761 tag2 = TINT; 1762 from2 = to2 = s2->val.nint; 1763 } else if (!IsFdInterval(s2->val, s2->tag)) { 1764 tag2 = s2->tag.kernel; 1765 } else { 1766 s2 = s2->val.ptr + 1; 1767 t2 = s2++; 1768 Dereference_(t2); 1769 Dereference_(s2); 1770 from2 = t2->val.nint; 1771 to2 = s2->val.nint; 1772 tag2 = TINT; 1773 } 1774 } 1775 } 1776 if (was_int) { 1777 p = insert_interval(fromj, toj, p); 1778 size += toj - fromj + 1; 1779 } 1780 p->tag.all = TNIL; 1781 *dsize = size; 1782 if (size == 0) 1783 return 0; 1784 return ints; 1785} 1786 1787/* dom_compare(Comp, Dom1, Dom2) */ 1788static int 1789p_dom_compare(value vc, type tc, value vd1, type td1, value vd2, type td2) 1790{ 1791 register pword *d1, *d2; /* list pointers */ 1792 register pword *s1, *s2; 1793 register pword *t1, *t2; 1794 register word tag1, tag2; 1795 word from1, from2; 1796 word to1, to2; 1797 int res = EQ; 1798 int comp; 1799 int next = 0; 1800 int move; 1801 1802 Check_Output_Atom(tc); 1803 Check_Domain(vd1, td1) 1804 Check_Domain(vd2, td2) 1805 d1 = vd1.ptr + 1; 1806 Dereference_(d1); 1807 d2 = vd2.ptr + 1; 1808 Dereference_(d2); 1809 if (IsNil(d1->tag)) { 1810 if (IsNil(d2->tag)) { 1811 Return_Unify_Atom(vc, tc, d_.unify0) 1812 } else { 1813 Return_Unify_Atom(vc, tc, d_.inf0) 1814 } 1815 } else if (IsNil(d2->tag)) { 1816 Return_Unify_Atom(vc, tc, d_.sup0) 1817 } 1818 d1 = d1->val.ptr; 1819 s1 = d1++; 1820 Dereference_(s1); 1821 if (!IsFdInterval(s1->val, s1->tag)) { 1822 tag1 = s1->tag.kernel; 1823 from1 = to1 = s1->val.nint; 1824 } else { 1825 s1 = s1->val.ptr + 1; 1826 t1 = s1++; 1827 Dereference_(t1); 1828 Dereference_(s1); 1829 from1 = t1->val.nint; 1830 to1 = s1->val.nint; 1831 tag1 = TINT; 1832 } 1833 d2 = d2->val.ptr; 1834 s2 = d2++; 1835 Dereference_(s2); 1836 if (!IsFdInterval(s2->val, s2->tag)) { 1837 tag2 = s2->tag.kernel; 1838 from2 = to2 = s2->val.nint; 1839 } else { 1840 s2 = s2->val.ptr + 1; 1841 t2 = s2++; 1842 Dereference_(t2); 1843 Dereference_(s2); 1844 from2 = t2->val.nint; 1845 to2 = s2->val.nint; 1846 tag2 = TINT; 1847 } 1848 move = DOM_BOTH; 1849 for (;;) 1850 { 1851 if (move == DOM_BOTH && IsTag(tag1, TINT) && IsTag(tag2, TINT)) { 1852 if (from1 < from2) { 1853 res &= GT; 1854 if (next == WAIT_2) { 1855 Fail_ 1856 } 1857 } else if (from1 > from2) { 1858 res &= LT; 1859 if (next == WAIT_1) { 1860 Fail_ 1861 } 1862 } else 1863 next = 0; 1864 if (to1 < to2) { 1865 if (to1 >= from2) { 1866 from2 = to1 + 1; 1867 } else 1868 next = WAIT_1; 1869 comp = -1; 1870 } else if (to1 > to2) { 1871 if (to2 >= from1) { 1872 from1 = to2 + 1; 1873 } else 1874 next = WAIT_2; 1875 comp = 1; 1876 } else { 1877 comp = 0; 1878 } 1879 } else if (move == DOM_BOTH) { 1880 comp = ec_compare_terms(s1->val, s1->tag, s2->val, s2->tag); 1881 if (comp < 0) { 1882 if (next == WAIT_2) { 1883 Fail_ 1884 } 1885 res &= GT; 1886 next = WAIT_1; 1887 } 1888 else if (comp > 0) { 1889 if (next == WAIT_1) { 1890 Fail_ 1891 } 1892 res &= LT; 1893 next = WAIT_2; 1894 } else 1895 next = 0; 1896 } else if (move == DOM_1) { 1897 if (next == WAIT_2) { 1898 Fail_ 1899 } 1900 res &= GT; 1901 break; 1902 } else if (move == DOM_2) { 1903 if (next == WAIT_1) { 1904 Fail_ 1905 } 1906 res &= LT; 1907 break; 1908 } else 1909 break; 1910 if (!res) { 1911 Fail_; 1912 } 1913 if (comp <= 0) { 1914 Dereference_(d1); 1915 if (IsNil(d1->tag)) 1916 move &= DOM_2; 1917 else { 1918 d1 = d1->val.ptr; 1919 s1 = d1++; 1920 Dereference_(s1); 1921 if (IsInteger(s1->tag)) { 1922 from1 = to1 = s1->val.nint; 1923 tag1 = TINT; 1924 } else if (!IsFdInterval(s1->val, s1->tag)) { 1925 tag1 = s1->tag.kernel; 1926 } else { 1927 s1 = s1->val.ptr + 1; 1928 t1 = s1++; 1929 Dereference_(t1); 1930 Dereference_(s1); 1931 from1 = t1->val.nint; 1932 to1 = s1->val.nint; 1933 tag1 = TINT; 1934 } 1935 } 1936 } 1937 if (comp >= 0) { 1938 Dereference_(d2); 1939 if (IsNil(d2->tag)) 1940 move &= DOM_1; 1941 else { 1942 d2 = d2->val.ptr; 1943 s2 = d2++; 1944 Dereference_(s2); 1945 if (IsInteger(s2->tag)) { 1946 from2 = to2 = s2->val.nint; 1947 tag2 = TINT; 1948 } else if (!IsFdInterval(s2->val, s2->tag)) { 1949 tag2 = s2->tag.kernel; 1950 } else { 1951 s2 = s2->val.ptr + 1; 1952 t2 = s2++; 1953 Dereference_(t2); 1954 Dereference_(s2); 1955 from2 = t2->val.nint; 1956 to2 = s2->val.nint; 1957 tag2 = TINT; 1958 } 1959 } 1960 } 1961 } 1962 if (!res) { 1963 Fail_; 1964 } 1965 Return_Unify_Atom(vc, tc, (res == EQ) ? d_.unify0 : ( 1966 (res == LT) ? d_.inf0 : d_.sup0)) 1967} 1968 1969/* dom_union(Dom1, Dom2, Union, NewSize) */ 1970static int 1971p_dom_union(value vd1, type td1, value vd2, type td2, value vu, type tu, value vs, type ts) 1972{ 1973 register pword *d1, *d2; /* list pointers */ 1974 register pword *s1, *s2; 1975 register pword *t1, *t2; 1976 register pword *p; 1977 word from1, from2, fromi; 1978 word to1, to2, toi; 1979 register word tag1, tag2; 1980 word size = 0; 1981 word size1, size2; 1982 pword *ints; /* result */ 1983 dident dd; 1984 int next; 1985 int res; 1986 int was_int = 0; 1987 int can_leave = 0; 1988 Prepare_Requests; 1989 1990 next = DOM_NONE; 1991 Check_Domain(vd1, td1) 1992 Check_Domain(vd2, td2) 1993 dd = vd1.ptr->val.did; 1994 d1 = vd1.ptr + 1; 1995 t1 = d1 + 1; 1996 Dereference_(d1); 1997 Dereference_(t1); 1998 size1 = t1->val.nint; 1999 d2 = vd2.ptr + 1; 2000 t2 = d2 + 1; 2001 Dereference_(d2); 2002 Dereference_(t2); 2003 size2 = t2->val.nint; 2004 if (IsNil(d1->tag)) { 2005 if (IsNil(d2->tag)) { 2006 Fail_ 2007 } else { 2008 Request_Unify_Integer(vs, ts, size2); 2009 Request_Unify_Structure(vu, tu, vd2.ptr); 2010 Return_Unify; 2011 } 2012 } else { 2013 d1 = d1->val.ptr; 2014 s1 = d1++; 2015 Dereference_(s1); 2016 if (!IsFdInterval(s1->val, s1->tag)) { 2017 tag1 = s1->tag.kernel; 2018 from1 = to1 = s1->val.nint; 2019 } else { 2020 s1 = s1->val.ptr + 1; 2021 t1 = s1++; 2022 Dereference_(t1); 2023 Dereference_(s1); 2024 from1 = t1->val.nint; 2025 to1 = s1->val.nint; 2026 tag1 = TINT; 2027 } 2028 next |= DOM_1; 2029 } 2030 if (IsNil(d2->tag)) { 2031 Request_Unify_Integer(vs, ts, size1); 2032 Request_Unify_Structure(vu, tu, vd1.ptr); 2033 Return_Unify; 2034 } else { 2035 d2 = d2->val.ptr; 2036 s2 = d2++; 2037 Dereference_(s2); 2038 if (!IsFdInterval(s2->val, s2->tag)) { 2039 tag2 = s2->tag.kernel; 2040 from2 = to2 = s2->val.nint; 2041 } else { 2042 s2 = s2->val.ptr + 1; 2043 t2 = s2++; 2044 Dereference_(t2); 2045 Dereference_(s2); 2046 from2 = t2->val.nint; 2047 to2 = s2->val.nint; 2048 tag2 = TINT; 2049 } 2050 next |= DOM_2; 2051 } 2052 p = ints = Gbl_Tg; 2053 Gbl_Tg++; 2054 Check_Gc; 2055 for (;;) 2056 { 2057 if (IsTag(tag1, TINT) && IsTag(tag2, TINT)) { 2058 if (next == DOM_BOTH && from1 <= from2 || next == DOM_1) 2059 res = -1; 2060 else 2061 res = 1; 2062 } else if (next == DOM_BOTH) 2063 res = ec_compare_terms(s1->val, s1->tag, s2->val, s2->tag); 2064 else if (next == DOM_1) 2065 res = -1; 2066 else 2067 res = 1; 2068 if (res <= 0) { 2069 if (IsTag(tag1, TINT)) { 2070 if (was_int) { 2071 if (from1 <= toi + 1) { /* merge */ 2072 if (to1 > toi) 2073 toi = to1; 2074 can_leave = 0; 2075 } else { 2076 p = insert_interval(fromi, toi, p); 2077 size += toi - fromi + 1; 2078 fromi = from1; 2079 toi = to1; 2080 can_leave = 1; 2081 } 2082 } else { 2083 fromi = from1; 2084 toi = to1; 2085 was_int = 1; 2086 can_leave = 0; 2087 } 2088 size1 -= to1 - from1 + 1; 2089 } else { /* atomic */ 2090 if (was_int) { 2091 p = insert_interval(fromi, toi, p); 2092 size += toi - fromi + 1; 2093 was_int = 0; 2094 } 2095 p->val.ptr = Gbl_Tg; 2096 p->tag.kernel = TLIST; 2097 p = Gbl_Tg; 2098 Gbl_Tg += 2; 2099 Check_Gc 2100 size++; 2101 p->val.all = s1->val.all; 2102 p++->tag.kernel = s1->tag.kernel; 2103 size1--; 2104 can_leave = 1; 2105 } 2106 Dereference_(d1); 2107 if (!(next & DOM_2) && (can_leave || IsNil(d1->tag))) { 2108 size += size1; 2109 break; 2110 } 2111 if (IsNil(d1->tag)) { 2112 next &= ~DOM_1; 2113 } else { 2114 d1 = d1->val.ptr; 2115 s1 = d1++; 2116 Dereference_(s1); 2117 if (IsInteger(s1->tag)) { 2118 from1 = to1 = s1->val.nint; 2119 tag1 = TINT; 2120 } else if (!IsFdInterval(s1->val, s1->tag)) { 2121 tag1 = s1->tag.kernel; 2122 } else { 2123 s1 = s1->val.ptr + 1; 2124 t1 = s1++; 2125 Dereference_(t1); 2126 Dereference_(s1); 2127 from1 = t1->val.nint; 2128 to1 = s1->val.nint; 2129 tag1 = TINT; 2130 } 2131 } 2132 } 2133 if (res >= 0) { 2134 if (IsTag(tag2, TINT)) { 2135 if (was_int) { 2136 if (from2 <= toi + 1) { /* merge */ 2137 if (to2 > toi) 2138 toi = to2; 2139 can_leave = 0; 2140 } else { 2141 p = insert_interval(fromi, toi, p); 2142 size += toi - fromi + 1; 2143 fromi = from2; 2144 toi = to2; 2145 can_leave = 1; 2146 } 2147 } else { 2148 fromi = from2; 2149 toi = to2; 2150 was_int = 1; 2151 can_leave = 1; 2152 } 2153 size2 -= to2 - from2 + 1; 2154 } else if (res > 0) { /* atomic */ 2155 if (was_int) { 2156 p = insert_interval(fromi, toi, p); 2157 size += toi - fromi + 1; 2158 was_int = 0; 2159 } 2160 p->val.ptr = Gbl_Tg; 2161 p->tag.kernel = TLIST; 2162 p = Gbl_Tg; 2163 Gbl_Tg += 2; 2164 Check_Gc 2165 size++; 2166 p->val.all = s2->val.all; 2167 p++->tag.kernel = s2->tag.kernel; 2168 size2--; 2169 can_leave = 1; 2170 } else 2171 size2--; 2172 Dereference_(d2); 2173 if (!(next & DOM_1) && (can_leave || IsNil(d2->tag))) { 2174 size += size2; 2175 d1 = d2; 2176 break; 2177 } 2178 if (IsNil(d2->tag)) { 2179 next &= ~DOM_2; 2180 continue; 2181 } 2182 d2 = d2->val.ptr; 2183 s2 = d2++; 2184 Dereference_(s2); 2185 if (IsInteger(s2->tag)) { 2186 from2 = to2 = s2->val.nint; 2187 tag2 = TINT; 2188 } else if (!IsFdInterval(s2->val, s2->tag)) { 2189 tag2 = s2->tag.kernel; 2190 } else { 2191 s2 = s2->val.ptr + 1; 2192 t2 = s2++; 2193 Dereference_(t2); 2194 Dereference_(s2); 2195 from2 = t2->val.nint; 2196 to2 = s2->val.nint; 2197 tag2 = TINT; 2198 } 2199 } 2200 } 2201 if (was_int) { 2202 p = insert_interval(fromi, toi, p); 2203 size += toi - fromi + 1; 2204 } 2205 *p = *d1; 2206 if (size == 0) { 2207 Fail_; 2208 } 2209 p = Gbl_Tg; 2210 Gbl_Tg += 3; 2211 Check_Gc; 2212 p[0].val.did = dd; 2213 p[0].tag.all = TDICT; 2214 p[1].val.ptr = ints->val.ptr; 2215 p[1].tag.all = TLIST; 2216 p[2].val.nint = size; 2217 p[2].tag.all = TINT; 2218 Request_Unify_Integer(vs, ts, size); 2219 Request_Unify_Structure(vu, tu, p); 2220 Return_Unify; 2221} 2222 2223/* dom_difference(Dom1, Dom2, Diff, NewSize) */ 2224static int 2225p_dom_difference(value vd1, type td1, value vd2, type td2, value vi, type ti, value vs, type ts) 2226{ 2227 register pword *d1, *d2; /* list pointers */ 2228 register pword *s1, *s2; 2229 register pword *t1, *t2; 2230 register pword *p; 2231 register word tag1, tag2; 2232 word from1, from2; 2233 word to1, to2, toi; 2234 word size = 0; 2235 word size1; 2236 pword *diff; /* result */ 2237 dident dd; 2238 int res; 2239 int was_int = 0; 2240 Prepare_Requests; 2241 d1 = vd1.ptr + 1; 2242 2243 Check_Domain(vd1, td1) 2244 Check_Domain(vd2, td2) 2245 dd = vd1.ptr->val.did; 2246 d1 = vd1.ptr + 1; 2247 t1 = d1 + 1; 2248 Dereference_(d1); 2249 Dereference_(t1); 2250 size1 = t1->val.nint; 2251 d2 = vd2.ptr + 1; 2252 Dereference_(d2); 2253 if (IsNil(d1->tag)) { 2254 Fail_; 2255 } 2256 else if (IsNil(d2->tag)) { 2257 t1 = vd1.ptr + 2; 2258 Dereference_(t1); 2259 size = t1->val.nint; 2260 Request_Unify_Integer(vs, ts, size); 2261 Request_Unify_Structure(vi, ti, vd1.ptr); 2262 Return_Unify; 2263 } 2264 p = diff = Gbl_Tg; 2265 Gbl_Tg++; 2266 Check_Gc; 2267 d1 = d1->val.ptr; 2268 s1 = d1++; 2269 Dereference_(s1); 2270 if (IsInteger(s1->tag)) { 2271 tag1 = TINT; 2272 from1 = to1 = s1->val.nint; 2273 size1--; 2274 was_int = 1; 2275 } else if (!IsFdInterval(s1->val, s1->tag)) { 2276 tag1 = s1->tag.kernel; 2277 size1--; 2278 } else { 2279 s1 = s1->val.ptr + 1; 2280 t1 = s1++; 2281 Dereference_(t1); 2282 Dereference_(s1); 2283 from1 = t1->val.nint; 2284 to1 = s1->val.nint; 2285 tag1 = TINT; 2286 size1 -= to1 - from1 + 1; 2287 was_int = 1; 2288 } 2289 d2 = d2->val.ptr; 2290 s2 = d2++; 2291 Dereference_(s2); 2292 if (!IsFdInterval(s2->val, s2->tag)) { 2293 tag2 = s2->tag.kernel; 2294 to2 = from2 = s2->val.nint; 2295 } else { 2296 s2 = s2->val.ptr + 1; 2297 t2 = s2++; 2298 Dereference_(t2); 2299 Dereference_(s2); 2300 from2 = t2->val.nint; 2301 to2 = s2->val.nint; 2302 tag2 = TINT; 2303 } 2304 for (;;) 2305 { 2306 if (IsTag(tag1, TINT) && IsTag(tag2, TINT)) { 2307 if (from1 < from2) { 2308 toi = to1 < from2 ? to1 : from2 - 1; 2309 p = insert_interval(from1, toi, p); 2310 size += toi - from1 + 1; 2311 } 2312 if (to1 > to2) { 2313 if (from1 <= to2) 2314 from1 = to2 + 1; 2315 res = 1; 2316 was_int = 1; 2317 } else { 2318 res = to1 < to2 ? -1 : 0; 2319 was_int = 0; 2320 } 2321 } else { 2322 res = ec_compare_terms(s1->val, s1->tag, s2->val, s2->tag); 2323 Dereference_(d2); 2324 if (res < 0 || res > 0 && IsNil(d2->tag)) { 2325 if (IsTag(tag1, TINT)) { 2326 p = insert_interval(from1, to1, p); 2327 size += to1 - from1 + 1; 2328 was_int = 0; 2329 } else { 2330 p->val.ptr = Gbl_Tg; 2331 p->tag.kernel = TLIST; 2332 p = Gbl_Tg; 2333 Gbl_Tg += 2; 2334 Check_Gc 2335 p->val.all = s1->val.all; 2336 p++->tag.kernel = s1->tag.kernel; 2337 size++; 2338 } 2339 } 2340 } 2341 if (res >= 0) { 2342 Dereference_(d2); 2343 if (IsNil(d2->tag)) { 2344 size += size1; 2345 break; 2346 } 2347 d2 = d2->val.ptr; 2348 s2 = d2++; 2349 Dereference_(s2); 2350 if (IsInteger(s2->tag)) { 2351 tag2 = TINT; 2352 from2 = to2 = s2->val.nint; 2353 } else if (!IsFdInterval(s2->val, s2->tag)) { 2354 tag2 = s2->tag.kernel; 2355 } else { 2356 s2 = s2->val.ptr + 1; 2357 t2 = s2++; 2358 Dereference_(t2); 2359 Dereference_(s2); 2360 from2 = t2->val.nint; 2361 to2 = s2->val.nint; 2362 tag2 = TINT; 2363 } 2364 } 2365 if (res <= 0) { 2366 Dereference_(d1); 2367 if (IsNil(d1->tag)) 2368 break; 2369 d1 = d1->val.ptr; 2370 s1 = d1++; 2371 Dereference_(s1); 2372 if (IsInteger(s1->tag)) { 2373 tag1 = TINT; 2374 from1 = to1 = s1->val.nint; 2375 size1--; 2376 was_int = 1; 2377 } else if (!IsFdInterval(s1->val, s1->tag)) { 2378 tag1 = s1->tag.kernel; 2379 size1--; 2380 } else { 2381 s1 = s1->val.ptr + 1; 2382 t1 = s1++; 2383 Dereference_(t1); 2384 Dereference_(s1); 2385 from1 = t1->val.nint; 2386 to1 = s1->val.nint; 2387 tag1 = TINT; 2388 size1 -= to1 - from1 + 1; 2389 was_int = 1; 2390 } 2391 } 2392 } 2393 if (was_int) { 2394 p = insert_interval(from1, to1, p); 2395 size += to1 - from1 + 1; 2396 } 2397 Dereference_(d1); 2398 *p = *d1; 2399 if (size == 0) { 2400 Fail_; 2401 } 2402 p = Gbl_Tg; 2403 Gbl_Tg += 3; 2404 Check_Gc; 2405 p[0].val.did = dd; 2406 p[0].tag.all = TDICT; 2407 p[1].val.ptr = diff->val.ptr; 2408 p[1].tag.all = TLIST; 2409 p[2].val.nint = size; 2410 p[2].tag.all = TINT; 2411 Request_Unify_Integer(vs, ts, size); 2412 Request_Unify_Structure(vi, ti, p); 2413 Return_Unify; 2414} 2415 2416 2417/* dvar_remove_smaller(Var, Min) */ 2418static int 2419p_dvar_remove_smaller(value vvar, type tvar, value vm, type tm) 2420{ 2421 register pword *v; 2422 register pword *p; 2423 word oldsize, size; 2424 2425 Check_Integer(tm) 2426 if (!IsMeta(tvar)) { 2427 Check_Integer(tvar) 2428 Succeed_If(vvar.nint >= vm.nint) 2429 } 2430 Check_Dvar(vvar.ptr, v); 2431 Attr_Domain(v, v); 2432 p = v + 2; 2433 Dereference_(p); 2434 oldsize = p->val.nint; 2435 size = dom_remove_smaller(v, vm.nint); 2436 Check_Return(size) 2437 if (!size) { 2438 Fail_ 2439 } 2440 if (size < oldsize) 2441 oldsize = _domain_changed(vvar.ptr, size, RES_MIN); 2442 Check_Return(oldsize) 2443 Succeed_ 2444} 2445 2446/* dvar_remove_greater(Var, Max) */ 2447static int 2448p_dvar_remove_greater(value vvar, type tvar, value vm, type tm) 2449{ 2450 register pword *v; 2451 register pword *p; 2452 word oldsize, size; 2453 2454 Check_Integer(tm) 2455 if (!IsMeta(tvar)) { 2456 Check_Integer(tvar) 2457 Succeed_If(vvar.nint <= vm.nint) 2458 } 2459 Check_Dvar(vvar.ptr, v); 2460 Attr_Domain(v, v); 2461 p = v + 2; 2462 Dereference_(p); 2463 oldsize = p->val.nint; 2464 size = dom_remove_greater(v, vm.nint); 2465 Check_Return(size) 2466 if (!size) { 2467 Fail_ 2468 } 2469 if (size < oldsize) 2470 oldsize = _domain_changed(vvar.ptr, size, RES_MAX); 2471 Check_Return(oldsize) 2472 Succeed_ 2473} 2474 2475int 2476dom_remove_greater(register pword *p, register word max) 2477{ 2478 register pword *s; 2479 register pword *t; 2480 register pword *r; 2481 register pword *u; 2482 pword *newd; 2483 pword *dom; 2484 word size = 0; 2485 value v0; 2486 2487 dom = p++; 2488 Dereference_(p); 2489 newd = r = Gbl_Tg; 2490 Gbl_Tg++; 2491 Check_Gc 2492 while (IsList(p->tag)) 2493 { 2494 p = p->val.ptr; 2495 s = p++; 2496 Dereference_(s); 2497 if (IsInteger(s->tag)) { 2498 if (s->val.nint <= max) { 2499 r->tag.kernel = TLIST; 2500 r->val.ptr = Gbl_Tg; 2501 r = Gbl_Tg; 2502 Gbl_Tg += 2; 2503 Check_Gc 2504 r->val.nint = s->val.nint; 2505 r++->tag.kernel = TINT; 2506 size++; 2507 } 2508 else 2509 break; 2510 } else if (!IsFdInterval(s->val, s->tag)) 2511 return TYPE_ERROR; 2512 else { 2513 u = s; 2514 s = s->val.ptr + 1; 2515 t = s++; 2516 Dereference_(t); 2517 Dereference_(s); 2518 if (t->val.nint <= max) { 2519 if (s->val.nint <= max) { 2520 r->tag.kernel = TLIST; 2521 r->val.ptr = Gbl_Tg; 2522 r = Gbl_Tg; 2523 Gbl_Tg += 2; 2524 Check_Gc 2525 *r++ = *u; 2526 size += s->val.nint - t->val.nint + 1; 2527 } 2528 else { 2529 r = insert_interval(t->val.nint, max, r); 2530 size += max - t->val.nint + 1; 2531 break; 2532 } 2533 } 2534 else 2535 break; 2536 } 2537 Dereference_(p); 2538 } 2539 r->tag.kernel = TNIL; 2540 if (size) { 2541 (void) ec_assign(dom + 1, newd->val, newd->tag); 2542 v0.nint = size; 2543 (void) ec_assign(dom + 2, v0, tint); 2544 } 2545 return size; 2546} 2547 2548/* p is the val.ptr of dom/2 */ 2549int 2550dom_remove_smaller(register pword *p, register word min) 2551{ 2552 register pword *s; 2553 register pword *t; 2554 register pword *r; 2555 pword *newd; 2556 pword *dom; 2557 word size; 2558 value v0; 2559 2560 dom = p++; 2561 s = p + 1; 2562 Dereference_(p); 2563 Dereference_(s); 2564 size = s->val.nint; 2565 while (IsList(p->tag)) 2566 { 2567 p = p->val.ptr; 2568 s = p++; 2569 Dereference_(s); 2570 if (IsInteger(s->tag)) { 2571 if (s->val.nint >= min) { 2572 newd = p - 1; 2573 break; 2574 } else 2575 size--; 2576 } else if (!IsFdInterval(s->val, s->tag)) 2577 return TYPE_ERROR; 2578 else { 2579 s = s->val.ptr + 1; 2580 t = s++; 2581 Dereference_(t); 2582 Dereference_(s); 2583 if (s->val.nint < min) 2584 size -= s->val.nint - t->val.nint + 1; 2585 else { 2586 if (t->val.nint >= min) { 2587 newd = p - 1; 2588 break; 2589 } 2590 else { 2591 newd = r = Gbl_Tg; 2592 Gbl_Tg++; 2593 Check_Gc 2594 r = insert_interval(min, s->val.nint, r); 2595 size -= min - t->val.nint; 2596 *r = *p; 2597 newd = newd->val.ptr; 2598 break; 2599 } 2600 } 2601 } 2602 Dereference_(p); 2603 } 2604 if (size) { 2605 v0.ptr = newd; 2606 (void) ec_assign(dom + 1, v0, tlist); 2607 v0.nint = size; 2608 (void) ec_assign(dom + 2, v0, tint); 2609 } 2610 return size; 2611} 2612 2613/* dvar_remove_element(DVar, El) */ 2614static int 2615p_dvar_remove_element(value vvar, type tvar, value vel, type tel) 2616{ 2617 register pword *d; 2618 int res; 2619 2620 Check_Element(vel, tel) 2621 if (!IsMeta(tvar)) { 2622 Check_Element(vvar, tvar) 2623 Succeed_If(ec_compare_terms(vvar, tvar, vel, tel)) 2624 } 2625 Check_Dvar(vvar.ptr, d); 2626 res = _remove_element(vvar.ptr, vel.nint, tel.kernel); 2627 Check_Return(res); 2628 if (res == RES_FAIL) { 2629 Fail_ 2630 } 2631 Succeed_ 2632} 2633 2634static int 2635_remove_element(pword *var, word el, word tag) 2636{ 2637 int res; 2638 register pword *v; 2639 pword inst; 2640 2641 Var_Domain(var, v); 2642 res = dom_remove_element(v, el, tag, &inst); 2643 switch (res) 2644 { 2645 case RES_FAIL: 2646 return RES_FAIL; 2647 2648 case RES_NO_CHANGE: 2649 return RES_SOLVED; 2650 2651 case RES_INSTANTIATED: 2652 Bind_Var(var->val, var->tag, inst.val.all, inst.tag.kernel) 2653 return RES_SOLVED; 2654 2655 case RES_MIN: 2656 /* We don't know the size, but we know it is > 1 */ 2657 res = _domain_changed(var, 2, RES_MIN); 2658 return res < 0 ? res : RES_WAKE; 2659 2660 case RES_MAX: 2661 res = _domain_changed(var, 2, RES_MAX); 2662 return res < 0 ? res : RES_WAKE; 2663 2664 case RES_ANY: 2665 res = _domain_changed(var, 2, 0); 2666 return res < 0 ? res : RES_WAKE; 2667 2668 default: 2669 return res; 2670 } 2671} 2672 2673static int 2674p_remove_element(value vvar, type tvar, value vel, type tel, value vres, type tres) 2675{ 2676 int res; 2677 2678 if (!IsMeta(tvar)) { 2679 if (IsRef(tvar) || IsFdInterval(vvar, tvar)) { 2680 Bind_Var(vres, tres, RES_ERROR, TINT) 2681 Succeed_ 2682 } 2683 Succeed_If(!SameType(tvar,tel) || !IsNil(tvar) && vvar.all != vel.all) 2684 } 2685 res = _remove_element(vvar.ptr, vel.nint, tel.kernel); 2686 Check_Return(res); 2687 if (res == RES_FAIL) { 2688 Fail_ 2689 } 2690 Bind_Var(vres, tres, res, TINT) 2691 Succeed_ 2692} 2693 2694int 2695dom_remove_element(register pword *p, register word el, word tag, pword *inst) 2696{ 2697 register pword *s; 2698 register pword *t; 2699 register pword *r; 2700 register pword *u; 2701 pword *newd; 2702 pword *dom; 2703 value v0; 2704 type t0; 2705 int st = 1; 2706 int res = RES_NO_CHANGE; 2707 pword *elem; 2708 int comp; 2709 word size; 2710 2711 dom = p++; 2712 Dereference_(p); 2713 s = dom + 2; 2714 Dereference_(s); 2715 size = s->val.nint; 2716 newd = r = Gbl_Tg; 2717 Gbl_Tg++; 2718 Check_Gc 2719 v0.nint = el; 2720 t0.kernel = tag; 2721 while (IsList(p->tag)) 2722 { 2723 p = p->val.ptr; 2724 s = p++; 2725 Dereference_(s); 2726 if (!IsFdInterval(s->val, s->tag)) { 2727 if (IsInteger(s->tag) && IsTag(tag, TINT)) { 2728 if (s->val.nint == el) 2729 comp = 0; 2730 else if (s->val.nint < el) 2731 comp = -1; 2732 else 2733 comp = 1; 2734 } else 2735 comp = ec_compare_terms(s->val, s->tag, v0, t0); 2736 if (!comp) { 2737 *r = *p; 2738 res = st ? RES_MIN : RES_MAX; 2739 if (st && size == 2) { 2740 Dereference_(p); 2741 if (!IsList(p->tag)) 2742 return RES_FAIL; 2743 p = p->val.ptr; 2744 Dereference_(p); 2745 elem = p; 2746 } 2747 break; 2748 } 2749 else if (comp > 0) 2750 break; 2751 else { 2752 r->tag.kernel = TLIST; 2753 r->val.ptr = Gbl_Tg; 2754 r = Gbl_Tg; 2755 Gbl_Tg += 2; 2756 Check_Gc 2757 elem = s; 2758 r->val.nint = s->val.nint; 2759 r++->tag.kernel = s->tag.kernel; 2760 } 2761 } else { 2762 u = s; 2763 s = s->val.ptr + 1; 2764 t = s++; 2765 Dereference_(t); 2766 Dereference_(s); 2767 if (IsTag(tag, TINT)) { 2768 if (s->val.nint < el) 2769 comp = 1; 2770 else 2771 comp = 0; 2772 } 2773 else 2774 comp = 1; 2775 if (comp) 2776 { /* interval is before the element */ 2777 r->tag.kernel = TLIST; 2778 r->val.ptr = Gbl_Tg; 2779 r = Gbl_Tg; 2780 Gbl_Tg += 2; 2781 Check_Gc 2782 *r++ = *u; 2783 } 2784 else { 2785 if (t->val.nint <= el) { 2786 if (t->val.nint < el) { 2787 elem = t; 2788 r = insert_interval(t->val.nint, el - 1, r); 2789 res = RES_ANY; 2790 } else { 2791 elem = s; 2792 res = st ? RES_MIN : RES_ANY; 2793 } 2794 if (s->val.nint > el) { 2795 r = insert_interval(el + 1, s->val.nint, r); 2796 if (!res) 2797 res = RES_ANY; 2798 } else 2799 res = RES_MAX; 2800 break; 2801 } 2802 else 2803 break; /* interval is after the element */ 2804 } 2805 } 2806 Dereference_(p); 2807 st = 0; 2808 } 2809 Dereference_(p); 2810 *r = *p; 2811 if (res != RES_NO_CHANGE) { 2812 if (size <= 1) 2813 return RES_FAIL; 2814 else if (size == 2) { 2815 *inst = *elem; 2816 return RES_INSTANTIATED; 2817 } 2818 if (res == RES_MAX && !IsNil(p->tag)) 2819 res = RES_ANY; 2820 (void) ec_assign(dom + 1, newd->val, newd->tag); 2821 v0.nint = size - 1; 2822 (void) ec_assign(dom + 2, v0, tint); 2823 return res; 2824 } 2825 else 2826 return RES_NO_CHANGE; 2827} 2828 2829static int 2830p_dvar_replace(value vvar, type tvar, value vn, type tn) 2831{ 2832 register pword *dom; 2833 register pword *s; 2834 register word size; 2835 2836 Check_Meta(tvar) 2837 Check_Domain(vn, tn); 2838 Check_Dvar(vvar.ptr, dom) 2839 2840 s = vn.ptr + 2; 2841 Dereference_(s); 2842 size = s->val.nint; 2843 if (size == 0) { 2844 Fail_ 2845 } 2846 2847 s = dom = dom->val.ptr + DOMAIN_OFF; 2848 Dereference_(s); 2849 s = s->val.ptr + 2; 2850 Dereference_(s); 2851 if (s->val.nint == size) { 2852 Succeed_ 2853 } else if (s->val.nint < size) { 2854 Bip_Error(RANGE_ERROR) 2855 } 2856 return ec_assign(dom, vn, tn); 2857} 2858 2859static word 2860_dom_value(register pword *p) 2861{ 2862 p++; 2863 Dereference_(p); 2864 p = p->val.ptr; 2865 Dereference_(p); 2866 if (IsInteger(p->tag)) 2867 return p->val.nint; 2868 else { 2869 p = p->val.ptr + 1; 2870 Dereference_(p); 2871 return p->val.nint; 2872 } 2873} 2874 2875/* 2876 * Take care of suspended lists and variables after a domain update. 2877 * If the domain is a singleton, instantiate the variable. Schedule 2878 * the appropriate lists and reset them in the domain. 2879 */ 2880static int 2881_domain_changed(pword *var, word size, int which) 2882{ 2883 register pword *attr; 2884 register pword *p; 2885 word val; 2886 int res; 2887 2888 if (size == 0) 2889 return PFAIL; 2890 Var_Attr(var, attr); 2891 if (size == 1) 2892 { 2893 /* get the element */ 2894 Attr_Domain(attr, p) 2895 val = _dom_value(p); 2896 Bind_Var(var->val, var->tag, val, TINT); 2897 2898 /* schedule the lists, otherwise attr_instantiate in the unify-handler 2899 * could think that no waking is necessary, because it sees a domain 2900 * which is already reduced. */ 2901 2902 attr = attr->val.ptr; 2903 p = attr + ANY_OFF; 2904 Dereference_(p); 2905 res = p_schedule_woken(p->val, p->tag); 2906 Check_Return(res); 2907 2908 if (which & RES_MIN) { 2909 p = attr + MIN_OFF; 2910 Dereference_(p); 2911 res = p_schedule_woken(p->val, p->tag); 2912 Check_Return(res); 2913 } 2914 if (which & RES_MAX) { 2915 p = attr + MAX_OFF; 2916 Dereference_(p); 2917 res = p_schedule_woken(p->val, p->tag); 2918 Check_Return(res); 2919 } 2920 } 2921 else /* schedule and update the suspension lists */ 2922 { 2923 attr = attr->val.ptr; 2924 res = ec_schedule_susps(attr + ANY_OFF); 2925 Check_Return(res); 2926 2927 if (which & RES_MIN) { 2928 res = ec_schedule_susps(attr + MIN_OFF); 2929 Check_Return(res); 2930 } 2931 if (which & RES_MAX) { 2932 res = ec_schedule_susps(attr + MAX_OFF); 2933 Check_Return(res); 2934 } 2935 } 2936 return notify_constrained(var); 2937} 2938 2939static int 2940p_prune_woken_goals(value val, type tag) /* must be dereferenced */ 2941{ 2942 register word arity; 2943 register int res; 2944 register pword *arg; 2945 2946 for (;;) 2947 { 2948 if (IsList(tag)) 2949 arity = 2; 2950 else if (IsStructure(tag)) 2951 { 2952 arity = DidArity(val.ptr->val.did); 2953 val.ptr++; 2954 } 2955 else if IsMeta(tag) { 2956 arg = MetaTerm(val.ptr); 2957 Dereference_(arg); 2958 if (!IsStructure(arg->tag)) 2959 { Succeed_; } 2960 arg = arg->val.ptr + domain_slot; 2961 Dereference_(arg); 2962 if (!IsStructure(arg->tag)) 2963 { Succeed_; } 2964 arg = arg->val.ptr; 2965 res = ec_prune_suspensions(arg + MIN_OFF); 2966 Check_Return(res); 2967 res = ec_prune_suspensions(arg + MAX_OFF); 2968 Check_Return(res); 2969 return ec_prune_suspensions(arg + ANY_OFF); 2970 } 2971 else 2972 { 2973 Succeed_; 2974 } 2975 2976 for( ;arity > 1; arity--) 2977 { 2978 arg = val.ptr++; 2979 Dereference_(arg); 2980 res = p_prune_woken_goals(arg->val, arg->tag); 2981 Check_Return(res); 2982 } 2983 arg = val.ptr; /* tail recursion */ 2984 Dereference_(arg); 2985 val.all = arg->val.all; 2986 tag.all = arg->tag.all; 2987 } 2988} 2989 2990 2991static int 2992p_integer_list_to_dom(value vl, type tl, value vd, type td) 2993{ 2994 pword *p; 2995 pword *l; 2996 pword *s, *t; 2997 pword *ints; 2998 pword *el; 2999 word from, to; 3000 word num; 3001 word size = 0; 3002 3003 if (!IsRef(td)) { 3004 Check_Domain(vd, td) 3005 } 3006 if (IsList(tl)) { 3007 l = vl.ptr; 3008 el = l++; 3009 Dereference_(el); 3010 if (IsInteger(el->tag)) 3011 from = to = el->val.nint; 3012 else if (!IsFdInterval(el->val, el->tag)) { 3013 Bip_Error(TYPE_ERROR) 3014 } else { 3015 s = el->val.ptr + 1; 3016 t = s++; 3017 Dereference_(t); 3018 Check_Integer(t->tag); 3019 Dereference_(s); 3020 Check_Integer(s->tag); 3021 from = t->val.nint; 3022 to = s->val.nint; 3023 if (from > to) { 3024 Bip_Error(RANGE_ERROR) 3025 } 3026 } 3027 } else { 3028 Check_List(tl) 3029 } 3030 3031 p = ints = Gbl_Tg; 3032 Gbl_Tg++; 3033 Check_Gc; 3034 3035 if (IsNil(tl)) { 3036 ints->tag.kernel = TNIL; 3037 l = ints; 3038 } 3039 3040 for (;;) { 3041 Dereference_(l); 3042 if (IsList(l->tag)) { 3043 l = l->val.ptr; 3044 el = l++; 3045 Dereference_(el); 3046 if (IsInteger(el->tag)) { 3047 num = el->val.nint; 3048 if (num == to + 1) 3049 to = num; 3050 else if (num > to) { 3051 p = insert_interval((word) from, (word) to, p); 3052 size += to - from + 1; 3053 from = to = num; 3054 } else { 3055 Bip_Error(RANGE_ERROR) 3056 } 3057 } 3058 else if (!IsFdInterval(el->val, el->tag)) { 3059 Bip_Error(TYPE_ERROR) 3060 } else { 3061 s = el->val.ptr + 1; 3062 t = s++; 3063 Dereference_(t); 3064 Check_Integer(t->tag); 3065 Dereference_(s); 3066 Check_Integer(s->tag); 3067 num = t->val.nint; 3068 if (num == to + 1) 3069 to = s->val.nint; 3070 else if (num > to) { 3071 p = insert_interval((word) from, (word) to, p); 3072 size += to - from + 1; 3073 from = num; 3074 to = s->val.nint; 3075 } else if (num >= from) {/* overlapping ranges */ 3076 if (to < s->val.nint) to = s->val.nint; 3077 else if (s->val.nint < num) { 3078 Bip_Error(RANGE_ERROR) 3079 } 3080 } else { 3081 Bip_Error(RANGE_ERROR) 3082 } 3083 if (num > to) { 3084 Bip_Error(RANGE_ERROR) 3085 } 3086 } 3087 } 3088 else if (IsNil(l->tag)) 3089 break; 3090 else { 3091 Check_List(l->tag) 3092 } 3093 } 3094 if (!IsNil(tl)) { 3095 p = insert_interval((word) from, (word) to, p); 3096 p->tag.kernel = TNIL; 3097 size += to - from + 1; 3098 } 3099 3100 p = Gbl_Tg; 3101 Gbl_Tg += 3; 3102 Check_Gc; 3103 p[0].tag.kernel = TDICT; 3104 p[0].val.did = d_dom; 3105 p[1].tag.kernel = ints->tag.kernel; 3106 p[1].val.all = ints->val.all; 3107 p[2].tag.kernel = TINT; 3108 p[2].val.nint = size; 3109 Return_Unify_Structure(vd, td, p); 3110} 3111 3112 3113/* 3114 * sdelta(+L1, +L2, ?L1minusL2), used by library(conjunto) 3115 */ 3116 3117static int 3118p_sdelta(value l1, type t1, value l2, type t2, value l3, type t3) 3119{ 3120 pword result_pw; 3121 pword *result = &result_pw; 3122 pword *head1, *head2, *p; 3123 int comp; 3124 3125 Check_List(t1); 3126 Check_List(t2); 3127 Check_Output_List(t3); 3128 3129 for(;;) 3130 { 3131 if (!IsList(t1)) { 3132 Make_Nil(result); 3133 break; 3134 } 3135 if (!IsList(t2)) { 3136 result->tag = t1; 3137 result->val = l1; 3138 break; 3139 } 3140 3141 head1 = l1.ptr; Dereference_(head1); 3142 head2 = l2.ptr; Dereference_(head2); 3143 3144 comp = ec_compare_terms(head1->val, head1->tag, head2->val, head2->tag); 3145 3146 if (comp == 0) { /* The element is removed from both lists */ 3147 p = l1.ptr + 1; Dereference_(p); l1 = p->val; t1 = p->tag; 3148 p = l2.ptr + 1; Dereference_(p); l2 = p->val; t2 = p->tag; 3149 } else if (comp > 0) { /* The head of the second list is removed */ 3150 p = l2.ptr + 1; Dereference_(p); l2 = p->val; t2 = p->tag; 3151 } else { /* The head of the first list is moved in the result */ 3152 Make_List(result, TG); 3153 result = TG; 3154 Push_List_Frame(); 3155 *result++ = *head1; 3156 p = l1.ptr + 1; Dereference_(p); l1 = p->val; t1 = p->tag; 3157 } 3158 } 3159 Return_Unify_Pw(l3, t3, result_pw.val, result_pw.tag); 3160} 3161 3162