26
27:- module(clpBNR, 28 [
29 op(700, xfx, ::),
30 (::)/2, 31 {}/1, 32 interval/1, 33 interval_degree/2, 34 list/1, 35 domain/2, range/2, 36 delta/2, 37 midpoint/2, 38 median/2, 39 lower_bound/1, 40 upper_bound/1, 41
42 43 op(200, fy, ~), 44 op(500, yfx, and), 45 op(500, yfx, or), 46 op(500, yfx, nand), 47 op(500, yfx, nor), 48 49 op(700, xfx, <>), 50 op(700, xfx, <=), 51
52 53 print_interval/1, print_interval/2, 54 small/1, small/2, 55 solve/1, solve/2, 56 splitsolve/1, splitsolve/2, 57 absolve/1, absolve/2, 58 enumerate/1, 59 global_minimum/2, 60 global_minimum/3, 61 global_maximum/2, 62 global_maximum/3, 63 global_minimize/2, 64 global_minimize/3, 65 global_maximize/2, 66 global_maximize/3, 67 nb_setbounds/2, 68 partial_derivative/3, 69 clpStatistics/0, 70 clpStatistic/1, 71 clpStatistics/1, 72 watch/2, 73 trace_clpBNR/1 74 ]). 75
77
94
95version("0.11.5").
96
98:- if(exists_source(swish(lib/swish_debug))). 99 :- create_prolog_flag(clpBNR_swish, true, [access(read_only)]). 100 :- use_module(swish(lib/swish_debug)). 101:- else. 102 :- use_module(library(debug)). 103:- endif. 104
105:- use_module(library(prolog_versions)). 106
107:- require_prolog_version('9.1.22', 108 [ rational 109 ]). 110
114set_optimize_flags_ :- 115 set_prolog_flag(optimise,true), 116 current_prolog_flag(optimise_debug,ODflag), 117 nb_linkval('$optimise_debug_save',ODflag),
118 set_prolog_flag(optimise_debug,false). 119
120restore_optimize_flags_ :- 121 nb_getval('$optimise_debug_save',ODflag), nb_delete('$optimise_debug_save'),
122 set_prolog_flag(optimise_debug,ODflag).
123
124:- set_optimize_flags_. 125
127debug_clpBNR_(FString,Args) :- debug(clpBNR,FString,Args).
128
130:- multifile(sandbox:safe_prolog_flag/1). 131:- multifile(sandbox:safe_global_variable/1). 132:- multifile(sandbox:safe_primitive/1). 133:- multifile(sandbox:safe_meta/2). 134
135current_node_(Node) :- 136 prolog_current_frame(Frame), 137 prolog_frame_attribute(Frame,parent_goal,doNode_(Args,Op,_,_,_,_,_)),
138 map_constraint_op_(Op,Args,Node),
139 !.
140
141sandbox:safe_primitive(clpBNR:current_node_(_Node)).
142
146
148g_assign(G,V) :- nb_linkval(G,V).
149g_inc(G) :- nb_getval(G,N), N1 is N+1, nb_linkval(G,N1).
150g_incb(G) :- nb_getval(G,N), N1 is N+1, b_setval(G,N1). 151g_read(G,V) :- nb_getval(G,V).
152
153sandbox:safe_global_variable('clpBNR:thread_init_done').
154sandbox:safe_global_variable('clpBNR:userTime').
155sandbox:safe_global_variable('clpBNR:inferences').
156sandbox:safe_global_variable('clpBNR:gc_time').
157
164user:exception(undefined_global_variable,'clpBNR:thread_init_done',retry) :- !,
165 set_prolog_flags, 166 clpStatistics, 167 g_assign('clpBNR:thread_init_done',1).
168
172:- create_prolog_flag(clpBNR_iteration_limit,3000,[type(integer),keep(true)]). 173:- create_prolog_flag(clpBNR_default_precision,6,[type(integer),keep(true)]). 174:- create_prolog_flag(clpBNR_verbose,false,[type(boolean),keep(true)]). 175
176sandbox:safe_prolog_flag(clpBNR_iteration_limit,_).
177sandbox:safe_prolog_flag(clpBNR_default_precision,_).
178sandbox:safe_prolog_flag(clpBNR_verbose,_).
182set_prolog_flags :-
183 set_prolog_flag(prefer_rationals, true), 184 (current_prolog_flag(max_rational_size,_)
185 -> true 186 ; set_prolog_flag(max_rational_size, 16) 187 ),
188 set_prolog_flag(max_rational_size_action, float), 189
190 set_prolog_flag(float_overflow,infinity), 191 set_prolog_flag(float_zero_div,infinity),
192 set_prolog_flag(float_undefined,nan),
193 set_prolog_flag(write_attributes,portray). 194
195:- discontiguous clpBNR:clpStatistics/0, clpBNR:clpStatistic/1. 196
197clpStatistics :-
198 199 statistics(cputime,T), g_assign('clpBNR:userTime',T), 200 statistics(inferences,I), g_assign('clpBNR:inferences',I),
201 statistics(garbage_collection,[_,_,G,_]), g_assign('clpBNR:gc_time',G),
202 fail. 203
204clpStatistic(_) :- g_read('clpBNR:thread_init_done',0). 205
206clpStatistic(userTime(T)) :- statistics(cputime,T1), g_read('clpBNR:userTime',T0), T is T1-T0.
207
208clpStatistic(gcTime(G)) :- statistics(garbage_collection,[_,_,G1,_]), g_read('clpBNR:gc_time',G0), G is (G1-G0)/1000.0.
209
210clpStatistic(globalStack(U/T)) :- statistics(globalused,U), statistics(global,T).
211
212clpStatistic(trailStack(U/T)) :- statistics(trailused,U), statistics(trail,T).
213
214clpStatistic(localStack(U/T)) :- statistics(localused,U), statistics(local,T).
215
216clpStatistic(inferences(I)) :- statistics(inferences,I1), g_read('clpBNR:inferences',I0), I is I1-I0.
217
222list(X) :- compound(X) -> X=[_|_] ; X==[].
223
224:- include(clpBNR/ia_primitives). 225
238interval(Int) :- get_attr(Int, clpBNR, _).
239
243interval_degree(X, N) :-
244 interval_object(X, _, _, Nodelist)
245 -> system:'$skip_list'(N, Nodelist, _) 246 ; number(X), N = 0. 247
249interval_object(Int, Type, Val, Nodelist) :-
250 get_attr(Int, clpBNR, interval(Type, Val, Nodelist, _)).
251
253get_interval_flags_(Int, Flags) :-
254 get_attr(Int, clpBNR, interval(_, _, _, Flags)).
255
256set_interval_flags_(Int, Flags) :- 257 interval_object(Int, Type, Val, Nodelist),
258 put_attr(Int, clpBNR, interval(Type, Val, Nodelist, Flags)).
259
260reset_interval_nodelist_(Int) :-
261 get_attr(Int, clpBNR, Def) -> setarg(3,Def,_) ; true.
262
266universal_interval((-1.0Inf,1.0Inf)).
267
268empty_interval((1.0Inf,-1.0Inf)).
269
271finite_interval(real, (-1.0e+16,1.0e+16)).
272finite_interval(integer, (L,H)) :-
274 current_prolog_flag(min_tagged_integer,L),
275 current_prolog_flag(max_tagged_integer,H)
275.
276finite_interval(boolean, (0,1)).
277
279integerBnd(1.0Inf).
280integerBnd(-1.0Inf).
281integerBnd(B) :- integer(B).
282
284preciseBnd(1.0Inf).
285preciseBnd(-1.0Inf).
286preciseBnd(B) :- rational(B).
287
291nb_setbounds(Int, [L,U]) :-
292 get_attr(Int, clpBNR, Def),
293 arg(2, Def, Val), 294 ^(Val,(L,U),NewVal), 295 nb_setarg(2, Def, NewVal).
296
300getValue(Int, Val) :-
301 number(Int)
302 -> Val=(Int,Int) 303 ; get_attr(Int, clpBNR, interval(_, Val, _, _)). 304
310putValue_(New, Int, NodeList) :-
311 get_attr(Int, clpBNR, Def) 312 -> (debugging(clpBNR) -> check_monitor_(Int, New, Def) ; true),
313 Def = interval(Type,_,Nodes,_), 314 New = (L,H),
315 ( 0 is cmpr(L,H) 316 -> setarg(3,Def,_NL), 317 pointValue_(L,H,Int), 318 NodeList = Nodes 319 ; setarg(2,Def,New), 320 321 (Type == integer
322 -> ( integerBnd(L), integerBnd(H) -> NodeList = Nodes ; NodeList = [node(integral,_,0,$(Int))|_] )
323 ; NodeList = Nodes
324 )
325 )
326 ; true. 327
328pointValue_(-0.0,_,0.0) :-!.
329pointValue_(L,H,Int) :- (rational(L) -> Int = L ; Int = H).
330
334range(Int, [L,H]) :- getValue(Int, (IL,IH)), !, 335 (var(L) -> L=IL ; non_empty(L,IL)), 336 (var(H) -> H=IH ; non_empty(IH,H)).
337range(Int, [L,H]) :- var(Int), 338 Int::real(L,H).
339
343domain(Int, Dom) :-
344 interval_object(Int, Type, Val, _),
345 interval_domain_(Type, Val, Dom).
346
347interval_domain_(integer,(0,1),boolean) :- !. 348interval_domain_(T,(L,H),Dom) :- Dom=..[T,L,H].
349
350:- use_module(library(arithmetic), []). 354:- arithmetic_function(delta/1). 355
356delta(Int, Wid) :-
357 getValue(Int,(L,H)),
358 Wid is roundtoward(H-L,to_positive).
359
368:- arithmetic_function(midpoint/1). 369
370midpoint(Int, Mid) :-
371 getValue(Int,(L,H)),
372 midpoint_(L,H,Mid).
373
374midpoint_(L,H,M) :- L =:= -H, !, M=0. 375midpoint_(-1.0Inf,H,M) :- !, M is nexttoward(-1.0Inf,0)/2 + H/2.
376midpoint_(L,1.0Inf,M) :- !, M is L/2 + nexttoward(1.0Inf,0)/2.
377midpoint_(L,H,M) :- M1 is L/2 + H/2, M=M1. 378
384:- arithmetic_function(median/1). 385
386median(Int, Med) :-
387 getValue(Int,(L,H)),
388 median_bound_(lo,L,FL),
389 median_bound_(hi,H,FH),
390 median_(FL,FH,Med), !.
391
392median_bound_(lo,B,FB) :- B=:=0, FB is nexttoward(B,1.0).
393median_bound_(lo,-1.0Inf,FB) :- FB is nexttoward(-1.0Inf,0.0).
394median_bound_(lo,B,FB) :- FB is roundtoward(float(B), to_negative).
395
396median_bound_(hi,B,FB) :- B=:=0, !, FB is nexttoward(B,-1.0).
397median_bound_(hi,1.0Inf,FB) :- FB is nexttoward(1.0Inf,0.0).
398median_bound_(hi,B,FB) :- FB is roundtoward(float(B), to_positive).
399
400median_(B,B,B). 401median_(L,H,0.0) :- L < 0.0, H > 0.0. 402median_(L,H,M) :- M is copysign(sqrt(abs(L))*sqrt(abs(H)),L). 403
407lower_bound(Int) :-
408 getValue(Int,(L,_H)),
409 Int=L.
410
411upper_bound(Int) :-
412 getValue(Int,(_L,H)),
413 Int=H.
414
418Rs::Dom :- list(Rs),!, 419 intervals_(Rs,Dom).
420
421R::Dom :- 422 g_read('clpBNR:thread_init_done',_), 423 (var(Dom) 424 -> (var(R) -> int_decl_(real,_,R) ; true), 425 domain(R,Dom) 426 ; Dom=..[Type|Bounds], 427 Val=..[','|Bounds],
428 int_decl_(Type,Val,R)
429 ).
430
431intervals_([],_Def).
432intervals_([Int|Ints],Def) :-
433 Int::Def, !,
434 intervals_(Ints,Def).
435
436int_decl_(boolean,_,R) :- !, 437 int_decl_(integer,(0,1),R).
438int_decl_(Type,(','),R) :- !, 439 int_decl_(Type,(_,_),R).
440int_decl_(Type,Val,R) :- interval_object(R,CType,CVal,_NL), !, 441 (Type = CType, Val = CVal 442 -> true
443 ; Val = (L,H), 444 lower_bound_val_(Type,L,IL),
445 upper_bound_val_(Type,H,IH),
446 applyType_(Type, R, T/T, Agenda), 447 ^(CVal,(IL,IH),New), 448 updateValue_(CVal, New, R, 1, Agenda, NewAgenda), 449 stable_(NewAgenda) 450 ).
451int_decl_(Type,(L,H),R) :- var(R), !, 452 lower_bound_val_(Type,L,IL),
453 upper_bound_val_(Type,H,IH),
454 C is cmpr(IL,IH), 455 (C == 0
456 -> (rational(IL) -> R=IL ; R = IH) 457 ; C == -1, 458 put_attr(R, clpBNR, interval(Type, (IL,IH), _NL, [])) 459 ).
460int_decl_(Type,(L,H),R) :- constant_type_(Type,R), 461 lower_bound_val_(Type,L,IL), non_empty(IL,R), 462 upper_bound_val_(Type,H,IH), non_empty(R,IH). 463
464lower_bound_val_(Type,L,L) :- var(L), !, 465 finite_interval(Type,(L,_)).
466lower_bound_val_(real,L,IL) :- 467 ((L == pi ; L == e)
468 -> IL is roundtoward(L,to_negative)
469 ; Lv is L,
470 (preciseBnd(Lv) -> IL=Lv ; IL is nexttoward(Lv,-1.0Inf))
471 ).
472lower_bound_val_(integer,L,IL) :- 473 IL is ceiling(L).
474lower_bound_val_(boolean,L,IL) :- 475 IL is max(0,ceiling(L)).
476
477upper_bound_val_(Type,H,H) :- var(H), !, 478 finite_interval(Type,(_,H)).
479upper_bound_val_(real,H,IH) :- 480 ((H == pi ; H == e)
481 -> IH is roundtoward(H,to_positive)
482 ; Hv is H,
483 (preciseBnd(Hv) -> IH=Hv ; IH is nexttoward(Hv,1.0Inf))
484 ).
485upper_bound_val_(integer,H,IH) :- 486 IH is floor(H).
487upper_bound_val_(boolean,H,IH) :- 488 IH is min(1,floor(H)).
489
490constant_type_(real,C) :- number(C).
491constant_type_(integer,C) :- integer(C), !.
492constant_type_(integer,C) :- float(C), float_class(C,infinite).
493
494applyType_(NewType, Int, Agenda, NewAgenda) :- 495 get_attr(Int,clpBNR,interval(Type,Val,NodeList,Flags)),
496 (NewType @< Type 497 -> (debugging(clpBNR) -> check_monitor_(Int, NewType, interval(Type,Val,NodeList,Flags)) ; true),
498 Val = (L,H),
499 lower_bound_val_(NewType,L,IL),
500 upper_bound_val_(NewType,H,IH),
501 (IL=IH
502 -> Int=IL 503 ; (put_attr(Int,clpBNR,interval(integer,(IL,IH),NodeList,Flags)), 504 linkNodeList_(NodeList, Agenda, NewAgenda)
505 )
506 )
507 ; NewAgenda = Agenda
508 ).
509
513attr_unify_hook(IntDef, Num) :- 514 number(Num),
515 IntDef = interval(Type,(L,H),Nodelist,_Flags),
516 constant_type_(Type,Num), 517 518 cmpr(L,Num) + cmpr(Num,H) < 0, !, 519 (debugging(clpBNR) -> monitor_unify_(IntDef, Num) ; true),
520 (var(Nodelist)
521 -> true 522 ; linkNodeList_(Nodelist, T/T, Agenda),
523 stable_(Agenda) 524 ).
525
526attr_unify_hook(interval(Type1,V1,Nodelist1,Flags1), Int) :- 527 get_attr(Int, clpBNR, interval(Type2,V2,Nodelist2,Flags2)), 528 ^(V1,V2,R), 529 mergeValues_(Type1, Type2, NewType, R, NewR), !,
530 mergeNodes_(Nodelist2,Nodelist1,Newlist), 531 mergeFlags_(Flags1,Flags2,Flags),
532 (debugging(clpBNR) -> monitor_unify_(interval(Type1,V1,_,Flags), Int) ; true),
533 534 put_attr(Int,clpBNR,interval(NewType,NewR,Newlist,Flags)),
535 (var(Newlist)
536 -> true 537 ; linkNodeList_(Newlist, T/T, Agenda),
538 stable_(Agenda) 539 ).
540
541attr_unify_hook(interval(Type,Val,_Nodelist,_Flags), V) :- 542 g_inc('clpBNR:evalNodeFail'), 543 debugging(clpBNR), 544 debug_clpBNR_('Failed to unify ~w::(~w) with ~w',[Type,Val,V]),
545 fail.
546
548monitor_unify_(IntDef, Update) :- 549 put_attr(Temp,clpBNR,IntDef),
550 check_monitor_(Temp, Update, IntDef).
551
554mergeValues_(T, T, T, R, R) :- !.
555mergeValues_(_, _, integer, (L,H), (IL,IH)) :-
556 lower_bound_val_(integer,L,IL), 557 upper_bound_val_(integer,H,IH),
558 non_empty(IL,IH). 559
561mergeFlags_([],Flags2,Flags2) :- !.
562mergeFlags_(Flags1,[],Flags1) :- !.
563mergeFlags_([F1|Flags1],Flags2,Flags) :- 564 functor(F1,N,1), 565 functor(F2,N,1),
566 memberchk(F2,Flags2), !,
567 mergeFlags_(Flags1,Flags2,Flags).
568mergeFlags_([F1|Flags1],Flags2,[F1|Flags]) :- 569 mergeFlags_(Flags1,Flags2,Flags).
570
572mergeNodes_([N],NodeList,NodeList) :- var(N),!. 573mergeNodes_([node(Op,_,_,Ops)|Ns],NodeList,NewList) :- 574 matching_node_(NodeList,Op,Ops), !,
575 mergeNodes_(Ns,NodeList,NewList).
576mergeNodes_([N|Ns],NodeList,[N|NewList]) :- 577 mergeNodes_(Ns,NodeList,NewList).
578
579matching_node_([node(Op,_,_,NOps)|_Ns],Op,Ops) :-
580 NOps==Ops, !. 581matching_node_([N|Ns],Op,Ops) :-
582 nonvar(N), 583 matching_node_(Ns,Op,Ops).
584
588{Cons} :-
589 g_read('clpBNR:thread_init_done',_), 590 term_variables(Cons, CVars),
591 declare_vars_(CVars), 592 addConstraints_(Cons,T/T,Agenda), 593 stable_(Agenda). 594
595declare_vars_([]).
596declare_vars_([CV|CVars]) :-
597 (interval(CV) -> true ; new_interval_(CV,real)),
598 declare_vars_(CVars).
599
600new_interval_(V,Type) :-
601 universal_interval(UI),
602 int_decl_(Type,UI,V).
603
604addConstraints_([],Agenda,Agenda) :- !.
605addConstraints_([C|Cs],Agenda,NewAgenda) :-
606 nonvar(C),
607 addConstraints_(C,Agenda,NextAgenda), !,
608 addConstraints_(Cs,NextAgenda,NewAgenda).
609addConstraints_((C,Cs),Agenda,NewAgenda) :- 610 nonvar(C),
611 addConstraints_(C,Agenda,NextAgenda), !,
612 addConstraints_(Cs,NextAgenda,NewAgenda).
613addConstraints_(C,Agenda,NewAgenda) :-
614 constraint_(C), 615 simplify(C,CS), 616 buildConstraint_(CS, Agenda, NewAgenda).
617
619constrain_(C) :-
620 buildConstraint_(C,T/T,Agenda),
621 stable_(Agenda).
622
623buildConstraint_(C,Agenda,NewAgenda) :-
624 debug_clpBNR_('Add ~p',{C}),
625 626 catch(build_(C, 1, boolean, Agenda, NewAgenda),_Err,fail), !.
627buildConstraint_(C,_Agenda,_NewAgenda) :-
628 debug_clpBNR_('{} failure due to bad or inconsistent constraint: ~p',{C}),
629 fail.
630
631:- include(clpBNR/ia_simplify). 632
636build_(Int, Int, VarType, Agenda, NewAgenda) :-
637 interval(Int), !, 638 applyType_(VarType, Int, Agenda, NewAgenda). 639build_(Var, Var, VarType, Agenda, Agenda) :- 640 var(Var), !,
641 new_interval_(Var,VarType).
642build_(Num, Int, VarType, Agenda, Agenda) :- 643 float(Num), !,
644 (
645 float_class(Num,infinite)
646 -> Int=Num 647 ; int_decl_(VarType,(Num,Num),Int) 648 ).
649build_(::(L,H), Int, VarType, Agenda, Agenda) :- 650 number(L), number(H), !,
651 C is cmpr(L,H), 652 (C == 0
653 -> (rational(L) -> Int=L ; Int=H) 654 ; C == -1, 655 once(VarType == real ; true), 656 put_attr(Int, clpBNR, interval(VarType, (L,H), _NL, [])) 657 ).
658build_(Num, Int, VarType, Agenda, Agenda) :- 659 (Num == pi ; Num == e), !,
660 int_decl_(VarType,(Num,Num),Int).
661build_(Exp, Num, _, Agenda, Agenda) :- 662 ground(Exp),
663 safe_(Exp), 664 Num is Exp,
665 666 preciseBnd(Num), 667 !.
668build_(Exp, Z, _, Agenda, NewAgenda) :- 669 Exp =.. [F|Args],
670 fmap_(F,Op,[Z|Args],ArgsR,Types), !, 671 build_args_(ArgsR,Objs,Types,Agenda,ObjAgenda),
672 newNode_(Op,Objs,ObjAgenda,NewAgenda).
673build_(Exp, Z, _, Agenda, NewAgenda) :- 674 Exp =.. [Prim|Args],
675 chk_primitive_(Prim),
676 build_args_([Z|Args],Objs,_Types,Agenda,ObjAgenda),
677 newNode_(user(Prim),Objs,ObjAgenda,NewAgenda).
678
679build_args_([],[],_,Agenda,Agenda).
680build_args_([Arg|ArgsR],[Obj|Objs],[Type|Types],Agenda,NewAgenda) :-
681 (var(Type) -> Type=real ; true), 682 build_(Arg,Obj,Type,Agenda,NxtAgenda),
683 build_args_(ArgsR,Objs,Types,NxtAgenda,NewAgenda).
684
685chk_primitive_(Prim) :- 686 UsrHead =..[Prim,'$op',_,_,_],
687 current_predicate(_,clpBNR:UsrHead).
688
689sandbox:safe_primitive(clpBNR:chk_primitive_(_Prim)).
690
692call_user_primitive(Prim, P, InArgs, OutArgs) :- 693 call(clpBNR:Prim, '$op', InArgs, OutArgs, P).
694
696sandbox:safe_meta(clpBNR:call_user_primitive(_Prim, _P, _InArgs, _OutArgs), []).
697
699safe_(E) :- atomic(E), !. 700safe_([A|As]) :- !,
701 safe_(A),
702 safe_(As).
703safe_(_ xor _) :- !, 704 fail.
705safe_(integer(_)) :- !, 706 fail.
707safe_(_/Z) :- 0.0 is abs(Z), !, 708 fail.
709safe_(F) :-
710 current_arithmetic_function(F), 711 F =.. [_Op|Args],
712 safe_(Args).
713
715constraint_(C) :- nonvar(C), C =..[Op|_], fmap_(Op,_,_,_,[boolean|_]), !.
716
718fmap_(+, add, ZXY, ZXY, [real,real,real]).
719fmap_(-, add, [Z,X,Y], [X,Z,Y], [real,real,real]). 720fmap_(*, mul, ZXY, ZXY, [real,real,real]).
721fmap_(/, mul, [Z,X,Y], [X,Z,Y], [real,real,real]).
722fmap_(**, pow, ZXY, ZXY, [real,real,real]).
723fmap_(min, min, ZXY, ZXY, [real,real,real]).
724fmap_(max, max, ZXY, ZXY, [real,real,real]).
725fmap_(==, eq, ZXY, ZXY, [boolean,real,real]). 726fmap_(=:=, eq, ZXY, ZXY, [boolean,real,real]). 727fmap_(is, eq, ZXY, ZXY, [boolean,real,real]).
728fmap_(<>, ne, ZXY, ZXY, [boolean,integer,integer]).
729fmap_(=\=, ne, ZXY, ZXY, [boolean,integer,integer]). 730fmap_(=<, le, ZXY, ZXY, [boolean,real,real]).
731fmap_(>=, le, [Z,X,Y], [Z,Y,X], [boolean,real,real]).
732fmap_(<, lt, ZXY, ZXY, [boolean,real,real]).
733fmap_(>, lt, [Z,X,Y], [Z,Y,X], [boolean,real,real]).
734fmap_(<=, in, ZXY, ZXY, [boolean,real,real]). 735
736fmap_(and, and, ZXY, ZXY, [boolean,boolean,boolean]).
737fmap_(',', and, ZXY, ZXY, [boolean,boolean,boolean]). 738fmap_(or, or, ZXY, ZXY, [boolean,boolean,boolean]).
739fmap_(nand, nand, ZXY, ZXY, [boolean,boolean,boolean]).
740fmap_(nor, nor, ZXY, ZXY, [boolean,boolean,boolean]).
741fmap_(xor, xor, ZXY, ZXY, [boolean,boolean,boolean]).
742fmap_(->, imB, ZXY, ZXY, [boolean,boolean,boolean]).
743
744fmap_(sqrt, sqrt, ZX, ZX, [real,real]). 745fmap_(-, minus, ZX, ZX, [real,real]).
746fmap_(~, not, ZX, ZX, [boolean,boolean]).
747fmap_(integer,int, ZX, ZX, [boolean,real]).
748fmap_(exp, exp, ZX, ZX, [real,real]).
749fmap_(log, exp, [Z,X], [X,Z], [real,real]).
750fmap_(abs, abs, ZX, ZX, [real,real]).
751fmap_(sin, sin, ZX, ZX, [real,real]).
752fmap_(asin, sin, [Z,X], [X,Z], [real,real]).
753fmap_(cos, cos, ZX, ZX, [real,real]).
754fmap_(acos, cos, [Z,X], [X,Z], [real,real]).
755fmap_(tan, tan, ZX, ZX, [real,real]).
756fmap_(atan, tan, [Z,X], [X,Z], [real,real]).
757
759map_constraint_op_(integral,$(V),integral(V)) :- !.
760map_constraint_op_(user(Func),Args,C) :- !,
761 remap_(Func,Args,C).
762map_constraint_op_(Op,Args,C) :-
763 fmap_(COp,Op,_,_,_),
764 remap_(COp,Args,C),
765 !.
766
767remap_(Op,$(Z,X,Y),C) :- constraint_(Op), Z==1, !, 768 C=..[Op,X,Y].
769remap_(Op,$(Z,X),C) :- constraint_(Op), Z==1, !, 770 C=..[Op,X].
771remap_(Op,$(Z,X,Y),Z==C) :- !,
772 C=..[Op,X,Y].
773remap_(Op,$(Z,X),Z==C) :-
774 C=..[Op,X].
775
781newNode_(eq, [Z,X,Y], Agenda, Agenda) :- Z==1, !, X=Y.
782newNode_(Op, Objs, Agenda, NewAgenda) :-
783 Args =.. [$|Objs], 784 NewNode = node(Op, _P, 0, Args), 785 addNode_(Objs,NewNode),
786 787 g_incb('clpBNR:node_count'),
788 linkNode_(Agenda, NewNode, NewAgenda).
789
790addNode_([],_Node).
791addNode_([Arg|Args],Node) :-
792 (interval_object(Arg, _Type, _Val, Nodelist) -> newmember(Nodelist, Node) ; true),
793 addNode_(Args,Node).
794
795sandbox:safe_global_variable('clpBNR:node_count').
796
797clpStatistics :-
798 g_assign('clpBNR:node_count',0), 799 fail. 800
801clpStatistic(node_count(C)) :-
802 g_read('clpBNR:node_count',C).
803
805newmember([X|Xs],N) :-
806 (nonvar(X)
807 -> newmember(Xs,N) 808 ; X = N 809 ).
810
814stable_([]/[]) :- !. 815stable_(Agenda) :-
816 current_prolog_flag(clpBNR_iteration_limit,Ops), 817 stableLoop_(Agenda,Ops),
818 !. 819
820stableLoop_([]/[], OpsLeft) :- !, 821 g_read('clpBNR:iterations',Cur), 822 (OpsLeft<Cur -> g_assign('clpBNR:iterations',OpsLeft) ; true),
823 (OpsLeft<0 -> E is -OpsLeft, debug_clpBNR_('Iteration throttle limit exceeded by ~w ops.',E) ; true).
824stableLoop_([Node|Agenda]/T, OpsLeft) :-
825 Node = node(Op,P,_,Args), 826 doNode_(Args, Op, P, OpsLeft, DoOver, Agenda/T, NxtAgenda), 827 nb_setarg(3,Node,0), 828 829 (atom(DoOver), OpsLeft > 0 -> linkNode_(NxtAgenda,Node,NewAgenda) ; NewAgenda = NxtAgenda),
830 RemainingOps is OpsLeft-1, 831 stableLoop_(NewAgenda,RemainingOps).
832
834sandbox:safe_global_variable('clpBNR:iterations').
835
836clpStatistics :-
837 current_prolog_flag(clpBNR_iteration_limit,L),
838 g_assign('clpBNR:iterations',L), 839 fail. 840
841clpStatistic(max_iterations(O/L)) :-
842 g_read('clpBNR:iterations',Ops),
843 current_prolog_flag(clpBNR_iteration_limit,L),
844 O is L-Ops. 845
853doNode_($(ZArg,XArg,YArg), Op, P, OpsLeft, DoOver, Agenda, NewAgenda) :- 854 (var(P) 855 -> getValue(ZArg,ZVal),
856 getValue(XArg,XVal),
857 getValue(YArg,YVal),
858 evalNode(Op, P, $(ZVal,XVal,YVal), $(NZVal,NXVal,NYVal)), 859 860 (var(ZArg) 861 -> (ZArg==XArg -> consistent_value_(NZVal,NXVal,NZ1,DoOver) ; NZ1 = NZVal),
862 (ZArg==YArg -> consistent_value_(NZ1, NYVal,NZ2,DoOver) ; NZ2 = NZ1),
863 updateValue_(ZVal, NZ2, ZArg, OpsLeft, Agenda, AgendaZ)
864 ; AgendaZ = Agenda
865 ),
866 (var(XArg), XArg==YArg 867 -> consistent_value_(NXVal,NYVal,NVal,DoOver),
868 updateValue_(XVal, NVal, XArg, OpsLeft, AgendaZ, NewAgenda) 869 ; updateValue_(XVal, NXVal, XArg, OpsLeft, AgendaZ, AgendaZX),
870 updateValue_(YVal, NYVal, YArg, OpsLeft, AgendaZX, NewAgenda)
871 )
872 ; 873 trim_op_(ZArg), trim_op_(XArg), trim_op_(YArg),
874 NewAgenda = Agenda
875 ).
876
877doNode_($(ZArg,XArg), Op, P, OpsLeft, DoOver, Agenda, NewAgenda) :- 878 (var(P) 879 -> getValue(ZArg,ZVal),
880 getValue(XArg,XVal),
881 evalNode(Op, P, $(ZVal,XVal), $(NZVal,NXVal)), 882 883 (var(ZArg), ZArg==XArg 884 -> consistent_value_(NZVal,NXVal,NVal,DoOver), 885 updateValue_(ZVal, NVal, ZArg, OpsLeft, Agenda, NewAgenda) 886 ; updateValue_(ZVal, NZVal, ZArg, OpsLeft, Agenda, AgendaZ),
887 updateValue_(XVal, NXVal, XArg, OpsLeft, AgendaZ, NewAgenda)
888 )
889 ; 890 trim_op_(ZArg), trim_op_(XArg),
891 NewAgenda = Agenda
892 ).
893
894doNode_($(Arg), Op, P, _OpsLeft, _, Agenda, NewAgenda) :- 895 (var(P) 896 -> getValue(Arg,Val),
897 evalNode(Op, P, $(Val), $(NVal)), 898 updateValue_(Val, NVal, Arg, 1, Agenda,NewAgenda) 899 ; 900 trim_op_(Arg),
901 NewAgenda = Agenda
902 ).
903
904consistent_value_(Val,Val,Val,_) :- !. 905consistent_value_(Val1,Val2,Val,true) :- ^(Val1,Val2,Val). 906
911trim_op_(Arg) :-
912 ( get_attr(Arg, clpBNR, Def) 913 -> arg(3,Def,NList), 914 trim_persistent_(NList,TrimList),
915 916 (var(TrimList) -> setarg(3,Def,_) ; setarg(3,Def,TrimList)) 917 ; true 918 ).
919
920trim_persistent_(T,T) :- var(T), !. 921trim_persistent_([node(_,P,_,_)|Ns],TNs) :- nonvar(P), !, trim_persistent_(Ns,TNs).
922trim_persistent_([N|Ns],[N|TNs]) :- trim_persistent_(Ns,TNs).
923
928updateValue_(Old, Old, _, _, Agenda, Agenda) :- !. 929
930updateValue_(Old, New, Int, OpsLeft, Agenda, NewAgenda) :- 931 (OpsLeft>0 -> true ; propagate_if_(Old, New)), !, 932 putValue_(New, Int, Nodelist), 933 linkNodeList_(Nodelist, Agenda, NewAgenda). 934
935updateValue_(_, _, _, _, Agenda, Agenda). 936
938propagate_if_((OL,OH), (NL,NH)) :- (NH-NL)/(OH-OL) < 0.9. 939
940linkNodeList_([X|Xs], List, NewList) :-
941 (var(X)
942 -> List = NewList 943 ; (arg(3,X,Linked), Linked == 1 944 -> linkNodeList_(Xs, List, NewList) 945 ; linkNode_(List, X, NextList), 946 linkNodeList_(Xs, NextList, NewList) 947 )
948 ).
949
950linkNode_(List/[X|NextTail], X, List/NextTail) :- 951 setarg(3,X,1). 952
953:- include(clpBNR/ia_utilities). 954
958watch(Int,Action) :-
959 atom(Action),
960 current_module(clpBNR), 961 get_interval_flags_(Int,Flags), !,
962 remove_(Flags,watch(_),Flags1),
963 (Action = none -> Flags2=Flags1 ; Flags2=[watch(Action)|Flags1]),
964 set_interval_flags_(Int,Flags2).
965watch(Ints,Action) :-
966 list(Ints),
967 watch_list_(Ints,Action).
968
969remove_([],_,[]).
970remove_([X|Xs],X,Xs) :- !.
971remove_([X|Xs],X,[X|Ys]) :-
972 remove_(Xs,X,Ys).
973
974watch_list_([],_Action).
975watch_list_([Int|Ints],Action) :-
976 watch(Int,Action),
977 watch_list_(Ints,Action).
978
980check_monitor_(Int, Update, interval(_Type,_Val,_Nodelist,Flags)) :-
981 (memberchk(watch(Action), Flags)
982 -> once(monitor_action_(Action, Update, Int))
983 ; true
984 ).
985
989monitor_action_(trace, Update, Int) :- !, 990 monitor_action_(log, Update, Int),
991 trace.
992monitor_action_(log, Update, Int) :- var(Update), !, 993 debug_clpBNR_('Unify ~p with ~p',[Int,Update]).
994monitor_action_(log, Update, Int) :- number(Update), !, 995 domain(Int,Dom),
996 debug_clpBNR_('Unify _?{~p} with ~p',[Dom,Update]).
997monitor_action_(log, integer, Int) :- !, 998 debug_clpBNR_('Set type of ~p to ~p',[Int,integer]).
999monitor_action_(log, Val, Int) :- !, 1000 debug_clpBNR_('Set value of ~p to (~p)',[Int,Val]).
1001monitor_action_(_, _, _). 1002
1003sandbox:safe_primitive(clpBNR:watch(_Int,Action)) :- 1004 Action \= trace.
1006sandbox:safe_primitive(clpBNR:monitor_action_(_Action, _Update, _Int)).
1007
1012:- use_module(library(prolog_wrap)). 1013
1014trace_clpBNR(Bool) :- 1015 ( current_predicate_wrapper(clpBNR:doNode_(_Args, _Op, _P, _OpsLeft, _DoOver, _Agenda, _NewAgenda),
1016 'clpBNR:doNode_', _Wrapped, _Body)
1017 -> Bool = true ; Bool = false
1018 ),
1019 !.
1020trace_clpBNR(true) :- 1021 wrap_predicate(clpBNR:doNode_(Args, Op, _P, _OpsLeft, _DoOver, _Agenda, _NewAgenda),
1022 'clpBNR:doNode_',
1023 Wrapped,
1024 doNode_wrap_(Wrapped, Args,Op)).
1025trace_clpBNR(false) :- 1026 unwrap_predicate(clpBNR:doNode_/7, 1027 'clpBNR:doNode_').
1028
1029doNode_wrap_(Wrapped, Args,Op) :-
1030 map_constraint_op_(Op,Args,C),
1031 Wrapped, 1032 debug_clpBNR_("~p.",C). 1033
1037clpStatistics(Ss) :- findall(S, clpStatistic(S), Ss).
1038
1040clpStatistics.
1041
1045init_clpBNR :-
1046 restore_optimize_flags_,
1047 print_message(informational, clpBNR(versionInfo)),
1048 print_message(informational, clpBNR(arithmeticFlags)). 1049
1050check_hooks_safety :- 1051 1052 ignore(attr_portray_hook([],_)), 1053 ignore(user:exception(undefined_global_variable,'clpBNR:thread_init_done',[])), 1055 ignore(user:portray('$clpBNR...'(_))). 1056
1057:- multifile prolog:message//1. 1058
1059prolog:message(clpBNR(versionInfo)) -->
1060 { version(Version) },
1061 [ '*** clpBNR v~w ***.'-[Version] ].
1062
1063prolog:message(clpBNR(arithmeticFlags)) -->
1064 [ ' Arithmetic global flags will be set to prefer rationals and IEEE continuation values.'-[] ].
1065
1066:- initialization(init_clpBNR, now).