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) 1995 - 2006 Cisco Systems, Inc. All Rights Reserved. 18% 19% Contributor(s): Kish Shen, IC-Parc 20% 21% END LICENSE BLOCK 22% ---------------------------------------------------------------------- 23% System: ECLiPSe Constraint Logic Programming System 24% Version: $Id: ech.pl,v 1.6 2013/02/16 02:55:20 kish_shen Exp $ 25% ---------------------------------------------------------------------- 26 27% New CHR implementation 28% Kish Shen, March - June 1998, version 1 29% March - April, 1999, some fixes 30% Sept 1999, further fixes 31% Sept 2001, merged into one file 32% Partial support for multi-head (>2) rules: no multi-head propagation rules 33% Syntax changes and minor semantic changes from old CHR 34% Faster execution 35 36:- module(ech). 37 38:- meta_attribute(ech, [ 39 unify: unify_ech/2 40 %print: print_ech/2 41 ]). 42 43:- export op(1100, fy, handler). 44:- export op(1000, fy, constraints). 45%:- export op(1200, fy, [label_with]). 46:- export op(1190, xfx, [==>, <=>]). 47%:- export op(1200, xfx, :--). 48:- export op(1200, xfx, ::=). % replaces @ in old syntax 49:- export op(1100, xfx, |). 50:- export op(1100, xfx, \ ). 51:- export op(700, xfx, flag). 52 53:- local struct(chrcinfo(spec,count,prio)). 54:- local variable(chr_priority, 9). 55 56:- export record_chrrule/3, record_chrprule/3, new_constraints/3, 57 ignore_handler/2, record_namedrule/3, appliedpos/2, 58 suspendindexpos/2, constraintnumpos/2, 59 wrapperinpos/2, cdeletethreshold/2. 60 61:- tool(record_namedrule/2, record_namedrule/3). 62:- tool(record_chrrule/2, record_chrrule/3). 63:- tool(record_chrprule/2, record_chrprule/3). 64:- tool(new_constraints/2, new_constraints/3). 65 66 67:- export suspend_constraint/4, get_global_constraint/2, 68 get_constraint_list/3, kill_constraint/2, check_pairapplied/6, 69 check_pairapplied_direct/6, insert_pairapplied/6, is_in_store/2, 70 create_applied/2, check_samepairapplied/6, insert_samepairapplied/6, 71 check_samepairapplied_direct/6, check_samepairapplied_directmarked/8, 72 check_pairapplied_directmarked/8, find_partner/4, in_chrstore/2, 73 chr_get_gconstraint/2, chr_get_vconstraint/3. 74 75 76:- export chr/1, chr/2, in_chrstore/1, option/2, option/3, chr_get_constraint/1, 77 chr_get_constraint/2, (constraints)/1, (constraints)/2, (handler)/1. 78 79 80:- tool(suspend_constraint/4, suspend_constraint/5). 81:- tool(get_global_constraint/2, get_global_constraint/3). 82:- tool(get_constraint_list/3, get_constraint_list/4). 83:- tool(kill_constraint/2, kill_constraint/3). 84:- tool(check_pairapplied/6, check_pairapplied/7). 85:- tool(insert_pairapplied/6, insert_pairapplied/7). 86:- tool(check_samepairapplied/6, check_samepairapplied/7). 87:- tool(insert_samepairapplied/6, insert_samepairapplied/7). 88:- tool(check_pairapplied_directmarked/8, check_pairapplied_directmarked/9). 89:- tool(check_samepairapplied_directmarked/8, 90 check_samepairapplied_directmarked/9). 91:- tool((chr)/1, (chr)/2). 92:- tool(in_chrstore/1, in_chrstore/2). 93:- tool(option/2, option/3). 94:- tool((constraints)/1, (constraints)/2). 95:- tool(chr_get_constraint/1, chr_get_gconstraint/2). 96:- tool(chr_get_constraint/2, chr_get_vconstraint/3). 97 98 99 100% avoid magic number in code 101realconstraintpos(constraint_in_wrapper_pos, 2). 102% arg. pos for const. in wrapper 103suspendindexpos(suspendid_pos, 3). % arg. pos for Index in wrapper 104% arg. pos for In arg. in wrapper 105wrapperinpos(wrapper_inpos, 4). 106% arg. pos for global const. no. in wrapper 107constraintnumpos(constraintnum_pos, 1). 108% arg. pos for applied-list in wrapper 109appliedpos(applied_pos, 5). 110% threshold for general clean-up of var's constraint list 111%varslistthreshold(varslist_threshold, 100). 112% threshold of number of kill_constraints before general cleanup 113cdeletethreshold(cdelete_threshold, 15). 114 115% macros for use when CHR syntax code is being read in 116 117ignore_handler(_, []). 118 119record_chrrule(Rule, [], Module) :- 120 % put in front as later we add to Processed at the front of the list 121 check_if_new_or_update(Module), 122 recorda('CHRcode', Rule)@Module. 123 124record_chrprule(Rule0, [], Module) :- 125 check_if_new_or_update(Module), 126 erase('CHRprule_count', count(Module,Np)), 127 Np1 is Np + 1, 128 (Rule0 = (Name ::= Rule1) -> 129 Rule = (Name ::= Np1-(Rule1)) ; Rule = Np1-(Rule0) 130 ), 131 recorda('CHRcode', Rule)@Module, 132 recorda('CHRprule_count',count(Module,Np1)). 133 134record_namedrule(NamedRule, [], Module) :- 135 NamedRule = (_Name ::= Rule), 136 ( Rule = (Head ==> Body) -> record_chrprule(NamedRule, [], Module) 137 ;( Rule = (Head <=> Body) -> record_chrrule(NamedRule, [], Module) 138 ; writeln(error, "Syntax error, ::= is not followed by a valid rule in"), 139 pretty_write(NamedRule), nl 140 )). 141 142new_constraints(constraints ConstDec, [], Module) :- % still support old syntax for now 143 check_if_new_or_update(Module), 144 erase('CHRconst_count', count(Module,NConst0)), 145 count_and_record_constraints(ConstDec, NConst0, Count0, Module), 146 recorda('CHRconst_count', count(Module,Count0)). 147 148constraints(ConstDec, Module) :- 149 check_if_new_or_update(Module), 150 erase('CHRconst_count', count(Module,NConst0)), 151 count_and_record_constraints(ConstDec, NConst0, Count0, Module), 152 recorda('CHRconst_count', count(Module,Count0)). 153 154handler _. % do nothing; for compatibility only 155 156 157 158:- export macro((handler)/2, ignore_handler/3, [clause]). 159:- export macro((==>)/2, record_chrprule/3, [clause]). 160:- export macro((<=>)/2, record_chrrule/3, [clause]). 161:- export macro((::=)/2, record_namedrule/3, [clause]). 162:- export macro((constraints)/1, new_constraints/3, [clause]). 163:- export macro(no_macro_expansion(constraint_in_wrapper_pos/0), realconstraintpos/2, []). 164:- export macro(no_macro_expansion(suspendid_pos/0), suspendindexpos/2, []). 165:- export macro(no_macro_expansion(constraintnum_pos/0), constraintnumpos/2, []). 166:- export macro(no_macro_expansion(applied_pos/0), appliedpos/2, []). 167:- export macro(no_macro_expansion(wrapper_inpos/0), wrapperinpos/2, []). 168%:- export macro(varslist_threshold/0, varslistthreshold/2, []). 169:- export macro(no_macro_expansion(cdelete_threshold/0), cdeletethreshold/2, []). 170 171 172:- pragma(expand). 173 174 175 176% global constraint count 177:- local variable(constraint_number, 0). 178 179:- import sepia_kernel. 180 181:- set_flag(coroutine, on). 182 183 184:- lib(lists). 185:- lib(numbervars). 186 187 188:- local struct( 189 ech( 190 slists, % indexed store for suspension lists of constraint 191 count 192 ) 193 ). 194 195%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 196% `compiler' 197 198chrcompile(Error, Culprit, Module) :- Culprit = (term,_,_), !, 199 error(default(Error), Culprit, Module). 200chrcompile(Error, Culprit, Module) :- Culprit = (_, _, dumped), !, 201 error(default(Error), Culprit, Module). 202chrcompile(Error, Culprit, Module) :- 203 recorded_list('CHRadding_code', Modules), 204 erase_all('CHRadding_code'), 205 (Modules \== [] -> % have read in some constraints 206 chrcompile_by_module(Modules) ; true 207 ), 208 error(default(Error), Culprit, Module). 209 210chrcompile_by_module([]) :- !. 211chrcompile_by_module([Module|Modules]) :- 212 recorded('CHRconst_count', count(Module,N)), 213 % N should be > 0 214 recorded_list('CHRconstraints', Constraints)@Module, 215 recorded_list('CHRcode', Rules)@Module, 216 compile_term([(:- import sepia_kernel), (:- set_flag(coroutine, on)), 217 number_of_constraints(N)])@Module, 218 (transform(Rules,Constraints,N, Module) -> 219 true 220 ; 221 printf(error, "***Compiling of CHRs failed in module %w. Please" 222 " report problem.", 223 [Module]), 224 abort 225 ), 226 ArraySize is N + 1, % need +1 to avoid using 0. 227 (current_array('CHRcdelete_count'(OldSize),_)@Module -> 228 (OldSize \== ArraySize -> 229 erase_array('CHRcdelete_count'/1)@Module, 230 local(array('CHRcdelete_count'(ArraySize), integer))@Module 231 ; true 232 ) 233 ;local(array('CHRcdelete_count'(ArraySize), integer))@Module 234 235 ), 236 chrcompile_by_module(Modules). 237 238check_if_new_or_update(Module) :- 239 (recorded('CHRadding_code', Module) -> 240 true 241 242 ; % indicates that CHR code is being added since last (if any) compile 243 recorda('CHRadding_code', Module) 244 ), 245 (current_array('CHRcstore',_)@Module -> 246 % CHRcstore will be defined in Module if CHR encountered for Module 247 % must use something from Module as the module may have been erased 248 true ; initialise_module_for_chr(Module) 249 ). 250 251 252:- local initialization(set_event_handler(139, chrcompile/3)). 253 254/* transform(+Rules, +Constraints, +N, +Module) 255 transforms the list of CHR in rules into Prolog code. Constraints is the 256 list of declared constraints for these rules. N is the number of 257 constraints, and Nprule is the number of propagation rules in the CHR 258*/ 259transform(Rules, Constraints, N, Module) :- 260 initialise_processed(N, ProcessedRules), 261 syntax_check(Rules, Constraints, ProcessedRules, Module), 262 recorded('CHRprule_count', count(Module,Nprule)), 263 compile_term(number_of_propagations(Nprule))@Module, 264 translate(ProcessedRules, Constraints, Nprule, Module). 265 266 267indexing_argsize(_N, 0).% :- writeln(_N). % for now 268 269 270/* translate(+Processed, +Constraints, +Nprule, +Module) 271 translate the processed rules in Processed into Prolog code. Constraints is 272 the list of constraints, and Nprule is the number of propagation rules -- 273 if this is zero, the suspension can be simplified. 274*/ 275translate(Processed,Constraints,Nprule, Module) :- 276 functor(Processed,_,Size), 277 translate_each_constraint(Size, Processed, Constraints, Nprule, Module). 278 279/* translate_each_constraint(+Nth, +Processed, +Constraints, +Nprule, +Module) 280 translate the rules associated with the Nth constraint, i.e. those rules 281 where the Nth constraint occurs in the head. Note that seperate code needs to 282 be generated for each occurance of a head constraint, except where the 283 situation is symmetric and can be optimised 284*/ 285translate_each_constraint(0,_,_,_,_) :- !. 286translate_each_constraint(N, Processed, Constraints, Nprule, Module) :- 287 arg(N,Processed,HRuleList), 288 length(HRuleList, NRule), 289 indexing_argsize(NRule, NRule1), 290 nth_member(N, Constraints, F/A), 291 printf(log_output, "Found CHR %a/%w in module %w, generating transformed" 292 " code\n", [F,A, Module]), 293 gen_code_for_constraint(HRuleList, [], F, A, 1, NRule1, Nprule, Code0, Module), 294 optimise(Code0, Code), 295% printcode(Code), 296 compile_term([(:- pragma(expand))|Code])@Module, 297 N1 is N - 1, 298 translate_each_constraint(N1, Processed, Constraints, Nprule, Module). 299 300/* construct_exec_constraint(+WrappedF, +WrappedA, +F, +A, +ConstNum, + 301 Priority, +NRule, +Nprule, -Code, +Module) 302 constructs the various codes for managing a particular constraint. Two 303 clauses are needed: one (WrappedF/WrappedA) that is suspended, and when 304 woken, calls the rules (with possible optimisations); and the other, 305 called from the plane constraint (F/A), which is used to initiate a 306 new call to the rules. A demon directive for WrappedF/WrappedA is also 307 needed so that it is not killed when woken. ConstNum is the index number 308 into the constraint store for this constraint (F/A) 309*/ 310construct_exec_constraint(WF, WA, CF, CA, ConstNo, Prio, NRule, Nprule, Code, Module) :- 311 functor(WHead, WF, WA), % wrapped constraint 312 make_current_rule_name(CF, CA, 1, NRule, Nprule, FirstRule0, A), 313 WHead =.. [_F,_ConsNum,Constraint|MetaArgs], 314 % WHead - suspended constraint, for wake up calls 315 functor(Constraint,CF,CA), 316 Constraint =.. [CF|ConsArgs], % original constraint form 317 length(Index,NRule), 318 instantiate_list(Index, 1), % make all 1 for now 319 append(Index, ConsArgs, L1), 320 append(L1, MetaArgs, ArgList), 321 functor(FirstRule0, FirstRuleF, A), 322 Body =.. [FirstRuleF|ArgList], 323 add_check_in_store(Constraint, Body, ConstNo, Prio, Call, Module), 324 % to add optimising code before Body in WHead 325 Code = [(:- demon(WF/WA)), ( WHead :- Body), (Constraint :- Call)]. 326 327 328add_check_in_store(Constraint, Call, No, Prio, Check, Module) :- 329 PriCall = call_priority(Call, Prio), 330 (recorded('CHRdont_in_store', Module) -> 331 Check = PriCall 332 ; Check = (ech:get_global_constraint(No, SuspL), 333 (ech:is_in_store(SuspL, Constraint) -> true ; PriCall) 334 ) 335 ). 336 337/* extract the first Ath argument from the structure NewHead as a list, ConsArgs */ 338get_constraint_args(NewHead, A, ConsArgs) :- 339 NewHead =.. [_|Args], 340 split_list(A, Args, ConsArgs, _). 341 342 343gen_code_for_constraint([], PreviousTryNexts, F, A, Nth, NRule, Nprule, CodeTail, Module) :- !, 344 % need to generate termination rule 345 (PreviousTryNexts \== none -> % have processed rules for this constraint 346 make_rulefunctor(F, A, Nth, Functor), 347 nmetaargs(Nprule, N), 348 NewArity is A + N, % no indexing for this last clause. 349 functor(NewHead, Functor, NewArity), 350 get_constraint_args(NewHead, A, ConsArgs), 351 Head =.. [F|ConsArgs], % set the constraint arguments 352 AddBase is A + 1, % start of extra args 353 arg(AddBase, NewHead, Index), 354 %%% MAGIC NUMBER 355 InPos is AddBase + 1, 356 arg(InPos, NewHead, In), 357 (Nprule =:= 0 -> ExtraArgs = [Index,In] 358 ; AppPos is AddBase + 2, arg(AppPos, NewHead, Applied), 359 ExtraArgs = [Index,In,Applied] 360 ), 361 362 get_constraintnumber_fa(F,A, ConstNo, Prio, Module), 363 construct_wrapper_constraint(Head, ExtraArgs, Constraint, _), 364 construct_writeconstraint_code(Constraint, WriteDefine, WriteRule), 365 CodeTail = [( NewHead :- 366 (var(Index) -> 367 ech:suspend_constraint(Constraint, Head, ConstNo, Prio) 368 ; get_suspension_data(Index, goal, Goal), 369 setarg(wrapper_inpos, Goal, In) 370 ) 371 ),WriteDefine, WriteRule| ExecConstraint], 372 functor(Constraint, WH, WA), 373 374 construct_exec_constraint(WH,WA,F,A, ConstNo, Prio, NRule, Nprule, 375 ExecConstraint, Module), 376 construct_previous_try_next(PreviousTryNexts, A, NRule, NRule, NewHead) 377 ; /* no code for this constraint at all */ 378 printf(warning_output, "Warning: No rule found for constraint %w/%w.\n",[F,A]), 379 CodeTail = []). 380gen_code_for_constraint([rule(Rule,Status,Head,KeepHeads,DeleteHeads,Body, 381 PInfo, ComInfo, _Name)|Rest], 382 PreviousTryNexts, F, A, Nth, NRule, Nprule, Transformed1, Module) ?- 383 Head =.. [F|ArgList], 384 make_current_rule_name(F,A,Nth,NRule,Nprule, CHead, _Arity), 385 % CHead is clause head here (i.e. with meta args); Head is constrtraint 386 construct_previous_try_next(PreviousTryNexts, A, NRule, 0, CHead), 387 fill_current_head(CHead, A, Nth,NRule, ArgList, IndexHeadArgs,MetaArgs), 388 % fill in the arguments for the head 389 (Nprule \== 0 -> 390 MetaArgs = [CIndex,In,_Applied] 391 ; MetaArgs = [CIndex,In] 392 ), 393 append(DeleteHeads, KeepHeads, Partners), 394 %DeleteHeads first so that these can be deleted in body 395 Clause = (CHead ?- Code0), % Code0 to be filled in 396 rule_type(Rule, RuleType), 397 construct_main_clause(RuleType, Status, Partners, DeleteHeads, KeepHeads, Head, CHead, Body, Nth, Nprule, PInfo, ComInfo, IndexHeadArgs, MetaArgs, Code0, Vars, Cans, InsChecks, TryNexts0, PreFiredCodes0, PostFiredCodes0, AllRest, Module), 398 construct_2ndclause(CHead, Nth, NRule, A, SecondClause, TryNexts1), 399 400 (Partners \== [] -> % not needed if no partners 401 construct_prefired_otherpartners(RuleType, Status, Partners, DeleteHeads, KeepHeads, CHead, Head, Body, A, AllRest, 402 Nth, NRule, Nprule, Cans, InsChecks, PInfo, ComInfo, PreFiredName, PreFiredCodes1, PostFiredCodes1, TryNexts2, PrePRule, Module), 403 construct_postfired_otherpartners(RuleType, Status, Partners, DeleteHeads, KeepHeads, CHead, Head, Body, A, AllRest, 404 Nth, NRule, Nprule, Cans, InsChecks, PInfo, ComInfo, PostFiredName, PostFiredCodes2, TryNexts3, PostPRule, Module), 405 % fill in various bits of code 406 functor(CHead, CFunc, _), 407 construct_instancematches(Partners, Cans, Vars, InsChecks, CFunc, 1, Module), 408 409 fill_in_try_otherrest(PreFiredCodes0, PreFiredName), 410 fill_in_try_otherrest(PreFiredCodes1, PreFiredName), 411 fill_in_try_otherrest(PostFiredCodes0, PostFiredName), 412 fill_in_try_otherrest(PostFiredCodes1, PostFiredName), 413 fill_in_try_otherrest(PostFiredCodes2, PostFiredName), 414 append(TryNexts0,TryNexts1, TryNexts4), 415 append(TryNexts4, TryNexts2, TryNexts5), 416 append(TryNexts5, TryNexts3, TryNexts), 417 PrePRule = [Pre1,Pre2], PostPRule = [Post1,Post2], 418 Transformed1 = [Clause,SecondClause,Pre1,Pre2,Post1,Post2|Transformed2] 419 420 ; /* should not have prefirecodes etc. if no partners */ 421 append(TryNexts0, TryNexts1, TryNexts), 422 Transformed1 = [Clause,SecondClause|Transformed2] 423 ), 424 425 426 Nth1 is Nth + 1, 427 gen_code_for_constraint(Rest, TryNexts, F, A, Nth1, NRule, Nprule, Transformed2, Module). 428 429 430construct_instancematches([], [], [], [], _, _, _) :- !. 431construct_instancematches([Partner|Ps], [Candidate|Cans], [Common-Remain|Cs], [ICheck|ICs], CFunc, N, Module) :- 432 copy_term(Remain,CRemain), 433 concat_atom([CFunc,match,N], NewFunc), 434 ICheck =.. [NewFunc,Candidate,Common, Remain], 435 GoalHead =.. [NewFunc,Partner,Common, CRemain], 436 compile_term((GoalHead ?- CRemain = Remain))@Module, 437 N1 is N + 1, 438 construct_instancematches(Ps, Cans, Cs, ICs, CFunc, N1, Module). 439 440 441fill_in_try_otherrest([], _Name) :- !. 442fill_in_try_otherrest([f(ArgList,TobeFilled)|Others], Name) :- 443 (var(TobeFilled) -> 444 TobeFilledGoal =.. [Name|ArgList], 445 % add a cut before the call to prevent spurious backtracking 446 TobeFilled = (!, TobeFilledGoal) 447 ; true), 448 % TobeFilled is not var if no code needs to be filled in 449 fill_in_try_otherrest(Others, Name). 450 451 452rule_type((_H==>_B), Type) ?- !, Type = propagation. 453rule_type((H<=>_B), Type) ?- 454 H = (_\_) -> 455 Type = simpogation ; Type = simplification. 456 457 458construct_main_clause(RuleType, Status, Partners, DeleteHeads, KeepHeads, Head, CHead, Body, Nth, Nprule, PropInfo, CompInfo, 459 IndexHeadArgs, MetaArgs, Code0, Vars, Candidates, 460 InstanceChecks, TryNexts, PreFiredCodes, PostFiredCode, AllRest, Module) :- 461 462 get_constraintnumber(Head, ConstNo, Module), 463 decompose_body(Body, Guard, BGoals), 464 465 % construct the clause 466 CommonArgs = a(Head,CHead,MetaArgs,Nth,AllRest,_PIndecies,_GConst, 467 _Add_Applied,AppTail), 468 ExtendArgs = a(Status,ConstNo,BGoals,DeleteHeads,KeepHeads,PostFired0,NTryNext), 469 470 construct_find_partners(Partners, CommonArgs, 1, [], [], 471 Vars, Candidates, InstanceChecks, FindPartners, 472 Module), 473 MetaArgs = [_,In|_], 474 (FindPartners \== true -> 475 TryNexts0 = [f(Try_Next_Rule,[Nth-np|In],CHead)], % don't know how Cth 476 % is used, omitted 477 Code0 = (FindPartners -> 478 Code1 479 ; 480 !, Try_Next_Rule 481 ) 482 ; 483 TryNexts0 = [], 484 Code0 = Code1 485 ), 486 construct_applied(RuleType, Partners, CommonArgs, PropInfo, CompInfo, Code1, 487 PreFired0, TryNext0, Code2), 488 construct_guard(Guard, (Head,Partners), CommonArgs, CompInfo, ExtendArgs, Nprule, Code2, PreFired1, TryNext, Code3, Module), 489 construct_body(CommonArgs, ExtendArgs, Nprule, Code3, PostFired, TryNext1, Module), 490 491 % construct the various arg list 492 multi_append([TryNext0,TryNext,TryNext1,TryNexts0,NTryNext], TryNexts), 493 append(IndexHeadArgs, [AllRest], L0), 494 append(L0, MetaArgs, Post1), 495 append(L0, [applied|MetaArgs], Pre0), append(L0, [gf|MetaArgs], Pre1), 496 (Nprule == 0 -> 497 Post1 = PostFiredArgs, 498 Pre1 = PreArgs1, 499 Pre0 = PreArgs0 500 ; append(Post1, [AppTail], PostFiredArgs), 501 append(Pre0, [AppTail], PreArgs0), 502 append(Pre1, [AppTail], PreArgs1) 503 ), 504 PostFiredCode = [f(PostFiredArgs,PostFired),f(PostFiredArgs,PostFired0)], 505 PreFiredCodes = [f(PreArgs0,PreFired0),f(PreArgs1,PreFired1)]. 506 507 508construct_2ndclause(OldHead, Nth, NRule, ConsArity, Code, TryNexts) :- 509 functor(OldHead, F,A), 510 functor(NewHead, F,A), % construct new head 511 InPos is ConsArity + NRule + 2, % second meta-arg is In 512 arg(InPos, NewHead, In), 513 (NRule > 0 -> 514 arg(Nth, NewHead, I), % the indexing var. for this clause 515 %% MAGIC NUMBER 516 TryNexts = [f(TryNext1,[Nth-hf|In],NewHead),f(TryNext0,In,NewHead)], 517 Code = (NewHead :- 518 I == 1 -> TryNext0 519 ; TryNext1 520 ) 521 ; Code = (NewHead :- TryNext0), 522 TryNexts = [f(TryNext0,[Nth-hf|In],NewHead)] 523 ). 524 525 526fill_previous_infoargs(PInfoPos, NRule, TryOtherHead, [FailType,SuspL,AppTail]) :- 527 arg(PInfoPos, TryOtherHead, FailType), 528 SuspPos is NRule + 2, 529 arg(SuspPos, TryOtherHead, SuspL), 530 AppTailPos is NRule + 3, 531 arg(AppTailPos, TryOtherHead, AppTail). 532 533 534construct_previous_try_next([], _, _, _, _) :- !. 535construct_previous_try_next([f(TryNext, NewIn, PrevHead)|TryNexts], OArity, NRule, RemoveArg, NewHead) :- 536% RemoveArg normally set to zero, so that indexing args are not removed, except for last clause for this constraint 537 (TryNext \== true -> 538 functor(NewHead, Name, _A), % NewHead used as template to construct calling goal 539 add_inarg(PrevHead, OArity, NRule, NewIn, NewArgs0), 540 remove_indexing(RemoveArg, NewArgs0, NewArgs), 541 TryNext =.. [Name|NewArgs] % code for calling goal 542 ;true 543 ), 544 construct_previous_try_next(TryNexts, OArity, NRule, RemoveArg, NewHead). 545 546/* updates MetaArgs from OldIn to NewIn */ 547add_inarg(PrevHead, OArity, NRule, NewIn, NewArgs) :- 548 divide_vars(PrevHead, OArity, NRule, OIndexHeadArgs, OMetaArgs), 549 update_inarg(OMetaArgs,NewIn, NMetaArgs), 550 append(OIndexHeadArgs, NMetaArgs, NewArgs). 551 552/* updates In when given Metaargs */ 553update_inarg([Index,_OldIn|Rest], NewIn, [Index,NewIn|Rest]). 554 555 556/* removes the first Nth arguments from rule clause, which are for indexing */ 557remove_indexing(0, Args0, Args1) :- !, Args0 = Args1. % nothing to remove 558remove_indexing(1, [_|Args0], Args1) :- !, Args0 = Args1. 559remove_indexing(N, [_|Args0], Args1) :- N > 1, 560 N1 is N - 1, 561 remove_indexing(N1, Args0, Args1). 562 563 564/* connect_orig_args(+OrigHead, +NRule, +IndexHeadArgs) 565 connect the original args. (i.e. "real" arguments from the constraint 566 OrigHead) with their corresponding args. in the current clause being 567 constructed -- these are in the IndexHeadArgs, which includes the 568 indexing args at the start 569*/ 570connect_orig_args(OHead, NRule, IndexHeadArgs) :- 571 OHead =.. [_|RealArgs], 572 remove_indexing(NRule, IndexHeadArgs, RealArgs). 573 574 575 576construct_prefired_otherpartners(RuleType, Status, Partners, DeleteHeads,KeepHeads, 577 RuleF, Head, Body, OrigArity, AllRests, Nth, NRule, Nprule, Candidates, CheckInsts, PInfo, ComInfo, PreFiredName, 578 PreFiredCodes, PostFiredCode, TryNexts, Code0, Module) :- 579 decompose_body(Body, Guard, BGoals), 580 get_constraintnumber(Head, ConstNo, Module), 581 make_try_other_name(RuleF, prefired, PreFiredName), 582 nmetaargs(Nprule, BasicSize), % number of "basic" meta-args 583 (Nprule == 0 -> MetaSize is BasicSize + 2; MetaSize is BasicSize + 3), 584 % 4 fixed meta-args (AllRest,Reason,Index,In) + 2 w/propagation (Applied, AppTail) 585 Arity is NRule + OrigArity + MetaSize, 586 functor(CHead, PreFiredName, Arity), 587 divide_vars(CHead, OrigArity, NRule, IndexHeadArgs, PreMetaArgs), 588 connect_orig_args(Head, NRule, IndexHeadArgs), 589 PreMetaArgs = [AllRests,_Reason|MetaArgs], 590 get_appliedtail(Nprule, MetaArgs, AppTail), 591 Code0 = [(CHead ?- Code1), (CHead :- NextRule)], 592 MetaArgs = [_Index,In|_], 593true, 594 construct_basic_head(CHead, Head, NRule, Nprule, MetaArgs, ConsHead), 595 TryNext0 = [f(NextRule, In, ConsHead)], 596 CommonArgs = a(Head,CHead,MetaArgs,Nth,AllRests1,_PIndecies,_GConst, 597 _Add_Applied, NAppTail), 598 % we no longer create TryNexts branches in fguards, so no need for TryNext 599 ExtendArgs = a(Status,ConstNo,BGoals,DeleteHeads,KeepHeads,PostFired0,[]), 600 601 construct_other_findpartners(AllRests, Partners, CommonArgs, NRule, 602 1, [], Nprule, Candidates, CheckInsts, Code1, Code2), 603 construct_fapplied(RuleType, AppTail, CommonArgs, PInfo, ComInfo, Code2, 604 PreFired0, Code3), 605 construct_fguard(Guard, (Head,Partners), CommonArgs, ExtendArgs, ComInfo, Nprule, Code3, Code4, Module), 606 construct_body(CommonArgs, ExtendArgs, Nprule, Code4, PostFired, TryNext1, Module), 607 608 % same args as head, except for AllRest, Reason and AppTail 609 % no need to append TryNext0, should not have pre/post fired if no 610 % partner 611 new_metaargs(Nprule, MetaArgs, NAppTail, NewMetaArgs), 612 append(TryNext0, TryNext1, TryNexts), 613 append(IndexHeadArgs, [AllRests1,applied|NewMetaArgs], PreArgs0), 614 append(IndexHeadArgs, [AllRests1|NewMetaArgs], PostArgs), 615 PreFiredCodes = [f(PreArgs0,PreFired0)], 616 PostFiredCode = [f(PostArgs,PostFired),f(PostArgs,PostFired0)]. 617 618 619 620construct_postfired_otherpartners(RuleType, Status, Partners, DeleteHeads, KeepHeads, RuleF, Head, Body, OrigArity, AllRests, Nth, NRule, Nprule, Candidates, CheckInsts, PInfo, ComInfo, PostFiredName, PostFiredCodes, TryNexts, Code0, Module) :- 621 decompose_body(Body, Guard, BGoals), 622 get_constraintnumber(Head, ConstNo, Module), 623 make_try_other_name(RuleF, postfired, PostFiredName), 624 nmetaargs(Nprule, BasicSize), 625 (Nprule ==0 -> MetaSize is BasicSize +1 ; MetaSize is BasicSize + 2), 626 % should try to remove these magic numbers 627 Arity is NRule + OrigArity + MetaSize, 628 functor(CHead, PostFiredName, Arity), 629 divide_vars(CHead, OrigArity, NRule, IndexHeadArgs, PostMetaArgs), 630 connect_orig_args(Head, NRule, IndexHeadArgs), 631 PostMetaArgs = [AllRests|MetaArgs], 632 get_appliedtail(Nprule, MetaArgs, AppTail), 633 Code0 = [( CHead :- Code1), (CHead :- NextRule)], 634 MetaArgs = [_Index,In|_], 635true, 636 construct_basic_head(CHead, Head, NRule, Nprule, MetaArgs, ConsHead), 637 TryNext0 = [f(NextRule, In, ConsHead)], 638 CommonArgs = a(Head,CHead,MetaArgs,Nth,AllRests1,_PIndecies,_GConst, 639 _Add_Applied,AppTail1), 640 ExtendArgs = a(Status,ConstNo,BGoals,DeleteHeads,KeepHeads,PostFired3,[]), 641 642 643 construct_other_findpartners(AllRests, Partners, CommonArgs, NRule, 644 1, [], Nprule, Candidates, CheckInsts, Code1, Code2), 645 construct_fapplied(RuleType, AppTail, CommonArgs, PInfo, ComInfo, Code2, PostFired0, Code3), 646 construct_fguard(Guard, (Head,Partners), CommonArgs, ExtendArgs, ComInfo, Nprule, Code3, Code4, Module), 647 construct_body(CommonArgs, ExtendArgs, Nprule, Code4, PostFired2, TryNext1, Module), 648 % no need to delete post-fired 649 650 append(TryNext0,TryNext1, TryNexts), 651 652 (Status == keep -> true; fill_in_with_true(TryNexts)), 653 new_metaargs(Nprule, MetaArgs, AppTail1, NewMetaArgs), 654 append(IndexHeadArgs, [AllRests1|NewMetaArgs], PostArgs), 655 PostFiredCodes = [f(PostArgs,PostFired0),f(PostArgs,PostFired2),f(PostArgs,PostFired3)]. 656 657 658/* new_metaargs(+Nprule, +OldArg, -NewAppTail, NewArgs) 659 creates NewArgs, the new meta-args, for the recursive calls to pre- and post- 660 fired clauses, from within a pre- and post- fire clause. OldArgs are the 661 original meta-args upon entry into the pre-/post-fired clause that is 662 being created, and the only value that needs to be changed is the AppTail 663 argument, if it exist 664*/ 665new_metaargs(Nprule, OldArgs, NewAppTail, NewArgs):- 666 (Nprule =:= 0 -> NewArgs = OldArgs ; 667 OldArgs = [Index,In,Applied,_], 668 NewArgs = [Index,In,Applied,NewAppTail] 669 ). 670 671 672fill_in_with_true([]) :- !. 673fill_in_with_true([f(ToBeTrue, _, _)|TryNexts]) :- 674 ToBeTrue = true, 675 fill_in_with_true(TryNexts). 676 677 678 679/* fill_current_head(+CurrentHead, +OriginalArity, +Nth, +NRule, +ArgList, 680 -IndexHeadArgs, -MetaArgs) 681 CurrentHead is the head of the translated Prolog goal for the current 682 rule being compiled. OriginalArity is the 683 original arity of the head constraints that triggered the trying of the 684 current rule, Nth indicates that the current rule is the Nth rule for this 685 constraint, and is used to construct the indexing, NRule is the number of 686 rules for this constraint, which determines how many arguments will be 687 needed for indexing. ArgList is a list of the original arguments in the 688 constraint. IndexHeadArgs will be returned with the indexing and head 689 (original arguments of the constraint) arguments of CurrentHead, and 690 MetaArgs are the "meta" arguments of CurrentHead, i.e. those needed to 691 allow for the suspension and rewakening of the constraint. 692*/ 693fill_current_head(CHead, A, Nth, NRule, ArgList, IndexHeadArgs, MetaArgs) ?- 694/* current scheme for head args are 695 (Indexing..., Original Args..., ConstraintIndex, FailureInfo, Applied) */ 696 (NRule \== 0 -> arg(Nth, CHead, 1) ; true),% indexing 697 fill_original_args(0, A, NRule, ArgList, CHead), 698 divide_vars(CHead, A, NRule, IndexHeadArgs, MetaArgs). 699 700 701/* divide_vars(+CurrentHead, +OrigArity, +NRule, -IndexHeadArgs, -MetaArgs) 702 splits the arguments of CurrentHead into two lists: IndexHeadArgs, which 703 are the Indexing and head args, and MetaArgs, which are the meta args 704*/ 705divide_vars(CHead, OArity, NRule, IndexHeadArgs, MetaArgs) :- 706 CHead =.. [_|AllArgs], 707 IndexHeadSize is OArity + NRule, 708 split_list(IndexHeadSize, AllArgs, IndexHeadArgs, MetaArgs). 709 710fill_original_args(N, N, _, [], _) :- !. 711fill_original_args(N0, Max, NRule, [Arg|ArgList], CHead) :- 712 N1 is N0 + 1, 713 Pos is NRule + N1, 714 arg(Pos, CHead, Arg), % put Arg in 715 fill_original_args(N1, Max, NRule, ArgList, CHead). 716 717 718/* get_appliedtail(+Nprule, +MetaArgs, -AppTail) 719 returns the AppTail meta-argument from MetaArgs if it exists (if there are 720 no propagation rules, i.e. Nprule = 0). This is for the pre and post fired 721 clauses, where the two propagation args would be at the end if they exist 722 The clause simply does not do anything if AppTail does not exist -- this 723 means that following clauses should not make use of AppTail 724*/ 725get_appliedtail(Nprule, [_,_|Pos], AppTail) :- 726 (Nprule =\= 0 -> Pos = [_Applied,AppTail] ; true). 727 728/* get_constraintnumber(+Constraint, -ListNumber, +Module) 729 returns the ListNumber for constraint, i.e. which constraint list a 730 particular constraint (in the form of a structure) is stored in 731*/ 732get_constraintnumber(Cons, ConstNo, Module) :- 733 functor(Cons,F,A), 734 get_constraintnumber_fa(F,A, ConstNo, _, Module). 735 736get_constraintnumber_fa(F,A, ConstNo, Prio, Module) :- 737 recorded_list('CHRconstraints', Constraints)@Module, 738 chr_constraint_info(Constraints, F/A, ConstNo, Prio). 739 740 741construct_check_identical(Partner, Head, PartnerIndex, CIndex, CheckIdentical) :- 742 /*get_constraintnumber(Partner, PartnerIndex),*/ 743 (\+ \+(Partner = Head) -> 744 % if unifiable, then need to generate code to check Partner is not current 745 CheckIdentical = (PartnerIndex \== CIndex) ; CheckIdentical = true 746 ). 747 748% construct code that checks if the currently found partner has already 749% been previously matched in this rule 750construct_not_already_matched([], _, CheckCode) :- !, 751 CheckCode = true. 752construct_not_already_matched([MatchedIndex], PartnerIndex, CheckCode) :- !, 753 CheckCode = (PartnerIndex \== MatchedIndex). 754construct_not_already_matched(MatchedIdxs, PartnerIndex, CheckCode) :- 755% more than one matched head already... 756 CheckCode = (\+memberchk(PartnerIndex, MatchedIdxs)). 757 758construct_find_partners([],a(_,_,_,_,AllRest,PIndex,_,_,_),_,_,_, 759 Com,Cans,InsChk,Code,_M) :- !, 760 Code = true, AllRest = [], PIndex = [], Com = [], 761 InsChk = [], Cans = []. 762construct_find_partners([Partner|Partners],a(Head,CHead,MetaArgs,Nth,AllRest, 763 [PartnerIndex|PIndecies],_,_,_), Cth, MatchedPIdxs, MatchedPartners, 764 [Common-Remain|Cs], [Candidate|Cans], [InstanceCheck|ICs], Code, Module) :- 765% Nth rule for this constraint, Cth partner, In for failure info 766% Head is the raw constraint head (i.e. without meta args) 767% MatchedPIdxs are indecies of the suspended goals for already matched 768% partners 769 MetaArgs = [CIndex,_In|_], 770 shared_vars(Partner, [Head|MatchedPartners], Common, Remain), 771 % non-shared variables in Candidate and Partner are the same 772 get_constraintnumber(Partner,ConstNo, Module), 773 (Common \== [] -> 774 GetSList = ech:get_constraint_list(Common, ConstNo, SuspL) 775 ; 776 GetSList = ech:get_global_constraint(ConstNo, SuspL) 777 ), 778 construct_check_identical(Partner, Head, PartnerIndex, CIndex, CheckIdentical), 779 construct_not_already_matched(MatchedPIdxs, PartnerIndex, CheckNotAlreadyMatched), 780 Code = 781 (GetSList, 782 ech:find_partner(SuspL, PartnerIndex, Candidate, Rest), 783 InstanceCheck, 784 CheckIdentical, 785 CheckNotAlreadyMatched, 786 RestCode0 787 ), 788 % If this is not the first partner, use the original suspension list 789 % instead of Rest (the remaining list after finding he current partner) 790 % This is because there might be dependencies from the earlier partners 791 % that means subsequent refiring of the (simpogation/propagation) rule 792 % needs to check partners that did not match with the current. 793 % A possible optimisation is to determine the dependencies to see if 794 % Rest can be used. 795 (Cth > 1 -> 796 AllRest = [SuspL|AllRest0] 797 ; 798 AllRest = [Rest|AllRest0] 799 ), 800 Cth1 is Cth + 1, 801 construct_find_partners(Partners,a(Head,CHead,MetaArgs,Nth,AllRest0, 802 PIndecies,_,_,_), Cth1, [PartnerIndex|MatchedPIdxs], 803 [Partner|MatchedPartners], Cs, Cans, ICs, RestCode0, Module). 804 805 806/* construct_basic_head(+CurrentClauseHead, +OrigConstraintHead, +NRule, 807 +Nprule, +BasicMetaArgs, -ConstructedHead) 808 constructs a "basic" head with just the indexing, real arguments, and 809 the basic meta-args. CurrentClauseHead is the head of the clause that 810 is being constructed. This can contain additional meta-args to the basic 811 one. These need to be removed. OrigConstraintHead is the constraint, 812 without any indexing or meta-args. NRule is the number of rules for this 813 constraint (i.e. number of indexing args.). BasicMetaArgs is the basic 814 meta-args for the CurrentClauseHead 815*/ 816construct_basic_head(CHead, Head, NRule, Nprule, MetaArgs, NewHead) :- 817 functor(Head,F,A), 818 divide_vars(CHead, A, NRule, IndexHeadArgs, _), 819 nmetaargs(Nprule, N), length(MetaArgs1, N), 820 append(MetaArgs1, _, MetaArgs), 821 % get rid of any extra non-basic arguments at end of MetaArgs 822 append(IndexHeadArgs, MetaArgs1, Args), 823 NewHead =.. [F|Args]. 824 825 826construct_other_findpartners([], [], a(_,_,_,_,AllRest,PIndex,_,_,_), _, _, _, 827 _, _, _, Code0, Code) :- !, 828 Code0 = Code, AllRest = [], PIndex = []. 829construct_other_findpartners([Rest|Rests], [Partner|Partners], a(Head,CHead, 830 MetaArgs,Nth,AllNRest,[PartnerIndex|PIndecies],_,_,_), NRule, Cth, 831 MatchedPIdxs, Nprule, [Candidate|Cans], [CheckIns|CIs], Code, RestCode) :- 832 MetaArgs = [CIndex, _In|_], 833 834 % construct ConsHead which contains only the basic meta-args 835 %construct_basic_head(CHead, Head, NRule, Nprule, MetaArgs, ConsHead), 836 837 construct_check_identical(Partner, Head, PartnerIndex, CIndex, CheckIdentical), 838 construct_not_already_matched(MatchedPIdxs, PartnerIndex, CheckNotAlreadyMatched), 839 Code = ( 840 ech:find_partner(Rest, PartnerIndex, Candidate, NewRest), 841 CheckIns, 842 CheckIdentical, 843 CheckNotAlreadyMatched, 844 845 RestCode0 846 ), 847 % use full original list if Cth > 1 848 (Cth > 1 -> 849 AllNRest = [Rest|NewRests] 850 ; 851 AllNRest = [NewRest|NewRests] 852 ), 853 Cth1 is Cth + 1, 854 construct_other_findpartners(Rests, Partners, a(Head,CHead,MetaArgs,Nth,NewRests,PIndecies,_,_,_), NRule, 855 Cth1, [PartnerIndex|MatchedPIdxs], Nprule, Cans, CIs, RestCode0, RestCode). 856 857 858/* extract_applied(+MetaArgs, -Applied) extracts the argument for storing 859 Applied information from the meta arguments of a clause 860*/ 861extract_applied([_,_,Applied|_], Applied). 862 863/* construct_applied_check 864 865 this constructs the appropriate direct applied (i.e. applied list has 866 already been extracted) check for propagation rules. This occurs in the 867 pre-fired and post-fired clauses. Currently it only deals with two headed 868 propagation rules (no check needed for single headed propagation 869 rules). In such cases, there are two factors: if the head constraints have 870 the same functor/arity, and if the one initiating the rule has already 871 been added to the constraint store or not. These generate four different 872 situations 873*/ 874 875construct_applied_check(1, double(H1,_H2), Head, RuleNo, PList, [PIndex], Index, Add_Applied, Not_AppliedCheck, AppTail, GConsNo, Status) :- !, 876 get_currentheadpos(H1, Head, Pos, OtherPos), 877 Not_AppliedCheck = ( 878 get_suspension_data(PIndex, goal, PGoal), 879 arg(constraintnum_pos, PGoal, PConsNumber), % get the ConsNo for partner 880 PList = [_|PListRest], 881 (var(Index) -> /* if var, then initiating head is not in constraint store */ 882 /* can only check in that case */ 883 ech:check_samepairapplied_direct(PList, PListRest, Pos-PConsNumber, AppTail, AppRest, Status) 884 885 ; /* can check and mark if initiating head already in constraint store */ 886 get_suspension_data(Index, goal, Cons0), 887 arg(constraintnum_pos, Cons0, GConsNo), 888 889 ech:check_samepairapplied_directmarked(PList, PListRest, Pos-PConsNumber, AppTail, OtherPos-GConsNo, PGoal, RuleNo, Status) 890 ) 891 892 ), 893 Add_Applied = samepairapplied(Pos,PConsNumber,AppTail,AppRest,OtherPos,PGoal,RuleNo). 894construct_applied_check(1, _, _, RuleNo, PList, [PIndex], Index, Add_Applied, 895 Code, AppTail, GConsNo, Status) :- !, 896 Code = (get_suspension_data(PIndex, goal, PGoal), 897 arg(constraintnum_pos, PGoal, PConsNumber), 898 PList = [_|PListRest], 899 (var(Index) -> 900 ech:check_pairapplied_direct(PList, PListRest, PConsNumber, AppTail, AppRest, Status) 901 902 ;get_suspension_data(Index, goal, Cons0), 903 arg(constraintnum_pos, Cons0, GConsNo), 904 905 ech:check_pairapplied_directmarked(PList, PListRest, PConsNumber, AppTail, GConsNo, PGoal, RuleNo, Status) 906 ) 907 ), 908 Add_Applied = pairapplied(PConsNumber,AppTail,AppRest,PGoal,RuleNo). 909construct_applied_check(N, _, _, _RuleNo, _PList, _, _Index, Add_Applied, 910 Code, _AppTail, _, _Status) :- !, 911 N > 1, 912 writeln(error, "Propagation rule with more than two head constraints not yet supported. No applied testing done.\n"), flush(error), 913 Add_Applied = true, 914 Code = true. 915 916 917 918 919 920appropriate_applied(0, _, _, RuleNo, [], Applied, Code, Add_Applied, 921 AppTail, _ConsNo, Status) :- !, 922 Code = ( nonvar(Applied) -> 923 arg(RuleNo, Applied, App), 924 (App == * -> Status = found ; Status = notfound) 925 ; % var(Applied) 926 number_of_propagations(Size), 927 ech:create_applied(Applied, Size), 928 Status = notfound 929 ), AppTail = [], 930 Add_Applied = arg(RuleNo, Applied, *). % * mark as read 931appropriate_applied(1, double(H1, _H2), Head, RuleNo, [PIndex], Applied, Code, 932 Add_Applied, AppTail, ConsNo, Status) :- !, 933 % propagation rule, with two heads that has the same functor and arity 934 % needs special check and insert applies 935 get_currentheadpos(H1, Head, Pos, OtherPos), 936 Code = ( get_suspension_data(PIndex, goal, PGoal), 937 arg(constraintnum_pos, PGoal, PConsNumber), 938 ech:check_samepairapplied(RuleNo, Applied, Pos-PConsNumber, AppTail, AppRest, Status) 939 ), 940 Add_Applied = ech:insert_samepairapplied(Pos-PConsNumber, AppTail, AppRest, OtherPos-ConsNo, PGoal, RuleNo). 941appropriate_applied(1, _, _, RuleNo, [PIndex], Applied, Code, Add_Applied, AppTail, ConsNo, 942 Status) :- !, 943 Code = ( get_suspension_data(PIndex, goal, PGoal), 944 arg(constraintnum_pos, PGoal, PConsNumber), 945 ech:check_pairapplied(RuleNo, Applied, PConsNumber, AppTail, AppRest, Status) 946 ), 947 Add_Applied = ech:insert_pairapplied(PConsNumber, AppTail, AppRest, ConsNo, PGoal, RuleNo). 948appropriate_applied(N, _, _, _RuleNo, _, _, Code, Add_Applied, _, _, _) :- 949 N > 1, 950 writeln(error, "Propagation rule with more than two head constraints not yet supported. Not applied testing done.\n"), flush(error), 951 Code = true, 952 Add_Applied = true. 953 954 955 956/* get_currentheadpos(+Head1, +Partner, -Pos, -OtherPos) 957 returns in Pos the position (1 or 2) of the current head that is being 958 transformed. OtherPos is the other position. Head1 is the first (leftmost) 959 head as occur in the rule, and Head is the current active head 960*/ 961get_currentheadpos(Head1, Head, Pos, OPos) :- 962 Head1 \== Head -> Pos = 2, OPos = 1; Pos = 1, OPos = 2. 963 964 965 966 967construct_applied(Rule_Type, Partners, a(Head,CHead,MetaArgs,Nth,_,PIndecies, 968 GConsNo,Add_Applied,AppTail), RuleNo, ComInfo, Code, PreFiredAlt, TryNext, 969 RestCode) :- 970 Rule_Type == propagation -> 971 length(PIndecies, NPartners), 972 extract_applied(MetaArgs, Applied), 973 appropriate_applied(NPartners, ComInfo, Head, RuleNo, PIndecies, Applied, Not_Applied, Add_Applied, AppTail, GConsNo, Status), 974 975 Code = ( 976 Not_Applied, 977 (Status == notfound -> 978 RestCode 979 ; !, AltAction 980 ) 981 ), 982 (Partners == [] -> 983 MetaArgs = [_Index,In|_], % get In 984 TryNext = [f(AltAction, [Nth-notapp|In], CHead)], 985 PreFiredAlt = true 986 ; TryNext = [], PreFiredAlt = AltAction 987 ) 988 ; Add_Applied = true, PreFiredAlt = true, TryNext = [], 989 RestCode = Code. 990 991construct_fapplied(Rule_Type, Partners, a(Head,_,MetaArgs,_,_,PIndecies,GConsNo,Add_Applied,AppTail), RuleNo, ComInfo, Code, PreFiredAlt, RestCode) :- 992 Rule_Type == propagation -> 993 MetaArgs = [Index|_], 994 length(PIndecies, NPartners), 995 construct_applied_check(NPartners, ComInfo, Head, RuleNo, Partners, PIndecies, Index, Add_Applied, Not_AppliedCheck, AppTail, GConsNo, Status), 996 997 Code = ( 998 Not_AppliedCheck, 999 (Status == notfound -> 1000 RestCode 1001 ; !, PreFiredAlt 1002 ) 1003 ) 1004 ; 1005 Add_Applied = true, 1006 RestCode = Code. 1007 1008/* metaguard_code(+Guard, -Code) 1009 construct the code for "meta" Guards -- i.e. none of the guards can 1010 constrain the variables in them 1011*/ 1012metaguard_code(Guard, Code) :- 1013 Code = (last_suspension(Mark), 1014 Guard, ttrue, % need to mark differently so not optimised away 1015 new_suspensions(Mark,[]) % no goals in guard has been delayed 1016 ). 1017 1018/* guard_code(+Guard, +Global, -Code) 1019 construct the code for Guards, where they contain goals which are capable 1020 of constraining (global)variables. Code taken from old chr.pl: 1021 1022% Before the guard (Goal) is called, a 'fail' is attached to every variable 1023% of the Goal. Then, as soon as one of these variables is touched 1024% (unified), the call will fail. 1025 1026*/ 1027guard_code(Guard, Globals, Code) :- 1028 Code = ( 1029 make_suspension(fail, 1, Susp), 1030 insert_suspension(Globals, Susp, constrained of suspend, suspend), 1031 last_suspension(Mark), 1032 Guard, ttrue, 1033 new_suspensions(Mark, []), 1034 kill_suspension(Susp) 1035 ). 1036 1037construct_invertable_rule(Globals, CommonArgs, InvBody, ExtendArgs, Nprule, Code, Try_Other_Partners, TryNext, Module) :- 1038 decompose_body(InvBody, InvG, InvB), 1039 construct_guard(InvG, Globals, CommonArgs, nil, ExtendArgs, Nprule, Code, Try_Other_Partners, TryNext, RestCode, Module), 1040 ExtendArgs = a(delete,ConstNo,_,DeleteHead,KeepHead,PostFired,TryNext1), 1041 % Delete and Keep Heads swapped 1042 construct_body(CommonArgs, a(keep,ConstNo,InvB,KeepHead,DeleteHead, 1043 PostFired,TryNext1), Nprule, RestCode, PostFired, TryNext1, Module). 1044 1045construct_guard(Guard, Globals, CommonArgs, ComInfo, ExtendArgs, Nprule, Code, Try_Other_Partners, TryNext, Rest_Code, Module) :- 1046 1047 CommonArgs = a(_,CHead,MetaArgs,Nth,AllRest,_,_,_,_), 1048 (Guard \== true -> 1049 ((recorded('CHRdont_guard_bindings', Module) ; nonconstrainable(Guard)) -> 1050 % check if guard can possibly cause the constraining of any variable 1051 metaguard_code(Guard, Execute_Guard) 1052 ; guard_code(Guard, Globals, Execute_Guard) 1053 ), 1054 1055 (AllRest == [] -> /* no need to try other partners */ 1056 Code = ( 1057 Execute_Guard -> !, 1058 Rest_Code 1059 ; !, AltCode 1060 1061 ), 1062 MetaArgs = [_Index,In|_], 1063 TryNext = [f(Try_Next_Rule, [Nth-gf|In], CHead)], 1064 Try_Other_Partners = true 1065 1066 ; %AllRest \== [] 1067 Code = 1068 (Execute_Guard -> !, 1069 Rest_Code 1070 ; !, AltCode 1071 ), 1072 TryNext = [] 1073 ), 1074 1075 (ComInfo = twobodies(InvBody) -> 1076 construct_invertable_rule(Globals, CommonArgs, InvBody, ExtendArgs, Nprule, AltCode, Try_Other_Partners, TryNext, Module) 1077 1078 ; (AllRest == [] -> AltCode = Try_Next_Rule ; AltCode = Try_Other_Partners), 1079 ExtendArgs = a(_,_,_,_,_,true,[]) 1080 ) 1081 1082 ; /* Guard == true */ 1083 ExtendArgs = a(_,_,_,_,_,true,[]), % bind the output args 1084 Code = (!, Rest_Code), Try_Other_Partners = true, 1085 TryNext = [] 1086 ). 1087 1088 1089construct_fguard(Guard, Globals, CommonArgs, ExtendArgs, ComInfo, Nprule, Code, Rest_Code, Module) :- 1090 (Guard \== true -> 1091 ((recorded('CHRdont_guard_bindings', Module) ; nonconstrainable(Guard)) -> 1092 % check if guard can possibly cause the constraining of any variable 1093 metaguard_code(Guard, Execute_Guard) 1094 ; guard_code(Guard, Globals, Execute_Guard) 1095 ), 1096 (ComInfo = twobodies(Inv) -> 1097 Code = (Execute_Guard -> 1098 !, Rest_Code ; AltCode 1099 ), 1100 construct_finvertable_rule(Globals, Inv, CommonArgs, ExtendArgs, Nprule, AltCode, Module) 1101 1102 ; Code = ( 1103 Execute_Guard, !, 1104 Rest_Code 1105 ) 1106 1107 1108 ) 1109 ; /* Guard == true, no difference in twobodies case, as head will be 1110 removed */ 1111 Code = (!, Rest_Code) 1112 ). 1113 1114 1115 1116construct_finvertable_rule(Globals, Inv, CommonArgs, ExtendArgs, Nprule, Code, Module) :- 1117 decompose_body(Inv, InvG, InvB), 1118 construct_fguard(InvG, Globals, CommonArgs, ExtendArgs, nil, Nprule, Code, RestCode, Module), 1119 ExtendArgs = a(delete,ConstNo,_,DeleteHead,KeepHead,PostFired,TryNext1), 1120 % Delete and Keep Heads swapped 1121 construct_body(CommonArgs, a(keep,ConstNo,InvB,KeepHead,DeleteHead, 1122 PostFired,TryNext1), Nprule, RestCode, PostFired, TryNext1, Module). 1123 1124 1125 1126construct_deletion([], _, _, true) :- !. 1127construct_deletion([DHead|DHs], [Index|Indecies], Constraints, Code) :- 1128 functor(DHead,F,A), 1129 chr_constraint_info(Constraints, F/A, ConstNo, _), 1130 Code = (ech:kill_constraint(ConstNo, Index), Code1), 1131 construct_deletion(DHs, Indecies, Constraints, Code1). 1132 1133 1134construct_body(a(Head,CHead,MetaArgs,_,AllRest,PIndecies,GConst,Add_Applied,_), 1135 ExtendArgs, Nprule, Code, PostFired, TryNext, Module) :- 1136 1137 ExtendArgs = a(HeadAction,ConstNo,BodyGoals,DeleteHeads,_,_,_), 1138 recorded_list('CHRconstraints', Constraints)@Module, 1139 construct_deletion(DeleteHeads, PIndecies, Constraints, DeleteConstraints), 1140 MetaArgs = [Index,In|_], 1141 nmetaargs(Nprule, BasicSize), 1142 length(BasicMetaArgs, BasicSize), % only basic MetaArgs are used in suspended constraint 1143 append(BasicMetaArgs, _, MetaArgs), 1144 (HeadAction == keep -> 1145 construct_wrapper_constraint(Head, BasicMetaArgs, Constraint, GConst), 1146 functor(Head,F,A), 1147 get_constraintnumber_fa(F,A, _, Prio, Module), 1148 generate_constraint_suspend(Add_Applied, Index, Constraint, Head, 1149 ConstNo, Prio, GConst, SCode), 1150 Code = ( 1151 SCode, 1152 DeleteConstraints, 1153 BodyGoals, 1154 May_Continue 1155 ), 1156 (AllRest == [] -> 1157 PostFired = true, 1158 TryNext = [f(Continue1,In,CHead)], 1159 add_may_continue(BodyGoals, Index, May_Continue, Continue1) 1160 ; 1161 TryNext = [], 1162 add_may_continue(BodyGoals, Index, May_Continue, PostFired) 1163 ) 1164 1165 ; /* HeadAction \= keep */ 1166 Code = ( 1167 ech:kill_constraint(ConstNo, Index), 1168 DeleteConstraints, 1169 BodyGoals 1170 ), PostFired = true, TryNext = [] 1171 ). 1172 1173 1174/* add check for if Index is a live suspension or not if the body goals 1175 could possibly cause the constraint to be killed 1176*/ 1177add_may_continue(BodyGoals, Index, May_Continue, ContinueCode) :- 1178 (nonconstrainable(BodyGoals) -> 1179 % if body goals could not possibly cause constraint to be killed, 1180 % then no need to test if suspension is valid or not. 1181 May_Continue = ContinueCode 1182 ; May_Continue = 1183 (is_suspension(Index) -> 1184 ContinueCode ; true 1185 ) 1186 ). 1187 1188/* generate the code for dealing with the possible addition of a constraint 1189 to the constraint store after a rule is fired. If the rule is a two 1190 headed propagation rule, then special code may need to be generated to 1191 deal with checking if the heads have been applied already. There is also 1192 different code in this case for the initial call and the pre- and post- 1193 fired calls 1194*/ 1195generate_constraint_suspend(samepairapplied(Pos,PConsNumber,AppTail,AppRest, 1196 OtherPos,PGoal,RuleNo), _Index, Constraint, Head, ConstNo, Prio, GConst, Code) ?- !, 1197% double headed propagation rule, with same (same functor) heads. Here 1198% Add_Applied (first arg.) is used to pass extra args for constructing code 1199 Code = 1200 (var(GConst) -> % check GConst instead of Index. Previous check of var(Index) means GConst would be instatiated if Index non-var 1201 ech:suspend_constraint(Constraint, Head, ConstNo, Prio), 1202 ech:insert_samepairapplied(Pos-PConsNumber, AppTail, AppRest, OtherPos-GConst, PGoal, RuleNo) 1203 1204 ; true 1205 ). 1206generate_constraint_suspend(pairapplied(PConsNumber,AppTail,AppRest,PGoal,RuleNo), 1207 _Index, Constraint, Head, ConstNo, Prio, GConst, Code) ?- !, 1208% double headed propagation rule, with different heads 1209 Code = 1210 (var(GConst) -> 1211 ech:suspend_constraint(Constraint, Head, ConstNo, Prio), 1212 ech:insert_pairapplied(PConsNumber, AppTail, AppRest, GConst, PGoal, RuleNo) 1213 1214 ; true 1215 ). 1216generate_constraint_suspend(Add_Applied, Index, Constraint, Head, ConstNo, 1217 Prio, GConst, Code) :- 1218% generic case 1219 Code = ( 1220 (var(Index) -> 1221 ech:suspend_constraint(Constraint, Head, ConstNo, Prio) 1222 ; get_suspension_data(Index, goal, Cons0), 1223 arg(constraintnum_pos, Cons0, GConst) 1224 %Cons0 is Constraint, but use new var as no need to deconstruct 1225 ), 1226 Add_Applied 1227 ). 1228 1229 1230/* make_current_rule_name(+CFunctor, +CArity, +Nth, +NRule, +Nprule, -NewRuleHead, -NewArity) 1231 creates a new clause head (NewRuleHead) for a translated rule called with a 1232 constraint CFunctor/CArity. This clause is the Nth clause for this constraint. 1233 There are a total of NRule for this constraint. 1234 Nprule is the number of propagation rule in the program, if this is zero, the 1235 clause head is simplier as it omits the Applied argument 1236*/ 1237make_current_rule_name(CF, CA, Nth, NRule, Nprule, RuleHead, Arity) :- 1238 (Nprule =:= 0 -> Extra = 0 ; Extra = 1), 1239 Arity is CA + Extra + NRule + 2, % NRule args for indexing; 2 extra meta arguments 1240 make_rulefunctor(CF, CA, Nth, Functor), 1241 functor(RuleHead, Functor, Arity). 1242 1243make_rulefunctor(CF, CA, Nth, Functor) :- % creates a (hopefully) unique new name 1244 concat_atom(['CHR',CF,CA,'_',Nth], Functor). 1245 1246/* make_try_other_name(+MainRuleHead, +Position, -Name) 1247 creates the name for the auxillary predicates for the rule with MainRuleHead 1248 as head of the rule. Position is either prefired or postfired, depending 1249 on if the goal is to be called before or after the firing of the rule 1250*/ 1251make_try_other_name(MainRuleHead, Position, Name) :- 1252 functor(MainRuleHead, F, _), 1253 concat_atom([F,Position], Name). 1254 1255 1256/* construct_wrapper_constraint(+CHead, +ExtraArgs, -Constraint, -GlobalNumber) 1257 constructs the actual suspension (Constraint) that is used to represent 1258 the suspended constraint CHead. ExtraArgs is a list of the meta arguments 1259 carried by the actual suspension. GlobalNumber is the global constraint 1260 number used to index CHR constraints for this Constraint 1261*/ 1262construct_wrapper_constraint(CHead, ExtraArgs, Constraint, GConsNo) :- 1263 functor(CHead, CF, CA), 1264 concat_atom(['CHRsusp',CF,CA], WFunctor), 1265 Constraint =.. [WFunctor, GConsNo, CHead|ExtraArgs]. 1266 1267nmetaargs(Nprule, N) :- 1268% Currently MetaArgs are Index,In,Applied 1269 (Nprule =:= 0 -> N = 2 ; N = 3). 1270 1271 1272optimise([], []) :- !. 1273optimise([Clause|Code], [OClause|OCode]) :- 1274 optimise_clause(Clause, OClause), 1275 optimise(Code, OCode). 1276 1277optimise_clause((:- Goal), (:- Goal)) :- !. 1278optimise_clause((Head :- Body), (Head :- OBody)) :- !, 1279 optimise_body(Body, OBody0), optimise_further(OBody0, OBody). 1280optimise_clause((Head ?- Body), (Head ?- OBody)) :- !, 1281 optimise_body(Body, OBody0), optimise_further(OBody0, OBody). 1282optimise_clause(Fact, Fact). 1283 1284 1285% convert ttrue to true and remove singleton trues that may be left. 1286optimise_further(ttrue, Out) ?- !, Out = true. 1287optimise_further((ttrue, Goals), Out) ?- !, Out = (true,OGoals), 1288 optimise_further(Goals, OGoals). 1289optimise_further((true, Goals), OGoals) ?- !, 1290 optimise_further(Goals, OGoals). 1291optimise_further((Goal, true), OGoal) ?- !, 1292 optimise_further(Goal, OGoal). 1293optimise_further((Goal,Goals), Out) ?- !, Out = (OGoal,OGoals), 1294 optimise_further(Goal, OGoal), optimise_further(Goals, OGoals). 1295optimise_further((Goal1;Goal2), Out) ?- !, Out = (OGoal1;OGoal2), 1296 optimise_further(Goal1, OGoal1), optimise_further(Goal2, OGoal2). 1297optimise_further((If -> Then), Out) ?- !, Out = (OIf -> OThen), 1298 optimise_further(If, OIf), optimise_further(Then, OThen). 1299optimise_further(Goal, Goal). 1300 1301 1302optimise_body((true, Goals), OGoals) ?- !, 1303 optimise_body(Goals, OGoals). 1304optimise_body((Goal,true), OGoal) ?- !, 1305 optimise_body(Goal, OGoal). 1306optimise_body((Goal,Goals), Out) ?- !, Out = (OGoal,OGoals), 1307 optimise_body(Goal, OGoal), 1308 optimise_body(Goals, OGoals). 1309optimise_body((Goals1;Goals2), Out) ?- !, Out = (OGoals1;OGoals2), 1310 optimise_body(Goals1, OGoals1), 1311 optimise_body(Goals2, OGoals2). 1312optimise_body((If -> Then), Out) ?- !, Out = (OIf -> OThen), 1313 optimise_body(If, OIf), 1314 optimise_body(Then, OThen). 1315optimise_body(Goal, Goal). 1316 1317 1318printcode([]) :- !. 1319printcode([Clause|Clauses]) :- 1320 writeclause(log_output,Clause), nl, 1321 printcode(Clauses). 1322 1323 1324/* nonconstrainable(+Goals) succeeds if all goals in Goals 1325 cannot possibly constrain the value of their arguments. 1326*/ 1327nonconstrainable((Guard1, Guard2)) ?- 1328 nonvar(Guard1), !, 1329 nonconstrainable(Guard1), nonconstrainable(Guard2). 1330nonconstrainable(Guard) :- % single goal 1331 nonconstraining_goal(Guard). 1332 1333nonconstraining_goal(_ > _) :- !. 1334nonconstraining_goal(_ < _) :- !. 1335nonconstraining_goal(_ >= _) :- !. 1336nonconstraining_goal(_ =< _) :- !. 1337nonconstraining_goal(var(_)) :- !. 1338nonconstraining_goal(nonvar(_)) :- !. 1339nonconstraining_goal(_ == _) :- !. 1340nonconstraining_goal(_ =:= _) :- !. 1341nonconstraining_goal(_ =\= _) :- !. 1342nonconstraining_goal(_ \== _) :- !. 1343nonconstraining_goal(ground(_)) :- !. 1344nonconstraining_goal(nonground(_)) :- !. 1345nonconstraining_goal(free(_)) :- !. 1346nonconstraining_goal(integer(_)) :- !. 1347nonconstraining_goal(number(_)) :- !. 1348nonconstraining_goal(float(_)) :- !. 1349nonconstraining_goal(real(_)) :- !. 1350nonconstraining_goal(rational(_)) :- !. 1351nonconstraining_goal(breal(_)) :- !. 1352nonconstraining_goal(_@>_) :- !. 1353nonconstraining_goal(_@<_) :- !. 1354nonconstraining_goal(_@>=_) :- !. 1355nonconstraining_goal(_@=<_) :- !. 1356nonconstraining_goal(_@>_) :- !. 1357 1358 1359/* shared_vars(?T1, ?T2, -Shared, -Remain1) 1360 returns in Shared the shared variables of Terms T1 and T2, Remain1 1361 will contain the non-shared variables in T1 1362*/ 1363shared_vars(T1, T2, Shared, Remain1) :- 1364 term_variables(T1, Vars1), 1365 term_variables(T2, Vars2), 1366 intersect(Vars1, Vars2, Shared, Remain1). 1367 1368intersect([], _, L, R) :- !, L = [], R =[]. 1369intersect([V1|L1], L2, Intersect, Remain) :- 1370 (membervar(L2, V1) -> 1371 Intersect = [V1|Intersect0], Remain = Remain0 1372 ; Intersect = Intersect0, Remain = [V1|Remain0] 1373 ), intersect(L1, L2, Intersect0, Remain0). 1374 1375 1376membervar([V1|L], V) :- 1377 V == V1 -> true ; membervar(L,V). 1378 1379 1380initialise_processed(N, Processed) :- 1381 functor(Processed, rules, N), 1382 make_empty_lists(N, Processed). 1383 1384/* make_list(+CommaList, -List) 1385 changes CommaList (in the form (A1,A2,....An) to a normal List) 1386*/ 1387make_list((A1,A2), [A1|L]) :- 1388 !, 1389 make_list(A2, L). 1390make_list(A, [A]). 1391 1392 1393/* decompose_body(+Body, -GuardGoals, -BodyGoals) 1394 breaks down the incoming Body into goals for the guard and body 1395*/ 1396decompose_body((Guards|Goals), Guards, Goals) :- !. 1397decompose_body(Goals, true, Goals). 1398 1399 1400 1401syntax_check([], _, _, _). 1402syntax_check([Rule|Rules], Constraints, PRules, Module) :- 1403 check_one_rule0(Rule, Constraints, PRules, Module), 1404 syntax_check(Rules, Constraints, PRules, Module). 1405 1406 1407check_one_rule0(FRule, Constraints, Processed, Module) :- 1408 (FRule = (Name ::= Rule) -> 1409 check_one_rule(Rule, Constraints, Processed, Name, Module) 1410 ; check_one_rule(FRule, Constraints, Processed, [], Module) 1411 ). 1412 1413check_one_rule((KeepHeads\DeleteHeads <=> Body), Constraints, Processed, Name, 1414 Module) ?- !, 1415 Rule = (KeepHeads\DeleteHeads<=>Body), 1416 make_list(KeepHeads, KHeadsL0), 1417 make_list(DeleteHeads, DHeadsL0), 1418 remove_symmetric(DHeadsL0, DHeadsL), 1419 %may_remove_symmetric(KHeadsL0, KHeadsL), 1420 KHeadsL0 = KHeadsL, 1421 single_simpogation(KHeadsL, DHeadsL, Body, InvBody, Type, Module), 1422 simpogation_action(Type, Rule, KHeadsL0, KHeadsL, DHeadsL0, DHeadsL, Body, 1423 InvBody, Constraints, Processed, Name). 1424check_one_rule((Heads <=> Body), Constraints, Processed, Name, _Module) ?- !, 1425 Rule = (Heads <=> Body), 1426 make_list(Heads, HeadList0), 1427 remove_symmetric(HeadList0, HeadList), 1428 definedheads(HeadList, Constraints, delete, [], HeadList0, Body, 0, Rule, 1429 Name, not_prop, nil, Processed). 1430check_one_rule(PNo-(Heads==>Body), Constraints, Processed, Name, _Module) ?- 1431 Rule = (Heads==>Body), 1432 make_list(Heads, HeadList0), 1433 may_remove_symmetric(Body, HeadList0, HeadList, Info), 1434 definedheads(HeadList, Constraints, keep, HeadList0, [], Body, 0, Rule, 1435 Name, PNo, Info, Processed). 1436 1437 1438simpogation_action(not_reducible, Rule, KHeadsL0, KHeadsL, DHeadsL0, DHeadsL, 1439 Body, _InvBody, Constraints, Processed, Name) ?- !, 1440 1441 definedheads(KHeadsL, Constraints, keep, KHeadsL0, DHeadsL0, Body, 0, Rule, 1442 Name, not_prop, nil, Processed), 1443 definedheads(DHeadsL, Constraints, delete, KHeadsL0, DHeadsL0, Body, 0, Rule, 1444 Name, not_prop, nil, Processed). 1445simpogation_action(nobody, Rule, KHeadsL0, _KHeadsL, DHeadsL0, DHeadsL, 1446 Body, _InvBody, Constraints, Processed, Name) ?- !, 1447 definedheads(DHeadsL, Constraints, delete, KHeadsL0, DHeadsL0, Body, 0, 1448 Rule, Name, not_prop, nil, Processed). 1449simpogation_action(twobodies, Rule, KHeadsL0, _KHeadsL, DHeadsL0, DHeadsL, 1450 Body, InvBody, Constraints, Processed, Name) ?- 1451 definedheads(DHeadsL, Constraints, delete, KHeadsL0, DHeadsL0, Body, 0, 1452 Rule, Name, not_prop, twobodies(InvBody), Processed). 1453 1454 1455 1456get_prop_nclausearg(V0,V1) :- var(V0), !, V0 = V1. 1457get_prop_nclausearg([N-_Head|Rest], [N|Ns]) :- 1458 get_prop_nclausearg(Rest, Ns). 1459 1460/* definedheads(+HeadList, +Constraints, +Status, +KeepHeads, +DeleteHeads, 1461 +Body, +N, +Rule, +Name, +PropNum, +Info, +Processed) 1462 definedheads checks if the head constraints in HeadList of rule Rule are 1463 defined or not. It also does some initial processing on the rule to ease 1464 the later translation: the constraints that are kept (KeepHeads) and those 1465 that are deleted (DeleteHeads) are seperated when called. The HeadList 1466 passed is either those constraints that are kept (i.e. same as KeepHeads) 1467 or those that are deleted (DeleteHeads), as indicated by Status. Body is 1468 the body of the rule (guard and body goals). N is used to indicate the Nth 1469 Head in HeadList is being considered. Processed is used to store the 1470 processed rule. For a particular rule, an entry is made in Processed for 1471 each head constraint in the rule. Name is the name the user gave to the 1472 rule, would be [] if not named. PropNum is the propagation rule number for 1473 this propagation rule (not_prop if not propagation rule). 1474 Additional information deduced obtained during the processing which 1475 have affected the way processed rules are generated - this information 1476 is passed along in Info for correct behaviour during transformation 1477 1478*/ 1479definedheads([H|Hs0], Constraints, Status, AllKHeads, AllDHeads, Body, N0, Rule, Name, NProp, Info, Processed) ?- 1480 functor(H, F, A), 1481 (chr_constraint_info(Constraints, F/A, ConsNum, _) -> 1482 N1 is N0 + 1, 1483 (Status == keep -> 1484 remove_head(N1, AllKHeads, OtherHeads), 1485 addto_processed(ConsNum, Rule, keep, H, OtherHeads, AllDHeads, Body, 1486 Name, NProp, Info, Processed) 1487 ; remove_head(N1, AllDHeads, OtherHeads), 1488 addto_processed(ConsNum, Rule, delete, H, AllKHeads, OtherHeads, 1489 Body, Name, NProp, Info, Processed) 1490 ), 1491 definedheads(Hs0, Constraints, Status, AllKHeads, AllDHeads, Body, N1, Rule, Name, NProp, Info, Processed) 1492 ; printf(error, "Syntax error: undefined constraint %a/%w (%w) found in:\n", [F,A,H]), 1493 flush(error), 1494 pretty_write(Rule) 1495 % some error recovery routine 1496 ). 1497definedheads([], _, _, _, _, _, _, _, _, _, _, _). 1498 1499 1500% for propagation rule, can only remove symmetric heads if body goals cannot 1501% affect computation (only catch "true" as such a body goal for now) 1502 1503may_remove_symmetric(Body, Hs0, Hs, Info) :- 1504 simple_body(Body) -> 1505 remove_symmetric(Hs0, Hs), 1506 (Hs0 == Hs -> % no removal 1507 check_double_samehead(Hs, Info) 1508 ; Info = nil 1509 ) 1510 ; check_double_samehead(Hs0, Info), 1511 Hs0 = Hs. 1512 1513simple_body(true) :- !. 1514simple_body((_G|Body)) :- 1515 simple_body(Body). 1516 1517check_double_samehead([H1,H2], Info) :- 1518 functor(H1, F, A), functor(H2, F, A), !, 1519 Info = double(H1, H2). 1520check_double_samehead(_, nil). 1521 1522 1523remove_symmetric([H1,H2], Hs) :- !, 1524 (is_symmetric(H1, H2) -> Hs = [H1] ; Hs = [H1,H2]). 1525remove_symmetric(Hs, Hs). 1526 1527 1528is_symmetric(H1, H2) :- 1529 \+ \+(H1 = H2), 1530 \+ \+is_pairsymmetric(H1,H2). 1531 1532is_pairsymmetric(H1,H2) :- 1533 copy_term((H2,H1), NPair), 1534 numbervars((H1,H2), 0, N), 1535 numbervars(NPair, 0, N), 1536 NPair == (H1,H2). 1537 1538no_body((true|true)) :- !. 1539no_body(true). 1540 1541% if the simpogation rule has only two heads, and the keep and deleted 1542% heads are symmetric, then generate only one rule for the two heads 1543single_simpogation([KH], [DH], Body, NBody, Type, Module) :- 1544 \+recorded('CHRdont_simpa_symmetric', Module), 1545 \+ \+(KH = DH), 1546 \+ \+is_pairsymmetric(KH, DH), !, 1547 (no_body(Body) -> 1548 Type = nobody 1549 1550 ; Type = twobodies, 1551 % the following assumes term_variables/2 will extract variables in 1552 % exactly the same order for two symmetric terms 1553 term_variables((KH,Body),Vars1), 1554 term_variables((DH,Body),Vars2), 1555 copy_term((Body,Vars1,Vars2),(NBody,Vars2,Vars1)) 1556 ). 1557single_simpogation(_, _, _, _, Type, _M) :- Type = not_reducible. 1558 1559 1560 1561/* shared_vars(H1, H2, Shared, _Rest), 1562 is_symmetric_with_shared(Shared, H1, H2). 1563 1564is_symmetric_with_shared([], _, _) :- !. 1565is_symmetric_with_shared([Var|Vars], H1, H2) :- 1566 % need to check that all shared vars are in same position 1567 \+ \+(check_one_var(Var, H1, H2)), 1568 is_symmetric_with_shared(Vars, H1, H2). 1569*/ 1570 1571check_one_var(*, H1, H2) :- 1572 copy_term(H1, H11), 1573 variant(H11, H2). % need copy_term to get rid of shared var 1574 1575/* addto_processed(+ConsNo, +Rule, +Status, +Head, +KeepHeads, +DeleteHeads, 1576 +Body, +Name, +PropagationNo, +Info, +Processed) 1577 adds information about rule Rule when the trying of the rule is initiated 1578 by Head. ConsNo is the constraint number for Head. Status is either keep or 1579 delete, indicating if Head is to be kept or deleted from the constraint 1580 store if the rule is fired. KeepHeads and DeleteHeads are lists of the 1581 other heads in rule (i.e. excluding Head) that are to be kept or deleted 1582 after firing of rule. Body is the guard and body goals of the rule. 1583 Processed is the structure into which this information is to be added. 1584 PropagationNo is the propagation rule number for this propagation rule. 1585 Info is additional information that may be needed in transformation stage 1586*/ 1587addto_processed(ConsNo, Rule, Status, Head, KeepHeads, DeleteHeads, Body, Name, 1588 NProp, Info, Processed) :- 1589 arg(ConsNo, Processed, RulesList), 1590 setarg(ConsNo, Processed, [rule(Rule,Status,Head,KeepHeads,DeleteHeads,Body, NProp, Info, Name)|RulesList]). 1591 1592 1593 1594remove_head(1, [_Head|Heads], Heads) :- !. 1595remove_head(N, [Head|Heads0], [Head|Heads1]) :- 1596 N1 is N - 1, 1597 remove_head(N1, Heads0, Heads1). 1598 1599construct_writeconstraint_code(SCons, Define, NNameRule) :- 1600 functor(SCons, F, A), 1601 atom_string(F, FS), 1602 append_strings(FS, "print", NNameS), 1603 atom_string(NName, NNameS), 1604 1605 arg(2, SCons, Constraint), 1606 NNameRule =.. [NName, SCons, Constraint], 1607 Define = (:- erase_macro(F/A), export(macro(F/A, NName/2, [write,goal]))). 1608 1609chr(File, Module) :- 1610 chr_clear, 1611 compile(File)@Module. 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1627% Runtime stuff 1628 1629count_and_record_constraints((ConstDec1,ConstDec2), Count0, Count, Module) :- 1630 !, 1631 count_and_record_constraints(ConstDec1, Count0, Count1, Module), 1632 count_and_record_constraints(ConstDec2, Count1, Count, Module). 1633count_and_record_constraints(SingleConstDec, Count0, Count, Module) :- 1634 Count1 is Count0 + 1, 1635 % Count is also used as id for constraint 1636 recorded_list('CHRconstraints', ConList)@Module, 1637 (extract_constraint_info(SingleConstDec, ConstSpec, Prio) -> 1638 true 1639 ; 1640 printf(error, "invalid chr constraint declaration: %w;" 1641 " aborting..%n", [SingleConstDec]), 1642 abort 1643 ), 1644 (chr_constraint_info(ConList, ConstSpec, _,_) -> 1645 % WARNING -- need to be integrated into system errors? 1646 printf(warning_output, "Warning -- constraint %w already declared\n",ConstSpec), 1647 Count = Count0 1648 ; Count = Count1, 1649 1650 recordz('CHRconstraints', chrcinfo with [spec:ConstSpec,count:Count,prio:Prio])@Module 1651 ). 1652 1653extract_constraint_info(F/A:PrioSpec, ConstSpec, Prio) ?- 1654 ConstSpec = F/A, 1655 priospec_to_priority(PrioSpec, F/A, Prio). 1656extract_constraint_info(F/A, ConsSpec, Prio) ?- 1657 ConsSpec = F/A, 1658 getval(chr_priority, Prio). 1659 1660priospec_to_priority(at_higher(N), F/A, Prio) ?- 1661 Prio0 is getval(chr_priority) - N, 1662 (Prio0 < 1 -> 1663 printf(error, "Relative priority specified for %w:higher(%d)" 1664 " too high; using 1 instead%n", [F/A,N]), 1665 Prio = 1 1666 ; 1667 Prio = Prio0 1668 ). 1669priospec_to_priority(at_lower(N), F/A, Prio) ?- 1670 Prio0 is getval(chr_priority) + N, 1671 (Prio0 > 11 -> 1672 printf(error, "Relative priority specified for %w:lower(%d)" 1673 " too low; using 11 instead%n", [F/A,N]), 1674 Prio = 11 1675 ; 1676 Prio = Prio0 1677 ). 1678priospec_to_priority(at_absolute_priority(N), F/A, Prio) ?- 1679 (N > 0, N < 12 -> 1680 Prio = N 1681 ; 1682 printf(error, "Absolute priority out of range for" 1683 " %w:absolute_priority(%d); using default priority" 1684 " instead%n", [F/A, N]), 1685 getval(chr_priority, Prio) 1686 ). 1687 1688 1689second_member([Nth-I1|Is], I, N) ?- 1690 I == I1 -> N = Nth ; second_member(Is, I, N). 1691 1692chr_constraint_info([chrcinfo with [spec:CSpec0,prio:P0,count:N0]|_], 1693 CSpec, N, P) :- 1694 CSpec0 == CSpec, !, 1695 N0 = N, P0 = P. 1696chr_constraint_info([_|CInfos], CSpec, N, P) :- 1697 chr_constraint_info(CInfos, CSpec, N, P). 1698 1699 1700nth_member(Nth, [chrcinfo with [count:N, spec:F0/A0]|Constraints], F/A) :- 1701 (Nth == N -> F = F0, A0 = A ; nth_member(Nth, Constraints, F/A)). 1702 1703 1704initialise_module_for_chr(Module) :- 1705 % "global" (to chr in Module) chr constraint list. Note needs to 1706 % be initialised to empty list when used. 1707 local(reference('CHRcstore', 0))@Module, 1708 1709 1710 % the following probably should not use the index database and should be 1711 % module-based; but this update minimise code changes Kish 2002-11-20 1712 1713 % count of number of chr constraints 1714 % remove any existing count (may be there as Module erased 1715 (erase('CHRconst_count', count(Module, _)) -> true ; true), 1716 recorda('CHRconst_count', count(Module,0)), 1717 1718 % count of number of propagation rules 1719 (erase('CHRprule_count', count(Module, _)) -> true ; true), 1720 recorda('CHRprule_count', count(Module,0)), 1721 1722 local(record('CHRcode'))@Module, local(record('CHRconstraints'))@Module, 1723 1724 % define a finalization goal for Module that make sure any stray record 1725 % for Module in the ech module is properly removed. 1726 local(finalization(( 1727 ( current_module(ech) -> % may be erased! 1728 (erase('CHRconst_count', count(Module,_))@ech->true;true) 1729 ; 1730 true % nothing to be done if ech erased 1731 ) 1732 )) 1733 )@Module. 1734 1735redefine_cdelete_count(Error, Culprit, Module, LM) :- 1736 (Culprit = local(array('CHRcdelete_count'(_N), integer)) -> 1737 true % allow silent update 1738 ; error(default(Error), Culprit, Module)@LM 1739 ). 1740 1741 1742 1743% allow cdelete_count to be redefined silently. 1744:- set_event_handler(42, redefine_cdelete_count/4). 1745 1746 1747instantiate_list([], _) :- !. 1748instantiate_list([E|L], E) :- 1749 instantiate_list(L, E). 1750 1751 1752/* split_list(+N, +List, -Front, -Back) 1753 splits the list List such that Front will contain the first Nth elements, 1754 and Back the rest 1755*/ 1756split_list(0, List, [], List) :- !. 1757split_list(N, [E|L], [E|Front], Back) :- 1758 N1 is N - 1, 1759 split_list(N1, L, Front, Back). 1760 1761 1762%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1763 1764/* find_partner(+SuspL, -PartnerIndex, +Partner, -RestL, -Condition) 1765 checks the list of suspended constraint SuspL to try to find one that 1766 matches Partner. PartnerIndex is the internal suspension index 1767 associated with the constraint. RestL is the remaining items on the 1768 SuspL after Partner is found. 1769 1770 In the old find_partner/5, Condition returns either yes or no 1771 depending on if Partner is found or not. The predicate does not simply 1772 fail to allow the CHR program to collect information. This information 1773 is not currently used, so the code is commented out 1774 1775find_partner([SIndex|Rest], SIndex, Constraint, Rest, yes) :- 1776 get_suspension_data(SIndex, goal, Suspended), 1777 % need to extract constraint from the meta-info surrounding it 1778 arg(constraint_in_wrapper_pos,Suspended,Constraint). 1779find_partner([_|Rest], SIndex, Constraint, RestL, Cond) :- 1780 find_partner(Rest, SIndex, Constraint, RestL, Cond). 1781find_partner([], _, _, _, no). 1782 1783*/ 1784/* find_parnter(+,-,-,-) */ 1785find_partner([SIndex|Rest], SIndex, Constraint, Rest) :- 1786 get_suspension_data(SIndex, goal, Suspended), 1787 % need to extract constraint from the meta-info surrounding it 1788 arg(constraint_in_wrapper_pos,Suspended,Constraint). 1789find_partner([_|Rest], SIndex, Constraint, RestL) :- 1790 find_partner(Rest, SIndex, Constraint, RestL). 1791 1792 1793/* get_global_constraint(+Const, -SuspL, +Module) 1794 get the global constraint list SuspL for constraint number Const 1795*/ 1796get_global_constraint(Const, SuspL, Module) :- 1797 getval_body('CHRcstore', Store, Module), 1798 (Store \== 0 -> arg(Const, Store, SuspL) ; SuspL = []). 1799 1800 1801 1802% list is terminated by a variable. Find it 1803find_tail(Tail, Tail0) :- 1804 var(Tail), !, Tail0 = Tail. 1805find_tail([_|Rest], Tail) :- 1806 find_tail(Rest, Tail). 1807 1808pretty_write(Term) :- writeln(Term). 1809 1810count_dead([], L,L, D,D) :- !. 1811count_dead([S|Ss], L0, L, D0, D) :- 1812 (is_suspension(S) -> D1 = D0 ; D1 is D0 + 1), 1813 L1 is L0 + 1, 1814 count_dead(Ss, L1, L, D1, D). 1815 1816/* get_constraint_list(?Vars, +ConstNo, -SuspL, +Module) 1817 returns the list of suspended constraints for constraint ConstNo in SuspL. 1818 The list is either those that are suspended on Vars, or the global list, 1819 if none of the variables in Vars remain free. 1820*/ 1821get_constraint_list(Vars, ConstNo, SuspL, Module) :- 1822 nonground(Vars, Var) -> 1823 get_varconstraint(Var, ConstNo, SuspL, Module) 1824 1825 ; get_globalconstraint(ConstNo, SuspL, Module). 1826 1827get_constraint_listi(Vars, ConstNo, SuspL, Cond, Module) :- 1828 nonground(Vars, Var) -> 1829 Cond = var, 1830 get_varconstraint(Var, ConstNo, SuspL, Module) 1831 1832 ; get_globalconstraint(ConstNo, SuspL, Module). 1833 1834/*set_varconstraint(_X{ech:Attr}, ConstNo, SuspL) ?- 1835 setarg(ConstNo, Attr, SuspL). 1836*/ 1837 1838set_varconstraint(_X{ech:Attr}, ConstNo, SuspL) ?- 1839 Attr = ech with [slists: Ss], 1840 setarg(ConstNo, Ss, SuspL). 1841 1842get_wholevarconstraint(X{ech:Attr0}, Attr, Module) ?- 1843 nonvar(Attr0), !, 1844 Attr = Attr0, 1845 get_wholevarconstraint1(X, Attr, Module). 1846get_wholevarconstraint(X, Attr, Module) :- 1847 var(X), 1848 new_chr_attr(X, Attr, Module). 1849/*NOCOUNT 1850get_wholevarconstraint1(_X, SuspSt, Module) :- 1851 var(SuspSt) -> new_cstore(SuspSt, Module); true. 1852*/ 1853get_wholevarconstraint1(_X, ech with [slists: SuspSt,count:C], Module) :- 1854 var(SuspSt) -> new_cstore(SuspSt, Module), C = 0; true. 1855 1856 1857get_varconstraint(X{ech:Attr}, ConstNo, SuspL, Module) ?- 1858 nonvar(Attr), !, 1859 get_varconstraint1(X, ConstNo, SuspL, Attr, Module). 1860get_varconstraint(X, _ConstNo, SuspL, Module) :- 1861 var(X), 1862 SuspL = [], 1863 new_chr_attr(X, _Attr, Module). 1864 1865get_varconstraint1(X, _, SuspL, Attr, Module) :- 1866 var(Attr), 1867 SuspL = [], 1868 new_chr_attr(X, Attr, Module). 1869/*get_varconstraint1(_X, ConstNo, SuspL, Attr, _Module) :- 1870 arg(ConstNo, Attr, SuspL). 1871NOCOUNT*/ 1872get_varconstraint1(_X, ConstNo, SuspL, Attr, Module) :- 1873 nonvar(Attr), 1874 Attr = ech with [slists: Ss,count:C], 1875 (var(Ss) -> new_cstore(Ss, Module), C = 0, SuspL = [] ; 1876 arg(ConstNo, Ss, SuspL0), 1877 (C == 10 -> remove_dead_suspensions(SuspL0, SuspL), 1878 setarg(ConstNo, Ss, SuspL), setarg(count of ech, Attr, 0) 1879 ; SuspL = SuspL0, C1 is C + 1, 1880 setarg(count of ech, Attr, C1) 1881 ) 1882 ). 1883 1884get_globalconstraint(ConstNo, SuspL, Module) :- 1885 getval_body('CHRcstore', Store, Module), 1886 % Store == 0 if uninitialised. 1887 (Store \== 0 -> arg(ConstNo, Store, SuspL) ; SuspL = []). 1888 1889 1890new_chr_attr(X, Attr, Module) :- % make a new chr-variable 1891 Attr = ech with [slists: Ss,count: 0], 1892 new_cstore(Ss, Module), add_attribute(X, Attr). 1893/*NOCOUNT 1894new_chr_attr(X, Attr, Module) :- 1895 new_cstore(Attr, Module), add_attribute(X, Attr). 1896*/ 1897 1898new_cstore(Ss, Module) :- 1899 call(number_of_constraints(Size))@Module, % dependent on chr prog. Need to be supplied 1900 functor(Ss, s, Size), 1901 make_empty_lists(Size, Ss). 1902 1903 1904make_empty_lists(N, Ss) :- 1905 N == 0 -> 1906 true 1907 ; N1 is N - 1, 1908 arg(N, Ss, List), 1909 (var(List) -> List = [] ; true), 1910 make_empty_lists(N1, Ss). 1911 1912/* insert(+Constraint, +Susp, +ConstNo) 1913 insert the suspension Susp into variables in the constraint Constraint. 1914 Optimisation should be possible which variables need to be inserted, 1915 and into what list 1916*/ 1917insert(Constraint, Susp, ConstNo, Module) :- 1918 term_variables(Constraint, VarL), 1919 varsuspending(VarL, Susp, ConstNo, Module). 1920 1921 1922varsuspending([], _, _, _). 1923/*varsuspending([V|Vs], Susp, ConstNo, Module) :- 1924 insert_suspension(V, Susp, constrained of suspend, suspend), 1925 %get_wholevarconstraint(V, Attr, Module), 1926 %Attr = ech with [slists: SuspSt], 1927 get_wholevarconstraint(V, SuspSt, Module), 1928 arg(ConstNo, SuspSt, SuspL0), 1929 cleanup(SuspL0, SuspL1), 1930 setarg(ConstNo, SuspSt, [Susp|SuspL1]), 1931 varsuspending(Vs, Susp, ConstNo, Module). 1932COUNT*/ 1933varsuspending([V|Vs], Susp, ConstNo, Module) :- 1934 insert_suspension(V, Susp, constrained of suspend, suspend), 1935 get_wholevarconstraint(V, Attr, Module), 1936 Attr = ech with [slists: SuspSt], 1937 arg(ConstNo, SuspSt, SuspL0), 1938 cleanup(SuspL0, SuspL1), 1939 setarg(ConstNo, SuspSt, [Susp|SuspL1]), 1940 varsuspending(Vs, Susp, ConstNo, Module). 1941 1942 1943/* cleanup(+SuspLIn, -SuspLOut) 1944 performs some clean up (removal of dead suspensions) from SuspLIn. 1945*/ 1946cleanup(SuspL0, SuspL) :- 1947 SuspL0 = [Susp|SuspL1] -> 1948 (is_suspension(Susp) -> SuspL = SuspL0 1949 ; cleanup(SuspL1, SuspL) 1950 ) 1951 ; SuspL = SuspL0. 1952 1953 1954 1955/* suspended constraints looks like: 1956 Name(Index,ConstraintGoal,SuspIndex,ExecInfo,Applied) 1957*/ 1958suspend_constraint(ConstGoal, Constraint, ConstNo, Prio, Module) :- 1959 getval(constraint_number, N), 1960 arg(constraintnum_pos,ConstGoal,N), 1961 incval(constraint_number), 1962 arg(suspendid_pos,ConstGoal,Susp), % to be filled by suspended goal's index 1963 make_suspension(ConstGoal, Prio, Susp, Module), 1964 getval_body('CHRcstore',Store,Module), % need to add it to the global constraint store 1965 insert(Constraint, Susp, ConstNo, Module), 1966 % insert into variables' constraint store 1967 1968 % insert into global constraint store 1969 (Store == 0 -> /* constraint store not yet initialised, initialise it */ 1970 new_cstore(Store0, Module), 1971 setval_body('CHRcstore', Store0,Module), 1972 setarg(ConstNo, Store0, [Susp]) 1973 ; arg(ConstNo, Store, SuspL), setarg(ConstNo, Store, [Susp|SuspL]) 1974 ). 1975 1976kill_constraint(ListIndex, Susp, Module) :- 1977 var(Susp) -> true ; 1978 kill_suspension(Susp), 1979 getval_body('CHRcdelete_count'(ListIndex), Count, Module), 1980 (Count == cdelete_threshold -> 1981 setval_body('CHRcdelete_count'(ListIndex), 0, Module), 1982 cleanup_conlist(ListIndex, Module) 1983 ; %Count1 is Count + 1, 1984 %setval('CHRcdelete_count'(ListIndex), Count1)@Module 1985 incval_body('CHRcdelete_count'(ListIndex), Module) 1986 ). 1987 1988cleanup_conlist(ListIndex, Module) :- 1989 getval_body('CHRcstore', ConStore, Module), 1990 arg(ListIndex, ConStore, ConList), % must be already initialised 1991 remove_dead_suspensions(ConList, NewConList), 1992 setarg(ListIndex, ConStore, NewConList). 1993 1994 1995remove_dead_suspensions_count([], [], 0) :- !. 1996remove_dead_suspensions_count([Susp|ConsList0], ConsList, N) :- 1997 is_suspension(Susp) -> 1998 ConsList = [Susp|ConsList1], 1999 remove_dead_suspensions_count(ConsList0, ConsList1, N) 2000 ; remove_dead_suspensions_count(ConsList0, ConsList, N1), 2001 N is N1 + 1. 2002 2003 2004remove_dead_suspensions([], []) :- !. 2005%remove_dead_suspensions(ConsList, 0, ConsList) :- !. 2006remove_dead_suspensions([Susp|ConsList0], ConsList) :- 2007 is_suspension(Susp) -> ConsList = [Susp|ConsList1], 2008 remove_dead_suspensions(ConsList0, ConsList1) 2009 ; %N1 is N - 1, 2010 remove_dead_suspensions(ConsList0, ConsList). 2011 2012 2013 2014 2015 2016/* check_pairapplied(+RuleNo, ?Applied, +PartnerIndex, -Tail, -Rest, -Status, 2017 +Module) 2018 check that propagation rule RuleNo, which has two heads, has not been 2019 applied with partner with PartnerIndex. As the applied lists are ordered, 2020 checking only needs to be done to where PartnerIndex should be in the 2021 list. Rest is the rest of the list after this position, and Tail is 2022 where the position is. This is to allow for insertion of PartnerIndex 2023 in place if rule is fired. Status returns found or notfound. 2024*/ 2025check_pairapplied(RuleNo, Applied, PartnerIndex, Tail, Rest, Status, Module) :- 2026 (nonvar(Applied) -> 2027 get_applied_list(RuleNo, Applied, AppL), 2028 AppL = [_|Rest0], 2029 check_pairapplied_direct(AppL, Rest0, PartnerIndex, Tail, Rest, Status) 2030 ; call(number_of_propagations(Size))@Module, % Need to be supplied by chr program 2031 create_applied(Applied, Size), 2032 get_applied_list(RuleNo, Applied, Tail), 2033 Rest = [], 2034 Status = notfound 2035 ). 2036 2037check_samepairapplied(RuleNo, Applied, PartnerIndex, Tail, Rest, Status, Module) :- 2038 (nonvar(Applied) -> 2039 get_applied_list(RuleNo, Applied, AppL), 2040 AppL = [_|Rest0], 2041 check_samepairapplied_direct(AppL, Rest0, PartnerIndex, Tail, Rest, Status) 2042 ; call(number_of_propagations(Size))@Module, % Need to be supplied by chr program 2043 create_applied(Applied, Size), 2044 get_applied_list(RuleNo, Applied, Tail), 2045 /* in samepairapplied, so Rest is empty list */ 2046 Rest = [], 2047 Status = notfound 2048 ). 2049 2050 2051check_pairapplied_direct(AppL, Rest0, PartnerIndex, Tail, Rest, Status) :- 2052 (Rest0 = [Index|Rest1] -> 2053 (Index \== PartnerIndex -> 2054 (Index > PartnerIndex -> /* still need to search list */ 2055 check_pairapplied_direct(Rest0, Rest1, PartnerIndex, Tail, Rest, Status) 2056 ; Tail = AppL, Rest = Rest0, Status = notfound 2057 ) 2058 ; Rest = Rest0, Tail = AppL, Status = found 2059 ) 2060 ; /* reached end of list - not found */ 2061 Tail = AppL, Rest = [], Status = notfound 2062 ). 2063 2064check_samepairapplied_direct(AppL, Rest0, PosPartnerIndex, Tail, Rest, Status) :- 2065 (Rest0 = [PosIndex|Rest1] -> 2066 (PosIndex \== PosPartnerIndex -> 2067 PosIndex = Pos-Index, PosPartnerIndex = _PPos-PartnerIndex, 2068 (Index > PartnerIndex -> /* still need to search list */ 2069 check_samepairapplied_direct(Rest0, Rest1, PosPartnerIndex, Tail, Rest, Status) 2070 ; (Index \== PartnerIndex -> Tail = AppL, Rest = Rest0, Status = notfound 2071 ; % Index == PartnerIndex, so Poses must be different 2072 % 3 --> both pos tried 2073 (Pos == 3 -> Rest = Rest0, Tail = AppL, Status = found 2074 ; % Pos = 1 or 2, not tried in PPos' position 2075 Tail = AppL, Rest = Rest0, Status = notfound 2076 ) 2077 ) 2078 ) 2079 ; % PosIndex == PosPartnerIndex 2080 Tail = AppL, Rest = Rest0, Status = found 2081 ) 2082 ; /* reached end of list - not found */ 2083 Tail = AppL, Rest = [], Status = notfound 2084 ). 2085 2086check_pairapplied_directmarked(AppL, Rest0, PartnerIndex, Tail, ConsNumber, PGoal, RuleNo, Status, Module) :- 2087 (Rest0 = [Index|Rest1] -> 2088 (Index \== PartnerIndex -> 2089 (Index > PartnerIndex -> /* still need to search list */ 2090 check_pairapplied_directmarked(Rest0, Rest1, PartnerIndex, Tail, ConsNumber, PGoal, RuleNo, Status, Module) 2091 ; % first Index < PartnerIndex, so not found and insert it 2092 Status = notfound, 2093 Tail = [PartnerIndex|Rest0], 2094 setarg(2, AppL, Tail), 2095 mark_partnerapplied(ConsNumber, PGoal, RuleNo, Module) 2096 ) 2097 ; %Index == PartnerIndex 2098 Status = found, 2099 Tail = Rest0 2100 ) 2101 ; % reached end of list - not found 2102 Status = notfound, 2103 Tail = [PartnerIndex], 2104 setarg(2, AppL, Tail), 2105 mark_partnerapplied(ConsNumber, PGoal, RuleNo, Module) 2106 ). 2107 2108mark_partnerapplied(ConsNumber, PGoal, RuleNo, Module) :- 2109 arg(applied_pos, PGoal, PApplied), 2110 (var(PApplied) -> 2111 call(number_of_propagations(Size))@Module, 2112 create_applied(PApplied, Size) 2113 ;true 2114 ), 2115 get_applied_list(RuleNo, PApplied, PartnerAppL), 2116 insert_into_partnerappliedlist(PartnerAppL, ConsNumber). 2117 2118check_samepairapplied_directmarked(AppL, Rest0, PosPartnerIndex, Tail, PosConsNumber, PGoal, RuleNo, Status, Module) :- 2119 (Rest0 = [PosIndex|Rest1] -> 2120 (PosIndex \== PosPartnerIndex -> 2121 PosIndex = Pos-Index, PosPartnerIndex = _PPos-PartnerIndex, 2122 (Index > PartnerIndex -> /* still need to search list */ 2123 check_samepairapplied_directmarked(Rest0, Rest1, PosPartnerIndex, Tail, PosConsNumber, PGoal, RuleNo, Status, Module) 2124 ; (Index \== PartnerIndex -> 2125 mark_samepartnerapplied(PosConsNumber, PGoal, RuleNo, Module), 2126 setarg(2, AppL, [PosPartnerIndex|Rest0]), 2127 Tail = Rest0, Status = notfound 2128 ; % Index == PartnerIndex, so Poses must be different 2129 % 3 --> both pos tried 2130 (Pos == 3 -> Tail = Rest0, Status = found 2131 ; % Pos = 1 or 2, not tried in PPos' position, now both tried 2132 setarg(1,PosIndex, 3), Tail = Rest0, 2133 2134 mark_samepartnerapplied(PosConsNumber, PGoal, RuleNo, Module), 2135 2136 Status = notfound 2137 ) 2138 ) 2139 ) 2140 ; % PosIndex == PosPartnerIndex 2141 Tail = Rest0, Status = found 2142 ) 2143 ; /* reached end of list - not found */ 2144 mark_samepartnerapplied(PosConsNumber, PGoal, RuleNo, Module), 2145 Tail = [PosPartnerIndex], 2146 setarg(2, AppL, Tail), Status = notfound 2147 ). 2148 2149mark_samepartnerapplied(PosConsNumber, PGoal, RuleNo, Module) :- 2150 arg(applied_pos, PGoal, PApplied), 2151 (var(PApplied) -> 2152 call(number_of_propagations(Size))@Module, 2153 create_applied(PApplied, Size) 2154 ;true 2155 ), 2156 get_applied_list(RuleNo, PApplied, PartnerAppL), 2157 insert_into_samepartnerappliedlist(PartnerAppL, PosConsNumber). 2158 2159 2160% like checkpairapplied_direct, except that Index known not to be in list, 2161% just need to find where it should be inserted. 2162find_pairappliedinsertpos(AppL, Rest0, Index, Tail, Rest) :- 2163 (Rest0 = [Index0|Rest1] -> 2164 (Index0 > Index -> /* still need to search list */ 2165 check_pairapplied_direct(Rest0, Rest1, Index, Tail, Rest, _) 2166 ; Tail = AppL, Rest = Rest0 2167 ) 2168 ; /* reached end of list - not found */ 2169 Tail = AppL, Rest = [] 2170 ). 2171 2172/* For multiple heads not yet ready 2173check_multiapplied(RuleNo, Applied, Partners, Tail, Rest, Status, Module) :- 2174 (nonvar(Applied) -> 2175 get_applied_list(RuleNo, Applied, AppL), 2176 check_applied_direct(AppL, Partners, Tail, Rest, Status) 2177 ; call(number_of_propagations(Size))@Module, % Need to be supplied by chr program 2178 create_applied(Applied, Size), 2179 arg(RuleNo, Applied, Tail), 2180 Rest = [], 2181 Status = notfound 2182 ). 2183%%%%%%%%%%%% write rest of code later. 2184*/ 2185 2186 2187insert_pairapplied(PConsNumber, Tail, Rest, ConsNumber, PGoal, RuleNo, Module) :- 2188 setarg(2, Tail, [PConsNumber|Rest]), 2189 arg(applied_pos, PGoal, PApplied), 2190 (var(PApplied) -> 2191 call(number_of_propagations(Size))@Module, 2192 create_applied(PApplied, Size) 2193 ;true 2194 ), 2195 get_applied_list(RuleNo, PApplied, PartnerAppL), 2196 insert_into_partnerappliedlist(PartnerAppL, ConsNumber). 2197 2198insert_samepairapplied(PosPConsNumber, Tail, Rest, PosConsNumber, PGoal, RuleNo, Module) :- 2199 insert_samepair_atpos(PosPConsNumber, Tail, Rest), 2200 arg(applied_pos, PGoal, PApplied), 2201 (var(PApplied) -> 2202 call(number_of_propagations(Size))@Module, 2203 create_applied(PApplied, Size) 2204 ;true 2205 ), 2206 get_applied_list(RuleNo, PApplied, PartnerAppL), 2207 insert_into_samepartnerappliedlist(PartnerAppL, PosConsNumber). 2208 2209insert_samepair_atpos(PosPConsNumber, Tail, Rest) :- 2210 (Rest = [PosNum|_] -> 2211 PosPConsNumber = _Pos-PConsNumber, 2212 (PosNum = _-PConsNumber -> 2213 % same PConsNumber, must have tried both positions, so set Pos to 3 2214 setarg(1, PosNum, 3) 2215 ; % not same PConsNumber... 2216 setarg(2, Tail, [PosPConsNumber|Rest]) 2217 ) 2218 ; % Rest is empty list 2219 setarg(2, Tail, [PosPConsNumber]) 2220 ). 2221 2222insert_into_partnerappliedlist(PAppL, ConsNum) :- 2223 PAppL = [_|Rest0], 2224 find_pairappliedinsertpos(PAppL, Rest0, ConsNum, Tail, Rest), 2225 setarg(2, Tail, [ConsNum|Rest]). 2226 2227insert_into_samepartnerappliedlist(PAppL, PosPConsNum) :- 2228 PAppL = [_|Rest0], 2229 check_samepairapplied_direct(PAppL, Rest0, PosPConsNum, Tail, Rest, _S), 2230 % defensive check, comment out for max. speed 2231 %(_S == found -> writeln('ECKKKKKK....');true), 2232 insert_samepair_atpos(PosPConsNum, Tail, Rest). 2233 2234 2235add_applied(PartnersNo, Tail) :- 2236 (nonvar(Tail) -> 2237 Tail = [_|Ns], 2238 NewTail = [PartnersNo|Ns], 2239 setarg(2,Tail,NewTail) 2240 ; Tail = [PartnersNo] 2241 ). 2242 2243create_applied(Applied, Size) :- 2244 functor(Applied, a, Size). 2245 2246get_applied_list(N, Applied, List) :- 2247 arg(N, Applied, List), 2248 (var(List) -> List = [1.0Inf] ; true). 2249 2250 2251% Fix for bug 491: when unifying two ech-variables, we wake one (arbitary) 2252% variable's slists. This will cause multi-head rules to fire which, as a 2253% result of the unification, now have the necessary shared head variables. 2254% This is necessary because since release 5.8 not all suspensions in the 2255% constrained-lists are woken on var-var unifications (only those that the 2256% vars have in common). Waking a single variable's lists should be 2257% sufficient because either head-partner constraint can find the other. 2258 2259% unify_ech(+Term, Attribute) 2260unify_ech(_, Attr) :- 2261 var(Attr), !. 2262% Fix for bug#745, Kish 2013-02-14 - the ech suspension lists needs to be 2263% inherited by any variables in the compound term. 2264unify_ech(Term, Attr) :- 2265 compound(Term), !, 2266 arg(slists of ech, Attr, CStore), 2267 term_variables(Term, Vars), 2268 ( Vars = [] -> 2269 true 2270 ; 2271 arity(CStore, Size), 2272 (foreach(V, Vars), param(CStore, Size) do 2273 add_chrstore_to_var(V, CStore, Size) 2274 ) 2275 ). 2276unify_ech(Term, _) :- 2277 atomic(Term), !. 2278unify_ech(Term{ech:Attr0}, Attr1) ?- 2279 (nonvar(Attr0) -> 2280 /* Term is var, there are chr attributes for both variables */ 2281 arg(slists of ech, Attr0, CStore0), 2282 arg(slists of ech, Attr1, CStore1), 2283 chrstore_merge_and_schedule(CStore0, CStore1) 2284 ; 2285 /* Term does not have chr attribute, just add it in */ 2286 add_attribute(Term, Attr) 2287 ). 2288 2289 2290chrstore_merge_and_schedule(CS0, CS1) :- 2291 functor(CS0, F, A), 2292 functor(CS1, F, A), 2293 % merge the lists from Attr1 into Attr0 2294 chrstore_merge_and_schedule(A, CS0, CS1). 2295 2296chrstore_merge_and_schedule(0, _, _) :- !. 2297chrstore_merge_and_schedule(N, CS0, CS1) :- 2298 schedule_suspensions(N, CS0), % schedule either CS0 or CS1 here 2299 merge_one_slist(N, CS0, CS1), 2300 N1 is N - 1, 2301 chrstore_merge_and_schedule(N1, CS0, CS1). 2302 2303chrstore_merge(0, _, _) :- !. 2304chrstore_merge(N, CS0, CS1) :- 2305 merge_one_slist(N, CS0, CS1), 2306 N1 is N - 1, 2307 chrstore_merge(N1, CS0, CS1). 2308 2309merge_one_slist(N, CS0, CS1) :- 2310 arg(N, CS0, List0), 2311 arg(N, CS1, List1), 2312 ordered_merge(List0, List1, List), 2313 setarg(N, CS0, List). 2314 2315ordered_merge([], L, L) :- !. 2316ordered_merge(L, [], L) :- !. 2317ordered_merge(L0, L1, L) :- 2318 L0 = [SIndex0|L00], 2319 L1 = [SIndex1|L11], 2320 (get_suspension_data(SIndex0, goal, G0) -> 2321 (get_suspension_data(SIndex1, goal, G1) -> 2322 arg(constraintnum_pos, G0, CN0), 2323 arg(constraintnum_pos, G1, CN1), 2324 (CN0 =:= CN1 -> 2325 L = [SIndex0|L2], % identical, throw one away 2326 ordered_merge(L00, L11, L2) 2327 ;CN0 > CN1 -> 2328 L = [SIndex0|L2], 2329 ordered_merge(L00, L1, L2) 2330 ; % CN1 > CN0 2331 L = [SIndex1|L2], 2332 ordered_merge(L0, L11, L2) 2333 ) 2334 ; ordered_merge(L0, L11, L) % throw away dead suspension 2335 ) 2336 ; ordered_merge(L00, L1, L) % throw away dead suspension 2337 2338 ). 2339 2340 2341/* add an existing chrstore from one variable to another variable */ 2342add_chrstore_to_var(V{Attr1}, Cs, Size) ?- !, 2343 (nonvar(Attr1) -> 2344 % already a CHR module, merge stores 2345 arg(slists of ech, Attr1, Cs1), 2346 arity(Cs1, Size), 2347 chrstore_merge(Size, Cs1, Cs) 2348 ; 2349 % new CHR variable, copy store 2350 duplicate_cstore(Attr, Cs, Size) 2351 ). 2352add_chrstore_to_var(V, Cs, Size) :- 2353 free(V), 2354 duplicate_cstore(Attr, Cs, Size), 2355 add_attribute(V, Attr). 2356 2357duplicate_cstore(NewAttr, OldCs, Size) :- 2358 NewAttr = ech{slists: NewCs, count:0}, 2359 functor(OldCs, Name, Size), 2360 functor(NewCs, Name, Size), 2361 (foreacharg(OldL, OldCs), foreacharg(NewL, NewCs) do 2362 (foreach(S, OldL), fromto(NewL, NL1,NL2, []) do 2363 % copy and also clean up lists 2364 (is_suspension(S) -> NL1 = [S|NL2] ; NL1 = NL2) 2365 ) 2366 ). 2367 2368chr_clear :- 2369 recorded_list('CHRconst_count', CCountL), 2370 erase_all('CHRconst_count'), 2371 erase_all('CHRprule_count'), 2372 erase_all('CHRadding_code'), 2373 setval(constraint_number, 0), 2374 clean_each_module(CCountL). 2375 2376clean_each_module([]) :- !. 2377clean_each_module([count(Module,_)|L]) :- 2378 erase_all('CHRcode')@Module, 2379 erase_all('CHRconstraints')@Module, 2380 % get around bug b91: reset the store so a new store will not inherit 2381 % incorrect value 2382 setval_body('CHRcstore', 0, Module), 2383 erase_array('CHRcstore')@Module, 2384 clean_each_module(L). 2385 2386 2387is_in_store([CIndex|L], NewCon) :- 2388 (get_suspension_data(CIndex, goal, CGoal) -> 2389 arg(constraint_in_wrapper_pos, CGoal, Con), 2390 (Con == NewCon -> true ; is_in_store(L, NewCon) ) 2391 ; is_in_store(L, NewCon) 2392 ). 2393 2394 2395multi_append(Lists, Appended) :- 2396 multi_append1(Lists, [], Appended). 2397 2398multi_append1([], List0, List1) ?- !, List0 = List1. 2399multi_append1([List|Ls], App1, Appended) ?- 2400 nonvar(List), 2401 append(List, App1, App2), 2402 multi_append1(Ls, App2, Appended). 2403 2404 2405chr_get_gconstraint(Constraint, Module) :- 2406 (nonvar(Constraint) -> 2407 recorded_list('CHRconstraints', ConList)@Module, 2408 functor(Constraint, F, A), 2409 chr_constraint_info(ConList, F/A, ConsNo, _), 2410 get_global_constraint(ConsNo, SuspL, Module), 2411 matching_constraint(SuspL, Constraint, CIndex) 2412 ; getval_body('CHRcstore', Store, Module), 2413 functor(Store, _, Size), 2414 get_all_sconstraints(Size, Store, Constraint, ConsNo, CIndex) 2415 ), 2416 kill_constraint(ConsNo, CIndex, Module). 2417 2418get_all_sconstraints(0, _, _, _, _) :- !, fail. 2419get_all_sconstraints(N, Store, Constraint, N, CIndex) :- 2420 arg(N, Store, SuspL), 2421 matching_constraint(SuspL, Constraint, CIndex). 2422get_all_sconstraints(N, Store, Constraint, CurrentN, CIndex) :- 2423 N1 is N - 1, 2424 get_all_sconstraints(N1, Store, Constraint, CurrentN, CIndex). 2425 2426matching_constraint([CIndex0|_], Constraint, CIndex) :- 2427 get_suspension_data(CIndex0, goal, CGoal), 2428 arg(constraint_in_wrapper_pos, CGoal, Constraint), 2429 CIndex = CIndex0. 2430matching_constraint([_|L], Constraint, CIndex) :- 2431 matching_constraint(L, Constraint, CIndex). 2432 2433 2434chr_get_vconstraint(_V{ech:Attr}, Constraint, Module) ?- 2435 nonvar(Attr), 2436 Attr = ech with [slists:Ss], 2437 nonvar(Ss), 2438 (nonvar(Constraint) -> 2439 recorded_list('CHRconstraints', ConList)@Module, 2440 functor(Constraint, F, A), 2441 chr_constraint_info(ConList, F/A, ConsNo, _), 2442 arg(ConsNo, Ss, SuspL), 2443 matching_constraint(SuspL, Constraint, CIndex) 2444 ; functor(Ss, _, Size), 2445 get_all_sconstraints(Size, Ss, Constraint, ConsNo, CIndex) 2446 ), 2447 kill_constraint(ConsNo, CIndex, Module). 2448 2449 2450in_chrstore(Constraint, Module) :- 2451 recorded_list('CHRconstraints', ConList)@Module, 2452 functor(Constraint, F, A), 2453 chr_constraint_info(ConList, F/A, ConsNo, _), 2454 get_global_constraint(ConsNo, SuspL, Module), 2455 is_in_store(SuspL, Constraint). 2456 2457option(default_chr_priority, Prio, _) ?- !, 2458 (integer(Prio), 2459 Prio > 0, 2460 Prio < 12 -> 2461 setval(chr_priority, Prio), 2462 printf(log_output, "Changed default chr priority to %d%n", 2463 [Prio]) 2464 ; 2465 printf(error, "Invalid chr priority: %d. Priority is uncahnged." 2466 "%n", [Prio]) 2467 ). 2468option(Option, State, Module) :- 2469 is_valid_option(Option, OptionName) -> 2470 may_erase(OptionName, Module), 2471 update_option(State, OptionName, Module) 2472 ; printf(error, "'%w' is not a valid option.\n", [Option]). 2473 2474update_option(on, _OptionName, _Module) ?- !. 2475update_option(off, OptionName, Module) ?- !, 2476 recorda(OptionName, Module). 2477update_option(State, _, _) :- 2478 printf(error, "'%w' is an invalid state for options.\n",[State]). 2479 2480is_valid_option(check_guard_bindings, 'CHRdont_guard_bindings'). 2481is_valid_option(already_in_store, 'CHRdont_in_store'). 2482is_valid_option(single_symmetric_simpagation, 'CHRdont_simpa_symmetric'). 2483 2484may_erase(Key, Value) :- 2485 erase(Key, Value), !. 2486may_erase(_, _). 2487 2488%----------------------------------------------------------------------- 2489 2490:- comment(categories, ["Constraints","Techniques"]). 2491:- comment(summary, "Extended constraint handling rules library"). 2492 2493:- comment(desc, html("\ 2494 This library allows the user to write constraint handling rules (CHR) in 2495 their ECLiPSe programs. CHR is a high-level language extension for writing 2496 user-defined constraints, allowing for rapid prototyping of constraints. 2497<P> 2498 This library provides some extensions over the older chr library: 2499<UL> 2500 <LI> support for multi (>2) headed simplification and simpagation rules 2501 2502 <LI> cleanup of semantics and syntax of CHRs 2503 2504 <LI> faster execution 2505 2506 <LI> more convenient compilation and mixing with ECLiPSe code 2507</UL> 2508 CHRs are compiled by source-to-source transformation into ECLiPSe code that 2509 make calls to many ech library predicates that implements the CHR 2510 functionality. Thus, most exported predicates predicates are not intended 2511 to be used by the user directly, and are not documented. 2512")). 2513 2514:- comment((constraints)/1, [ 2515 summary: "Directive for declaring SpecList to be CHR constraints", 2516 amode: constraints(+), 2517 args: ["SpecList": "Sequence of the form Atom/Integer, or Atom/Integer:PrioSpec"], 2518 eg: "\ 2519 :- constraints leq/2. 2520 :- op(700, xfx, leq). 2521 2522 X leq Y <=> \\+nonground(X), \\+nonground(Y) | X @=< Y. 2523 X leq X <=> true. 2524", 2525 desc: html("\ 2526 Declares the predicates specified in SpecList as CHR constraints. This 2527 allows the predicate to appear in the head of a CHR rule. A constraint 2528 can be follwed by a priority specification PrioSpec, which can be one of: 2529<P> 2530 1. at_lower(++N) 2. at_higher(++N) 3. at_absolute_priority(++N) 2531<P> 2532 where N is an integer. This specifies the priority the CHR rules will be 2533 executed at if the specified constraint is the active constraint. 2534 at_lower and at_higher specifies that the priority is N lower or higher 2535 than the default CHR priority, and for at_absolute_priority, it is the 2536 actual priority. 2537<P> 2538 Note that a predicate declared as a CHR constraint should not appear as 2539 a normal ECLiPSe predicate. Any such definition of the predicate in the 2540 user's program would be replaced by the CHR definition. 2541")] 2542). 2543 2544:- comment(in_chrstore/1, [ 2545 summary: "Test if CHRConst is in the CHR constraint store or not", 2546 amode: in_chrstore(+), 2547 args: ["CHRConst": "A CHR constraint"], 2548 eg: "\ 2549 X leq Y, Y leq Z ==> \\+in_chrstore(X leq Z)| X leq Z. 2550", 2551 desc: html("\ 2552 This predicate is used to test if a particular CHR constraint is in the 2553 CHR constraint store or not. It can be used to prevent the addition of 2554 redundant constraints. This only useful if the 'already_in_store' 2555 option is off. 2556")] 2557). 2558 2559:- comment(option/2, [ 2560 summary: "Specify options for controlling ech compilation", 2561 amode: option(++,++), 2562 args: ["Option": "Option Name (Atom)", 2563 "On_or_Off": "If Option should be on ('on') or off ('off')," 2564 " or an integer between 1 and 11" 2565 ], 2566 desc: html("\ 2567 Allows the user to set options that affect the way the CHRs are compiled. 2568 These options can be turned on or off, with the default state being on. 2569 The options controls if certain run-time safety checks are performed or 2570 not. With the option off, the associated safety check will not be generated 2571 for the CHR code when compiled. Such code can run more efficiently, but 2572 can lead to incorrect behaviour that the checks would have been able to 2573 prevent. 2574 2575<DL> 2576 <DT>check_guard_bindings 2577 <DD> When executing a guard in a CHR rule, checks are performed 2578 so that if a guard goal attemps to touch a global variable (i.e. a 2579 variable which occurs in the rule head), the guard will fail. With 2580 this option set to `off', then the checks are not performed. 2581 2582 <DT>already_in_store 2583 <DD> Before adding a user-defined CHR constraint to the constraint 2584 store, a check is performed to see if the particular constraint 2585 (i.e. with exactly the same variables) is already in the store. 2586 If this option is set to `off', then the check is not performed. 2587 The user can explicitly check if a constraint is in store by the 2588 in_chrstore/1 predicate. 2589 2590 <DT>chr_priority 2591 <DD> On_or_Off is an integer between 1 and 11, specifying the 2592 default priority for CHR constraints generated by the compiler. 2593 It also specifies the priority that at_lower/at_higher 2594 declarations will be calculated from in the constraints/1 2595 declarations. Note that all priorities are determined at the 2596 point of the constraint declaration and is not affected by any 2597 subsequent changes in chr_priority. 2598 2599</DL> 2600") 2601]). 2602 2603