diff --git a/C/cdmgr.c b/C/cdmgr.c index f0ae6ccd2..d2f19d855 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -2975,6 +2975,29 @@ p_is_source(void) return(out); } +static Int +p_owner_file(void) +{ /* '$owner_file'(+P,M,F) */ + PredEntry *pe; + Atom owner; + + pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source"); + if (EndOfPAEntr(pe)) + return FALSE; + LOCK(pe->PELock); + if (pe->ModuleOfPred == IDB_MODULE) { + UNLOCK(pe->PELock); + return FALSE; + } + if (pe->PredFlags & MultiFileFlag) { + UNLOCK(pe->PELock); + return FALSE; + } + owner = pe->src.OwnerFile + UNLOCK(pe->PELock); + return Yap_unify(ARG3, MkAtomTerm(owner)); +} + static Int p_mk_d(void) { /* '$is_dynamic'(+P) */ @@ -5593,6 +5616,7 @@ Yap_InitCdMgr(void) Yap_InitCPred("$is_expand_goal_or_meta_predicate", 2, p_is_expandgoalormetapredicate, TestPredFlag | SafePredFlag|HiddenPredFlag); Yap_InitCPred("$is_log_updatable", 2, p_is_log_updatable, TestPredFlag | SafePredFlag|HiddenPredFlag); Yap_InitCPred("$is_source", 2, p_is_source, TestPredFlag | SafePredFlag|HiddenPredFlag); + Yap_InitCPred("$owner_file", 3, p_owner_file, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$mk_d", 2, p_mk_d, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$pred_exists", 2, p_pred_exists, TestPredFlag | SafePredFlag|HiddenPredFlag); Yap_InitCPred("$number_of_clauses", 3, p_number_of_clauses, SafePredFlag|SyncPredFlag|HiddenPredFlag); diff --git a/C/cmppreds.c b/C/cmppreds.c index 3446919e8..c829f54e9 100644 --- a/C/cmppreds.c +++ b/C/cmppreds.c @@ -681,35 +681,35 @@ a_eq(Term t1, Term t2) static Int a_dif(Term t1, Term t2) { - int out = a_cmp(Deref(t1),Deref(t2)); + Int out = a_cmp(Deref(t1),Deref(t2)); return !ArithError && out != 0; } static Int a_gt(Term t1, Term t2) { /* A > B */ - int out = a_cmp(Deref(t1),Deref(t2)); + Int out = a_cmp(Deref(t1),Deref(t2)); return !ArithError && out > 0; } static Int a_ge(Term t1, Term t2) { /* A >= B */ - int out = a_cmp(Deref(t1),Deref(t2)); + Int out = a_cmp(Deref(t1),Deref(t2)); return !ArithError && out >= 0; } static Int a_lt(Term t1, Term t2) { /* A < B */ - int out = a_cmp(Deref(t1),Deref(t2)); + Int out = a_cmp(Deref(t1),Deref(t2)); return !ArithError && out < 0; } static Int a_le(Term t1, Term t2) { /* A <= B */ - int out = a_cmp(Deref(t1),Deref(t2)); + Int out = a_cmp(Deref(t1),Deref(t2)); return !ArithError && out <= 0; } diff --git a/C/errors.c b/C/errors.c index bf4c34857..3d6c857bb 100644 --- a/C/errors.c +++ b/C/errors.c @@ -902,6 +902,21 @@ Yap_Error(yap_error_number type, Term where, char *format,...) serious = TRUE; } break; + case EXISTENCE_ERROR_VARIABLE: + { + int i; + Term ti[2]; + + i = strlen(tmpbuf); + ti[0] = MkAtomTerm(AtomVariable); + ti[1] = where; + nt[0] = Yap_MkApplTerm(FunctorExistenceError, 2, ti); + tp = tmpbuf+i; + psize -= i; + fun = FunctorError; + serious = TRUE; + } + break; case EVALUATION_ERROR_FLOAT_OVERFLOW: { int i; diff --git a/C/globals.c b/C/globals.c index f1c79ccdc..cefa30833 100644 --- a/C/globals.c +++ b/C/globals.c @@ -1285,8 +1285,10 @@ p_nb_getval(void) return FALSE; } ge = FindGlobalEntry(AtomOfTerm(t)); - if (!ge) + if (!ge) { + Yap_Error(EXISTENCE_ERROR_VARIABLE,t,"nb_getval"); return FALSE; + } READ_LOCK(ge->GRWLock); to = ge->global; if (IsVarTerm(to) && IsUnboundVar(VarOfTerm(to))) { @@ -1309,8 +1311,10 @@ nbdelete(Atom at) Prop gp, g0; ge = FindGlobalEntry(at); - if (!ge) + if (!ge) { + Yap_Error(EXISTENCE_ERROR_VARIABLE,MkAtomTerm(at),"nb_delete"); return FALSE; + } WRITE_LOCK(ge->GRWLock); ae = ge->AtomOfGE; if (GlobalVariables == ge) { @@ -1375,8 +1379,10 @@ p_nb_create(void) return FALSE; } ge = GetGlobalEntry(AtomOfTerm(t)); - if (!ge) + if (!ge) { + Yap_Error(EXISTENCE_ERROR_VARIABLE,t,"nb_create"); return FALSE; + } if (IsVarTerm(tarity)) { Yap_Error(INSTANTIATION_ERROR,tarity,"nb_create"); return FALSE; @@ -1418,8 +1424,10 @@ p_nb_create2(void) return FALSE; } ge = GetGlobalEntry(AtomOfTerm(t)); - if (!ge) + if (!ge) { + Yap_Error(EXISTENCE_ERROR_VARIABLE,t,"nb_create"); return FALSE; + } if (IsVarTerm(tarity)) { Yap_Error(INSTANTIATION_ERROR,tarity,"nb_create"); return FALSE; diff --git a/C/iopreds.c b/C/iopreds.c index 6044d8f06..01f05c897 100755 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -3401,7 +3401,7 @@ p_peek_mem_write_stream (void) Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); return(FALSE); } - i = 0; + i = Stream[sno].u.mem_string.pos; tf = ARG2; LOCK(Stream[sno].streamlock); goto restart; diff --git a/H/Yap.h b/H/Yap.h index 45b7f8447..f8870dd2d 100644 --- a/H/Yap.h +++ b/H/Yap.h @@ -90,7 +90,7 @@ #undef USE_THREADED_CODE #endif #define inline __inline -#define YAP_VERSION "Yap-6.0.0" +#define YAP_VERSION "Yap-6.0.1" #define BIN_DIR "c:\\Yap\\bin" #define LIB_DIR "c:\\Yap\\lib\\Yap" @@ -464,6 +464,7 @@ typedef enum EXISTENCE_ERROR_KEY, EXISTENCE_ERROR_SOURCE_SINK, EXISTENCE_ERROR_STREAM, + EXISTENCE_ERROR_VARIABLE, INSTANTIATION_ERROR, INTERRUPT_ERROR, OPERATING_SYSTEM_ERROR, diff --git a/LGPL/prolog_source.pl b/LGPL/prolog_source.pl index d6e9472d4..148ec5422 100644 --- a/LGPL/prolog_source.pl +++ b/LGPL/prolog_source.pl @@ -69,10 +69,6 @@ users of the library are: :- if(current_prolog_flag(dialect, yap)). % yap -'$set_source_module'(M1, M2) :- - source_module(M1), - module(M2). - '$style_check'([Singleton,Discontiguous,Multiple], StyleF) :- ( prolog_flag(single_var_warnings,on) diff --git a/LGPL/prolog_xref.pl b/LGPL/prolog_xref.pl index 59de4897d..4265a407a 100644 --- a/LGPL/prolog_xref.pl +++ b/LGPL/prolog_xref.pl @@ -1,4 +1,4 @@ -/* $Id: prolog_xref.pl,v 1.3 2008-02-13 14:42:55 vsc Exp $ +/* $Id$ Part of SWI-Prolog @@ -51,15 +51,16 @@ xref_used_class/2, % ?Source, ?ClassName xref_defined_class/3 % ?Source, ?ClassName, -How ]). - -%:- use_module(library(debug), [debug/3, debugging/1]). -:- use_module(library(lists), [append/3, member/2, is_list/1]). +:- use_module(library(debug), [debug/3, debugging/1]). +:- use_module(library(lists), [append/3, member/2]). :- use_module(library(operators), [pop_operators/0, push_op/3, push_operators/1]). +:- if(current_prolog_flag(dialect, swi)). :- use_module(library(shlib), [current_foreign_library/2]). +:- endif. :- use_module(library(prolog_source)). :- use_module(library(option)). -:- use_module(library(debug)). +:- use_module(library(error)). :- dynamic called/3, % Head, Src, From @@ -78,6 +79,7 @@ defined_class/5, % Name, Super, Summary, Src, Line (mode)/2. % Mode, Src +:- create_prolog_flag(xref, false, [type(boolean)]). /******************************* * HOOKS * @@ -101,44 +103,30 @@ :- dynamic meta_goal/2. +called_by(Goal, Called) :- + prolog:called_by(Goal, Called), !. +called_by(on_signal(_,_,New), [New+1]) :- + ( new == throw + ; new == default + ), !, fail. + + /******************************* * BUILT-INS * *******************************/ %% built_in_predicate(+Callable) -% +% % True if Callable is a built-in +:- expects_dialect(swi). + :- if(current_prolog_flag(dialect, swi)). system_predicate(Goal) :- + functor(Goal, Name, Arity), + current_predicate(system:Name/Arity), % avoid autoloading predicate_property(system:Goal, built_in), !. - -genarg(X,Y,Z) :- - arg(X,Y,Z). -:- else. -% yap - -:- ensure_loaded(library(swi)). - -:- user_defined_flag(xref). - -:- use_module(library(arg)). - -flag(Key,Old,New) :- - retract('$flag'(Key,OOld)), !, - Old = OOld, - assert('$flag'(Key,New)). -flag(Key,0,New) :- - assert('$flag'(Key,New)). - -'$set_source_module'(M1, M2) :- - source_module(M1), - module(M2). - -'$get_predicate_attribute'(M1, P1, P2) :- - Prop =.. [P1,P2], - predicate_property(M1, Prop). -:- endif. +:-endif. /******************************** * TOPLEVEL * @@ -148,11 +136,11 @@ verbose :- debugging(xref). %% xref_source(+Source) is det. -% +% % Generate the cross-reference data for Source if not already % done and the source is not modified. Checking for modifications % is only done for files. -% +% % @param Source File specification or XPCE buffer xref_source(Source) :- @@ -172,28 +160,38 @@ xref_source(Source) :- xref_setup(Src, In, State), call_cleanup(collect(Src, In), xref_cleanup(State)). -xref_setup(Src, In, state(In, Xref, Ref)) :- +:- thread_local + xref_stream/1. % input stream + +xref_setup(Src, In, state(In, Xref, [SRef|HRefs])) :- prolog_open_source(Src, In), + asserta(xref_stream(In), SRef), ( current_prolog_flag(xref, Xref) -> true ; Xref = false ), set_prolog_flag(xref, true), ( verbose - -> Ref = [] - ; asserta(user:message_hook(_,_,_), Ref) + -> HRefs = [] + ; asserta(user:message_hook(_,_,_), Ref), + HRefs = [Ref] ). -xref_cleanup(state(In, Xref, Ref)) :- +xref_cleanup(state(In, Xref, Refs)) :- prolog_close_source(In), set_prolog_flag(xref, Xref), - ( Ref \== [] - -> erase(Ref) - ; true - ). + maplist(erase, Refs). + +%% xref_input_stream(-Stream) is det. +% +% Current input stream for cross-referencer. + +xref_input_stream(Stream) :- + xref_stream(Var), !, + Stream = Var. %% xref_push_op(Source, +Prec, +Type, :Name) -% +% % Define operators into the default source module and register % them to be undone by pop_operators/0. @@ -209,7 +207,7 @@ xref_push_op(Src, P, T, N0) :- !, %% xref_clean(+Source) is det. -% +% % Reset the database for the given source. xref_clean(Source) :- @@ -228,7 +226,7 @@ xref_clean(Source) :- retractall(used_class(_, Src)), retractall(defined_class(_, _, _, Src, _)), retractall(mode(_, Src)). - + /******************************* * READ RESULTS * @@ -243,7 +241,7 @@ xref_current_source(Source) :- %% xref_done(+Source, -Time) is det. -% +% % Cross-reference executed at Time xref_done(Source, Time) :- @@ -252,7 +250,7 @@ xref_done(Source, Time) :- %% xref_called(+Source, ?Called, ?By) is nondet. -% +% % Enumerate the predicate-call relations. Predicate called by % directives have a By ''. @@ -262,7 +260,7 @@ xref_called(Source, Called, By) :- %% xref_defined(+Source, +Goal, ?How) is semidet. -% +% % Test if Goal is accessible in Source. If this is the case, How % specifies the reason why the predicate is accessible. Note that % this predicate does not deal with built-in or global predicates, @@ -289,7 +287,7 @@ xref_defined2(imported(From), Src, Called) :- %% xref_definition_line(+How, -Line) -% +% % If the 3th argument of xref_defined contains line info, return % this in Line. @@ -306,7 +304,7 @@ xref_exported(Source, Called) :- exported(Called, Src). %% xref_module(?Source, ?Module) is nondet. -% +% % True if Module is defined in Source. xref_module(Source, Module) :- @@ -314,11 +312,11 @@ xref_module(Source, Module) :- xmodule(Module, Src). %% xref_op(?Source, Op) is nondet. -% +% % Give the operators active inside the module. This is intended to % setup the environment for incremental parsing of a term from the % source-file. -% +% % @param Op Term of the form op(Priority, Type, Name) xref_op(Source, Op) :- @@ -342,18 +340,18 @@ xref_defined_class(Source, Class, file(File)) :- collect(Src, In) :- repeat, - catch(read_source_term(In, Term, TermPos), - E, syntax_error(E)), + catch(read_source_term(Src, In, Term, TermPos), + E, report_syntax_error(E)), xref_expand(Term, T), ( T == end_of_file -> ! ; stream_position_data(line_count, TermPos, Line), flag(xref_src_line, _, Line), - process(T, Src), + catch(process(T, Src), E, print_message(error, E)), fail ). -%% read_source_term(+In:stream, -Term, -TermPos) is det. +%% read_source_term(+Src, +In:stream, -Term, -TermPos) is det. % % Read next term from In. The cross-referencer supports the % comment_hook as also implemented by the compiler for the @@ -362,7 +360,9 @@ collect(Src, In) :- :- multifile prolog:comment_hook/3. -read_source_term(In, Term, TermPos) :- +read_source_term(Src, In, Term, TermPos) :- + atom(Src), + \+ source_file(Src), % normally loaded; no need to update '$get_predicate_attribute'(prolog:comment_hook(_,_,_), number_of_clauses, N), N > 0, !, @@ -377,7 +377,7 @@ read_source_term(In, Term, TermPos) :- -> true ; true ). -read_source_term(In, Term, TermPos) :- +read_source_term(_, In, Term, TermPos) :- '$set_source_module'(SM, SM), read_term(In, Term, [ term_position(TermPos), @@ -385,7 +385,7 @@ read_source_term(In, Term, TermPos) :- ]). -syntax_error(E) :- +report_syntax_error(E) :- ( verbose -> print_message(error, E) ; true @@ -405,6 +405,10 @@ syntax_error(E) :- % are processed using process_chr/2 directly from the source, % which is why we inhibit expansion here. +xref_expand((:- if(Cond)), (:- if(Cond))). +xref_expand((:- elif(Cond)), (:- elif(Cond))). +xref_expand((:- else), (:- else)). +xref_expand((:- endif), (:- endif)). xref_expand((:- require(X)), (:- require(X))) :- !. xref_expand(Term, _) :- @@ -468,15 +472,20 @@ process_directive(List, Src) :- process_directive(consult(List), Src). process_directive(use_module(Spec, Import), Src) :- xref_public_list(Spec, Path, Public, Src), - assert_import(Src, Import, Public, Path). + assert_import(Src, Import, Public, Path, false). +process_directive(reexport(Spec, Import), Src) :- + xref_public_list(Spec, Path, Public, Src), + assert_import(Src, Import, Public, Path, true). +process_directive(reexport(Modules), Src) :- + process_use_module(Modules, Src, true). process_directive(use_module(Modules), Src) :- - process_use_module(Modules, Src). + process_use_module(Modules, Src, false). process_directive(consult(Modules), Src) :- - process_use_module(Modules, Src). + process_use_module(Modules, Src, false). process_directive(ensure_loaded(Modules), Src) :- - process_use_module(Modules, Src). + process_use_module(Modules, Src, false). process_directive(load_files(Files, _Options), Src) :- - process_use_module(Files, Src). + process_use_module(Files, Src, false). process_directive(include(Files), Src) :- process_include(Files, Src). process_directive(dynamic(Dynamic), Src) :- @@ -499,15 +508,20 @@ process_directive(op(P, A, N), Src) :- xref_push_op(Src, P, A, N). process_directive(style_check(X), _) :- style_check(X). +process_directive(encoding(Enc), _) :- + ( xref_input_stream(Stream) + -> catch(set_stream(Stream, encoding(Enc)), _, true) + ; true % can this happen? + ). process_directive(system_module, _) :- style_check(+dollar). process_directive(set_prolog_flag(character_escapes, Esc), _) :- set_prolog_flag(character_escapes, Esc). process_directive(pce_expansion:push_compile_operators, _) :- '$set_source_module'(SM, SM), - pce_expansion:push_compile_operators(SM). + call(pce_expansion:push_compile_operators(SM)). % call to avoid xref process_directive(pce_expansion:pop_compile_operators, _) :- - pce_expansion:pop_compile_operators. + call(pce_expansion:pop_compile_operators). process_directive(meta_predicate(Meta), _) :- process_meta_predicate(Meta). process_directive(arithmetic_function(FSpec), Src) :- @@ -517,12 +531,20 @@ process_directive(arithmetic_function(FSpec), Src) :- process_directive(format_predicate(_, Goal), Src) :- !, flag(xref_src_line, Line, Line), assert_called(Src, ''(Line), Goal). +process_directive(if(Cond), Src) :- !, + flag(xref_src_line, Line, Line), + assert_called(Src, ''(Line), Cond). +process_directive(elif(Cond), Src) :- !, + flag(xref_src_line, Line, Line), + assert_called(Src, ''(Line), Cond). +process_directive(else, _) :- !. +process_directive(endif, _) :- !. process_directive(Goal, Src) :- flag(xref_src_line, Line, Line), process_body(Goal, ''(Line), Src). %% process_meta_predicate(+Decl) -% +% % Create prolog:meta_goal/2 declaration from the meta-goal % declaration. @@ -534,22 +556,22 @@ process_meta_predicate(Decl) :- functor(Head, Name, Arity), meta_args(1, Arity, Decl, Head, Meta), ( ( prolog:meta_goal(Head, _) - ; prolog:called_by(Head, _) + ; called_by(Head, _) ; meta_goal(Head, _) ) -> true - ; assert(prolog:meta_goal(Head, Meta)) + ; assert(meta_goal(Head, Meta)) ). meta_args(I, Arity, _, _, []) :- I > Arity, !. -meta_args(I, Arity, Decl, Head, [H|T]) :- % : - arg(I, Decl, :), !, +meta_args(I, Arity, Decl, Head, [H|T]) :- % 0 + arg(I, Decl, 0), !, arg(I, Head, H), I2 is I + 1, meta_args(I2, Arity, Decl, Head, T). meta_args(I, Arity, Decl, Head, [H+A|T]) :- % I --> H+I - arg(I, Decl, A), + arg(I, Decl, A), integer(A), A > 0, !, arg(I, Head, H), I2 is I + 1, @@ -568,15 +590,24 @@ xref_meta((A; B), [A, B]). xref_meta((A| B), [A, B]). xref_meta((A -> B), [A, B]). xref_meta((A *-> B), [A, B]). -xref_meta(findall(_V, G, _L), [G]). +xref_meta(findall(_V,G,_L), [G]). +xref_meta(findall(_V,G,_L,_T), [G]). xref_meta(setof(_V, G, _L), [G]). xref_meta(bagof(_V, G, _L), [G]). xref_meta(forall(A, B), [A, B]). -xref_meta(maplist(G, _), [G+1]). -xref_meta(maplist(G, _, _), [G+2]). -xref_meta(maplist(G, _, _, _), [G+3]). +xref_meta(maplist(G,_), [G+1]). +xref_meta(maplist(G,_,_), [G+2]). +xref_meta(maplist(G,_,_,_), [G+3]). +xref_meta(maplist(G,_,_,_,_), [G+4]). +xref_meta(map_list_to_pairs(G,_,_), [G+2]). +xref_meta(map_assoc(G, _), [G+1]). +xref_meta(map_assoc(G, _, _), [G+2]). xref_meta(checklist(G, _L), [G+1]). xref_meta(sublist(G, _, _), [G+1]). +xref_meta(include(G, _, _), [G+1]). +xref_meta(exclude(G, _, _), [G+1]). +xref_meta(partition(G, _, _, _, _), [G+2]). +xref_meta(partition(G, _, _, _),[G+1]). xref_meta(call(G), [G]). xref_meta(call(G, _), [G+1]). xref_meta(call(G, _, _), [G+2]). @@ -588,21 +619,23 @@ xref_meta(\+(G), [G]). xref_meta(ignore(G), [G]). xref_meta(once(G), [G]). xref_meta(initialization(G), [G]). +xref_meta(initialization(G,_), [G]). xref_meta(retract(Rule), [G]) :- head_of(Rule, G). xref_meta(clause(G, _), [G]). xref_meta(clause(G, _, _), [G]). xref_meta(phrase(G, _A), [G+2]). xref_meta(phrase(G, _A, _R), [G+2]). +xref_meta(phrase_from_file(G,_),[G+2]). xref_meta(catch(A, _, B), [A, B]). xref_meta(thread_create(A,_,_), [A]). xref_meta(thread_signal(_,A), [A]). xref_meta(thread_at_exit(A), [A]). +xref_meta(thread_initialization(A), [A]). xref_meta(predsort(A,_,_), [A+3]). xref_meta(call_cleanup(A, B), [A, B]). xref_meta(call_cleanup(A, _, B),[A, B]). -xref_meta(setup_and_call_cleanup(A, B, C),[A, B, C]). -xref_meta(setup_and_call_cleanup(A, B, _, C),[A, B, C]). -xref_meta(on_signal(_,_,A), [A+1]). +xref_meta(setup_call_cleanup(A, B, C),[A, B, C]). +xref_meta(setup_call_catcher_cleanup(A, B, _, C),[A, B, C]). xref_meta(with_mutex(_,A), [A]). xref_meta(assume(G), [G]). % library(debug) xref_meta(assertion(G), [G]). % library(debug) @@ -615,8 +648,13 @@ xref_meta(profile(G), [G]). xref_meta(at_halt(G), [G]). xref_meta(call_with_time_limit(_, G), [G]). xref_meta(call_with_depth_limit(G, _, _), [G]). +xref_meta(alarm(_, G, _), [G]). +xref_meta(alarm(_, G, _, _), [G]). xref_meta('$add_directive_wic'(G), [G]). xref_meta(with_output_to(_, G), [G]). +xref_meta(if(G), [G]). +xref_meta(elif(G), [G]). +xref_meta(meta_options(G,_,_), [G+1]). % XPCE meta-predicates xref_meta(pce_global(_, new(_)), _) :- !, fail. @@ -633,7 +671,7 @@ xref_meta(G, Meta) :- % Generated from :- meta_predicate %% head_of(+Rule, -Head) -% +% % Get the head for a retract call. head_of(Var, _) :- @@ -642,7 +680,7 @@ head_of((Head :- _), Head). head_of(Head, Head). %% xref_hook(?Callable) -% +% % Definition of known hooks. Hooks that can be called in any % module are unqualified. Other hooks are qualified with the % module where they are called. @@ -650,42 +688,52 @@ head_of(Head, Head). xref_hook(Hook) :- prolog:hook(Hook). xref_hook(Hook) :- - xhook(Hook). + hook(Hook). -xhook(attr_portray_hook(_,_)). -xhook(attr_unify_hook(_,_)). -xhook(goal_expansion(_,_)). -xhook(term_expansion(_,_)). -xhook(resource(_,_,_)). +hook(attr_portray_hook(_,_)). +hook(attr_unify_hook(_,_)). +hook(goal_expansion(_,_)). +hook(term_expansion(_,_)). +hook(resource(_,_,_)). + +hook(emacs_prolog_colours:goal_classification(_,_)). +hook(emacs_prolog_colours:term_colours(_,_)). +hook(emacs_prolog_colours:goal_colours(_,_)). +hook(emacs_prolog_colours:style(_,_)). +hook(emacs_prolog_colours:identify(_,_)). +hook(pce_principal:pce_class(_,_,_,_,_,_)). +hook(pce_principal:send_implementation(_,_,_)). +hook(pce_principal:get_implementation(_,_,_,_)). +hook(pce_principal:pce_lazy_get_method(_,_,_)). +hook(pce_principal:pce_lazy_send_method(_,_,_)). +hook(pce_principal:pce_uses_template(_,_)). +hook(prolog:locate_clauses(_,_)). +hook(prolog:message(_,_,_)). +hook(prolog:message_context(_,_,_)). +hook(prolog:debug_control_hook(_)). +hook(prolog:help_hook(_)). +hook(prolog:show_profile_hook(_,_)). +hook(prolog:general_exception(_,_)). +hook(prolog_edit:load). +hook(prolog_edit:locate(_,_,_)). +hook(shlib:unload_all_foreign_libraries). +hook(system:'$foreign_registered'(_, _)). +hook(user:exception(_,_,_)). +hook(user:file_search_path(_,_)). +hook(user:library_directory(_)). +hook(user:message_hook(_,_,_)). +hook(user:portray(_)). +hook(user:prolog_clause_name(_,_)). +hook(user:prolog_list_goal(_)). +hook(user:prolog_predicate_name(_,_)). +hook(user:prolog_trace_interception(_,_,_,_)). +hook(user:prolog_event_hook(_)). +hook(user:prolog_exception_hook(_,_,_,_)). -xhook(emacs_prolog_colours:goal_colours(_,_)). -xhook(pce_principal:pce_class(_,_,_,_,_,_)). -xhook(pce_principal:send_implementation(_,_,_)). -xhook(pce_principal:get_implementation(_,_,_,_)). -xhook(pce_principal:pce_lazy_get_method(_,_,_)). -xhook(pce_principal:pce_lazy_send_method(_,_,_)). -xhook(prolog:locate_clauses(_,_)). -xhook(prolog:message(_,_,_)). -xhook(prolog:debug_control_hook(_)). -xhook(prolog:help_hook(_)). -xhook(prolog:show_profile_hook(_,_)). -xhook(prolog_edit:load). -xhook(shlib:unload_all_foreign_libraries). -xhook(system:'$foreign_registered'(_, _)). -xhook(user:exception(_,_,_)). -xhook(user:file_search_path(_,_)). -xhook(user:library_directory(_)). -xhook(user:message_hook(_,_,_)). -xhook(user:portray(_)). -xhook(user:prolog_clause_name(_,_)). -xhook(user:prolog_list_goal(_)). -xhook(user:prolog_predicate_name(_,_)). -xhook(user:prolog_trace_interception(_,_,_,_)). -xhook(user:prolog_event_hook(_)). %% arith_callable(+Spec, -Callable) -% +% % Translate argument of arithmetic_function/1 into a callable term arith_callable(Var, _) :- @@ -698,18 +746,15 @@ arith_callable(Name/Arity, Goal) :- %% process_body(+Body, +Origin, +Src) -% +% % Process a callable body (body of a clause or directive). Origin % describes the origin of the call. process_body(Var, _, _) :- var(Var), !. process_body(Goal, Origin, Src) :- - prolog:called_by(Goal, Called), !, - ( is_list(Called) - -> true - ; throw(error(type_error(list, Called), _)) - ), + called_by(Goal, Called), !, + must_be(list, Called), assert_called(Src, Origin, Goal), process_called_list(Called, Origin, Src). process_body(Goal, Origin, Src) :- @@ -782,13 +827,13 @@ pce_goal(get_object(_,_,_), get_object(arg, msg, -)). process_xpce_goal(G, Origin, Src) :- pce_goal(G, Process), !, assert_called(Src, Origin, G), - ( genarg(I, Process, How), + ( arg(I, Process, How), arg(I, G, Term), process_xpce_arg(How, Term, Origin, Src), fail ; true ). - + process_xpce_arg(new, Term, Origin, Src) :- callable(Term), process_new(Term, Origin, Src). @@ -797,7 +842,7 @@ process_xpce_arg(arg, Term, Origin, Src) :- process_new(Term, Origin, Src). process_xpce_arg(msg, Term, Origin, Src) :- compound(Term), - ( genarg(_, Term, Arg), + ( arg(_, Term, Arg), process_xpce_arg(arg, Arg, Origin, Src), fail ; true @@ -806,12 +851,19 @@ process_xpce_arg(msg, Term, Origin, Src) :- process_new(_M:_Term, _, _) :- !. % TBD: Calls on other modules! process_new(Term, Origin, Src) :- assert_new(Src, Origin, Term), - ( genarg(_, Term, Arg), + ( arg(_, Term, Arg), process_xpce_arg(arg, Arg, Origin, Src), fail ; true ). +assert_new(_, _, Term) :- + \+ callable(Term), !. +assert_new(Src, Origin, Control) :- + functor(Control, Class, _), + pce_control_class(Class), !, + forall(arg(_, Control, Arg), + assert_new(Src, Origin, Arg)). assert_new(Src, Origin, Term) :- compound(Term), arg(1, Term, Prolog), @@ -829,27 +881,34 @@ assert_new(Src, Origin, Term) :- fail. assert_new(_, _, @(_)) :- !. assert_new(Src, _, Term) :- - callable(Term), functor(Term, Name, _), assert_used_class(Src, Name). +pce_control_class(and). +pce_control_class(or). +pce_control_class(if). +pce_control_class(not). + + /******************************** * INCLUDED MODULES * ********************************/ -process_use_module(_Module:_Files, _) :- !. % loaded in another module -process_use_module([], _) :- !. -process_use_module([H|T], Src) :- !, - process_use_module(H, Src), - process_use_module(T, Src). -process_use_module(library(pce), Src) :- !, % bit special +%% process_use_module(+Modules, +Src, +Rexport) is det. + +process_use_module(_Module:_Files, _, _) :- !. % loaded in another module +process_use_module([], _, _) :- !. +process_use_module([H|T], Src, Reexport) :- !, + process_use_module(H, Src, Reexport), + process_use_module(T, Src, Reexport). +process_use_module(library(pce), Src, Reexport) :- !, % bit special xref_public_list(library(pce), Path, Public, Src), forall(member(Import, Public), - process_pce_import(Import, Src, Path)). -process_use_module(File, Src) :- + process_pce_import(Import, Src, Path, Reexport)). +process_use_module(File, Src, Reexport) :- ( catch(xref_public_list(File, Path, Public, Src), _, fail) - -> assert_import(Src, Public, Path), + -> assert_import(Src, Public, _, Path, Reexport), ( File = library(chr) % hacky -> assert(mode(chr, Src)) ; true @@ -857,30 +916,103 @@ process_use_module(File, Src) :- ; true ). -process_pce_import(Name/Arity, Src, Path) :- +process_pce_import(Name/Arity, Src, Path, Reexport) :- atom(Name), integer(Arity), !, functor(Term, Name, Arity), ( \+ system_predicate(Term), \+ Term = pce_error(_) % hack!? - -> assert_import(Src, Name/Arity, Path) + -> assert_import(Src, [Name/Arity], _, Path, Reexport) ; true ). -process_pce_import(op(P,T,N), Src, _) :- +process_pce_import(op(P,T,N), Src, _, _) :- xref_push_op(Src, P, T, N). %% xref_public_list(+File, -Path, -Public, +Src) -% -% Find File as referenced from Src. Unify Path with the an -% absolute path to the referenced source and Public with a -% Name/Arity list holding all the public predicates exported from -% that (module) file. +% +% Find File as referenced from Src. Unify Path with the an +% absolute path to the referenced source and Public with the +% export list of that (module) file. Exports are produced by the +% :- module/2 directive and all subsequent :- reexport directives. xref_public_list(File, Path, Public, Src) :- + xref_public_list(File, Path, Src, Public, []). + +xref_public_list(File, Path, Src, Public, Rest) :- xref_source_file(File, Path, Src), prolog_open_source(Path, Fd), % skips possible #! line - call_cleanup(read(Fd, ModuleDecl), prolog_close_source(Fd)), - ModuleDecl = (:- module(_, Public)). + call_cleanup(read_public(Fd, Src, Public, Rest), + prolog_close_source(Fd)). + +read_public(In, File, Public, Rest) :- + read(In, (:- module(_, Export))), + append(Export, Reexport, Public), + read(In, ReexportDecl), + read_reexport(ReexportDecl, In, File, Reexport, Rest). + +read_reexport((:- reexport(Spec)), In, File, Reexport, Rest) :- !, + reexport_files(Spec, File, Reexport, Rest0), + read(In, ReexportDecl), + read_reexport(ReexportDecl, In, File, Rest0, Rest). +read_reexport((:- reexport(Spec, Import)), In, File, Reexport, Rest) :- !, + public_from_import(Import, Spec, File, Reexport, Rest0), + read(In, ReexportDecl), + read_reexport(ReexportDecl, In, File, Rest0, Rest). +read_reexport(_, _, _, Rest, Rest). + + +reexport_files([], _, Public, Public) :- !. +reexport_files([H|T], Src, Public, Rest) :- !, + xref_public_list(H, _, Src, Public, Rest0), + reexport_files(T, Src, Rest0, Rest). +reexport_files(Spec, Src, Public, Rest) :- + xref_public_list(Spec, Src, Public, Rest). + +public_from_import(except(Map), File, Src, Export, Rest) :- !, + xref_public_list(File, _, Public, Src), + except(Map, Public, Export, Rest). +public_from_import(Import, _, _, Export, Rest) :- + import_name_map(Import, Export, Rest). + + +except([], Public, Export, Rest) :- + append(Public, Rest, Export). +except([PI0 as NewName|Map], Public, Export, Rest) :- !, + canonical_pi(PI0, PI), + map_as(Public, PI, NewName, Public2), + except(Map, Public2, Export, Rest). +except([PI0|Map], Public, Export, Rest) :- + canonical_pi(PI0, PI), + select(PI2, Public, Public2), + same_pi(PI, PI2), !, + except(Map, Public2, Export, Rest). + + +map_as([PI|T], Repl, As, [PI2|T]) :- + same_pi(Repl, PI), !, + pi_as(PI, As, PI2). +map_as([H|T0], Repl, As, [H|T]) :- + map_as(T0, Repl, As, T). + +pi_as(_/Arity, Name, Name/Arity). +pi_as(_//Arity, Name, Name//Arity). + +import_name_map([], L, L). +import_name_map([_/Arity as NewName|T0], [NewName/Arity|T], Tail) :- !, + import_name_map(T0, T, Tail). +import_name_map([_//Arity as NewName|T0], [NewName//Arity|T], Tail) :- !, + import_name_map(T0, T, Tail). +import_name_map([H|T0], [H|T], Tail) :- + import_name_map(T0, T, Tail). + +canonical_pi(Name//Arity0, PI) :- + integer(Arity0), !, + PI = Name/Arity, + Arity is Arity0 + 2. +canonical_pi(PI, PI). + +same_pi(Canonical, PI2) :- + canonical_pi(PI2, Canonical). /******************************* @@ -906,7 +1038,7 @@ read_src_to_terms(File, Src, Terms) :- prolog_open_source(Path, Fd), call_cleanup(read_clauses(Fd, Terms), prolog_close_source(Fd)). - + read_clauses(In, Terms) :- read_clause(In, C0), read_clauses(C0, In, Terms). @@ -918,7 +1050,7 @@ read_clauses(Term, In, [Term|T]) :- %% process_foreign(+Spec, +Src) -% +% % Process a load_foreign_library/1 call. process_foreign(Spec, Src) :- @@ -1068,7 +1200,7 @@ assert_called(Src, Origin, Goal) :- assert(called(Term, Src, OTerm)). %% hide_called(:Callable) -% +% % Goals that should not turn up as being called. Hack. Eventually % we should deal with that using an XPCE plugin. @@ -1091,27 +1223,56 @@ assert_foreign(Src, Goal) :- flag(xref_src_line, Line, Line), assert(foreign(Term, Src, Line)). -%% assert_import(+Src, +ImportList, +From) is det. -%% assert_import(+Src, +ImportList, +PublicList, +From) is det. +%% assert_import(+Src, +Import, +PublicList, +From, +Reexport) is det. +% +% Asserts imports into Src. Import is the import specification, +% PublicList is the list of known public predicates or unbound if +% this need not be checked and From is the file from which the +% public predicates come. If Reexport is =true=, re-export the +% imported predicates. +% +% @tbd Tighter type-checking on Import. -assert_import(Src, Import, From) :- - assert_import(Src, Import, _, From). - -assert_import(_, [], _, _) :- !. -assert_import(Src, [H|T], Public, From) :- !, - assert_import(Src, H, Public, From), - assert_import(Src, T, Public, From). -assert_import(Src, Name/Arity, Public, From) :- - atom(Name), integer(Arity), !, +assert_import(_, [], _, _, _) :- !. +assert_import(Src, [H|T], Public, From, Reexport) :- !, + assert_import(Src, H, Public, From, Reexport), + assert_import(Src, T, Public, From, Reexport). +assert_import(Src, except(Except), Public, From, Reexport) :- !, + is_list(Public), !, + except(Except, Public, Import, []), + assert_import(Src, Import, _All, From, Reexport). +assert_import(Src, Import as Name, Public, From, Reexport) :- !, + pi_to_head(Import, Term0), + functor(Term0, _OldName, Arity), functor(Term, Name, Arity), - ( member(Name/Arity, Public) - -> assert(imported(Term, Src, From)) + ( in_public_list(Term0, Public) + -> assert(imported(Term, Src, From)), + assert_reexport(Reexport, Src, Term) + ; flag(xref_src_line, Line, Line), + assert_called(Src, ''(Line), Term0) + ). +assert_import(Src, Import, Public, From, Reexport) :- + pi_to_head(Import, Term), !, + ( in_public_list(Term, Public) + -> assert(imported(Term, Src, From)), + assert_reexport(Reexport, Src, Term) ; flag(xref_src_line, Line, Line), assert_called(Src, ''(Line), Term) ). -assert_import(Src, op(P,T,N), _, _) :- +assert_import(Src, op(P,T,N), _, _, _) :- xref_push_op(Src, P,T,N). +in_public_list(_Head, Public) :- + var(Public), !. +in_public_list(Head, Public) :- + member(Export, Public), + pi_to_head(Export, Head). + +assert_reexport(false, _, _) :- !. +assert_reexport(true, Src, Term) :- + assert(exported(Term, Src)). + + %% assert_op(+Src, +Op) is det. % % @param Op Ground term op(Priority, Type, Name). @@ -1123,34 +1284,22 @@ assert_op(Src, op(P,T,_:N)) :- ). %% assert_module(+Src, +Module) -% +% % Assert we are loading code into Module. This is also used to % exploit local term-expansion and other rules. -assert_module(Src, $(Module)) :- % deal with system modules - atom(Module), !, - atom_concat($, Module, Name), - assert_module(Src, Name). assert_module(Src, Module) :- xmodule(Module, Src), !. assert_module(Src, Module) :- '$set_source_module'(_, Module), - assert(xmodule(Module, Src)), - ( sub_atom(Module, 0, _, _, $) - -> style_check(+dollar) - ; true - ). + assert(xmodule(Module, Src)). assert_export(_, []) :- !. -assert_export(Src, [H|T]) :- +assert_export(Src, [H|T]) :- !, assert_export(Src, H), assert_export(Src, T). -assert_export(Src, Name0/Arity) :- - ( Name0 = $(Hidden) % deal with system modules - -> atom_concat($, Hidden, Name) - ; Name = Name0 - ), - functor(Term, Name, Arity), +assert_export(Src, PI) :- + pi_to_head(PI, Term), !, assert(exported(Term, Src)). assert_export(Src, op(P, A, N)) :- xref_push_op(Src, P, A, N). @@ -1159,8 +1308,8 @@ assert_dynamic(Src, (A, B)) :- !, assert_dynamic(Src, A), assert_dynamic(Src, B). assert_dynamic(_, _M:_Name/_Arity) :- !. % not local -assert_dynamic(Src, Name/Arity) :- - functor(Term, Name, Arity), +assert_dynamic(Src, PI) :- + pi_to_head(PI, Term), ( thread_local(Term, Src, _) % dynamic after thread_local has -> true % no effect ; flag(xref_src_line, Line, Line), @@ -1171,8 +1320,8 @@ assert_thread_local(Src, (A, B)) :- !, assert_thread_local(Src, A), assert_thread_local(Src, B). assert_thread_local(_, _M:_Name/_Arity) :- !. % not local -assert_thread_local(Src, Name/Arity) :- - functor(Term, Name, Arity), +assert_thread_local(Src, PI) :- + pi_to_head(PI, Term), flag(xref_src_line, Line, Line), assert(thread_local(Term, Src, Line)). @@ -1180,11 +1329,25 @@ assert_multifile(Src, (A, B)) :- !, assert_multifile(Src, A), assert_multifile(Src, B). assert_multifile(_, _M:_Name/_Arity) :- !. % not local -assert_multifile(Src, Name/Arity) :- - functor(Term, Name, Arity), +assert_multifile(Src, PI) :- + pi_to_head(PI, Term), flag(xref_src_line, Line, Line), assert(multifile(Term, Src, Line)). +%% pi_to_head(+PI, -Head) is semidet. +% +% Translate Name/Arity or Name//Arity to a callable term. Fails if +% PI is not a predicate indicator. + +pi_to_head(Var, _) :- + var(Var), !, fail. +pi_to_head(Name/Arity, Term) :- + functor(Term, Name, Arity). +pi_to_head(Name//DCGArity, Term) :- + Arity is DCGArity+2, + functor(Term, Name, Arity). + + assert_used_class(Src, Name) :- used_class(Name, Src), !. assert_used_class(Src, Name) :- @@ -1220,7 +1383,7 @@ assert_defined_class(Src, Name, imported_from(File)) :- ********************************/ %% generalise(+Callable, -General) -% +% % Generalise a callable term. generalise(Var, Var) :- @@ -1259,7 +1422,7 @@ hooking can be databases, (HTTP) URIs, etc. %% xref_source_file(+Spec, -File, +Src) is semidet. %% xref_source_file(+Spec, -File, +Src, +Options) is semidet. -% +% % Find named source file from Spec, relative to Src. xref_source_file(Plain, File, Source) :- @@ -1273,7 +1436,7 @@ xref_source_file(Plain, File, Source, Options) :- ; atom(Source), file_directory_name(Source, Dir) ), - concat_atom([Dir, /, Plain], Spec), + atomic_list_concat([Dir, /, Plain], Spec), do_xref_source_file(Spec, File, Options), !. xref_source_file(Spec, File, _, Options) :- do_xref_source_file(Spec, File, Options), !. diff --git a/Makefile.in b/Makefile.in index 456122f3e..bbfae6c2b 100755 --- a/Makefile.in +++ b/Makefile.in @@ -98,7 +98,7 @@ YAPLIB=@YAPLIB@ #4.1VPATH=@srcdir@:@srcdir@/OPTYap CWD=$(PWD) # -VERSION=6.0.0 +VERSION=6.0.1 MYDDAS_VERSION=MYDDAS-0.9.1 # @@ -219,7 +219,9 @@ PL_SOURCES= \ $(srcdir)/pl/directives.yap \ $(srcdir)/pl/eam.yap \ $(srcdir)/pl/eval.yap \ - $(srcdir)/pl/errors.yap $(srcdir)/pl/grammar.yap \ + $(srcdir)/pl/errors.yap \ + $(srcdir)/pl/flags.yap \ + $(srcdir)/pl/grammar.yap \ $(srcdir)/pl/ground.yap \ $(srcdir)/pl/hacks.yap \ $(srcdir)/pl/init.yap \ diff --git a/docs/yap.tex b/docs/yap.tex index e7a2f2a01..331c6c478 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -8,9 +8,9 @@ a\input texinfo @c -*- mode: texinfo; coding: latin-1; -*- @c @setchapternewpage odd @c %**end of header -@set VERSION 6.0.0 -@set EDITION 4.2.5 -@set UPDATED June 2008 +@set VERSION 6.0.1 +@set EDITION 4.2.6 +@set UPDATED Feb 2010 @c Index for C-Prolog compatible predicate @defindex cy @@ -6395,6 +6395,7 @@ Grammar related built-in predicates: @table @code +@item @var{CurrentModule}:expand_term(@var{T},-@var{X}) @item user:expand_term(@var{T},-@var{X}) @findex expand_term/2 @syindex expand_term/2 @@ -6405,11 +6406,12 @@ Grammar related built-in predicates: This predicate is used by YAP for preprocessing each top level term read when consulting a file and before asserting or executing it. It rewrites a term @var{T} to a term @var{X} according to the following -rules: first try to use the user defined predicate +rules: first try @code{term_expansion/2} in the current module, and then try to use the user defined predicate @code{user:term_expansion/2}. If this call fails then the translating process for DCG rules is applied, together with the arithmetic optimizer whenever the compilation of arithmetic expressions is in progress. +@item @var{CurrentModule}:goal_expansion(+@var{G},+@var{M},-@var{NG}) @item user:goal_expansion(+@var{G},+@var{M},-@var{NG}) @findex goal_expansion/3 @snindex goal_expansion/3 @@ -6544,7 +6546,7 @@ Execute a new shell. @snindex alarm/3 @cnindex alarm/3 Arranges for YAP to be interrupted in @var{Seconds} seconds, or in -@var{Seconds.MicroSeconds}. When interrupted, YAP will execute +@var{[Seconds|MicroSeconds]}. When interrupted, YAP will execute @var{Callable} and then return to the previous execution. If @var{Seconds} is @code{0}, no new alarm is scheduled. In any event, any previously set alarm is canceled. @@ -7766,6 +7768,11 @@ procedures. If @code{on} compile predicates so that they will output profiling information. Profiling data can be read through the @code{profile_data/3} built-in. +@item prompt_alternatives_on(atom, changeable) +@findex prompt_alternatives_on (yap_flag/2 option) +SWI-Compatible opttion, determines prompting for alternatives in the Prolog toplevel. Default is @t{groundness}, YAP prompts for alternatives if and only if the query contains variables. The alternative, default in SWI-Prolog is @t{determinism} which implies the system prompts for alternatives if the goal succeeded while leaving choicepoints. + + @item redefine_warnings @findex discontiguous_warnings (yap_flag/2 option) @* @@ -7936,6 +7943,11 @@ prompts from the system were redirected to the stream automatically redirects the @code{user_error} alias to the original @code{stderr}. +@item user_flags +@findex user_flags (yap_flag/2 option) +@* +Define the behaviour of @code{set_prolog_flag/2} if the flag is not known. Values are @code{silent}, @code{warning} and @code{error}. The first two create the flag on-the-fly, with @code{warning} printing a message. The value @code{error} is consistent with ISO: it raises an existence error and does not create the flag. See also @code{create_prolog_flag/3}. The default is@code{error}, and developers are encouraged to use @code{create_prolog_flag/3} to create flags for their library. + @item user_input @findex user_input (yap_flag/2 option) @* @@ -8141,15 +8153,28 @@ Stream currently being read in. Stream position at the stream currently being read in. @end table - -@end table - @item source_location(?@var{FileName}, ?@var{Line}) @findex source_location/2 @syindex source_location/2 @cnindex source_location/2 SWI-compatible predicate. If the last term has been read from a physical file (i.e., not from the file user or a string), unify File with an absolute path to the file and Line with the line-number in the file. Please use @code{prolog_load_context/2}. +@item source_file(?@var{File}) +@findex source_file/1 +@syindex source_file/1 +@cnindex source_file/1 +SWI-compatible predicate. True if @var{File} is a loaded Prolog source file. + +@item source_file(?@var{ModuleAndPred},?@var{File}) +@findex source_file/2 +@syindex source_file/2 +@cnindex source_file/2 +SWI-compatible predicate. True if the predicate specified by @var{ModuleAndPred} was loaded from file @var{File}, where @var{File} is an absolute path name (see @code{absolute_file_name/2}). + + + +@end table + @node Library, SWI-Prolog, Built-ins, Top @chapter Library Predicates diff --git a/library/Makefile.in b/library/Makefile.in index da52ed7b2..5dd3d578c 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -34,7 +34,7 @@ PROGRAMS= \ $(srcdir)/bhash.yap \ $(srcdir)/charsio.yap \ $(srcdir)/cleanup.yap \ - $(srcdir)/clpfd.pl \ + $(srcdir)/clp/clpfd.pl \ $(srcdir)/dbqueues.yap \ $(srcdir)/dbusage.yap \ $(srcdir)/dgraphs.yap \ diff --git a/library/clp/clp_distinct.pl b/library/clp/clp_distinct.pl new file mode 100644 index 000000000..3372886f3 --- /dev/null +++ b/library/clp/clp_distinct.pl @@ -0,0 +1,261 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Markus Triska + E-mail: triska@gmx.at + WWW: http://www.swi-prolog.org + Copyright (C): 2005, Markus Triska + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(clp_distinct, + [ + vars_in/2, + vars_in/3, + all_distinct/1 + ]). +:- use_module(library(lists)). + +/** Weak arc consistent all_distinct/1 constraint + +@deprecated Superseded by library(clpfd)'s all_distinct/1. +@author Markus Triska +*/ + +% For details, see Neng-Fa Zhou, 2005: +% "Programming Finite-Domain Constraint Propagators in Action Rules" + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This library uses the following arribute value: + + dom_neq(Domain, Left, Right) + +Domain is an unbounded (GMP) integer representing the domain as a +bit-vector, meaning N is in the domain iff 0 =\= Domain /\ (1< + ( get_attr(V, clp_distinct, dom_neq(VBV,VLeft,VRight)) -> + Bitvec1 is VBV /\ Bitvec, + Bitvec1 =\= 0, + ( popcount(Bitvec1) =:= 1 -> + V is msb(Bitvec1) + ; + put_attr(V, clp_distinct, dom_neq(Bitvec1,VLeft,VRight)) + ) + ; + ( popcount(Bitvec) =:= 1 -> + V is msb(Bitvec) + ; + put_attr(V, clp_distinct, dom_neq(Bitvec, [], [])) + ) + ) + ; + 0 =\= Bitvec /\ (1< + get_attr(X, clp_distinct, dom_neq(Dom,Lefts,Rights)), + outof_reducer(Lefts, Rights, X, Dom) + ; + true + ), + outof_reducer(Xs). + +all_distinct([], _). +all_distinct([X|Right], Left) :- + \+ list_contains(Right, X), + outof(X, Left, Right), + all_distinct(Right, [X|Left]). + + +outof(X, Left, Right) :- + ( var(X) -> + get_attr(X, clp_distinct, dom_neq(Dom, XLefts, XRights)), + put_attr(X, clp_distinct, dom_neq(Dom, [Left|XLefts], [Right|XRights])) + ; + exclude_fire([Left], [Right], X) + ). + + +exclude_fire(Lefts, Rights, E) :- + Mask is \ ( 1 << E), + exclude_fire(Lefts, Rights, E, Mask). + +exclude_fire([], [], _, _). +exclude_fire([Left|Ls], [Right|Rs], E, Mask) :- + exclude_list(Left, E, Mask), + exclude_list(Right, E, Mask), + exclude_fire(Ls, Rs, E, Mask). + + +exclude_list([], _, _). +exclude_list([V|Vs], Val, Mask) :- + ( var(V) -> + get_attr(V, clp_distinct, dom_neq(VDom0,VLefts,VRights)), + VDom1 is VDom0 /\ Mask, + VDom1 =\= 0, + ( popcount(VDom1) =:= 1 -> + V is msb(VDom1) + ; + put_attr(V, clp_distinct, dom_neq(VDom1,VLefts,VRights)) + ) + ; + V =\= Val + ), + exclude_list(Vs, Val, Mask). + +attr_unify_hook(dom_neq(Dom,Lefts,Rights), Y) :- + ( ground(Y) -> + Dom /\ (1 << Y) =\= 0, + exclude_fire(Lefts, Rights, Y) + ; + + \+ lists_contain(Lefts, Y), + \+ lists_contain(Rights, Y), + ( get_attr(Y, clp_distinct, dom_neq(YDom0,YLefts0,YRights0)) -> + YDom1 is YDom0 /\ Dom, + YDom1 =\= 0, + ( popcount(YDom1) =:= 1 -> + Y is msb(YDom1) + ; + append(YLefts0, Lefts, YLefts1), + append(YRights0, Rights, YRights1), + put_attr(Y, clp_distinct, dom_neq(YDom1,YLefts1,YRights1)) + ) + ; + put_attr(Y, clp_distinct, dom_neq(Dom,Lefts,Rights)) + ) + ). + +lists_contain([X|Xs], Y) :- + ( list_contains(X, Y) -> + true + ; + lists_contain(Xs, Y) + ). + +list_contains([X|Xs], Y) :- + ( X == Y -> + true + ; + list_contains(Xs, Y) + ). + + +outof_reducer([], [], _, _). +outof_reducer([L|Ls], [R|Rs], Var, Dom) :- + append(L, R, Others), + N is popcount(Dom), + num_subsets(Others, Dom, 0, Num), + ( Num >= N -> + fail + ; Num =:= (N - 1) -> + reduce_from_others(Others, Dom) + ; + true + ), + outof_reducer(Ls, Rs, Var, Dom). + + +reduce_from_others([], _). +reduce_from_others([X|Xs], Dom) :- + ( var(X) -> + get_attr(X, clp_distinct, dom_neq(XDom,XLeft,XRight)), + ( is_subset(Dom, XDom) -> + true + ; + NXDom is XDom /\ \Dom, + NXDom =\= 0, + ( popcount(NXDom) =:= 1 -> + X is msb(NXDom) + ; + put_attr(X, clp_distinct, dom_neq(NXDom,XLeft,XRight)) + ) + ) + ; + true + ), + reduce_from_others(Xs, Dom). + +num_subsets([], _Dom, Num, Num). +num_subsets([S|Ss], Dom, Num0, Num) :- + ( var(S) -> + get_attr(S, clp_distinct, dom_neq(SDom,_,_)), + ( is_subset(Dom, SDom) -> + Num1 is Num0 + 1 + ; + Num1 = Num0 + ) + ; + Num1 = Num0 + ), + num_subsets(Ss, Dom, Num1, Num). + + + % true iff S is a subset of Dom - should be a GMP binding (subsumption) + +is_subset(Dom, S) :- + S \/ Dom =:= Dom. + +attr_portray_hook(dom_neq(Dom,_,_), _) :- + Max is msb(Dom), + Min is lsb(Dom), + write(Min-Max). diff --git a/library/clp/clp_events.pl b/library/clp/clp_events.pl new file mode 100644 index 000000000..349348842 --- /dev/null +++ b/library/clp/clp_events.pl @@ -0,0 +1,89 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Tom Schrijvers + E-mail: tom.schrijvers@cs.kuleuven.ac.be + WWW: http://www.swi-prolog.org + Copyright (C): 2005, K.U.Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Module for managing constraint solver events. +% +% Author: Tom Schrijvers +% E-mail: tom.schrijvers@cs.kuleuven.ac.be +% Copyright: 2005, K.U.Leuven +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:-module(clp_events, + [ + notify/2, + subscribe/4, + unsubscribe/2 + ]). + +notify(V,NMod) :- + ( get_attr(V,clp_events,List) -> + notify_list(List,NMod) + ; + true + ). + +subscribe(V,NMod,SMod,Goal) :- + ( get_attr(V,clp_events,List) -> + put_attr(V,clp_events,[entry(NMod,SMod,Goal)|List]) + ; + put_attr(V,clp_events,[entry(NMod,SMod,Goal)]) + ). + +unsubscribe(V,SMod) :- + ( get_attr(V,clp_events,List) -> + unsubscribe_list(List,SMod,NList), + put_attr(V,clp_events,NList) + ; + true + ). + +notify_list([],_). +notify_list([entry(Mod,_,Goal)|Rest],NMod) :- + ( Mod == NMod -> + call(Goal) + ; + true + ), + notify_list(Rest,NMod). + +unsubscribe_list([],_,_). +unsubscribe_list([Entry|Rest],SMod,List) :- + Entry = entry(_,Mod,_), + ( Mod == SMod -> + List = Rest + ; + List = [Entry|Tail], + unsubscribe_list(Rest,SMod,Tail) + ). + +attr_unify_hook(_,_). diff --git a/library/clpfd.pl b/library/clp/clpfd.pl similarity index 59% rename from library/clpfd.pl rename to library/clp/clpfd.pl index 0708fbbbe..c01e81b44 100644 --- a/library/clpfd.pl +++ b/library/clp/clpfd.pl @@ -5,7 +5,7 @@ Author: Markus Triska E-mail: triska@gmx.at WWW: http://www.swi-prolog.org - Copyright (C): 2007-2009 Markus Triska + Copyright (C): 2007-2010 Markus Triska This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License @@ -46,7 +46,7 @@ No artificial limits (using GMP) --------------------------------- - ?- N is 2**66, X #\= N. + ?- N is 2^66, X #\= N. %@ N = 73786976294838206464, %@ X in inf..73786976294838206463\/73786976294838206465..sup. @@ -61,18 +61,9 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Many things can be improved; if you want to help, feel free to - e-mail me. A good starting point is taking a propagation algorithm - from the literature and adding it - for example: - - J-C. Régin: "A filtering algorithm for constraints of difference in - CSPs", AAAI-94, Seattle, WA, USA, pp 362--367, 1994. - - You can implement this algorithm without any knowledge of Prolog or - this library. Just write an efficient C function that, given a set - of variables and their list of domain elements, uses the described - algorithm to compute the set of arcs that can be safely removed - from the value graph. + Many things can be improved; if you need any additional features or + want to help, please e-mail me. A good starting point is taking a + propagation algorithm from the literature and adding it. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ @@ -110,13 +101,20 @@ all_different/1, all_distinct/1, sum/3, + scalar_product/4, tuples_in/2, labeling/2, label/1, indomain/1, lex_chain/1, serialized/2, + global_cardinality/2, + global_cardinality/3, + circuit/1, element/3, + automaton/3, + automaton/8, + transpose/2, zcompare/3, chain/2, fd_var/1, @@ -129,7 +127,11 @@ :- expects_dialect(swi). +:- use_module(library(apply)). :- use_module(library(error)). +:- use_module(library(lists)). +:- use_module(library(pairs)). + :- op(700, xfx, cis). :- op(700, xfx, cis_geq). @@ -1074,6 +1076,11 @@ indomain(Var) :- label([Var]). order_dom_next(up, Dom, Next) :- domain_infimum(Dom, n(Next)). order_dom_next(down, Dom, Next) :- domain_supremum(Dom, n(Next)). +order_dom_next(random_value(_), Dom, Next) :- + domain_to_list(Dom, Ls), + length(Ls, L), + I is random(L), + nth0(I, Ls, Next). %% label(+Vars) @@ -1229,44 +1236,44 @@ label([], _, _, _, Consistency) :- !, ; true ). label(Vars, Selection, Order, Choice, Consistency) :- - select_var(Selection, Vars, Var, RVars), - ( var(Var) -> - ( Consistency = upto_in(I0,I), - fd_get(Var, _, Ps), - all_dead(Ps) -> - fd_size(Var, Size), - I1 is I0*Size, - label(RVars, Selection, Order, Choice, upto_in(I1,I)) - ; Consistency = upto_in, fd_get(Var, _, Ps), all_dead(Ps) -> - label(RVars, Selection, Order, Choice, Consistency) - ; choice_order_variable(Choice, Order, Var, RVars, Selection, Consistency) + ( Vars = [V|Vs], nonvar(V) -> label(Vs, Selection, Order, Choice, Consistency) + ; select_var(Selection, Vars, Var, RVars), + ( var(Var) -> + ( Consistency = upto_in(I0,I), fd_get(Var, _, Ps), all_dead(Ps) -> + fd_size(Var, Size), + I1 is I0*Size, + label(RVars, Selection, Order, Choice, upto_in(I1,I)) + ; Consistency = upto_in, fd_get(Var, _, Ps), all_dead(Ps) -> + label(RVars, Selection, Order, Choice, Consistency) + ; choice_order_variable(Choice, Order, Var, RVars, Vars, Selection, Consistency) + ) + ; label(RVars, Selection, Order, Choice, Consistency) ) - ; label(RVars, Selection, Order, Choice, Consistency) ). -choice_order_variable(step, Order, Var, Vars, Selection, Consistency) :- +choice_order_variable(step, Order, Var, Vars, Vars0, Selection, Consistency) :- fd_get(Var, Dom, _), order_dom_next(Order, Dom, Next), ( Var = Next, label(Vars, Selection, Order, step, Consistency) ; neq_num(Var, Next), do_queue, - label([Var|Vars], Selection, Order, step, Consistency) + label(Vars0, Selection, Order, step, Consistency) ). -choice_order_variable(enum, Order, Var, Vars, Selection, Consistency) :- +choice_order_variable(enum, Order, Var, Vars, _, Selection, Consistency) :- fd_get(Var, Dom0, _), domain_direction_element(Dom0, Order, Var), label(Vars, Selection, Order, enum, Consistency). -choice_order_variable(bisect, Order, Var, Vars, Selection, Consistency) :- +choice_order_variable(bisect, Order, Var, _, Vars0, Selection, Consistency) :- fd_get(Var, Dom, _), domain_infimum(Dom, n(I)), domain_supremum(Dom, n(S)), Mid0 is (I + S) // 2, ( Mid0 =:= S -> Mid is Mid0 - 1 ; Mid = Mid0 ), ( Var #=< Mid, - label([Var|Vars], Selection, Order, bisect, Consistency) + label(Vars0, Selection, Order, bisect, Consistency) ; Var #> Mid, - label([Var|Vars], Selection, Order, bisect, Consistency) + label(Vars0, Selection, Order, bisect, Consistency) ). override(What, Prev, Value, Options, Result) :- @@ -1285,6 +1292,9 @@ selection(ffc). selection(min). selection(max). selection(leftmost). +selection(random_variable(Seed)) :- + must_be(integer, Seed), + set_random(seed(Seed)). choice(step). choice(enum). @@ -1292,6 +1302,11 @@ choice(bisect). order(up). order(down). +% TODO: random_variable and random_value currently both set the seed, +% so exchanging the options can yield different results. +order(random_value(Seed)) :- + must_be(integer, Seed), + set_random(seed(Seed)). consistency(upto_in(I), upto_in(1, I)). consistency(upto_in, upto_in). @@ -1308,11 +1323,17 @@ select_var(max, [V|Vs], Var, RVars) :- find_max(Vs, V, Var), delete_eq([V|Vs], Var, RVars). select_var(ff, [V|Vs], Var, RVars) :- - find_ff(Vs, V, Var), + fd_size_(V, n(S)), + find_ff(Vs, V, S, Var), delete_eq([V|Vs], Var, RVars). select_var(ffc, [V|Vs], Var, RVars) :- find_ffc(Vs, V, Var), delete_eq([V|Vs], Var, RVars). +select_var(random_variable(_), Vars0, Var, Vars) :- + length(Vars0, L), + I is random(L), + nth0(I, Vars0, Var), + delete_eq(Vars0, Var, Vars). find_min([], Var, Var). find_min([V|Vs], CM, Min) :- @@ -1328,11 +1349,13 @@ find_max([V|Vs], CM, Max) :- ; find_max(Vs, CM, Max) ). -find_ff([], Var, Var). -find_ff([V|Vs], CM, FF) :- - ( ff_lt(V, CM) -> - find_ff(Vs, V, FF) - ; find_ff(Vs, CM, FF) +find_ff([], Var, _, Var). +find_ff([V|Vs], CM, S0, FF) :- + ( nonvar(V) -> find_ff(Vs, CM, S0, FF) + ; ( fd_size_(V, n(S1)), S1 < S0 -> + find_ff(Vs, V, S1, FF) + ; find_ff(Vs, CM, S0, FF) + ) ). find_ffc([], Var, Var). @@ -1342,16 +1365,6 @@ find_ffc([V|Vs], Prev, FFC) :- ; find_ffc(Vs, Prev, FFC) ). -ff_lt(X, Y) :- - ( fd_get(X, DX, _) -> - domain_num_elements(DX, n(NX)) - ; NX = 1 - ), - ( fd_get(Y, DY, _) -> - domain_num_elements(DY, n(NY)) - ; NY = 1 - ), - NX < NY. ffc_lt(X, Y) :- ( fd_get(X, XD, XPs) -> @@ -1380,11 +1393,12 @@ bounds(X, L, U) :- ; L = X, U = L ). -delete_eq([],_,[]). -delete_eq([X|Xs],Y,List) :- - ( X == Y -> List = Xs +delete_eq([], _, []). +delete_eq([X|Xs], Y, List) :- + ( nonvar(X) -> delete_eq(Xs, Y, List) + ; X == Y -> List = Xs ; List = [X|Tail], - delete_eq(Xs,Y,Tail) + delete_eq(Xs, Y, Tail) ). /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1456,7 +1470,9 @@ fds_sespsize([V|Vs], S0, S) :- optimise(Vars, Options, Whats) :- Whats = [What|WhatsRest], Extremum = extremum(none), - ( store_extremum(Vars, Options, What, Extremum) + ( catch(store_extremum(Vars, Options, What, Extremum), + time_limit_exceeded, + false) ; Extremum = extremum(n(Val)), arg(1, What, Expr), append(WhatsRest, Options, Options1), @@ -1468,18 +1484,17 @@ optimise(Vars, Options, Whats) :- ). store_extremum(Vars, Options, What, Extremum) :- - duplicate_term(Vars-What, Vars1-What1), - once(labeling(Options, Vars1)), + catch((labeling(Options, Vars), throw(w(What))), w(What1), true), functor(What, Direction, _), maplist(arg(1), [What,What1], [Expr,Expr1]), optimise(Direction, Options, Vars, Expr1, Expr, Extremum). optimise(Direction, Options, Vars, Expr0, Expr, Extremum) :- - Val0 is Expr0, - nb_setarg(1, Extremum, n(Val0)), - duplicate_term(Vars-Expr, Vars1-Expr1), - tighten(Direction, Expr1, Val0), - once(labeling(Options, Vars1)), + must_be(ground, Expr0), + nb_setarg(1, Extremum, n(Expr0)), + catch((tighten(Direction, Expr, Expr0), + labeling(Options, Vars), + throw(v(Expr))), v(Expr1), true), optimise(Direction, Options, Vars, Expr1, Expr, Extremum). tighten(min, E, V) :- E #< V. @@ -1493,20 +1508,22 @@ tighten(max, E, V) :- E #> V. all_different(Ls) :- must_be(list, Ls), - all_different(Ls, [], _), + maplist(fd_variable, Ls), + put_attr(Orig, clpfd_original, all_different(Ls)), + all_different(Ls, [], Orig), do_queue. all_different([], _, _). -all_different([X|Right], Left, State) :- +all_different([X|Right], Left, Orig) :- ( var(X) -> - make_propagator(pdifferent(Left,Right,X,State), Prop), + make_propagator(pdifferent(Left,Right,X,Orig), Prop), init_propagator(X, Prop), trigger_prop(Prop) ; exclude_fire(Left, Right, X) ), - all_different(Right, [X|Left], State). + all_different(Right, [X|Left], Orig). -%% sum(+Vars, +Rel, +Expr) +%% sum(+Vars, +Rel, ?Expr) % % The sum of elements of the list Vars is in relation Rel to Expr. For % example: @@ -1519,38 +1536,59 @@ all_different([X|Right], Left, State) :- % C in 0..100. % == -scalar_supported(#=). -scalar_supported(#\=). +sum(Vs, Op, Value) :- + must_be(list, Vs), + length(Vs, L), + length(Ones, L), + maplist(=(1), Ones), + scalar_product(Ones, Vs, Op, Value). -sum(Ls, Op, Value) :- - must_be(list, Ls), - maplist(fd_variable, Ls), +vars_plusterm([], _, T, T). +vars_plusterm([C|Cs], [V|Vs], T0, T) :- vars_plusterm(Cs, Vs, T0+(C*V), T). + +%% scalar_product(+Cs, +Vs, +Rel, ?Expr) +% +% Cs is a list of integers, Vs is a list of variables and integers. +% True if the scalar product of Cs and Vs is in relation Rel to Expr. + +scalar_product(Cs, Vs, Op, Value) :- + must_be(list(integer), Cs), + must_be(list, Vs), must_be(callable, Op), - ( scalar_supported(Op), - vars_plusterm(Ls, 0, Left), - left_right_linsum_const(Left, Value, Cs, Vs, Const) -> - scalar_product(Cs, Vs, Op, Const) - ; sum(Ls, 0, Op, Value) + maplist(fd_variable, Vs), + \+ cyclic_term(Value), + ( memberchk(Op, [#=,#\=,#<,#>,#=<,#>=]) -> true + ; domain_error(scalar_product_relation, Op) + ), + vars_plusterm(Cs, Vs, 0, Left), + ( left_right_linsum_const(Left, Value, Cs1, Vs1, Const) -> + scalar_product_(Op, Cs1, Vs1, Const) + ; sum(Cs, Vs, 0, Op, Value) ). -vars_plusterm([], T, T). -vars_plusterm([V|Vs], T0, T) :- vars_plusterm(Vs, T0+V, T). +sum([], _, Sum, Op, Value) :- call(Op, Sum, Value). +sum([C|Cs], [X|Xs], Acc, Op, Value) :- + NAcc #= Acc + C*X, + sum(Cs, Xs, NAcc, Op, Value). -scalar_product(Cs, Vs, Op, C) :- - make_propagator(scalar_product(Cs,Vs,Op,C), Prop), - vs_propagator(Vs, Prop), - trigger_prop(Prop), - do_queue. +scalar_product_(#=, Cs, Vs, C) :- + propagator_init_trigger(Vs, scalar_product_eq(Cs, Vs, C)). +scalar_product_(#\=, Cs, Vs, C) :- + propagator_init_trigger(Vs, scalar_product_neq(Cs, Vs, C)). +scalar_product_(#=<, Cs, Vs, C) :- + propagator_init_trigger(Vs, scalar_product_leq(Cs, Vs, C)). +scalar_product_(#<, Cs, Vs, C) :- + C1 is C - 1, + scalar_product_(#=<, Cs, Vs, C1). +scalar_product_(#>, Cs, Vs, C) :- + C1 is C + 1, + scalar_product_(#>=, Cs, Vs, C1). +scalar_product_(#>=, Cs, Vs, C) :- + maplist(negative, Cs, Cs1), + C1 is -C, + scalar_product_(#=<, Cs1, Vs, C1). -vs_propagator([], _). -vs_propagator([V|Vs], Prop) :- - init_propagator(V, Prop), - vs_propagator(Vs, Prop). - -sum([], Sum, Op, Value) :- call(Op, Sum, Value). -sum([X|Xs], Acc, Op, Value) :- - NAcc #= Acc + X, - sum(Xs, NAcc, Op, Value). +negative(X0, X) :- X is -X0. coeffs_variables_const([], [], [], [], I, I). coeffs_variables_const([C|Cs], [V|Vs], Cs1, Vs1, I0, I) :- @@ -1620,6 +1658,24 @@ remove_dist_upper_lower([C|Cs], [V|Vs], D1, D2) :- ), remove_dist_upper_lower(Cs, Vs, D1, D2). + +remove_dist_upper_leq([], _, _). +remove_dist_upper_leq([C|Cs], [V|Vs], D1) :- + ( fd_get(V, VD, VPs) -> + ( C < 0 -> + domain_supremum(VD, n(Sup)), + L is Sup + D1//C, + domain_remove_smaller_than(VD, L, VD1) + ; domain_infimum(VD, n(Inf)), + G is Inf + D1//C, + domain_remove_greater_than(VD, G, VD1) + ), + fd_put(V, VD1, VPs) + ; true + ), + remove_dist_upper_leq(Cs, Vs, D1). + + remove_dist_upper([], _). remove_dist_upper([C*V|CVs], D) :- ( fd_get(V, VD, VPs) -> @@ -1697,24 +1753,28 @@ remove_lower([C*X|CXs], Min) :- new ones, until fixpoint. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ -% % LIFO queue -% make_queue :- nb_setval('$propagator_queue',[]). - -% push_queue(E) :- -% b_getval('$propagator_queue',Q), -% b_setval('$propagator_queue',[E|Q]). -% pop_queue(E) :- -% b_getval('$propagator_queue',[E|Q]), -% b_setval('$propagator_queue',Q). - - % FIFO queue -make_queue :- nb_setval('$clpfd_queue', Q-Q). -push_queue(E) :- - b_getval('$clpfd_queue', H-[E|T]), b_setval('$clpfd_queue', H-T). + +make_queue :- nb_setval('$clpfd_queue', fast_slow(Q-Q, L-L)). + +push_fast_queue(E) :- + b_getval('$clpfd_queue', fast_slow(H-[E|T], L)), + b_setval('$clpfd_queue', fast_slow(H-T, L)). + +push_slow_queue(E) :- + b_getval('$clpfd_queue', fast_slow(L, H-[E|T])), + b_setval('$clpfd_queue', fast_slow(L, H-T)). + pop_queue(E) :- - b_getval('$clpfd_queue', H-T), - nonvar(H), H = [E|NH], b_setval('$clpfd_queue', NH-T). + b_getval('$clpfd_queue', fast_slow(H-T, I-U)), + ( nonvar(H) -> + H = [E|NH], + b_setval('$clpfd_queue', fast_slow(NH-T, I-U)) + ; nonvar(I) -> + I = [E|NI], + b_setval('$clpfd_queue', fast_slow(H-T, NI-U)) + ; false + ). fetch_propagator(Prop) :- pop_queue(P), @@ -1722,10 +1782,6 @@ fetch_propagator(Prop) :- ; Prop = P ). -:- thread_initialization((make_queue, - nb_setval('$clpfd_current_propagator', []), - nb_setval('$clpfd_queue_status', enabled))). - /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Parsing a CLP(FD) expression has two important side-effects: First, it constrains the variables occurring in the expression to @@ -1749,55 +1805,110 @@ power_var_num(P, X, N) :- N is L + R ). -parse_clpfd(Expr, Result) :- - ( cyclic_term(Expr) -> domain_error(clpfd_expression, Expr) - ; var(Expr) -> - constrain_to_integer(Expr), - Result = Expr - ; integer(Expr) -> Result = Expr - ; Expr = (L + R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - myplus(RL, RR, Result) - ; power_var_num(Expr, Var, N) -> Var^N #= Result - ; Expr = (L * R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - mytimes(RL, RR, Result) - ; Expr = (L - R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - mytimes(-1, RR, RRR), - myplus(RL, RRR, Result) - ; Expr = (- E) -> - parse_clpfd(E, RE), - mytimes(-1, RE, Result) - ; Expr = max(L, R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - mymax(RL, RR, Result) - ; Expr = min(L,R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - mymin(RL, RR, Result) - ; Expr = L mod R -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - RR #\= 0, - mymod(RL, RR, Result) - ; Expr = abs(E) -> - parse_clpfd(E, RE), - myabs(RE, Result), - Result #>= 0 - ; Expr = (L / R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), RR #\= 0, - mydiv(RL, RR, Result) - ; Expr = (L ^ R) -> - parse_clpfd(L, RL), parse_clpfd(R, RR), - myexp(RL, RR, Result) - ; domain_error(clpfd_expression, Expr) - ). +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Given expression E, we obtain the finite domain variable R by + interpreting a simple committed-choice language that is a list of + conditions and bodies. In conditions, g(Goal) means literally Goal, + and m(Match) means that E can be decomposed as stated. The + variables are to be understood as the result of parsing the + subexpressions recursively. In the body, g(Goal) means again Goal, + and p(Propagator) means to attach and trigger once a propagator. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +parse_clpfd(E, R, + [(g(cyclic_term(E)) -> [g(domain_error(clpfd_expression, E))]), + (g(var(E)) -> [g(constrain_to_integer(E)), g(E = R)]), + (g(integer(E)) -> [g(R = E)]), + (m(A+B) -> [p(pplus(A, B, R))]), + % power_var_num/3 must occur before */2 to be useful + (g(power_var_num(E, V, N)) -> [p(pexp(V, N, R))]), + (m(A*B) -> [p(ptimes(A, B, R))]), + (m(A-B) -> [p(pplus(R,B,A))]), + (m(-A) -> [p(ptimes(-1,A,R))]), + (m(max(A,B)) -> [g(A #=< R), g(B #=< R), p(pmax(A, B, R))]), + (m(min(A,B)) -> [g(A #>= R), g(B #>= R), p(pmin(A, B, R))]), + (m(mod(A,B)) -> [g(B #\= 0), p(pmod(A, B, R))]), + (m(abs(A)) -> [g(R #>= 0), p(pabs(A, R))]), + (m(A/B) -> [g(B #\= 0), p(pdiv(A, B, R))]), + (m(A^B) -> [p(pexp(A, B, R))]), + (g(true) -> [g(domain_error(clpfd_expression, E))]) + ]). + +% Here, we compile the committed choice language to a single +% predicate, parse_clpfd/2. + +make_parse_clpfd(Clauses) :- + parse_clpfd_clauses(Clauses0), + maplist(goals_goal, Clauses0, Clauses). + +goals_goal((Head :- Goals), (Head :- Body)) :- + list_goal(Goals, Body). + +parse_clpfd_clauses(Clauses) :- + parse_clpfd(E, R, Matchers), + maplist(parse_matcher(E, R), Matchers, Clauses). + +parse_matcher(E, R, Matcher, Clause) :- + Matcher = (Condition0 -> Goals0), + phrase((parse_condition(Condition0, E, Head), + parse_goals(Goals0)), Goals), + Clause = (parse_clpfd(Head, R) :- Goals). + +parse_condition(g(Goal), E, E) --> [Goal, !]. +parse_condition(m(Match), _, Match0) --> + { copy_term(Match, Match0) }, + [!], + { term_variables(Match0, Vs0), + term_variables(Match, Vs) + }, + parse_match_variables(Vs0, Vs). + +parse_match_variables([], []) --> []. +parse_match_variables([V0|Vs0], [V|Vs]) --> + [parse_clpfd(V0, V)], + parse_match_variables(Vs0, Vs). + +parse_goals([]) --> []. +parse_goals([G|Gs]) --> parse_goal(G), parse_goals(Gs). + +parse_goal(g(Goal)) --> [Goal]. +parse_goal(p(Prop)) --> + [make_propagator(Prop, P)], + { term_variables(Prop, Vs) }, + parse_init(Vs, P), + [trigger_once(P)]. + +parse_init([], _) --> []. +parse_init([V|Vs], P) --> [init_propagator(V, P)], parse_init(Vs, P). + +%?- set_prolog_flag(toplevel_print_options, [portray(true)]), +% clpfd:parse_clpfd_clauses(Clauses), maplist(portray_clause, Clauses). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% trigger_once(Prop) :- trigger_prop(Prop), do_queue. -neq(A, B) :- - make_propagator(pneq(A, B), Prop), - init_propagator(A, Prop), init_propagator(B, Prop), - trigger_once(Prop). +neq(A, B) :- propagator_init_trigger(pneq(A, B)). + +propagator_init_trigger(P) --> + { term_variables(P, Vs) }, + propagator_init_trigger(Vs, P). + +propagator_init_trigger(Vs, P) --> + [p(Prop)], + { make_propagator(P, Prop), + maplist(prop_init(Prop), Vs), + trigger_once(Prop) }. + +propagator_init_trigger(P) :- + phrase(propagator_init_trigger(P), _). + +propagator_init_trigger(Vs, P) :- + phrase(propagator_init_trigger(Vs, P), _). + +prop_init(Prop, V) :- init_propagator(V, Prop). geq(A, B) :- ( fd_get(A, AD, APs) -> @@ -1805,10 +1916,7 @@ geq(A, B) :- ( fd_get(B, BD, _) -> domain_supremum(BD, BS), ( AI cis_geq BS -> true - ; make_propagator(pgeq(A,B), Prop), - init_propagator(A, Prop), - init_propagator(B, Prop), - trigger_once(Prop) + ; propagator_init_trigger(pgeq(A,B)) ) ; domain_remove_smaller_than(AD, B, AD1), fd_put(A, AD1, APs), @@ -1821,48 +1929,6 @@ geq(A, B) :- ; A >= B ). -myplus(X, Y, Z) :- - make_propagator(pplus(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop). - -mytimes(X, Y, Z) :- - make_propagator(ptimes(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop). - -mydiv(X, Y, Z) :- - make_propagator(pdiv(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop). - -myexp(X, Y, Z) :- - make_propagator(pexp(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop). - -myabs(X, Y) :- - make_propagator(pabs(X,Y), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - trigger_prop(Prop), trigger_once(Prop). - -mymod(X, M, K) :- - make_propagator(pmod(X,M,K), Prop), - init_propagator(X, Prop), init_propagator(M, Prop), - init_propagator(K, Prop), trigger_once(Prop). - -mymax(X, Y, Z) :- - X #=< Z, Y #=< Z, - make_propagator(pmax(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop). - -mymin(X, Y, Z) :- - X #>= Z, Y #>= Z, - make_propagator(pmin(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop). - /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Naive parsing of inequalities and disequalities can result in a lot of unnecessary work if expressions of non-trivial depth are @@ -1873,8 +1939,168 @@ mymin(X, Y, Z) :- only extremal values are of interest in inequalities. Introducing auxiliary variables should be avoided when possible, and specialised propagators should be used for common constraints. + + We again use a simple committed-choice language for matching + special cases of constraints. m_c(M,C) means that M matches and C + holds. d(X, Y) means decomposition, i.e., it is short for + g(parse_clpfd(X, Y)). r(X, Y) means to rematch with X and Y. + + Two things are important: First, although the actual constraint + functors (#\=2, #=/2 etc.) are used in the description, they must + expand to the respective auxiliary predicates (match_expand/2) + because the actual constraints are subject to goal expansion. + Second, when specialised constraints (like scalar product) post + simpler constraints on their own, these simpler versions must be + handled separately and must occur before. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ +match_expand(#>=, clpfd_geq_). +match_expand(#=, clpfd_equal_). +match_expand(#\=, clpfd_neq). + +symmetric(#=). +symmetric(#\=). + +matches([ + (m_c(any(X) #>= any(Y), left_right_linsum_const(X, Y, Cs, Vs, Const)) -> + [g(( Cs = [1], Vs = [A] -> geq(A, Const) + ; Cs = [-1], Vs = [A] -> Const1 is -Const, geq(Const1, A) + ; Cs = [1,1], Vs = [A,B] -> A+B #= S, geq(S, Const) + ; Cs = [1,-1], Vs = [A,B] -> + ( Const =:= 0 -> geq(A, B) + ; C1 is -Const, + propagator_init_trigger(x_leq_y_plus_c(B, A, C1)) + ) + ; Cs = [-1,1], Vs = [A,B] -> + ( Const =:= 0 -> geq(B, A) + ; C1 is -Const, + propagator_init_trigger(x_leq_y_plus_c(A, B, C1)) + ) + ; Cs = [-1,-1], Vs = [A,B] -> + A+B #= S, Const1 is -Const, geq(Const1, S) + ; scalar_product_(#>=, Cs, Vs, Const) + ))]), + (m(any(X) - any(Y) #>= integer(C)) -> [d(X, X1), d(Y, Y1), g(C1 is -C), p(x_leq_y_plus_c(Y1, X1, C1))]), + (m(integer(X) #>= any(Z) + integer(A)) -> [g(C is X - A), r(C, Z)]), + (m(abs(any(X)-any(Y)) #>= integer(I)) -> [d(X, X1), d(Y, Y1), p(absdiff_geq(X1, Y1, I))]), + (m(abs(any(X)) #>= integer(I)) -> [d(X, RX), g((I>0 -> I1 is -I, RX in inf..I1 \/ I..sup; true))]), + (m(integer(I) #>= abs(any(X))) -> [d(X, RX), g(I>=0), g(I1 is -I), g(RX in I1..I)]), + (m(any(X) #>= any(Y)) -> [d(X, RX), d(Y, RY), g(geq(RX, RY))]), + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + (m(var(X) #= var(Y)) -> [g(constrain_to_integer(X)), g(X=Y)]), + (m(var(X) #= var(Y)+var(Z)) -> [p(pplus(Y,Z,X))]), + (m(var(X) #= var(Y)-var(Z)) -> [p(pplus(X,Z,Y))]), + (m(var(X) #= var(Y)*var(Z)) -> [p(ptimes(Y,Z,X))]), + (m(var(X) #= -var(Z)) -> [p(ptimes(-1, Z, X))]), + (m_c(any(X) #= any(Y), left_right_linsum_const(X, Y, Cs, Vs, S)) -> + [g(( Cs = [] -> S =:= 0 + ; Cs = [C|CsRest], + gcd(CsRest, C, GCD), + S mod GCD =:= 0, + scalar_product_(#=, Cs, Vs, S) + ))]), + (m(var(X) #= any(Y)) -> [d(Y,X)]), + (m(any(X) #= any(Y)) -> [d(X, RX), d(Y, RX)]), + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + (m(var(X) #\= integer(Y)) -> [g(neq_num(X, Y))]), + (m(var(X) #\= var(Y)) -> [g(neq(X,Y))]), + (m(var(X) #\= var(Y) + var(Z)) -> [p(x_neq_y_plus_z(X, Y, Z))]), + (m(var(X) #\= var(Y) - var(Z)) -> [p(x_neq_y_plus_z(Y, X, Z))]), + (m(var(X) #\= var(Y)*var(Z)) -> [p(ptimes(Y,Z,P)), g(neq(X,P))]), + (m(integer(X) #\= abs(any(Y)-any(Z))) -> [d(Y, Y1), d(Z, Z1), p(absdiff_neq(Y1, Z1, X))]), + (m_c(any(X) #\= any(Y), left_right_linsum_const(X, Y, Cs, Vs, S)) -> + [g(scalar_product_(#\=, Cs, Vs, S))]), + (m(any(X) #\= any(Y) + any(Z)) -> [d(X, X1), d(Y, Y1), d(Z, Z1), p(x_neq_y_plus_z(X1, Y1, Z1))]), + (m(any(X) #\= any(Y) - any(Z)) -> [d(X, X1), d(Y, Y1), d(Z, Z1), p(x_neq_y_plus_z(Y1, X1, Z1))]), + (m(any(X) #\= any(Y)) -> [d(X, RX), d(Y, RY), g(neq(RX, RY))]) + ]). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + We again compile the committed-choice matching language to the + intended auxiliary predicates. We now must take care not to + unintentionally unify a variable with a complex term. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +make_matches(Clauses) :- + matches(Ms), + findall(F, (member((M->_), Ms), arg(1, M, M1), functor(M1, F, _)), Fs0), + sort(Fs0, Fs), + maplist(prevent_cyclic_argument, Fs, PrevCyclicClauses), + phrase(matchers(Ms), Clauses0), + maplist(goals_goal, Clauses0, MatcherClauses), + append(PrevCyclicClauses, MatcherClauses, Clauses1), + sort_by_predicate(Clauses1, Clauses). + +sort_by_predicate(Clauses, ByPred) :- + map_list_to_pairs(predname, Clauses, Keyed), + keysort(Keyed, KeyedByPred), + pairs_values(KeyedByPred, ByPred). + +predname((H:-_), Key) :- !, predname(H, Key). +predname(M:H, M:Key) :- !, predname(H, Key). +predname(H, Name/Arity) :- !, functor(H, Name, Arity). + +prevent_cyclic_argument(F0, Clause) :- + match_expand(F0, F), + Head =.. [F,X,Y], + Clause = (Head :- ( cyclic_term(X) -> + domain_error(clpfd_expression, X) + ; cyclic_term(Y) -> + domain_error(clpfd_expression, Y) + ; false + )). + +matchers([]) --> []. +matchers([(Condition->Goals)|Ms]) --> + matcher(Condition, Goals), + matchers(Ms). + +matcher(m(M), Gs) --> matcher(m_c(M,true), Gs). +matcher(m_c(Matcher,Cond), Gs) --> + [(Head :- Goals0)], + { Matcher =.. [F,A,B], + match_expand(F, Expand), + Head =.. [Expand,X,Y], + phrase((match(A, X), match(B, Y)), Goals0, [Cond,!|Goals1]), + phrase(match_goals(Gs, Expand), Goals1) }, + ( { symmetric(F), \+ (subsumes_chk(A, B), subsumes_chk(B, A)) } -> + { Head1 =.. [Expand,Y,X] }, + [(Head1 :- Goals0)] + ; [] + ). + +match(any(A), T) --> [A = T]. +match(var(V), T) --> [v_or_i(T), V = T]. +match(integer(I), T) --> [integer(T), I = T]. +match(-X, T) --> [nonvar(T), T = -A], match(X, A). +match(abs(X), T) --> [nonvar(T), T = abs(A)], match(X, A). +match(X+Y, T) --> [nonvar(T), T = A + B], match(X, A), match(Y, B). +match(X-Y, T) --> [nonvar(T), T = A - B], match(X, A), match(Y, B). +match(X*Y, T) --> [nonvar(T), T = A * B], match(X, A), match(Y, B). + +match_goals([], _) --> []. +match_goals([G|Gs], F) --> match_goal(G, F), match_goals(Gs, F). + +match_goal(r(X,Y), F) --> { G =.. [F,X,Y] }, [G]. +match_goal(d(X,Y), _) --> [parse_clpfd(X, Y)]. +match_goal(g(Goal), _) --> [Goal]. +match_goal(p(Prop), _) --> + [make_propagator(Prop, P)], + { term_variables(Prop, Vs) }, + parse_init(Vs, P), + [trigger_once(P)]. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + %% ?X #>= ?Y % % X is greater than or equal to Y. @@ -1883,31 +2109,6 @@ X #>= Y :- clpfd_geq(X, Y). clpfd_geq(X, Y) :- clpfd_geq_(X, Y), reinforce(X), reinforce(Y). -clpfd_geq_(X, Y) :- - ( var(X), nonvar(Y), Y = Y1 - C, var(Y1), integer(C) -> - var_leq_var_plus_const(Y1, X, C) - ; var(X), nonvar(Y), Y = Y1 + C, var(Y1), integer(C) -> - C1 is -C, - var_leq_var_plus_const(Y1, X, C1) - ; nonvar(X), var(Y), X = X1 + C, var(X1), integer(C) -> - var_leq_var_plus_const(Y, X1, C) - ; nonvar(X), var(Y), X = X1 - C, var(X1), integer(C) -> - C1 is - C, - var_leq_var_plus_const(Y, X1, C1) - ; nonvar(Y), Y = Z+One, One == 1, integer(Z) -> - Y1 is Z + 1, - clpfd_geq_(X, Y1) - ; integer(X), nonvar(Y), Y = Z+One, One == 1 -> - X1 is X - 1, - clpfd_geq_(X1, Z) - ; parse_clpfd(X,RX), parse_clpfd(Y,RY), geq(RX,RY) - ). - -var_leq_var_plus_const(X, Y, C) :- - make_propagator(x_leq_y_plus_c(X,Y,C), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - trigger_once(Prop). - %% ?X #=< ?Y % % X is less than or equal to Y. @@ -1920,6 +2121,8 @@ X #=< Y :- Y #>= X. X #= Y :- clpfd_equal(X, Y). +clpfd_equal(X, Y) :- clpfd_equal_(X, Y), reinforce(X). + /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Conditions under which an equality can be compiled to built-in arithmetic. Their order is significant. @@ -1951,29 +2154,40 @@ expr_conds(A0^B0, A^B) --> user:goal_expansion(X0 #= Y0, Equal) :- \+ current_prolog_flag(clpfd_goal_expansion, false), - phrase(expr_conds(X0, X), CsX), - phrase(expr_conds(Y0, Y), CsY), - list_goal(CsX, CondX), - list_goal(CsY, CondY), - Equal = ( CondY -> + phrase(clpfd:expr_conds(X0, X), CsX), + phrase(clpfd:expr_conds(Y0, Y), CsY), + clpfd:list_goal(CsX, CondX), + clpfd:list_goal(CsY, CondY), + Equal = ( CondX -> + ( var(Y) -> Y is X + ; CondY -> X =:= Y + ; T is X, clpfd:clpfd_equal(T, Y0) + ) + ; CondY -> ( var(X) -> X is Y - ; CondX -> X =:= Y - ; clpfd:clpfd_equal(X0, Y0) + ; T is Y, clpfd:clpfd_equal(X0, T) ) ; clpfd:clpfd_equal(X0, Y0) ). user:goal_expansion(X0 #>= Y0, Geq) :- \+ current_prolog_flag(clpfd_goal_expansion, false), - phrase(expr_conds(X0, X), Conds, Rest), - phrase(expr_conds(Y0, Y), Rest), - list_goal(Conds, Cond), - Geq = ( Cond -> X >= Y + phrase(clpfd:expr_conds(X0, X), CsX), + phrase(clpfd:expr_conds(Y0, Y), CsY), + clpfd:list_goal(CsX, CondX), + clpfd:list_goal(CsY, CondY), + Geq = ( CondX -> + ( CondY -> X >= Y + ; T is X, clpfd:clpfd_geq(T, Y0) + ) + ; CondY -> T is Y, clpfd:clpfd_geq(X0, T) ; clpfd:clpfd_geq(X0, Y0) ). user:goal_expansion(X #=< Y, Leq) :- user:goal_expansion(Y #>= X, Leq). user:goal_expansion(X #> Y, Gt) :- user:goal_expansion(X #>= Y+1, Gt). user:goal_expansion(X #< Y, Lt) :- user:goal_expansion(Y #> X, Lt). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + linsum(X, S, S) --> { var(X) }, !, [vn(X,1)]. linsum(I, S0, S) --> { integer(I), !, S is S0 + I }. linsum(-A, S0, S) --> mulsum(A, -1, S0, S). @@ -1993,12 +2207,6 @@ v_or_i(V) :- var(V), !. v_or_i(I) :- integer(I). left_right_linsum_const(Left, Right, Cs, Vs, Const) :- - % omit constraints that scalar_product posts - \+ ( v_or_i(Left), v_or_i(Right) ), - \+ ( nonvar(Left), Left = A+B, maplist(v_or_i, [A,B,Right]) ), - \+ ( nonvar(Right), Right = A+B, maplist(v_or_i, [A,B,Left]) ), - \+ ( nonvar(Left), Left = A*B, maplist(v_or_i, [A,B,Right]) ), - \+ ( nonvar(Right), Right = A*B, maplist(v_or_i, [A,B,Left]) ), phrase(linsum(Left, 0, CL), Lefts0, Rights), phrase(linsum(Right, 0, CR), Rights0), maplist(linterm_negate, Rights0, Rights), @@ -2030,31 +2238,11 @@ filter_linsum([C0|Cs0], [V0|Vs0], Cs, Vs) :- filter_linsum(Cs0, Vs0, Cs1, Vs1) ). -clpfd_equal(X, Y) :- - ( left_right_linsum_const(X, Y, Cs, Vs, S) -> - ( Cs = [] -> S =:= 0 - ; Cs = [C|CsRest], - gcd(CsRest, C, GCD), - S mod GCD =:= 0, - scalar_product(Cs, Vs, #=, S) - ) - ; ( v_or_i(Y) -> parse_clpfd(X, Y), reinforce(Y) - ; v_or_i(X) -> parse_clpfd(Y, X), reinforce(X) - ; parse_clpfd(X, RX), parse_clpfd(Y, RX), reinforce(RX) - ) - ). - gcd([], G, G). gcd([N|Ns], G0, G) :- - gcd_(N, G0, G1), + G1 is gcd(N, G0), gcd(Ns, G1, G). -gcd_(A, B, G) :- - ( B =:= 0 -> G = A - ; R is A mod B, - gcd_(B, R, G) - ). - /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - k-th root of N, if N is a k-th power. @@ -2073,14 +2261,14 @@ integer_kth_root(N, K, R) :- ). integer_kroot(L, U, N, K, R) :- - ( L =:= U -> N =:= L**K, R = L + ( L =:= U -> N =:= L^K, R = L ; L + 1 =:= U -> - ( L**K =:= N -> R = L - ; U**K =:= N -> R = U + ( L^K =:= N -> R = L + ; U^K =:= N -> R = U ; fail ) ; Mid is (L + U)//2, - ( Mid**K > N -> + ( Mid^K > N -> integer_kroot(L, Mid, N, K, R) ; integer_kroot(Mid, U, N, K, R) ) @@ -2091,85 +2279,12 @@ integer_kroot(L, U, N, K, R) :- % % X is not Y. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Some expressions are handled by special propagators, and we want to - recognise all their variations. A fact match(Expr, Call) describes - which specialised predicate can be applied for Expr. -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ - -match(var(X) #\= integer(Y), neq_num(X, Y)). -match(var(X) #\= var(Y) + var(Z), x_neq_y_plus_z(X, Y, Z)). -match(var(X) #\= var(Y) - var(Z), x_neq_y_plus_z(Y, X, Z)). -match(integer(X) #\= abs(var(Y)-var(Z)), absdiff_neq_const(Y, Z, X)). - -left_right_matcher(X, Y, M) :- - findall(Term-Pred, match(Term,Pred), TPs), - matcher(TPs, X, Y, M). - -matcher([], _, _, false). -matcher([Term-Pred|TPs], X, Y, Matchers) :- - ( Term = (Left #\= Right) -> - Matchers = (Cond1 -> Pred; Cond2 -> Pred ; Rest), - condition(Left, Right, X, Y, Cond1), - condition(Right, Left, X, Y, Cond2), - matcher(TPs, X, Y, Rest) - ; domain_error(matcher_expression, Term) - ). - -condition(Left, Right, X, Y, Cond) :- - phrase((conditions(Left,X),conditions(Right,Y)), Cs), - list_goal(Cs, Cond). - -conditions(var(V), T) --> [v_or_i(T), V = T]. -conditions(integer(I), T) --> [integer(T), I = T]. -conditions(X+Y, T) --> - [nonvar(T), T = A + B], - conditions(X, A), - conditions(Y, B). -conditions(X-Y, T) --> - [nonvar(T), T = A - B], - conditions(X, A), - conditions(Y, B). -conditions(abs(X), T) --> - [nonvar(T), T = abs(A)], - conditions(X, A). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -X #\= Y :- - ( - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - %% matcher for specialised propagators, generated with: - %%?- set_prolog_flag(toplevel_print_options, [portray(true)]), - %% clpfd:left_right_matcher(X, Y, M). - ((v_or_i(X), M1481=X), integer(Y)), M1483=Y->neq_num(M1481, M1483); ((integer(X), M1483=X), v_or_i(Y)), M1481=Y->neq_num(M1481, M1483); ((((((v_or_i(X), M1459=X), nonvar(Y)), Y=M1674+M1675), v_or_i(M1674)), M1464=M1674), v_or_i(M1675)), M1466=M1675->x_neq_y_plus_z(M1459, M1464, M1466); ((((((nonvar(X), X=M1756+M1757), v_or_i(M1756)), M1464=M1756), v_or_i(M1757)), M1466=M1757), v_or_i(Y)), M1459=Y->x_neq_y_plus_z(M1459, M1464, M1466); ((((((v_or_i(X), M1437=X), nonvar(Y)), Y=M1872-M1873), v_or_i(M1872)), M1442=M1872), v_or_i(M1873)), M1444=M1873->x_neq_y_plus_z(M1442, M1437, M1444); ((((((nonvar(X), X=M1954-M1955), v_or_i(M1954)), M1442=M1954), v_or_i(M1955)), M1444=M1955), v_or_i(Y)), M1437=Y->x_neq_y_plus_z(M1442, M1437, M1444); ((((((((integer(X), M1413=X), nonvar(Y)), Y=abs(M2070)), nonvar(M2070)), M2070=M2083-M2084), v_or_i(M2083)), M1420=M2083), v_or_i(M2084)), M1422=M2084->absdiff_neq_const(M1420, M1422, M1413); ((((((((nonvar(X), X=abs(M2171)), nonvar(M2171)), M2171=M2184-M2185), v_or_i(M2184)), M1420=M2184), v_or_i(M2185)), M1422=M2185), integer(Y)), M1413=Y->absdiff_neq_const(M1420, M1422, M1413) - %% end of generated code - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ; left_right_linsum_const(X, Y, Cs, Vs, S) -> - scalar_product(Cs, Vs, #\=, S) - ; parse_clpfd(X, RX), parse_clpfd(Y, RY), neq(RX, RY) - ), - do_queue. - -% abs(X-Y) #\= C - -absdiff_neq_const(X, Y, C) :- - ( C >= 0 -> - make_propagator(absdiff_neq(X,Y,C), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - trigger_once(Prop) - ; constrain_to_integer(X), constrain_to_integer(Y) - ). +X #\= Y :- clpfd_neq(X, Y), do_queue. % X #\= Y + Z x_neq_y_plus_z(X, Y, Z) :- - ( Z == 0 -> neq(X, Y) - ; make_propagator(x_neq_y_plus_z(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), trigger_once(Prop) - ). + propagator_init_trigger(x_neq_y_plus_z(X,Y,Z)). % X is distinct from the number N. This is used internally, and does % not reinforce other constraints. @@ -2223,6 +2338,34 @@ X #< Y :- Y #> X. % B = 0, % X in inf..3\/5..sup. % == +% The following example uses reified constraints to relate a list of +% finite domain variables to the number of occurrences of a given value: +% +% == +% :- use_module(library(clpfd)). +% +% vs_n_num(Vs, N, Num) :- +% maplist(eq_b(N), Vs, Bs), +% sum(Bs, #=, Num). +% +% eq_b(X, Y, B) :- X #= Y #<==> B. +% == +% +% Sample queries and their results: +% +% == +% ?- Vs = [X,Y,Z], Vs ins 0..1, vs_n_num(Vs, 4, Num). +% Vs = [X, Y, Z], +% Num = 0, +% X in 0..1, +% Y in 0..1, +% Z in 0..1. +% +% ?- vs_n_num([X,Y,Z], 2, 3). +% X = 2, +% Y = 2, +% Z = 2. +% == L #<==> R :- reify(L, B), reify(R, B), do_queue. @@ -2230,13 +2373,28 @@ L #<==> R :- reify(L, B), reify(R, B), do_queue. % % P implies Q. -L #==> R :- reify(L, BL), reify(R, BR), myimpl(BL, BR), do_queue. +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Implication is special in that created auxiliary constraints can be + retracted when the implication becomes entailed, for example: + + %?- X + 1 #= Y #==> Z, Z #= 1. + %@ Z = 1, + %@ X in inf..sup, + %@ Y in inf..sup. + + We cannot use propagator_init_trigger/1 here because the states of + auxiliary propagators are themselves part of the propagator. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +L #==> R :- + phrase((reify(L, BL),reify(R, BR)), Ps), + propagator_init_trigger([BL,BR], pimpl(BL,BR,Ps)). %% ?P #<== ?Q % % Q implies P. -L #<== R :- reify(L, BL), reify(R, BR), myimpl(BR, BL), do_queue. +L #<== R :- R #==> L. %% ?P #/\ ?Q % @@ -2255,30 +2413,10 @@ L #/\ R :- reify(L, 1), reify(R, 1), do_queue. % Sum = 233168. % == -L #\/ R :- reify(L, BL), reify(R, BR), myor(BL, BR, 1), do_queue. - -myor(X, Y, Z) :- - make_propagator(por(X,Y,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), - trigger_prop(Prop). - -myimpl(X, Y) :- - make_propagator(pimpl(X,Y), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - trigger_prop(Prop). - -my_reified_div(X, Y, D, Z) :- - make_propagator(reified_div(X,Y,D,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), init_propagator(D, Prop), - trigger_once(Prop). - -my_reified_mod(X, Y, D, Z) :- - make_propagator(reified_mod(X,Y,D,Z), Prop), - init_propagator(X, Prop), init_propagator(Y, Prop), - init_propagator(Z, Prop), init_propagator(D, Prop), - trigger_once(Prop). +L #\/ R :- + reify(L, X, Ps1), + reify(R, Y, Ps2), + propagator_init_trigger([X,Y], reified_or(X,Ps1,Y,Ps2,1)). /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - A constraint that is being reified need not hold. Therefore, in @@ -2286,116 +2424,201 @@ my_reified_mod(X, Y, D, Z) :- constrain the *result* of an expression (which does not appear explicitly in the expression and is not visible to the outside), but not the operands, except for requiring that they be integers. + In contrast to parse_clpfd/2, the result of an expression can now also be undefined, in which case the constraint cannot hold. + Therefore, the committed-choice language is extended by an element + d(D) that states D is 1 iff all subexpressions are defined. a(V) + means that V is an auxiliary variable that was introduced while + parsing a compound expression. a(X,V) means V is auxiliary unless + it is ==/2 X, and a(X,Y,V) means V is auxiliary unless it is ==/2 X + or Y. l(L) means the literal L occurs in the described list. + + When a constraint becomes entailed or subexpressions become + undefined, created auxiliary constraints are killed, and the + "clpfd" attribute is removed from auxiliary variables. + + For (/)/2 and mod/2, we create a skeleton propagator and remember + it as an auxiliary constraint. The corresponding reified + propagators can use the skeleton when the constraint is defined. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ -parse_reified_clpfd(Expr, Result, Defined) :- - ( cyclic_term(Expr) -> domain_error(clpfd_expression, Expr) - ; var(Expr) -> - constrain_to_integer(Expr), - Result = Expr, Defined = 1 - ; integer(Expr) -> Result = Expr, Defined = 1 - ; Expr = (L + R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - myplus(RL, RR, Result), DL #/\ DR #<==> Defined - ; Expr = (L * R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - mytimes(RL, RR, Result), DL #/\ DR #<==> Defined - ; Expr = (L - R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - mytimes(-1, RR, RRR), - myplus(RL, RRR, Result), DL #/\ DR #<==> Defined - ; Expr = (- E) -> - parse_reified_clpfd(E, RE, Defined), - mytimes(-1, RE, Result) - ; Expr = max(L, R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - mymax(RL, RR, Result), DL #/\ DR #<==> Defined - ; Expr = min(L,R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - mymin(RL, RR, Result), DL #/\ DR #<==> Defined - ; Expr = L mod R -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - DL #/\ DR #<==> Defined1, - my_reified_mod(RL, RR, Defined2, Result), - Defined1 #/\ Defined2 #<==> Defined - ; Expr = abs(E) -> - parse_reified_clpfd(E, RE, Defined), - myabs(RE, Result), - Result #>= 0 - ; Expr = (L / R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - DL #/\ DR #<==> Defined1, - my_reified_div(RL, RR, Defined2, Result), - Defined1 #/\ Defined2 #<==> Defined - ; Expr = (L ^ R) -> - parse_reified_clpfd(L, RL, DL), parse_reified_clpfd(R, RR, DR), - DL #/\ DR #<==> Defined, - myexp(RL, RR, Result) - ; domain_error(clpfd_expression, Expr) +parse_reified(E, R, D, + [(g(cyclic_term(E)) -> [g(domain_error(clpfd_expression, E))]), + (g(var(E)) -> [g(constrain_to_integer(E)), g(R = E), g(D=1)]), + (g(integer(E)) -> [g(R=E), g(D=1)]), + (m(A+B) -> [d(D), p(pplus(A,B,R)), a(A,B,R)]), + (m(A*B) -> [d(D), p(ptimes(A,B,R)), a(A,B,R)]), + (m(A-B) -> [d(D), p(pplus(R,B,A)), a(A,B,R)]), + (m(-A) -> [d(D), p(ptimes(-1,A,R)), a(R)]), + (m(max(A,B)) -> [d(D), p(pgeq(R, A)), p(pgeq(R, B)), p(pmax(A,B,R)), a(A,B,R)]), + (m(min(A,B)) -> [d(D), p(pgeq(A, R)), p(pgeq(B, R)), p(pmin(A,B,R)), a(A,B,R)]), + (m(A mod B) -> + [d(D1), l(p(P)), g(make_propagator(pmod(X,Y,Z), P)), + p([A,B,D2,R], reified_mod(A,B,D2,[X,Y,Z]-P,R)), + p(reified_and(D1,[],D2,[],D)), a(D2), a(A,B,R)]), + (m(abs(A)) -> [g(R#>=0), d(D), p(pabs(A, R)), a(A,R)]), + (m(A/B) -> + [d(D1), l(p(P)), g(make_propagator(pdiv(X,Y,Z), P)), + p([A,B,D2,R], reified_div(A,B,D2,[X,Y,Z]-P,R)), + p(reified_and(D1,[],D2,[],D)), a(D2), a(A,B,R)]), + (m(A^B) -> [d(D), p(pexp(A,B,R)), a(A,B,R)]), + (g(true) -> [g(domain_error(clpfd_expression, E))])] + ). + +% Again, we compile this to a predicate, parse_reified_clpfd//3. This +% time, it is a DCG that describes the list of auxiliary variables and +% propagators for the given expression, in addition to relating it to +% its reified (Boolean) finite domain variable and its Boolean +% definedness. + +make_parse_reified(Clauses) :- + parse_reified_clauses(Clauses0), + maplist(goals_goal_dcg, Clauses0, Clauses). + +goals_goal_dcg((Head --> Goals), Clause) :- + list_goal(Goals, Body), + expand_term((Head --> Body), Clause). + +parse_reified_clauses(Clauses) :- + parse_reified(E, R, D, Matchers), + maplist(parse_reified(E, R, D), Matchers, Clauses). + +parse_reified(E, R, D, Matcher, Clause) :- + Matcher = (Condition0 -> Goals0), + phrase((reified_condition(Condition0, E, Head, Ds), + reified_goals(Goals0, Ds)), Goals, [a(D)]), + Clause = (parse_reified_clpfd(Head, R, D) --> Goals). + +reified_condition(g(Goal), E, E, []) --> [{Goal}, !]. +reified_condition(m(Match), _, Match0, Ds) --> + { copy_term(Match, Match0) }, + [!], + { term_variables(Match0, Vs0), + term_variables(Match, Vs) + }, + reified_variables(Vs0, Vs, Ds). + +reified_variables([], [], []) --> []. +reified_variables([V0|Vs0], [V|Vs], [D|Ds]) --> + [parse_reified_clpfd(V0, V, D)], + reified_variables(Vs0, Vs, Ds). + +reified_goals([], _) --> []. +reified_goals([G|Gs], Ds) --> reified_goal(G, Ds), reified_goals(Gs, Ds). + +reified_goal(d(D), Ds) --> + ( { Ds = [X] } -> [{D=X}] + ; { Ds = [X,Y] } -> + { phrase(reified_goal(p(reified_and(X,[],Y,[],D)), _), Gs), + list_goal(Gs, Goal) }, + [( {X==1, Y==1} -> {D = 1} ; Goal )] + ; { domain_error(one_or_two_element_list, Ds) } + ). +reified_goal(g(Goal), _) --> [{Goal}]. +reified_goal(p(Vs, Prop), _) --> + [{make_propagator(Prop, P)}], + parse_init_dcg(Vs, P), + [{trigger_once(P)}], + [( { arg(2, P, S), S == dead } -> [] ; [p(P)])]. +reified_goal(p(Prop), Ds) --> + { term_variables(Prop, Vs) }, + reified_goal(p(Vs,Prop), Ds). +reified_goal(a(V), _) --> [a(V)]. +reified_goal(a(X,V), _) --> [a(X,V)]. +reified_goal(a(X,Y,V), _) --> [a(X,Y,V)]. +reified_goal(l(L), _) --> [[L]]. + +parse_init_dcg([], _) --> []. +parse_init_dcg([V|Vs], P) --> [{init_propagator(V, P)}], parse_init_dcg(Vs, P). + +%?- set_prolog_flag(toplevel_print_options, [portray(true)]), +% clpfd:parse_reified_clauses(Cs), maplist(portray_clause, Cs). + +reify(E, B) :- reify(E, B, _). + +reify(Expr, B, Ps) :- phrase(reify(Expr, B), Ps). + +reify(E, B) --> { B in 0..1 }, reify_(E, B). + +reify_(E, _) --> + { cyclic_term(E), !, domain_error(clpfd_reifiable_expression, E) }. +reify_(E, B) --> { var(E), !, E = B }. +reify_(E, B) --> { integer(E), !, E = B }. +reify_(V in Drep, B) --> !, + { drep_to_domain(Drep, Dom), fd_variable(V) }, + propagator_init_trigger(reified_in(V,Dom,B)), + a(B). +reify_(finite_domain(V), B) --> !, + { fd_variable(V) }, + propagator_init_trigger(reified_fd(V,B)), + a(B). +reify_(L #>= R, B) --> !, + { phrase((parse_reified_clpfd(L, LR, LD), + parse_reified_clpfd(R, RR, RD)), Ps) }, + list(Ps), + propagator_init_trigger([LD,LR,RD,RR,B], reified_geq(LD,LR,RD,RR,Ps,B)), + a(B). +reify_(L #> R, B) --> !, reify_(L #>= (R+1), B). +reify_(L #=< R, B) --> !, reify_(R #>= L, B). +reify_(L #< R, B) --> !, reify_(R #>= (L+1), B). +reify_(L #= R, B) --> !, + { phrase((parse_reified_clpfd(L, LR, LD), + parse_reified_clpfd(R, RR, RD)), Ps) }, + list(Ps), + propagator_init_trigger([LD,LR,RD,RR,B], reified_eq(LD,LR,RD,RR,Ps,B)), + a(B). +reify_(L #\= R, B) --> !, + { phrase((parse_reified_clpfd(L, LR, LD), + parse_reified_clpfd(R, RR, RD)), Ps) }, + list(Ps), + propagator_init_trigger([LD,LR,RD,RR,B], reified_neq(LD,LR,RD,RR,Ps,B)), + a(B). +reify_(L #==> R, B) --> !, reify_((#\ L) #\/ R, B). +reify_(L #<== R, B) --> !, reify_(R #==> L, B). +reify_(L #<==> R, B) --> !, reify_((L #==> R) #/\ (R #==> L), B). +reify_(L #/\ R, B) --> !, + { reify(L, LR, Ps1), + reify(R, RR, Ps2) }, + list(Ps1), list(Ps2), + propagator_init_trigger([LR,RR,B], reified_and(LR,Ps1,RR,Ps2,B)), + a(LR, RR, B). +reify_(L #\/ R, B) --> !, + { reify(L, LR, Ps1), + reify(R, RR, Ps2) }, + list(Ps1), list(Ps2), + propagator_init_trigger([LR,RR,B], reified_or(LR,Ps1,RR,Ps2,B)), + a(LR, RR, B). +reify_(#\ Q, B) --> !, + reify(Q, QR), + propagator_init_trigger(reified_not(QR,B)), + a(B). +reify_(E, _) --> !, { domain_error(clpfd_reifiable_expression, E) }. + +list([]) --> []. +list([L|Ls]) --> [L], list(Ls). + +a(X,Y,B) --> + ( { nonvar(X) } -> a(Y, B) + ; { nonvar(Y) } -> a(X, B) + ; [a(X,Y,B)] ). -reify(Expr, B) :- - B in 0..1, - ( cyclic_term(Expr) -> domain_error(clpfd_reifiable_expression, Expr) - ; var(Expr) -> B = Expr - ; integer(Expr) -> B = Expr - ; Expr = (V in Drep) -> - drep_to_domain(Drep, Dom), - fd_variable(V), - make_propagator(reified_in(V,Dom,B), Prop), - init_propagator(V, Prop), init_propagator(B, Prop), - trigger_prop(Prop) - ; Expr = finite_domain(V) -> - fd_variable(V), - make_propagator(reified_fd(V,B), Prop), - init_propagator(V, Prop), init_propagator(B, Prop), - trigger_prop(Prop) - ; Expr = (L #>= R) -> - parse_reified_clpfd(L, LR, LD), parse_reified_clpfd(R, RR, RD), - make_propagator(reified_geq(LD,LR,RD,RR,B), Prop), - init_propagator(LR, Prop), init_propagator(RR, Prop), - init_propagator(B, Prop), init_propagator(LD, Prop), - init_propagator(RD, Prop), trigger_prop(Prop) - ; Expr = (L #> R) -> reify(L #>= (R+1), B) - ; Expr = (L #=< R) -> reify(R #>= L, B) - ; Expr = (L #< R) -> reify(R #>= (L+1), B) - ; Expr = (L #= R) -> - parse_reified_clpfd(L, LR, LD), parse_reified_clpfd(R, RR, RD), - make_propagator(reified_eq(LD,LR,RD,RR,B), Prop), - init_propagator(LR, Prop), init_propagator(RR, Prop), - init_propagator(B, Prop), init_propagator(LD, Prop), - init_propagator(RD, Prop), trigger_prop(Prop) - ; Expr = (L #\= R) -> - parse_reified_clpfd(L, LR, LD), parse_reified_clpfd(R, RR, RD), - make_propagator(reified_neq(LD,LR,RD,RR,B), Prop), - init_propagator(LR, Prop), init_propagator(RR, Prop), - init_propagator(B, Prop), init_propagator(LD, Prop), - init_propagator(RD, Prop), trigger_prop(Prop) - ; Expr = (L #==> R) -> reify((#\ L) #\/ R, B) - ; Expr = (L #<== R) -> reify(R #==> L, B) - ; Expr = (L #<==> R) -> reify((L #==> R) #/\ (R #==> L), B) - ; Expr = (L #/\ R) -> - reify(L, LR), reify(R, RR), - make_propagator(reified_and(LR,RR,B), Prop), - init_propagator(LR, Prop), init_propagator(RR, Prop), - init_propagator(B, Prop), - trigger_prop(Prop) - ; Expr = (L #\/ R) -> - reify(L, LR), reify(R, RR), - make_propagator(reified_or(LR,RR,B), Prop), - init_propagator(LR, Prop), init_propagator(RR, Prop), - init_propagator(B, Prop), - trigger_prop(Prop) - ; Expr = (#\ Q) -> - reify(Q, QR), - make_propagator(reified_not(QR,B), Prop), - init_propagator(QR, Prop), init_propagator(B, Prop), - trigger_prop(Prop) - ; domain_error(clpfd_reifiable_expression, Expr) +a(X, B) --> + ( { var(X) } -> [a(X, B)] + ; a(B) ). +a(B) --> + ( { var(B) } -> [a(B)] + ; [] + ). + +% Match variables to created skeleton. + +skeleton(Vs, Vs-Prop) :- + maplist(prop_init(Prop), Vs), + trigger_once(Prop). /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - A drep is a user-accessible and visible domain representation. N, @@ -2662,11 +2885,33 @@ trigger_prop(Propagator) :- ; % passive % format("triggering: ~w\n", [Propagator]), put_attr(State, clpfd_aux, queued), - push_queue(Propagator) + ( arg(1, Propagator, C), functor(C, F, _), global_constraint(F) -> + push_slow_queue(Propagator) + ; push_fast_queue(Propagator) + ) ). kill(State) :- del_attr(State, clpfd_aux), State = dead. +kill(State, Ps) :- + kill(State), + maplist(kill_entailed, Ps). + +kill_entailed(p(Prop)) :- + arg(2, Prop, State), + kill(State). +kill_entailed(a(V)) :- + del_attr(V, clpfd). +kill_entailed(a(X,B)) :- + ( X == B -> true + ; del_attr(B, clpfd) + ). +kill_entailed(a(X,Y,B)) :- + ( X == B -> true + ; Y == B -> true + ; del_attr(B, clpfd) + ). + no_reactivation(rel_tuple(_,_)). %no_reactivation(scalar_product(_,_,_,_)). @@ -2714,12 +2959,23 @@ constraint_wake(pneq, ground). constraint_wake(x_neq_y_plus_z, ground). constraint_wake(absdiff_neq, ground). constraint_wake(pdifferent, ground). -constraint_wake(pdistinct, ground). +constraint_wake(pexclude, ground). +constraint_wake(scalar_product_neq, ground). constraint_wake(x_leq_y_plus_c, bounds). -constraint_wake(scalar_product, bounds). +constraint_wake(scalar_product_eq, bounds). +constraint_wake(scalar_product_leq, bounds). constraint_wake(pplus, bounds). constraint_wake(pgeq, bounds). +constraint_wake(pgcc_single, bounds). +constraint_wake(pgcc_check_single, bounds). + +global_constraint(pdistinct). +global_constraint(pgcc). +global_constraint(pgcc_single). +global_constraint(pcircuit). +%global_constraint(rel_tuple). +%global_constraint(scalar_product_eq). insert_propagator(Prop, Ps0, Ps) :- Ps0 = fd_props(Gs,Bs,Os), @@ -2740,24 +2996,16 @@ insert_propagator(Prop, Ps0, Ps) :- lex_chain(Lss) :- must_be(list(list), Lss), + maplist(maplist(fd_variable), Lss), make_propagator(presidual(lex_chain(Lss)), Prop), lex_chain_(Lss, Prop). lex_chain_([], _). lex_chain_([Ls|Lss], Prop) :- - lex_check_and_attach(Ls, Prop), + maplist(prop_init(Prop), Ls), lex_chain_lag(Lss, Ls), lex_chain_(Lss, Prop). -lex_check_and_attach([], _). -lex_check_and_attach([L|Ls], Prop) :- - fd_variable(L), - ( var(L) -> - init_propagator(L, Prop) - ; true - ), - lex_check_and_attach(Ls, Prop). - lex_chain_lag([], _). lex_chain_lag([Ls|Lss], Ls0) :- lex_le(Ls0, Ls), @@ -2826,7 +3074,7 @@ tuples_in(Tuples, Relation) :- tuples_domain([], _). tuples_domain([Tuple|Tuples], Relation) :- - relation_unifiable(Relation, Tuple, Us, 0, _), + relation_unifiable(Relation, Tuple, Us, _, _), ( ground(Tuple) -> memberchk(Tuple, Relation) ; tuple_domain(Tuple, Us), ( Tuple = [_,_|_] -> tuple_freeze(Tuple, Us) @@ -2837,7 +3085,7 @@ tuples_domain([Tuple|Tuples], Relation) :- tuple_domain([], _). tuple_domain([T|Ts], Relation0) :- - take_firsts(Relation0, Firsts, Relation1), + lists_firsts_rests(Relation0, Firsts, Relation1), ( var(T) -> ( Firsts = [Unique] -> T = Unique ; list_to_domain(Firsts, FDom), @@ -2849,12 +3097,9 @@ tuple_domain([T|Ts], Relation0) :- ), tuple_domain(Ts, Relation1). -take_firsts([], [], []). -take_firsts([[F|Os]|Rest], [F|Fs], [Os|Oss]) :- - take_firsts(Rest, Fs, Oss). - tuple_freeze(Tuple, Relation) :- - make_propagator(rel_tuple(mutable(Relation,_),Tuple), Prop), + put_attr(R, clpfd_relation, Relation), + make_propagator(rel_tuple(R, Tuple), Prop), tuple_freeze(Tuple, Tuple, Prop). tuple_freeze([], _, _). @@ -2871,7 +3116,7 @@ relation_unifiable([R|Rs], Tuple, Us, Changed0, Changed) :- ( all_in_domain(R, Tuple) -> Us = [R|Rest], relation_unifiable(Rs, Tuple, Rest, Changed0, Changed) - ; relation_unifiable(Rs, Tuple, Us, 1, Changed) + ; relation_unifiable(Rs, Tuple, Us, true, Changed) ). all_in_domain([], []). @@ -2896,22 +3141,61 @@ run_propagator(pdifferent(Left,Right,X,_), _MState) :- ; true ). -run_propagator(pdistinct(Left,Right,X,_), _MState) :- +run_propagator(weak_distinct(Left,Right,X,_), _MState) :- ( ground(X) -> disable_queue, exclude_fire(Left, Right, X), enable_queue - ; %outof_reducer(Left, Right, X) + ; outof_reducer(Left, Right, X) %( var(X) -> kill_if_isolated(Left, Right, X, MState) %; true - %), - true + %) ). +run_propagator(pexclude(Left,Right,X), _) :- + ( ground(X) -> + disable_queue, + exclude_fire(Left, Right, X), + enable_queue + ; true + ). + +run_propagator(pdistinct(Ls), _MState) :- + distinct(Ls). + run_propagator(check_distinct(Left,Right,X), _) :- \+ list_contains(Left, X), \+ list_contains(Right, X). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +run_propagator(pelement(N, Is, V), MState) :- + ( fd_get(N, NDom, _) -> + ( fd_get(V, VDom, VPs) -> + integers_remaining(Is, 1, NDom, empty, VDom1), + domains_intersection(VDom, VDom1, VDom2), + fd_put(V, VDom2, VPs) + ; true + ) + ; kill(MState), nth1(N, Is, V) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +run_propagator(pgcc_single(Vs, Pairs), _) :- gcc_global(Vs, Pairs). + +run_propagator(pgcc_check_single(Pairs), _) :- gcc_check(Pairs). + +run_propagator(pgcc_check(Pairs), _) :- gcc_check(Pairs). + +run_propagator(pgcc(Vs, _, Pairs), _) :- gcc_global(Vs, Pairs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +run_propagator(pcircuit(Vs), _MState) :- + distinct(Vs), + propagate_circuit(Vs). + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% run_propagator(pneq(A, B), MState) :- ( nonvar(A) -> @@ -2964,37 +3248,47 @@ run_propagator(pgeq(A,B), MState) :- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(rel_tuple(Rel, Tuple), MState) :- - arg(1, Rel, Relation), +run_propagator(rel_tuple(R, Tuple), MState) :- + get_attr(R, clpfd_relation, Relation), ( ground(Tuple) -> kill(MState), memberchk(Tuple, Relation) - ; relation_unifiable(Relation, Tuple, Us, 0, Changed), + ; relation_unifiable(Relation, Tuple, Us, false, Changed), Us = [_|_], ( Tuple = [First,Second], ( ground(First) ; ground(Second) ) -> kill(MState) ; true ), ( Us = [Single] -> kill(MState), Single = Tuple - ; Changed =:= 0 -> true - ; setarg(1, Rel, Us), + ; Changed -> + put_attr(R, clpfd_relation, Us), disable_queue, tuple_domain(Tuple, Us), enable_queue + ; true ) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(pserialized(Var,Duration,Left,SDs), _MState) :- - myserialized(Duration, Left, SDs, Var). +run_propagator(pserialized(S_I, D_I, S_J, D_J, _), MState) :- + ( nonvar(S_I), nonvar(S_J) -> + kill(MState), + ( S_I + D_I =< S_J -> true + ; S_J + D_J =< S_I -> true + ; false + ) + ; serialize_lower_upper(S_I, D_I, S_J, D_J, MState), + serialize_lower_upper(S_J, D_J, S_I, D_I, MState) + ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % abs(X-Y) #\= C run_propagator(absdiff_neq(X,Y,C), MState) :- - ( nonvar(X) -> - ( nonvar(Y) -> kill(MState), abs(X - Y) =\= C - ; kill(MState), - V1 is X - C, neq_num(Y, V1), + ( C < 0 -> kill(MState) + ; nonvar(X) -> + kill(MState), + ( nonvar(Y) -> abs(X - Y) =\= C + ; V1 is X - C, neq_num(Y, V1), V2 is C + X, neq_num(Y, V2) ) ; nonvar(Y) -> kill(MState), @@ -3003,6 +3297,22 @@ run_propagator(absdiff_neq(X,Y,C), MState) :- ; true ). +% abs(X-Y) #>= C +run_propagator(absdiff_geq(X,Y,C), MState) :- + ( C =< 0 -> kill(MState) + ; nonvar(X) -> + kill(MState), + ( nonvar(Y) -> abs(X-Y) >= C + ; P1 is X - C, P2 is X + C, + Y in inf..P1 \/ P2..sup + ) + ; nonvar(Y) -> + kill(MState), + P1 is Y - C, P2 is Y + C, + X in inf..P1 \/ P2..sup + ; true + ). + % X #\= Y + Z run_propagator(x_neq_y_plus_z(X,Y,Z), MState) :- ( nonvar(X) -> @@ -3016,8 +3326,10 @@ run_propagator(x_neq_y_plus_z(X,Y,Z), MState) :- ; nonvar(Y) -> ( nonvar(Z) -> kill(MState), YZ is Y + Z, neq_num(X, YZ) + ; Y =:= 0 -> kill(MState), neq(X, Z) ; true ) + ; Z == 0 -> kill(MState), neq(X, Y) ; true ). @@ -3062,71 +3374,84 @@ run_propagator(x_leq_y_plus_c(X,Y,C), MState) :- ) ). -run_propagator(scalar_product(Cs0,Vs0,Op,P0), MState) :- +run_propagator(scalar_product_neq(Cs0,Vs0,P0), MState) :- coeffs_variables_const(Cs0, Vs0, Cs, Vs, 0, I), P is P0 - I, - ( Op == (#\=) -> - ( Vs = [] -> kill(MState), P =\= 0 - ; P =:= 0, Cs = [1,1,-1] -> - kill(MState), Vs = [A,B,C], - x_neq_y_plus_z(C, A, B) - ; Cs == [1,-1] -> kill(MState), Vs = [A,B], - x_neq_y_plus_z(A, B, P) - ; Cs == [-1,1] -> kill(MState), Vs = [A,B], - x_neq_y_plus_z(B, A, P) - ; Vs = [V], Cs = [C] -> - kill(MState), - ( C =:= 1 -> neq_num(V, P) - ; C*V #\= P + ( Vs = [] -> kill(MState), P =\= 0 + ; Vs = [V], Cs = [C] -> + kill(MState), + ( C =:= 1 -> neq_num(V, P) + ; C*V #\= P + ) + ; Cs == [1,-1] -> kill(MState), Vs = [A,B], x_neq_y_plus_z(A, B, P) + ; Cs == [-1,1] -> kill(MState), Vs = [A,B], x_neq_y_plus_z(B, A, P) + ; P =:= 0, Cs = [1,1,-1] -> + kill(MState), Vs = [A,B,C], x_neq_y_plus_z(C, A, B) + ; P =:= 0, Cs = [1,-1,1] -> + kill(MState), Vs = [A,B,C], x_neq_y_plus_z(B, A, C) + ; P =:= 0, Cs = [-1,1,1] -> + kill(MState), Vs = [A,B,C], x_neq_y_plus_z(A, B, C) + ; true + ). + +run_propagator(scalar_product_leq(Cs0,Vs0,P0), MState) :- + coeffs_variables_const(Cs0, Vs0, Cs, Vs, 0, I), + P is P0 - I, + ( Vs = [] -> kill(MState), P >= 0 + ; sum_finite_domains(Cs, Vs, Infs, Sups, 0, 0, Inf, Sup), + D1 is P - Inf, + disable_queue, + ( Infs == [], Sups == [] -> + Inf =< P, + ( Sup =< P -> kill(MState) + ; remove_dist_upper_leq(Cs, Vs, D1) ) + ; Infs == [] -> Inf =< P, remove_dist_upper(Sups, D1) + ; Sups = [_], Infs = [_] -> + remove_upper(Infs, D1) + ; Infs = [_] -> remove_upper(Infs, D1) ; true - ) - ; Op == (#=) -> - ( Vs = [] -> kill(MState), P =:= 0 - ; Vs = [V], Cs = [C] -> - kill(MState), - P mod C =:= 0, - V is P // C - ; Cs == [1,1] -> kill(MState), Vs = [A,B], A + B #= P - ; Cs == [-1,1] -> kill(MState), Vs = [A,B], B #= P + A - ; Cs == [1,-1] -> kill(MState), Vs = [A,B], A #= P + B - ; P =:= 0, Cs == [1,1,-1] -> - kill(MState), Vs = [A,B,C], A + B #= C - ; P =:= 0, Cs == [1,-1,1] -> - kill(MState), Vs = [A,B,C], A + C #= B - ; P =:= 0, Cs == [-1,1,1] -> - kill(MState), Vs = [A,B,C], B + C #= A - ; sum_finite_domains(Cs, Vs, Infs, Sups, 0, 0, Inf, Sup), - % nl, write(Infs-Sups-Inf-Sup), nl, - D1 is P - Inf, - D2 is Sup - P, - disable_queue, - ( Infs == [], Sups == [] -> - between(Inf, Sup, P), - remove_dist_upper_lower(Cs, Vs, D1, D2) - ; Sups = [] -> - P =< Sup, - remove_dist_lower(Infs, D2) - ; Infs = [] -> - Inf =< P, - remove_dist_upper(Sups, D1) - ; Sups = [_], Infs = [_] -> - remove_lower(Sups, D2), - remove_upper(Infs, D1) - ; Infs = [_] -> - remove_upper(Infs, D1) - ; Sups = [_] -> - remove_lower(Sups, D2) - ; true - ), - enable_queue - ) + ), + enable_queue + ). + +run_propagator(scalar_product_eq(Cs0,Vs0,P0), MState) :- + coeffs_variables_const(Cs0, Vs0, Cs, Vs, 0, I), + P is P0 - I, + ( Vs = [] -> kill(MState), P =:= 0 + ; Vs = [V], Cs = [C] -> kill(MState), P mod C =:= 0, V is P // C + ; Cs == [1,1] -> kill(MState), Vs = [A,B], A + B #= P + ; Cs == [1,-1] -> kill(MState), Vs = [A,B], A #= P + B + ; Cs == [-1,1] -> kill(MState), Vs = [A,B], B #= P + A + ; Cs == [-1,-1] -> kill(MState), Vs = [A,B], P1 is -P, A + B #= P1 + ; P =:= 0, Cs == [1,1,-1] -> kill(MState), Vs = [A,B,C], A + B #= C + ; P =:= 0, Cs == [1,-1,1] -> kill(MState), Vs = [A,B,C], A + C #= B + ; P =:= 0, Cs == [-1,1,1] -> kill(MState), Vs = [A,B,C], B + C #= A + ; sum_finite_domains(Cs, Vs, Infs, Sups, 0, 0, Inf, Sup), + % nl, writeln(Infs-Sups-Inf-Sup), + D1 is P - Inf, + D2 is Sup - P, + disable_queue, + ( Infs == [], Sups == [] -> + between(Inf, Sup, P), + remove_dist_upper_lower(Cs, Vs, D1, D2) + ; Sups = [] -> P =< Sup, remove_dist_lower(Infs, D2) + ; Infs = [] -> Inf =< P, remove_dist_upper(Sups, D1) + ; Sups = [_], Infs = [_] -> + remove_lower(Sups, D2), + remove_upper(Infs, D1) + ; Infs = [_] -> remove_upper(Infs, D1) + ; Sups = [_] -> remove_lower(Sups, D2) + ; true + ), + enable_queue ). % X + Y = Z run_propagator(pplus(X,Y,Z), MState) :- ( nonvar(X) -> ( X =:= 0 -> kill(MState), Y = Z + ; Y == Z -> kill(MState), X =:= 0 ; nonvar(Y) -> kill(MState), Z is X + Y ; nonvar(Z) -> kill(MState), Y is Z - X ; fd_get(Z, ZD, ZPs), @@ -3160,6 +3485,8 @@ run_propagator(pplus(X,Y,Z), MState) :- ) ) ; ( X == Y -> kill(MState), 2*X #= Z + ; X == Z -> kill(MState), Y = 0 + ; Y == Z -> kill(MState), X = 0 ; fd_get(X, XD, XL, XU, XPs), fd_get(Y, YD, YL, YU, YPs), fd_get(Z, ZD, ZL, ZU, _) -> NXL cis max(XL, ZL-YU), @@ -3268,9 +3595,12 @@ run_propagator(ptimes(X,Y,Z), MState) :- ( fd_get(Z, ZD2, ZL2, ZU2, ZExp2) -> min_times(NXL,NXU,NYL,NYU,NZL), max_times(NXL,NXU,NYL,NYU,NZU), - ( NZL cis_leq ZL2, NZU cis_geq ZU2 -> true + ( NZL cis_leq ZL2, NZU cis_geq ZU2 -> ZD3 = ZD2 ; domains_intersection(ZD2, from_to(NZL,NZU), ZD3), fd_put(Z, ZD3, ZExp2) + ), + ( domain_contains(ZD3, 0) -> true + ; neq_num(X, 0), neq_num(Y, 0) ) ; true ) @@ -3479,8 +3809,8 @@ run_propagator(pmax(X,Y,Z), MState) :- ; fd_get(Z, ZD, ZPs) -> fd_get(X, _, XInf, XSup, _), fd_get(Y, YD, YInf, YSup, _), - ( YInf cis_gt YSup -> Z = Y - ; YSup cis_lt XInf -> Z = X + ( YInf cis_gt YSup -> kill(MState), Z = Y + ; YSup cis_lt XInf -> kill(MState), Z = X ; n(M) cis max(XSup, YSup) -> domain_remove_greater_than(ZD, M, ZD1), fd_put(Z, ZD1, ZPs) @@ -3514,8 +3844,8 @@ run_propagator(pmin(X,Y,Z), MState) :- ; fd_get(Z, ZD, ZPs) -> fd_get(X, _, XInf, XSup, _), fd_get(Y, YD, YInf, YSup, _), - ( YSup cis_lt YInf -> Z = Y - ; YInf cis_gt XSup -> Z = X + ( YSup cis_lt YInf -> kill(MState), Z = Y + ; YInf cis_gt XSup -> kill(MState), Z = X ; n(M) cis min(XInf, YInf) -> domain_remove_smaller_than(ZD, M, ZD1), fd_put(Z, ZD1, ZPs) @@ -3534,7 +3864,7 @@ run_propagator(pexp(X,Y,Z), MState) :- ; nonvar(X), nonvar(Y) -> ( Y >= 0 -> true ; X =:= -1 ), kill(MState), - Z is X**Y + Z is X^Y ; nonvar(Z), nonvar(Y) -> integer_kth_root(Z, Y, R), kill(MState), @@ -3556,10 +3886,10 @@ run_propagator(pexp(X,Y,Z), MState) :- ; neq_num(Z, 0) ), ( XL = n(NXL), NXL >= 0 -> - NZL is NXL ** Y, + NZL is NXL ^ Y, domain_remove_smaller_than(ZD, NZL, ZD1), ( XU = n(NXU) -> - NZU is NXU ** Y, + NZU is NXU ^ Y, domain_remove_greater_than(ZD1, NZU, ZD2) ; ZD2 = ZD1 ), @@ -3638,31 +3968,31 @@ run_propagator(reified_fd(V,B), MState) :- % The result of X/Y and X mod Y is undefined iff Y is 0. -run_propagator(reified_div(X,Y,D,Z), MState) :- +run_propagator(reified_div(X,Y,D,Skel,Z), MState) :- ( Y == 0 -> kill(MState), D = 0 - ; D == 1 -> kill(MState), Z #= X / Y - ; integer(Y), Y =\= 0 -> kill(MState), D = 1, Z #= X / Y + ; D == 1 -> kill(MState), neq_num(Y, 0), skeleton([X,Y,Z], Skel) + ; integer(Y), Y =\= 0 -> kill(MState), D = 1, skeleton([X,Y,Z], Skel) ; fd_get(Y, YD, _), \+ domain_contains(YD, 0) -> kill(MState), - D = 1, Z #= X / Y + D = 1, skeleton([X,Y,Z], Skel) ; true ). -run_propagator(reified_mod(X,Y,D,Z), MState) :- +run_propagator(reified_mod(X,Y,D,Skel,Z), MState) :- ( Y == 0 -> kill(MState), D = 0 - ; D == 1 -> kill(MState), Z #= X mod Y - ; integer(Y), Y =\= 0 -> kill(MState), D = 1, Z #= X mod Y + ; D == 1 -> kill(MState), neq_num(Y, 0), skeleton([X,Y,Z], Skel) + ; integer(Y), Y =\= 0 -> kill(MState), D = 1, skeleton([X,Y,Z], Skel) ; fd_get(Y, YD, _), \+ domain_contains(YD, 0) -> kill(MState), - D = 1, Z #= X mod Y + D = 1, skeleton([X,Y,Z], Skel) ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(reified_geq(DX,X,DY,Y,B), MState) :- - ( DX == 0 -> kill(MState), B = 0 - ; DY == 0 -> kill(MState), B = 0 +run_propagator(reified_geq(DX,X,DY,Y,Ps,B), MState) :- + ( DX == 0 -> kill(MState, Ps), B = 0 + ; DY == 0 -> kill(MState, Ps), B = 0 ; B == 1 -> kill(MState), DX = 1, DY = 1, geq(X, Y) ; DX == 1, DY == 1 -> ( var(B) -> @@ -3671,21 +4001,21 @@ run_propagator(reified_geq(DX,X,DY,Y,B), MState) :- kill(MState), ( X >= Y -> B = 1 ; B = 0 ) ; fd_get(Y, _, YL, YU, _), - ( n(X) cis_geq YU -> kill(MState), B = 1 - ; n(X) cis_lt YL -> kill(MState), B = 0 + ( n(X) cis_geq YU -> kill(MState, Ps), B = 1 + ; n(X) cis_lt YL -> kill(MState, Ps), B = 0 ; true ) ) ; nonvar(Y) -> fd_get(X, _, XL, XU, _), - ( XL cis_geq n(Y) -> kill(MState), B = 1 - ; XU cis_lt n(Y) -> kill(MState), B = 0 + ( XL cis_geq n(Y) -> kill(MState, Ps), B = 1 + ; XU cis_lt n(Y) -> kill(MState, Ps), B = 0 ; true ) ; fd_get(X, _, XL, XU, _), fd_get(Y, _, YL, YU, _), - ( XL cis_geq YU -> kill(MState), B = 1 - ; XU cis_lt YL -> kill(MState), B = 0 + ( XL cis_geq YU -> kill(MState, Ps), B = 1 + ; XU cis_lt YL -> kill(MState, Ps), B = 0 ; true ) ) @@ -3696,9 +4026,9 @@ run_propagator(reified_geq(DX,X,DY,Y,B), MState) :- ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(reified_eq(DX,X,DY,Y,B), MState) :- - ( DX == 0 -> kill(MState), B = 0 - ; DY == 0 -> kill(MState), B = 0 +run_propagator(reified_eq(DX,X,DY,Y,Ps,B), MState) :- + ( DX == 0 -> kill(MState, Ps), B = 0 + ; DY == 0 -> kill(MState, Ps), B = 0 ; B == 1 -> kill(MState), DX = 1, DY = 1, X = Y ; DX == 1, DY == 1 -> ( var(B) -> @@ -3708,15 +4038,15 @@ run_propagator(reified_eq(DX,X,DY,Y,B), MState) :- ( X =:= Y -> B = 1 ; B = 0) ; fd_get(Y, YD, _), ( domain_contains(YD, X) -> true - ; kill(MState), B = 0 + ; kill(MState, Ps), B = 0 ) ) - ; nonvar(Y) -> run_propagator(reified_eq(DY,Y,DX,X,B), MState) + ; nonvar(Y) -> run_propagator(reified_eq(DY,Y,DX,X,Ps,B), MState) ; X == Y -> kill(MState), B = 1 ; fd_get(X, _, XL, XU, _), fd_get(Y, _, YL, YU, _), - ( XL cis_gt YU -> kill(MState), B = 0 - ; YL cis_gt XU -> kill(MState), B = 0 + ( XL cis_gt YU -> kill(MState, Ps), B = 0 + ; YL cis_gt XU -> kill(MState, Ps), B = 0 ; true ) ) @@ -3726,9 +4056,9 @@ run_propagator(reified_eq(DX,X,DY,Y,B), MState) :- ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(reified_neq(DX,X,DY,Y,B), MState) :- - ( DX == 0 -> kill(MState), B = 0 - ; DY == 0 -> kill(MState), B = 0 +run_propagator(reified_neq(DX,X,DY,Y,Ps,B), MState) :- + ( DX == 0 -> kill(MState, Ps), B = 0 + ; DY == 0 -> kill(MState, Ps), B = 0 ; B == 1 -> kill(MState), DX = 1, DY = 1, X #\= Y ; DX == 1, DY == 1 -> ( var(B) -> @@ -3738,15 +4068,16 @@ run_propagator(reified_neq(DX,X,DY,Y,B), MState) :- ( X =\= Y -> B = 1 ; B = 0) ; fd_get(Y, YD, _), ( domain_contains(YD, X) -> true - ; B = 1 + ; kill(MState, Ps), + B = 1 ) ) - ; nonvar(Y) -> run_propagator(reified_neq(DY,Y,DX,X,B), MState) + ; nonvar(Y) -> run_propagator(reified_neq(DY,Y,DX,X,Ps,B), MState) ; X == Y -> B = 0 ; fd_get(X, _, XL, XU, _), fd_get(Y, _, YL, YU, _), - ( XL cis_gt YU -> kill(MState), B = 1 - ; YL cis_gt XU -> kill(MState), B = 1 + ( XL cis_gt YU -> kill(MState, Ps), B = 1 + ; YL cis_gt XU -> kill(MState, Ps), B = 1 ; true ) ) @@ -3756,39 +4087,27 @@ run_propagator(reified_neq(DX,X,DY,Y,B), MState) :- ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(reified_and(X,Y,B), MState) :- - ( var(B) -> - ( nonvar(X) -> - ( X =:= 0 -> B = 0 - ; X =:= 1 -> B = Y - ) - ; nonvar(Y) -> run_propagator(reified_and(Y,X,B), MState) - ; true +run_propagator(reified_and(X,Ps1,Y,Ps2,B), MState) :- + ( nonvar(X) -> + kill(MState), + ( X =:= 0 -> maplist(kill_entailed, Ps2), B = 0 + ; B = Y ) - ; B =:= 0 -> - ( X == 1 -> kill(MState), Y = 0 - ; Y == 1 -> kill(MState), X = 0 - ; true - ) - ; B =:= 1 -> kill(MState), X = 1, Y = 1 + ; nonvar(Y) -> run_propagator(reified_and(Y,Ps2,X,Ps1,B), MState) + ; B == 1 -> kill(MState), X = 1, Y = 1 + ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(reified_or(X,Y,B), MState) :- - ( var(B) -> - ( nonvar(X) -> - ( X =:= 1 -> B = 1 - ; X =:= 0 -> B = Y - ) - ; nonvar(Y) -> run_propagator(reified_or(Y,X,B), MState) - ; true - ) - ; B =:= 0 -> kill(MState), X = 0, Y = 0 - ; B =:= 1 -> - ( X == 0 -> Y = 1 - ; Y == 0 -> X = 1 - ; true +run_propagator(reified_or(X,Ps1,Y,Ps2,B), MState) :- + ( nonvar(X) -> + kill(MState), + ( X =:= 1 -> maplist(kill_entailed, Ps2), B = 1 + ; B = Y ) + ; nonvar(Y) -> run_propagator(reified_or(Y,Ps2,X,Ps1,B), MState) + ; B == 0 -> kill(MState), X = 0, Y = 0 + ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -3801,29 +4120,20 @@ run_propagator(reified_not(X,Y), MState) :- ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -run_propagator(pimpl(X, Y), MState) :- +run_propagator(pimpl(X, Y, Ps), MState) :- ( nonvar(X) -> - ( X =:= 1 -> kill(MState), Y = 1 - ; kill(MState) + kill(MState), + ( X =:= 1 -> Y = 1 + ; maplist(kill_entailed, Ps) ) ; nonvar(Y) -> - ( Y =:= 0 -> kill(MState), X = 0 - ; kill(MState) + kill(MState), + ( Y =:= 0 -> X = 0 + ; maplist(kill_entailed, Ps) ) ; true ). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -run_propagator(por(X, Y, Z), MState) :- - ( nonvar(X) -> - ( X =:= 0 -> Y = Z - ; X =:= 1 -> Z = 1 - ) - ; nonvar(Y) -> run_propagator(por(Y,X,Z), MState) - ; true - ). - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -3842,11 +4152,20 @@ max_divide_less(L1,U1,L2,U2,Max) :- ; Max cis max(max(div(L1,L2),div(L1,U2)),max(div(U1,L2),div(U1,U2))) ). +finite(n(_)). min_divide(L1,U1,L2,U2,Min) :- - ( L2 = n(NL2), NL2 > 0, U2 = n(_), cis_geq_zero(L1) -> + ( L2 = n(NL2), NL2 > 0, finite(U2), cis_geq_zero(L1) -> Min cis div(L1+U2-n(1),U2) % TODO: cover more cases + ; L1 = n(NL1), NL1 > 0, U2 cis_leq n(-1) -> Min cis div(U1,U2) + ; L1 = n(NL1), NL1 > 0 -> Min cis -U1 + ; U1 = n(NU1), NU1 < 0, U2 cis_leq n(0) -> + ( finite(L2) -> Min cis div(U1+L2+n(1),L2) + ; Min = n(1) + ) + ; U1 = n(NU1), NU1 < 0, cis_geq_zero(L2) -> Min cis div(L1,L2) + ; U1 = n(NU1), NU1 < 0 -> Min = L1 ; L2 cis_leq n(0), cis_geq_zero(U2) -> Min = inf ; Min cis min(min(div(L1,L2),div(L1,U2)),min(div(U1,L2),div(U1,U2))) ). @@ -3854,30 +4173,395 @@ max_divide(L1,U1,L2,U2,Max) :- ( L2 = n(_), cis_geq_zero(L1), cis_geq_zero(L2) -> Max cis div(U1,L2) % TODO: cover more cases + ; L1 = n(NL1), NL1 > 0, U2 cis_leq n(0) -> + ( finite(L2) -> Max cis div(L1-L2-n(1),L2) + ; Max = n(-1) + ) + ; L1 = n(NL1), NL1 > 0 -> Max = U1 + ; U1 = n(NU1), NU1 < 0, U2 cis_leq n(-1) -> Max cis div(L1,U2) + ; U1 = n(NU1), NU1 < 0, cis_geq_zero(L2) -> + ( finite(U2) -> Max cis div(U1-U2+n(1),U2) + ; Max = n(-1) + ) + ; U1 = n(NU1), NU1 < 0 -> Max cis -L1 ; L2 cis_leq n(0), cis_geq_zero(U2) -> Max = sup ; Max cis max(max(div(L1,L2),div(L1,U2)),max(div(U1,L2),div(U1,U2))) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Weak arc consistent all_distinct/1 constraint. + J-C. Régin: "A filtering algorithm for constraints of difference in + CSPs", AAAI-94, Seattle, WA, USA, pp 362--367, 1994 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ +distinct_attach(Ls) :- + must_be(list, Ls), + maplist(fd_variable, Ls), + make_propagator(pdistinct(Ls), Prop), + distinct_attach(Ls, Prop, []), + trigger_prop(Prop), + do_queue. + +distinct_attach([], _, _). +distinct_attach([X|Xs], Prop, Right) :- + ( var(X) -> + init_propagator(X, Prop), + make_propagator(pexclude(Xs,Right,X), P1), + init_propagator(X, P1), + trigger_prop(P1) + ; exclude_fire(Xs, Right, X) + ), + distinct_attach(Xs, Prop, [X|Right]). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + For each integer of the union of domains, an attributed variable is + introduced, to benefit from constant-time access. Attributes are: + + value ... integer corresponding to the node + free ... whether this (right) node is still free + edges ... [flow_from(F,From)] and [flow_to(F,To)] where F has an + attribute "flow" that is either 0 or 1 and an attribute "used" + if it is part of a maximum matching + parent ... used in breadth-first search + g0_edges ... [flow_to(F,To)] as above + visited ... true if node was visited in DFS + index, in_stack, lowlink ... used in Tarjan's SCC algorithm +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +difference_arcs(Vars, FreeLeft, FreeRight) :- + empty_assoc(E), + difference_arcs(Vars, FreeLeft, E, NumVar), + assoc_to_list(NumVar, LsNumVar), + pairs_values(LsNumVar, FreeRight). + +domain_to_list(Domain, List) :- phrase(domain_to_list(Domain), List). + +domain_to_list(split(_, Left, Right)) --> + domain_to_list(Left), domain_to_list(Right). +domain_to_list(empty) --> []. +domain_to_list(from_to(n(F),n(T))) --> { numlist(F, T, Ns) }, list(Ns). + +difference_arcs([], [], NumVar, NumVar). +difference_arcs([V|Vs], FL0, NumVar0, NumVar) :- + ( fd_get(V, Dom, _), domain_to_list(Dom, Ns) -> + FL0 = [V|FL], + enumerate(Ns, V, NumVar0, NumVar1), + difference_arcs(Vs, FL, NumVar1, NumVar) + ; difference_arcs(Vs, FL0, NumVar0, NumVar) + ). + +enumerate([], _, NumVar, NumVar). +enumerate([N|Ns], V, NumVar0, NumVar) :- + put_attr(F, flow, 0), + ( get_assoc(N, NumVar0, Y) -> + get_attr(Y, edges, Es), + put_attr(Y, edges, [flow_from(F,V)|Es]), + NumVar0 = NumVar1 + ; put_assoc(N, NumVar0, Y, NumVar1), + put_attr(Y, value, N), + put_attr(Y, edges, [flow_from(F,V)]) + ), + ( get_attr(V, edges, Es1) -> + put_attr(V, edges, [flow_to(F,Y)|Es1]) + ; put_attr(V, edges, [flow_to(F,Y)]) + ), + enumerate(Ns, V, NumVar1, NumVar). + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Strategy: Breadth-first search until we find a free right vertex in + the value graph, then find an augmenting path in reverse. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +clear_parent(V) :- del_attr(V, parent). + +maximum_matching([]). +maximum_matching([FL|FLs]) :- + augmenting_path_to(1, [[FL]], Levels, To), + phrase(augmenting_path(To, FL), Path), + maplist(maplist(clear_parent), Levels), + del_attr(To, free), + adjust_alternate_1(Path), + maximum_matching(FLs). + +reachables([]) --> []. +reachables([V|Vs]) --> + { get_attr(V, edges, Es) }, + reachables_(Es, V), + reachables(Vs). + +reachables_([], _) --> []. +reachables_([E|Es], V) --> + edge_reachable(E, V), + reachables_(Es, V). + +edge_reachable(flow_to(F,To), V) --> + ( { get_attr(F, flow, 0), + \+ get_attr(To, parent, _) } -> + { put_attr(To, parent, V-F) }, + [To] + ; [] + ). +edge_reachable(flow_from(F,From), V) --> + ( { get_attr(F, flow, 1), + \+ get_attr(From, parent, _) } -> + { put_attr(From, parent, V-F) }, + [From] + ; [] + ). + +augmenting_path_to(Level, Levels0, Levels, Right) :- + Levels0 = [Vs|_], + Levels1 = [Tos|Levels0], + phrase(reachables(Vs), Tos), + Tos = [_|_], + ( Level mod 2 =:= 1, member(Free, Tos), get_attr(Free, free, true) -> + Right = Free, Levels = Levels1 + ; Level1 is Level + 1, + augmenting_path_to(Level1, Levels1, Levels, Right) + ). + +augmenting_path(N, To) --> + ( { N == To } -> [] + ; { get_attr(N, parent, P-F) }, + [F], + augmenting_path(P, To) + ). + +adjust_alternate_1([A|Arcs]) :- + put_attr(A, flow, 1), + adjust_alternate_0(Arcs). + +adjust_alternate_0([]). +adjust_alternate_0([A|Arcs]) :- + put_attr(A, flow, 0), + adjust_alternate_1(Arcs). + +remove_ground([], _). +remove_ground([V|Vs], R) :- + neq_num(V, R), + remove_ground(Vs, R). + +% Instead of applying Berge's property directly, we can translate the +% problem in such a way, that we have to search for the so-called +% strongly connected components of the graph. + +g_g0(V) :- + get_attr(V, edges, Es), + maplist(g_g0_(V), Es). + +g_g0_(V, flow_to(F,To)) :- + ( get_attr(F, flow, 1) -> + ( get_attr(V, g0_edges, Es) -> + put_attr(V, g0_edges, [flow_to(F,To)|Es]) + ; put_attr(V, g0_edges, [flow_to(F,To)]) + ) + ; ( get_attr(To, g0_edges, Es1) -> + put_attr(To, g0_edges, [flow_to(F,V)|Es1]) + ; put_attr(To, g0_edges, [flow_to(F,V)]) + ) + ). + + +g0_successors(V, Tos) :- + ( get_attr(V, g0_edges, Tos0) -> + maplist(arg(2), Tos0, Tos) + ; Tos = [] + ). + +put_free(F) :- put_attr(F, free, true). + +free_node(F) :- + get_attr(F, free, true), + del_attr(F, free). + +distinct(Vars) :- + difference_arcs(Vars, FreeLeft, FreeRight0), + length(FreeLeft, LFL), + length(FreeRight0, LFR), + LFL =< LFR, + maplist(put_free, FreeRight0), + maximum_matching(FreeLeft), + sublist(free_node, FreeRight0, FreeRight), + maplist(g_g0, FreeLeft), + phrase(scc(FreeLeft), [s(0,[],g0_successors)], _), + maplist(dfs_used, FreeRight), + phrase(distinct_goals(FreeLeft), Gs), + maplist(distinct_clear_attributes, FreeLeft), + disable_queue, + maplist(call, Gs), + enable_queue. + +distinct_clear_attributes(V) :- + ( get_attr(V, edges, Es) -> + del_attr(V, edges), + % parent and in_stack are already cleared + maplist(del_attr(V), [index,lowlink,value,visited]), + maplist(clear_edge, Es), + ( get_attr(V, g0_edges, Es1) -> + del_attr(V, g0_edges), + maplist(clear_edge, Es1) + ; true + ) + ; true + ). + + +clear_edge(flow_to(F, To)) :- + del_attr(F, flow), + del_attr(F, used), + distinct_clear_attributes(To). +clear_edge(flow_from(X, Y)) :- clear_edge(flow_to(X, Y)). + + +distinct_goals([]) --> []. +distinct_goals([V|Vs]) --> + { get_attr(V, edges, Es) }, + distinct_edges(Es, V), + distinct_goals(Vs). + +distinct_edges([], _) --> []. +distinct_edges([flow_to(F,To)|Es], V) --> + ( { get_attr(F, flow, 0), + \+ get_attr(F, used, true), + get_attr(V, lowlink, L1), + get_attr(To, lowlink, L2), + L1 =\= L2 } -> + { get_attr(To, value, N) }, + [neq_num(V, N)] + ; [] + ), + distinct_edges(Es, V). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Mark used edges. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +dfs_used(V) :- + ( get_attr(V, visited, true) -> true + ; put_attr(V, visited, true), + ( get_attr(V, g0_edges, Es) -> + dfs_used_edges(Es) + ; true + ) + ). + +dfs_used_edges([]). +dfs_used_edges([flow_to(F,To)|Es]) :- + put_attr(F, used, true), + dfs_used(To), + dfs_used_edges(Es). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Tarjan's strongly connected components algorithm. + + DCGs are used to implicitly pass around the global index, stack + and the predicate relating a vertex to its successors. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +scc([]) --> []. +scc([V|Vs]) --> + ( vindex_defined(V) -> scc(Vs) + ; scc_(V), scc(Vs) + ). + +vindex_defined(V) --> { get_attr(V, index, _) }. + +vindex_is_index(V) --> + state(s(Index,_,_)), + { put_attr(V, index, Index) }. + +vlowlink_is_index(V) --> + state(s(Index,_,_)), + { put_attr(V, lowlink, Index) }. + +index_plus_one --> + state(s(I,Stack,Succ), s(I1,Stack,Succ)), + { I1 is I+1 }. + +s_push(V) --> + state(s(I,Stack,Succ), s(I,[V|Stack],Succ)), + { put_attr(V, in_stack, true) }. + +vlowlink_min_lowlink(V, VP) --> + { get_attr(V, lowlink, VL), + get_attr(VP, lowlink, VPL), + VL1 is min(VL, VPL), + put_attr(V, lowlink, VL1) }. + +successors(V, Tos) --> state(s(_,_,Succ)), { call(Succ, V, Tos) }. + +scc_(V) --> + vindex_is_index(V), + vlowlink_is_index(V), + index_plus_one, + s_push(V), + successors(V, Tos), + each_edge(Tos, V), + ( { get_attr(V, index, VI), + get_attr(V, lowlink, VI) } -> pop_stack_to(V, VI) + ; [] + ). + +pop_stack_to(V, N) --> + state(s(I,[First|Stack],Succ), s(I,Stack,Succ)), + { del_attr(First, in_stack) }, + ( { First == V } -> [] + ; { put_attr(First, lowlink, N) }, + pop_stack_to(V, N) + ). + +each_edge([], _) --> []. +each_edge([VP|VPs], V) --> + ( vindex_defined(VP) -> + ( v_in_stack(VP) -> + vlowlink_min_lowlink(V, VP) + ; [] + ) + ; scc_(VP), + vlowlink_min_lowlink(V, VP) + ), + each_edge(VPs, V). + +state(S), [S] --> [S]. + +state(S0, S), [S] --> [S0]. + +v_in_stack(V) --> { get_attr(V, in_stack, true) }. + %% all_distinct(+Ls). % -% Like all_different/1, with stronger propagation. +% Like all_different/1, with stronger propagation. For example, +% all_distinct/1 can detect that not all variables can assume distinct +% values given the following domains: +% +% == +% ?- maplist(in, Vs, [1\/3..4, 1..2\/4, 1..2\/4, 1..3, 1..3, 1..6]), all_distinct(Vs). +% false. +% == -%all_distinct(Ls) :- all_different(Ls). -all_distinct(Ls) :- +all_distinct(Ls) :- distinct_attach(Ls). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Weak arc consistent constraint of difference, currently only + available internally. Candidate for all_different/2 option. + + See Neng-Fa Zhou: "Programming Finite-Domain Constraint Propagators + in Action Rules", Theory and Practice of Logic Programming, Vol.6, + No.5, pp 483-508, 2006 +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +weak_arc_all_distinct(Ls) :- must_be(list, Ls), - all_distinct(Ls, [], _), + put_attr(O, clpfd_original, weak_arc_all_distinct(Ls)), + all_distinct(Ls, [], O), do_queue. all_distinct([], _, _). -all_distinct([X|Right], Left, MState) :- +all_distinct([X|Right], Left, Orig) :- %\+ list_contains(Right, X), ( var(X) -> - make_propagator(pdistinct(Left,Right,X,MState), Prop), + make_propagator(weak_distinct(Left,Right,X,Orig), Prop), init_propagator(X, Prop), trigger_prop(Prop) % make_propagator(check_distinct(Left,Right,X), Prop2), @@ -3886,20 +4570,11 @@ all_distinct([X|Right], Left, MState) :- ; exclude_fire(Left, Right, X) ), outof_reducer(Left, Right, X), - all_distinct(Right, [X|Left], MState). + all_distinct(Right, [X|Left], Orig). exclude_fire(Left, Right, E) :- - exclude_list(Left, E), - exclude_list(Right, E). - -exclude_list([], _). -exclude_list([V|Vs], Val) :- - ( fd_get(V, VD, VPs) -> - domain_remove(VD, Val, VD1), - fd_put(V, VD1, VPs) - ; V =\= Val - ), - exclude_list(Vs, Val). + remove_ground(Left, E), + remove_ground(Right, E). list_contains([X|Xs], Y) :- ( X == Y -> true @@ -3959,50 +4634,46 @@ num_subsets([S|Ss], Dom, Num0, Num, NonSubs) :- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% serialized(+Starts, +Durations) +%% serialized(+Starts, +Durations) % -% Constrain a set of intervals to a non-overlapping sequence. -% Starts = [S_1,...,S_n], is a list of variables or integers, -% Durations = [D_1,...,D_n] is a list of non-negative integers. -% Constrains Starts and Durations to denote a set of -% non-overlapping tasks, i.e.: S_i + D_i =< S_j or S_j + D_j =< -% S_i for all 1 =< i < j =< n. +% Constrain a set of intervals to a non-overlapping sequence. +% Starts = [S_1,...,S_n], is a list of variables or integers, +% Durations = [D_1,...,D_n] is a list of non-negative integers. +% Constrains Starts and Durations to denote a set of +% non-overlapping tasks, i.e.: S_i + D_i =< S_j or S_j + D_j =< +% S_i for all 1 =< i < j =< n. Example: +% +% == +% ?- length(Vs, 3), Vs ins 0..3, serialized(Vs, [1,2,3]), label(Vs). +% Vs = [0, 1, 3] ; +% Vs = [2, 0, 3] ; +% false. +% == % % @see Dorndorf et al. 2000, "Constraint Propagation Techniques for the % Disjunctive Scheduling Problem" serialized(Starts, Durations) :- must_be(list(integer), Durations), - pair_up(Starts, Durations, SDs), - serialize(SDs, []), - do_queue. - -pair_up([], [], []). -pair_up([A|As], [B|Bs], [A-n(B)|ABs]) :- pair_up(As, Bs, ABs). - -% attribute: pserialized(Var, Duration, Left, Right) -% Left and Right are lists of Start-Duration pairs representing -% other tasks occupying the same resource + pairs_keys_values(SDs, Starts, Durations), + put_attr(Orig, clpfd_original, serialized(Starts, Durations)), + serialize(SDs, Orig). serialize([], _). -serialize([Start-D|SDs], Left) :- - cis_geq_zero(D), - ( var(Start) -> - make_propagator(pserialized(Start,D,Left,SDs), Prop), - init_propagator(Start, Prop), - trigger_prop(Prop) - ; true - ), - myserialized(D, Left, SDs, Start), - serialize(SDs, [Start-D|Left]). +serialize([S-D|SDs], Orig) :- + D >= 0, + serialize(SDs, S, D, Orig), + serialize(SDs, Orig). + +serialize([], _, _, _). +serialize([S-D|Rest], S0, D0, Orig) :- + D >= 0, + propagator_init_trigger([S0,S], pserialized(S,D,S0,D0,Orig)), + serialize(Rest, S0, D0, Orig). % consistency check / propagation % Currently implements 2-b-consistency -myserialized(Duration, Left, Right, Start) :- - myserialized(Left, Start, Duration), - myserialized(Right, Start, Duration). - earliest_start_time(Start, EST) :- ( fd_get(Start, D, _) -> domain_infimum(D, EST) @@ -4015,45 +4686,40 @@ latest_start_time(Start, LST) :- ; LST = n(Start) ). -myserialized([], _, _). -myserialized([S_I-D_I|SDs], S_J, D_J) :- +serialize_lower_upper(S_I, D_I, S_J, D_J, MState) :- ( var(S_I) -> - serialize_lower_bound(S_I, D_I, Start, D_J), - ( var(S_I) -> serialize_upper_bound(S_I, D_I, Start, D_J) + serialize_lower_bound(S_I, D_I, S_J, D_J, MState), + ( var(S_I) -> serialize_upper_bound(S_I, D_I, S_J, D_J, MState) ; true ) - ; var(S_J) -> - serialize_lower_bound(S_J, D_J, S, D_I), - ( var(S_J) -> serialize_upper_bound(S_J, D_J, S, D_I) - ; true - ) - ; D_I = n(D_II), D_J = n(D_JJ), - ( S_I + D_II =< S_J -> true - ; S_J + D_JJ =< S_I -> true - ; fail - ) - ), - myserialized(SDs, S_J, D_J). + ; true + ). -serialize_lower_bound(I, D_I, J, D_J) :- +serialize_lower_bound(I, D_I, J, D_J, MState) :- fd_get(I, DomI, Ps), - domain_infimum(DomI, EST_I), - latest_start_time(J, LST_J), - ( Sum cis EST_I + D_I, Sum cis_gt LST_J -> - earliest_start_time(J, EST_J), - EST cis EST_J+D_J, + ( domain_infimum(DomI, n(EST_I)), + latest_start_time(J, n(LST_J)), + EST_I + D_I > LST_J, + earliest_start_time(J, n(EST_J)) -> + ( nonvar(J) -> kill(MState) + ; true + ), + EST is EST_J+D_J, domain_remove_smaller_than(DomI, EST, DomI1), fd_put(I, DomI1, Ps) ; true ). -serialize_upper_bound(I, D_I, J, D_J) :- +serialize_upper_bound(I, D_I, J, D_J, MState) :- fd_get(I, DomI, Ps), - domain_supremum(DomI, LST_I), - earliest_start_time(J, EST_J), - ( Sum cis EST_J + D_J, Sum cis_gt LST_I -> - latest_start_time(J, LST_J), - LST cis LST_J-D_I, + ( domain_supremum(DomI, n(LST_I)), + earliest_start_time(J, n(EST_J)), + EST_J + D_J > LST_I, + latest_start_time(J, n(LST_J)) -> + ( nonvar(J) -> kill(MState) + ; true + ), + LST is LST_J-D_I, domain_remove_greater_than(DomI, LST, DomI1), fd_put(I, DomI1, Ps) ; true @@ -4061,18 +4727,791 @@ serialize_upper_bound(I, D_I, J, D_J) :- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% element(?N, +Is, ?I) +%% element(?N, +Vs, ?V) % -% The N-th element of the list of integers Is is I. Analogous to nth1/3. +% The N-th element of the list of finite domain variables Vs is V. +% Analogous to nth1/3. -element(N, Is, I) :- +element(N, Is, V) :- must_be(list, Is), length(Is, L), - numlist(1, L, Ns), - maplist(twolist, Ns, Is, Rs), - tuples_in([[N,I]], Rs). + N in 1..L, + element_(Is, 1, N, V), + propagator_init_trigger([N|Is], pelement(N,Is,V)). -twolist(N, I, [N,I]). +element_domain(V, VD) :- + ( fd_get(V, VD, _) -> true + ; VD = from_to(n(V), n(V)) + ). + +element_([], _, _, _). +element_([I|Is], N0, N, V) :- + I #\= V #==> N #\= N0, + N1 is N0 + 1, + element_(Is, N1, N, V). + +integers_remaining([], _, _, D, D). +integers_remaining([V|Vs], N0, Dom, D0, D) :- + ( domain_contains(Dom, N0) -> + element_domain(V, VD), + domains_union(D0, VD, D1) + ; D1 = D0 + ), + N1 is N0 + 1, + integers_remaining(Vs, N1, Dom, D1, D). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% global_cardinality(+Vs, +Pairs) +% +% Vs is a list of finite domain variables, Pairs is a list of +% Key-Num pairs, where Key is an integer and Num is a finite +% domain variable. The constraint holds iff each V in Vs is equal +% to some key, and for each Key-Num pair in Pairs, the number of +% occurrences of Key in Vs is Num. +% +% Example: +% +% == +% ?- Vs = [_,_,_], global_cardinality(Vs, [1-2,3-_]), label(Vs). +% Vs = [1, 1, 3] ; +% Vs = [1, 3, 1] ; +% Vs = [3, 1, 1]. +% == + +global_cardinality(Xs, Pairs) :- + must_be(list, Xs), + maplist(fd_variable, Xs), + must_be(list, Pairs), + maplist(gcc_pair, Pairs), + pairs_keys_values(Pairs, Keys, Nums), + ( sort(Keys, Keys1), length(Keys, LK), length(Keys1, LK) -> true + ; domain_error(gcc_unique_key_pairs, Pairs) + ), + length(Xs, L), + Nums ins 0..L, + list_to_domain(Keys, Dom), + domain_to_drep(Dom, Drep), + Xs ins Drep, + gcc_pairs(Pairs, Xs, Pairs1), + % pgcc_check must be installed before triggering other + % propagators + propagator_init_trigger(Xs, pgcc_check(Pairs1)), + propagator_init_trigger(Nums, pgcc_single(Xs, Pairs1)), + propagator_init_trigger(Nums, pgcc_check_single(Pairs1)), + propagator_init_trigger(Xs, pgcc(Xs, Pairs, Pairs1)). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + For each Key-Num0 pair, we introduce an auxiliary variable Num and + attach the following attributes to it: + + clpfd_gcc_num: equal Num0, the user-visible counter variable + clpfd_gcc_vs: the remaining variables in the constraint that can be + equal Key. + clpfd_gcc_occurred: stores how often Key already occurred in vs. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +gcc_pairs([], _, []). +gcc_pairs([Key-Num0|KNs], Vs, [Key-Num|Rest]) :- + put_attr(Num, clpfd_gcc_num, Num0), + put_attr(Num, clpfd_gcc_vs, Vs), + put_attr(Num, clpfd_gcc_occurred, 0), + gcc_pairs(KNs, Vs, Rest). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + J.-C. Régin: "Generalized Arc Consistency for Global Cardinality + Constraint", AAAI-96 Portland, OR, USA, pp 209--215, 1996 +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +gcc_global(Vs, KNs) :- + gcc_check(KNs), + % reach fix-point: all elements of clpfd_gcc_vs must be variables + do_queue, + gcc_arcs(KNs, S, Vals), + variables_with_num_occurrences(Vs, VNs), + maplist(target_to_v(T), VNs), + ( get_attr(S, edges, Es) -> + put_attr(S, parent, none), % Mark S as seen to avoid going back to S. + feasible_flow(Es, S, T), % First construct a feasible flow (if any) + maximum_flow(S, T), % only then, maximize it. + gcc_consistent(T), + del_attr(S, parent), + phrase(scc(Vals), [s(0,[],gcc_successors)], _), + phrase(gcc_goals(Vals), Gs), + gcc_clear(S), + disable_queue, + maplist(call, Gs), + enable_queue + ; true + ). + +gcc_consistent(T) :- + get_attr(T, edges, Es), + maplist(positive_flow, Es). + +positive_flow(arc_from(_,_,_,Flow)) :- get_attr(Flow, flow, F), F > 0. + +gcc_goals([]) --> []. +gcc_goals([Val|Vals]) --> + { get_attr(Val, edges, Es) }, + gcc_edges_goals(Es, Val), + gcc_goals(Vals). + +gcc_edges_goals([], _) --> []. +gcc_edges_goals([E|Es], Val) --> + gcc_edge_goal(E, Val), + gcc_edges_goals(Es, Val). + +gcc_edge_goal(arc_from(_,_,_,_), _) --> []. +gcc_edge_goal(arc_to(_,_,V,F), Val) --> + ( { get_attr(F, flow, 0), + get_attr(V, lowlink, L1), + get_attr(Val, lowlink, L2), + L1 =\= L2, + get_attr(Val, value, Value) } -> + [neq_num(V, Value)] + ; [] + ). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Like in all_distinct/1, first use breadth-first search, then + construct an augmenting path in reverse. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +maximum_flow(S, T) :- + ( gcc_augmenting_path([[S]], Levels, T) -> + phrase(gcc_augmenting_path(S, T), Path), + Path = [augment(_,First,_)|Rest], + path_minimum(Rest, First, Min), + maplist(gcc_augment(Min), Path), + maplist(maplist(clear_parent), Levels), + maximum_flow(S, T) + ; true + ). + +feasible_flow([], _, _). +feasible_flow([A|As], S, T) :- + make_arc_feasible(A, S, T), + feasible_flow(As, S, T). + +make_arc_feasible(A, S, T) :- + A = arc_to(L,_,V,F), + get_attr(F, flow, Flow), + ( Flow >= L -> true + ; Diff is L - Flow, + put_attr(V, parent, S-augment(F,Diff,+)), + gcc_augmenting_path([[V]], Levels, T), + phrase(gcc_augmenting_path(S, T), Path), + path_minimum(Path, Diff, Min), + maplist(gcc_augment(Min), Path), + maplist(maplist(clear_parent), Levels), + make_arc_feasible(A, S, T) + ). + +gcc_augmenting_path(Levels0, Levels, T) :- + Levels0 = [Vs|_], + Levels1 = [Tos|Levels0], + phrase(gcc_reachables(Vs), Tos), + Tos = [_|_], + ( member(To, Tos), To == T -> Levels = Levels1 + ; gcc_augmenting_path(Levels1, Levels, T) + ). + +gcc_reachables([]) --> []. +gcc_reachables([V|Vs]) --> + { get_attr(V, edges, Es) }, + gcc_reachables_(Es, V), + gcc_reachables(Vs). + +gcc_reachables_([], _) --> []. +gcc_reachables_([E|Es], V) --> + gcc_reachable(E, V), + gcc_reachables_(Es, V). + +gcc_reachable(arc_from(_,_,V,F), P) --> + ( { \+ get_attr(V, parent, _), + get_attr(F, flow, Flow), + Flow > 0 } -> + { put_attr(V, parent, P-augment(F,Flow,-)) }, + [V] + ; [] + ). +gcc_reachable(arc_to(_L,U,V,F), P) --> + ( { \+ get_attr(V, parent, _), + get_attr(F, flow, Flow), + Flow < U } -> + { Diff is U - Flow, + put_attr(V, parent, P-augment(F,Diff,+)) }, + [V] + ; [] + ). + + +path_minimum([], Min, Min). +path_minimum([augment(_,A,_)|As], Min0, Min) :- + Min1 is min(Min0,A), + path_minimum(As, Min1, Min). + +gcc_augment(Min, augment(F,_,Sign)) :- + get_attr(F, flow, Flow0), + gcc_flow_(Sign, Flow0, Min, Flow), + put_attr(F, flow, Flow). + +gcc_flow_(+, F0, A, F) :- F is F0 + A. +gcc_flow_(-, F0, A, F) :- F is F0 - A. + +gcc_augmenting_path(S, V) --> + ( { V == S } -> [] + ; { get_attr(V, parent, V1-Augment) }, + [Augment], + gcc_augmenting_path(S, V1) + ). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Build value network for global cardinality constraint. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +gcc_arcs([], _, []). +gcc_arcs([Key-Num0|KNs], S, Vals) :- + ( get_attr(Num0, clpfd_gcc_vs, Vs) -> + get_attr(Num0, clpfd_gcc_num, Num), + get_attr(Num0, clpfd_gcc_occurred, Occ), + ( nonvar(Num) -> U is Num - Occ, U = L + ; fd_get(Num, _, n(L0), n(U0), _), + L is L0 - Occ, U is U0 - Occ + ), + put_attr(Val, value, Key), + Vals = [Val|Rest], + Edge = arc_to(L, U, Val, F), + put_attr(F, flow, 0), + ( get_attr(S, edges, SEs) -> + put_attr(S, edges, [Edge|SEs]) + ; put_attr(S, edges, [Edge]) + ), + put_attr(Val, edges, [arc_from(L, U, S, F)]), + variables_with_num_occurrences(Vs, VNs), + maplist(val_to_v(Val), VNs) + ; Vals = Rest + ), + gcc_arcs(KNs, S, Rest). + +variables_with_num_occurrences(Vs0, VNs) :- + include(var, Vs0, Vs1), + msort(Vs1, Vs), + ( Vs == [] -> VNs = [] + ; Vs = [V|Rest], + variables_with_num_occurrences(Rest, V, 1, VNs) + ). + +variables_with_num_occurrences([], Prev, Count, [Prev-Count]). +variables_with_num_occurrences([V|Vs], Prev, Count0, VNs) :- + ( V == Prev -> + Count1 is Count0 + 1, + variables_with_num_occurrences(Vs, Prev, Count1, VNs) + ; VNs = [Prev-Count0|Rest], + variables_with_num_occurrences(Vs, V, 1, Rest) + ). + + +target_to_v(T, V-Count) :- + ( get_attr(V, edges, VarEs) -> true + ; VarEs = [] + ), + put_attr(F, flow, 0), + put_attr(V, edges, [arc_to(0, Count, T, F)|VarEs]), + TE = arc_from(0, Count, V, F), + ( get_attr(T, edges, TEs) -> + put_attr(T, edges, [TE|TEs]) + ; put_attr(T, edges, [TE]) + ). + + +val_to_v(Val, V-Count) :- + put_attr(F, flow, 0), + ( get_attr(V, edges, VarEs) -> true + ; VarEs = [] + ), + put_attr(V, edges, [arc_from(0, Count, Val, F)|VarEs]), + get_attr(Val, edges, VEs), + put_attr(Val, edges, [arc_to(0, Count, V, F)|VEs]). + + +gcc_clear(V) :- + ( get_attr(V, edges, Es) -> + maplist(del_attr(V), [edges,index,lowlink,value]), + maplist(gcc_clear_edge, Es) + ; true + ). + +gcc_clear_edge(arc_to(_,_,V,F)) :- + del_attr(F, flow), + gcc_clear(V). +gcc_clear_edge(arc_from(L,U,V,F)) :- gcc_clear_edge(arc_to(L,U,V,F)). + + +gcc_successors(V, Tos) :- + get_attr(V, edges, Tos0), + phrase(gcc_successors_(Tos0), Tos). + +gcc_successors_([]) --> []. +gcc_successors_([E|Es]) --> gcc_succ_edge(E), gcc_successors_(Es). + +gcc_succ_edge(arc_to(_,U,V,F)) --> + ( { get_attr(F, flow, Flow), + Flow < U } -> [V] + ; [] + ). +gcc_succ_edge(arc_from(_,_,V,F)) --> + ( { get_attr(F, flow, Flow), + Flow > 0 } -> [V] + ; [] + ). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Simple consistency check, run before global propagation. + Importantly, it removes all ground values from clpfd_gcc_vs. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +gcc_done(Num) :- + del_attr(Num, clpfd_gcc_vs), + del_attr(Num, clpfd_gcc_num), + del_attr(Num, clpfd_gcc_occurred). + +gcc_check(Pairs) :- + disable_queue, + gcc_check_(Pairs), + enable_queue. + +gcc_check_([]). +gcc_check_([Key-Num0|KNs]) :- + ( get_attr(Num0, clpfd_gcc_vs, Vs) -> + get_attr(Num0, clpfd_gcc_num, Num), + get_attr(Num0, clpfd_gcc_occurred, Occ0), + vs_key_min_others(Vs, Key, 0, Min, Os), + put_attr(Num0, clpfd_gcc_vs, Os), + put_attr(Num0, clpfd_gcc_occurred, Occ1), + Occ1 is Occ0 + Min, + % The queue must be disabled when posting constraints + % here, otherwise the stored (new) occurrences can differ + % from the (old) ones used in the following. + geq(Num, Occ1), + ( Occ1 == Num -> gcc_done(Num0), all_neq(Os, Key) + ; Os == [] -> gcc_done(Num0), Num = Occ1 + ; length(Os, L), + Max is Occ1 + L, + geq(Max, Num), + ( nonvar(Num) -> Diff is Num - Occ1 + ; fd_get(Num, ND, _), + domain_infimum(ND, n(NInf)), + Diff is NInf - Occ1 + ), + L >= Diff, + ( L =:= Diff -> + gcc_done(Num0), + Num is Occ1 + Diff, + maplist(=(Key), Os) + ; true + ) + ) + ; true + ), + gcc_check_(KNs). + +vs_key_min_others([], _, Min, Min, []). +vs_key_min_others([V|Vs], Key, Min0, Min, Others) :- + ( fd_get(V, VD, _) -> + ( domain_contains(VD, Key) -> + Others = [V|Rest], + vs_key_min_others(Vs, Key, Min0, Min, Rest) + ; vs_key_min_others(Vs, Key, Min0, Min, Others) + ) + ; ( V =:= Key -> + Min1 is Min0 + 1, + vs_key_min_others(Vs, Key, Min1, Min, Others) + ; vs_key_min_others(Vs, Key, Min0, Min, Others) + ) + ). + +all_neq([], _). +all_neq([X|Xs], C) :- + neq_num(X, C), + all_neq(Xs, C). + +gcc_pair(Pair) :- + ( Pair = Key-Val -> + must_be(integer, Key), + fd_variable(Val) + ; domain_error(gcc_pair, Pair) + ). + +%% global_cardinality(+Vs, +Pairs, +Options) +% +% Like global_cardinality/2, with Options a list of options. +% Currently, the only supported option is +% +% * cost(Cost, Matrix) +% Matrix is a list of rows, one for each variable, in the order +% they occur in Vs. Each of these rows is a list of integers, one +% for each key, in the order these keys occur in Pairs. When +% variable v_i is assigned the value of key k_j, then the +% associated cost is Matrix_{ij}. Cost is the sum of all costs. + + +global_cardinality(Xs, Pairs, Options) :- + global_cardinality(Xs, Pairs), + Options = [cost(Cost, Matrix)], + must_be(list(list(integer)), Matrix), + pairs_keys_values(Pairs, Keys, _), + maplist(keys_costs(Keys), Xs, Matrix, Costs), + sum(Costs, #=, Cost). + +keys_costs(Keys, X, Row, C) :- + element(N, Keys, X), + element(N, Row, C). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% circuit(+Vs) +% +% True if the list Vs of finite domain variables induces a +% Hamiltonian circuit, where the k-th element of Vs denotes the +% successor of node k. Node indexing starts with 1. Examples: +% +% == +% ?- length(Vs, _), circuit(Vs), label(Vs). +% Vs = [] ; +% Vs = [1] ; +% Vs = [2, 1] ; +% Vs = [2, 3, 1] ; +% Vs = [3, 1, 2] ; +% Vs = [2, 3, 4, 1] . +% == + +circuit(Vs) :- + must_be(list, Vs), + maplist(fd_variable, Vs), + length(Vs, L), + Vs ins 1..L, + ( L =:= 1 -> true + ; all_circuit(Vs, 1), + make_propagator(pcircuit(Vs), Prop), + distinct_attach(Vs, Prop, []), + trigger_prop(Prop), + do_queue + ). + +all_circuit([], _). +all_circuit([X|Xs], N) :- + neq_num(X, N), + N1 is N + 1, + all_circuit(Xs, N1). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Necessary condition for existence of a Hamiltonian circuit: The + graph has a single strongly connected component. If the list is + ground, the condition is also sufficient. + + Ts are used as temporary variables to attach attributes: + + lowlink, index: used for SCC + [arc_to(V)]: possible successors +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +propagate_circuit(Vs) :- + length(Vs, N), + length(Ts, N), + circuit_graph(Vs, Ts, Ts), + phrase(scc(Ts), [s(0,[],circuit_successors)], _), + ( maplist(single_component, Ts) -> Continuation = true + ; Continuation = false + ), + maplist(del_attrs, Ts), + Continuation. + +single_component(V) :- get_attr(V, lowlink, 0). + +circuit_graph([], _, _). +circuit_graph([V|Vs], Ts0, [T|Ts]) :- + put_attr(T, clpfd_var, V), + ( nonvar(V) -> Ns = [V] + ; fd_get(V, Dom, _), + domain_to_list(Dom, Ns) + ), + phrase(circuit_edges(Ns, Ts0), Es), + put_attr(T, edges, Es), + circuit_graph(Vs, Ts0, Ts). + +circuit_edges([], _) --> []. +circuit_edges([N|Ns], Ts) --> + { nth1(N, Ts, T) }, + [arc_to(T)], + circuit_edges(Ns, Ts). + +circuit_successors(V, Tos) :- + get_attr(V, edges, Tos0), + maplist(arg(1), Tos0, Tos). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% automaton(+Signature, +Nodes, +Arcs) +% +% Equivalent to automaton(_, _, Signature, Nodes, Arcs, [], [], _), a +% common use case of automaton/8. In the following example, a list of +% binary finite domain variables is constrained to contain at least +% two consecutive ones: +% +% == +% two_consecutive_ones(Vs) :- +% automaton(Vs, [source(a),sink(c)], +% [arc(a,0,a), arc(a,1,b), +% arc(b,0,a), arc(b,1,c), +% arc(c,0,c), arc(c,1,c)]). +% +% ?- length(Vs, 3), two_consecutive_ones(Vs), label(Vs). +% Vs = [0, 1, 1] ; +% Vs = [1, 1, 0] ; +% Vs = [1, 1, 1]. +% == + +automaton(Sigs, Ns, As) :- automaton(_, _, Sigs, Ns, As, [], [], _). + + +%% automaton(?Sequence, ?Template, +Signature, +Nodes, +Arcs, +Counters, +Initials, ?Finals) +% +% True if the finite automaton induced by Nodes and Arcs (extended +% with Counters) accepts Signature. Sequence is a list of terms, all +% of the same shape. Additional constraints must link Sequence to +% Signature, if necessary. Nodes is a list of source(Node) and +% sink(Node) terms. Arcs is a list of arc(Node,Integer,Node) and +% arc(Node,Integer,Node,Exprs) terms that denote the automaton's +% transitions. Each node is represented by an arbitrary term. +% Transitions that are not mentioned go to an implicit failure node. +% Exprs is a list of arithmetic expressions, of the same length as +% Counters. In each expression, variables occurring in Counters +% correspond to old counter values, and variables occurring in +% Template correspond to the current element of Sequence. When a +% transition containing expressions is taken, counters are updated as +% stated. By default, counters remain unchanged. Counters is a list +% of variables that must not occur anywhere outside of the constraint +% goal. Initials is a list of the same length as Counters. Counter +% arithmetic on the transitions relates the counter values in +% Initials to Finals. +% +% The following example is taken from Beldiceanu, Carlsson, Debruyne +% and Petit: "Reformulation of Global Constraints Based on +% Constraints Checkers", Constraints 10(4), pp 339-362 (2005). It +% relates a sequence of integers and finite domain variables to its +% number of inflexions, which are switches between strictly ascending +% and strictly descending subsequences: +% +% == +% sequence_inflexions(Vs, N) :- +% variables_signature(Vs, Sigs), +% Sigs ins 0..2, +% automaton(_, _, Sigs, +% [source(s),sink(i),sink(j),sink(s)], +% [arc(s,0,s), arc(s,1,j), arc(s,2,i), +% arc(i,0,i), arc(i,1,j,[C+1]), arc(i,2,i), +% arc(j,0,j), arc(j,1,j), arc(j,2,i,[C+1])], [C], [0], [N]). +% +% variables_signature([], []). +% variables_signature([V|Vs], Sigs) :- +% variables_signature_(Vs, V, Sigs). +% +% variables_signature_([], _, []). +% variables_signature_([V|Vs], Prev, [S|Sigs]) :- +% V #= Prev #<==> S #= 0, +% Prev #< V #<==> S #= 1, +% Prev #> V #<==> S #= 2, +% variables_signature_(Vs, V, Sigs). +% == +% +% Example queries: +% +% == +% ?- sequence_inflexions([1,2,3,3,2,1,3,0], N). +% N = 3. +% +% ?- length(Ls, 5), Ls ins 0..1, sequence_inflexions(Ls, 3), label(Ls). +% Ls = [0, 1, 0, 1, 0] ; +% Ls = [1, 0, 1, 0, 1]. +% == + +template_var_path(V, Var, []) :- var(V), !, V == Var. +template_var_path(T, Var, [N|Ns]) :- + arg(N, T, Arg), + template_var_path(Arg, Var, Ns). + +path_term_variable([], V, V). +path_term_variable([P|Ps], T, V) :- + arg(P, T, Arg), + path_term_variable(Ps, Arg, V). + +initial_expr(_, []-1). + +automaton(Seqs, Template, Sigs, Ns, As0, Cs, Is, Fs) :- + must_be(list(list), [Sigs,Ns,As0,Cs,Is]), + ( var(Seqs) -> Seqs = Sigs + ; must_be(list, Seqs) + ), + memberchk(source(Source), Ns), + maplist(arc_normalized(Cs), As0, As), + include(sink, Ns, Sinks0), + maplist(arg(1), Sinks0, Sinks), + maplist(initial_expr, Cs, Exprs0), + phrase((arcs_relation(As, Relation), + nodes_nums(Sinks, SinkNums0), + node_num(Source, Start)), + [s([]-0, Exprs0)], [s(_,Exprs1)]), + maplist(expr0_expr, Exprs1, Exprs), + phrase(transitions(Seqs, Template, Sigs, Start, End, Exprs, Cs, Is, Fs), Tuples), + list_to_domain(SinkNums0, SinkDom), + domain_to_drep(SinkDom, SinkDrep), + tuples_in(Tuples, Relation), + End in SinkDrep. + +expr0_expr(Es0-_, Es) :- + pairs_keys_values(Es0, Es1, _), + reverse(Es1, Es). + +transitions([], _, [], S, S, _, _, Cs, Cs) --> []. +transitions([Seq|Seqs], Template, [Sig|Sigs], S0, S, Exprs, Counters, Cs0, Cs) --> + [[S0,Sig,S1|Is]], + { phrase(exprs_next(Exprs, Is, Cs1), [s(Seq,Template,Counters,Cs0)], _) }, + transitions(Seqs, Template, Sigs, S1, S, Exprs, Counters, Cs1, Cs). + +exprs_next([], [], []) --> []. +exprs_next([Es|Ess], [I|Is], [C|Cs]) --> + exprs_values(Es, Vs), + { element(I, Vs, C) }, + exprs_next(Ess, Is, Cs). + +exprs_values([], []) --> []. +exprs_values([E0|Es], [V|Vs]) --> + { term_variables(E0, EVs0), + copy_term(E0, E), + term_variables(E, EVs), + V #= E }, + match_variables(EVs0, EVs), + exprs_values(Es, Vs). + +match_variables([], _) --> []. +match_variables([V0|Vs0], [V|Vs]) --> + state(s(Seq,Template,Counters,Cs0)), + { ( template_var_path(Template, V0, Ps) -> + path_term_variable(Ps, Seq, V) + ; template_var_path(Counters, V0, Ps) -> + path_term_variable(Ps, Cs0, V) + ; domain_error(variable_from_template_or_counters, V0) + ) }, + match_variables(Vs0, Vs). + +nodes_nums([], []) --> []. +nodes_nums([Node|Nodes], [Num|Nums]) --> + node_num(Node, Num), + nodes_nums(Nodes, Nums). + +arcs_relation([], []) --> []. +arcs_relation([arc(S0,L,S1,Es)|As], [[From,L,To|Ns]|Rs]) --> + node_num(S0, From), + node_num(S1, To), + state(s(Nodes, Exprs0), s(Nodes, Exprs)), + { exprs_nums(Es, Ns, Exprs0, Exprs) }, + arcs_relation(As, Rs). + +exprs_nums([], [], [], []). +exprs_nums([E|Es], [N|Ns], [Ex0-C0|Exs0], [Ex-C|Exs]) :- + ( member(Exp-N, Ex0), Exp == E -> C = C0, Ex = Ex0 + ; N = C0, C is C0 + 1, Ex = [E-C0|Ex0] + ), + exprs_nums(Es, Ns, Exs0, Exs). + +node_num(Node, Num) --> + state(s(Nodes0-C0, Exprs), s(Nodes-C, Exprs)), + { ( member(N-Num, Nodes0), N == Node -> C = C0, Nodes = Nodes0 + ; Num = C0, C is C0 + 1, Nodes = [Node-C0|Nodes0] + ) + }. + +sink(sink(_)). + +arc_normalized(Cs, Arc0, Arc) :- arc_normalized_(Arc0, Cs, Arc). + +arc_normalized_(arc(S0,L,S,Cs), _, arc(S0,L,S,Cs)). +arc_normalized_(arc(S0,L,S), Cs, arc(S0,L,S,Cs)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% transpose(+Matrix, ?Transpose) +% +% Transpose a list of lists of the same length. Example: +% +% == +% ?- transpose([[1,2,3],[4,5,6],[7,8,9]], Ts). +% Ts = [[1, 4, 7], [2, 5, 8], [3, 6, 9]]. +% == +% +% This predicate is useful in many constraint programs. Consider for +% instance Sudoku: +% +% == +% sudoku(Rows) :- +% length(Rows, 9), maplist(length_(9), Rows), +% append(Rows, Vs), Vs ins 1..9, +% maplist(all_distinct, Rows), +% transpose(Rows, Columns), maplist(all_distinct, Columns), +% Rows = [A,B,C,D,E,F,G,H,I], +% blocks(A, B, C), blocks(D, E, F), blocks(G, H, I). +% +% length_(L, Ls) :- length(Ls, L). +% +% blocks([], [], []). +% blocks([A,B,C|Bs1], [D,E,F|Bs2], [G,H,I|Bs3]) :- +% all_distinct([A,B,C,D,E,F,G,H,I]), +% blocks(Bs1, Bs2, Bs3). +% +% problem(1, [[_,_,_,_,_,_,_,_,_], +% [_,_,_,_,_,3,_,8,5], +% [_,_,1,_,2,_,_,_,_], +% [_,_,_,5,_,7,_,_,_], +% [_,_,4,_,_,_,1,_,_], +% [_,9,_,_,_,_,_,_,_], +% [5,_,_,_,_,_,_,7,3], +% [_,_,2,_,1,_,_,_,_], +% [_,_,_,_,4,_,_,_,9]]). +% == +% +% Sample query: +% +% == +% ?- problem(1, Rows), sudoku(Rows), maplist(writeln, Rows). +% [9, 8, 7, 6, 5, 4, 3, 2, 1] +% [2, 4, 6, 1, 7, 3, 9, 8, 5] +% [3, 5, 1, 9, 2, 8, 7, 4, 6] +% [1, 2, 8, 5, 3, 7, 6, 9, 4] +% [6, 3, 4, 8, 9, 2, 1, 5, 7] +% [7, 9, 5, 4, 6, 1, 8, 3, 2] +% [5, 1, 9, 2, 8, 6, 4, 7, 3] +% [4, 7, 2, 3, 1, 9, 5, 6, 8] +% [8, 6, 3, 7, 4, 5, 2, 1, 9] +% Rows = [[9, 8, 7, 6, 5, 4, 3, 2|...], ... , [...|...]]. +% == + +transpose(Ms, Ts) :- + must_be(list(list), Ms), + ( Ms = [] -> Ts = [] + ; Ms = [F|_], + transpose(F, Ms, Ts) + ). + +transpose([], _, []). +transpose([_|Rs], Ms, [Ts|Tss]) :- + lists_firsts_rests(Ms, Ts, Ms1), + transpose(Rs, Ms1, Tss). + +lists_firsts_rests([], [], []). +lists_firsts_rests([[F|Os]|Rest], [F|Fs], [Os|Oss]) :- + lists_firsts_rests(Rest, Fs, Oss). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -4103,10 +5542,7 @@ zcompare(Order, A, B) :- ; freeze(Order, zcompare_(Order, A, B)), fd_variable(A), fd_variable(B), - make_propagator(pzcompare(Order, A, B), Prop), - init_propagator(A, Prop), - init_propagator(B, Prop), - trigger_once(Prop) + propagator_init_trigger(pzcompare(Order, A, B)) ). zcompare_(=, A, B) :- A #= B. @@ -4298,89 +5734,115 @@ attribute_goals(X) --> attributes_goals(Ps). clpfd_aux:attribute_goals(_) --> []. +clpfd_aux:attr_unify_hook(_,_) :- false. + +clpfd_gcc_vs:attribute_goals(_) --> []. +clpfd_gcc_vs:attr_unify_hook(_,_) :- false. + +clpfd_gcc_num:attribute_goals(_) --> []. +clpfd_gcc_num:attr_unify_hook(_,_) :- false. + +clpfd_gcc_occurred:attribute_goals(_) --> []. +clpfd_gcc_occurred:attr_unify_hook(_,_) :- false. + +clpfd_relation:attribute_goals(_) --> []. +clpfd_relation:attr_unify_hook(_,_) :- false. + +clpfd_original:attribute_goals(_) --> []. +clpfd_original:attr_unify_hook(_,_) :- false. attributes_goals([]) --> []. attributes_goals([propagator(P, State)|As]) --> ( { ground(State) } -> [] - ; { ( functor(P, pdifferent, _) ; functor(P, pdistinct, _) ), - arg(4, P, S), S == processed } -> [] - ; { attribute_goal_(P, G) } -> + ; { phrase(attribute_goal_(P), Gs) } -> { del_attr(State, clpfd_aux), State = processed }, - [clpfd:G] + with_clpfd(Gs) ; [P] % possibly user-defined constraint ), attributes_goals(As). -attribute_goal_(presidual(Goal), Goal). -attribute_goal_(pgeq(A,B), A #>= B). -attribute_goal_(pplus(X,Y,Z), X + Y #= Z). -attribute_goal_(pneq(A,B), A #\= B). -attribute_goal_(ptimes(X,Y,Z), X*Y #= Z). -attribute_goal_(absdiff_neq(X,Y,C), abs(X-Y) #\= C). -attribute_goal_(x_neq_y_plus_z(X,Y,Z), X #\= Y + Z). -attribute_goal_(x_leq_y_plus_c(X,Y,C), X #=< Y + C). -attribute_goal_(pdiv(X,Y,Z), X/Y #= Z). -attribute_goal_(pexp(X,Y,Z), X^Y #= Z). -attribute_goal_(pabs(X,Y), Y #= abs(X)). -attribute_goal_(pmod(X,M,K), X mod M #= K). -attribute_goal_(pmax(X,Y,Z), Z #= max(X,Y)). -attribute_goal_(pmin(X,Y,Z), Z #= min(X,Y)). -attribute_goal_(scalar_product(Cs,Vs,Op,C), Goal) :- - Cs = [FC|Cs1], Vs = [FV|Vs1], - coeff_var_term(FC, FV, T0), - unfold_product(Cs1, Vs1, T0, Left), - Goal =.. [Op,Left,C]. -attribute_goal_(pdifferent(Left, Right, X, Shared), all_different(Vs)) :- - append(Left, [X|Right], Vs0), - msort(Vs0, Vs), - Shared = processed. -attribute_goal_(pdistinct(Left, Right, X, Shared), all_distinct(Vs)) :- - append(Left, [X|Right], Vs0), - msort(Vs0, Vs), - Shared = processed. -attribute_goal_(pserialized(Var,D,Left,Right), serialized(Vs, Ds)) :- - append(Left, [Var-D|Right], VDs), - pair_up(Vs, Ds, VDs). -attribute_goal_(rel_tuple(mutable(Rel,_), Tuple), tuples_in([Tuple], Rel)). -attribute_goal_(pzcompare(O,A,B), zcompare(O,A,B)). +with_clpfd([]) --> []. +with_clpfd([G|Gs]) --> [clpfd:G], with_clpfd(Gs). + +attribute_goal_(presidual(Goal)) --> [Goal]. +attribute_goal_(pgeq(A,B)) --> [A #>= B]. +attribute_goal_(pplus(X,Y,Z)) --> [X + Y #= Z]. +attribute_goal_(pneq(A,B)) --> [A #\= B]. +attribute_goal_(ptimes(X,Y,Z)) --> [X*Y #= Z]. +attribute_goal_(absdiff_neq(X,Y,C)) --> [abs(X-Y) #\= C]. +attribute_goal_(absdiff_geq(X,Y,C)) --> [abs(X-Y) #>= C]. +attribute_goal_(x_neq_y_plus_z(X,Y,Z)) --> [X #\= Y + Z]. +attribute_goal_(x_leq_y_plus_c(X,Y,C)) --> [X #=< Y + C]. +attribute_goal_(pdiv(X,Y,Z)) --> [X/Y #= Z]. +attribute_goal_(pexp(X,Y,Z)) --> [X^Y #= Z]. +attribute_goal_(pabs(X,Y)) --> [Y #= abs(X)]. +attribute_goal_(pmod(X,M,K)) --> [X mod M #= K]. +attribute_goal_(pmax(X,Y,Z)) --> [Z #= max(X,Y)]. +attribute_goal_(pmin(X,Y,Z)) --> [Z #= min(X,Y)]. +attribute_goal_(scalar_product_neq([FC|Cs],[FV|Vs],C)) --> + [Left #\= C], + { coeff_var_term(FC, FV, T0), fold_product(Cs, Vs, T0, Left) }. +attribute_goal_(scalar_product_eq([FC|Cs],[FV|Vs],C)) --> + [Left #= C], + { coeff_var_term(FC, FV, T0), fold_product(Cs, Vs, T0, Left) }. +attribute_goal_(scalar_product_leq([FC|Cs],[FV|Vs],C)) --> + [Left #=< C], + { coeff_var_term(FC, FV, T0), fold_product(Cs, Vs, T0, Left) }. +attribute_goal_(pdifferent(_,_,_,O)) --> original_goal(O). +attribute_goal_(weak_distinct(_,_,_,O)) --> original_goal(O). +attribute_goal_(pdistinct(Vs)) --> [all_distinct(Vs)]. +attribute_goal_(pexclude(_,_,_)) --> []. +attribute_goal_(pelement(N,Is,V)) --> [element(N, Is, V)]. +attribute_goal_(pgcc(Vs, Pairs, _)) --> [global_cardinality(Vs, Pairs)]. +attribute_goal_(pgcc_single(_,_)) --> []. +attribute_goal_(pgcc_check_single(_)) --> []. +attribute_goal_(pgcc_check(_)) --> []. +attribute_goal_(pcircuit(Vs)) --> [circuit(Vs)]. +attribute_goal_(pserialized(_,_,_,_,O)) --> original_goal(O). +attribute_goal_(rel_tuple(R, Tuple)) --> + { get_attr(R, clpfd_relation, Rel) }, + [tuples_in([Tuple], Rel)]. +attribute_goal_(pzcompare(O,A,B)) --> [zcompare(O,A,B)]. % reified constraints -attribute_goal_(reified_in(V, D, B), V in Drep #<==> B) :- - domain_to_drep(D, Drep). -attribute_goal_(reified_fd(V,B), finite_domain(V) #<==> B). -attribute_goal_(reified_neq(DX, X, DY, Y, B), (DX #/\ DY #/\ X #\= Y) #<==> B). -attribute_goal_(reified_eq(DX, X, DY, Y, B), (DX #/\ DY #/\ X #= Y) #<==> B). -attribute_goal_(reified_geq(DX, X, DY, Y, B), (DX #/\ DY #/\ X #>= Y) #<==> B). -attribute_goal_(reified_div(X, Y, D, Z), (D #= 1 #==> X / Y #= Z, Y #\= 0 #==> D #= 1)). -attribute_goal_(reified_mod(X, Y, D, Z), (D #= 1 #==> X mod Y #= Z, Y #\= 0 #==> D #= 1)). -attribute_goal_(por(X,Y,Z), X #\/ Y #<==> Z). -attribute_goal_(reified_and(X, Y, B), X #/\ Y #<==> B). -attribute_goal_(reified_or(X, Y, B), X #\/ Y #<==> B). -attribute_goal_(reified_not(X, Y), #\ X #<==> Y). -attribute_goal_(pimpl(X, Y), X #==> Y). +attribute_goal_(reified_in(V, D, B)) --> + [V in Drep #<==> B], + { domain_to_drep(D, Drep) }. +attribute_goal_(reified_fd(V,B)) --> [finite_domain(V) #<==> B]. +attribute_goal_(reified_neq(DX,X,DY,Y,_,B)) --> conjunction(DX, DY, X#\=Y, B). +attribute_goal_(reified_eq(DX,X,DY,Y,_,B)) --> conjunction(DX, DY, X #= Y, B). +attribute_goal_(reified_geq(DX,X,DY,Y,_,B)) --> conjunction(DX, DY, X #>= Y, B). +attribute_goal_(reified_div(X,Y,D,_,Z)) --> + [D #= 1 #==> X / Y #= Z, Y #\= 0 #==> D #= 1]. +attribute_goal_(reified_mod(X,Y,D,_,Z)) --> + [D #= 1 #==> X mod Y #= Z, Y #\= 0 #==> D #= 1]. +attribute_goal_(reified_and(X,_,Y,_,B)) --> [X #/\ Y #<==> B]. +attribute_goal_(reified_or(X, _, Y, _, B)) --> [X #\/ Y #<==> B]. +attribute_goal_(reified_not(X, Y)) --> [#\ X #<==> Y]. +attribute_goal_(pimpl(X, Y, _)) --> [X #==> Y]. + +conjunction(A, B, G, D) --> + ( { A == 1, B == 1 } -> [G #<==> D] + ; { A == 1 } -> [(B #/\ G) #<==> D] + ; { B == 1 } -> [(A #/\ G) #<==> D] + ; [(A #/\ B #/\ G) #<==> D] + ). coeff_var_term(C, V, T) :- ( C =:= 1 -> T = V ; T = C*V ). -unfold_product([], [], P, P). -unfold_product([C|Cs], [V|Vs], P0, P) :- +fold_product([], [], P, P). +fold_product([C|Cs], [V|Vs], P0, P) :- coeff_var_term(C, V, T), - unfold_product(Cs, Vs, P0 + T, P). + fold_product(Cs, Vs, P0 + T, P). + +original_goal(V) --> + ( { get_attr(V, clpfd_original, Goal) } -> + { del_attr(V, clpfd_original) }, + [Goal] + ; [] + ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -% Testing -% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ - - -% domain_to_list(Domain, List) :- phrase(domain_to_list(Domain), List). - -% domain_to_list(split(_, Left, Right)) --> -% domain_to_list(Left), domain_to_list(Right). -% domain_to_list(empty) --> []. -% domain_to_list(from_to(n(F),n(T))) --> { numlist(F, T, Ns) }, dlist(Ns). - -% dlist([]) --> []. -% dlist([L|Ls]) --> [L], dlist(Ls). % %?- test_intersection([1,2,3,4,5], [1,5], I). @@ -4397,9 +5859,53 @@ unfold_product([C|Cs], [V|Vs], P0, P) :- % list_to_domain(L2, D2), % domain_subdomain(D1, D2). -:- ( current_prolog_flag(bounded, true) -> - format("\n--- WARNING: Using CLP(FD) with bounded arithmetic may yield wrong results.\n"), - format("--- Compile SWI-Prolog with the GMP library for unbounded integer arithmetic.\n\n") - ; true - ). +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Generated predicates +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ +term_expansion(make_parse_clpfd, Clauses) :- make_parse_clpfd(Clauses). +term_expansion(make_parse_reified, Clauses) :- make_parse_reified(Clauses). +term_expansion(make_matches, Clauses) :- make_matches(Clauses). + +make_parse_clpfd. +make_parse_reified. +make_matches. + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Global variables +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +make_clpfd_var('$clpfd_queue') :- + make_queue. +make_clpfd_var('$clpfd_current_propagator') :- + nb_setval('$clpfd_current_propagator', []). +make_clpfd_var('$clpfd_queue_status') :- + nb_setval('$clpfd_queue_status', enabled). + +:- multifile user:exception/3. + +user:exception(undefined_global_variable, Name, retry) :- + make_clpfd_var(Name), !. + +warn_if_bounded_arithmetic :- + make_queue, + enable_queue, + nb_setval('$clpfd_current_propagator', []), + fail. +warn_if_bounded_arithmetic :- + ( current_prolog_flag(bounded, true) -> + print_message(warning, clpfd(bounded)) + ; true + ). + +:- initialization(warn_if_bounded_arithmetic). + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Messages +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +:- multifile prolog:message//1. + +prolog:message(clpfd(bounded)) --> + ['Using CLP(FD) with bounded arithmetic may yield wrong results.'-[]]. diff --git a/library/clp/simplex.pl b/library/clp/simplex.pl new file mode 100644 index 000000000..77b54cc40 --- /dev/null +++ b/library/clp/simplex.pl @@ -0,0 +1,1370 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Markus Triska + E-mail: triska@gmx.at + WWW: http://www.swi-prolog.org + Copyright (C): 2005-2009, Markus Triska + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(simplex, + [ + assignment/2, + constraint/3, + constraint/4, + constraint_add/4, + gen_state/1, + gen_state_clpr/1, + gen_state_clpr/2, + maximize/3, + minimize/3, + objective/2, + shadow_price/3, + transportation/4, + variable_value/3 + ]). + +:- use_module(library(clpr)). +:- use_module(library(assoc)). +:- use_module(library(pio)). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + CLP(R) bindings + the (unsolved) state is stored as a structure of the form + clpr_state(Options, Cs, Is) + Options: list of Option=Value pairs, currently only eps=Eps + Cs: list of constraints, i.e., structures of the form + c(Name, Left, Op, Right) + anonymous constraints have Name == 0 + Is: list of integral variables +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +gen_state_clpr(State) :- gen_state_clpr([], State). + +gen_state_clpr(Options, State) :- + ( memberchk(eps=_, Options) -> Options1 = Options + ; Options1 = [eps=1e-6|Options] + ), + State = clpr_state(Options1, [], []). + +clpr_state_options(clpr_state(Os, _, _), Os). +clpr_state_constraints(clpr_state(_, Cs, _), Cs). +clpr_state_integrals(clpr_state(_, _, Is), Is). +clpr_state_add_integral(I, clpr_state(Os, Cs, Is), clpr_state(Os, Cs, [I|Is])). +clpr_state_add_constraint(C, clpr_state(Os, Cs, Is), clpr_state(Os, [C|Cs], Is)). +clpr_state_set_constraints(Cs, clpr_state(Os,_,Is), clpr_state(Os, Cs, Is)). + +clpr_constraint(Name, Constraint, S0, S) :- + ( Constraint = integral(Var) -> clpr_state_add_integral(Var, S0, S) + ; Constraint =.. [Op,Left,Right], + coeff_one(Left, Left1), + clpr_state_add_constraint(c(Name, Left1, Op, Right), S0, S) + ). + +clpr_constraint(Constraint, S0, S) :- + clpr_constraint(0, Constraint, S0, S). + +clpr_shadow_price(clpr_solved(_,_,Duals,_), Name, Value) :- + memberchk(Name-Value0, Duals), + Value is Value0. + %( var(Value0) -> + % Value = 0 + %; + % Value is Value0 + %). + + + +clpr_make_variables(Cs, Aliases) :- + clpr_constraints_variables(Cs, Variables0, []), + sort(Variables0, Variables1), + clpr_aliases(Variables1, Aliases). + +clpr_constraints_variables([]) --> []. +clpr_constraints_variables([c(_, Left, _, _)|Cs]) --> + variables(Left), + clpr_constraints_variables(Cs). + +clpr_aliases([], []). +clpr_aliases([Var|Vars], [Var-_|Rest]) :- + clpr_aliases(Vars, Rest). + +clpr_set_up([], _). +clpr_set_up([C|Cs], Aliases) :- + C = c(_Name, Left, Op, Right), + clpr_translate_linsum(Left, Aliases, LinSum), + CLPRConstraint =.. [Op, LinSum, Right], + clpr:{ CLPRConstraint }, + clpr_set_up(Cs, Aliases). + +clpr_set_up_noneg([], _). +clpr_set_up_noneg([Var|Vs], Aliases) :- + memberchk(Var-CLPVar, Aliases), + { CLPVar >= 0 }, + clpr_set_up_noneg(Vs, Aliases). + +clpr_translate_linsum([], _, 0). +clpr_translate_linsum([Coeff*Var|Ls], Aliases, LinSum) :- + memberchk(Var-CLPVar, Aliases), + LinSum = Coeff*CLPVar + LinRest, + clpr_translate_linsum(Ls, Aliases, LinRest). + +clpr_dual(Objective0, S0, DualValues) :- + clpr_state_constraints(S0, Cs0), + clpr_constraints_variables(Cs0, Variables0, []), + sort(Variables0, Variables1), + clpr_standard_form(Cs0, Cs1), + clpr_include_all_vars(Cs1, Variables1, Cs2), + clpr_merge_into(Variables1, Objective0, Objective, []), + clpr_unique_names(Cs2, 0, Names), + clpr_constraints_coefficients(Cs2, Coefficients), + transpose(Coefficients, TCs), + clpr_dual_constraints(TCs, Objective, Names, DualConstraints), + clpr_nonneg_constraints(Cs2, Names, DualNonNeg, []), + append(DualConstraints, DualNonNeg, DualConstraints1), + clpr_dual_objective(Cs2, Names, DualObjective), + clpr_make_variables(DualConstraints1, Aliases), + clpr_set_up(DualConstraints1, Aliases), + clpr_translate_linsum(DualObjective, Aliases, LinExpr), + minimize(LinExpr), + Aliases = DualValues. + + + +clpr_dual_objective([], _, []). +clpr_dual_objective([C|Cs], [Name|Names], [Right*Name|Os]) :- + C = c(_, _, _, Right), + clpr_dual_objective(Cs, Names, Os). + +clpr_nonneg_constraints([], _, Nons, Nons). +clpr_nonneg_constraints([C|Cs], [Name|Names], Nons0, Nons) :- + C = c(_, _, Op, _), + ( Op == (=<) -> Nons0 = [c(0, [1*Name], (>=), 0)|Rest] + ; Nons0 = Rest + ), + clpr_nonneg_constraints(Cs, Names, Rest, Nons). + + +clpr_dual_constraints([], [], _, []). +clpr_dual_constraints([Coeffs|Cs], [O*_|Os], Names, [Constraint|Constraints]) :- + clpr_dual_linsum(Coeffs, Names, Linsum), + Constraint = c(0, Linsum, (>=), O), + clpr_dual_constraints(Cs, Os, Names, Constraints). + + +clpr_dual_linsum([], [], []). +clpr_dual_linsum([Coeff|Coeffs], [Name|Names], [Coeff*Name|Rest]) :- + clpr_dual_linsum(Coeffs, Names, Rest). + + +clpr_constraints_coefficients([], []). +clpr_constraints_coefficients([C|Cs], [Coeff|Coeffs]) :- + C = c(_, Left, _, _), + all_coeffs(Left, Coeff), + clpr_constraints_coefficients(Cs, Coeffs). + +all_coeffs([], []). +all_coeffs([Coeff*_|Cs], [Coeff|Rest]) :- + all_coeffs(Cs, Rest). + + +clpr_unique_names([], _, []). +clpr_unique_names([C0|Cs0], Num, [N|Ns]) :- + C0 = c(Name, _, _, _), + ( Name == 0 -> N = Num, Num1 is Num + 1 + ; N = Name, Num1 = Num + ), + clpr_unique_names(Cs0, Num1, Ns). + +clpr_include_all_vars([], _, []). +clpr_include_all_vars([C0|Cs0], Variables, [C|Cs]) :- + C0 = c(Name, Left0, Op, Right), + clpr_merge_into(Variables, Left0, Left, []), + C = c(Name, Left, Op, Right), + clpr_include_all_vars(Cs0, Variables, Cs). + +clpr_merge_into([], _, Ls, Ls). +clpr_merge_into([V|Vs], Left, Ls0, Ls) :- + ( member(Coeff*V, Left) -> + Ls0 = [Coeff*V|Rest] + ; + Ls0 = [0*V|Rest] + ), + clpr_merge_into(Vs, Left, Rest, Ls). + + + + +clpr_maximize(Expr0, S0, S) :- + coeff_one(Expr0, Expr), + clpr_state_constraints(S0, Cs), + clpr_make_variables(Cs, Aliases), + clpr_set_up(Cs, Aliases), + clpr_constraints_variables(Cs, Variables0, []), + sort(Variables0, Variables1), + clpr_set_up_noneg(Variables1, Aliases), + clpr_translate_linsum(Expr, Aliases, LinExpr), + clpr_state_integrals(S0, Is), + ( Is == [] -> + maximize(LinExpr), + Sup is LinExpr, + clpr_dual(Expr, S0, DualValues), + S = clpr_solved(Sup, Aliases, DualValues, S0) + ; + clpr_state_options(S0, Options), + memberchk(eps=Eps, Options), + clpr_fetch_vars(Is, Aliases, Vars), + bb_inf(Vars, -LinExpr, Sup, Vertex, Eps), + clpr_merge_vars(Is, Vertex, Values), + % what about the dual in MIPs? + Sup1 is -Sup, + S = clpr_solved(Sup1, Values, [], S0) + ). + +clpr_minimize(Expr0, S0, S) :- + coeff_one(Expr0, Expr1), + clpr_all_negate(Expr1, Expr2), + clpr_maximize(Expr2, S0, S1), + S1 = clpr_solved(Sup, Values, Duals, S0), + Inf is -Sup, + S = clpr_solved(Inf, Values, Duals, S0). + +clpr_merge_vars([], [], []). +clpr_merge_vars([I|Is], [V|Vs], [I-V|Rest]) :- + clpr_merge_vars(Is, Vs, Rest). + +clpr_fetch_vars([], _, []). +clpr_fetch_vars([Var|Vars], Aliases, [X|Xs]) :- + memberchk(Var-X, Aliases), + clpr_fetch_vars(Vars, Aliases, Xs). + +clpr_variable_value(clpr_solved(_, Aliases, _, _), Variable, Value) :- + memberchk(Variable-Value0, Aliases), + Value is Value0. + %( var(Value0) -> + % Value = 0 + %; + % Value is Value0 + %). + +clpr_objective(clpr_solved(Obj, _, _, _), Obj). + +clpr_standard_form([], []). +clpr_standard_form([c(Name, Left, Op, Right)|Cs], [S|Ss]) :- + clpr_standard_form_(Op, Name, Left, Right, S), + clpr_standard_form(Cs, Ss). + +clpr_standard_form_((=), Name, Left, Right, c(Name, Left, (=), Right)). +clpr_standard_form_((>=), Name, Left, Right, c(Name, Left1, (=<), Right1)) :- + Right1 is -Right, + clpr_all_negate(Left, Left1). +clpr_standard_form_((=<), Name, Left, Right, c(Name, Left, (=<), Right)). + +clpr_all_negate([], []). +clpr_all_negate([Coeff0*Var|As], [Coeff1*Var|Ns]) :- + Coeff1 is -Coeff0, + clpr_all_negate(As, Ns). + + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + General Simplex Algorithm + Structures used: + + tableau(Objective, Variables, Indicators, Constraints) + *) objective function, represented as row + *) list of variables corresponding to columns + *) indicators denoting which variables are still active + *) constraints as rows + + row(Var, Left, Right) + *) the basic variable corresponding to this row + *) coefficients of the left-hand side of the constraint + *) right-hand side of the constraint +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +find_row(Variable, [Row|Rows], R) :- + Row = row(V, _, _), + ( V == Variable -> R = Row + ; find_row(Variable, Rows, R) + ). + + +variable_value(State, Variable, Value) :- + functor(State, F, _), + ( F == solved -> + solved_tableau(State, Tableau), + tableau_rows(Tableau, Rows), + ( find_row(Variable, Rows, Row) -> Row = row(_, _, Value) + ; Value = 0 + ) + ; F == clpr_solved -> clpr_variable_value(State, Variable, Value) + ). + +all_vars_zero([], _). +all_vars_zero([_Coeff*Var|Vars], State) :- + variable_value(State, Var, 0), + all_vars_zero(Vars, State). + +list_first(Ls, F, Index) :- once(nth0(Index, Ls, F)). + +shadow_price(State, Name, Value) :- + functor(State, F, _), + ( F == solved -> + solved_tableau(State, Tableau), + tableau_objective(Tableau, row(_,Left,_)), + tableau_variables(Tableau, Variables), + solved_names(State, Names), + memberchk(user(Name)-Var, Names), + list_first(Variables, Var, Nth0), + nth0(Nth0, Left, Value) + ; F == clpr_solved -> clpr_shadow_price(State, Name, Value) + ). + +objective(State, Obj) :- + functor(State, F, _), + ( F == solved -> + solved_tableau(State, Tableau), + tableau_objective(Tableau, Objective), + Objective = row(_, _, Obj) + ; clpr_objective(State, Obj) + ). + + % interface functions that access tableau components + +tableau_objective(tableau(Obj, _, _, _), Obj). +tableau_rows(tableau(_, _, _, Rows), Rows). +tableau_indicators(tableau(_, _, Inds, _), Inds). +tableau_variables(tableau(_, Vars, _, _), Vars). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + interface functions that access and modify state components + + state is a structure of the form + state(Num, Names, Cs, Is) + Num: used to obtain new unique names for slack variables in a side-effect + free way (increased by one and threaded through) + Names: list of Name-Var, correspondence between constraint-names and + names of slack/artificial variables to obtain shadow prices later + Cs: list of constraints + Is: list of integer variables + + constraints are initially represented as c(Name, Left, Op, Right), + and after normalizing as c(Var, Left, Right). Name of unnamed constraints + is 0. The distinction is important for merging constraints (mainly in + branch and bound) with existing ones. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +constraint_name(c(Name, _, _, _), Name). +constraint_op(c(_, _, Op, _), Op). +constraint_left(c(_, Left, _, _), Left). +constraint_right(c(_, _, _, Right), Right). + +gen_state(state(0,[],[],[])). + +state_add_constraint(C, S0, S) :- + ( constraint_name(C, 0), constraint_left(C, [_Coeff*_Var]) -> + state_merge_constraint(C, S0, S) + ; state_add_constraint_(C, S0, S) + ). + +state_add_constraint_(C, state(VID,Ns,Cs,Is), state(VID,Ns,[C|Cs],Is)). + +state_merge_constraint(C, S0, S) :- + constraint_left(C, [Coeff0*Var0]), + constraint_right(C, Right0), + constraint_op(C, Op), + ( Coeff0 =:= 0 -> + ( Op == (=) -> Right0 =:= 0, S0 = S + ; Op == (=<) -> S0 = S + ; Op == (>=) -> Right0 =:= 0, S0 = S + ) + ; Coeff0 < 0 -> state_add_constraint_(C, S0, S) + ; Right is Right0 rdiv Coeff0, + state_constraints(S0, Cs), + ( select(c(0, [1*Var0], Op, CRight), Cs, RestCs) -> + ( Op == (=) -> CRight =:= Right, S0 = S + ; Op == (=<) -> + NewRight is min(Right, CRight), + NewCs = [c(0, [1*Var0], Op, NewRight)|RestCs], + state_set_constraints(NewCs, S0, S) + ; Op == (>=) -> + NewRight is max(Right, CRight), + NewCs = [c(0, [1*Var0], Op, NewRight)|RestCs], + state_set_constraints(NewCs, S0, S) + ) + ; state_add_constraint_(c(0, [1*Var0], Op, Right), S0, S) + ) + ). + + +state_add_name(Name, Var), [state(VID,[Name-Var|Ns],Cs,Is)] --> + [state(VID,Ns,Cs,Is)]. + +state_add_integral(Var, state(VID,Ns,Cs,Is), state(VID,Ns,Cs,[Var|Is])). + +state_constraints(state(_, _, Cs, _), Cs). +state_names(state(_,Names,_,_), Names). +state_integrals(state(_,_,_,Is), Is). +state_set_constraints(Cs, state(VID,Ns,_,Is), state(VID,Ns,Cs,Is)). +state_set_integrals(Is, state(VID,Ns,Cs,_), state(VID,Ns,Cs,Is)). + + +state_next_var(VarID0), [state(VarID1,Names,Cs,Is)] --> + [state(VarID0,Names,Cs,Is)], + { VarID1 is VarID0 + 1 }. + +solved_tableau(solved(Tableau, _, _), Tableau). +solved_names(solved(_, Names,_), Names). +solved_integrals(solved(_,_,Is), Is). + +% User-named constraints are wrapped with user/1 to also allow "0" in +% constraint names. + +constraint(C, S0, S) :- + functor(S0, F, _), + ( F == state -> + ( C = integral(Var) -> state_add_integral(Var, S0, S) + ; constraint_(0, C, S0, S) + ) + ; F == clpr_state -> clpr_constraint(C, S0, S) + ). + +constraint(Name, C, S0, S) :- constraint_(user(Name), C, S0, S). + +constraint_(Name, C, S0, S) :- + functor(S0, F, _), + ( F == state -> + ( C = integral(Var) -> state_add_integral(Var, S0, S) + ; C =.. [Op, Left0, Right0], + coeff_one(Left0, Left), + Right0 >= 0, + Right is rationalize(Right0), + state_add_constraint(c(Name, Left, Op, Right), S0, S) + ) + ; F == clpr_state -> clpr_constraint(Name, C, S0, S) + ). + +constraint_add(Name, A, S0, S) :- + functor(S0, F, _), + ( F == state -> + state_constraints(S0, Cs), + add_left(Cs, user(Name), A, Cs1), + state_set_constraints(Cs1, S0, S) + ; F == clpr_state -> + clpr_state_constraints(S0, Cs), + add_left(Cs, Name, A, Cs1), + clpr_state_set_constraints(Cs1, S0, S) + ). + + +add_left([c(Name,Left0,Op,Right)|Cs], V, A, [c(Name,Left,Op,Right)|Rest]) :- + ( Name == V -> append(A, Left0, Left), Rest = Cs + ; Left0 = Left, add_left(Cs, V, A, Rest) + ). + +branching_variable(State, Variable) :- + solved_integrals(State, Integrals), + member(Variable, Integrals), + variable_value(State, Variable, Value), + \+ integer(Value). + + +worth_investigating(ZStar0, _, _) :- var(ZStar0). +worth_investigating(ZStar0, AllInt, Z) :- + nonvar(ZStar0), + ( AllInt =:= 1 -> Z1 is floor(Z) + ; Z1 = Z + ), + Z1 > ZStar0. + + +branch_and_bound(Objective, Solved, AllInt, ZStar0, ZStar, S0, S, Found) :- + objective(Solved, Z), + ( worth_investigating(ZStar0, AllInt, Z) -> + ( branching_variable(Solved, BrVar) -> + variable_value(Solved, BrVar, Value), + Value1 is floor(Value), + Value2 is Value1 + 1, + constraint([BrVar] =< Value1, S0, SubProb1), + ( maximize_(Objective, SubProb1, SubSolved1) -> + Sub1Feasible = 1, + objective(SubSolved1, Obj1) + ; Sub1Feasible = 0 + ), + constraint([BrVar] >= Value2, S0, SubProb2), + ( maximize_(Objective, SubProb2, SubSolved2) -> + Sub2Feasible = 1, + objective(SubSolved2, Obj2) + ; Sub2Feasible = 0 + ), + ( Sub1Feasible =:= 1, Sub2Feasible =:= 1 -> + ( Obj1 >= Obj2 -> + First = SubProb1, + Second = SubProb2, + FirstSolved = SubSolved1, + SecondSolved = SubSolved2 + ; First = SubProb2, + Second = SubProb1, + FirstSolved = SubSolved2, + SecondSolved = SubSolved1 + ), + branch_and_bound(Objective, FirstSolved, AllInt, ZStar0, ZStar1, First, Solved1, Found1), + branch_and_bound(Objective, SecondSolved, AllInt, ZStar1, ZStar2, Second, Solved2, Found2) + ; Sub1Feasible =:= 1 -> + branch_and_bound(Objective, SubSolved1, AllInt, ZStar0, ZStar1, SubProb1, Solved1, Found1), + Found2 = 0 + ; Sub2Feasible =:= 1 -> + Found1 = 0, + branch_and_bound(Objective, SubSolved2, AllInt, ZStar0, ZStar2, SubProb2, Solved2, Found2) + ; Found1 = 0, Found2 = 0 + ), + ( Found1 =:= 1, Found2 =:= 1 -> S = Solved2, ZStar = ZStar2 + ; Found1 =:= 1 -> S = Solved1, ZStar = ZStar1 + ; Found2 =:= 1 -> S = Solved2, ZStar = ZStar2 + ; S = S0, ZStar = ZStar0 + ), + Found is max(Found1, Found2) + ; S = Solved, ZStar = Z, Found = 1 + ) + ; ZStar = ZStar0, S = S0, Found = 0 + ). + +maximize(Z0, S0, S) :- + coeff_one(Z0, Z1), + functor(S0, F, _), + ( F == state -> maximize_mip(Z1, S0, S) + ; F == clpr_state -> clpr_maximize(Z1, S0, S) + ). + +maximize_mip(Z, S0, S) :- + maximize_(Z, S0, Solved), + state_integrals(S0, Is), + ( Is == [] -> S = Solved + ; % arrange it so that branch and bound branches on variables + % in the same order the integrality constraints were stated in + reverse(Is, Is1), + state_set_integrals(Is1, S0, S1), + ( all_integers(Z, Is1) -> AllInt = 1 + ; AllInt = 0 + ), + branch_and_bound(Z, Solved, AllInt, _, _, S1, S, 1) + ). + +all_integers([], _). +all_integers([Coeff*V|Rest], Is) :- + integer(Coeff), + memberchk(V, Is), + all_integers(Rest, Is). + + +minimize(Z0, S0, S) :- + coeff_one(Z0, Z1), + functor(S0, F, _), + ( F == state -> + linsum_negate(Z1, Z2), + maximize_mip(Z2, S0, S1), + solved_tableau(S1, tableau(Obj, Vars, Inds, Rows)), + solved_names(S1, Names), + Obj = row(z, Left0, Right0), + all_times(Left0, -1, Left), + Right is -Right0, + Obj1 = row(z, Left, Right), + state_integrals(S0, Is), + S = solved(tableau(Obj1, Vars, Inds, Rows), Names, Is) + ; F == clpr_state -> clpr_minimize(Z1, S0, S) + ). + +op_pendant(>=, =<). +op_pendant(=<, >=). + +constraints_collapse([], []). +constraints_collapse([C|Cs], Colls) :- + C = c(Name, Left, Op, Right), + ( Name == 0, Left = [1*Var], op_pendant(Op, P) -> + Pendant = c(0, [1*Var], P, Right), + ( select(Pendant, Cs, Rest) -> + Colls = [c(0, Left, (=), Right)|CollRest], + CsLeft = Rest + ; Colls = [C|CollRest], + CsLeft = Cs + ) + ; Colls = [C|CollRest], + CsLeft = Cs + ), + constraints_collapse(CsLeft, CollRest). + +% solve a (relaxed) LP in standard form + +maximize_(Z, S0, S) :- + state_constraints(S0, Cs0), + constraints_collapse(Cs0, Cs1), + phrase(constraints_normalize(Cs1, Cs, As0), [S0], [S1]), + flatten(As0, As1), + ( As1 == [] -> + make_tableau(Z, Cs, Tableau0), + simplex(Tableau0, Tableau), + state_names(S1, Names), + state_integrals(S1, Is), + S = solved(Tableau, Names, Is) + ; state_names(S1, Names), + state_integrals(S1, Is), + two_phase_simplex(Z, Cs, As1, Names, Is, S) + ). + +make_tableau(Z, Cs, Tableau) :- + ZC = c(_, Z, _), + phrase(constraints_variables([ZC|Cs]), Variables0), + sort(Variables0, Variables), + constraints_rows(Cs, Variables, Rows), + linsum_row(Variables, Z, Objective1), + all_times(Objective1, -1, Obj), + length(Variables, LVs), + length(Ones, LVs), + all_one(Ones), + Tableau = tableau(row(z, Obj, 0), Variables, Ones, Rows). + +all_one([]). +all_one([1|Os]) :- all_one(Os). + +proper_form([], _, _, Obj, Obj). +proper_form([_Coeff*A|As], Variables, Rows, Obj0, Obj) :- + ( find_row(A, Rows, PivotRow) -> + list_first(Variables, A, Col), + row_eliminate(Obj0, PivotRow, Col, Obj1) + ; Obj1 = Obj0 + ), + proper_form(As, Variables, Rows, Obj1, Obj). + + +two_phase_simplex(Z, Cs, As, Names, Is, S) :- + % phase 1: minimize sum of articifial variables + make_tableau(As, Cs, Tableau0), + Tableau0 = tableau(Obj0, Variables, Inds, Rows), + proper_form(As, Variables, Rows, Obj0, Obj), + simplex(tableau(Obj, Variables, Inds, Rows), Tableau1), + all_vars_zero(As, solved(Tableau1, _, _)), + % phase 2: remove artificial variables and solve actual LP. + tableau_rows(Tableau1, Rows2), + eliminate_artificial(As, As, Variables, Rows2, Rows3), + list_nths(As, Variables, Nths0), + nths_to_zero(Nths0, Inds, Inds1), + linsum_row(Variables, Z, Objective), + all_times(Objective, -1, Objective1), + proper_form(Z, Variables, Rows3, row(z, Objective1, 0), ObjRow), + simplex(tableau(ObjRow, Variables, Inds1, Rows3), Tableau), + S = solved(Tableau, Names, Is). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + If artificial variables are still in the basis, replace them with + non-artificial variables if possible. If that is not possible, the + constraint is ignored because it is redundant. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +eliminate_artificial([], _, _, Rows, Rows). +eliminate_artificial([_Coeff*A|Rest], As, Variables, Rows0, Rows) :- + ( select(row(A, Left, 0), Rows0, Others) -> + ( nth0(Col, Left, Coeff), + Coeff =\= 0, + nth0(Col, Variables, Var), + \+ memberchk(_*Var, As) -> + row_divide(row(A, Left, 0), Coeff, Row), + gauss_elimination(Rows0, Row, Col, Rows1), + swap_basic(Rows1, A, Var, Rows2) + ; Rows2 = Others + ) + ; Rows2 = Rows0 + ), + eliminate_artificial(Rest, As, Variables, Rows2, Rows). + +nths_to_zero([], Inds, Inds). +nths_to_zero([Nth|Nths], Inds0, Inds) :- + nth_to_zero(Inds0, 0, Nth, Inds1), + nths_to_zero(Nths, Inds1, Inds). + +nth_to_zero([], _, _, []). +nth_to_zero([I|Is], Curr, Nth, [Z|Zs]) :- + ( Curr =:= Nth -> [Z|Zs] = [0|Is] + ; Z = I, + Next is Curr + 1, + nth_to_zero(Is, Next, Nth, Zs) + ). + + +list_nths([], _, []). +list_nths([_Coeff*A|As], Variables, [Nth|Nths]) :- + list_first(Variables, A, Nth), + list_nths(As, Variables, Nths). + + +linsum_negate([], []). +linsum_negate([Coeff0*Var|Ls], [Coeff*Var|Ns]) :- + Coeff is Coeff0 * (-1), + linsum_negate(Ls, Ns). + + +linsum_row([], _, []). +linsum_row([V|Vs], Ls, [C|Cs]) :- + ( member(Coeff*V, Ls) -> C is rationalize(Coeff) + ; C = 0 + ), + linsum_row(Vs, Ls, Cs). + +constraints_rows([], _, []). +constraints_rows([C|Cs], Vars, [R|Rs]) :- + C = c(Var, Left0, Right), + linsum_row(Vars, Left0, Left), + R = row(Var, Left, Right), + constraints_rows(Cs, Vars, Rs). + +constraints_normalize([], [], []) --> []. +constraints_normalize([C0|Cs0], [C|Cs], [A|As]) --> + { constraint_op(C0, Op), + constraint_left(C0, Left), + constraint_right(C0, Right), + constraint_name(C0, Name), + Con =.. [Op, Left, Right] }, + constraint_normalize(Con, Name, C, A), + constraints_normalize(Cs0, Cs, As). + +constraint_normalize(As0 =< B0, Name, c(Slack, [1*Slack|As0], B0), []) --> + state_next_var(Slack), + state_add_name(Name, Slack). +constraint_normalize(As0 = B0, Name, c(AID, [1*AID|As0], B0), [-1*AID]) --> + state_next_var(AID), + state_add_name(Name, AID). +constraint_normalize(As0 >= B0, Name, c(AID, [-1*Slack,1*AID|As0], B0), [-1*AID]) --> + state_next_var(Slack), + state_next_var(AID), + state_add_name(Name, AID). + +coeff_one([], []). +coeff_one([L|Ls], [Coeff*Var|Rest]) :- + ( L = A*B -> Coeff = A, Var = B + ; Coeff = 1, Var = L + ), + coeff_one(Ls, Rest). + + +tableau_optimal(Tableau) :- + tableau_objective(Tableau, Objective), + tableau_indicators(Tableau, Indicators), + Objective = row(_, Left, _), + all_nonnegative(Left, Indicators). + +all_nonnegative([], []). +all_nonnegative([Coeff|As], [I|Is]) :- + ( I =:= 0 -> true + ; Coeff >= 0 + ), + all_nonnegative(As, Is). + +pivot_column(Tableau, PCol) :- + tableau_objective(Tableau, row(_, Left, _)), + tableau_indicators(Tableau, Indicators), + first_negative(Left, Indicators, 0, Index0, Val, RestL, RestI), + Index1 is Index0 + 1, + pivot_column(RestL, RestI, Val, Index1, Index0, PCol). + +first_negative([L|Ls], [I|Is], Index0, N, Val, RestL, RestI) :- + Index1 is Index0 + 1, + ( I =:= 0 -> first_negative(Ls, Is, Index1, N, Val, RestL, RestI) + ; ( L < 0 -> N = Index0, Val = L, RestL = Ls, RestI = Is + ; first_negative(Ls, Is, Index1, N, Val, RestL, RestI) + ) + ). + + +pivot_column([], _, _, _, N, N). +pivot_column([L|Ls], [I|Is], Coeff0, Index0, N0, N) :- + ( I =:= 0 -> Coeff1 = Coeff0, N1 = N0 + ; ( L < Coeff0 -> Coeff1 = L, N1 = Index0 + ; Coeff1 = Coeff0, N1 = N0 + ) + ), + Index1 is Index0 + 1, + pivot_column(Ls, Is, Coeff1, Index1, N1, N). + + +pivot_row(Tableau, PCol, PRow) :- + tableau_rows(Tableau, Rows), + pivot_row(Rows, PCol, false, _, 0, 0, PRow). + +pivot_row([], _, Bounded, _, _, Row, Row) :- Bounded. +pivot_row([Row|Rows], PCol, Bounded0, Min0, Index0, PRow0, PRow) :- + Row = row(_Var, Left, B), + nth0(PCol, Left, Ae), + ( Ae > 0 -> + Bounded1 = true, + Bound is B rdiv Ae, + ( Bounded0 -> + ( Bound < Min0 -> Min1 = Bound, PRow1 = Index0 + ; Min1 = Min0, PRow1 = PRow0 + ) + ; Min1 = Bound, PRow1 = Index0 + ) + ; Bounded1 = Bounded0, Min1 = Min0, PRow1 = PRow0 + ), + Index1 is Index0 + 1, + pivot_row(Rows, PCol, Bounded1, Min1, Index1, PRow1, PRow). + + +row_divide(row(Var, Left0, Right0), Div, row(Var, Left, Right)) :- + all_divide(Left0, Div, Left), + Right is Right0 rdiv Div. + + +all_divide([], _, []). +all_divide([R|Rs], Div, [DR|DRs]) :- + DR is R rdiv Div, + all_divide(Rs, Div, DRs). + +gauss_elimination([], _, _, []). +gauss_elimination([Row0|Rows0], PivotRow, Col, [Row|Rows]) :- + PivotRow = row(PVar, _, _), + Row0 = row(Var, _, _), + ( PVar == Var -> Row = PivotRow + ; row_eliminate(Row0, PivotRow, Col, Row) + ), + gauss_elimination(Rows0, PivotRow, Col, Rows). + +row_eliminate(row(Var, Ls0, R0), row(_, PLs, PR), Col, row(Var, Ls, R)) :- + nth0(Col, Ls0, Coeff), + ( Coeff =:= 0 -> Ls = Ls0, R = R0 + ; MCoeff is -Coeff, + all_times_plus([PR|PLs], MCoeff, [R0|Ls0], [R|Ls]) + ). + +all_times_plus([], _, _, []). +all_times_plus([A|As], T, [B|Bs], [AT|ATs]) :- + AT is A * T + B, + all_times_plus(As, T, Bs, ATs). + +all_times([], _, []). +all_times([A|As], T, [AT|ATs]) :- + AT is A * T, + all_times(As, T, ATs). + +simplex(Tableau0, Tableau) :- + ( tableau_optimal(Tableau0) -> Tableau0 = Tableau + ; pivot_column(Tableau0, PCol), + pivot_row(Tableau0, PCol, PRow), + Tableau0 = tableau(Obj0,Variables,Inds,Matrix0), + nth0(PRow, Matrix0, Row0), + Row0 = row(Leaving, Left0, _Right0), + nth0(PCol, Left0, PivotElement), + row_divide(Row0, PivotElement, Row1), + gauss_elimination([Obj0|Matrix0], Row1, PCol, [Obj|Matrix1]), + nth0(PCol, Variables, Entering), + swap_basic(Matrix1, Leaving, Entering, Matrix), + simplex(tableau(Obj,Variables,Inds,Matrix), Tableau) + ). + +swap_basic([Row0|Rows0], Old, New, Matrix) :- + Row0 = row(Var, Left, Right), + ( Var == Old -> Matrix = [row(New, Left, Right)|Rows0] + ; Matrix = [Row0|Rest], + swap_basic(Rows0, Old, New, Rest) + ). + +constraints_variables([]) --> []. +constraints_variables([c(_,Left,_)|Cs]) --> + variables(Left), + constraints_variables(Cs). + +variables([]) --> []. +variables([_Coeff*Var|Rest]) --> [Var], variables(Rest). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + A dual algorithm ("algorithm alpha-beta" in Papadimitriou and + Steiglitz) is used for transportation and assignment problems. The + arising max-flow problem is solved with Edmonds-Karp, itself a dual + algorithm. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + An attributed variable is introduced for each node. Attributes: + node: Original name of the node. + edges: arc_to(To,F,Capacity) (F has an attribute "flow") or + arc_from(From,F,Capacity) + parent: used in breadth-first search +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +arcs([], Assoc, Assoc). +arcs([arc(From0,To0,C)|As], Assoc0, Assoc) :- + ( get_assoc(From0, Assoc0, From) -> Assoc1 = Assoc0 + ; put_assoc(From0, Assoc0, From, Assoc1), + put_attr(From, node, From0) + ), + ( get_attr(From, edges, Es) -> true + ; Es = [] + ), + put_attr(F, flow, 0), + put_attr(From, edges, [arc_to(To,F,C)|Es]), + ( get_assoc(To0, Assoc1, To) -> Assoc2 = Assoc1 + ; put_assoc(To0, Assoc1, To, Assoc2), + put_attr(To, node, To0) + ), + ( get_attr(To, edges, Es1) -> true + ; Es1 = [] + ), + put_attr(To, edges, [arc_from(From,F,C)|Es1]), + arcs(As, Assoc2, Assoc). + + +edmonds_karp(Arcs0, Arcs) :- + empty_assoc(E), + arcs(Arcs0, E, Assoc), + get_assoc(s, Assoc, S), + get_assoc(t, Assoc, T), + maximum_flow(S, T), + % fetch attvars before deleting visited edges + term_attvars(S, AttVars), + phrase(flow_to_arcs(S), Ls), + arcs_assoc(Ls, Arcs), + maplist(del_attrs, AttVars). + +flow_to_arcs(V) --> + ( { get_attr(V, edges, Es) } -> + { del_attr(V, edges), + get_attr(V, node, Name) }, + flow_to_arcs_(Es, Name) + ; [] + ). + +flow_to_arcs_([], _) --> []. +flow_to_arcs_([E|Es], Name) --> + edge_to_arc(E, Name), + flow_to_arcs_(Es, Name). + +edge_to_arc(arc_from(_,_,_), _) --> []. +edge_to_arc(arc_to(To,F,C), Name) --> + { get_attr(To, node, NTo), + get_attr(F, flow, Flow) }, + [arc(Name,NTo,Flow,C)], + flow_to_arcs(To). + +arcs_assoc(Arcs, Hash) :- + empty_assoc(E), + arcs_assoc(Arcs, E, Hash). + +arcs_assoc([], Hs, Hs). +arcs_assoc([arc(From,To,F,C)|Rest], Hs0, Hs) :- + ( get_assoc(From, Hs0, As) -> Hs1 = Hs0 + ; put_assoc(From, Hs0, [], Hs1), + empty_assoc(As) + ), + put_assoc(To, As, arc(From,To,F,C), As1), + put_assoc(From, Hs1, As1, Hs2), + arcs_assoc(Rest, Hs2, Hs). + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + Strategy: Breadth-first search until we find a free right vertex in + the value graph, then find an augmenting path in reverse. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +maximum_flow(S, T) :- + ( augmenting_path([[S]], Levels, T) -> + phrase(augmenting_path(S, T), Path), + Path = [augment(_,First,_)|Rest], + path_minimum(Rest, First, Min), + % format("augmenting path: ~w\n", [Min]), + maplist(augment(Min), Path), + maplist(maplist(clear_parent), Levels), + maximum_flow(S, T) + ; true + ). + +clear_parent(V) :- del_attr(V, parent). + +augmenting_path(Levels0, Levels, T) :- + Levels0 = [Vs|_], + Levels1 = [Tos|Levels0], + phrase(reachables(Vs), Tos), + Tos = [_|_], + ( member(To, Tos), To == T -> Levels = Levels1 + ; augmenting_path(Levels1, Levels, T) + ). + +reachables([]) --> []. +reachables([V|Vs]) --> + { get_attr(V, edges, Es) }, + reachables_(Es, V), + reachables(Vs). + +reachables_([], _) --> []. +reachables_([E|Es], V) --> + reachable(E, V), + reachables_(Es, V). + +reachable(arc_from(V,F,_), P) --> + ( { \+ get_attr(V, parent, _), + get_attr(F, flow, Flow), + Flow > 0 } -> + { put_attr(V, parent, P-augment(F,Flow,-)) }, + [V] + ; [] + ). +reachable(arc_to(V,F,C), P) --> + ( { \+ get_attr(V, parent, _), + get_attr(F, flow, Flow), + ( C == inf ; Flow < C )} -> + { ( C == inf -> Diff = inf + ; Diff is C - Flow + ), + put_attr(V, parent, P-augment(F,Diff,+)) }, + [V] + ; [] + ). + + +path_minimum([], Min, Min). +path_minimum([augment(_,A,_)|As], Min0, Min) :- + ( A == inf -> Min1 = Min0 + ; Min1 is min(Min0,A) + ), + path_minimum(As, Min1, Min). + +augment(Min, augment(F,_,Sign)) :- + get_attr(F, flow, Flow0), + flow_(Sign, Flow0, Min, Flow), + put_attr(F, flow, Flow). + +flow_(+, F0, A, F) :- F is F0 + A. +flow_(-, F0, A, F) :- F is F0 - A. + +augmenting_path(S, V) --> + ( { V == S } -> [] + ; { get_attr(V, parent, V1-Augment) }, + [Augment], + augmenting_path(S, V1) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +naive_init(Supplies, _, Costs, Alphas, Betas) :- + length(Supplies, LAs), + length(Alphas, LAs), + maplist(=(0), Alphas), + transpose(Costs, TCs), + naive_init_betas(TCs, Betas). + +naive_init_betas([], []). +naive_init_betas([Ls|Lss], [B|Bs]) :- + list_min(Ls, B), + naive_init_betas(Lss, Bs). + +list_min([F|Rest], Min) :- + list_min(Rest, F, Min). + +list_min([], Min, Min). +list_min([L|Ls], Min0, Min) :- + Min1 is min(L,Min0), + list_min(Ls, Min1, Min). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +transpose(Ms, Ts) :- Ms = [F|_], transpose(F, Ms, Ts). + +transpose([], _, []). +transpose([_|Rs], Ms, [Ts|Tss]) :- + lists_firsts_rests(Ms, Ts, Ms1), + transpose(Rs, Ms1, Tss). + +lists_firsts_rests([], [], []). +lists_firsts_rests([[F|Os]|Rest], [F|Fs], [Os|Oss]) :- + lists_firsts_rests(Rest, Fs, Oss). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + TODO: use attributed variables throughout +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +transportation(Supplies, Demands, Costs, Transport) :- + length(Supplies, LAs), + length(Demands, LBs), + naive_init(Supplies, Demands, Costs, Alphas, Betas), + network_head(Supplies, 1, SArcs, []), + network_tail(Demands, 1, DArcs, []), + numlist(1, LAs, Sources), + numlist(1, LBs, Sinks0), + maplist(make_sink, Sinks0, Sinks), + append(SArcs, DArcs, Torso), + alpha_beta(Torso, Sources, Sinks, Costs, Alphas, Betas, Flow), + flow_transport(Supplies, 1, Demands, Flow, Transport). + +flow_transport([], _, _, _, []). +flow_transport([_|Rest], N, Demands, Flow, [Line|Lines]) :- + transport_line(Demands, N, 1, Flow, Line), + N1 is N + 1, + flow_transport(Rest, N1, Demands, Flow, Lines). + +transport_line([], _, _, _, []). +transport_line([_|Rest], I, J, Flow, [L|Ls]) :- + ( get_assoc(I, Flow, As), get_assoc(p(J), As, arc(I,p(J),F,_)) -> L = F + ; L = 0 + ), + J1 is J + 1, + transport_line(Rest, I, J1, Flow, Ls). + + +make_sink(N, p(N)). + +network_head([], _) --> []. +network_head([S|Ss], N) --> + [arc(s,N,S)], + { N1 is N + 1 }, + network_head(Ss, N1). + +network_tail([], _) --> []. +network_tail([D|Ds], N) --> + [arc(p(N),t,D)], + { N1 is N + 1 }, + network_tail(Ds, N1). + +network_connections([], _, _, _) --> []. +network_connections([A|As], Betas, [Cs|Css], N) --> + network_connections(Betas, Cs, A, N, 1), + { N1 is N + 1 }, + network_connections(As, Betas, Css, N1). + +network_connections([], _, _, _, _) --> []. +network_connections([B|Bs], [C|Cs], A, N, PN) --> + ( { C =:= A + B } -> [arc(N,p(PN),inf)] + ; [] + ), + { PN1 is PN + 1 }, + network_connections(Bs, Cs, A, N, PN1). + +alpha_beta(Torso, Sources, Sinks, Costs, Alphas, Betas, Flow) :- + network_connections(Alphas, Betas, Costs, 1, Cons, []), + append(Torso, Cons, Arcs), + edmonds_karp(Arcs, MaxFlow), + mark_hashes(MaxFlow, MArcs, MRevArcs), + all_markable(MArcs, MRevArcs, Markable), + mark_unmark(Sources, Markable, MarkSources, UnmarkSources), + ( MarkSources == [] -> Flow = MaxFlow + ; mark_unmark(Sinks, Markable, MarkSinks0, UnmarkSinks0), + maplist(un_p, MarkSinks0, MarkSinks), + maplist(un_p, UnmarkSinks0, UnmarkSinks), + MarkSources = [FirstSource|_], + UnmarkSinks = [FirstSink|_], + theta(FirstSource, FirstSink, Costs, Alphas, Betas, TInit), + theta(MarkSources, UnmarkSinks, Costs, Alphas, Betas, TInit, Theta), + duals_add(MarkSources, Alphas, Theta, Alphas1), + duals_add(UnmarkSinks, Betas, Theta, Betas1), + Theta1 is -Theta, + duals_add(UnmarkSources, Alphas1, Theta1, Alphas2), + duals_add(MarkSinks, Betas1, Theta1, Betas2), + alpha_beta(Torso, Sources, Sinks, Costs, Alphas2, Betas2, Flow) + ). + +mark_hashes(MaxFlow, Arcs, RevArcs) :- + assoc_to_list(MaxFlow, FlowList), + maplist(un_arc, FlowList, FlowList1), + flatten(FlowList1, FlowList2), + empty_assoc(E), + mark_arcs(FlowList2, E, Arcs), + mark_revarcs(FlowList2, E, RevArcs). + +un_arc(_-Ls0, Ls) :- + assoc_to_list(Ls0, Ls1), + maplist(un_arc_, Ls1, Ls). + +un_arc_(_-Ls, Ls). + +mark_arcs([], Arcs, Arcs). +mark_arcs([arc(From,To,F,C)|Rest], Arcs0, Arcs) :- + ( get_assoc(From, Arcs0, As) -> true + ; As = [] + ), + ( C == inf -> As1 = [To|As] + ; F < C -> As1 = [To|As] + ; As1 = As + ), + put_assoc(From, Arcs0, As1, Arcs1), + mark_arcs(Rest, Arcs1, Arcs). + +mark_revarcs([], Arcs, Arcs). +mark_revarcs([arc(From,To,F,_)|Rest], Arcs0, Arcs) :- + ( get_assoc(To, Arcs0, Fs) -> true + ; Fs = [] + ), + ( F > 0 -> Fs1 = [From|Fs] + ; Fs1 = Fs + ), + put_assoc(To, Arcs0, Fs1, Arcs1), + mark_revarcs(Rest, Arcs1, Arcs). + + +un_p(p(N), N). + +duals_add([], Alphas, _, Alphas). +duals_add([S|Ss], Alphas0, Theta, Alphas) :- + add_to_nth(1, S, Alphas0, Theta, Alphas1), + duals_add(Ss, Alphas1, Theta, Alphas). + +add_to_nth(N, N, [A0|As], Theta, [A|As]) :- !, + A is A0 + Theta. +add_to_nth(N0, N, [A|As0], Theta, [A|As]) :- + N1 is N0 + 1, + add_to_nth(N1, N, As0, Theta, As). + + +theta(Source, Sink, Costs, Alphas, Betas, Theta) :- + nth1(Source, Costs, Row), + nth1(Sink, Row, C), + nth1(Source, Alphas, A), + nth1(Sink, Betas, B), + Theta is (C - A - B) rdiv 2. + +theta([], _, _, _, _, Theta, Theta). +theta([Source|Sources], Sinks, Costs, Alphas, Betas, Theta0, Theta) :- + theta_(Sinks, Source, Costs, Alphas, Betas, Theta0, Theta1), + theta(Sources, Sinks, Costs, Alphas, Betas, Theta1, Theta). + +theta_([], _, _, _, _, Theta, Theta). +theta_([Sink|Sinks], Source, Costs, Alphas, Betas, Theta0, Theta) :- + theta(Source, Sink, Costs, Alphas, Betas, Theta1), + Theta2 is min(Theta0, Theta1), + theta_(Sinks, Source, Costs, Alphas, Betas, Theta2, Theta). + + +mark_unmark(Nodes, Hash, Mark, Unmark) :- + mark_unmark(Nodes, Hash, Mark, [], Unmark, []). + +mark_unmark([], _, Mark, Mark, Unmark, Unmark). +mark_unmark([Node|Nodes], Markable, Mark0, Mark, Unmark0, Unmark) :- + ( memberchk(Node, Markable) -> + Mark0 = [Node|Mark1], + Unmark0 = Unmark1 + ; Mark0 = Mark1, + Unmark0 = [Node|Unmark1] + ), + mark_unmark(Nodes, Markable, Mark1, Mark, Unmark1, Unmark). + +all_markable(Flow, RevArcs, Markable) :- + phrase(markable(s, [], _, Flow, RevArcs), Markable). + +all_markable([], Visited, Visited, _, _) --> []. +all_markable([To|Tos], Visited0, Visited, Arcs, RevArcs) --> + ( { memberchk(To, Visited0) } -> { Visited0 = Visited1 } + ; markable(To, [To|Visited0], Visited1, Arcs, RevArcs) + ), + all_markable(Tos, Visited1, Visited, Arcs, RevArcs). + +markable(Current, Visited0, Visited, Arcs, RevArcs) --> + { ( Current = p(_) -> + ( get_assoc(Current, RevArcs, Fs) -> true + ; Fs = [] + ) + ; ( get_assoc(Current, Arcs, Fs) -> true + ; Fs = [] + ) + ) }, + [Current], + all_markable(Fs, [Current|Visited0], Visited, Arcs, RevArcs). + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + solve(File) -- read input from File. + + Format (NS = number of sources, ND = number of demands): + + NS + ND + S1 S2 S3 ... + D1 D2 D3 ... + C11 C12 C13 ... + C21 C22 C23 ... + ... ... ... ... +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input(Ss, Ds, Costs) --> + integer(NS), + integer(ND), + n_integers(NS, Ss), + n_integers(ND, Ds), + n_kvectors(NS, ND, Costs). + +n_kvectors(0, _, []) --> !. +n_kvectors(N, K, [V|Vs]) --> + n_integers(K, V), + { N1 is N - 1 }, + n_kvectors(N1, K, Vs). + +n_integers(0, []) --> !. +n_integers(N, [I|Is]) --> integer(I), { N1 is N - 1 }, n_integers(N1, Is). + + +number([D|Ds]) --> digit(D), number(Ds). +number([D]) --> digit(D). + +digit(D) --> [D], { between(0'0, 0'9, D) }. + +integer(N) --> number(Ds), !, ws, { name(N, Ds) }. + +ws --> [W], { W =< 0' }, !, ws. % closing quote for syntax highlighting: ' +ws --> []. + +solve(File) :- + time((phrase_from_file(input(Supplies, Demands, Costs), File), + transportation(Supplies, Demands, Costs, Matrix), + maplist(print_row, Matrix))), + halt. + +print_row(R) :- maplist(print_row_, R), nl. + +print_row_(N) :- format("~w ", [N]). + + +% ?- call_residue_vars(transportation([12,7,14], [3,15,9,6], [[20,50,10,60],[70,40,60,30],[40,80,70,40]], Ms), Vs). +%@ Ms = [[0, 3, 9, 0], [0, 7, 0, 0], [3, 5, 0, 6]], +%@ Vs = []. + + +%?- call_residue_vars(simplex:solve('instance_80_80.txt'), Vs). + +%?- call_residue_vars(simplex:solve('instance_3_4.txt'), Vs). + +%?- call_residue_vars(simplex:solve('instance_100_100.txt'), Vs). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Assignment problem - for now, reduce to transportation problem + +assignment(Costs, Assignment) :- + length(Costs, LC), + length(Supply, LC), + all_one(Supply), + transportation(Supply, Supply, Costs, Assignment). + diff --git a/library/dialect/swi.yap b/library/dialect/swi.yap index d4769b29a..1d2505c53 100755 --- a/library/dialect/swi.yap +++ b/library/dialect/swi.yap @@ -13,6 +13,8 @@ :- load_foreign_files([plstream], [], initIO). +:- set_prolog_flag(user_flags,silent). + :- ensure_loaded(library(atts)). :- use_module(library(charsio),[write_to_chars/2,read_from_chars/2]). @@ -38,6 +40,7 @@ :- use_module(library(system), [datime/1, mktime/2, + file_property/2, sleep/1]). :- use_module(library(arg), @@ -48,6 +51,7 @@ :- use_module(library(terms), [subsumes/2, + subsumes_chk/2, term_hash/2, unifiable/3, variant/2]). @@ -96,6 +100,7 @@ swi_predicate_table(_,sublist(X,Y),lists,sublist(X,Y)). swi_predicate_table(_,hash_term(X,Y),terms,term_hash(X,Y)). swi_predicate_table(_,term_hash(X,Y),terms,term_hash(X,Y)). swi_predicate_table(_,subsumes(X,Y),terms,subsumes(X,Y)). +swi_predicate_table(_,subsumes_chk(X,Y),terms,subsumes_chk(X,Y)). swi_predicate_table(_,unifiable(X,Y,Z),terms,unifiable(X,Y,Z)). swi_predicate_table(_,cyclic_term(X),terms,cyclic_term(X)). swi_predicate_table(_,acyclic_term(X),terms,acyclic_term(X)). @@ -352,7 +357,33 @@ prolog:'$set_source_module'(Source0, SourceF) :- prolog_load_context(module, Source0), module(SourceF). +prolog:'$set_source_module'(Source0, SourceF) :- + current_module(Source0, SourceF). + prolog:'$declare_module'(Name, Context, _, _, _) :- add_import_module(Name, Context, start). prolog:'$set_predicate_attribute'(_, _, _). + +prolog:time_file(File, Time) :- + file_property(File, mod_time(Date)), + Time is Date*1.0. + +prolog:flag(Key, Old, New) :- + recorded(Key, Old, R), !, + ( + Old \== New + -> + erase(R), + recorda(Key, New, _) + ; + true + ). +prolog:flag(Key, 0, New) :- + functor(Key, N, Ar), + functor(K, N, Ar), + assert(swi:flag(K)), + recorda(K, New, _). + +prolog:current_flag(Key) :- + swi:flag(Key). diff --git a/misc/Yap.spec b/misc/Yap.spec index c95e0ba62..00714f476 100644 --- a/misc/Yap.spec +++ b/misc/Yap.spec @@ -3,10 +3,10 @@ Name: Yap Summary: Prolog Compiler -Version: 6.0.0 +Version: 6.0.1 Packager: Vitor Santos Costa Release: 1 -Source: http://www.ncc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz +Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz License: Perl Artistic License Provides: yap Requires: readline diff --git a/misc/yap.nsi b/misc/yap.nsi index 94cff1789..e57d34b06 100755 --- a/misc/yap.nsi +++ b/misc/yap.nsi @@ -268,4 +268,4 @@ Function .onInstFailed installer, please contact yap-users@sf.net" FunctionEnd -outfile "yap-6.0.0-installer.exe" +outfile "yap-6.0.1-installer.exe" diff --git a/pl/boot.yap b/pl/boot.yap index 9bd74a606..f90e48c83 100755 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -65,17 +65,12 @@ true :- true. '$stream_representation_error'(user_output, 512), '$stream_representation_error'(user_error, 512), '$enter_system_mode', + '$init_globals', set_value(fileerrors,1), - '$init_consult', set_value('$gc',on), ('$exit_undefp' -> true ; true), prompt(' ?- '), - nb_setval('$break',0), - % '$set_read_error_handler'(error), let the user do that - nb_setval('$open_expands_filename',true), '$debug_on'(false), - nb_setval('$trace',off), - b_setval('$spy_glist',[]), % simple trick to find out if this is we are booting from Prolog. get_value('$user_module',V), ( @@ -99,6 +94,17 @@ true :- true. '$init_or_threads', '$run_at_thread_start'. + +'$init_globals' :- + '$init_consult', + nb_setval('$break',0), + % '$set_read_error_handler'(error), let the user do that + nb_setval('$open_expands_filename',true), + nb_setval('$trace',off), + nb_setval('$assert_all',off), + nb_setval('$if_skip_mode',no_skip), + b_setval('$spy_glist',[]). + '$init_consult' :- nb_setval('$lf_verbose',informational), nb_setval('$if_level',0), @@ -475,7 +481,9 @@ true :- true. X == '$', !, ( recorded('$reconsulting',_,R) -> erase(R) ). - /* Executing a query */ +'$prompt_alternatives_on'(groundness). + +/* Executing a query */ '$query'(end_of_file,_). @@ -493,21 +501,31 @@ true :- true. % end of YAPOR - '$query'(G,[]) :- !, + '$query'(G,[]) :- + '$prompt_alternatives_on'(groundness), !, '$yes_no'(G,(?-)). '$query'(G,V) :- ( '$exit_system_mode', + yap_hacks:current_choice_point(CP), '$execute'(G), - ( '$enter_system_mode' ; '$exit_system_mode', fail), - '$output_frozen'(G, V, LGs), - '$write_answer'(V, LGs, Written), - '$write_query_answer_true'(Written), + yap_hacks:current_choice_point(NCP), + ( '$enter_system_mode' ; '$exit_system_mode', fail), + '$output_frozen'(G, V, LGs), + '$write_answer'(V, LGs, Written), + '$write_query_answer_true'(Written), + ( + '$prompt_alternatives_on'(determinism), CP = NCP -> + nl(user_error), + ! + ; '$another', - !, fail + ! + ), + fail ; - '$enter_system_mode', - '$out_neg_answer' + '$enter_system_mode', + '$out_neg_answer' ). '$yes_no'(G,C) :- @@ -921,8 +939,6 @@ not(G) :- \+ '$execute'(G). '$check_callable'(_,_). % Called by the abstract machine, if no clauses exist for a predicate -'$undefp'([M|expand_goal(G,GEx)]) :- !, - G = GEx. '$undefp'([M|G]) :- % make sure we do not loop on undefined predicates % for undefined_predicates. @@ -993,7 +1009,7 @@ break :- nb_setval('$system_mode',SystemMode). '$silent_bootstrap'(F) :- - '$init_consult', + '$init_globals', nb_setval('$if_level',0), nb_getval('$lf_verbose',OldSilent), nb_setval('$lf_verbose',silent), @@ -1113,12 +1129,14 @@ access_file(F,Mode) :- expand_term(Term,Expanded) :- - ( \+ '$undefined'(term_expansion(_,_), user), + ( '$current_module'(Mod), \+ '$undefined'(term_expansion(_,_), Mod), + '$notrace'(Mod:term_expansion(Term,Expanded)) + ; \+ '$undefined'(term_expansion(_,_), user), '$notrace'(user:term_expansion(Term,Expanded)) ; '$expand_term_grammar'(Term,Expanded) ), -!. + !. % diff --git a/pl/checker.yap b/pl/checker.yap index 0279b7713..05a3ee24e 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -217,6 +217,10 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$multifile'((X,Y), M) :- !, '$multifile'(X, M), '$multifile'(Y, M). '$multifile'(Mod:PredSpec, _) :- !, '$multifile'(PredSpec, Mod). +'$multifile'(N//A, M) :- !, + integer(A), + A1 is A+2, + '$multifile'(N/A1, M). '$multifile'(N/A, M) :- '$add_multifile'(N,A,M), fail. @@ -247,6 +251,10 @@ discontiguous(F) :- '$discontiguous'(Y,M). '$discontiguous'(M:A,_) :- !, '$discontiguous'(A,M). +'$discontiguous'(N//A1, M) :- !, + integer(A1), !, + A is A1+2, + '$discontiguous'(N/A, M). '$discontiguous'(N/A, M) :- !, ( recordzifnot('$discontiguous_defs','$df'(N,A,M),_) -> true diff --git a/pl/consult.yap b/pl/consult.yap index be7bc7246..d536a656a 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -425,6 +425,23 @@ use_module(M,F,Is) :- '$skip_unix_comments'(_). +source_file(FileName) :- + recorded('$lf_loaded','$lf_loaded'(FileName,Mod,_,_),_), Mod \= prolog. + +source_file(Mod:Pred, FileName) :- + current_module(Mod), + Mod \= prolog, + '$current_predicate_no_modules'(Mod,_,Pred), + '$owned_by'(Pred, Mod, FileName). + +'$owned_by'(T, Mod, FileName) :- + '$is_multifile'(T, Mod), + functor(T, Name, Arity), + setof(FileName, Ref^recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), Ref), L), + lists:member(FileName, L). +'$owned_by'(T, Mod, FileName) :- + '$owner_file'(T, Mod, FileName). + source_location(FileName, Line) :- prolog_load_context(file, FileName), prolog_load_context(term_position,'$stream_position'(_, Line, _, _, _)). diff --git a/pl/directives.yap b/pl/directives.yap index 3eac18043..c19ebd4a0 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -165,1036 +165,12 @@ user_defined_directive(Dir,Action) :- assert_static(('$exec_directive'(Dir, _, _) :- Action)), '$current_module'(_, M). - -yap_flag(V,Out) :- - '$user_defined_flag'(V,_,_,_), - (nonvar(V) -> - ! - ; - true - ), - '$user_flag_value'(V, Out). - -yap_flag(V,Out) :- - var(V), !, - '$show_yap_flag_opts'(V,Out). - -% do or do not machine code -yap_flag(fast,on) :- set_value('$fast',true). -yap_flag(fast,off) :- !, set_value('$fast',[]). - -% do or do not machine code -yap_flag(argv,L) :- '$argv'(L). - -% do or do not machine code -yap_flag(executable,L) :- '$executable'(L). - -% hide/unhide atoms -yap_flag(hide,Atom) :- !, hide(Atom). -yap_flag(unhide,Atom) :- !, unhide(Atom). - -% hide/unhide atoms -yap_flag(encoding,DefaultEncoding) :- var(DefaultEncoding), !, - '$default_encoding'(DefCode), - '$valid_encoding'(DefaultEncoding, DefCode). -yap_flag(encoding,Encoding) :- - '$valid_encoding'(Encoding, EncCode), !, - '$default_encoding'(EncCode). -yap_flag(encoding,Encoding) :- - '$do_error'(domain_error(io_mode,encoding(Encoding)),yap_flag(encoding,Encoding)). - -% control garbage collection -yap_flag(gc,V) :- - var(V), !, - ( get_value('$gc',[]) -> V = off ; V = on). -yap_flag(gc,on) :- !, set_value('$gc',true). -yap_flag(gc,off) :- !, set_value('$gc',[]). - -yap_flag(gc_margin,N) :- - ( var(N) -> - get_value('$gc_margin',N) - ; - integer(N), N >0 -> - set_value('$gc_margin',N) - ; - '$do_error'(domain_error(flag_value,gc_margin+X),yap_flag(gc_margin,X)) - ). -yap_flag(gc_trace,V) :- - var(V), !, - get_value('$gc_trace',N1), - get_value('$gc_verbose',N2), - get_value('$gc_very_verbose',N3), - '$yap_flag_show_gc_tracing'(N1, N2, N3, V). -yap_flag(gc_trace,on) :- !, - set_value('$gc_trace',true), - set_value('$gc_verbose',[]), - set_value('$gc_very_verbose',[]). -yap_flag(gc_trace,verbose) :- !, - set_value('$gc_trace',[]), - set_value('$gc_verbose',true), - set_value('$gc_very_verbose',[]). -yap_flag(gc_trace,very_verbose) :- !, - set_value('$gc_trace',[]), - set_value('$gc_verbose',true), - set_value('$gc_very_verbose',true). -yap_flag(gc_trace,off) :- - set_value('$gc_trace',[]), - set_value('$gc_verbose',[]), - set_value('$gc_very_verbose',[]). -yap_flag(syntax_errors, V) :- var(V), !, - '$get_read_error_handler'(V). -yap_flag(syntax_errors, Option) :- - '$set_read_error_handler'(Option). -% compatibility flag -yap_flag(enhanced,on) :- !, set_value('$enhanced',true). -yap_flag(enhanced,off) :- set_value('$enhanced',[]). - -% -% SWI compatibility flag -% -yap_flag(generate_debug_info,X) :- - var(X), !, - '$access_yap_flags'(18,Options), - (Options =:= 0 -> X = false ; X = true ). -yap_flag(generate_debug_info,true) :- !, - '$enable_restore_flag_info'(generate_debug_info), - '$set_yap_flags'(18,1), - source. -yap_flag(generate_debug_info,false) :- !, - '$enable_restore_flag_info'(generate_debug_info), - '$set_yap_flags'(18,0), - no_source. -yap_flag(generate_debug_info,X) :- - '$do_error'(domain_error(flag_value,generate_debug_info+X),yap_flag(generate_debug_info,X)). - -'$enable_restore_flag_info'(_) :- - nb_getval('$consulting_file',[]), !. -'$enable_restore_flag_info'(_) :- - nb_getval('$initialization_goals',on), !. -'$enable_restore_flag_info'(Flag) :- - '$show_consult_level'(Level1), - yap_flag(Flag, Info), - % it will be done after we leave the current consult level. - Level is Level1-1, - recorda('$initialisation',do(Level,yap_flag(Flag,Info)),_), +'$thread_initialization'(M:D) :- + eraseall('$thread_initialization'), + recorda('$thread_initialization',M:D,_), fail. -'$enable_restore_flag_info'(_). - -% -% show state of $ -% -yap_flag(dollar_as_lower_case,V) :- - var(V), !, - '$type_of_char'(36,T), - (T = 3 -> V = on ; V = off). -% -% make $a a legit atom -% -yap_flag(dollar_as_lower_case,on) :- !, - '$change_type_of_char'(36,3). -% -% force quoting of '$a' -% -yap_flag(dollar_as_lower_case,off) :- - '$change_type_of_char'(36,7). - -yap_flag(call_counting,X) :- (var(X); X = on; X = off), !, - '$is_call_counted'(X). - -yap_flag(bounded,X) :- - var(X), !, - '$access_yap_flags'(0, X1), - '$transl_to_true_false'(X1,X). -yap_flag(bounded,X) :- !, - (X = true ; X = false), !, - '$do_error'(permission_error(modify,flag,bounded),yap_flag(bounded,X)). -yap_flag(bounded,X) :- - '$do_error'(domain_error(flag_value,bounded+X),yap_flag(bounded,X)). - -% do or do not indexation -yap_flag(index,X) :- var(X), - '$access_yap_flags'(19, X1), - '$transl_to_index_mode'(X1,X), !. -yap_flag(index,X) :- - '$transl_to_index_mode'(X1,X), !, - '$set_yap_flags'(19,X1). -yap_flag(index,X) :- - '$do_error'(domain_error(flag_value,index+X),yap_flag(index,X)). - -yap_flag(home,X) :- - '$yap_home'(X). - -% should match definitions in Yap.h -'$transl_to_index_mode'(0, off). -'$transl_to_index_mode'(1, single). -'$transl_to_index_mode'(2, compact). -'$transl_to_index_mode'(3, multi). -'$transl_to_index_mode'(3, on). % default is multi argument indexing -'$transl_to_index_mode'(4, max). - -% tabling mode -yap_flag(tabling_mode,Options) :- - var(Options), !, - '$access_yap_flags'(20,Options). -yap_flag(tabling_mode,[]) :- !. -yap_flag(tabling_mode,[HOption|TOption]) :- !, - yap_flag(tabling_mode,HOption), - yap_flag(tabling_mode,TOption). -yap_flag(tabling_mode,(Option1,Option2)) :- !, - yap_flag(tabling_mode,Option1), - yap_flag(tabling_mode,Option2). -yap_flag(tabling_mode,Option) :- - '$transl_to_tabling_mode'(Flag,Option), - '$set_yap_flags'(20,Flag). -yap_flag(tabling_mode,Options) :- - '$do_error'(domain_error(flag_value,tabling_mode+Options),yap_flag(tabling_mode,Options)). - -% should match with code in stdpreds.c -'$transl_to_tabling_mode'(0,default). -'$transl_to_tabling_mode'(1,batched). -'$transl_to_tabling_mode'(2,local). -'$transl_to_tabling_mode'(3,exec_answers). -'$transl_to_tabling_mode'(4,load_answers). - -yap_flag(informational_messages,X) :- var(X), !, - get_value('$verbose',X). -yap_flag(informational_messages,on) :- !, - set_value('$verbose',on), - '$set_yap_flags'(22,0). -yap_flag(informational_messages,off) :- !, - set_value('$verbose',off), - '$set_yap_flags'(22,1). -yap_flag(informational_messages,X) :- - '$do_error'(domain_error(flag_value,informational_messages+X),yap_flag(informational_messages,X)). - -yap_flag(verbose,X) :- var(X), !, - get_value('$verbose',X0), - (X0 == on -> X = normal ; X = silent). -yap_flag(verbose,normal) :- !, - set_value('$verbose',on), - '$set_yap_flags'(22,0). -yap_flag(verbose,silent) :- !, - set_value('$verbose',off), - '$set_yap_flags'(22,1). -yap_flag(verbose,X) :- - '$do_error'(domain_error(flag_value,verbose+X),yap_flag(verbose,X)). - -yap_flag(integer_rounding_function,X) :- - var(X), !, - '$access_yap_flags'(2, X1), - '$transl_to_rounding_function'(X1,X). -yap_flag(integer_rounding_function,X) :- - (X = down; X = toward_zero), !, - '$do_error'(permission_error(modify,flag,integer_rounding_function),yap_flag(integer_rounding_function,X)). -yap_flag(integer_rounding_function,X) :- - '$do_error'(domain_error(flag_value,integer_rounding_function+X),yap_flag(integer_rounding_function,X)). - -yap_flag(max_arity,X) :- - var(X), !, - '$access_yap_flags'(1, X1), - '$transl_to_arity'(X1,X). -yap_flag(max_arity,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,max_arity),yap_flag(max_arity,X)). -yap_flag(max_arity,X) :- - '$do_error'(domain_error(flag_value,max_arity+X),yap_flag(max_arity,X)). - -yap_flag(version,X) :- - var(X), !, - get_value('$version_name',X). -yap_flag(version,X) :- - '$do_error'(permission_error(modify,flag,version),yap_flag(version,X)). - -yap_flag(version_data,X) :- - var(X), !, - '$get_version_codes'(Major,Minor,Patch), - X = yap(Major, Minor, Patch, _). -yap_flag(version_data,X) :- - '$do_error'(permission_error(modify,flag,version),yap_flag(version_data,X)). - -'$get_version_codes'(Major,Minor,Patch) :- - get_value('$version_name',X), - atom_codes(X,VersionTag), %' - '$fetch_num_code'(VersionTag,0,Major,L1), - '$fetch_num_code'(L1,0,Minor,L2), - '$fetch_num_code'(L2,0,Patch,[]). - -'$fetch_num_code'([],Code,Code,[]). -'$fetch_num_code'([C|Cs],Code0,CodeF,L) :- - C >= 0'0, C =< 0'9, !, - CodeI is Code0*10+(C-0'0), %' - '$fetch_num_code'(Cs,CodeI,CodeF,L). -'$fetch_num_code'([_|Cs],Code,Code,Cs). - -yap_flag(max_integer,X) :- - var(X), !, - '$access_yap_flags'(0, 1), - '$access_yap_flags'(3, X). -yap_flag(max_integer,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,max_integer),yap_flag(max_integer,X)). -yap_flag(max_integer,X) :- - '$do_error'(domain_error(flag_value,max_integer+X),yap_flag(max_integer,X)). - -yap_flag(max_tagged_integer,X) :- - '$max_tagged_integer'(X), !. -yap_flag(max_tagged_integer,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,max_tagged_integer),yap_flag(max_tagged_integer,X)). -yap_flag(max_tagged_integer,X) :- - '$do_error'(domain_error(flag_value,max_tagged_integer+X),yap_flag(max_tagged_integer,X)). - -yap_flag(min_integer,X) :- - var(X), !, - '$access_yap_flags'(0, 1), - '$access_yap_flags'(4, X). -yap_flag(min_integer,X) :- - integer(X), X < 0, !, - '$do_error'(permission_error(modify,flag,min_integer),yap_flag(min_integer,X)). -yap_flag(min_integer,X) :- - '$do_error'(domain_error(flag_value,min_integer+X),yap_flag(min_integer,X)). - -yap_flag(min_tagged_integer,X) :- - '$min_tagged_integer'( X), !. -yap_flag(min_tagged_integer,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,min_tagged_integer),yap_flag(min_tagged_integer,X)). -yap_flag(min_tagged_integer,X) :- - '$do_error'(domain_error(flag_value,min_tagged_integer+X),yap_flag(min_tagged_integer,X)). - -/* ISO Core Revision DTR: new float flags - -yap_flag(float_mantissa_digits,X) :- - var(X), !, - ????? -yap_flag(float_mantissa_digits,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,float_mantissa_digits),yap_flag(float_mantissa_digits,X)). -yap_flag(float_mantissa_digits,X) :- - '$do_error'(domain_error(flag_value,float_mantissa_digits+X),yap_flag(float_mantissa_digits,X)). - -yap_flag(float_epsilon,X) :- - var(X), !, - ????? -yap_flag(float_epsilon,X) :- - float(X), X > 0, !, - '$do_error'(permission_error(modify,flag,float_epsilon),yap_flag(float_epsilon,X)). -yap_flag(float_epsilon,X) :- - '$do_error'(domain_error(flag_value,float_epsilon+X),yap_flag(float_epsilon,X)). - -yap_flag(float_min_exponent,X) :- - var(X), !, - ????? -yap_flag(float_min_exponent,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,float_min_exponent),yap_flag(float_min_exponent,X)). -yap_flag(float_epsilon,X) :- - '$do_error'(domain_error(flag_value,float_min_exponent+X),yap_flag(float_min_exponent,X)). - -yap_flag(float_max_exponent,X) :- - var(X), !, - ????? -yap_flag(float_max_exponent,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,float_max_exponent),yap_flag(float_max_exponent,X)). -yap_flag(float_max_exponent,X) :- - '$do_error'(domain_error(flag_value,float_max_exponent+X),yap_flag(float_max_exponent,X)). -*/ - -yap_flag(char_conversion,X) :- - var(X), !, - '$access_yap_flags'(5, X1), - '$transl_to_on_off'(X1,X). -yap_flag(char_conversion,X) :- - '$transl_to_on_off'(X1,X), !, - '$set_yap_flags'(5,X1), - ( X1 = 1 -> - '$force_char_conversion' - ; - '$disable_char_conversion' - ). -yap_flag(char_conversion,X) :- - '$do_error'(domain_error(flag_value,char_conversion+X),yap_flag(char_conversion,X)). - -yap_flag(double_quotes,X) :- - var(X), !, - '$access_yap_flags'(6, X1), - '$transl_to_trl_types'(X1,X). -yap_flag(double_quotes,X) :- - '$transl_to_trl_types'(X1,X), !, - '$set_yap_flags'(6,X1). -yap_flag(double_quotes,X) :- - '$do_error'(domain_error(flag_value,double_quotes+X),yap_flag(double_quotes,X)). - -yap_flag(n_of_integer_keys_in_db,X) :- - var(X), !, - '$resize_int_keys'(X). -yap_flag(n_of_integer_keys_in_db,X) :- integer(X), X > 0, !, - '$resize_int_keys'(X). -yap_flag(n_of_integer_keys_in_db,X) :- - '$do_error'(domain_error(flag_value,n_of_integer_keys_in_db+X),yap_flag(n_of_integer_keys_in_db,X)). - -yap_flag(n_of_integer_keys_in_bb,X) :- - var(X), !, - '$resize_bb_int_keys'(X). -yap_flag(n_of_integer_keys_in_bb,X) :- integer(X), X > 0, !, - '$resize_bb_int_keys'(X). -yap_flag(n_of_integer_keys_in_bb,X) :- - '$do_error'(domain_error(flag_value,n_of_integer_keys_in_bb+X),yap_flag(n_of_integer_keys_in_bb,X)). - -yap_flag(profiling,X) :- (var(X); X = on; X = off), !, - '$is_profiled'(X). - -yap_flag(strict_iso,OUT) :- - var(OUT), !, - '$access_yap_flags'(9,X), - '$transl_to_on_off'(X,OUT). -yap_flag(strict_iso,on) :- !, - yap_flag(language,iso), - '$transl_to_on_off'(X,on), - '$set_yap_flags'(9,X). -yap_flag(strict_iso,off) :- !, - '$transl_to_on_off'(X,off), - '$set_yap_flags'(9,X). -yap_flag(strict_iso,X) :- - '$do_error'(domain_error(flag_value,strict_iso+X),yap_flag(strict_iso,X)). - -yap_flag(variable_names_may_end_with_quotes,OUT) :- - var(OUT), !, - '$access_yap_flags'(21,X), - '$transl_to_on_off'(X,OUT). -yap_flag(variable_names_may_end_with_quotes,on) :- !, - '$transl_to_on_off'(X,on), - '$set_yap_flags'(21,X). -yap_flag(variable_names_may_end_with_quotes,off) :- !, - '$transl_to_on_off'(X,off), - '$set_yap_flags'(21,X). -yap_flag(variable_names_may_end_with_quotes,X) :- - '$do_error'(domain_error(flag_value,strict_iso+X),yap_flag(strict_iso,X)). - -yap_flag(language,X) :- - var(X), !, - '$access_yap_flags'(8, X1), - '$trans_to_lang_flag'(X1,X). -yap_flag(language,X) :- - '$trans_to_lang_flag'(N,X), !, - '$set_yap_flags'(8,N), - '$adjust_language'(X). -yap_flag(language,X) :- - '$do_error'(domain_error(flag_value,language+X),yap_flag(language,X)). - -yap_flag(debug,X) :- - var(X), !, - ('$debug_on'(true) - -> - X = on - ; - X = true - ). -yap_flag(debug,X) :- - '$transl_to_on_off'(_,X), !, - (X = on -> debug ; nodebug). -yap_flag(debug,X) :- - '$do_error'(domain_error(flag_value,debug+X),yap_flag(debug,X)). - -yap_flag(discontiguous_warnings,X) :- - var(X), !, - ('$syntax_check_mode'(on,_), '$syntax_check_discontiguous'(on,_) -> - X = on - ; - X = off - ). -yap_flag(discontiguous_warnings,X) :- - '$transl_to_on_off'(_,X), !, - (X = on -> - '$syntax_check_mode'(_,on), - '$syntax_check_discontiguous'(_,on) - ; - '$syntax_check_discontiguous'(_,off)). -yap_flag(discontiguous_warnings,X) :- - '$do_error'(domain_error(flag_value,discontiguous_warnings+X),yap_flag(discontiguous_warnings,X)). - -yap_flag(redefine_warnings,X) :- - var(X), !, - ('$syntax_check_mode'(on,_), '$syntax_check_multiple'(on,_) -> - X = on - ; - X = off - ). -yap_flag(redefine_warnings,X) :- - '$transl_to_on_off'(_,X), !, - (X = on -> - '$syntax_check_mode'(_,on), - '$syntax_check_multiple'(_,on) - ; - '$syntax_check_multiple'(_,off)). -yap_flag(redefine_warnings,X) :- - '$do_error'(domain_error(flag_value,redefine_warnings+X),yap_flag(redefine_warnings,X)). - -yap_flag(chr_toplevel_show_store,X) :- - var(X), !, - nb_getval('$chr_toplevel_show_store',X). -yap_flag(chr_toplevel_show_store,X) :- - (X = true ; X = false), !, - nb_setval('$chr_toplevel_show_store',X). -yap_flag(chr_toplevel_show_store,X) :- - '$do_error'(domain_error(flag_value,chr_toplevel_show_store+X),yap_flag(chr_toplevel_show_store,X)). - -yap_flag(open_expands_filename,Expand) :- - var(Expand), !, - '$default_expand'(Expand). -yap_flag(open_expands_filename,Expand) :- - '$set_default_expand'(Expand). - -yap_flag(single_var_warnings,X) :- - var(X), !, - ('$syntax_check_mode'(on,_), '$syntax_check_single_var'(on,_) -> - X = on - ; - X = off - ). -yap_flag(single_var_warnings,X) :- - '$transl_to_on_off'(_,X), !, - (X = on -> - '$syntax_check_mode'(_,on), - '$syntax_check_single_var'(_,on) - ; - '$syntax_check_single_var'(_,off)). -yap_flag(single_var_warnings,X) :- - '$do_error'(domain_error(flag_value,single_var_warnings+X),yap_flag(single_var_warnings,X)). - -yap_flag(system_options,X) :- - '$system_options'(X). - -'$system_options'(big_numbers) :- - '$has_bignums'. -'$system_options'(coroutining) :- - '$yap_has_coroutining'. -'$system_options'(depth_limit) :- - \+ '$undefined'(get_depth_limit(_), prolog). -'$system_options'(low_level_tracer) :- - \+ '$undefined'(start_low_level_trace, prolog). -'$system_options'(or_parallelism) :- - \+ '$undefined'('$yapor_on', prolog). -'$system_options'(rational_trees) :- - '$yap_has_rational_trees'. -'$system_options'(readline) :- - '$has_readline'. -'$system_options'(tabling) :- - \+ '$undefined'('$c_table'(_,_), prolog). -'$system_options'(threads) :- - \+ '$no_threads'. -'$system_options'(wam_profiler) :- - \+ '$undefined'(reset_op_counters, prolog). - -yap_flag(unknown,X) :- - var(X), !, - unknown(X,_). -yap_flag(unknown,N) :- - unknown(_,N). - -yap_flag(to_chars_mode,X) :- - var(X), !, - ( '$access_yap_flags'(7,0) -> X = quintus ; X = iso ). -yap_flag(to_chars_mode,quintus) :- !, - '$set_yap_flags'(7,0). -yap_flag(to_chars_mode,iso) :- !, - '$set_yap_flags'(7,1). -yap_flag(to_chars_mode,X) :- - '$do_error'(domain_error(flag_value,to_chars_mode+X),yap_flag(to_chars_mode,X)). - -yap_flag(character_escapes,X) :- - var(X), !, - '$access_yap_flags'(12,Y), - '$transl_to_character_escape_modes'(Y,X). -yap_flag(character_escapes,X) :- !, - '$transl_to_character_escape_modes'(Y,X), !, - '$set_yap_flags'(12,Y). -yap_flag(character_escapes,X) :- - '$do_error'(domain_error(flag_value,character_escapes+X),yap_flag(to_chars_mode,X)). - -yap_flag(update_semantics,X) :- - var(X), !, - ( '$log_upd'(I) -> '$convert_upd_sem'(I,X) ). -yap_flag(update_semantics,logical) :- !, - '$switch_log_upd'(1). -yap_flag(update_semantics,logical_assert) :- !, - '$switch_log_upd'(2). -yap_flag(update_semantics,immediate) :- !, - '$switch_log_upd'(0). -yap_flag(update_semantics,X) :- - '$do_error'(domain_error(flag_value,update_semantics+X),yap_flag(update_semantics,X)). - -yap_flag(toplevel_hook,X) :- - var(X), !, - ( recorded('$toplevel_hooks',G,_) -> G ; true ). -yap_flag(toplevel_hook,G) :- !, - '$set_toplevel_hook'(G). - -yap_flag(unix,true) :- - '$unix', !. -yap_flag(unix,false). - -yap_flag(windows,true) :- - '$win32', !. -yap_flag(windows,false). - -yap_flag(shared_object_search_path,P) :- - '$ld_path'(P). - -yap_flag(typein_module,X) :- - var(X), !, - '$current_module'(X). -yap_flag(typein_module,X) :- - module(X). - -yap_flag(write_strings,OUT) :- - var(OUT), !, - '$access_yap_flags'(13,X), - '$transl_to_on_off'(X,OUT). -yap_flag(write_strings,on) :- !, - '$transl_to_on_off'(X,on), - '$set_yap_flags'(13,X). -yap_flag(write_strings,off) :- !, - '$transl_to_on_off'(X,off), - '$set_yap_flags'(13,X). -yap_flag(write_strings,X) :- - '$do_error'(domain_error(flag_value,write_strings+X),yap_flag(write_strings,X)). - -yap_flag(stack_dump_on_error,OUT) :- - var(OUT), !, - '$access_yap_flags'(17,X), - '$transl_to_on_off'(X,OUT). -yap_flag(stack_dump_on_error,on) :- !, -'$transl_to_on_off'(X,on), - '$set_yap_flags'(17,X). -yap_flag(stack_dump_on_error,off) :- !, - '$transl_to_on_off'(X,off), - '$set_yap_flags'(17,X). -yap_flag(stack_dump_on_error,X) :- - '$do_error'(domain_error(flag_value,stack_dump_on_error+X),yap_flag(stack_dump_on_error,X)). - -yap_flag(user_input,OUT) :- - var(OUT), !, - '$flag_check_alias'(OUT, user_input). - -yap_flag(user_input,Stream) :- - '$change_alias_to_stream'(user_input,Stream). - -yap_flag(user_output,OUT) :- - var(OUT), !, - '$flag_check_alias'(OUT, user_output). -yap_flag(user_output,Stream) :- - '$change_alias_to_stream'(user_output,Stream). - - -yap_flag(user_error,OUT) :- - var(OUT), !, - '$flag_check_alias'(OUT, user_error). -yap_flag(user_error,Stream) :- - '$change_alias_to_stream'(user_error,Stream). - -yap_flag(debugger_print_options,OUT) :- - var(OUT), - recorded('$print_options','$debugger'(OUT),_), !. -yap_flag(debugger_print_options,Opts) :- !, - '$check_io_opts'(Opts, yap_flag(debugger_print_options,Opts)), - recorda('$print_options','$debugger'(Opts),_). - -:- recorda('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(10)]),_). - -yap_flag(toplevel_print_options,OUT) :- - var(OUT), - recorded('$print_options','$toplevel'(OUT),_), !. -yap_flag(toplevel_print_options,Opts) :- !, - '$check_io_opts'(Opts, yap_flag(toplevel_print_options,Opts)), - recorda('$print_options','$toplevel'(Opts),_). - -yap_flag(fileerrors,OUT) :- - var(OUT), !, - get_value(fileerrors,X0), - (X0 = [] -> X= 0 ; X = X0), - '$transl_to_on_off'(X,OUT). -yap_flag(fileerrors,on) :- !, - set_value(fileerrors,1). -yap_flag(fileerrors,off) :- !, - set_value(fileerrors,0). -yap_flag(fileerrors,X) :- - '$do_error'(domain_error(flag_value,fileerrors+X),yap_flag(fileerrors,X)). - -:- recorda('$print_options','$toplevel'([quoted(true),numbervars(true),portrayed(true)]),_). - -yap_flag(host_type,X) :- - '$host_type'(X). - -yap_flag(verbose_load,X) :- - var(X), !, - ( get_value('$lf_verbose',silent) -> X = false ; X = true ). -yap_flag(verbose_load,true) :- !, - set_value('$lf_verbose',informational). -yap_flag(verbose_load,false) :- !, - set_value('$lf_verbose',silent), - '$set_yap_flags'(7,1). -yap_flag(verbose_load,X) :- - '$do_error'(domain_error(flag_value,verbose_auto_load+X),yap_flag(verbose_auto_load,X)). - -yap_flag(verbose_auto_load,X) :- - var(X), !, - ( get_value('$verbose_auto_load',true) -> X = true ; X = false ). -yap_flag(verbose_auto_load,true) :- !, - set_value('$verbose_auto_load',true). -yap_flag(verbose_auto_load,false) :- !, - set_value('$verbose_auto_load',false), - '$set_yap_flags'(7,1). -yap_flag(verbose_auto_load,X) :- - '$do_error'(domain_error(flag_value,verbose_auto_load+X),yap_flag(verbose_auto_load,X)). - -yap_flag(float_format,X) :- - var(X), !, - '$float_format'(X). -yap_flag(float_format,X) :- - atom(X), !, - '$float_format'(X). -yap_flag(float_format,X) :- - '$do_error'(type_error(atom,X),yap_flag(float_format,X)). - -yap_flag(max_workers,X) :- - var(X), !, - '$max_workers'(X). -yap_flag(max_workers,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,max_workers),yap_flag(max_workers,X)). -yap_flag(max_workers,X) :- - '$do_error'(domain_error(flag_value,max_workers+X),yap_flag(max_workers,X)). - -yap_flag(max_threads,X) :- - var(X), !, - '$max_threads'(X). -yap_flag(max_threads,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,max_threads),yap_flag(max_threads,X)). -yap_flag(max_threads,X) :- - '$do_error'(domain_error(flag_value,max_threads+X),yap_flag(max_threads,X)). - -yap_flag(address_bits,X) :- - var(X), !, - '$address_bits'(X). -yap_flag(address_bits,X) :- - integer(X), X > 0, !, - '$do_error'(permission_error(modify,flag,address_bits),yap_flag(address_bits,X)). -yap_flag(address_bits,X) :- - '$do_error'(domain_error(flag_value,address_bits+X),yap_flag(address_bits,X)). - -yap_flag(dialect,yap). - -'$show_yap_flag_opts'(V,Out) :- - ( - V = address_bits ; - V = answer_format ; - V = argv ; - V = bounded ; - V = char_conversion ; - V = character_escapes ; - V = chr_toplevel_show_store ; - V = debug ; - V = debugger_print_options ; - V = dialect ; - V = discontiguous_warnings ; - V = dollar_as_lower_case ; - V = double_quotes ; - V = encoding ; - V = executable ; -% V = fast ; - V = fileerrors ; - V = float_format ; -% V = float_mantissa_digits ; -% V = float_epsilon ; -% V = float_min_exponent ; -% V = float_max_exponent ; - V = gc ; - V = gc_margin ; - V = gc_trace ; - V = generate_debug_info ; -% V = hide ; - V = home ; - V = host_type ; - V = index ; - V = tabling_mode ; - V = informational_messages ; - V = integer_rounding_function ; - V = language ; - V = max_arity ; - V = max_integer ; - V = max_tagged_integer ; - V = max_workers ; - V = max_threads ; - V = min_integer ; - V = min_tagged_integer ; - V = n_of_integer_keys_in_db ; - V = open_expands_filename ; - V = profiling ; - V = redefine_warnings ; - V = shared_object_search_path ; - V = single_var_warnings ; - V = stack_dump_on_error ; - V = strict_iso ; - V = syntax_errors ; - V = system_options ; - V = to_chars_mode ; - V = toplevel_hook ; - V = toplevel_print_options ; - V = typein_module ; - V = unix ; - V = unknown ; - V = update_semantics ; - V = user_error ; - V = user_input ; - V = user_output ; - V = variable_names_may_end_with_quotes ; - V = verbose ; - V = verbose_auto_load ; - V = version ; - V = version_data ; - V = windows ; - V = write_strings - ), - yap_flag(V, Out). - -'$trans_to_lang_flag'(0,cprolog). -'$trans_to_lang_flag'(1,iso). -'$trans_to_lang_flag'(2,sicstus). - -'$adjust_language'(cprolog) :- -% '$switch_log_upd'(0), - '$syntax_check_mode'(_,off), - '$syntax_check_single_var'(_,off), - '$syntax_check_discontiguous'(_,off), - '$syntax_check_multiple'(_,off), - '$set_yap_flags'(12,0), % disable character escapes. - '$set_yap_flags'(14,1), - '$set_fpu_exceptions', - unknown(_,fail). -'$adjust_language'(sicstus) :- - '$switch_log_upd'(1), - leash(full), - '$syntax_check_mode'(_,on), - '$syntax_check_single_var'(_,on), - '$syntax_check_discontiguous'(_,on), - '$syntax_check_multiple'(_,on), - '$transl_to_on_off'(X1,on), - '$set_yap_flags'(5,X1), - '$force_char_conversion', - '$set_yap_flags'(14,0), - % CHARACTER_ESCAPE - '$set_yap_flags'(12,1), - '$set_fpu_exceptions', - fileerrors, - unknown(_,error). -'$adjust_language'(iso) :- - '$switch_log_upd'(1), - '$syntax_check_mode'(_,on), - '$syntax_check_single_var'(_,on), - '$syntax_check_discontiguous'(_,on), - '$syntax_check_multiple'(_,on), - % YAP_TO_CHARS - '$set_yap_flags'(7,1), - fileerrors, - '$transl_to_on_off'(X1,on), - % CHAR_CONVERSION - '$set_yap_flags'(5,X1), - '$force_char_conversion', - % ALLOW_ASSERTING_STATIC - '$set_yap_flags'(14,0), - % CHARACTER_ESCAPE - '$set_yap_flags'(12,1), - '$set_fpu_exceptions', - unknown(_,error). - -'$transl_to_character_escape_modes'(0,off) :- !. -'$transl_to_character_escape_modes'(0,cprolog). -'$transl_to_character_escape_modes'(2,on) :- !. -'$transl_to_character_escape_modes'(1,iso). -'$transl_to_character_escape_modes'(2,sicstus). - -'$convert_upd_sem'(0,immediate). -'$convert_upd_sem'(1,logical). -'$convert_upd_sem'(2,logical_assert). - -'$transl_to_true_false'(0,false). -'$transl_to_true_false'(1,true). - -'$transl_to_on_off'(0,off). -'$transl_to_on_off'(1,on). - -'$transl_to_arity'(X1,X) :- X1 < 0, !, X = unbounded. -'$transl_to_arity'(X,X). - -'$transl_to_rounding_function'(0,down). -'$transl_to_rounding_function'(1,toward_zero). - -'$transl_to_trl_types'(0,chars). -'$transl_to_trl_types'(1,codes). -'$transl_to_trl_types'(2,atom). - -'$yap_flag_show_gc_tracing'(true, _, _, on) :- !. -'$yap_flag_show_gc_tracing'(_, true, _, verbose) :- !. -'$yap_flag_show_gc_tracing'(_, _, on, very_verbose) :- !. -'$yap_flag_show_gc_tracing'(_, _, _, off). - -'$flag_check_alias'(OUT, Alias) :- - stream_property(OUT,[alias(Alias)]), !. - -current_prolog_flag(V,Out) :- - var(V), !, - '$show_yap_flag_opts'(V,NOut), - NOut = Out. -current_prolog_flag(V,Out) :- - atom(V), !, - yap_flag(V,NOut), - NOut = Out. -current_prolog_flag(V,Out) :- - '$do_error'(type_error(atom,V),current_prolog_flag(V,Out)). - -set_prolog_flag(F,V) :- - var(F), !, - '$do_error'(instantiation_error,set_prolog_flag(F,V)). -set_prolog_flag(F,V) :- - var(V), !, - '$do_error'(instantiation_error,set_prolog_flag(F,V)). -set_prolog_flag(F, Val) :- - prolog:'$user_defined_flag'(F,_,_,_), !, - yap_flag(F, Val). -set_prolog_flag(F,V) :- - \+ atom(F), !, - '$do_error'(type_error(atom,F),set_prolog_flag(F,V)). -set_prolog_flag(F,V) :- - yap_flag(F,V). - -prolog_flag(F, Old, New) :- - var(F), !, - '$do_error'(instantiation_error,prolog_flag(F,Old,New)). -prolog_flag(F, Old, New) :- - current_prolog_flag(F, Old), - set_prolog_flag(F, New). - -prolog_flag(F, Old) :- - current_prolog_flag(F, Old). - -% if source_mode is on, then the source for the predicates -% is stored with the code -source_mode(Old,New) :- - '$access_yap_flags'(11,X), - '$transl_to_on_off'(X,Old), - '$transl_to_on_off'(XN,New), - '$set_yap_flags'(11,XN). - -source :- '$set_yap_flags'(11,1). -no_source :- '$set_yap_flags'(11,0). - -create_prolog_flag(Name, Value, Options) :- - '$check_flag_name'(Name, create_prolog_flag(Name, Value, Options)), - '$check_flag_options'(Options, Domain, RW, create_prolog_flag(Name, Value, Options)), - '$check_flag_value'(Value, Domain, create_prolog_flag(Name, Value, Options)), - retractall(prolog:'$user_defined_flag'(Name,_,_,_)), - assert(prolog:'$user_defined_flag'(Name,Domain,RW,Value)). - -'$check_flag_name'(V, G) :- - var(V), - '$do_error'(instantiation_error,G). -'$check_flag_name'(Name, _) :- - atom(Name), !. -'$check_flag_name'(Name, G) :- - '$do_error'(type_error(atom),G). - -'$check_flag_options'(O, _, _, G) :- - var(O), - '$do_error'(instantiation_error,G). -'$check_flag_options'([], _, read_write, _) :- !. -'$check_flag_options'([O1|Os], Domain, RW, G) :- !, - '$check_flag_optionsl'([O1|Os], Domain, RW, G). -'$check_flag_options'(O, _, _, G) :- - '$do_error'(type_error(list),G). - - -'$check_flag_optionsl'([], _, read_write, G). -'$check_flag_optionsl'([V|Os], Domain, RW, G) :- - var(V), - '$do_error'(instantiation_error,G). -'$check_flag_optionsl'([type(Type)|Os], Domain, RW, G) :- !, - '$check_flag_type'(Type, Domain, G), - '$check_flag_optionsl'(Os, _, RW, G). -'$check_flag_optionsl'([access(Access)|Os], Domain, RW, G) :- !, - '$check_flag_access'(Access, RW, G), - '$check_flag_optionsl'(Os, Domain, _, G). -'$check_flag_optionsl'(Os, Domain, RW, G) :- - '$do_error'(domain_error(create_prolog_flag,Os),G). - -'$check_flag_type'(V, _, G) :- - var(V), - '$do_error'(instantiation_error,G). -'$check_flag_type'(boolean, boolean, _) :- !. -'$check_flag_type'(integer, integer, _) :- !. -'$check_flag_type'(float, float, _) :- !. -'$check_flag_type'(atom, atom, _) :- !. -'$check_flag_type'(term, term, _) :- !. -'$check_flag_type'(Atom, _, G) :- - '$do_error'(domain_error(create_prolog_flag_option(type),Atom),G). - -'$check_flag_access'(V, _, G) :- - var(V), - '$do_error'(instantiation_error,G). -'$check_flag_access'(read_write, read_write, _) :- !. -'$check_flag_access'(read_only, read_only, _) :- !. -'$check_flag_type'(Atom, _, G) :- - '$do_error'(domain_error(create_prolog_flag_option(access),Atom),G). - -'$user_flag_value'(F, Val) :- - var(Val), !, - '$user_defined_flag'(F,_,_,Val). -'$user_flag_value'(F, Val) :- - atomic(Val), !, - prolog:'$user_defined_flag'(F,Domain,RW,V0), - ( - Val == V0 - -> - true - ; - RW = read_only - -> - '$do_error'(permission_error(modify,flag,F),yap_flag(F,Val)) - ; - '$check_flag_value'(Val, Domain, yap_flag(F,Val)), - retractall(prolog:'$user_defined_flag'(F,_,_,_)), - assert(prolog:'$user_defined_flag'(F,Domain,RW,Val)) - ). -'$user_flag_value'(F, Val) :- - '$do_error'(type_error(atomic,Val),yap_flag(F,Val)). - -'$check_flag_value'(Value, _, G) :- - \+ ground(Value), !, - '$do_error'(instantiation_error,G). -'$check_flag_value'(Value, Domain, G) :- - var(Domain), !, - '$flag_domain_from_value'(Value, Domain). -'$check_flag_value'(_, term, _) :- !. -'$check_flag_value'(Value, atom, _) :- - atom(Value), !. -'$check_flag_value'(Value, integer, _) :- - integer(Value), !. -'$check_flag_value'(Value, float, _) :- - float(Value), !. -'$check_flag_value'(true, boolean, _) :- !. -'$check_flag_value'(false, boolean, _) :- !. -'$check_flag_value'(Value, Domain, G) :- - '$do_error'(domain_error(Domain,Value),G). - -'$flag_domain_from_value'(true, boolean) :- !. -'$flag_domain_from_value'(false, boolean) :- !. -'$flag_domain_from_value'(Value, integer) :- integer(Value), !. -'$flag_domain_from_value'(Value, float) :- float(Value), !. -'$flag_domain_from_value'(Value, atom) :- atom(Value), !. -'$flag_domain_from_value'(_, term). - +'$thread_initialization'(M:D) :- + '$initialization'(M:D). '$expects_dialect'(swi) :- eraseall('$dialect'), @@ -1204,11 +180,4 @@ create_prolog_flag(Name, Value, Options) :- eraseall('$dialect'), recorda('$dialect',yap,_). -'$thread_initialization'(M:D) :- - eraseall('$thread_initialization'), - recorda('$thread_initialization',M:D,_), - fail. -'$thread_initialization'(M:D) :- - '$initialization'(M:D). - diff --git a/pl/flags.yap b/pl/flags.yap new file mode 100644 index 000000000..0691379fb --- /dev/null +++ b/pl/flags.yap @@ -0,0 +1,1098 @@ +/************************************************************************* +* * +* YAP Prolog * +* * +* Yap Prolog was developed at NCCUP - Universidade do Porto * +* * +* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * +* * +************************************************************************** +* * +* File: flags.yap * +* Last rev: * +* mods: * +* comments: controlling YAP * +* * +*************************************************************************/ + + +yap_flag(V,Out) :- + '$user_defined_flag'(V,_,_,_), + (nonvar(V) -> + ! + ; + true + ), + '$user_flag_value'(V, Out). + +yap_flag(V,Out) :- + var(V), !, + '$show_yap_flag_opts'(V,Out). + +% do or do not machine code +yap_flag(fast,on) :- set_value('$fast',true). +yap_flag(fast,off) :- !, set_value('$fast',[]). + +% do or do not machine code +yap_flag(argv,L) :- '$argv'(L). + +% do or do not machine code +yap_flag(executable,L) :- '$executable'(L). + +% hide/unhide atoms +yap_flag(hide,Atom) :- !, hide(Atom). +yap_flag(unhide,Atom) :- !, unhide(Atom). + +% hide/unhide atoms +yap_flag(encoding,DefaultEncoding) :- var(DefaultEncoding), !, + '$default_encoding'(DefCode), + '$valid_encoding'(DefaultEncoding, DefCode). +yap_flag(encoding,Encoding) :- + '$valid_encoding'(Encoding, EncCode), !, + '$default_encoding'(EncCode). +yap_flag(encoding,Encoding) :- + '$do_error'(domain_error(io_mode,encoding(Encoding)),yap_flag(encoding,Encoding)). + +% control garbage collection +yap_flag(gc,V) :- + var(V), !, + ( get_value('$gc',[]) -> V = off ; V = on). +yap_flag(gc,on) :- !, set_value('$gc',true). +yap_flag(gc,off) :- !, set_value('$gc',[]). + +yap_flag(gc_margin,N) :- + ( var(N) -> + get_value('$gc_margin',N) + ; + integer(N), N >0 -> + set_value('$gc_margin',N) + ; + '$do_error'(domain_error(flag_value,gc_margin+X),yap_flag(gc_margin,X)) + ). +yap_flag(gc_trace,V) :- + var(V), !, + get_value('$gc_trace',N1), + get_value('$gc_verbose',N2), + get_value('$gc_very_verbose',N3), + '$yap_flag_show_gc_tracing'(N1, N2, N3, V). +yap_flag(gc_trace,on) :- !, + set_value('$gc_trace',true), + set_value('$gc_verbose',[]), + set_value('$gc_very_verbose',[]). +yap_flag(gc_trace,verbose) :- !, + set_value('$gc_trace',[]), + set_value('$gc_verbose',true), + set_value('$gc_very_verbose',[]). +yap_flag(gc_trace,very_verbose) :- !, + set_value('$gc_trace',[]), + set_value('$gc_verbose',true), + set_value('$gc_very_verbose',true). +yap_flag(gc_trace,off) :- + set_value('$gc_trace',[]), + set_value('$gc_verbose',[]), + set_value('$gc_very_verbose',[]). +yap_flag(syntax_errors, V) :- var(V), !, + '$get_read_error_handler'(V). +yap_flag(syntax_errors, Option) :- + '$set_read_error_handler'(Option). +% compatibility flag +yap_flag(enhanced,on) :- !, set_value('$enhanced',true). +yap_flag(enhanced,off) :- set_value('$enhanced',[]). + +% +% SWI compatibility flag +% +yap_flag(generate_debug_info,X) :- + var(X), !, + '$access_yap_flags'(18,Options), + (Options =:= 0 -> X = false ; X = true ). +yap_flag(generate_debug_info,true) :- !, + '$enable_restore_flag_info'(generate_debug_info), + '$set_yap_flags'(18,1), + source. +yap_flag(generate_debug_info,false) :- !, + '$enable_restore_flag_info'(generate_debug_info), + '$set_yap_flags'(18,0), + no_source. +yap_flag(generate_debug_info,X) :- + '$do_error'(domain_error(flag_value,generate_debug_info+X),yap_flag(generate_debug_info,X)). + +'$enable_restore_flag_info'(_) :- + nb_getval('$consulting_file',[]), !. +'$enable_restore_flag_info'(_) :- + nb_getval('$initialization_goals',on), !. +'$enable_restore_flag_info'(Flag) :- + '$show_consult_level'(Level1), + yap_flag(Flag, Info), + % it will be done after we leave the current consult level. + Level is Level1-1, + recorda('$initialisation',do(Level,yap_flag(Flag,Info)),_), + fail. +'$enable_restore_flag_info'(_). + +% +% show state of $ +% +yap_flag(dollar_as_lower_case,V) :- + var(V), !, + '$type_of_char'(36,T), + (T = 3 -> V = on ; V = off). +% +% make $a a legit atom +% +yap_flag(dollar_as_lower_case,on) :- !, + '$change_type_of_char'(36,3). +% +% force quoting of '$a' +% +yap_flag(dollar_as_lower_case,off) :- + '$change_type_of_char'(36,7). + +yap_flag(call_counting,X) :- (var(X); X = on; X = off), !, + '$is_call_counted'(X). + +yap_flag(bounded,X) :- + var(X), !, + '$access_yap_flags'(0, X1), + '$transl_to_true_false'(X1,X). +yap_flag(bounded,X) :- !, + (X = true ; X = false), !, + '$do_error'(permission_error(modify,flag,bounded),yap_flag(bounded,X)). +yap_flag(bounded,X) :- + '$do_error'(domain_error(flag_value,bounded+X),yap_flag(bounded,X)). + +% do or do not indexation +yap_flag(index,X) :- var(X), + '$access_yap_flags'(19, X1), + '$transl_to_index_mode'(X1,X), !. +yap_flag(index,X) :- + '$transl_to_index_mode'(X1,X), !, + '$set_yap_flags'(19,X1). +yap_flag(index,X) :- + '$do_error'(domain_error(flag_value,index+X),yap_flag(index,X)). + +yap_flag(home,X) :- + '$yap_home'(X). + +% should match definitions in Yap.h +'$transl_to_index_mode'(0, off). +'$transl_to_index_mode'(1, single). +'$transl_to_index_mode'(2, compact). +'$transl_to_index_mode'(3, multi). +'$transl_to_index_mode'(3, on). % default is multi argument indexing +'$transl_to_index_mode'(4, max). + +% tabling mode +yap_flag(tabling_mode,Options) :- + var(Options), !, + '$access_yap_flags'(20,Options). +yap_flag(tabling_mode,[]) :- !. +yap_flag(tabling_mode,[HOption|TOption]) :- !, + yap_flag(tabling_mode,HOption), + yap_flag(tabling_mode,TOption). +yap_flag(tabling_mode,(Option1,Option2)) :- !, + yap_flag(tabling_mode,Option1), + yap_flag(tabling_mode,Option2). +yap_flag(tabling_mode,Option) :- + '$transl_to_tabling_mode'(Flag,Option), + '$set_yap_flags'(20,Flag). +yap_flag(tabling_mode,Options) :- + '$do_error'(domain_error(flag_value,tabling_mode+Options),yap_flag(tabling_mode,Options)). + +% should match with code in stdpreds.c +'$transl_to_tabling_mode'(0,default). +'$transl_to_tabling_mode'(1,batched). +'$transl_to_tabling_mode'(2,local). +'$transl_to_tabling_mode'(3,exec_answers). +'$transl_to_tabling_mode'(4,load_answers). + +yap_flag(informational_messages,X) :- var(X), !, + get_value('$verbose',X). +yap_flag(informational_messages,on) :- !, + set_value('$verbose',on), + '$set_yap_flags'(22,0). +yap_flag(informational_messages,off) :- !, + set_value('$verbose',off), + '$set_yap_flags'(22,1). +yap_flag(informational_messages,X) :- + '$do_error'(domain_error(flag_value,informational_messages+X),yap_flag(informational_messages,X)). + +yap_flag(verbose,X) :- var(X), !, + get_value('$verbose',X0), + (X0 == on -> X = normal ; X = silent). +yap_flag(verbose,normal) :- !, + set_value('$verbose',on), + '$set_yap_flags'(22,0). +yap_flag(verbose,silent) :- !, + set_value('$verbose',off), + '$set_yap_flags'(22,1). +yap_flag(verbose,X) :- + '$do_error'(domain_error(flag_value,verbose+X),yap_flag(verbose,X)). + +yap_flag(integer_rounding_function,X) :- + var(X), !, + '$access_yap_flags'(2, X1), + '$transl_to_rounding_function'(X1,X). +yap_flag(integer_rounding_function,X) :- + (X = down; X = toward_zero), !, + '$do_error'(permission_error(modify,flag,integer_rounding_function),yap_flag(integer_rounding_function,X)). +yap_flag(integer_rounding_function,X) :- + '$do_error'(domain_error(flag_value,integer_rounding_function+X),yap_flag(integer_rounding_function,X)). + +yap_flag(max_arity,X) :- + var(X), !, + '$access_yap_flags'(1, X1), + '$transl_to_arity'(X1,X). +yap_flag(max_arity,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,max_arity),yap_flag(max_arity,X)). +yap_flag(max_arity,X) :- + '$do_error'(domain_error(flag_value,max_arity+X),yap_flag(max_arity,X)). + +yap_flag(version,X) :- + var(X), !, + get_value('$version_name',X). +yap_flag(version,X) :- + '$do_error'(permission_error(modify,flag,version),yap_flag(version,X)). + +yap_flag(version_data,X) :- + var(X), !, + '$get_version_codes'(Major,Minor,Patch), + X = yap(Major, Minor, Patch, _). +yap_flag(version_data,X) :- + '$do_error'(permission_error(modify,flag,version),yap_flag(version_data,X)). + +'$get_version_codes'(Major,Minor,Patch) :- + get_value('$version_name',X), + atom_codes(X,VersionTag), %' + '$fetch_num_code'(VersionTag,0,Major,L1), + '$fetch_num_code'(L1,0,Minor,L2), + '$fetch_num_code'(L2,0,Patch,[]). + +'$fetch_num_code'([],Code,Code,[]). +'$fetch_num_code'([C|Cs],Code0,CodeF,L) :- + C >= 0'0, C =< 0'9, !, + CodeI is Code0*10+(C-0'0), %' + '$fetch_num_code'(Cs,CodeI,CodeF,L). +'$fetch_num_code'([_|Cs],Code,Code,Cs). + +yap_flag(max_integer,X) :- + var(X), !, + '$access_yap_flags'(0, 1), + '$access_yap_flags'(3, X). +yap_flag(max_integer,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,max_integer),yap_flag(max_integer,X)). +yap_flag(max_integer,X) :- + '$do_error'(domain_error(flag_value,max_integer+X),yap_flag(max_integer,X)). + +yap_flag(max_tagged_integer,X) :- + '$max_tagged_integer'(X), !. +yap_flag(max_tagged_integer,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,max_tagged_integer),yap_flag(max_tagged_integer,X)). +yap_flag(max_tagged_integer,X) :- + '$do_error'(domain_error(flag_value,max_tagged_integer+X),yap_flag(max_tagged_integer,X)). + +yap_flag(min_integer,X) :- + var(X), !, + '$access_yap_flags'(0, 1), + '$access_yap_flags'(4, X). +yap_flag(min_integer,X) :- + integer(X), X < 0, !, + '$do_error'(permission_error(modify,flag,min_integer),yap_flag(min_integer,X)). +yap_flag(min_integer,X) :- + '$do_error'(domain_error(flag_value,min_integer+X),yap_flag(min_integer,X)). + +yap_flag(min_tagged_integer,X) :- + '$min_tagged_integer'( X), !. +yap_flag(min_tagged_integer,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,min_tagged_integer),yap_flag(min_tagged_integer,X)). +yap_flag(min_tagged_integer,X) :- + '$do_error'(domain_error(flag_value,min_tagged_integer+X),yap_flag(min_tagged_integer,X)). + +/* ISO Core Revision DTR: new float flags + +yap_flag(float_mantissa_digits,X) :- + var(X), !, + ????? +yap_flag(float_mantissa_digits,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,float_mantissa_digits),yap_flag(float_mantissa_digits,X)). +yap_flag(float_mantissa_digits,X) :- + '$do_error'(domain_error(flag_value,float_mantissa_digits+X),yap_flag(float_mantissa_digits,X)). + +yap_flag(float_epsilon,X) :- + var(X), !, + ????? +yap_flag(float_epsilon,X) :- + float(X), X > 0, !, + '$do_error'(permission_error(modify,flag,float_epsilon),yap_flag(float_epsilon,X)). +yap_flag(float_epsilon,X) :- + '$do_error'(domain_error(flag_value,float_epsilon+X),yap_flag(float_epsilon,X)). + +yap_flag(float_min_exponent,X) :- + var(X), !, + ????? +yap_flag(float_min_exponent,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,float_min_exponent),yap_flag(float_min_exponent,X)). +yap_flag(float_epsilon,X) :- + '$do_error'(domain_error(flag_value,float_min_exponent+X),yap_flag(float_min_exponent,X)). + +yap_flag(float_max_exponent,X) :- + var(X), !, + ????? +yap_flag(float_max_exponent,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,float_max_exponent),yap_flag(flo + at_max_exponent,X)). +yap_flag(float_max_exponent,X) :- + '$do_error'(domain_error(flag_value,float_max_exponent+X),yap_flag(float_max_exponent,X)). +*/ + +yap_flag(char_conversion,X) :- + var(X), !, + '$access_yap_flags'(5, X1), + '$transl_to_on_off'(X1,X). +yap_flag(char_conversion,X) :- + '$transl_to_on_off'(X1,X), !, + '$set_yap_flags'(5,X1), + ( X1 = 1 -> + '$force_char_conversion' + ; + '$disable_char_conversion' + ). +yap_flag(char_conversion,X) :- + '$do_error'(domain_error(flag_value,char_conversion+X),yap_flag(char_conversion,X)). + +yap_flag(double_quotes,X) :- + var(X), !, + '$access_yap_flags'(6, X1), + '$transl_to_trl_types'(X1,X). +yap_flag(double_quotes,X) :- + '$transl_to_trl_types'(X1,X), !, + '$set_yap_flags'(6,X1). +yap_flag(double_quotes,X) :- + '$do_error'(domain_error(flag_value,double_quotes+X),yap_flag(double_quotes,X)). + +yap_flag(n_of_integer_keys_in_db,X) :- + var(X), !, + '$resize_int_keys'(X). +yap_flag(n_of_integer_keys_in_db,X) :- integer(X), X > 0, !, + '$resize_int_keys'(X). +yap_flag(n_of_integer_keys_in_db,X) :- + '$do_error'(domain_error(flag_value,n_of_integer_keys_in_db+X),yap_flag(n_of_integer_keys_in_db,X)). + +yap_flag(n_of_integer_keys_in_bb,X) :- + var(X), !, + '$resize_bb_int_keys'(X). +yap_flag(n_of_integer_keys_in_bb,X) :- integer(X), X > 0, !, + '$resize_bb_int_keys'(X). +yap_flag(n_of_integer_keys_in_bb,X) :- + '$do_error'(domain_error(flag_value,n_of_integer_keys_in_bb+X),yap_flag(n_of_integer_keys_in_bb,X)). + +yap_flag(profiling,X) :- (var(X); X = on; X = off), !, + '$is_profiled'(X). + +yap_flag(strict_iso,OUT) :- + var(OUT), !, + '$access_yap_flags'(9,X), + '$transl_to_on_off'(X,OUT). +yap_flag(strict_iso,on) :- !, + yap_flag(language,iso), + '$transl_to_on_off'(X,on), + '$set_yap_flags'(9,X). +yap_flag(strict_iso,off) :- !, + '$transl_to_on_off'(X,off), + '$set_yap_flags'(9,X). +yap_flag(strict_iso,X) :- + '$do_error'(domain_error(flag_value,strict_iso+X),yap_flag(strict_iso,X)). + +yap_flag(variable_names_may_end_with_quotes,OUT) :- + var(OUT), !, + '$access_yap_flags'(21,X), + '$transl_to_on_off'(X,OUT). +yap_flag(variable_names_may_end_with_quotes,on) :- !, + '$transl_to_on_off'(X,on), + '$set_yap_flags'(21,X). +yap_flag(variable_names_may_end_with_quotes,off) :- !, + '$transl_to_on_off'(X,off), + '$set_yap_flags'(21,X). +yap_flag(variable_names_may_end_with_quotes,X) :- + '$do_error'(domain_error(flag_value,strict_iso+X),yap_flag(strict_iso,X)). + +yap_flag(language,X) :- + var(X), !, + '$access_yap_flags'(8, X1), + '$trans_to_lang_flag'(X1,X). +yap_flag(language,X) :- + '$trans_to_lang_flag'(N,X), !, + '$set_yap_flags'(8,N), + '$adjust_language'(X). +yap_flag(language,X) :- + '$do_error'(domain_error(flag_value,language+X),yap_flag(language,X)). + +yap_flag(debug,X) :- + var(X), !, + ('$debug_on'(true) + -> + X = on + ; + X = true + ). +yap_flag(debug,X) :- + '$transl_to_on_off'(_,X), !, + (X = on -> debug ; nodebug). +yap_flag(debug,X) :- + '$do_error'(domain_error(flag_value,debug+X),yap_flag(debug,X)). + +yap_flag(discontiguous_warnings,X) :- + var(X), !, + ('$syntax_check_mode'(on,_), '$syntax_check_discontiguous'(on,_) -> + X = on + ; + X = off + ). +yap_flag(discontiguous_warnings,X) :- + '$transl_to_on_off'(_,X), !, + (X = on -> + '$syntax_check_mode'(_,on), + '$syntax_check_discontiguous'(_,on) + ; + '$syntax_check_discontiguous'(_,off)). +yap_flag(discontiguous_warnings,X) :- + '$do_error'(domain_error(flag_value,discontiguous_warnings+X),yap_flag(discontiguous_warnings,X)). + +yap_flag(redefine_warnings,X) :- + var(X), !, + ('$syntax_check_mode'(on,_), '$syntax_check_multiple'(on,_) -> + X = on + ; + X = off + ). +yap_flag(redefine_warnings,X) :- + '$transl_to_on_off'(_,X), !, + (X = on -> + '$syntax_check_mode'(_,on), + '$syntax_check_multiple'(_,on) + ; + '$syntax_check_multiple'(_,off)). +yap_flag(redefine_warnings,X) :- + '$do_error'(domain_error(flag_value,redefine_warnings+X),yap_flag(redefine_warnings,X)). + +yap_flag(chr_toplevel_show_store,X) :- + var(X), !, + nb_getval('$chr_toplevel_show_store',X). +yap_flag(chr_toplevel_show_store,X) :- + (X = true ; X = false), !, + nb_setval('$chr_toplevel_show_store',X). +yap_flag(chr_toplevel_show_store,X) :- + '$do_error'(domain_error(flag_value,chr_toplevel_show_store+X),yap_flag(chr_toplevel_show_store,X)). + +yap_flag(open_expands_filename,Expand) :- + var(Expand), !, + '$default_expand'(Expand). +yap_flag(open_expands_filename,Expand) :- + '$set_default_expand'(Expand). + +yap_flag(single_var_warnings,X) :- + var(X), !, + ('$syntax_check_mode'(on,_), '$syntax_check_single_var'(on,_) -> + X = on + ; + X = off + ). +yap_flag(single_var_warnings,X) :- + '$transl_to_on_off'(_,X), !, + (X = on -> + '$syntax_check_mode'(_,on), + '$syntax_check_single_var'(_,on) + ; + '$syntax_check_single_var'(_,off)). +yap_flag(single_var_warnings,X) :- + '$do_error'(domain_error(flag_value,single_var_warnings+X),yap_flag(single_var_warnings,X)). + +yap_flag(system_options,X) :- + '$system_options'(X). + +'$system_options'(big_numbers) :- + '$has_bignums'. +'$system_options'(coroutining) :- + '$yap_has_coroutining'. +'$system_options'(depth_limit) :- + \+ '$undefined'(get_depth_limit(_), prolog). +'$system_options'(low_level_tracer) :- + \+ '$undefined'(start_low_level_trace, prolog). +'$system_options'(or_parallelism) :- + \+ '$undefined'('$yapor_on', prolog). +'$system_options'(rational_trees) :- + '$yap_has_rational_trees'. +'$system_options'(readline) :- + '$has_readline'. +'$system_options'(tabling) :- + \+ '$undefined'('$c_table'(_,_), prolog). +'$system_options'(threads) :- + \+ '$no_threads'. +'$system_options'(wam_profiler) :- + \+ '$undefined'(reset_op_counters, prolog). + +yap_flag(unknown,X) :- + var(X), !, + unknown(X,_). +yap_flag(unknown,N) :- + unknown(_,N). + +yap_flag(to_chars_mode,X) :- + var(X), !, + ( '$access_yap_flags'(7,0) -> X = quintus ; X = iso ). +yap_flag(to_chars_mode,quintus) :- !, + '$set_yap_flags'(7,0). +yap_flag(to_chars_mode,iso) :- !, + '$set_yap_flags'(7,1). +yap_flag(to_chars_mode,X) :- + '$do_error'(domain_error(flag_value,to_chars_mode+X),yap_flag(to_chars_mode,X)). + +yap_flag(character_escapes,X) :- + var(X), !, + '$access_yap_flags'(12,Y), + '$transl_to_character_escape_modes'(Y,X). +yap_flag(character_escapes,X) :- !, + '$transl_to_character_escape_modes'(Y,X), !, + '$set_yap_flags'(12,Y). +yap_flag(character_escapes,X) :- + '$do_error'(domain_error(flag_value,character_escapes+X),yap_flag(to_chars_mode,X)). + +yap_flag(update_semantics,X) :- + var(X), !, + ( '$log_upd'(I) -> '$convert_upd_sem'(I,X) ). +yap_flag(update_semantics,logical) :- !, + '$switch_log_upd'(1). +yap_flag(update_semantics,logical_assert) :- !, + '$switch_log_upd'(2). +yap_flag(update_semantics,immediate) :- !, + '$switch_log_upd'(0). +yap_flag(update_semantics,X) :- + '$do_error'(domain_error(flag_value,update_semantics+X),yap_flag(update_semantics,X)). + +yap_flag(toplevel_hook,X) :- + var(X), !, + ( recorded('$toplevel_hooks',G,_) -> G ; true ). +yap_flag(toplevel_hook,G) :- !, + '$set_toplevel_hook'(G). + +yap_flag(unix,true) :- + '$unix', !. +yap_flag(unix,false). + +yap_flag(windows,true) :- + '$win32', !. +yap_flag(windows,false). + +yap_flag(shared_object_search_path,P) :- + '$ld_path'(P). + +yap_flag(typein_module,X) :- + var(X), !, + '$current_module'(X). +yap_flag(typein_module,X) :- + module(X). + +yap_flag(write_strings,OUT) :- + var(OUT), !, + '$access_yap_flags'(13,X), + '$transl_to_on_off'(X,OUT). +yap_flag(write_strings,on) :- !, + '$transl_to_on_off'(X,on), + '$set_yap_flags'(13,X). +yap_flag(write_strings,off) :- !, + '$transl_to_on_off'(X,off), + '$set_yap_flags'(13,X). +yap_flag(write_strings,X) :- + '$do_error'(domain_error(flag_value,write_strings+X),yap_flag(write_strings,X)). + +yap_flag(prompt_alternatives_on,OUT) :- + var(OUT), !, + '$prompt_alternatives_on'(OUT). +yap_flag(prompt_alternatives_on,determinism) :- !, + '$purge_clauses'('$prompt_alternatives_on'(_),prolog), + '$compile'('$prompt_alternatives_on'(determinism),0,'$prompt_alternatives_on'(determinism),prolog). +yap_flag(prompt_alternatives_on,groundness) :- !, + '$purge_clauses'('$prompt_alternatives_on'(_),prolog), + '$compile'('$prompt_alternatives_on'(groundness),0,'$prompt_alternatives_on'(groundness),prolog). +yap_flag(prompt_alternatives_on,X) :- + '$do_error'(domain_error(flag_value,prompt_alternatives_on+X),yap_flag(prompt_alternatives_on,X)). + +'$user_flags'(error). + +yap_flag(user_flags,OUT) :- + var(OUT), !, + '$user_flags'(OUT). +yap_flag(user_flags,silent) :- !, + '$purge_clauses'('$user_flags'(_),prolog), + '$compile'('$user_flags'(silent),0,'$user_flags'(silent),prolog). +yap_flag(user_flags,warning) :- !, + '$purge_clauses'('$user_flags'(_),prolog), + '$compile'('$user_flags'(warning),0,'$user_flags'(warning),prolog). +yap_flag(user_flags,error) :- !, + '$purge_clauses'('$user_flags'(_),prolog), + '$compile'('$user_flags'(error),0,'$user_flags'(error),prolog). +yap_flag(user_flags,X) :- + '$do_error'(domain_error(flag_value,user_flags+X),yap_flag(user_flags,X)). + +yap_flag(stack_dump_on_error,OUT) :- + var(OUT), !, + '$access_yap_flags'(17,X), + '$transl_to_on_off'(X,OUT). +yap_flag(stack_dump_on_error,on) :- !, +'$transl_to_on_off'(X,on), + '$set_yap_flags'(17,X). +yap_flag(stack_dump_on_error,off) :- !, + '$transl_to_on_off'(X,off), + '$set_yap_flags'(17,X). +yap_flag(stack_dump_on_error,X) :- + '$do_error'(domain_error(flag_value,stack_dump_on_error+X),yap_flag(stack_dump_on_error,X)). + +yap_flag(user_input,OUT) :- + var(OUT), !, + '$flag_check_alias'(OUT, user_input). + +yap_flag(user_input,Stream) :- + '$change_alias_to_stream'(user_input,Stream). + +yap_flag(user_output,OUT) :- + var(OUT), !, + '$flag_check_alias'(OUT, user_output). +yap_flag(user_output,Stream) :- + '$change_alias_to_stream'(user_output,Stream). + + +yap_flag(user_error,OUT) :- + var(OUT), !, + '$flag_check_alias'(OUT, user_error). +yap_flag(user_error,Stream) :- + '$change_alias_to_stream'(user_error,Stream). + +yap_flag(debugger_print_options,OUT) :- + var(OUT), + recorded('$print_options','$debugger'(OUT),_), !. +yap_flag(debugger_print_options,Opts) :- !, + '$check_io_opts'(Opts, yap_flag(debugger_print_options,Opts)), + recorda('$print_options','$debugger'(Opts),_). + +:- recorda('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(10)]),_). + +yap_flag(toplevel_print_options,OUT) :- + var(OUT), + recorded('$print_options','$toplevel'(OUT),_), !. +yap_flag(toplevel_print_options,Opts) :- !, + '$check_io_opts'(Opts, yap_flag(toplevel_print_options,Opts)), + recorda('$print_options','$toplevel'(Opts),_). + +yap_flag(fileerrors,OUT) :- + var(OUT), !, + get_value(fileerrors,X0), + (X0 = [] -> X= 0 ; X = X0), + '$transl_to_on_off'(X,OUT). +yap_flag(fileerrors,on) :- !, + set_value(fileerrors,1). +yap_flag(fileerrors,off) :- !, + set_value(fileerrors,0). +yap_flag(fileerrors,X) :- + '$do_error'(domain_error(flag_value,fileerrors+X),yap_flag(fileerrors,X)). + +:- recorda('$print_options','$toplevel'([quoted(true),numbervars(true),portrayed(true)]),_). + +yap_flag(host_type,X) :- + '$host_type'(X). + +yap_flag(verbose_load,X) :- + var(X), !, + ( get_value('$lf_verbose',silent) -> X = false ; X = true ). +yap_flag(verbose_load,true) :- !, + set_value('$lf_verbose',informational). +yap_flag(verbose_load,false) :- !, + set_value('$lf_verbose',silent), + '$set_yap_flags'(7,1). +yap_flag(verbose_load,X) :- + '$do_error'(domain_error(flag_value,verbose_auto_load+X),yap_flag(verbose_auto_load,X)). + +yap_flag(verbose_auto_load,X) :- + var(X), !, + ( get_value('$verbose_auto_load',true) -> X = true ; X = false ). +yap_flag(verbose_auto_load,true) :- !, + set_value('$verbose_auto_load',true). +yap_flag(verbose_auto_load,false) :- !, + set_value('$verbose_auto_load',false), + '$set_yap_flags'(7,1). +yap_flag(verbose_auto_load,X) :- + '$do_error'(domain_error(flag_value,verbose_auto_load+X),yap_flag(verbose_auto_load,X)). + +yap_flag(float_format,X) :- + var(X), !, + '$float_format'(X). +yap_flag(float_format,X) :- + atom(X), !, + '$float_format'(X). +yap_flag(float_format,X) :- + '$do_error'(type_error(atom,X),yap_flag(float_format,X)). + +yap_flag(max_workers,X) :- + var(X), !, + '$max_workers'(X). +yap_flag(max_workers,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,max_workers),yap_flag(max_workers,X)). +yap_flag(max_workers,X) :- + '$do_error'(domain_error(flag_value,max_workers+X),yap_flag(max_workers,X)). + +yap_flag(max_threads,X) :- + var(X), !, + '$max_threads'(X). +yap_flag(max_threads,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,max_threads),yap_flag(max_threads,X)). +yap_flag(max_threads,X) :- + '$do_error'(domain_error(flag_value,max_threads+X),yap_flag(max_threads,X)). + +yap_flag(address_bits,X) :- + var(X), !, + '$address_bits'(X). +yap_flag(address_bits,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,address_bits),yap_flag(address_bits,X)). +yap_flag(address_bits,X) :- + '$do_error'(domain_error(flag_value,address_bits+X),yap_flag(address_bits,X)). + +yap_flag(dialect,yap). + +'$yap_system_flag'(address_bits). +'$yap_system_flag'(answer_format). +'$yap_system_flag'(argv). +'$yap_system_flag'(bounded). +'$yap_system_flag'(char_conversion). +'$yap_system_flag'(character_escapes). +'$yap_system_flag'(chr_toplevel_show_store). +'$yap_system_flag'(debug). +'$yap_system_flag'(debugger_print_options). +'$yap_system_flag'(dialect). +'$yap_system_flag'(discontiguous_warnings). +'$yap_system_flag'(dollar_as_lower_case). +'$yap_system_flag'(double_quotes). +'$yap_system_flag'(encoding). +'$yap_system_flag'(executable). +% V = fast ; +'$yap_system_flag'(fileerrors ). +'$yap_system_flag'(float_format). +% V = float_mantissa_digits ; +% V = float_epsilon ; +% V = float_min_exponent ; +% V = float_max_exponent ; +'$yap_system_flag'(gc ). +'$yap_system_flag'(gc_margin ). +'$yap_system_flag'(gc_trace ). +'$yap_system_flag'(generate_debug_info ). +% V = hide ; +'$yap_system_flag'(home ). +'$yap_system_flag'(host_type ). +'$yap_system_flag'(index). +'$yap_system_flag'(tabling_mode). +'$yap_system_flag'(informational_messages). +'$yap_system_flag'(integer_rounding_function). +'$yap_system_flag'(language). +'$yap_system_flag'(max_arity). +'$yap_system_flag'(max_integer). +'$yap_system_flag'(max_tagged_integer). +'$yap_system_flag'(max_workers). +'$yap_system_flag'(max_threads). +'$yap_system_flag'(min_integer). +'$yap_system_flag'(min_tagged_integer). +'$yap_system_flag'(n_of_integer_keys_in_db). +'$yap_system_flag'(open_expands_filename). +'$yap_system_flag'(profiling). +'$yap_system_flag'(prompt_alternatives_on). +'$yap_system_flag'(redefine_warnings). +'$yap_system_flag'(shared_object_search_path). +'$yap_system_flag'(single_var_warnings). +'$yap_system_flag'(stack_dump_on_error). +'$yap_system_flag'(strict_iso). +'$yap_system_flag'(syntax_errors). +'$yap_system_flag'(system_options). +'$yap_system_flag'(to_chars_mode). +'$yap_system_flag'(toplevel_hook). +'$yap_system_flag'(toplevel_print_options). +'$yap_system_flag'(typein_module). +'$yap_system_flag'(unix). +'$yap_system_flag'(unknown). +'$yap_system_flag'(update_semantics). +'$yap_system_flag'(user_error). +'$yap_system_flag'(user_flags). +'$yap_system_flag'(user_input). +'$yap_system_flag'(user_output). +'$yap_system_flag'(variable_names_may_end_with_quotes). +'$yap_system_flag'(verbose). +'$yap_system_flag'(verbose_auto_load). +'$yap_system_flag'(version). +'$yap_system_flag'(version_data). +'$yap_system_flag'(windows). +'$yap_system_flag'(write_strings). + +'$show_yap_flag_opts'(V,Out) :- + '$yap_system_flag'(V), + yap_flag(V, Out). + +'$trans_to_lang_flag'(0,cprolog). +'$trans_to_lang_flag'(1,iso). +'$trans_to_lang_flag'(2,sicstus). + +'$adjust_language'(cprolog) :- +% '$switch_log_upd'(0), + '$syntax_check_mode'(_,off), + '$syntax_check_single_var'(_,off), + '$syntax_check_discontiguous'(_,off), + '$syntax_check_multiple'(_,off), + '$set_yap_flags'(12,0), % disable character escapes. + '$set_yap_flags'(14,1), + '$set_fpu_exceptions', + unknown(_,fail). +'$adjust_language'(sicstus) :- + '$switch_log_upd'(1), + leash(full), + '$syntax_check_mode'(_,on), + '$syntax_check_single_var'(_,on), + '$syntax_check_discontiguous'(_,on), + '$syntax_check_multiple'(_,on), + '$transl_to_on_off'(X1,on), + '$set_yap_flags'(5,X1), + '$force_char_conversion', + '$set_yap_flags'(14,0), + % CHARACTER_ESCAPE + '$set_yap_flags'(12,1), + '$set_fpu_exceptions', + fileerrors, + unknown(_,error). +'$adjust_language'(iso) :- + '$switch_log_upd'(1), + '$syntax_check_mode'(_,on), + '$syntax_check_single_var'(_,on), + '$syntax_check_discontiguous'(_,on), + '$syntax_check_multiple'(_,on), + % YAP_TO_CHARS + '$set_yap_flags'(7,1), + fileerrors, + '$transl_to_on_off'(X1,on), + % CHAR_CONVERSION + '$set_yap_flags'(5,X1), + '$force_char_conversion', + % ALLOW_ASSERTING_STATIC + '$set_yap_flags'(14,0), + % CHARACTER_ESCAPE + '$set_yap_flags'(12,1), + '$set_fpu_exceptions', + unknown(_,error). + +'$transl_to_character_escape_modes'(0,off) :- !. +'$transl_to_character_escape_modes'(0,cprolog). +'$transl_to_character_escape_modes'(2,on) :- !. +'$transl_to_character_escape_modes'(1,iso). +'$transl_to_character_escape_modes'(2,sicstus). + +'$convert_upd_sem'(0,immediate). +'$convert_upd_sem'(1,logical). +'$convert_upd_sem'(2,logical_assert). + +'$transl_to_true_false'(0,false). +'$transl_to_true_false'(1,true). + +'$transl_to_on_off'(0,off). +'$transl_to_on_off'(1,on). + +'$transl_to_arity'(X1,X) :- X1 < 0, !, X = unbounded. +'$transl_to_arity'(X,X). + +'$transl_to_rounding_function'(0,down). +'$transl_to_rounding_function'(1,toward_zero). + +'$transl_to_trl_types'(0,chars). +'$transl_to_trl_types'(1,codes). +'$transl_to_trl_types'(2,atom). + +'$yap_flag_show_gc_tracing'(true, _, _, on) :- !. +'$yap_flag_show_gc_tracing'(_, true, _, verbose) :- !. +'$yap_flag_show_gc_tracing'(_, _, on, very_verbose) :- !. +'$yap_flag_show_gc_tracing'(_, _, _, off). + +'$flag_check_alias'(OUT, Alias) :- + stream_property(OUT,[alias(Alias)]), !. + +current_prolog_flag(V,Out) :- + var(V), !, + '$show_yap_flag_opts'(V,NOut), + NOut = Out. +current_prolog_flag(V,Out) :- + atom(V), !, + yap_flag(V,NOut), + NOut = Out. +current_prolog_flag(V,Out) :- + '$do_error'(type_error(atom,V),current_prolog_flag(V,Out)). + +set_prolog_flag(F,V) :- + var(F), !, + '$do_error'(instantiation_error,set_prolog_flag(F,V)). +set_prolog_flag(F,V) :- + var(V), !, + '$do_error'(instantiation_error,set_prolog_flag(F,V)). +set_prolog_flag(F, Val) :- + prolog:'$user_defined_flag'(F,_,_,_), !, + yap_flag(F, Val). +set_prolog_flag(F,V) :- + \+ atom(F), !, + '$do_error'(type_error(atom,F),set_prolog_flag(F,V)). +set_prolog_flag(F, Val) :- + prolog:'$user_defined_flag'(F,_,_,_), !, + yap_flag(F, Val). +set_prolog_flag(F,V) :- + '$yap_system_flag'(F), !, + yap_flag(F,V). +set_prolog_flag(F,V) :- + '$user_flags'(UFlag), + ( + UFlag = silent -> + create_prolog_flag(F, V, []) + ; + UFlag = warning -> + print_message(warning,existence_error(prolog_flag, F)), + create_prolog_flag(F, V, []) + ; + UFlag = error -> + '$do_error'(existence_error(prolog_flag, F),set_prolog_flag(F,V)) + ). + +prolog_flag(F, Old, New) :- + var(F), !, + '$do_error'(instantiation_error,prolog_flag(F,Old,New)). +prolog_flag(F, Old, New) :- + current_prolog_flag(F, Old), + set_prolog_flag(F, New). + +prolog_flag(F, Old) :- + current_prolog_flag(F, Old). + +% if source_mode is on, then the source for the predicates +% is stored with the code +source_mode(Old,New) :- + '$access_yap_flags'(11,X), + '$transl_to_on_off'(X,Old), + '$transl_to_on_off'(XN,New), + '$set_yap_flags'(11,XN). + +source :- '$set_yap_flags'(11,1). +no_source :- '$set_yap_flags'(11,0). + +create_prolog_flag(Name, Value, Options) :- + '$check_flag_name'(Name, create_prolog_flag(Name, Value, Options)), + '$check_flag_options'(Options, Domain, RW, create_prolog_flag(Name, Value, Options)), + '$check_flag_value'(Value, Domain, create_prolog_flag(Name, Value, Options)), + retractall(prolog:'$user_defined_flag'(Name,_,_,_)), + assert(prolog:'$user_defined_flag'(Name,Domain,RW,Value)). + +'$check_flag_name'(V, G) :- + var(V), + '$do_error'(instantiation_error,G). +'$check_flag_name'(Name, _) :- + atom(Name), !. +'$check_flag_name'(Name, G) :- + '$do_error'(type_error(atom),G). + +'$check_flag_options'(O, _, _, G) :- + var(O), + '$do_error'(instantiation_error,G). +'$check_flag_options'([], _, read_write, _) :- !. +'$check_flag_options'([O1|Os], Domain, RW, G) :- !, + '$check_flag_optionsl'([O1|Os], Domain, RW, G). +'$check_flag_options'(O, _, _, G) :- + '$do_error'(type_error(list),G). + + +'$check_flag_optionsl'([], _, read_write, G). +'$check_flag_optionsl'([V|Os], Domain, RW, G) :- + var(V), + '$do_error'(instantiation_error,G). +'$check_flag_optionsl'([type(Type)|Os], Domain, RW, G) :- !, + '$check_flag_type'(Type, Domain, G), + '$check_flag_optionsl'(Os, _, RW, G). +'$check_flag_optionsl'([access(Access)|Os], Domain, RW, G) :- !, + '$check_flag_access'(Access, RW, G), + '$check_flag_optionsl'(Os, Domain, _, G). +'$check_flag_optionsl'(Os, Domain, RW, G) :- + '$do_error'(domain_error(create_prolog_flag,Os),G). + +'$check_flag_type'(V, _, G) :- + var(V), + '$do_error'(instantiation_error,G). +'$check_flag_type'(boolean, boolean, _) :- !. +'$check_flag_type'(integer, integer, _) :- !. +'$check_flag_type'(float, float, _) :- !. +'$check_flag_type'(atom, atom, _) :- !. +'$check_flag_type'(term, term, _) :- !. +'$check_flag_type'(Atom, _, G) :- + '$do_error'(domain_error(create_prolog_flag_option(type),Atom),G). + +'$check_flag_access'(V, _, G) :- + var(V), + '$do_error'(instantiation_error,G). +'$check_flag_access'(read_write, read_write, _) :- !. +'$check_flag_access'(read_only, read_only, _) :- !. +'$check_flag_type'(Atom, _, G) :- + '$do_error'(domain_error(create_prolog_flag_option(access),Atom),G). + +'$user_flag_value'(F, Val) :- + var(Val), !, + '$user_defined_flag'(F,_,_,Val). +'$user_flag_value'(F, Val) :- + atomic(Val), !, + prolog:'$user_defined_flag'(F,Domain,RW,V0), + ( + Val == V0 + -> + true + ; + RW = read_only + -> + '$do_error'(permission_error(modify,flag,F),yap_flag(F,Val)) + ; + '$check_flag_value'(Val, Domain, yap_flag(F,Val)), + retractall(prolog:'$user_defined_flag'(F,_,_,_)), + assert(prolog:'$user_defined_flag'(F,Domain,RW,Val)) + ). +'$user_flag_value'(F, Val) :- + '$do_error'(type_error(atomic,Val),yap_flag(F,Val)). + +'$check_flag_value'(Value, _, G) :- + \+ ground(Value), !, + '$do_error'(instantiation_error,G). +'$check_flag_value'(Value, Domain, G) :- + var(Domain), !, + '$flag_domain_from_value'(Value, Domain). +'$check_flag_value'(_, term, _) :- !. +'$check_flag_value'(Value, atom, _) :- + atom(Value), !. +'$check_flag_value'(Value, integer, _) :- + integer(Value), !. +'$check_flag_value'(Value, float, _) :- + float(Value), !. +'$check_flag_value'(true, boolean, _) :- !. +'$check_flag_value'(false, boolean, _) :- !. +'$check_flag_value'(Value, Domain, G) :- + '$do_error'(domain_error(Domain,Value),G). + +'$flag_domain_from_value'(true, boolean) :- !. +'$flag_domain_from_value'(false, boolean) :- !. +'$flag_domain_from_value'(Value, integer) :- integer(Value), !. +'$flag_domain_from_value'(Value, float) :- float(Value), !. +'$flag_domain_from_value'(Value, atom) :- atom(Value), !. +'$flag_domain_from_value'(_, term). + + + diff --git a/pl/init.yap b/pl/init.yap index c98b8152a..2bd34f4f8 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -45,7 +45,8 @@ otherwise. :- [ 'utils.yap', 'control.yap', 'arith.yap', - 'directives.yap']. + 'directives.yap', + 'flags.yap']. :- compile_expressions. diff --git a/pl/messages.yap b/pl/messages.yap index 65149e5c8..85fd9df4a 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -127,6 +127,8 @@ system_message(no_match(P)) --> [ 'No matching predicate for ~w.' - [P] ]. system_message(leash([A|B])) --> [ 'Leashing set to ~w.' - [[A|B]] ]. +system_message(existence_error(prolog_flag,F)) --> + [ 'Prolog Flag ~w: new Prolog flags must be created using create_prolog_flag/3.' - [F] ]. system_message(singletons([SV],P,CLN)) --> [ 'Singleton variable ~s in ~q, clause ~d.' - [SV,P,CLN] ]. system_message(singletons(SVs,P,CLN)) --> @@ -154,6 +156,8 @@ system_message(error(context_error(Goal,Who),Where)) --> system_message(error(domain_error(DomainType,Opt), Where)) --> [ 'DOMAIN ERROR- ~w: ' - Where], domain_error(DomainType, Opt). +system_message(error(existence_error(prolog_flag,P), Where)) --> !, + [ 'EXISTENCE ERROR- ~w: prolog flag ~w is undefined' - [Where,P] ]. system_message(error(existence_error(procedure,P), context(Call,Parent))) --> !, [ 'EXISTENCE ERROR- procedure ~w is undefined, called from context ~w~n Goal was ~w' - [P,Parent,Call] ]. system_message(error(existence_error(stream,Stream), Where)) --> @@ -162,6 +166,8 @@ system_message(error(existence_error(key,Key), Where)) --> [ 'EXISTENCE ERROR- ~w: ~w not an existing key' - [Where,Key] ]. system_message(error(existence_error(thread,Thread), Where)) --> [ 'EXISTENCE ERROR- ~w: ~w not a running thread' - [Where,Thread] ]. +system_message(error(existence_error(variable,Var), Where)) --> + [ 'EXISTENCE ERROR- ~w: variable ~w does not exist' - [Where,Var] ]. system_message(error(existence_error(Name,F), W)) --> { object_name(Name, ObjName) }, [ 'EXISTENCE ERROR- ~w could not open ~a ~w' - [W,ObjName,F] ]. diff --git a/pl/modules.yap b/pl/modules.yap index df90272d0..e84aeff15 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -297,6 +297,27 @@ module(N) :- '$module_expansion'(M:G,G1,GO,_,CM,_,HVars) :- !, '$module_expansion'(G,G1,GO,M,M,HM,HVars). '$module_expansion'(G, G1, GO, CurMod, MM, HM, HVars) :- + '$do_expand'(CurMod:G, CurMod:GI), !, + '$module_expansion'(GI, G1, GO, CurMod, MM, HM, HVars). +'$module_expansion'(G, G1, GO, CurMod, MM, HM,HVars) :- + % is this imported from some other module M1? + '$imported_pred'(G, CurMod, GG, M1), + !, + '$module_expansion'(GG, G1, GO, M1, MM, HM,HVars). +'$module_expansion'(G, G1, GO, CurMod, MM, HM,HVars) :- + '$meta_expansion'(G, CurMod, MM, HM, GI, HVars), !, + '$complete_goal_expansion'(GI, CurMod, MM, HM, G1, GO, HVars). +'$module_expansion'(G, G1, GO, CurMod, MM, HM, HVars) :- + '$complete_goal_expansion'(G, CurMod, MM, HM, G1, GO, HVars). + +expand_goal(G, NG) :- + '$current_module'(Mod), + '$do_expand'(G, M, NG), !. +expand_goal(M:G, M:NG) :- + '$do_expand'(G, M, NG), !. +expand_goal(G, G). + +'$do_expand'(G, CurMod, NG) :- '$pred_goal_expansion_on', ( user:goal_expansion(G, CurMod, GI) -> @@ -309,18 +330,7 @@ module(N) :- ) ; user:goal_expansion(G, GI) - ), !, - '$module_expansion'(GI, G1, GO, CurMod, MM, HM, HVars). -'$module_expansion'(G, G1, GO, CurMod, MM, HM,HVars) :- - % is this imported from some other module M1? - '$imported_pred'(G, CurMod, GG, M1), - !, - '$module_expansion'(GG, G1, GO, M1, MM, HM,HVars). -'$module_expansion'(G, G1, GO, CurMod, MM, HM,HVars) :- - '$meta_expansion'(G, CurMod, MM, HM, GI, HVars), !, - '$complete_goal_expansion'(GI, CurMod, MM, HM, G1, GO, HVars). -'$module_expansion'(G, G1, GO, CurMod, MM, HM, HVars) :- - '$complete_goal_expansion'(G, CurMod, MM, HM, G1, GO, HVars). + ). % args are: % goal to expand diff --git a/pl/preds.yap b/pl/preds.yap index 54ad06722..88c2c62c4 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -525,6 +525,11 @@ abolish(X) :- '$abolish_all_atoms'(A,M). '$new_abolish'(M:PS,_) :- !, '$new_abolish'(PS,M). +'$new_abolish'(Na//Ar1, M) :- + integer(Ar1), + !, + Ar is Ar1+2, + '$new_abolish'(Na//Ar, M). '$new_abolish'(Na/Ar, M) :- functor(H, Na, Ar), '$is_dynamic'(H, M), !, @@ -556,7 +561,8 @@ abolish(X) :- '$check_error_in_module'(M, Msg), '$check_error_in_predicate_indicator'(S, Msg). '$check_error_in_predicate_indicator'(S, Msg) :- - S \= _/_, !, + S \= _/_, + S \= _//_, !, '$do_error'(type_error(predicate_indicator,S), Msg). '$check_error_in_predicate_indicator'(Na/_, Msg) :- var(Na), !, @@ -685,6 +691,10 @@ dynamic(X) :- '$dynamic2'(X, Mod) :- '$log_upd'(Stat), Stat\=0, !, '$logical_updatable'(X, Mod). +'$dynamic2'(A//N1, Mod) :- + integer(N1), + N is N1+2, + '$dynamic2'(A/N, Mod). '$dynamic2'(A/N, Mod) :- integer(N), atom(A), !, functor(T,A,N), '$flags'(T,Mod,F,F), @@ -699,6 +709,9 @@ dynamic(X) :- '$do_error'(type_error(callable,X),dynamic(Mod:X)). +'$logical_updatable'(A//N,Mod) :- integer(N), !, + N1 is N+2, + '$logical_updatable'(A/N1,Mod). '$logical_updatable'(A/N,Mod) :- integer(N), atom(A), !, functor(T,A,N), '$flags'(T,Mod,F,F), ( @@ -747,6 +760,9 @@ dynamic_predicate(P,Sem) :- '$public'((A,B), M) :- !, '$public'(A,M), '$public'(B,M). '$public'([],_) :- !. '$public'([H|L], M) :- !, '$public'(H, M), '$public'(L, M). +'$public'(A//N1, Mod) :- integer(N1), !, + N is N1+2, + '$public'(A//N, Mod). '$public'(A/N, Mod) :- integer(N), atom(A), !, functor(T,A,N), '$do_make_public'(T, Mod). diff --git a/pl/signals.yap b/pl/signals.yap index 3e529e969..606273eb3 100644 --- a/pl/signals.yap +++ b/pl/signals.yap @@ -249,6 +249,12 @@ alarm(Interval, Goal, Left) :- integer(Interval), !, on_signal(sig_alarm, _, Goal), '$alarm'(Interval, 0, Left, _). +alarm(Number, Goal, Left) :- + float(Number), !, + Secs is integer(Number), + USecs is integer((Number-Secs)*1000000) mod 1000000, + on_signal(sig_alarm, _, Goal), + '$alarm'(Interval, 0, Left, _). alarm(Interval.USecs, Goal, Left.LUSecs) :- on_signal(sig_alarm, _, Goal), '$alarm'(Interval, USecs, Left, LUSecs).