stop using submodule
This commit is contained in:
parent
d47f59be09
commit
9b33c9d8ba
|
@ -1,42 +0,0 @@
|
|||
[submodule "packages/chr"]
|
||||
path = packages/chr
|
||||
url = git://git.code.sf.net/p/yap/chr
|
||||
[submodule "packages/clpqr"]
|
||||
path = packages/clpqr
|
||||
url = git://git.code.sf.net/p/yap/clpqr
|
||||
[submodule "packages/jpl"]
|
||||
path = packages/jpl
|
||||
url = git://git.code.sf.net/p/yap/jpl
|
||||
[submodule "packages/zlib"]
|
||||
path = packages/zlib
|
||||
url = git://git.code.sf.net/p/yap/zlib
|
||||
[submodule "packages/http"]
|
||||
path = packages/http
|
||||
url = git://git.code.sf.net/p/yap/http
|
||||
[submodule "packages/clib"]
|
||||
path = packages/clib
|
||||
url = git://git.code.sf.net/p/yap/clib
|
||||
[submodule "packages/sgml"]
|
||||
path = packages/sgml
|
||||
url = git://git.code.sf.net/p/yap/sgml
|
||||
[submodule "packages/RDF"]
|
||||
path = packages/RDF
|
||||
url = git://git.code.sf.net/p/yap/RDF
|
||||
[submodule "packages/semweb"]
|
||||
path = packages/semweb
|
||||
url = git://git.code.sf.net/p/yap/semweb
|
||||
[submodule "packages/plunit"]
|
||||
path = packages/plunit
|
||||
url = git://git.code.sf.net/p/yap/plunit
|
||||
[submodule "packages/archive"]
|
||||
path = packages/archive
|
||||
url = git://git.code.sf.net/p/yap/archive
|
||||
[submodule "packages/odbc"]
|
||||
path = packages/odbc
|
||||
url = git://git.code.sf.net/p/yap/odbc
|
||||
[submodule "packages/udi"]
|
||||
path = packages/udi
|
||||
url = https://github.com/vscosta/yap-udi-indexers.git
|
||||
[submodule "packages/raptor"]
|
||||
path = packages/raptor
|
||||
url = git://git.code.sf.net/p/yap/raptor
|
|
@ -1 +0,0 @@
|
|||
Subproject commit f19e64df267c6dbaf3c4f93b44f2b1e343e4b449
|
|
@ -1 +0,0 @@
|
|||
Subproject commit 2095a5f288ae9cd6bed978295f78723a0ba62e6f
|
|
@ -1 +0,0 @@
|
|||
Subproject commit 0e7ab5c61c1387b21fb64458be6e3534a493fb27
|
|
@ -0,0 +1,26 @@
|
|||
:- prolog_load_context(directory, Dir),
|
||||
working_directory(_, Dir).
|
||||
|
||||
benches :-
|
||||
bench(B),
|
||||
atom_concat(B, '.chr', File),
|
||||
style_check(-singleton),
|
||||
abolish(main,0),
|
||||
abolish(main,1),
|
||||
[File],
|
||||
% (main;main;main;main),
|
||||
main,
|
||||
fail.
|
||||
benches.
|
||||
|
||||
bench(bool).
|
||||
bench(fib).
|
||||
bench(fibonacci).
|
||||
bench(leq).
|
||||
bench(primes).
|
||||
bench(ta).
|
||||
bench(wfs).
|
||||
bench(zebra).
|
||||
|
||||
cputime(Time) :-
|
||||
statistics(runtime, [_,Time]).
|
|
@ -0,0 +1,322 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Thom Fruehwirth ECRC 1991-1993
|
||||
%% 910528 started boolean,and,or constraints
|
||||
%% 910904 added xor,neg constraints
|
||||
%% 911120 added imp constraint
|
||||
%% 931110 ported to new release
|
||||
%% 931111 added card constraint
|
||||
%% 961107 Christian Holzbaur, SICStus mods
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers June 2003
|
||||
|
||||
|
||||
:- module(bool,[main/0,main/1]).
|
||||
|
||||
:- use_module( library(chr)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
:- chr_constraint boolean/1, and/3, or/3, xor/3, neg/2, imp/2, labeling/0, card/4.
|
||||
|
||||
|
||||
boolean(0) <=> true.
|
||||
boolean(1) <=> true.
|
||||
|
||||
labeling, boolean(A)#Pc <=>
|
||||
( A=0 ; A=1),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
|
||||
%% and/3 specification
|
||||
%%and(0,0,0).
|
||||
%%and(0,1,0).
|
||||
%%and(1,0,0).
|
||||
%%and(1,1,1).
|
||||
|
||||
and(0,X,Y) <=> Y=0.
|
||||
and(X,0,Y) <=> Y=0.
|
||||
and(1,X,Y) <=> Y=X.
|
||||
and(X,1,Y) <=> Y=X.
|
||||
and(X,Y,1) <=> X=1,Y=1.
|
||||
and(X,X,Z) <=> X=Z.
|
||||
%%and(X,Y,X) <=> imp(X,Y).
|
||||
%%and(X,Y,Y) <=> imp(Y,X).
|
||||
and(X,Y,A) \ and(X,Y,B) <=> A=B.
|
||||
and(X,Y,A) \ and(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, and(A,B,C)#Pc <=>
|
||||
label_and(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_and(0,X,0).
|
||||
label_and(1,X,X).
|
||||
|
||||
|
||||
%% or/3 specification
|
||||
%%or(0,0,0).
|
||||
%%or(0,1,1).
|
||||
%%or(1,0,1).
|
||||
%%or(1,1,1).
|
||||
|
||||
or(0,X,Y) <=> Y=X.
|
||||
or(X,0,Y) <=> Y=X.
|
||||
or(X,Y,0) <=> X=0,Y=0.
|
||||
or(1,X,Y) <=> Y=1.
|
||||
or(X,1,Y) <=> Y=1.
|
||||
or(X,X,Z) <=> X=Z.
|
||||
%%or(X,Y,X) <=> imp(Y,X).
|
||||
%%or(X,Y,Y) <=> imp(X,Y).
|
||||
or(X,Y,A) \ or(X,Y,B) <=> A=B.
|
||||
or(X,Y,A) \ or(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, or(A,B,C)#Pc <=>
|
||||
label_or(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_or(0,X,X).
|
||||
label_or(1,X,1).
|
||||
|
||||
|
||||
%% xor/3 specification
|
||||
%%xor(0,0,0).
|
||||
%%xor(0,1,1).
|
||||
%%xor(1,0,1).
|
||||
%%xor(1,1,0).
|
||||
|
||||
xor(0,X,Y) <=> X=Y.
|
||||
xor(X,0,Y) <=> X=Y.
|
||||
xor(X,Y,0) <=> X=Y.
|
||||
xor(1,X,Y) <=> neg(X,Y).
|
||||
xor(X,1,Y) <=> neg(X,Y).
|
||||
xor(X,Y,1) <=> neg(X,Y).
|
||||
xor(X,X,Y) <=> Y=0.
|
||||
xor(X,Y,X) <=> Y=0.
|
||||
xor(Y,X,X) <=> Y=0.
|
||||
xor(X,Y,A) \ xor(X,Y,B) <=> A=B.
|
||||
xor(X,Y,A) \ xor(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, xor(A,B,C)#Pc <=>
|
||||
label_xor(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_xor(0,X,X).
|
||||
label_xor(1,X,Y):- neg(X,Y).
|
||||
|
||||
|
||||
%% neg/2 specification
|
||||
%%neg(0,1).
|
||||
%%neg(1,0).
|
||||
|
||||
neg(0,X) <=> X=1.
|
||||
neg(X,0) <=> X=1.
|
||||
neg(1,X) <=> X=0.
|
||||
neg(X,1) <=> X=0.
|
||||
neg(X,X) <=> fail.
|
||||
neg(X,Y) \ neg(Y,Z) <=> X=Z.
|
||||
neg(X,Y) \ neg(Z,Y) <=> X=Z.
|
||||
neg(Y,X) \ neg(Y,Z) <=> X=Z.
|
||||
%% Interaction with other boolean constraints
|
||||
neg(X,Y) \ and(X,Y,Z) <=> Z=0.
|
||||
neg(Y,X) \ and(X,Y,Z) <=> Z=0.
|
||||
neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(X,Y) \ or(X,Y,Z) <=> Z=1.
|
||||
neg(Y,X) \ or(X,Y,Z) <=> Z=1.
|
||||
neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(X,Y) \ xor(X,Y,Z) <=> Z=1.
|
||||
neg(Y,X) \ xor(X,Y,Z) <=> Z=1.
|
||||
neg(X,Z) \ xor(X,Y,Z) <=> Y=1.
|
||||
neg(Z,X) \ xor(X,Y,Z) <=> Y=1.
|
||||
neg(Y,Z) \ xor(X,Y,Z) <=> X=1.
|
||||
neg(Z,Y) \ xor(X,Y,Z) <=> X=1.
|
||||
neg(X,Y) , imp(X,Y) <=> X=0,Y=1.
|
||||
neg(Y,X) , imp(X,Y) <=> X=0,Y=1.
|
||||
|
||||
labeling, neg(A,B)#Pc <=>
|
||||
label_neg(A,B),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_neg(0,1).
|
||||
label_neg(1,0).
|
||||
|
||||
|
||||
%% imp/2 specification (implication)
|
||||
%%imp(0,0).
|
||||
%%imp(0,1).
|
||||
%%imp(1,1).
|
||||
|
||||
imp(0,X) <=> true.
|
||||
imp(X,0) <=> X=0.
|
||||
imp(1,X) <=> X=1.
|
||||
imp(X,1) <=> true.
|
||||
imp(X,X) <=> true.
|
||||
imp(X,Y),imp(Y,X) <=> X=Y.
|
||||
|
||||
labeling, imp(A,B)#Pc <=>
|
||||
label_imp(A,B),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_imp(0,X).
|
||||
label_imp(1,1).
|
||||
|
||||
|
||||
|
||||
%% Boolean cardinality operator
|
||||
%% card(A,B,L,N) constrains list L of length N to have between A and B 1s
|
||||
|
||||
|
||||
card(A,B,L):-
|
||||
length(L,N),
|
||||
A=<B,0=<B,A=<N, %0=<N
|
||||
card(A,B,L,N).
|
||||
|
||||
%% card/4 specification
|
||||
%%card(A,B,[],0):- A=<0,0=<B.
|
||||
%%card(A,B,[0|L],N):-
|
||||
%% N1 is N-1,
|
||||
%% card(A,B,L,N1).
|
||||
%%card(A,B,[1|L],N):-
|
||||
%% A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
%% card(A1,B1,L,N1).
|
||||
|
||||
triv_sat @ card(A,B,L,N) <=> A=<0,N=<B | true. % trivial satisfaction
|
||||
pos_sat @ card(N,B,L,N) <=> set_to_ones(L). % positive satisfaction
|
||||
neg_sat @ card(A,0,L,N) <=> set_to_zeros(L). % negative satisfaction
|
||||
pos_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==1 | % positive reduction
|
||||
A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
card(A1,B1,L1,N1).
|
||||
neg_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==0 | % negative reduction
|
||||
N1 is N-1,
|
||||
card(A,B,L1,N1).
|
||||
%% special cases with two variables
|
||||
card2nand @ card(0,1,[X,Y],2) <=> and(X,Y,0).
|
||||
card2neg @ card(1,1,[X,Y],2) <=> neg(X,Y).
|
||||
card2or @ card(1,2,[X,Y],2) <=> or(X,Y,1).
|
||||
|
||||
b_delete( X, [X|L], L).
|
||||
b_delete( Y, [X|Xs], [X|Xt]) :-
|
||||
b_delete( Y, Xs, Xt).
|
||||
|
||||
labeling, card(A,B,L,N)#Pc <=>
|
||||
label_card(A,B,L,N),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_card(A,B,[],0):- A=<0,0=<B.
|
||||
label_card(A,B,[0|L],N):-
|
||||
%N1 is N-1,
|
||||
card(A,B,L).
|
||||
label_card(A,B,[1|L],N):-
|
||||
A1 is A-1, B1 is B-1, %N1 is N-1,
|
||||
card(A1,B1,L).
|
||||
|
||||
set_to_ones([]).
|
||||
set_to_ones([1|L]):-
|
||||
set_to_ones(L).
|
||||
|
||||
set_to_zeros([]).
|
||||
set_to_zeros([0|L]):-
|
||||
set_to_zeros(L).
|
||||
|
||||
|
||||
|
||||
%% Auxiliary predicates
|
||||
|
||||
:- op(100,xfy,#).
|
||||
|
||||
solve_bool(A,C) :- var(A), !, A=C.
|
||||
solve_bool(A,C) :- atomic(A), !, A=C.
|
||||
solve_bool(A * B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
and(A1,B1,C).
|
||||
solve_bool(A + B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
or(A1,B1,C).
|
||||
solve_bool(A # B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
xor(A1,B1,C).
|
||||
solve_bool(not(A),C) :- !,
|
||||
solve_bool(A,A1),
|
||||
neg(A1,C).
|
||||
solve_bool((A -> B), C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
imp(A1,B1),C=1.
|
||||
solve_bool(A = B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
A1=B1,C=1.
|
||||
|
||||
%% Labeling
|
||||
label_bool([]).
|
||||
label_bool([X|L]) :-
|
||||
( X=0;X=1),
|
||||
label_bool(L).
|
||||
|
||||
/* % no write macros in SICStus and hProlog
|
||||
|
||||
bool_portray(and(A,B,C),Out):- !, Out = (A*B = C).
|
||||
bool_portray(or(A,B,C),Out):- !, Out = (A+B = C).
|
||||
bool_portray(xor(A,B,C),Out):- !, Out = (A#B = C).
|
||||
bool_portray(neg(A,B),Out):- !, Out = (A= not(B)).
|
||||
bool_portray(imp(A,B),Out):- !, Out = (A -> B).
|
||||
bool_portray(card(A,B,L,N),Out):- !, Out = card(A,B,L).
|
||||
|
||||
:- define_macro(type(compound),bool_portray/2,[write]).
|
||||
*/
|
||||
|
||||
/* end of handler bool */
|
||||
|
||||
half_adder(X,Y,S,C) :-
|
||||
xor(X,Y,S),
|
||||
and(X,Y,C).
|
||||
|
||||
full_adder(X,Y,Ci,S,Co) :-
|
||||
half_adder(X,Y,S1,Co1),
|
||||
half_adder(Ci,S1,S,Co2),
|
||||
or(Co1,Co2,Co).
|
||||
|
||||
main :-
|
||||
main(60000).
|
||||
|
||||
main(N) :-
|
||||
cputime(X),
|
||||
adder(N),
|
||||
cputime(Now),
|
||||
Time is Now - X,
|
||||
write(bench(bool, N, Time, 0, hprolog)),write('.'),nl.
|
||||
|
||||
adder(N) :-
|
||||
length(Ys,N),
|
||||
add(N,Ys).
|
||||
|
||||
add(N,[Y|Ys]) :-
|
||||
half_adder(1,Y,0,C),
|
||||
add0(Ys,C).
|
||||
|
||||
add0([],1).
|
||||
add0([Y|Ys],C) :-
|
||||
full_adder(0,Y,C,1,NC),
|
||||
add1(Ys,NC).
|
||||
|
||||
add1([],0).
|
||||
add1([Y|Ys],C) :-
|
||||
full_adder(1,Y,C,0,NC),
|
||||
add0(Ys,NC).
|
||||
|
||||
%cputime(Time) :-
|
||||
% statistics(runtime, [_,Time]).
|
|
@ -0,0 +1,34 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 991202 Slim Abdennadher, LMU
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(fib,[main/0,main/1]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint fib/2.
|
||||
|
||||
%% fib(N,M) is true if M is the Nth Fibonacci number.
|
||||
|
||||
%% Top-down Evaluation with Tabulation
|
||||
|
||||
fib(N,M1), fib(N,M2) <=> M1 = M2, fib(N,M1).
|
||||
|
||||
fib(0,M) ==> M = 1.
|
||||
|
||||
fib(1,M) ==> M = 1.
|
||||
|
||||
fib(N,M) ==> N > 1 | N1 is N-1, fib(N1,M1), N2 is N-2, fib(N2,M2), M is M1 + M2.
|
||||
|
||||
main :-
|
||||
main(22).
|
||||
|
||||
main(N):-
|
||||
cputime(X),
|
||||
fib(N,_),
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(bench(fib ,N,Time, 0, hprolog)),write('.'), nl.
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven
|
||||
%%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(fibonacci,[main/0,main/1]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint fibonacci/2.
|
||||
|
||||
%% fibonacci(N,M) is true iff M is the Nth Fibonacci number.
|
||||
|
||||
%% Top-down Evaluation with effective Tabulation
|
||||
%% Contrary to the version in the SICStus manual, this one does "true"
|
||||
%% tabulation
|
||||
|
||||
fibonacci(N,M1) # ID \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(ID).
|
||||
|
||||
fibonacci(0,M) ==> M = 1.
|
||||
|
||||
fibonacci(1,M) ==> M = 1.
|
||||
|
||||
fibonacci(N,M) ==>
|
||||
N > 1 |
|
||||
N1 is N-1,
|
||||
fibonacci(N1,M1),
|
||||
N2 is N-2,
|
||||
fibonacci(N2,M2),
|
||||
M is M1 + M2.
|
||||
|
||||
main :-
|
||||
main(2000).
|
||||
|
||||
main(N):-
|
||||
cputime(X),
|
||||
fibonacci(N,_),
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(bench(fibonacci ,N,Time, 0, hprolog)),write('.'), nl.
|
||||
|
|
@ -0,0 +1,139 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Thom Fruehwirth ECRC 1991-1993
|
||||
%% 910528 started boolean,and,or constraints
|
||||
%% 910904 added xor,neg constraints
|
||||
%% 911120 added imp constraint
|
||||
%% 931110 ported to new release
|
||||
%% 931111 added card constraint
|
||||
%% 961107 Christian Holzbaur, SICStus mods
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers June 2003
|
||||
|
||||
|
||||
:- module(fulladder,[main/0,main/1]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint and/3, or/3, xor/3, neg/2.
|
||||
|
||||
:- use_module(library(lists)).
|
||||
|
||||
%% and/3 specification
|
||||
%%and(0,0,0).
|
||||
%%and(0,1,0).
|
||||
%%and(1,0,0).
|
||||
%%and(1,1,1).
|
||||
|
||||
and(0,X,Y) <=> Y=0.
|
||||
and(X,0,Y) <=> Y=0.
|
||||
and(1,X,Y) <=> Y=X.
|
||||
and(X,1,Y) <=> Y=X.
|
||||
and(X,Y,1) <=> X=1,Y=1.
|
||||
and(X,X,Z) <=> X=Z.
|
||||
and(X,Y,A) \ and(X,Y,B) <=> A=B, chr_dummy.
|
||||
and(X,Y,A) \ and(Y,X,B) <=> A=B, chr_dummy.
|
||||
|
||||
%% or/3 specification
|
||||
%%or(0,0,0).
|
||||
%%or(0,1,1).
|
||||
%%or(1,0,1).
|
||||
%%or(1,1,1).
|
||||
|
||||
or(0,X,Y) <=> Y=X.
|
||||
or(X,0,Y) <=> Y=X.
|
||||
or(X,Y,0) <=> X=0,Y=0.
|
||||
or(1,X,Y) <=> Y=1.
|
||||
or(X,1,Y) <=> Y=1.
|
||||
or(X,X,Z) <=> X=Z.
|
||||
or(X,Y,A) \ or(X,Y,B) <=> A=B, chr_dummy.
|
||||
or(X,Y,A) \ or(Y,X,B) <=> A=B, chr_dummy.
|
||||
|
||||
%% xor/3 specification
|
||||
%%xor(0,0,0).
|
||||
%%xor(0,1,1).
|
||||
%%xor(1,0,1).
|
||||
%%xor(1,1,0).
|
||||
|
||||
xor(0,X,Y) <=> X=Y.
|
||||
xor(X,0,Y) <=> X=Y.
|
||||
xor(X,Y,0) <=> X=Y.
|
||||
xor(1,X,Y) <=> neg(X,Y).
|
||||
xor(X,1,Y) <=> neg(X,Y).
|
||||
xor(X,Y,1) <=> neg(X,Y).
|
||||
xor(X,X,Y) <=> Y=0.
|
||||
xor(X,Y,X) <=> Y=0.
|
||||
xor(Y,X,X) <=> Y=0.
|
||||
xor(X,Y,A) \ xor(X,Y,B) <=> A=B, chr_dummy.
|
||||
xor(X,Y,A) \ xor(Y,X,B) <=> A=B, chr_dummy.
|
||||
|
||||
%% neg/2 specification
|
||||
%%neg(0,1).
|
||||
%%neg(1,0).
|
||||
|
||||
neg(0,X) <=> X=1.
|
||||
neg(X,0) <=> X=1.
|
||||
neg(1,X) <=> X=0.
|
||||
neg(X,1) <=> X=0.
|
||||
neg(X,X) <=> fail.
|
||||
neg(X,Y) \ neg(Y,Z) <=> X=Z, chr_dummy.
|
||||
neg(X,Y) \ neg(Z,Y) <=> X=Z, chr_dummy.
|
||||
neg(Y,X) \ neg(Y,Z) <=> X=Z, chr_dummy.
|
||||
%% Interaction with other boolean constraints
|
||||
neg(X,Y) \ and(X,Y,Z) <=> Z=0, chr_dummy.
|
||||
neg(Y,X) \ and(X,Y,Z) <=> Z=0, chr_dummy.
|
||||
neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(X,Y) \ or(X,Y,Z) <=> Z=1, chr_dummy.
|
||||
neg(Y,X) \ or(X,Y,Z) <=> Z=1, chr_dummy.
|
||||
neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(X,Y) \ xor(X,Y,Z) <=> Z=1, chr_dummy.
|
||||
neg(Y,X) \ xor(X,Y,Z) <=> Z=1, chr_dummy.
|
||||
neg(X,Z) \ xor(X,Y,Z) <=> Y=1, chr_dummy.
|
||||
neg(Z,X) \ xor(X,Y,Z) <=> Y=1, chr_dummy.
|
||||
neg(Y,Z) \ xor(X,Y,Z) <=> X=1, chr_dummy.
|
||||
neg(Z,Y) \ xor(X,Y,Z) <=> X=1, chr_dummy.
|
||||
|
||||
/* end of handler bool */
|
||||
|
||||
half_adder(X,Y,S,C) :-
|
||||
xor(X,Y,S),
|
||||
and(X,Y,C).
|
||||
|
||||
full_adder(X,Y,Ci,S,Co) :-
|
||||
half_adder(X,Y,S1,Co1),
|
||||
half_adder(Ci,S1,S,Co2),
|
||||
or(Co1,Co2,Co).
|
||||
|
||||
main :-
|
||||
main(6000).
|
||||
|
||||
main(N) :-
|
||||
cputime(X),
|
||||
adder(N),
|
||||
cputime(Now),
|
||||
Time is Now - X,
|
||||
write(bench(bool ,N,Time,0,hprolog)),write('.'),nl.
|
||||
|
||||
adder(N) :-
|
||||
length(Ys,N),
|
||||
add(N,Ys).
|
||||
|
||||
add(N,[Y|Ys]) :-
|
||||
half_adder(1,Y,0,C),
|
||||
add0(Ys,C).
|
||||
|
||||
add0([],1).
|
||||
add0([Y|Ys],C) :-
|
||||
full_adder(0,Y,C,1,NC),
|
||||
add1(Ys,NC).
|
||||
|
||||
add1([],0).
|
||||
add1([Y|Ys],C) :-
|
||||
full_adder(1,Y,C,0,NC),
|
||||
add0(Ys,NC).
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% simple constraint solver for inequalities between variables
|
||||
%% thom fruehwirth ECRC 950519, LMU 980207, 980311
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(leq,[main/0,main/1]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint leq/2.
|
||||
|
||||
reflexivity @ leq(X,X) <=> true.
|
||||
antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y.
|
||||
idempotence @ leq(X,Y) \ leq(X,Y) <=> true.
|
||||
transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z).
|
||||
|
||||
main :-
|
||||
main(60).
|
||||
|
||||
main(N):-
|
||||
cputime(X),
|
||||
length(L,N),
|
||||
genleq(L,Last),
|
||||
L=[First|_],
|
||||
leq(Last,First),
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(bench(leq ,N,Time,0,hprolog)), write('.'),nl.
|
||||
|
||||
genleq([Last],Last) :- ! .
|
||||
genleq([X,Y|Xs],Last):-
|
||||
leq(X,Y),
|
||||
genleq([Y|Xs],Last).
|
|
@ -0,0 +1,29 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Sieve of eratosthenes to compute primes
|
||||
%% thom fruehwirth 920218-20, 980311
|
||||
%% christian holzbaur 980207 for Sicstus CHR
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(primes,[main/0,main/1]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint candidate/1.
|
||||
:- chr_constraint prime/1.
|
||||
|
||||
candidate(1) <=> true.
|
||||
candidate(N) <=> primes:prime(N), N1 is N - 1, primes:candidate(N1).
|
||||
|
||||
absorb @ prime(Y) \ prime(X) <=> 0 =:= X mod Y | true.
|
||||
|
||||
main :-
|
||||
main(2500).
|
||||
|
||||
main(N):-
|
||||
cputime(X),
|
||||
candidate(N),
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(bench(primes ,N,Time,0,hprolog)), write('.'),nl.
|
||||
|
|
@ -0,0 +1,381 @@
|
|||
:- module(ta,[main/0,main/1]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
/*
|
||||
|
||||
Timed automaton => Constraints
|
||||
|
||||
=>
|
||||
|
||||
X := N geq(X,N)
|
||||
-------->
|
||||
|
||||
X =< N leq(X,N)
|
||||
-------->
|
||||
|
||||
X >= N geq(X,N)
|
||||
-------->
|
||||
|
||||
|
||||
n > 1, 1 ------> v fincl(Xv,X1),
|
||||
... / ...
|
||||
n ----/ fincl(Xv,Xn),
|
||||
fub_init(Xv,[])
|
||||
|
||||
n >= 1, v ------> 1 bincl(Xv,X1),
|
||||
\ ... ...
|
||||
\----> n bincl(Xv,X1),
|
||||
bub_init(Xv,[])
|
||||
*/
|
||||
|
||||
%% handler ta.
|
||||
|
||||
:- chr_constraint
|
||||
|
||||
fincl/2, % expresses that clock 1 includes clock 2 (union)
|
||||
% in the sense that clock 2 is forward of clock 1
|
||||
|
||||
bincl/2, % expresses that clock 1 includes clock 2 (union)
|
||||
% in the sense that clock 1 is forward of clock 2
|
||||
|
||||
leq/2, % expresses that clock 1 =< number 2
|
||||
|
||||
geq/2, % expresses that clock 1 >= number 2
|
||||
|
||||
fub_init/2, % collects the inital upper bounds
|
||||
% from incoming arrows for clock 1 in list 2
|
||||
|
||||
fub/2, % collects the upper bounds for clock 1
|
||||
% from incoming arrows in list 2
|
||||
|
||||
flb_init/2, % collects the inital lower bounds
|
||||
% from incoming arrows for clock 1 in list 2
|
||||
|
||||
flb/2, % collects the lower bounds for clock 1
|
||||
% from incoming arrows in list 2
|
||||
|
||||
bub_init/2, % collects the inital upper bounds
|
||||
% from backward arrows for clock 1 in list 2
|
||||
|
||||
bub/2, % collects the upper bounds for clock 1
|
||||
% from outgoing arrows in list 2
|
||||
% values of clock 1 cannot exceed all
|
||||
% values of the clocks in list 2
|
||||
|
||||
blb_init/2, % collects the inital lower bounds
|
||||
% from backward arrows for clock 1 in list 2
|
||||
|
||||
blb/2, % collects the lower bounds for clock 1
|
||||
% from outgoing arrows in list 2
|
||||
% not all values of clock 1 can exceed any
|
||||
% values of the clocks in list 2
|
||||
|
||||
compl/1, % indicate that all incoming arrows for clock 1
|
||||
% have been registerd
|
||||
|
||||
dist/3, % indicates that clock 1 - clock 2 =< number 3
|
||||
|
||||
fdist_init/3, % records initial distances for clock 1 and clock 2 from
|
||||
% incoming arrows in list 3
|
||||
|
||||
fdist/3, % records distances for clock 1 and clock 2 from
|
||||
% incoming arrows in list 3
|
||||
|
||||
setdist/3. % sets distance between clock 1 and clock 2, where
|
||||
% clock 1 is reset to value 3
|
||||
|
||||
/* More Constraints:
|
||||
|
||||
*/
|
||||
|
||||
leq(X,N1) \ leq(X,N2) <=> N1 =< N2 | true.
|
||||
|
||||
geq(X,N1) \ geq(X,N2) <=> N2 =< N1 | true.
|
||||
|
||||
dist(X,Y,D1) \ dist(X,Y,D2) <=> D1 =< D2 | true.
|
||||
|
||||
dist(X,Y,D), leq(Y,MY) \ leq(X,MX1) <=>
|
||||
MX2 is MY + D, MX2 < MX1 | leq(X,MX2).
|
||||
|
||||
dist(X,Y,D), geq(X,MX) \ geq(Y,MY1) <=>
|
||||
MY2 is MX - D, MY2 > MY1 | geq(Y,MY2).
|
||||
|
||||
fincl(X,Y), leq(Y,N) \ fub_init(X,L)
|
||||
<=> \+ memberchk_eq(N-Y,L) |
|
||||
insert_ub(L,Y,N,NL),
|
||||
fub_init(X,NL).
|
||||
|
||||
fincl(X,Y), geq(Y,N) \ flb_init(X,L)
|
||||
<=> \+ memberchk_eq(N-Y,L) |
|
||||
insert_lb(L,Y,N,NL),
|
||||
flb_init(X,NL).
|
||||
|
||||
dist(X1,Y1,D), fincl(X2,X1), fincl(Y2,Y1) \ fdist_init(X2,Y2,L)
|
||||
<=>
|
||||
\+ memberchk_eq(D-X1,L) |
|
||||
insert_ub(L,X1,D,NL),
|
||||
fdist_init(X2,Y2,NL).
|
||||
|
||||
bincl(X,Y), leq(Y,N) \ bub_init(X,L)
|
||||
<=>
|
||||
\+ memberchk_eq(N-Y,L) |
|
||||
insert_ub(L,Y,N,NL),
|
||||
bub_init(X,NL).
|
||||
|
||||
compl(X) \ fub_init(X,L) # ID
|
||||
<=>
|
||||
fub(X,L),
|
||||
val(L,M),
|
||||
leq(X,M)
|
||||
pragma passive(ID).
|
||||
|
||||
compl(X) \ flb_init(X,L) # ID
|
||||
<=>
|
||||
flb(X,L),
|
||||
val(L,M),
|
||||
geq(X,M)
|
||||
pragma passive(ID).
|
||||
|
||||
compl(X), compl(Y) \ fdist_init(X,Y,L) # ID
|
||||
<=>
|
||||
fdist(X,Y,L),
|
||||
val(L,D),
|
||||
dist(X,Y,D)
|
||||
pragma passive(D).
|
||||
|
||||
compl(X) \ bub_init(X,L) # ID
|
||||
<=>
|
||||
bub(X,L),
|
||||
val(L,M),
|
||||
leq(X,M)
|
||||
pragma passive(ID).
|
||||
|
||||
fincl(X,Y), leq(Y,N) \ fub(X,L)
|
||||
<=>
|
||||
\+ memberchk_eq(N-Y,L) |
|
||||
insert_ub(L,Y,N,NL),
|
||||
fub(X,NL),
|
||||
val(NL,M),
|
||||
leq(X,M).
|
||||
|
||||
fincl(X,Y), geq(Y,N) \ flb(X,L)
|
||||
<=>
|
||||
\+ memberchk_eq(N-Y,L) |
|
||||
insert_lb(L,Y,N,NL),
|
||||
flb(X,NL),
|
||||
val(NL,M),
|
||||
geq(X,M).
|
||||
|
||||
bincl(X,Y), leq(Y,N) \ bub(X,L)
|
||||
<=>
|
||||
\+ memberchk_eq(N-Y,L) |
|
||||
insert_ub(L,Y,N,NL),
|
||||
bub(X,NL),
|
||||
val(NL,M),
|
||||
leq(X,M).
|
||||
|
||||
fincl(X2,X1), fincl(Y2,Y1), dist(X1,Y1,D) \ fdist(X2,Y2,L)
|
||||
<=>
|
||||
\+ memberchk_eq(D-X1,L) |
|
||||
insert_ub(L,X1,D,NL),
|
||||
fdist(X2,Y2,NL),
|
||||
val(NL,MD),
|
||||
dist(X2,Y2,MD).
|
||||
|
||||
fincl(X,Y), leq(X,N) ==> leq(Y,N).
|
||||
|
||||
fincl(X,Y), geq(X,N) ==> geq(Y,N).
|
||||
|
||||
bincl(X,Y), geq(X,N) ==> geq(Y,N).
|
||||
|
||||
bincl(X1,X2), bincl(Y1,Y2), dist(X1,Y1,D1) \ dist(X2,Y2,D2) <=> D1 < D2 | dist(X2,Y2,D1).
|
||||
|
||||
setdist(X,Y,N), leq(Y,D1) ==> D2 is D1 - N, dist(Y,X,D2).
|
||||
setdist(X,Y,N), geq(Y,D1) ==> D2 is N - D1, dist(X,Y,D2).
|
||||
|
||||
val([N-_|_],N).
|
||||
|
||||
insert_ub([],X,N,[N-X]).
|
||||
insert_ub([M-Y|R],X,N,NL) :-
|
||||
( Y == X ->
|
||||
insert_ub(R,X,N,NL)
|
||||
; M > N ->
|
||||
NL = [M-Y|NR],
|
||||
insert_ub(R,X,N,NR)
|
||||
;
|
||||
NL = [N-X,M-Y|R]
|
||||
).
|
||||
|
||||
insert_lb([],X,N,[N-X]).
|
||||
insert_lb([M-Y|R],X,N,NL) :-
|
||||
( Y == X ->
|
||||
insert_lb(R,X,N,NL)
|
||||
; M < N ->
|
||||
NL = [M-Y|NR],
|
||||
insert_lb(R,X,N,NR)
|
||||
;
|
||||
NL = [N-X,M-Y|R]
|
||||
).
|
||||
|
||||
couple(X,Y) :-
|
||||
dist(X,Y,10000),
|
||||
dist(Y,X,10000).
|
||||
|
||||
giri :-
|
||||
giri([x1,y1,x2,y2,x3,y3,x4,y4,x5,y5,x6,y6,x7,y7,x8,y8,x9,y9,x10,y10]).
|
||||
|
||||
giri(L) :-
|
||||
L = [X1,Y1,X2,Y2,X3,Y3,X4,Y4,X5,Y5,X6,Y6,X7,Y7,X8,Y8,X9,Y9,X10,Y10],
|
||||
clocks(L),
|
||||
|
||||
% 1.
|
||||
couple(X1,Y1),
|
||||
geq(X1,0),
|
||||
geq(X2,0),
|
||||
dist(X1,Y1,0),
|
||||
dist(Y1,X1,0),
|
||||
|
||||
% 2.
|
||||
couple(X2,Y2),
|
||||
|
||||
fincl(X2,X1),
|
||||
fincl(X2,X8),
|
||||
fincl(X2,X10),
|
||||
fub_init(X2,[]),
|
||||
flb_init(X2,[]),
|
||||
|
||||
fincl(Y2,Y1),
|
||||
fincl(Y2,Y8),
|
||||
fincl(Y2,Y10),
|
||||
fub_init(Y2,[]),
|
||||
flb_init(Y2,[]),
|
||||
|
||||
bincl(X2,X3),
|
||||
bincl(X2,X4),
|
||||
bub_init(X2,[]),
|
||||
blb_init(X2,[]),
|
||||
|
||||
bincl(Y2,Y3),
|
||||
bincl(Y2,Y4),
|
||||
bub_init(Y2,[]),
|
||||
blb_init(Y2,[]),
|
||||
|
||||
fdist_init(X2,Y2,[]),
|
||||
fdist_init(Y2,X2,[]),
|
||||
|
||||
% 3.
|
||||
couple(X3,Y3),
|
||||
leq(X3,3),
|
||||
|
||||
bincl(X3,X9),
|
||||
bincl(X3,X5),
|
||||
bub_init(X3,[]),
|
||||
blb_init(X3,[]),
|
||||
|
||||
bincl(Y3,Y9),
|
||||
bincl(Y3,Y5),
|
||||
bub_init(Y3,[]),
|
||||
blb_init(Y3,[]),
|
||||
|
||||
%fdist_init(X3,Y3,[]),
|
||||
%fdist_init(Y3,X3,[]),
|
||||
|
||||
% 4.
|
||||
couple(X4,Y4),
|
||||
geq(Y4,2),
|
||||
leq(Y4,5),
|
||||
|
||||
% 5.
|
||||
couple(X5,Y5),
|
||||
geq(Y5,5),
|
||||
leq(Y5,10),
|
||||
|
||||
% 6.
|
||||
couple(X6,Y6),
|
||||
|
||||
fincl(X6,X4),
|
||||
fincl(X6,X5),
|
||||
fub_init(X6,[]),
|
||||
flb_init(X6,[]),
|
||||
|
||||
fincl(Y6,Y4),
|
||||
fincl(Y6,Y5),
|
||||
fub_init(Y6,[]),
|
||||
flb_init(Y6,[]),
|
||||
|
||||
bincl(X6,X7),
|
||||
bub_init(X6,[]),
|
||||
|
||||
bincl(Y6,Y7),
|
||||
bub_init(Y6,[]),
|
||||
|
||||
fdist_init(X6,Y6,[]),
|
||||
fdist_init(Y6,X6,[]),
|
||||
|
||||
% 7.
|
||||
couple(X7,Y7),
|
||||
geq(Y7,15),
|
||||
leq(Y7,15),
|
||||
|
||||
% 8.
|
||||
couple(X8,Y8),
|
||||
geq(X8,2),
|
||||
geq(Y8,2),
|
||||
dist(X8,Y8,0),
|
||||
dist(Y8,X8,0),
|
||||
|
||||
% 9.
|
||||
couple(X9,Y9),
|
||||
geq(Y9,5),
|
||||
leq(Y9,5),
|
||||
|
||||
|
||||
% 10.
|
||||
couple(X10,Y10),
|
||||
geq(X10,0),
|
||||
geq(Y10,0),
|
||||
dist(X10,Y10,0),
|
||||
dist(Y10,X10,0),
|
||||
|
||||
% finish
|
||||
compl(X2),
|
||||
compl(Y2),
|
||||
|
||||
compl(X3),
|
||||
compl(Y3),
|
||||
|
||||
compl(X6),
|
||||
compl(Y6).
|
||||
|
||||
|
||||
|
||||
clocks([]).
|
||||
clocks([C|Cs]) :-
|
||||
clock(C),
|
||||
clocks(Cs).
|
||||
|
||||
clock(X) :-
|
||||
geq(X,0),
|
||||
leq(X,10000).
|
||||
|
||||
main :-
|
||||
main(100).
|
||||
|
||||
main(N) :-
|
||||
cputime(T1),
|
||||
loop(N),
|
||||
cputime(T2),
|
||||
T is T2 - T1,
|
||||
write(bench(ta ,N , T,0,hprolog)),write('.'),nl.
|
||||
|
||||
|
||||
loop(N) :-
|
||||
( N =< 0 ->
|
||||
true
|
||||
;
|
||||
( giri, fail ; true),
|
||||
M is N - 1,
|
||||
loop(M)
|
||||
).
|
|
@ -0,0 +1,262 @@
|
|||
:- module(wfs,[main/0, main/1]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
% Schrijf het programma waarvan je de wellfounded semantics wil bepalen
|
||||
% hieronder onder de vorm van prog/1 feiten. Let erop dat je een conjunctie
|
||||
% in de body tussen haakjes zet zodat prog/1 geparsed wordt, ipv prog/n.
|
||||
|
||||
/*
|
||||
|
||||
prog(p :- p).
|
||||
|
||||
prog(p :- \+ p).
|
||||
|
||||
|
||||
prog(p :- (q, \+ r)).
|
||||
prog(q :- (r, \+ p)).
|
||||
prog(r :- (p, \+ q)).
|
||||
|
||||
prog(p :- r).
|
||||
prog(r :- q).
|
||||
prog(q :- \+ q).
|
||||
|
||||
prog(p :- r).
|
||||
prog(r).
|
||||
|
||||
prog(p :- p).
|
||||
prog(s :- \+ p).
|
||||
prog(y :- (s, \+ x)).
|
||||
prog(x :- y).
|
||||
*/
|
||||
prog(a :- a).
|
||||
prog(b :- b).
|
||||
prog(b :- \+ a).
|
||||
prog(c :- \+ b).
|
||||
prog(c :- c).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
|
||||
:- chr_constraint true/1, false/1, undefined/1, aclause/2, pos/2, neg/2, nbulit/2, nbplit/2, nbucl/2, phase2/0, true2/1, undefined2/1, aclause2/2, pos2/2, nbplit2/2, phase1/0, witness1/0, witness2/0.
|
||||
|
||||
true(At), aclause(Cl,At) \ pos(_,Cl) <=> true.
|
||||
|
||||
true(At), aclause(Cl,At) \ neg(_,Cl) <=> true.
|
||||
|
||||
false(At), aclause(Cl,At) \ pos(_,Cl) <=> true.
|
||||
|
||||
false(At), aclause(Cl,At) \ neg(_,Cl) <=> true.
|
||||
|
||||
true(At) \ nbucl(At,_) <=> true.
|
||||
|
||||
true(At) \ aclause(Cl,At), nbulit(Cl,_), nbplit(Cl,_) <=> true.
|
||||
|
||||
false(At) \ nbucl(At,_) <=> true.
|
||||
|
||||
nbucl(At,0) <=> false(At).
|
||||
|
||||
aclause(Cl,At), nbulit(Cl,0), nbplit(Cl,0) <=> true(At).
|
||||
|
||||
true(At) \ pos(At,Cl), nbulit(Cl,NU), nbplit(Cl,NP)
|
||||
<=>
|
||||
NU1 is NU - 1, nbulit(Cl,NU1),
|
||||
NP1 is NP - 1, nbplit(Cl,NP1).
|
||||
|
||||
false(At) \ neg(At,Cl), nbulit(Cl,NU)
|
||||
<=>
|
||||
NU1 is NU - 1, nbulit(Cl,NU1).
|
||||
|
||||
true(At) \ neg(At,Cl), aclause(Cl,OAt), nbulit(Cl,_), nbplit(Cl,_), nbucl(OAt,N)
|
||||
<=>
|
||||
N1 is N - 1, nbucl(OAt,N1).
|
||||
|
||||
false(At) \ pos(At,Cl), aclause(Cl,OAt), nbulit(Cl,_), nbplit(Cl,_), nbucl(OAt,N)
|
||||
<=>
|
||||
N1 is N - 1, nbucl(OAt,N1).
|
||||
|
||||
witness2 \ witness2 <=> true.
|
||||
phase2, nbucl(At,_) ==> witness2, undefined2(At).
|
||||
phase2, pos(At,Cl) ==> pos2(At,Cl).
|
||||
phase2, aclause(Cl,At) ==> aclause2(Cl,At).
|
||||
phase2, nbplit(Cl,N) ==> nbplit2(Cl,N).
|
||||
phase2, witness2 # ID <=> phase1 pragma passive(ID).
|
||||
phase2 \ nbplit2(_,_) # ID <=> true pragma passive(ID).
|
||||
phase2 \ aclause2(_,_) # ID <=> true pragma passive(ID).
|
||||
phase2 <=> true.
|
||||
|
||||
|
||||
true2(At), aclause2(Cl,At) \ pos2(_,Cl) <=> true.
|
||||
true2(At) \ undefined2(At) <=> true.
|
||||
aclause2(Cl,At), nbplit2(Cl,0) <=> true2(At).
|
||||
true2(At) \ pos2(At,Cl), nbplit2(Cl,NP)
|
||||
<=>
|
||||
NP1 is NP - 1, nbplit2(Cl,NP1).
|
||||
|
||||
witness1 \ witness1 <=> true.
|
||||
phase1, undefined2(At) # ID1 , aclause(Cl,At) # ID2 \ pos(_,Cl) # ID3 <=> true pragma passive(ID1), passive(ID2), passive(ID3).
|
||||
phase1, undefined2(At) # ID1 , aclause(Cl,At) # ID2 \ neg(_,Cl) # ID3 <=> true pragma passive(ID1), passive(ID2), passive(ID3).
|
||||
phase1, undefined2(At) # ID1 \ aclause(Cl,At) # ID2 , nbulit(Cl,_) # ID3, nbplit(Cl,_) # ID4 <=> true pragma passive(ID1), passive(ID2), passive(ID3), passive(ID4).
|
||||
phase1 \ undefined2(At) # ID <=> witness1, false(At) pragma passive(ID).
|
||||
phase1 \ true2(_) # ID <=> true pragma passive(ID).
|
||||
phase1 \ aclause2(_,_) <=> true.
|
||||
phase1 \ pos2(_,_) # ID <=> true pragma passive(ID).
|
||||
phase1 \ nbplit2(_,_) # ID <=> true pragma passive(ID).
|
||||
phase1, witness1 # ID <=> phase2 pragma passive(ID).
|
||||
phase1 \ nbucl(At,_) # ID <=> undefined(At) pragma passive(ID).
|
||||
phase1 \ pos(_,_) # ID <=> true.
|
||||
phase1 \ neg(_,_) # ID <=> true pragma passive(ID).
|
||||
phase1 \ aclause(_,_) # ID <=> true pragma passive(ID).
|
||||
phase1 \ nbulit(_,_) # ID <=> true pragma passive(ID).
|
||||
phase1 \ nbplit(_,_) # ID <=> true pragma passive(ID).
|
||||
phase1 <=> true.
|
||||
|
||||
/*
|
||||
p :- r.
|
||||
r.
|
||||
*/
|
||||
program1 :-
|
||||
nbucl(p,1), % aantal undefined clauses voor p
|
||||
pos(r,cl1), % positief voorkomen van r in clause cl1
|
||||
aclause(cl1,p), % clause cl1 defineert p
|
||||
nbulit(cl1,1), % aantal undefined literals in cl1
|
||||
nbplit(cl1,1), % aantal positieve undefined literals in cl1
|
||||
nbucl(r,1),
|
||||
aclause(cl2,r),
|
||||
nbulit(cl2,0),
|
||||
nbplit(cl2,0).
|
||||
|
||||
/*
|
||||
p :- not r.
|
||||
r.
|
||||
*/
|
||||
program2 :-
|
||||
nbucl(p,1),
|
||||
neg(r,cl1),
|
||||
aclause(cl1,p),
|
||||
nbulit(cl1,1),
|
||||
nbplit(cl1,1),
|
||||
nbucl(r,1),
|
||||
aclause(cl2,r),
|
||||
nbulit(cl2,0),
|
||||
nbplit(cl2,0).
|
||||
|
||||
/*
|
||||
p :- p.
|
||||
*/
|
||||
program3 :-
|
||||
nbucl(p,1),
|
||||
pos(p,cl1),
|
||||
aclause(cl1,p),
|
||||
nbulit(cl1,1),
|
||||
nbplit(cl1,1).
|
||||
|
||||
/*
|
||||
p :- not p.
|
||||
*/
|
||||
program4 :-
|
||||
nbucl(p,1),
|
||||
neg(p,cl1),
|
||||
aclause(cl1,p),
|
||||
nbulit(cl1,1),
|
||||
nbplit(cl1,0).
|
||||
|
||||
/*
|
||||
p :- q, not r.
|
||||
q :- r, not p.
|
||||
r :- p, not q.
|
||||
*/
|
||||
|
||||
program5 :-
|
||||
nbucl(p,1),
|
||||
pos(p,cl3),
|
||||
neg(p,cl2),
|
||||
aclause(cl1,p),
|
||||
nbulit(cl1,2),
|
||||
nbplit(cl1,1),
|
||||
nbucl(q,1),
|
||||
pos(q,cl1),
|
||||
neg(q,cl3),
|
||||
aclause(cl2,q),
|
||||
nbulit(cl2,2),
|
||||
nbplit(cl2,1),
|
||||
nbucl(r,1),
|
||||
pos(r,cl2),
|
||||
neg(r,cl1),
|
||||
aclause(cl3,r),
|
||||
nbulit(cl3,2),
|
||||
nbplit(cl3,1).
|
||||
|
||||
|
||||
main :-
|
||||
main(1000).
|
||||
|
||||
main(N) :-
|
||||
cputime(T1),
|
||||
loop(N),
|
||||
cputime(T2),
|
||||
T is T2 - T1,
|
||||
write(bench(wfs ,N , T,0,hprolog)),write('.'),nl.
|
||||
|
||||
loop(N) :-
|
||||
( N =< 0 ->
|
||||
true
|
||||
;
|
||||
( prog, fail ; true),
|
||||
M is N - 1,
|
||||
loop(M)
|
||||
).
|
||||
|
||||
prog :-
|
||||
findall(Clause,wfs:prog(Clause),Clauses),
|
||||
process(Clauses,1),
|
||||
setof(At,B^(wfs:prog(At :- B) ; wfs:prog(At), atom(At)),Ats),
|
||||
process_atoms(Ats),
|
||||
phase2.
|
||||
|
||||
process([],_).
|
||||
process([C|Cs],N) :-
|
||||
( C = (HAt :- B) ->
|
||||
aclause(N,HAt),
|
||||
conj2list(B,Literals,[]),
|
||||
process_literals(Literals,N,NbULit,NbPLit),
|
||||
nbulit(N,NbULit),
|
||||
nbplit(N,NbPLit)
|
||||
;
|
||||
C = HAt,
|
||||
aclause(N,HAt),
|
||||
nbulit(N,0),
|
||||
nbplit(N,0)
|
||||
),
|
||||
N1 is N + 1,
|
||||
process(Cs,N1).
|
||||
|
||||
conj2list(G,L,T) :-
|
||||
( G = (G1,G2) ->
|
||||
conj2list(G1,L,T1),
|
||||
conj2list(G2,T1,T)
|
||||
;
|
||||
L = [G|T]
|
||||
).
|
||||
|
||||
process_literals([],_,0,0).
|
||||
process_literals([L|R],Cl,U,P) :-
|
||||
process_literals(R,Cl,U1,P1),
|
||||
( L = (\+ At) ->
|
||||
neg(At,Cl),
|
||||
P = P1,
|
||||
U is U1 + 1
|
||||
;
|
||||
pos(L,Cl),
|
||||
P is P1 + 1,
|
||||
U is U1 + 1
|
||||
).
|
||||
|
||||
process_atoms([]).
|
||||
process_atoms([A|As]) :-
|
||||
findall(A,wfs:prog(A :- _),L),
|
||||
length(L,N),
|
||||
nbucl(A,N),
|
||||
process_atoms(As).
|
|
@ -0,0 +1,127 @@
|
|||
:- module(zebra,[main/0, main/1]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
/*
|
||||
1. The Englishman lives in the red house.
|
||||
2. The Spaniard owns the dog.
|
||||
3. Coffee is drunk in the green house.
|
||||
4. The Ukrainian drinks tea.
|
||||
5. The green house is immediately to the right of the ivory house.
|
||||
6. The Porsche driver owns snails.
|
||||
7. The Masserati is driven by the man who lives in the yellow house.
|
||||
8. Milk is drunk in the middle house.
|
||||
9. The Norwegian lives in the first house on the left.
|
||||
10. The man who drives a Saab lives in the house next to the man
|
||||
with the fox.
|
||||
11. The Masserati is driven by the man in the house next to the
|
||||
house where the horse is kept.
|
||||
12. The Honda driver drinks orange juice.
|
||||
13. The Japanese drives a Jaguar.
|
||||
14. The Norwegian lives next to the blue house.
|
||||
*/
|
||||
|
||||
:- chr_constraint domain/2, diff/2.
|
||||
|
||||
domain(_,[]) <=> fail.
|
||||
domain(X,[V]) <=> X = V.
|
||||
domain(X,L1), domain(X,L2) <=> intersection(L1,L2,L3), domain(X,L3).
|
||||
|
||||
diff(X,Y), domain(X,L) <=> nonvar(Y) | delete(L,Y,NL), domain(X,NL).
|
||||
diff(X,Y) <=> nonvar(X), nonvar(Y) | X \== Y.
|
||||
|
||||
all_different([]).
|
||||
all_different([H|T]) :-
|
||||
all_different(T,H),
|
||||
all_different(T).
|
||||
|
||||
all_different([],_).
|
||||
all_different([H|T],E) :-
|
||||
diff(H,E),
|
||||
diff(E,H),
|
||||
all_different(T,E).
|
||||
|
||||
main :-
|
||||
main(10).
|
||||
|
||||
main(N):-
|
||||
statistics(cputime, X),
|
||||
test(N),
|
||||
statistics(cputime, Now),
|
||||
Time is Now-X,
|
||||
write(bench(zebra, N,Time,0,hprolog)), write('.'),nl.
|
||||
|
||||
test(N) :-
|
||||
( N > 0 ->
|
||||
solve,!,
|
||||
M is N - 1,
|
||||
test(M)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
solve :-
|
||||
[ [ ACo, AN, ACa, AD, AP ],
|
||||
[ BCo, BN, BCa, BD, BP ],
|
||||
[ CCo, CN, CCa, CD, CP ],
|
||||
[ DCo, DN, DCa, DD, DP ],
|
||||
[ ECo, EN, ECa, ED, EP ] ] = S,
|
||||
domain(ACo,[red,green,ivory,yellow,blue]),
|
||||
domain(BCo,[red,green,ivory,yellow,blue]),
|
||||
domain(CCo,[red,green,ivory,yellow,blue]),
|
||||
domain(DCo,[red,green,ivory,yellow,blue]),
|
||||
domain(ECo,[red,green,ivory,yellow,blue]),
|
||||
domain(AN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(BN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(CN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(DN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(EN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(ACa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(BCa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(CCa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(DCa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(ECa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(AD ,[coffee,tea,milk,orange,water]),
|
||||
domain(BD ,[coffee,tea,milk,orange,water]),
|
||||
domain(CD ,[coffee,tea,milk,orange,water]),
|
||||
domain(DD ,[coffee,tea,milk,orange,water]),
|
||||
domain(ED ,[coffee,tea,milk,orange,water]),
|
||||
domain(AP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(BP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(CP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(DP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(EP ,[dog,snails,fox,horse,zebra]),
|
||||
all_different([ACo,BCo,CCo,DCo,ECo]),
|
||||
all_different([AN ,BN ,CN ,DN ,EN ]),
|
||||
all_different([ACa,BCa,CCa,DCa,ECa]),
|
||||
all_different([AD ,BD ,CD ,DD ,ED ]),
|
||||
all_different([AP ,BP ,CP ,DP ,EP ]),
|
||||
[_,_,[_,_,_,milk,_],_,_] = S, % clue 8
|
||||
[[_,norwegian,_,_,_],_,_,_,_] = S , % clue 9
|
||||
member( [green,_,_,coffee,_], S), % clue 3
|
||||
member( [red,english,_,_,_], S), % clue 1
|
||||
member( [_,ukranian,_,tea,_], S), % clue 4
|
||||
member( [yellow,_,masserati,_,_], S), % clue 7
|
||||
member( [_,_,honda,orange,_], S), % clue 12
|
||||
member( [_,japanese,jaguar,_,_], S), % clue 13
|
||||
member( [_,spanish,_,_,dog], S), % clue 2
|
||||
member( [_,_,porsche,_,snails], S), % clue 6
|
||||
left_right( [ivory,_,_,_,_], [green,_,_,_,_], S), % clue 5
|
||||
next_to( [_,norwegian,_,_,_],[blue,_,_,_,_], S), % clue 14
|
||||
next_to( [_,_,masserati,_,_],[_,_,_,_,horse], S), % clue 11
|
||||
next_to( [_,_,saab,_,_], [_,_,_,_,fox], S), % clue 10
|
||||
true.
|
||||
|
||||
% left_right(L, R, X) is true when L is to the immediate left of R in list X
|
||||
|
||||
left_right(L, R, [L, R | _]).
|
||||
|
||||
left_right(L, R, [_ | X]) :- left_right(L, R, X).
|
||||
|
||||
|
||||
% next_to(X, Y, L) is true when X and Y are next to each other in list L
|
||||
|
||||
next_to(X, Y, L) :- left_right(X, Y, L).
|
||||
|
||||
next_to(X, Y, L) :- left_right(Y, X, L).
|
|
@ -0,0 +1,861 @@
|
|||
[Aug 12 2009]
|
||||
|
||||
* CHR: no debugging instrumentation for optimized code
|
||||
|
||||
[Jun 27 2008]
|
||||
|
||||
* CHR: ADDED error value for check_guard_bindings option:
|
||||
throw error on guard binding
|
||||
|
||||
* CHR: ADDED error value for check_guard_bindings option:
|
||||
throw error on guard binding
|
||||
|
||||
[May 22 2008]
|
||||
|
||||
* CHR: experimental detach code size reduction (bug fix)
|
||||
|
||||
[May 21 2008]
|
||||
|
||||
* CHR: reduce code size of attach and detach predicates (experimental)
|
||||
|
||||
[May 20 2008]
|
||||
|
||||
* CHR: chr_enum/1 (bug fix) and chr_enum/2 (with handler)
|
||||
|
||||
[May 18 2008]
|
||||
|
||||
* CHR: reinstate chr_enum/1
|
||||
|
||||
[May 14 2008]
|
||||
|
||||
* CHR: suppress printing of put_attr/3 at toplevel
|
||||
|
||||
[Apr 18 2008]
|
||||
|
||||
* MODIFIED: Renamed hash_term/2 to term_hash/2. Added hash_term/2 to
|
||||
library(backcomp), so most code should not notice this.
|
||||
|
||||
[Feb 27 2008]
|
||||
|
||||
* ENHANCED: CHR performance of find_chr_constraint when called with nonvar argument
|
||||
|
||||
[Feb 14 2008]
|
||||
|
||||
* ENHANCED: CHR performance (minor issues)
|
||||
|
||||
[Feb 13 2008]
|
||||
|
||||
* FIX: CHR new C file for Windows
|
||||
|
||||
* FIX: CHR: single chr_support.c C file
|
||||
|
||||
[Feb 12 2008]
|
||||
|
||||
* ENHANCED: CHR: moved performance critical predicates to C
|
||||
|
||||
[Feb 11 2008]
|
||||
|
||||
* ENHANCED: CHR user-provided background knowledge (Jon Sneyers)
|
||||
|
||||
[Feb 10 2008]
|
||||
|
||||
* ENHANCED: CHR compiler performance
|
||||
|
||||
* ENHANCED: CHR compiler performance
|
||||
|
||||
[Jan 29 2008]
|
||||
|
||||
* EHANCED: CHR performance: compacted indexing code
|
||||
|
||||
[Jan 28 2008]
|
||||
|
||||
* ADDED: CHR: chr_constants/1 built-in type for enumerated constants
|
||||
|
||||
[Jan 27 2008]
|
||||
|
||||
* ENHANCED: CHR: performance improvements (success continuation, Prolog code optimization)
|
||||
|
||||
* COMPAT: Removed min_list/2 from library(hprolog) as this is now in library lists.
|
||||
|
||||
Jan 24, 2008
|
||||
|
||||
* TS: Exploit success continuation information.
|
||||
|
||||
Jan 23, 2008
|
||||
|
||||
* TS: Bug fix in continuation optimization.
|
||||
* TS: Fixed singleton variable.
|
||||
* TS: Suppress debug message.
|
||||
|
||||
Jan 22, 2008
|
||||
|
||||
* TS: Rewrite Prolog code: common prefix elimination in
|
||||
successive clauses of the same predicate.
|
||||
* TS: Tries stores enabled by default again.
|
||||
* TS: Success and failure continuation optimization for
|
||||
propagation occurrences.
|
||||
|
||||
Jan 14, 2008
|
||||
|
||||
* TS: Fix performance bug in locking of guard variables.
|
||||
* TS: Fix performance bug in spurious hash_term call.
|
||||
|
||||
Jan 10, 2008
|
||||
|
||||
* TS: Type check constraint declarations.
|
||||
* TS: Trie stores hidden behind `experimental' option.
|
||||
* TS: New option `verbose' prints constraint indices.
|
||||
* TS: Don't compute term_hash for int and natural types.
|
||||
|
||||
Jan 9, 2008
|
||||
|
||||
* TS: Avoid trivial warning for declare_stored_constraints.
|
||||
* TS: Bug fix: missing full store was causing compiler to loop.
|
||||
|
||||
Jan 9, 2008
|
||||
|
||||
* TS: Bug fix: atomic_constants store was causing compiler
|
||||
to loop.
|
||||
* TS: Clean-up and avoid adding additional global_ground store
|
||||
if atomic_constants store covers all cases.
|
||||
* TS: Clean-up and bug fix.
|
||||
|
||||
Jan 7, 2008
|
||||
|
||||
* TS: Performance improvement: use new store
|
||||
implementation for multi-argument lookups
|
||||
on manifest ground terms. Should be faster than
|
||||
hashtable.
|
||||
|
||||
Jan 4, 2008
|
||||
|
||||
* TS: Performance improvement: use new store
|
||||
implementation for single-argument lookups
|
||||
on manifest atomics. Should be faster than
|
||||
hashtable. Will be generalized to arbitrary
|
||||
manifest ground lookups and non-manifest
|
||||
atomically typed lookups .
|
||||
|
||||
Jan 3, 2008
|
||||
|
||||
* TS: Modified error messages of declare_stored_constraints
|
||||
option, to distinguish between stored, temporarily stored
|
||||
and never stored.
|
||||
* TS: write/1, writeln/1 and format/2 are now treated as non-binding
|
||||
builtins.
|
||||
* TS: Properly inline inthash constraint lookup.
|
||||
|
||||
Dec 31, 2007
|
||||
|
||||
* TS: Additional assertion # default(Goal) for the
|
||||
declare_stored_constraints, which specifies that
|
||||
an unconditional simplification rule for the constraint
|
||||
must be added to the end of the program. The Goal
|
||||
parameter specifies the goal of that rule, e.g.
|
||||
true or fail or throw(...). Experimental.
|
||||
|
||||
Dec 29, 2007
|
||||
|
||||
* TS: Experimental option declare_stored_constraints for
|
||||
telling the compiler to warn for stored constraints
|
||||
that are not asserted to be stored. Use the
|
||||
:- chr_constraint f(...) # stored.
|
||||
notation for asserting that a constraint is expected to
|
||||
be stored.
|
||||
|
||||
Dec 27, 2007
|
||||
|
||||
* TS: Inline constraint lookup.
|
||||
|
||||
* TS: Precompile term hashing.
|
||||
|
||||
Sep 26, 2007
|
||||
|
||||
* TS: Code cleaning was hampered by line numbers.
|
||||
Reported by Mike Elston.
|
||||
|
||||
May 2, 2007
|
||||
|
||||
* PVW: Bug fix in observation analysis.
|
||||
* PVW: Consistency checks of experimental history pragma.
|
||||
|
||||
Apr 5, 2007
|
||||
|
||||
* TS: Lessened worst bottlenecks in CHR compiler,
|
||||
in the guard simplification phase.
|
||||
|
||||
Mar 26, 2007
|
||||
|
||||
* TS: Experimental dynattr option, for dynamic size attribute terms.
|
||||
|
||||
Mar 16, 2007
|
||||
|
||||
* TS: Extended observation analysis (abstract interpretation)
|
||||
to deal with disjunctions. With Paolo Tacchella.
|
||||
|
||||
Mar 14, 2007
|
||||
|
||||
* TS: Renamed hprolog:substitute/4 to substitute_eq/4, because of
|
||||
name conflict with library(edit).
|
||||
|
||||
Mar 12, 2007
|
||||
|
||||
* TS: Use line numbers in error and warning messages.
|
||||
|
||||
Mar 8, 2007
|
||||
|
||||
* TS: Added maintenance of line numbers through CHR compilation
|
||||
as an option: chr_option(line_numbers,on).
|
||||
|
||||
Mar 5, 2007
|
||||
|
||||
* TS: Bug fix: setarg/3 instantiation error reported by Mike Elston.
|
||||
Caused by missing suspension argument in debug off, optimize off
|
||||
mode.
|
||||
|
||||
Feb 22, 2007
|
||||
|
||||
* LDK: O(1) removal from hashtables, with experimental
|
||||
chr_option(ht_removal,on).
|
||||
|
||||
Jan 25, 2007
|
||||
|
||||
* PVW: Bugfixes for optional use of CHR constraints in rule guards.
|
||||
|
||||
Jan 18, 2007
|
||||
|
||||
* PVW: Optional use of CHR constraints in rule guards.
|
||||
|
||||
Nov 20, 2006
|
||||
|
||||
* TS: Bug fix in compiler_errors.pl.
|
||||
|
||||
Oct 25, 2006
|
||||
|
||||
* TS: Bug fix in occurrence subsumption by Jon Sneyers.
|
||||
|
||||
Oct 18, 2006
|
||||
|
||||
* TS: New preprocessor feature.
|
||||
|
||||
* TS: Parametrization of experimental chr_identifier type.
|
||||
|
||||
Oct 16, 2006
|
||||
|
||||
* TS: More inlining.
|
||||
|
||||
* TS: Stronger static type checking.
|
||||
|
||||
* TS: Omitted buggy FD analysis from bootstrapping process.
|
||||
|
||||
Oct 12, 2006
|
||||
|
||||
* TS: More inlining.
|
||||
|
||||
* TS: Experimental chr_identifier type.
|
||||
|
||||
Oct 10, 2006
|
||||
|
||||
* TS: Allow for empty type definitions aka phantom types. These are
|
||||
useful for some type-level tricks. A warning is issued so the
|
||||
user can check whether a phantom type is intended. No other
|
||||
phantom type-specific checks are in place yet.
|
||||
|
||||
* TS: Fixed static type checking of built-in types.
|
||||
|
||||
Oct 9, 2006
|
||||
|
||||
* TS: The dense_int type can now appear on the rhs of type alias
|
||||
definitions.
|
||||
|
||||
Oct 3, 2006
|
||||
|
||||
* TS: Fixed bug concerning matchings between ground and possibly
|
||||
non-ground arguments.
|
||||
|
||||
Oct 2, 2006
|
||||
|
||||
* TS: Fixed a bug in code generation, overeager removal of a clause.
|
||||
|
||||
Sep 28, 2006
|
||||
|
||||
* TS: Refactored some code.
|
||||
|
||||
Sep 22, 2006
|
||||
|
||||
* TS: Add exception handler to initialize chr_leash in new threads.
|
||||
|
||||
Sep 18. 2006
|
||||
|
||||
* TS: Bug fix for programs in debugging mode.
|
||||
|
||||
Aug 30, 2006
|
||||
|
||||
* JW: Fixed make clean
|
||||
* JW: Enlarged stacks to make build succeed
|
||||
|
||||
Aug 24, 2006
|
||||
|
||||
* JW: Add target ln-install
|
||||
|
||||
Aug 21, 2006
|
||||
|
||||
* TS: Fixed wrong arities in not inlined predicates. Mike Elston.
|
||||
|
||||
Aug 18, 2006
|
||||
|
||||
* TS: Code clean-up, more inlining, only generate used imports.
|
||||
|
||||
Aug 17, 2006
|
||||
|
||||
* TS: Inlining and more specialization of auxiliary predicates.
|
||||
|
||||
Aug 10, 2006
|
||||
|
||||
* TS: Fixed bug for constraints without rules in debug mode.
|
||||
|
||||
* TS: Compiler clean-up
|
||||
|
||||
* TS: Experimental var_assoc_store.
|
||||
|
||||
|
||||
Aug 9, 2006
|
||||
|
||||
* TS: Various minor code generation improvements, including smaller
|
||||
suspension terms.
|
||||
|
||||
Aug 8, 2006
|
||||
|
||||
* TS: Absolutely no lock checking when check_guard_bindings is disabled.
|
||||
|
||||
Aug 4, 2006
|
||||
|
||||
* TS: Minor optimizations for (-) arguments.
|
||||
|
||||
* TS: Important optimization for awakening fewer suspended constraints
|
||||
|
||||
Aug 3, 2006
|
||||
|
||||
* TS: Fixed typo in static type checker.
|
||||
|
||||
* TS: Documented static and dynamic type checking.
|
||||
|
||||
Aug 2, 2006
|
||||
|
||||
* TS: Fixed bug (type alias related) in static type checker. Mike Elston.
|
||||
|
||||
* TS: Added static type checking on variable matching in rule heads.
|
||||
|
||||
* TS: Added static type checking on CHR constraints in rule bodies.
|
||||
|
||||
Aug 1, 2006
|
||||
|
||||
* TS: New (limited) compile time type checking of rule heads.
|
||||
|
||||
Jul 28, 2006
|
||||
|
||||
* TS: New experimental robustness feature in debug mode:
|
||||
runtime type checking of CHR constraints.
|
||||
|
||||
Jul 5, 2006
|
||||
|
||||
* TS: Minor bug fixes.
|
||||
|
||||
Jun 22, 2006
|
||||
|
||||
* TS: Improved performance of ai_observation_analysis,
|
||||
mainly via additional tabling and passive declarations.
|
||||
|
||||
Jun 8, 2006
|
||||
|
||||
* TS: Disabled some code only intended for SICStus.
|
||||
|
||||
* TS: Fixed bug in removal of constraints. Spotted by Leslie De Koninck.
|
||||
|
||||
Jun 7, 2006
|
||||
|
||||
* TS: Next fix to tracer. Cconstraints in propagation
|
||||
rules are shown in textual order.
|
||||
|
||||
Jun 2, 2006
|
||||
|
||||
* TS: Next few fixes to tracer. Constraints in simpagation rules
|
||||
are now shown on the right side of the backslash.
|
||||
|
||||
Jun 1, 2006
|
||||
|
||||
* TS: Synchronization with SICStus version of K.U.Leuven CHR.
|
||||
|
||||
* TS: First few fixes to tracer. Cconstraints in simplification
|
||||
rules are shown in textual order. Constraint insertions
|
||||
are always shown.
|
||||
|
||||
May 17, 2006
|
||||
|
||||
* TS: Termination bug fixed in guard_entailment.
|
||||
|
||||
* TS: Runtime library predicate run_suspensions is now specialized
|
||||
per constraint, avoiding requirement of fixed suspension layout.
|
||||
|
||||
* TS: Further update to suspension term layout. Only constraints for
|
||||
which the propagation history is used get a history field.
|
||||
|
||||
May 9, 2006
|
||||
|
||||
* TS: Ignore propagation rules with trivial body 'true'.
|
||||
|
||||
Apr 24, 2006
|
||||
|
||||
* TS: Guard entailment now first simplifies the formula it processes,
|
||||
in order to reduce the number of disjunctions, to obtain a smaller
|
||||
search tree.
|
||||
|
||||
Apr 22, 2006
|
||||
|
||||
* TS: Bug fix by Jon Sneyers: type aliases now support built-in types.
|
||||
Spotted by Mike Elston.
|
||||
|
||||
* TS: Small refactorings based on Ciao port experience.
|
||||
|
||||
* TS: Removed -singleton stylecheck option now that portray_clause
|
||||
prints singleton variables as _.
|
||||
|
||||
Apr 19, 2006
|
||||
|
||||
* JW: Make library(chr) load its private stuff silent.
|
||||
|
||||
Apr 14, 2006
|
||||
|
||||
* TS: Bug fix: too many guards were locked.
|
||||
|
||||
Apr 11, 2006
|
||||
|
||||
* TS: Most runtime library predicates are now specialized
|
||||
per constraint, avoiding generic =.. and lists code.
|
||||
|
||||
Mayor update to suspension term layout. Layout may now
|
||||
differ from one constraint to the other. Some unused suspension
|
||||
fields (continuation goal and generation number) are omitted.
|
||||
Further analysis can remove more fields.
|
||||
|
||||
Default store constraints now each have
|
||||
their own global variable: a list of all the suspensions.
|
||||
Removal from this list is now O(1) thanks to setarg/1 and
|
||||
back pointers in the suspension terms. This can cause time
|
||||
time complexity improvements in solvers that always have
|
||||
variable indexing on their constraints.
|
||||
|
||||
Ground, non-indexed constraints are now removed from
|
||||
their global list store in O(1), as for the default store.
|
||||
|
||||
Minor bug fixes in a number of places.
|
||||
|
||||
Mar 16, 2006
|
||||
|
||||
* TS: Fixed subtle bug in ai_observation analysis,
|
||||
that caused goal sequences to only generate
|
||||
the optimistic default answer pattern, leading
|
||||
to invalid 'not observed' conclusions.
|
||||
* TS: Variable indexing/suspension analysis now ignores functor/3
|
||||
in guards. Could be extended to other built-ins
|
||||
that cause an error when arguments are not
|
||||
properly instantiated.
|
||||
|
||||
Mar 11, 2006
|
||||
|
||||
* TS: Renamed global variable id to chr_id in chr_runtime.pl.
|
||||
|
||||
Mar 9, 2006
|
||||
* JS: Synchronization with experimental version:
|
||||
- minor optimizations, e.g. efficient lookups with statically known
|
||||
instantiated data
|
||||
- new alternative syntax for passive declarations
|
||||
- new dense_int built-in type + underlying store
|
||||
- new type alias definitions, like in Mercury
|
||||
|
||||
Mar 4, 2006
|
||||
* BD: small changes in chr_compiler_options.pl and chr_translate.chr
|
||||
affecting only the SICStus port
|
||||
|
||||
Mar 3, 2006
|
||||
* BD: lots of changes related to porting to SICStus
|
||||
* TS: Now exception/3 hook is only used in SWI-Prolog
|
||||
|
||||
Mar 2, 2006
|
||||
|
||||
* TS: Use exception/3 hook to catch undefined
|
||||
global variables of chr_runtime.pl and CHR modules,
|
||||
for multi-threaded programs and saved states.
|
||||
|
||||
Feb 9, 2006
|
||||
|
||||
* JW: Fix "make check" path issues.
|
||||
* TS: Removed all is_chr_file tests when loading file.
|
||||
|
||||
Feb 8, 2006
|
||||
|
||||
* BD: chr_swi.pl: option(optimize --> :- chr_option(optimize
|
||||
* TS: Removed obsolete experimental optimization option.
|
||||
* TS: Correctly report variable pragmas!
|
||||
* TS: No constraints declared is no longer a special case.
|
||||
|
||||
Jan 19, 2006
|
||||
|
||||
* BD: chr_swi.pl - use_module(hprolog added for SICStus port
|
||||
* TS: Removed operator declaration for '::'. No longer used.
|
||||
|
||||
Dec 23, 2005
|
||||
|
||||
* TS: Removed chr_constraints declaration again, in favor
|
||||
of only the chr_constraint declaration and modified
|
||||
documentation accordingly.
|
||||
* TS: Modified documentation based on recommendations of Bart Demoen.
|
||||
* TS: Added chr_info/3 predicate to chr_compiler_errors, as suggested by
|
||||
Jon Sneyers. Now print banner on calling compiler.
|
||||
|
||||
Dec 13, 2005
|
||||
|
||||
* TS: warnings are now written to user_error stream.
|
||||
|
||||
Dec 12, 2005
|
||||
|
||||
* TS: option and constraints declarations are now deprecated. They
|
||||
are replaced by chr_option and chr_constraint(s).
|
||||
* TR: Made an interface for warnings and errors. Errors now implemented
|
||||
with exceptions.
|
||||
* TR: Revised documentation.
|
||||
|
||||
Dec 2, 2005
|
||||
* BD: chr_translate.chr, chr_translate_bootstrap2.chr
|
||||
mutables "abstracted"
|
||||
* BD: chr_translate_bootstrap1.chr
|
||||
atomic_concat - some duplicate code of it is in more than one file :-(
|
||||
create_get_mutable definitions if-deffed
|
||||
verbosity_on/0 for porting
|
||||
hprolog.pl
|
||||
definitions of init_store/2, get_store/2, update_store/2
|
||||
and of make_init_store_goal/make_get_store_goal/make_update_store_goal
|
||||
removed prolog_flag/3 (seemed nowhere used)
|
||||
chr_translate_bootstrap2.chr
|
||||
make_init_store_goal/make_get_store_goal/make_update_store_goal introduced
|
||||
verbosity_on/0 for porting
|
||||
chr_translate_bootstrap.pl
|
||||
atom_concat -> atomic_concat
|
||||
verbosity_on/0 for porting
|
||||
conditional import van library(terms)
|
||||
chr_translate.chr
|
||||
make_init_store_goal etc. introduced
|
||||
create_get_mutable_ref wherever needed (chr_translate*)
|
||||
|
||||
|
||||
Nov 30, 2005
|
||||
* BD: chr_runtime.pl:
|
||||
chr_init for SICStus
|
||||
included contents of chr_debug.pl
|
||||
removed show_store/1
|
||||
create_mutable changed into 'chr create_mutable'
|
||||
got rid of explicit inlining and did it by goal expansion
|
||||
inlining also of 'chr default_store'
|
||||
* BD: chr_swi.pl:
|
||||
removed :- use_module(chr(chr_debug))
|
||||
module header: version for SICStus
|
||||
* BD: chr_debug.pl: emptied
|
||||
* BD: chr_translate.chr:
|
||||
system specific declarations factored out in insert_declarations
|
||||
changed two atom_concat/3 into atomic_concat/3 (because arg 2 was sometimes an int)
|
||||
* BD: chr_compiler_utility.pl:
|
||||
put atomic_concat/3 there
|
||||
adapted atom_concat_list/2 to use it
|
||||
* BD: chr_swi_bootstrap.pl:
|
||||
introduced chr_swi_bootstrap/2 for ease of porting
|
||||
exported also chr_compile/3
|
||||
porting code for get_time stuff/read_term/absolute_file_name
|
||||
* BD: builtins.pl, a_star.pl, clean_code.pl:
|
||||
some ifdefs
|
||||
|
||||
|
||||
Nov 29, 2005
|
||||
* BD: hprolog.pl: removed strip_attributes/2 and restore_attributes/2
|
||||
|
||||
Nov 29, 2005
|
||||
* BD: chr_swi.pl: Removed code that took Handler for Module (in chr_expand(end_of_file)
|
||||
Added :- chr_option(_,_) with same meaning as option(_,_)
|
||||
is_chr_file: .chr is no longer a recognised suffix
|
||||
added use_module(library(lists))
|
||||
changed calls to source_location/2 into prolog_load_context/2
|
||||
* BD: chr_translate.chr: chr_translate/2: added end_of_file to translated program
|
||||
adapted SICStus compatibility message
|
||||
made :- chr_option(_,_) available
|
||||
changed precedence of + - ? to 980 (these ops are
|
||||
probably not local enough to the module)
|
||||
|
||||
Nov 21, 2005
|
||||
|
||||
* TS: Further synchronization with hProlog.
|
||||
|
||||
Nov 18, 2005
|
||||
|
||||
* TS: Removed dead code in guard_entailment.chr
|
||||
* TS: Fixed performance bug: now lookup is indexed
|
||||
on maximal number of arguments.
|
||||
* TS: Removed some redundant intermediate predicates
|
||||
in chr_runtime.pl.
|
||||
* TS: It is now possible to disable the printing
|
||||
of the CHR constraint store per module,
|
||||
through the option toplevel_show_store on/off
|
||||
* TS: Synchronized with hProlog
|
||||
* TS: bug fix in functional dependency analysis
|
||||
|
||||
Nov 17, 2005
|
||||
|
||||
* TS: Removed two dead predicates in chr_translate.chr
|
||||
and hooked up the late_storage_analysis
|
||||
that was being bypassed.
|
||||
* TS: Renamed global_term_ref_1 to default_store.
|
||||
* TS: Removed redundant predicate values_ht.
|
||||
* TS: Compiler no longer generates dead code for never stored constraints,
|
||||
i.e. attach/detach predicates.
|
||||
This reduces the generated .pl by about 700 lines.
|
||||
|
||||
Nov 10, 2005
|
||||
|
||||
* TS: Two more bug fixes for constraints without
|
||||
active occurrences that trigger.
|
||||
|
||||
Nov 4, 2005
|
||||
|
||||
* TS: Small optimization of code for constraints
|
||||
without any active occurrence.
|
||||
* TS: Fixed bug caused by previous bug fix:
|
||||
added only_ground_indexed_arguments/1 test
|
||||
to separate out that meaning from may_trigger/1.
|
||||
|
||||
Nov 3, 2005
|
||||
|
||||
* TS: Removed strip_attributes code.
|
||||
* TS: Fixed bug that causes new constraints to be added on triggering.
|
||||
|
||||
Oct 25, 2005
|
||||
|
||||
* TS: Two minor bug fixes.
|
||||
|
||||
Oct 19, 2005
|
||||
|
||||
* TS: Fixed bug due to overly aggressive inlining of get_mutable_value.
|
||||
|
||||
Oct 18, 2005
|
||||
|
||||
* JS: Compiled code is broken, if debug is off and optimize too.
|
||||
Debug off now entails optimize on.
|
||||
|
||||
* TS: Some fixes of the documentation. Thanks to Bart Demoen
|
||||
and Thom Fruehwirth.
|
||||
|
||||
Sep 2, 2005
|
||||
|
||||
* TS: Synchronized with hProlog.
|
||||
|
||||
Aug 31, 2005
|
||||
|
||||
* TS: Added missing operator declarations for prefix (?).
|
||||
|
||||
Aug 9, 2005
|
||||
|
||||
* JW: import lists into chr_compiler_utility.pl
|
||||
|
||||
* JW: make message hook for query(yes) detect CHR global variables.
|
||||
|
||||
* JW: Exported pairlist_delete_eq/3 from pairlist and use this in
|
||||
chr_hashtable_store.pl
|
||||
|
||||
Aug 4, 2005
|
||||
|
||||
* TS: Renamed pairlist:delete/3 to pairlist:pairlist_delete/3.
|
||||
Mike Elston.
|
||||
Aug 1, 2005
|
||||
|
||||
* TS: Extended more efficient ground matching code to
|
||||
removed simpagation occurrence code.
|
||||
|
||||
Jul 28, 2005
|
||||
|
||||
* TS: New input verification: duplicate constraint declaration
|
||||
now reported as an error. Requested by Mike Elston.
|
||||
* TS: More efficient matching code for ground constraints
|
||||
when matching an argument of a partner constraint with
|
||||
a ground term
|
||||
* JS: Bug fix in guard simplification.
|
||||
|
||||
Jul 3, 2005
|
||||
|
||||
* TS: Factored out option functionality into separate module.
|
||||
* TS: Factored out utility code into separate module.
|
||||
|
||||
Jun 29, 2005
|
||||
|
||||
* TS: Changed chr_show_store/1 to use print/1 instead of write/1.
|
||||
|
||||
Jun 28, 2005
|
||||
|
||||
* TS: Removed spurious and conflicting operator definitions
|
||||
for +, - and ? as mode declarations.
|
||||
|
||||
Jun 27, 2005
|
||||
|
||||
* TS: Added find_chr_constraint/1 functionality.
|
||||
|
||||
Jun 8, 2005
|
||||
|
||||
* TS: Improved compiler scalability: use nb_setval/2 to
|
||||
remember compiled code through backtracking over
|
||||
compilation process instead of assert/1.
|
||||
* TS: Removed spurious comma from file.
|
||||
|
||||
Jun 1, 2005
|
||||
|
||||
* TS: Added option to disable toplevel constraint store printing.
|
||||
* TS: Slightly improved hash table constraint store implementation.
|
||||
|
||||
Apr 16, 2005
|
||||
|
||||
* JW: Added patch from Jon Sneyers.
|
||||
|
||||
Mar 11, 2005
|
||||
|
||||
* TS: Improved head reordering heuristic.
|
||||
* TS: Added support primitive for alternate built-in solver dependency.
|
||||
|
||||
Mar 4, 2005
|
||||
|
||||
* TS: Fixed bug that causes wrong output in chr_show_store.
|
||||
|
||||
Feb 25, 2005
|
||||
|
||||
* TS: Fixed several bugs in generation of debugable code.
|
||||
|
||||
Feb 19, 2005
|
||||
|
||||
* JW: Cleanup integration in SWI-Prolog environment:
|
||||
- Extended SWI-Prolog library ordsets. Renamed ord_delete/3 to
|
||||
ord_del_element/3 and ord_difference/3 to ord_subtract/3 for
|
||||
better compatibility.
|
||||
- Renamed module find to chr_find to avoid name conflict and declared
|
||||
preds as meta-predicate.
|
||||
- Re-inserted and exported strip_attributes/2 and
|
||||
restore_attributes/2 in hprolog.pl. Deleted hprolog: from
|
||||
chr_translate.chr.
|
||||
- Added dummy option declarations to bootstrap compiler.
|
||||
- Fixed path problems in makefile (-p chr=.) and install new
|
||||
components.
|
||||
- Fixed typo 'chr show_store' --> chr_show_store.
|
||||
|
||||
Feb 17, 2005
|
||||
|
||||
* JS: Added guard entailment optimizations and
|
||||
new syntax for type and mode declarations.
|
||||
|
||||
Dec 15, 2004
|
||||
|
||||
* TS: Use prolog:message/3 hook to automatically print
|
||||
contents of CHR constraint stores with query bindings
|
||||
on toplevel.
|
||||
|
||||
Dec 3, 2004
|
||||
|
||||
* TS: Bugfix in code generation. Reported by Lyosha Ilyukhin.
|
||||
|
||||
Jul 28, 2004
|
||||
|
||||
* TS: Updated hashtable stores. They now start small and expand.
|
||||
|
||||
Jul 19, 2004
|
||||
|
||||
* JW: Removed chr_pp: module prefixes
|
||||
* JW: Updated Windows makefile.mak (more similar organisation, added check)
|
||||
|
||||
Jul 17, 2004
|
||||
|
||||
* TS: Added chr_hashtable_store library.
|
||||
* TS: Added find library.
|
||||
* TS: Added builtins library.
|
||||
* TS: Added clean_code library.
|
||||
* TS: Added binomial_heap library.
|
||||
* TS: Added a_star library.
|
||||
* TS: Added new intermediate bootstrapping step
|
||||
* TS: Synchronized CHR compiler with most recent development version
|
||||
|
||||
Summary of changes:
|
||||
|
||||
"The new version of the compiler contains several new optimizations, both
|
||||
fully automatic, such as the antimonotny-based delay avoidance (see
|
||||
http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW385.abs.html for
|
||||
the technical report), and enabled by mode declarations (see CHR
|
||||
documentation), such as hashtable-based constraint indexes."
|
||||
|
||||
Apr 9, 2004
|
||||
|
||||
* JW: Added chr_messages.pl. Make all debug messages use the print_message/2
|
||||
interface to enable future embedding.
|
||||
|
||||
Apr 7, 2004
|
||||
|
||||
* JW: Added chr:debug_interact/3 hook. Defined in chr_swi.pl to void
|
||||
showing constraints first as goal and then as CHR call.
|
||||
* JW: Added chr:debug_event/2 hook. Defined in chr_swi.pl to make the
|
||||
CHR debugger honour a skip command from the Prolog tracer.
|
||||
|
||||
Apr 6, 2004
|
||||
|
||||
* JW: Added b (break) to the CHR debugger.
|
||||
* TS: added chr_expandable/2 clause for pragma/2
|
||||
|
||||
Apr 5, 2004
|
||||
|
||||
* JW: fixed reference to format_rule/2.
|
||||
* JW: Use select/3 rather than delete/3 in diff/2 in Tests/zebra.pl
|
||||
* TS: CHR translation now leaves CHR store empty
|
||||
|
||||
Apr 4, 2004
|
||||
|
||||
* JW: added :- use_module(library(chr)) to all examples.
|
||||
* JW: mapped -O --> option(optimize, full).
|
||||
* JW: introduced file-search-path `chr' for clarity and to enable running
|
||||
make check from the local environment instead of the public installation.
|
||||
* JW: mapped prolog flag generate_debug_info --> option(debug, on)
|
||||
* JW: Replaced the chr -> pl step with term_expansion/2.
|
||||
* JW: Moved insert_declarations/2 to chr_swi.pl
|
||||
|
||||
Apr 2, 2004
|
||||
|
||||
* JW: fixed Undefined procedure: chr_runtime:run_suspensions_loop_d/1
|
||||
* TS: Added <space> for creep and shortened debug line prefix to CHR:
|
||||
|
||||
Mar 29, 2004
|
||||
|
||||
* JW: Use \+ \+ in chr_compile/3 to undo changes to the constraint
|
||||
pool. Regression test suite using "make check" works again.
|
||||
|
||||
Mar 25, 2004
|
||||
|
||||
* TS: Added skip and ancestor debug commands
|
||||
|
||||
Mar 24, 2004
|
||||
G
|
||||
* TS: Added bootstrapping process for CHR compiler using CHR.
|
||||
* TS: CHR compiler now uses CHR.
|
||||
* TS: Fixed bug in compilation of multi-headed simpagation rules.
|
||||
* TS: Cleaned up compiler.
|
||||
* TS: Added analysis + optimization for never attached constraints.
|
||||
* TS: Exploit uniqueness (functional dependency) results to detect
|
||||
set semantics type simpagation rules where one rule can be passive
|
||||
* TS: Compiler generates 'chr debug_event'/1 calls
|
||||
* TS: Rudimentary support for debugging.
|
||||
option(debug,on) causes a trace of CHR events to be printed
|
||||
|
||||
Mar 15, 2004
|
||||
|
||||
* JW: Fix operator handling.
|
||||
|
||||
Mar 3, 2004
|
||||
|
||||
* JW: Integrated new version from Tom Schrijvers.
|
|
@ -0,0 +1,281 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Thom Fruehwirth ECRC 1991-1993
|
||||
%% 910528 started boolean,and,or constraints
|
||||
%% 910904 added xor,neg constraints
|
||||
%% 911120 added imp constraint
|
||||
%% 931110 ported to new release
|
||||
%% 931111 added card constraint
|
||||
%% 961107 Christian Holzbaur, SICStus mods
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers June 2003
|
||||
|
||||
|
||||
:- module(bool,[]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints boolean/1, and/3, or/3, xor/3, neg/2, imp/2, labeling/0, card/4.
|
||||
|
||||
|
||||
boolean(0) <=> true.
|
||||
boolean(1) <=> true.
|
||||
|
||||
labeling, boolean(A)#Pc <=>
|
||||
( A=0 ; A=1),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
|
||||
%% and/3 specification
|
||||
%%and(0,0,0).
|
||||
%%and(0,1,0).
|
||||
%%and(1,0,0).
|
||||
%%and(1,1,1).
|
||||
|
||||
and(0,X,Y) <=> Y=0.
|
||||
and(X,0,Y) <=> Y=0.
|
||||
and(1,X,Y) <=> Y=X.
|
||||
and(X,1,Y) <=> Y=X.
|
||||
and(X,Y,1) <=> X=1,Y=1.
|
||||
and(X,X,Z) <=> X=Z.
|
||||
%%and(X,Y,X) <=> imp(X,Y).
|
||||
%%and(X,Y,Y) <=> imp(Y,X).
|
||||
and(X,Y,A) \ and(X,Y,B) <=> A=B.
|
||||
and(X,Y,A) \ and(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, and(A,B,C)#Pc <=>
|
||||
label_and(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_and(0,X,0).
|
||||
label_and(1,X,X).
|
||||
|
||||
|
||||
%% or/3 specification
|
||||
%%or(0,0,0).
|
||||
%%or(0,1,1).
|
||||
%%or(1,0,1).
|
||||
%%or(1,1,1).
|
||||
|
||||
or(0,X,Y) <=> Y=X.
|
||||
or(X,0,Y) <=> Y=X.
|
||||
or(X,Y,0) <=> X=0,Y=0.
|
||||
or(1,X,Y) <=> Y=1.
|
||||
or(X,1,Y) <=> Y=1.
|
||||
or(X,X,Z) <=> X=Z.
|
||||
%%or(X,Y,X) <=> imp(Y,X).
|
||||
%%or(X,Y,Y) <=> imp(X,Y).
|
||||
or(X,Y,A) \ or(X,Y,B) <=> A=B.
|
||||
or(X,Y,A) \ or(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, or(A,B,C)#Pc <=>
|
||||
label_or(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_or(0,X,X).
|
||||
label_or(1,X,1).
|
||||
|
||||
|
||||
%% xor/3 specification
|
||||
%%xor(0,0,0).
|
||||
%%xor(0,1,1).
|
||||
%%xor(1,0,1).
|
||||
%%xor(1,1,0).
|
||||
|
||||
xor(0,X,Y) <=> X=Y.
|
||||
xor(X,0,Y) <=> X=Y.
|
||||
xor(X,Y,0) <=> X=Y.
|
||||
xor(1,X,Y) <=> neg(X,Y).
|
||||
xor(X,1,Y) <=> neg(X,Y).
|
||||
xor(X,Y,1) <=> neg(X,Y).
|
||||
xor(X,X,Y) <=> Y=0.
|
||||
xor(X,Y,X) <=> Y=0.
|
||||
xor(Y,X,X) <=> Y=0.
|
||||
xor(X,Y,A) \ xor(X,Y,B) <=> A=B.
|
||||
xor(X,Y,A) \ xor(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, xor(A,B,C)#Pc <=>
|
||||
label_xor(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_xor(0,X,X).
|
||||
label_xor(1,X,Y):- neg(X,Y).
|
||||
|
||||
|
||||
%% neg/2 specification
|
||||
%%neg(0,1).
|
||||
%%neg(1,0).
|
||||
|
||||
neg(0,X) <=> X=1.
|
||||
neg(X,0) <=> X=1.
|
||||
neg(1,X) <=> X=0.
|
||||
neg(X,1) <=> X=0.
|
||||
neg(X,X) <=> fail.
|
||||
neg(X,Y) \ neg(Y,Z) <=> X=Z.
|
||||
neg(X,Y) \ neg(Z,Y) <=> X=Z.
|
||||
neg(Y,X) \ neg(Y,Z) <=> X=Z.
|
||||
%% Interaction with other boolean constraints
|
||||
neg(X,Y) \ and(X,Y,Z) <=> Z=0.
|
||||
neg(Y,X) \ and(X,Y,Z) <=> Z=0.
|
||||
neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(X,Y) \ or(X,Y,Z) <=> Z=1.
|
||||
neg(Y,X) \ or(X,Y,Z) <=> Z=1.
|
||||
neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(X,Y) \ xor(X,Y,Z) <=> Z=1.
|
||||
neg(Y,X) \ xor(X,Y,Z) <=> Z=1.
|
||||
neg(X,Z) \ xor(X,Y,Z) <=> Y=1.
|
||||
neg(Z,X) \ xor(X,Y,Z) <=> Y=1.
|
||||
neg(Y,Z) \ xor(X,Y,Z) <=> X=1.
|
||||
neg(Z,Y) \ xor(X,Y,Z) <=> X=1.
|
||||
neg(X,Y) , imp(X,Y) <=> X=0,Y=1.
|
||||
neg(Y,X) , imp(X,Y) <=> X=0,Y=1.
|
||||
|
||||
labeling, neg(A,B)#Pc <=>
|
||||
label_neg(A,B),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_neg(0,1).
|
||||
label_neg(1,0).
|
||||
|
||||
|
||||
%% imp/2 specification (implication)
|
||||
%%imp(0,0).
|
||||
%%imp(0,1).
|
||||
%%imp(1,1).
|
||||
|
||||
imp(0,X) <=> true.
|
||||
imp(X,0) <=> X=0.
|
||||
imp(1,X) <=> X=1.
|
||||
imp(X,1) <=> true.
|
||||
imp(X,X) <=> true.
|
||||
imp(X,Y),imp(Y,X) <=> X=Y.
|
||||
|
||||
labeling, imp(A,B)#Pc <=>
|
||||
label_imp(A,B),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_imp(0,X).
|
||||
label_imp(1,1).
|
||||
|
||||
|
||||
|
||||
%% Boolean cardinality operator
|
||||
%% card(A,B,L,N) constrains list L of length N to have between A and B 1s
|
||||
|
||||
|
||||
card(A,B,L):-
|
||||
length(L,N),
|
||||
A=<B,0=<B,A=<N, %0=<N
|
||||
card(A,B,L,N).
|
||||
|
||||
%% card/4 specification
|
||||
%%card(A,B,[],0):- A=<0,0=<B.
|
||||
%%card(A,B,[0|L],N):-
|
||||
%% N1 is N-1,
|
||||
%% card(A,B,L,N1).
|
||||
%%card(A,B,[1|L],N):-
|
||||
%% A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
%% card(A1,B1,L,N1).
|
||||
|
||||
triv_sat @ card(A,B,L,N) <=> A=<0,N=<B | true. % trivial satisfaction
|
||||
pos_sat @ card(N,B,L,N) <=> set_to_ones(L). % positive satisfaction
|
||||
neg_sat @ card(A,0,L,N) <=> set_to_zeros(L). % negative satisfaction
|
||||
pos_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==1 | % positive reduction
|
||||
A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
card(A1,B1,L1,N1).
|
||||
neg_red @ card(A,B,L,N) <=> b_delete(X,L,L1),X==0 | % negative reduction
|
||||
N1 is N-1,
|
||||
card(A,B,L1,N1).
|
||||
%% special cases with two variables
|
||||
card2nand @ card(0,1,[X,Y],2) <=> and(X,Y,0).
|
||||
card2neg @ card(1,1,[X,Y],2) <=> neg(X,Y).
|
||||
card2or @ card(1,2,[X,Y],2) <=> or(X,Y,1).
|
||||
|
||||
b_delete( X, [X|L], L).
|
||||
b_delete( Y, [X|Xs], [X|Xt]) :-
|
||||
b_delete( Y, Xs, Xt).
|
||||
|
||||
labeling, card(A,B,L,N)#Pc <=>
|
||||
label_card(A,B,L,N),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_card(A,B,[],0):- A=<0,0=<B.
|
||||
label_card(A,B,[0|L],N):-
|
||||
N1 is N-1,
|
||||
card(A,B,L).
|
||||
label_card(A,B,[1|L],N):-
|
||||
A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
card(A1,B1,L).
|
||||
|
||||
set_to_ones([]).
|
||||
set_to_ones([1|L]):-
|
||||
set_to_ones(L).
|
||||
|
||||
set_to_zeros([]).
|
||||
set_to_zeros([0|L]):-
|
||||
set_to_zeros(L).
|
||||
|
||||
|
||||
|
||||
%% Auxiliary predicates
|
||||
|
||||
:- op(100,xfy,#).
|
||||
|
||||
solve_bool(A,C) :- var(A), !, A=C.
|
||||
solve_bool(A,C) :- atomic(A), !, A=C.
|
||||
solve_bool(A * B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
and(A1,B1,C).
|
||||
solve_bool(A + B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
or(A1,B1,C).
|
||||
solve_bool(A # B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
xor(A1,B1,C).
|
||||
solve_bool(not(A),C) :- !,
|
||||
solve_bool(A,A1),
|
||||
neg(A1,C).
|
||||
solve_bool((A -> B), C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
imp(A1,B1),C=1.
|
||||
solve_bool(A = B, C) :- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
A1=B1,C=1.
|
||||
|
||||
%% Labeling
|
||||
label_bool([]).
|
||||
label_bool([X|L]) :-
|
||||
( X=0;X=1),
|
||||
label_bool(L).
|
||||
|
||||
/* % no write macros in SICStus and hProlog
|
||||
|
||||
bool_portray(and(A,B,C),Out):- !, Out = (A*B = C).
|
||||
bool_portray(or(A,B,C),Out):- !, Out = (A+B = C).
|
||||
bool_portray(xor(A,B,C),Out):- !, Out = (A#B = C).
|
||||
bool_portray(neg(A,B),Out):- !, Out = (A= not(B)).
|
||||
bool_portray(imp(A,B),Out):- !, Out = (A -> B).
|
||||
bool_portray(card(A,B,L,N),Out):- !, Out = card(A,B,L).
|
||||
|
||||
:- define_macro(type(compound),bool_portray/2,[write]).
|
||||
*/
|
||||
|
||||
/* end of handler bool */
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(chrdif,[chrdif/2]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints dif/2, dif2/3, or/2, or_seq/2, del_or/1.
|
||||
|
||||
chrdif(X,Y) :- dif(X,Y).
|
||||
|
||||
dif(X,Y) <=> compound(X), compound(Y) | dif1(X,Y).
|
||||
dif(X,X) <=> fail.
|
||||
dif(X,Y) <=> nonvar(X), nonvar(Y) /* X \== Y holds */ | true.
|
||||
|
||||
dif1(X,Y) :-
|
||||
( functor(X,F,A),
|
||||
functor(Y,F,A) ->
|
||||
X =.. [_|XL],
|
||||
Y =.. [_|YL],
|
||||
dif1l(XL,YL,A)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
dif1l(Xs,Ys,N) :-
|
||||
or(Or,N),
|
||||
dif1l_2(Xs,Ys,Or).
|
||||
|
||||
dif1l_2([],[],_).
|
||||
dif1l_2([X|Xs],[Y|Ys],Or) :-
|
||||
dif2(X,Y,Or),
|
||||
dif1l_2(Xs,Ys,Or).
|
||||
|
||||
or_seq(OrP,Or) \ or(Or,0), or(OrP,N) <=> M is N - 1, or_seq(OrP,M).
|
||||
or(_,0) <=> fail.
|
||||
|
||||
dif2(X,Y,Or) <=> compound(X), compound(Y) | dif3(X,Y,Or).
|
||||
dif2(X,X,Or), or(Or,N) <=> M is N - 1, or(Or,M).
|
||||
dif2(X,Y,Or) <=> nonvar(X), nonvar(Y) /* X \== Y holds */ | del_or(Or).
|
||||
|
||||
del_or(Or) \ or_seq(OrP,Or) <=> del_or(OrP).
|
||||
del_or(Or) \ or_seq(Or,OrC) <=> del_or(OrC).
|
||||
del_or(Or) \ or(Or,_) <=> true.
|
||||
del_or(Or) \ dif2(_,_,Or) <=> true.
|
||||
del_or(Or) <=> true.
|
||||
|
||||
dif3(X,Y,Or) :-
|
||||
( functor(X,F,A),
|
||||
functor(Y,F,A) ->
|
||||
X =.. [_|XL],
|
||||
Y =.. [_|YL],
|
||||
or_seq(Or,Or2),
|
||||
dif1l(XL,YL,A)
|
||||
;
|
||||
del_or(Or)
|
||||
).
|
|
@ -0,0 +1,6 @@
|
|||
:- module(chrfreeze,[chrfreeze/2]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints chrfreeze/2.
|
||||
|
||||
chrfreeze(V,G) <=> nonvar(V) | call(G).
|
|
@ -0,0 +1,197 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(deadcode,[deadcode/2]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
:- constraints
|
||||
defined_predicate(+any),
|
||||
calls(+any,+any),
|
||||
live(+any),
|
||||
print_dead_predicates.
|
||||
|
||||
defined_predicate(P) \ defined_predicate(P) <=> true.
|
||||
|
||||
calls(P,Q) \ calls(P,Q) <=> true.
|
||||
|
||||
live(P) \ live(P) <=> true.
|
||||
|
||||
live(P), calls(P,Q) ==> live(Q).
|
||||
|
||||
print_dead_predicates \ live(P), defined_predicate(P) <=> true.
|
||||
print_dead_predicates \ defined_predicate(P) <=>
|
||||
writeln(P).
|
||||
print_dead_predicates \ calls(_,_) <=> true.
|
||||
print_dead_predicates \ live(_) <=> true.
|
||||
print_dead_predicates <=> true.
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
deadcode(File,Starts) :-
|
||||
readfile(File,Clauses),
|
||||
exported_predicates(Clauses,Exports),
|
||||
findall(C, ( member(C,Clauses), C \= (:- _) , C \= (?- _)), Cs),
|
||||
process_clauses(Cs),
|
||||
append(Starts,Exports,Alive),
|
||||
live_predicates(Alive),
|
||||
print_dead_predicates.
|
||||
|
||||
exported_predicates(Clauses,Exports) :-
|
||||
( member( (:- module(_, Exports)), Clauses) ->
|
||||
true
|
||||
;
|
||||
Exports = []
|
||||
).
|
||||
process_clauses([]).
|
||||
process_clauses([C|Cs]) :-
|
||||
hb(C,H,B),
|
||||
extract_predicates(B,Ps,[]),
|
||||
functor(H,F,A),
|
||||
defined_predicate(F/A),
|
||||
calls_predicates(Ps,F/A),
|
||||
process_clauses(Cs).
|
||||
|
||||
calls_predicates([],FA).
|
||||
calls_predicates([P|Ps],FA) :-
|
||||
calls(FA,P),
|
||||
calls_predicates(Ps,FA).
|
||||
|
||||
hb(C,H,B) :-
|
||||
( C = (H :- B) ->
|
||||
true
|
||||
;
|
||||
C = H,
|
||||
B = true
|
||||
).
|
||||
|
||||
live_predicates([]).
|
||||
live_predicates([P|Ps]) :-
|
||||
live(P),
|
||||
live_predicates(Ps).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
extract_predicates(!,L,L) :- ! .
|
||||
extract_predicates(_ < _,L,L) :- ! .
|
||||
extract_predicates(_ = _,L,L) :- ! .
|
||||
extract_predicates(_ =.. _ ,L,L) :- ! .
|
||||
extract_predicates(_ =:= _,L,L) :- ! .
|
||||
extract_predicates(_ == _,L,L) :- ! .
|
||||
extract_predicates(_ > _,L,L) :- ! .
|
||||
extract_predicates(_ \= _,L,L) :- ! .
|
||||
extract_predicates(_ \== _,L,L) :- ! .
|
||||
extract_predicates(_ is _,L,L) :- ! .
|
||||
extract_predicates(arg(_,_,_),L,L) :- ! .
|
||||
extract_predicates(atom_concat(_,_,_),L,L) :- ! .
|
||||
extract_predicates(atomic(_),L,L) :- ! .
|
||||
extract_predicates(b_getval(_,_),L,L) :- ! .
|
||||
extract_predicates(call(_),L,L) :- ! .
|
||||
extract_predicates(compound(_),L,L) :- ! .
|
||||
extract_predicates(copy_term(_,_),L,L) :- ! .
|
||||
extract_predicates(del_attr(_,_),L,L) :- ! .
|
||||
extract_predicates(fail,L,L) :- ! .
|
||||
extract_predicates(functor(_,_,_),L,L) :- ! .
|
||||
extract_predicates(get_attr(_,_,_),L,L) :- ! .
|
||||
extract_predicates(length(_,_),L,L) :- ! .
|
||||
extract_predicates(nb_setval(_,_),L,L) :- ! .
|
||||
extract_predicates(nl,L,L) :- ! .
|
||||
extract_predicates(nonvar(_),L,L) :- ! .
|
||||
extract_predicates(once(G),L,T) :- !,
|
||||
( nonvar(G) ->
|
||||
extract_predicates(G,L,T)
|
||||
;
|
||||
L = T
|
||||
).
|
||||
extract_predicates(op(_,_,_),L,L) :- ! .
|
||||
extract_predicates(prolog_flag(_,_),L,L) :- ! .
|
||||
extract_predicates(prolog_flag(_,_,_),L,L) :- ! .
|
||||
extract_predicates(put_attr(_,_,_),L,L) :- ! .
|
||||
extract_predicates(read(_),L,L) :- ! .
|
||||
extract_predicates(see(_),L,L) :- ! .
|
||||
extract_predicates(seen,L,L) :- ! .
|
||||
extract_predicates(setarg(_,_,_),L,L) :- ! .
|
||||
extract_predicates(tell(_),L,L) :- ! .
|
||||
extract_predicates(term_variables(_,_),L,L) :- ! .
|
||||
extract_predicates(told,L,L) :- ! .
|
||||
extract_predicates(true,L,L) :- ! .
|
||||
extract_predicates(var(_),L,L) :- ! .
|
||||
extract_predicates(write(_),L,L) :- ! .
|
||||
extract_predicates((G1,G2),L,T) :- ! ,
|
||||
extract_predicates(G1,L,T1),
|
||||
extract_predicates(G2,T1,T).
|
||||
extract_predicates((G1->G2),L,T) :- !,
|
||||
extract_predicates(G1,L,T1),
|
||||
extract_predicates(G2,T1,T).
|
||||
extract_predicates((G1;G2),L,T) :- !,
|
||||
extract_predicates(G1,L,T1),
|
||||
extract_predicates(G2,T1,T).
|
||||
extract_predicates(\+ G, L, T) :- !,
|
||||
extract_predicates(G, L, T).
|
||||
extract_predicates(findall(_,G,_),L,T) :- !,
|
||||
extract_predicates(G,L,T).
|
||||
extract_predicates(bagof(_,G,_),L,T) :- !,
|
||||
extract_predicates(G,L,T).
|
||||
extract_predicates(_^G,L,T) :- !,
|
||||
extract_predicates(G,L,T).
|
||||
extract_predicates(_:Call,L,T) :- !,
|
||||
extract_predicates(Call,L,T).
|
||||
extract_predicates(Call,L,T) :-
|
||||
( var(Call) ->
|
||||
L = T
|
||||
;
|
||||
functor(Call,F,A),
|
||||
L = [F/A|T]
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% File Reading
|
||||
|
||||
readfile(File,Declarations) :-
|
||||
see(File),
|
||||
readcontent(Declarations),
|
||||
seen.
|
||||
|
||||
readcontent(C) :-
|
||||
read(X),
|
||||
( X = (:- op(Prec,Fix,Op)) ->
|
||||
op(Prec,Fix,Op)
|
||||
;
|
||||
true
|
||||
),
|
||||
( X == end_of_file ->
|
||||
C = []
|
||||
;
|
||||
C = [X | Xs],
|
||||
readcontent(Xs)
|
||||
).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 000401 Slim Abdennadher and Henning Christiansen
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(family,[]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints
|
||||
% extensional predicates:
|
||||
person/2, father/2, mother/2,
|
||||
orphan/1,
|
||||
% intensional predicates:
|
||||
parent/2, sibling/2,
|
||||
% predefined:
|
||||
diff/2,
|
||||
% a little helper:
|
||||
start/0.
|
||||
|
||||
% Representing the test for failed state, i.e.,
|
||||
% that the 'predefined' are satisfiable
|
||||
|
||||
diff(X,X) ==> false.
|
||||
|
||||
|
||||
|
||||
% Definition rules:
|
||||
|
||||
parent_def @
|
||||
parent(P,C) <=> (true | (father(P,C) ; mother(P,C))).
|
||||
|
||||
sibling_def @
|
||||
sibling(C1,C2) <=>
|
||||
diff(C1,C2),
|
||||
parent(P,C1), parent(P,C2).
|
||||
|
||||
ext_intro @
|
||||
start <=> father(john,mary), father(john,peter),
|
||||
mother(jane,mary),
|
||||
person(john,male), person(peter,male),
|
||||
person(jane,female), person(mary,female),
|
||||
person(paul,male).
|
||||
|
||||
|
||||
|
||||
% Closing rules
|
||||
father_close @
|
||||
father(X,Y) ==> ( true | ((X=john, Y=mary) ; (X=john, Y=peter))).
|
||||
|
||||
% mother close @
|
||||
mother(X,Y) ==> X=jane, Y=mary.
|
||||
|
||||
% person_close @
|
||||
person(X,Y) ==> ( true | ( (X=john, Y=male) ;
|
||||
(X=peter, Y=male) ;
|
||||
(X=jane, Y=female) ;
|
||||
(X=mary, Y=female) ;
|
||||
(X=paul, Y=male)
|
||||
)
|
||||
).
|
||||
|
||||
|
||||
|
||||
% ICs
|
||||
|
||||
ic_father_unique @
|
||||
father(F1,C),father(F2,C) ==> F1=F2.
|
||||
|
||||
|
||||
ic_mother_unique @
|
||||
mother(M1,C),mother(M2,C) ==> M1=M2.
|
||||
|
||||
ic_gender_unique @
|
||||
person(P,G1), person(P,G2) ==> G1=G2.
|
||||
|
||||
ic_father_persons @
|
||||
father(F,C) ==> person(F,male), person(C,S).
|
||||
|
||||
ic_mother_persons @
|
||||
mother(M,C) ==> person(M,female), person(C,G).
|
||||
|
||||
% Indirect def.
|
||||
|
||||
orphan1 @
|
||||
orphan(C) ==> person(C,G).
|
||||
|
||||
orphan2 @
|
||||
orphan(C), /* person(F,male),*/ father(F,C) ==> false.
|
||||
|
||||
orphan3 @
|
||||
orphan(C), /* person(M,female),*/ mother(M,C) ==> false.
|
||||
|
||||
|
||||
|
||||
%%%% The following just to simplify output;
|
||||
|
||||
|
||||
father(F,C) \ father(F,C)<=> true.
|
||||
mother(M,C) \ mother(M,C)<=> true.
|
||||
person(M,C) \ person(M,C)<=> true.
|
||||
orphan(C) \ orphan(C)<=> true.
|
||||
|
||||
|
||||
/*************************************************
|
||||
Sample goals
|
||||
|
||||
:- start, sibling(peter,mary).
|
||||
|
||||
:- start, sibling(paul,mary).
|
||||
|
||||
:- father(X,Y), mother(X,Y).
|
||||
|
||||
**************************************************/
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 991202 Slim Abdennadher, LMU
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(fib,[]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints fib/2.
|
||||
|
||||
%% fib(N,M) is true if M is the Nth Fibonacci number.
|
||||
|
||||
%% Top-down Evaluation with Tabulation
|
||||
|
||||
fib(N,M1), fib(N,M2) <=> M1 = M2, fib(N,M1).
|
||||
|
||||
fib(0,M) ==> M = 1.
|
||||
|
||||
fib(1,M) ==> M = 1.
|
||||
|
||||
fib(N,M) ==> N > 1 | N1 is N-1, fib(N1,M1), N2 is N-2, fib(N2,M2), M is M1 + M2.
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven
|
||||
%%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(fibonacci,[]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints fibonacci/2.
|
||||
|
||||
%% fibonacci(N,M) is true iff M is the Nth Fibonacci number.
|
||||
|
||||
%% Top-down Evaluation with effective Tabulation
|
||||
%% Contrary to the version in the SICStus manual, this one does "true"
|
||||
%% tabulation
|
||||
|
||||
fibonacci(N,M1) # Id \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(Id).
|
||||
|
||||
fibonacci(0,M) ==> M = 1.
|
||||
|
||||
fibonacci(1,M) ==> M = 1.
|
||||
|
||||
fibonacci(N,M) ==>
|
||||
N > 1 |
|
||||
N1 is N-1,
|
||||
fibonacci(N1,M1),
|
||||
N2 is N-2,
|
||||
fibonacci(N2,M2),
|
||||
M is M1 + M2.
|
|
@ -0,0 +1,28 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 980202, 980311 Thom Fruehwirth, LMU
|
||||
%% computes greatest common divisor of positive numbers written each as gcd(N)
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(gcd,[]).
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
:- constraints gcd/1.
|
||||
|
||||
gcd(0) <=> true.
|
||||
%%gcd(N) \ gcd(M) <=> N=<M | L is M-N, gcd(L).
|
||||
gcd(N) \ gcd(M) <=> N=<M | L is M mod N, gcd(L). % faster variant
|
||||
|
||||
/*
|
||||
%% Sample queries
|
||||
|
||||
gcd(2),gcd(3).
|
||||
|
||||
gcd(1.5),gcd(2.5).
|
||||
|
||||
X is 37*11*11*7*3, Y is 11*7*5*3, Z is 37*11*5,gcd(X),gcd(Y),gcd(Z).
|
||||
|
||||
*/
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% simple constraint solver for inequalities between variables
|
||||
%% thom fruehwirth ECRC 950519, LMU 980207, 980311
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(leq,[]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints leq/2.
|
||||
reflexivity @ leq(X,X) <=> true.
|
||||
antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y.
|
||||
idempotence @ leq(X,Y) \ leq(X,Y) <=> true.
|
||||
transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z).
|
||||
|
||||
t(N):-
|
||||
cputime(X),
|
||||
length(L,N),
|
||||
genleq(L,Last),
|
||||
L=[First|_],
|
||||
leq(Last,First),
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(N-Time), nl.
|
||||
|
||||
genleq([Last],Last) :- ! .
|
||||
genleq([X,Y|Xs],Last):-
|
||||
leq(X,Y),
|
||||
genleq([Y|Xs],Last).
|
||||
|
||||
cputime( Ts) :-
|
||||
statistics( runtime, [Tm,_]),
|
||||
Ts is Tm/1000.
|
|
@ -0,0 +1,138 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Slim Abdennadher, Thom Fruehwirth, LMU, July 1998
|
||||
%% Finite (enumeration, list) domain solver over integers
|
||||
%%
|
||||
%% * ported to hProlog by Tom Schrijvers, K.U.Leuven
|
||||
|
||||
% :- module(listdom,[]).
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
:- use_module( library(lists)).
|
||||
|
||||
|
||||
%% for domain constraints
|
||||
:- op( 700,xfx,'::').
|
||||
:- op( 600,xfx,'..').
|
||||
|
||||
%% for inequality constraints
|
||||
:- op( 700,xfx,lt).
|
||||
:- op( 700,xfx,le).
|
||||
:- op( 700,xfx,ne).
|
||||
|
||||
%% for domain constraints
|
||||
?- op( 700,xfx,'::').
|
||||
?- op( 600,xfx,'..').
|
||||
|
||||
%% for inequality constraints
|
||||
?- op( 700,xfx,lt).
|
||||
?- op( 700,xfx,le).
|
||||
?- op( 700,xfx,ne).
|
||||
|
||||
:- constraints (::)/2, (le)/2, (lt)/2, (ne)/2, add/3, mult/3.
|
||||
%% X::Dom - X must be element of the finite list domain Dom
|
||||
|
||||
%% special cases
|
||||
X::[] <=> fail.
|
||||
%%X::[Y] <=> X=Y.
|
||||
%%X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true).
|
||||
|
||||
%% intersection of domains for the same variable
|
||||
X::L1, X::L2 <=> is_list(L1), is_list(L2) |
|
||||
intersection(L1,L2,L) , X::L.
|
||||
|
||||
X::L, X::Min..Max <=> is_list(L) |
|
||||
remove_lower(Min,L,L1), remove_higher(Max,L1,L2),
|
||||
X::L2.
|
||||
|
||||
|
||||
%% interaction with inequalities
|
||||
|
||||
X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2),
|
||||
min_list(L1,MinX), min_list(L2,MinY), MinX > MinY |
|
||||
max_list(L2,MaxY), Y::MinX..MaxY.
|
||||
X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2),
|
||||
max_list(L1,MaxX), max_list(L2,MaxY), MaxX > MaxY |
|
||||
min_list(L1,MinX), X::MinX..MaxY.
|
||||
|
||||
X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2),
|
||||
max_list(L1,MaxX), max_list(L2,MaxY),
|
||||
MaxY1 is MaxY - 1, MaxY1 < MaxX |
|
||||
min_list(L1,MinX), X::MinX..MaxY1.
|
||||
X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2),
|
||||
min_list(L1,MinX), min_list(L2,MinY),
|
||||
MinX1 is MinX + 1, MinX1 > MinY |
|
||||
max_list(L2,MaxY), Y :: MinX1..MaxY.
|
||||
|
||||
X ne Y \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1.
|
||||
Y ne X \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1.
|
||||
Y::D \ X ne Y <=> ground(X), is_list(D), \+ member(X,D) | true.
|
||||
Y::D \ Y ne X <=> ground(X), is_list(D), \+ member(X,D) | true.
|
||||
|
||||
|
||||
%% interaction with addition
|
||||
%% no backpropagation yet!
|
||||
|
||||
add(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) |
|
||||
all_addition(L1,L2,L3), Z::L3.
|
||||
|
||||
%% interaction with multiplication
|
||||
%% no backpropagation yet!
|
||||
|
||||
mult(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) |
|
||||
all_multiplication(L1,L2,L3), Z::L3.
|
||||
|
||||
|
||||
%% auxiliary predicates =============================================
|
||||
|
||||
remove_lower(_,[],L1):- !, L1=[].
|
||||
remove_lower(Min,[X|L],L1):-
|
||||
X@<Min,
|
||||
!,
|
||||
remove_lower(Min,L,L1).
|
||||
remove_lower(Min,[X|L],[X|L1]):-
|
||||
remove_lower(Min,L,L1).
|
||||
|
||||
remove_higher(_,[],L1):- !, L1=[].
|
||||
remove_higher(Max,[X|L],L1):-
|
||||
X@>Max,
|
||||
!,
|
||||
remove_higher(Max,L,L1).
|
||||
remove_higher(Max,[X|L],[X|L1]):-
|
||||
remove_higher(Max,L,L1).
|
||||
|
||||
intersection([], _, []).
|
||||
intersection([Head|L1tail], L2, L3) :-
|
||||
memberchk(Head, L2),
|
||||
!,
|
||||
L3 = [Head|L3tail],
|
||||
intersection(L1tail, L2, L3tail).
|
||||
intersection([_|L1tail], L2, L3) :-
|
||||
intersection(L1tail, L2, L3).
|
||||
|
||||
all_addition(L1,L2,L3) :-
|
||||
setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X + Y), L3).
|
||||
|
||||
all_multiplication(L1,L2,L3) :-
|
||||
setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X * Y), L3).
|
||||
|
||||
|
||||
%% EXAMPLE ==========================================================
|
||||
|
||||
/*
|
||||
?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y,
|
||||
add(X,Y,Z), mult(X,Y,Z).
|
||||
*/
|
||||
|
||||
%% end of handler listdom.pl =================================================
|
||||
%% ===========================================================================
|
||||
|
||||
|
||||
/*
|
||||
|
||||
?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y,
|
||||
add(X,Y,Z), mult(X,Y,Z).
|
||||
|
||||
Bad call to builtin predicate: _9696 =.. ['add/3__0',AttVar4942,AttVar5155,AttVar6836|_9501] in predicate mknewterm / 3
|
||||
*/
|
|
@ -0,0 +1,30 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Sieve of eratosthenes to compute primes
|
||||
%% thom fruehwirth 920218-20, 980311
|
||||
%% christian holzbaur 980207 for Sicstus CHR
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(primes,[]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints candidate/1.
|
||||
:- constraints prime/1.
|
||||
|
||||
|
||||
candidate(1) <=> true.
|
||||
candidate(N) <=> primes:prime(N), N1 is N - 1, primes:candidate(N1).
|
||||
|
||||
absorb @ prime(Y) \ prime(X) <=> 0 is X mod Y | true.
|
||||
|
||||
time(N):-
|
||||
cputime(X),
|
||||
candidate(N),
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(N-Time), nl.
|
||||
|
||||
cputime( Ts) :-
|
||||
statistics( runtime, [Tm,_]),
|
||||
Ts is Tm/1000.
|
|
@ -0,0 +1,114 @@
|
|||
################################################################
|
||||
# SWI-Prolog CHR package
|
||||
# Author: Tom Schrijvers and many others
|
||||
# Copyright: LGPL (see COPYING or www.gnu.org
|
||||
################################################################
|
||||
|
||||
PACKAGE=chr
|
||||
include ../Makefile.defs
|
||||
|
||||
CHRDIR=$(PLLIBDIR)/chr
|
||||
EXDIR=$(PKGEXDIR)/chr
|
||||
|
||||
LIBPL= $(srcdir)/chr_runtime.pl $(srcdir)/chr_op.pl \
|
||||
chr_translate.pl $(srcdir)/chr_debug.pl \
|
||||
$(srcdir)/chr_messages.pl \
|
||||
$(srcdir)/pairlist.pl $(srcdir)/clean_code.pl \
|
||||
$(srcdir)/find.pl $(srcdir)/a_star.pl \
|
||||
$(srcdir)/binomialheap.pl $(srcdir)/builtins.pl \
|
||||
$(srcdir)/chr_hashtable_store.pl $(srcdir)/listmap.pl \
|
||||
guard_entailment.pl \
|
||||
$(srcdir)/chr_compiler_options.pl \
|
||||
$(srcdir)/chr_compiler_utility.pl \
|
||||
$(srcdir)/chr_compiler_errors.pl \
|
||||
$(srcdir)/chr_integertable_store.pl
|
||||
CHRPL= $(srcdir)/chr_swi.pl
|
||||
EXAMPLES= chrfreeze.chr fib.chr gcd.chr primes.chr \
|
||||
bool.chr family.chr fibonacci.chr leq.chr listdom.chr \
|
||||
chrdif.chr
|
||||
|
||||
all: chr_translate.pl
|
||||
|
||||
chr_translate_bootstrap.pl:
|
||||
|
||||
chr_translate_bootstrap1.pl: $(srcdir)/chr_translate_bootstrap1.chr $(srcdir)/chr_translate_bootstrap.pl
|
||||
$(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step1('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step2('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
chr_translate_bootstrap2.pl: $(srcdir)/chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl
|
||||
$(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step2('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step3('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
guard_entailment.pl: $(srcdir)/guard_entailment.chr chr_translate_bootstrap2.pl
|
||||
$(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step3('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
chr_translate.pl: $(srcdir)/chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl
|
||||
$(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step3('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -p chr=. -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -p chr=. -q -f $(srcdir)/chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step4('$<','$@'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
chr.pl: $(srcdir)/chr_swi.pl
|
||||
cp $< $@
|
||||
|
||||
install: all $(DESTDIR)$(PLLIBDIR) install-examples
|
||||
mkdir -p $(DESTDIR)$(CHRDIR)
|
||||
$(INSTALL_DATA) $(LIBPL) $(DESTDIR)$(CHRDIR)
|
||||
$(INSTALL_DATA) $(CHRPL) $(DESTDIR)$(PLLIBDIR)/chr.pl
|
||||
$(INSTALL_DATA) $(srcdir)/README $(DESTDIR)$(CHRDIR)
|
||||
$(MKINDEX)
|
||||
|
||||
$(DESTDIR)$(PLLIBDIR):
|
||||
mkdir $@
|
||||
|
||||
ln-install::
|
||||
@$(MAKE) INSTALL_DATA='../ln-install' install
|
||||
|
||||
rpm-install: install
|
||||
|
||||
pdf-install: install-examples
|
||||
|
||||
html-install: install-examples
|
||||
|
||||
install-examples::
|
||||
mkdir -p $(DESTDIR)$(EXDIR)
|
||||
for i in $(EXAMPLES); do \
|
||||
$(INSTALL_DATA) $(srcdir)/Examples/$$i $(DESTDIR)$(EXDIR); \
|
||||
done
|
||||
|
||||
uninstall:
|
||||
(cd $(PLBASE)/library && rm -f $(LIBPL))
|
||||
@IN_SWI@$$(PL) -f none -g make -t halt
|
||||
|
||||
check: chr.pl
|
||||
$(PL) -q -f $(srcdir)/chr_test.pl -g test,halt -t 'halt(1)'
|
||||
|
||||
|
||||
################################################################
|
||||
# Clean
|
||||
################################################################
|
||||
|
||||
clean:
|
||||
rm -f *~ *.o *.@SO@ *% config.log
|
||||
rm -f chr.pl chr_translate.pl
|
||||
rm -f chr_translate_bootstrap1.pl chr_translate_bootstrap2.pl
|
||||
rm -f guard_entailment.pl
|
||||
|
||||
distclean: clean
|
||||
rm -f config.h config.cache config.status Makefile
|
||||
rm -f $(TEX)
|
|
@ -0,0 +1,111 @@
|
|||
################################################################
|
||||
# Install CHR stuff for the MS-Windows build
|
||||
# Author: Jan Wielemaker
|
||||
#
|
||||
# Use:
|
||||
# nmake /f Makefile.mak
|
||||
# nmake /f Makefile.mak install
|
||||
################################################################
|
||||
|
||||
PLHOME=..\..
|
||||
!include $(PLHOME)\src\rules.mk
|
||||
CFLAGS=$(CFLAGS) /D__SWI_PROLOG__
|
||||
LIBDIR=$(PLBASE)\library
|
||||
EXDIR=$(PKGDOC)\examples\chr
|
||||
CHR=$(LIBDIR)\chr
|
||||
PL="$(PLHOME)\bin\swipl.exe"
|
||||
|
||||
LIBPL= chr_runtime.pl chr_op.pl chr_translate.pl chr_debug.pl \
|
||||
chr_messages.pl hprolog.pl pairlist.pl clean_code.pl \
|
||||
find.pl a_star.pl binomialheap.pl builtins.pl \
|
||||
chr_hashtable_store.pl listmap.pl guard_entailment.pl \
|
||||
chr_compiler_options.pl chr_compiler_utility.pl \
|
||||
chr_compiler_errors.pl \
|
||||
chr_integertable_store.pl
|
||||
CHRPL= chr_swi.pl
|
||||
EXAMPLES= chrfreeze.chr fib.chr gcd.chr primes.chr \
|
||||
bool.chr family.chr fibonacci.chr leq.chr listdom.chr \
|
||||
chrdif.chr
|
||||
|
||||
|
||||
all: chr_translate.pl
|
||||
|
||||
chr_support.dll: chr_support.obj
|
||||
$(LD) /dll /out:$@ $(LDFLAGS) chr_support.obj $(PLLIB)
|
||||
|
||||
chr_translate_bootstrap1.pl: chr_translate_bootstrap1.chr
|
||||
$(PL) -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step1('chr_translate_bootstrap1.chr','chr_translate_bootstrap1.pl'),halt" \
|
||||
-t "halt(1)"
|
||||
$(PL) -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step2('chr_translate_bootstrap1.chr','chr_translate_bootstrap1.pl'),halt" \
|
||||
-t "halt(1)"
|
||||
|
||||
chr_translate_bootstrap2.pl: chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl
|
||||
$(PL) -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step2('chr_translate_bootstrap2.chr','chr_translate_bootstrap2.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step3('chr_translate_bootstrap2.chr','chr_translate_bootstrap2.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
guard_entailment.pl: guard_entailment.chr chr_translate_bootstrap2.pl
|
||||
$(PL) -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step3('guard_entailment.chr','guard_entailment.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
chr_translate.pl: chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl
|
||||
$(PL) -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step3('chr_translate.chr','chr_translate.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -p chr=. -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
$(PL) -p chr=. -q -f chr_swi_bootstrap.pl \
|
||||
-g "chr_compile_step4('chr_translate.chr','chr_translate.pl'),halt" \
|
||||
-t 'halt(1)'
|
||||
|
||||
chr.pl: chr_swi.pl
|
||||
copy chr_swi.pl chr.pl
|
||||
|
||||
check: chr.pl
|
||||
$(PL) -q -f chr_test.pl -g test,halt -t 'halt(1)'
|
||||
|
||||
|
||||
!IF "$(CFG)" == "rt"
|
||||
install::
|
||||
!ELSE
|
||||
install::
|
||||
@if not exist "$(CHR)\$(NULL)" $(MKDIR) "$(CHR)"
|
||||
@for %f in ($(LIBPL)) do \
|
||||
copy "%f" "$(CHR)"
|
||||
copy $(CHRPL) "$(LIBDIR)\chr.pl"
|
||||
copy README "$(CHR)\README.TXT"
|
||||
$(MAKEINDEX)
|
||||
!ENDIF
|
||||
|
||||
html-install: install-examples
|
||||
pdf-install: install-examples
|
||||
|
||||
install-examples::
|
||||
if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)"
|
||||
cd examples & @for %f in ($(EXAMPLES)) do @copy %f "$(EXDIR)"
|
||||
|
||||
xpce-install::
|
||||
|
||||
uninstall::
|
||||
@for %f in ($(LIBPL)) do \
|
||||
del "$(CHR)\%f"
|
||||
del "$(CHR)\README.TXT"
|
||||
del "$(LIBDIR)\chr.pl"
|
||||
$(MAKEINDEX)
|
||||
|
||||
clean::
|
||||
if exist *~ del *~
|
||||
-del chr.pl chr_translate.pl
|
||||
-del chr_translate_bootstrap1.pl chr_translate_bootstrap2.pl
|
||||
-del guard_entailment.pl
|
||||
|
||||
distclean: clean
|
||||
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
CHR for SWI-Prolog
|
||||
==================
|
||||
|
||||
Authors and license
|
||||
====================
|
||||
|
||||
This package contains code from the following authors. All code is
|
||||
distributed under the SWI-Prolog conditions with permission from the
|
||||
authors.
|
||||
|
||||
|
||||
* Tom Schrijvers, K.U.Leuven Tom.Schrijvers@cs.kuleuven.be
|
||||
* Christian Holzbaur christian@ai.univie.ac.at
|
||||
* Jan Wielemaker jan@swi-prolog.org
|
||||
|
||||
|
||||
Files and their roles:
|
||||
======================
|
||||
|
||||
# library(chr) chr_swi.pl
|
||||
Make user-predicates and hooks for loading CHR files available
|
||||
to the user.
|
||||
|
||||
# library(chr/chr_op)
|
||||
Include file containing the operator declaractions
|
||||
|
||||
# library(chr/chr_translate)
|
||||
Core translation module. Defines chr_translate/2.
|
||||
|
||||
# library(chr/chr_debug)
|
||||
Debugging routines, made available to the user through
|
||||
library(chr). Very incomplete.
|
||||
|
||||
# library(chr/hprolog)
|
||||
Compatibility to hProlog. Should be abstracted.
|
||||
|
||||
# library(chr/pairlist)
|
||||
Deal with lists of Name-Value. Used by chr_translate.pl
|
||||
|
||||
|
||||
Status
|
||||
======
|
||||
|
||||
Work in progress. The compiler source (chr_translate.pl) contains
|
||||
various `todo' issues. The debugger is almost non existent. Future work
|
||||
should improve on the compatibility with the reference CHR
|
||||
documentation. Details on loading CHR files are subject to change.
|
|
@ -0,0 +1,26 @@
|
|||
:- module(dense_int,[dense_int/0]).
|
||||
|
||||
:-use_module(library(chr)).
|
||||
|
||||
:-chr_type 'Arity' == dense_int.
|
||||
|
||||
:-chr_constraint c1(+'Arity').
|
||||
|
||||
:-chr_option(line_numbers, on).
|
||||
:-chr_option(check_guard_bindings, on).
|
||||
:-chr_option(debug, off).
|
||||
:-chr_option(optimize, full).
|
||||
|
||||
dense_int :-
|
||||
c1(1),
|
||||
c1(1).
|
||||
|
||||
|
||||
no_duplicates @
|
||||
c1(X)
|
||||
\
|
||||
c1(X)
|
||||
<=>
|
||||
true.
|
||||
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven
|
||||
%%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(fibonacci,[fibonacci/0]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint fibonacci/2, cleanup/1.
|
||||
|
||||
%% fibonacci(N,M) is true iff M is the Nth Fibonacci number.
|
||||
|
||||
%% Top-down Evaluation with effective Tabulation
|
||||
%% Contrary to the version in the SICStus manual, this one does "true"
|
||||
%% tabulation
|
||||
|
||||
fibonacci(N,M1) # ID \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(ID).
|
||||
|
||||
fibonacci(0,M) ==> M = 1.
|
||||
|
||||
fibonacci(1,M) ==> M = 1.
|
||||
|
||||
fibonacci(N,M) ==>
|
||||
N > 1 |
|
||||
N1 is N-1,
|
||||
fibonacci(N1,M1),
|
||||
N2 is N-2,
|
||||
fibonacci(N2,M2),
|
||||
M is M1 + M2.
|
||||
|
||||
cleanup(L), fibonacci(N,F) <=> L = [N-F|T], cleanup(T).
|
||||
cleanup(L) <=> L = [].
|
||||
|
||||
fibonacci :-
|
||||
fibonacci(15,F),
|
||||
F == 987,
|
||||
cleanup(L),
|
||||
sort(L,SL),
|
||||
SL == [0 - 1,1 - 1,2 - 2,3 - 3,4 - 5,5 - 8,6 - 13,7 - 21,8 - 34,9 - 55,10 - 89,11 - 144,12 - 233,13 - 377,14 - 610,15 - 987].
|
|
@ -0,0 +1,27 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% simple constraint solver for inequalities between variables
|
||||
%% thom fruehwirth ECRC 950519, LMU 980207, 980311
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(leq,[leq/0]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint leq/2.
|
||||
|
||||
reflexivity @ leq(X,X) <=> true.
|
||||
antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y.
|
||||
idempotence @ leq(X,Y) \ leq(X,Y) <=> true.
|
||||
transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z).
|
||||
|
||||
leq :-
|
||||
circle(X, Y, Z),
|
||||
\+ attvar(X),
|
||||
X == Y,
|
||||
Y == Z.
|
||||
|
||||
circle(X, Y, Z) :-
|
||||
leq(X, Y),
|
||||
leq(Y, Z),
|
||||
leq(Z, X).
|
|
@ -0,0 +1,12 @@
|
|||
:- module(passive_check,[passive_check/0]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint a/1, b/1.
|
||||
|
||||
:- chr_option(debug,off).
|
||||
:- chr_option(optimize,full).
|
||||
|
||||
a(X) # ID, b(X) <=> true pragma passive(ID).
|
||||
|
||||
passive_check :-
|
||||
a(_).
|
|
@ -0,0 +1,12 @@
|
|||
:- module(passive_check2,[passive_check2/0]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint a/1, b/2.
|
||||
|
||||
:- chr_option(debug,off).
|
||||
:- chr_option(optimize,full).
|
||||
|
||||
a(X) # ID, b(X,R) <=> R = 1 pragma passive(ID).
|
||||
|
||||
passive_check2 :-
|
||||
a(X), b(X,R), R == 1.
|
|
@ -0,0 +1,41 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Sieve of eratosthenes to compute primes
|
||||
%% thom fruehwirth 920218-20, 980311
|
||||
%% christian holzbaur 980207 for Sicstus CHR
|
||||
%%
|
||||
%% ported to hProlog by Tom Schrijvers
|
||||
|
||||
:- module(primes,[primes/0]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint candidate/1.
|
||||
:- chr_constraint prime/1.
|
||||
:- chr_constraint cleanup/1.
|
||||
|
||||
:- chr_option(debug,off).
|
||||
:- chr_option(optimize,full).
|
||||
|
||||
candidate(1) <=> true.
|
||||
candidate(N) <=> prime(N), N1 is N - 1, candidate(N1).
|
||||
|
||||
absorb @ prime(Y) \ prime(X) <=> 0 =:= X mod Y | true.
|
||||
|
||||
cleanup(_L), candidate(_X) <=> fail.
|
||||
cleanup(L), prime(N) <=> L = [N|T], cleanup(T).
|
||||
cleanup(L) <=> L = [].
|
||||
|
||||
primes :-
|
||||
candidate(100),
|
||||
cleanup(L),
|
||||
sort(L,SL),
|
||||
SL == [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97].
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
:- module(trigger_no_active_occurrence,[trigger_no_active_occurrence/0]).
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- chr_constraint a/1, b/2.
|
||||
|
||||
a(X) # ID , b(X,R) <=> R = 1 pragma passive(ID).
|
||||
|
||||
trigger_no_active_occurrence :-
|
||||
a(X),
|
||||
X = 1,
|
||||
b(1,R),
|
||||
R == 1.
|
|
@ -0,0 +1,117 @@
|
|||
:- module(zebra,[zebra/0]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- use_module(library(lists)).
|
||||
|
||||
/*
|
||||
1. The Englishman lives in the red house.
|
||||
2. The Spaniard owns the dog.
|
||||
3. Coffee is drunk in the green house.
|
||||
4. The Ukrainian drinks tea.
|
||||
5. The green house is immediately to the right of the ivory house.
|
||||
6. The Porsche driver owns snails.
|
||||
7. The Masserati is driven by the man who lives in the yellow house.
|
||||
8. Milk is drunk in the middle house.
|
||||
9. The Norwegian lives in the first house on the left.
|
||||
10. The man who drives a Saab lives in the house next to the man
|
||||
with the fox.
|
||||
11. The Masserati is driven by the man in the house next to the
|
||||
house where the horse is kept.
|
||||
12. The Honda driver drinks orange juice.
|
||||
13. The Japanese drives a Jaguar.
|
||||
14. The Norwegian lives next to the blue house.
|
||||
*/
|
||||
|
||||
:- chr_constraint domain/2, diff/2, cleanup/0.
|
||||
|
||||
zebra :-
|
||||
solve(Solution),
|
||||
cleanup,
|
||||
Solution == [[yellow,norwegian,masserati,water,fox],[blue,ukranian,saab,tea,horse],[red,english,porsche,milk,snails],[ivory,spanish,honda,orange,dog],[green,japanese,jaguar,coffee,zebra]].
|
||||
|
||||
domain(_X,[]) <=> fail.
|
||||
domain(X,[V]) <=> X = V.
|
||||
domain(X,L1), domain(X,L2) <=> intersection(L1,L2,L3), domain(X,L3).
|
||||
|
||||
diff(X,Y), domain(X,L) <=> nonvar(Y) | select(Y,L,NL), domain(X,NL).
|
||||
diff(X,Y) <=> nonvar(X), nonvar(Y) | X \== Y.
|
||||
|
||||
cleanup, domain(_,_) <=> writeln(a), fail.
|
||||
cleanup, diff(_,_) <=> writeln(b), fail.
|
||||
cleanup <=> true.
|
||||
|
||||
all_different([]).
|
||||
all_different([H|T]) :-
|
||||
all_different(T,H),
|
||||
all_different(T).
|
||||
|
||||
all_different([],_).
|
||||
all_different([H|T],E) :-
|
||||
diff(H,E),
|
||||
diff(E,H),
|
||||
all_different(T,E).
|
||||
|
||||
solve(S) :-
|
||||
[ [ ACo, AN, ACa, AD, AP ],
|
||||
[ BCo, BN, BCa, BD, BP ],
|
||||
[ CCo, CN, CCa, CD, CP ],
|
||||
[ DCo, DN, DCa, DD, DP ],
|
||||
[ ECo, EN, ECa, ED, EP ] ] = S,
|
||||
domain(ACo,[red,green,ivory,yellow,blue]),
|
||||
domain(BCo,[red,green,ivory,yellow,blue]),
|
||||
domain(CCo,[red,green,ivory,yellow,blue]),
|
||||
domain(DCo,[red,green,ivory,yellow,blue]),
|
||||
domain(ECo,[red,green,ivory,yellow,blue]),
|
||||
domain(AN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(BN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(CN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(DN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(EN ,[english,spanish,ukranian,norwegian,japanese]),
|
||||
domain(ACa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(BCa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(CCa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(DCa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(ECa,[porsche,masserati,saab,honda,jaguar]),
|
||||
domain(AD ,[coffee,tea,milk,orange,water]),
|
||||
domain(BD ,[coffee,tea,milk,orange,water]),
|
||||
domain(CD ,[coffee,tea,milk,orange,water]),
|
||||
domain(DD ,[coffee,tea,milk,orange,water]),
|
||||
domain(ED ,[coffee,tea,milk,orange,water]),
|
||||
domain(AP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(BP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(CP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(DP ,[dog,snails,fox,horse,zebra]),
|
||||
domain(EP ,[dog,snails,fox,horse,zebra]),
|
||||
all_different([ACo,BCo,CCo,DCo,ECo]),
|
||||
all_different([AN ,BN ,CN ,DN ,EN ]),
|
||||
all_different([ACa,BCa,CCa,DCa,ECa]),
|
||||
all_different([AD ,BD ,CD ,DD ,ED ]),
|
||||
all_different([AP ,BP ,CP ,DP ,EP ]),
|
||||
[_,_,[_,_,_,milk,_],_,_] = S, % clue 8
|
||||
[[_,norwegian,_,_,_],_,_,_,_] = S , % clue 9
|
||||
member( [green,_,_,coffee,_], S), % clue 3
|
||||
member( [red,english,_,_,_], S), % clue 1
|
||||
member( [_,ukranian,_,tea,_], S), % clue 4
|
||||
member( [yellow,_,masserati,_,_], S), % clue 7
|
||||
member( [_,_,honda,orange,_], S), % clue 12
|
||||
member( [_,japanese,jaguar,_,_], S), % clue 13
|
||||
member( [_,spanish,_,_,dog], S), % clue 2
|
||||
member( [_,_,porsche,_,snails], S), % clue 6
|
||||
left_right( [ivory,_,_,_,_], [green,_,_,_,_], S), % clue 5
|
||||
next_to( [_,norwegian,_,_,_],[blue,_,_,_,_], S), % clue 14
|
||||
next_to( [_,_,masserati,_,_],[_,_,_,_,horse], S), % clue 11
|
||||
next_to( [_,_,saab,_,_], [_,_,_,_,fox], S), % clue 10
|
||||
true.
|
||||
|
||||
% left_right(L, R, X) is true when L is to the immediate left of R in list X
|
||||
|
||||
left_right(L, R, [L, R | _]).
|
||||
|
||||
left_right(L, R, [_ | X]) :- left_right(L, R, X).
|
||||
|
||||
|
||||
% next_to(X, Y, L) is true when X and Y are next to each other in list L
|
||||
|
||||
next_to(X, Y, L) :- left_right(X, Y, L).
|
||||
|
||||
next_to(X, Y, L) :- left_right(Y, X, L).
|
|
@ -0,0 +1,77 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(a_star,
|
||||
[
|
||||
a_star/4
|
||||
]).
|
||||
|
||||
:- use_module(binomialheap).
|
||||
|
||||
:- use_module(find).
|
||||
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
|
||||
a_star(DataIn,FinalData,ExpandData,DataOut) :-
|
||||
a_star_node(DataIn,0,InitialNode),
|
||||
empty_q(NewQueue),
|
||||
insert_q(NewQueue,InitialNode,Queue),
|
||||
a_star_aux(Queue,FinalData,ExpandData,EndNode),
|
||||
a_star_node(DataOut,_,EndNode).
|
||||
|
||||
a_star_aux(Queue,FinalData,ExpandData,EndNode) :-
|
||||
delete_min_q(Queue,Queue1,Node),
|
||||
( final_node(FinalData,Node) ->
|
||||
Node = EndNode
|
||||
;
|
||||
expand_node(ExpandData,Node,Nodes),
|
||||
insert_list_q(Nodes,Queue1,NQueue),
|
||||
a_star_aux(NQueue,FinalData,ExpandData,EndNode)
|
||||
).
|
||||
|
||||
final_node(D^Call,Node) :-
|
||||
a_star_node(Data,_,Node),
|
||||
term_variables(Call,Vars),
|
||||
chr_delete(Vars,D,DVars),
|
||||
copy_term(D^Call-DVars,Data^NCall-DVars),
|
||||
call(NCall).
|
||||
|
||||
expand_node(D^Ds^C^Call,Node,Nodes) :-
|
||||
a_star_node(Data,Score,Node),
|
||||
term_variables(Call,Vars),
|
||||
chr_delete(Vars,D,DVars0),
|
||||
chr_delete(DVars0,Ds,DVars1),
|
||||
chr_delete(DVars1,C,DVars),
|
||||
copy_term(D^Ds^C^Call-DVars,Data^EData^Cost^NCall-DVars),
|
||||
term_variables(Node,NVars,DVars),
|
||||
find_with_var_identity(ENode,NVars,(NCall,EScore is Cost + Score,a_star:a_star_node(EData,EScore,ENode)),Nodes).
|
||||
|
||||
a_star_node(Data,Score,Data-Score).
|
|
@ -0,0 +1,139 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Binomial Heap imlementation based on
|
||||
%
|
||||
% Functional Binomial Queues
|
||||
% James F. King
|
||||
% University of Glasgow
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- module(binomialheap,
|
||||
[
|
||||
empty_q/1,
|
||||
insert_q/3,
|
||||
insert_list_q/3,
|
||||
delete_min_q/3,
|
||||
find_min_q/2
|
||||
]).
|
||||
|
||||
:- use_module(library(lists),[reverse/2]).
|
||||
|
||||
% data Tree a = Node a [Tree a]
|
||||
% type BinQueue a = [Maybe (Tree a)]
|
||||
% data Maybe a = Zero | One a
|
||||
% type Item = (Entry,Key)
|
||||
|
||||
key(_-Key,Key).
|
||||
|
||||
empty_q([]).
|
||||
|
||||
meld_q(P,Q,R) :-
|
||||
meld_qc(P,Q,zero,R).
|
||||
|
||||
meld_qc([],Q,zero,Q) :- !.
|
||||
meld_qc([],Q,C,R) :- !,
|
||||
meld_q(Q,[C],R).
|
||||
meld_qc(P,[],C,R) :- !,
|
||||
meld_qc([],P,C,R).
|
||||
meld_qc([zero|Ps],[zero|Qs],C,R) :- !,
|
||||
R = [C | Rs],
|
||||
meld_q(Ps,Qs,Rs).
|
||||
meld_qc([one(node(X,Xs))|Ps],[one(node(Y,Ys))|Qs],C,R) :- !,
|
||||
key(X,KX),
|
||||
key(Y,KY),
|
||||
( KX < KY ->
|
||||
T = node(X,[node(Y,Ys)|Xs])
|
||||
;
|
||||
T = node(Y,[node(X,Xs)|Ys])
|
||||
),
|
||||
R = [C|Rs],
|
||||
meld_qc(Ps,Qs,one(T),Rs).
|
||||
meld_qc([P|Ps],[Q|Qs],C,Rs) :-
|
||||
meld_qc([Q|Ps],[C|Qs],P,Rs).
|
||||
|
||||
insert_q(Q,I,NQ) :-
|
||||
meld_q([one(node(I,[]))],Q,NQ).
|
||||
|
||||
insert_list_q([],Q,Q).
|
||||
insert_list_q([I|Is],Q,NQ) :-
|
||||
insert_q(Q,I,Q1),
|
||||
insert_list_q(Is,Q1,NQ).
|
||||
|
||||
min_tree([T|Ts],MT) :-
|
||||
min_tree_acc(Ts,T,MT).
|
||||
|
||||
min_tree_acc([],MT,MT).
|
||||
min_tree_acc([T|Ts],Acc,MT) :-
|
||||
least(T,Acc,NAcc),
|
||||
min_tree_acc(Ts,NAcc,MT).
|
||||
|
||||
least(zero,T,T) :- !.
|
||||
least(T,zero,T) :- !.
|
||||
least(one(node(X,Xs)),one(node(Y,Ys)),T) :-
|
||||
key(X,KX),
|
||||
key(Y,KY),
|
||||
( KX < KY ->
|
||||
T = one(node(X,Xs))
|
||||
;
|
||||
T = one(node(Y,Ys))
|
||||
).
|
||||
|
||||
remove_tree([],_,[]).
|
||||
remove_tree([T|Ts],I,[NT|NTs]) :-
|
||||
( T == zero ->
|
||||
NT = T
|
||||
;
|
||||
T = one(node(X,_)),
|
||||
( X == I ->
|
||||
NT = zero
|
||||
;
|
||||
NT = T
|
||||
)
|
||||
),
|
||||
remove_tree(Ts,I,NTs).
|
||||
|
||||
delete_min_q(Q,NQ,Min) :-
|
||||
min_tree(Q,one(node(Min,Ts))),
|
||||
remove_tree(Q,Min,Q1),
|
||||
reverse(Ts,RTs),
|
||||
make_ones(RTs,Q2),
|
||||
meld_q(Q2,Q1,NQ).
|
||||
|
||||
make_ones([],[]).
|
||||
make_ones([N|Ns],[one(N)|RQ]) :-
|
||||
make_ones(Ns,RQ).
|
||||
|
||||
find_min_q(Q,I) :-
|
||||
min_tree(Q,one(node(I,_))).
|
||||
|
||||
|
|
@ -0,0 +1,625 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(builtins,
|
||||
[
|
||||
negate_b/2,
|
||||
entails_b/2,
|
||||
binds_b/2,
|
||||
builtin_binds_b/2
|
||||
]).
|
||||
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
negate_b(A,B) :- once(negate(A,B)).
|
||||
negate((A,B),NotB) :- A==true,negate(B,NotB). % added by jon
|
||||
negate((A,B),NotA) :- B==true,negate(A,NotA). % added by jon
|
||||
negate((A,B),(NotA;NotB)) :- negate(A,NotA),negate(B,NotB). % added by jon
|
||||
negate((A;B),(NotA,NotB)) :- negate(A,NotA),negate(B,NotB). % added by jon
|
||||
negate(true,fail).
|
||||
negate(fail,true).
|
||||
negate(X =< Y, Y < X).
|
||||
negate(X > Y, Y >= X).
|
||||
negate(X >= Y, Y > X).
|
||||
negate(X < Y, Y =< X).
|
||||
negate(X == Y, X \== Y). % added by jon
|
||||
negate(X \== Y, X == Y). % added by jon
|
||||
negate(X =:= Y, X =\= Y). % added by jon
|
||||
negate(X is Y, X =\= Y). % added by jon
|
||||
negate(X =\= Y, X =:= Y). % added by jon
|
||||
negate(X = Y, X \= Y). % added by jon
|
||||
negate(X \= Y, X = Y). % added by jon
|
||||
negate(var(X),nonvar(X)).
|
||||
negate(nonvar(X),var(X)).
|
||||
negate(\+ X,X). % added by jon
|
||||
negate(X,\+ X). % added by jon
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
entails_b(fail,_) :-!.
|
||||
entails_b(A,B) :-
|
||||
( var(B) ->
|
||||
entails(A,B,[A])
|
||||
;
|
||||
once((
|
||||
entails(A,C,[A]),
|
||||
B == C
|
||||
))
|
||||
).
|
||||
|
||||
entails(A,A,_).
|
||||
entails(A,C,History) :-
|
||||
entails_(A,B),
|
||||
\+ memberchk_eq(B,History),
|
||||
entails(B,C,[B|History]).
|
||||
|
||||
entails_(X > Y, X >= Y).
|
||||
entails_(X > Y, Y < X).
|
||||
entails_(X >= Y, Y =< X).
|
||||
entails_(X =< Y, Y >= X). %added by jon
|
||||
entails_(X < Y, Y > X).
|
||||
entails_(X < Y, X =< Y).
|
||||
entails_(X > Y, X \== Y).
|
||||
entails_(X \== Y, Y \== X).
|
||||
entails_(X == Y, Y == X).
|
||||
entails_(X == Y, X =:= Y) :- ground(X). %added by jon
|
||||
entails_(X == Y, X =:= Y) :- ground(Y). %added by jon
|
||||
entails_(X \== Y, X =\= Y) :- ground(X). %added by jon
|
||||
entails_(X \== Y, X =\= Y) :- ground(Y). %added by jon
|
||||
entails_(X =:= Y, Y =:= X). %added by jon
|
||||
entails_(X =\= Y, Y =\= X). %added by jon
|
||||
entails_(X == Y, X >= Y). %added by jon
|
||||
entails_(X == Y, X =< Y). %added by jon
|
||||
entails_(ground(X),nonvar(X)).
|
||||
entails_(compound(X),nonvar(X)).
|
||||
entails_(atomic(X),nonvar(X)).
|
||||
entails_(number(X),nonvar(X)).
|
||||
entails_(atom(X),nonvar(X)).
|
||||
entails_(fail,true).
|
||||
|
||||
builtin_binds_b(G,Vars) :-
|
||||
builtin_binds_(G,L,[]),
|
||||
sort(L,Vars).
|
||||
|
||||
builtin_binds_(var(_),L,L).
|
||||
builtin_binds_(nonvar(_),L,L).
|
||||
builtin_binds_(ground(_),L,L).
|
||||
builtin_binds_(compound(_),L,L).
|
||||
builtin_binds_(number(_),L,L).
|
||||
builtin_binds_(atom(_),L,L).
|
||||
builtin_binds_(atomic(_),L,L).
|
||||
builtin_binds_(integer(_),L,L).
|
||||
builtin_binds_(float(_),L,L).
|
||||
|
||||
builtin_binds_(?=(_, _), L, L).
|
||||
builtin_binds_(_<_, L, L).
|
||||
builtin_binds_(_=:=_, L, L).
|
||||
builtin_binds_(_=<_, L, L).
|
||||
builtin_binds_(_==_, L, L).
|
||||
builtin_binds_(_=@=_, L, L).
|
||||
builtin_binds_(_=\=_, L, L).
|
||||
builtin_binds_(_>=_, L, L).
|
||||
builtin_binds_(_>_, L, L).
|
||||
builtin_binds_(_@<_, L, L).
|
||||
builtin_binds_(_@=<_, L, L).
|
||||
builtin_binds_(_@>=_, L, L).
|
||||
builtin_binds_(_@>_, L, L).
|
||||
builtin_binds_(_\==_, L, L).
|
||||
builtin_binds_(_\=@=_, L, L).
|
||||
builtin_binds_(true,L,L).
|
||||
|
||||
% TODO: check all these SWI-Prolog built-ins for binding behavior.
|
||||
%
|
||||
% builtin_binds_(format(_,_),L,L).
|
||||
% builtin_binds_(portray(_), L, L).
|
||||
% builtin_binds_(write(_), L, L).
|
||||
% builtin_binds_(write(_),L,L).
|
||||
% builtin_binds_(write(_, _), L, L).
|
||||
% builtin_binds_(write_canonical(_), L, L).
|
||||
% builtin_binds_(write_canonical(_, _), L, L).
|
||||
% builtin_binds_(write_term(_, _), L, L).
|
||||
% builtin_binds_(write_term(_, _, _), L, L).
|
||||
% builtin_binds_(writef(_), L, L).
|
||||
% builtin_binds_(writef(_, _), L, L).
|
||||
% builtin_binds_(writeln(_), L, L).
|
||||
% builtin_binds_(writeln(_),L,L).
|
||||
% builtin_binds_(writeq(_), L, L).
|
||||
% builtin_binds_(writeq(_, _), L, L).
|
||||
%
|
||||
% builtin_binds_(!(_), L, L).
|
||||
% builtin_binds_(!, L, L).
|
||||
% builtin_binds_((_'|'_), L, L).
|
||||
% builtin_binds_((_*->_), L, L).
|
||||
% builtin_binds_(abolish(_), L, L).
|
||||
% builtin_binds_(abolish(_, _), L, L).
|
||||
% builtin_binds_(abort, L, L).
|
||||
% builtin_binds_(absolute_file_name(_, _), L, L).
|
||||
% builtin_binds_(absolute_file_name(_, _, _), L, L).
|
||||
% builtin_binds_(access_file(_, _), L, L).
|
||||
% builtin_binds_(acyclic_term(_), L, L).
|
||||
% builtin_binds_(add_import_module(_, _, _), L, L).
|
||||
% builtin_binds_(append(_), L, L).
|
||||
% builtin_binds_(apply(_, _), L, L).
|
||||
% builtin_binds_(arg(_, _, _), L, L).
|
||||
% builtin_binds_(arithmetic_function(_), L, L).
|
||||
% builtin_binds_(assert(_), L, L).
|
||||
% builtin_binds_(assert(_, _), L, L).
|
||||
% builtin_binds_(asserta(_), L, L).
|
||||
% builtin_binds_(asserta(_, _), L, L).
|
||||
% builtin_binds_(assertz(_), L, L).
|
||||
% builtin_binds_(assertz(_, _), L, L).
|
||||
% builtin_binds_(at_end_of_stream(_), L, L).
|
||||
% builtin_binds_(at_end_of_stream, L, L).
|
||||
% builtin_binds_(at_halt(_), L, L).
|
||||
% builtin_binds_(at_initialization(_), L, L).
|
||||
% builtin_binds_(atom(_), L, L).
|
||||
% builtin_binds_(atom_chars(_, _), L, L).
|
||||
% builtin_binds_(atom_codes(_, _), L, L).
|
||||
% builtin_binds_(atom_concat(_, _, _), L, L).
|
||||
% builtin_binds_(atom_length(_, _), L, L).
|
||||
% builtin_binds_(atom_number(_, _), L, L).
|
||||
% builtin_binds_(atom_prefix(_, _), L, L).
|
||||
% builtin_binds_(atom_to_term(_, _, _), L, L).
|
||||
% builtin_binds_(atomic(_), L, L).
|
||||
% builtin_binds_(attvar(_), L, L).
|
||||
% builtin_binds_(autoload(_), L, L).
|
||||
% builtin_binds_(autoload, L, L).
|
||||
% builtin_binds_(b_getval(_, _), L, L).
|
||||
% builtin_binds_(b_setval(_, _), L, L).
|
||||
% builtin_binds_(bagof(_, _, _), L, L).
|
||||
% builtin_binds_(between(_, _, _), L, L).
|
||||
% builtin_binds_(block(_, _, _), L, L).
|
||||
% builtin_binds_(break, L, L).
|
||||
% builtin_binds_(byte_count(_, _), L, L).
|
||||
% builtin_binds_(call(_), L, L).
|
||||
% builtin_binds_(call(_, _), L, L).
|
||||
% builtin_binds_(call(_, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(call(_, _, _, _, _, _, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(call_cleanup(_, _), L, L).
|
||||
% builtin_binds_(call_cleanup(_, _, _), L, L).
|
||||
% builtin_binds_(call_shared_object_function(_, _), L, L).
|
||||
% builtin_binds_(call_with_depth_limit(_, _, _), L, L).
|
||||
% builtin_binds_(callable(_), L, L).
|
||||
% builtin_binds_(catch(_, _, _), L, L).
|
||||
% builtin_binds_(char_code(_, _), L, L).
|
||||
% builtin_binds_(char_conversion(_, _), L, L).
|
||||
% builtin_binds_(char_type(_, _), L, L).
|
||||
% builtin_binds_(character_count(_, _), L, L).
|
||||
% builtin_binds_(clause(_, _), L, L).
|
||||
% builtin_binds_(clause(_, _, _), L, L).
|
||||
% builtin_binds_(clause_property(_, _), L, L).
|
||||
% builtin_binds_(close(_), L, L).
|
||||
% builtin_binds_(close(_, _), L, L).
|
||||
% builtin_binds_(close_shared_object(_), L, L).
|
||||
% builtin_binds_(code_type(_, _), L, L).
|
||||
% builtin_binds_(collation_key(_, _), L, L).
|
||||
% builtin_binds_(compare(_, _, _), L, L).
|
||||
% builtin_binds_(compile_aux_clauses(_), L, L).
|
||||
% builtin_binds_(compile_predicates(_), L, L).
|
||||
% builtin_binds_(compiling, L, L).
|
||||
% builtin_binds_(compound(_), L, L).
|
||||
% builtin_binds_(concat_atom(_, _), L, L).
|
||||
% builtin_binds_(concat_atom(_, _, _), L, L).
|
||||
% builtin_binds_(consult(_), L, L).
|
||||
% builtin_binds_(context_module(_), L, L).
|
||||
% builtin_binds_(copy_stream_data(_, _), L, L).
|
||||
% builtin_binds_(copy_stream_data(_, _, _), L, L).
|
||||
% builtin_binds_(copy_term(_, _), L, L).
|
||||
% builtin_binds_(copy_term_nat(_, _), L, L).
|
||||
% builtin_binds_(current_arithmetic_function(_), L, L).
|
||||
% builtin_binds_(current_atom(_), L, L).
|
||||
% builtin_binds_(current_blob(_, _), L, L).
|
||||
% builtin_binds_(current_char_conversion(_, _), L, L).
|
||||
% builtin_binds_(current_flag(_), L, L).
|
||||
% builtin_binds_(current_format_predicate(_, _), L, L).
|
||||
% builtin_binds_(current_functor(_, _), L, L).
|
||||
% builtin_binds_(current_input(_), L, L).
|
||||
% builtin_binds_(current_key(_), L, L).
|
||||
% builtin_binds_(current_module(_), L, L).
|
||||
% builtin_binds_(current_module(_, _), L, L).
|
||||
% builtin_binds_(current_op(_, _, _), L, L).
|
||||
% builtin_binds_(current_output(_), L, L).
|
||||
% builtin_binds_(current_predicate(_), L, L).
|
||||
% builtin_binds_(current_predicate(_, _), L, L).
|
||||
% builtin_binds_(current_prolog_flag(_, _), L, L).
|
||||
% builtin_binds_(current_resource(_, _, _), L, L).
|
||||
% builtin_binds_(current_signal(_, _, _), L, L).
|
||||
% builtin_binds_(cyclic_term(_), L, L).
|
||||
% builtin_binds_(date_time_stamp(_, _), L, L).
|
||||
% builtin_binds_(debugging, L, L).
|
||||
% builtin_binds_(default_module(_, _), L, L).
|
||||
% builtin_binds_(del_attr(_, _), L, L).
|
||||
% builtin_binds_(delete_directory(_), L, L).
|
||||
% builtin_binds_(delete_file(_), L, L).
|
||||
% builtin_binds_(delete_import_module(_, _), L, L).
|
||||
% builtin_binds_(deterministic(_), L, L).
|
||||
% builtin_binds_(downcase_atom(_, _), L, L).
|
||||
% builtin_binds_(duplicate_term(_, _), L, L).
|
||||
% builtin_binds_(dwim_match(_, _), L, L).
|
||||
% builtin_binds_(dwim_match(_, _, _), L, L).
|
||||
% builtin_binds_(dwim_predicate(_, _), L, L).
|
||||
% builtin_binds_(ensure_loaded(_), L, L).
|
||||
% builtin_binds_(erase(_), L, L).
|
||||
% builtin_binds_(eval_license, L, L).
|
||||
% builtin_binds_(exists_directory(_), L, L).
|
||||
% builtin_binds_(exists_file(_), L, L).
|
||||
% builtin_binds_(exit(_, _), L, L).
|
||||
% builtin_binds_(expand_file_name(_, _), L, L).
|
||||
% builtin_binds_(expand_file_search_path(_, _), L, L).
|
||||
% builtin_binds_(expand_goal(_, _), L, L).
|
||||
% builtin_binds_(expand_term(_, _), L, L).
|
||||
% builtin_binds_(export(_), L, L).
|
||||
% builtin_binds_(export_list(_, _), L, L).
|
||||
% builtin_binds_(fail(_), L, L).
|
||||
% builtin_binds_(fail, L, L).
|
||||
% builtin_binds_(file_base_name(_, _), L, L).
|
||||
% builtin_binds_(file_directory_name(_, _), L, L).
|
||||
% builtin_binds_(file_name_extension(_, _, _), L, L).
|
||||
% builtin_binds_(fileerrors(_, _), L, L).
|
||||
% builtin_binds_(findall(_, _, _), L, L).
|
||||
% builtin_binds_(findall(_, _, _, _), L, L).
|
||||
% builtin_binds_(flag(_, _, _), L, L).
|
||||
% builtin_binds_(float(_), L, L).
|
||||
% builtin_binds_(flush_output(_), L, L).
|
||||
% builtin_binds_(flush_output, L, L).
|
||||
% builtin_binds_(forall(_, _), L, L).
|
||||
% builtin_binds_(format(_), L, L).
|
||||
% builtin_binds_(format(_, _), L, L).
|
||||
% builtin_binds_(format(_, _, _), L, L).
|
||||
% builtin_binds_(format_predicate(_, _), L, L).
|
||||
% builtin_binds_(format_time(_, _, _), L, L).
|
||||
% builtin_binds_(format_time(_, _, _, _), L, L).
|
||||
% builtin_binds_(freeze(_, _), L, L).
|
||||
% builtin_binds_(frozen(_, _), L, L).
|
||||
% builtin_binds_(functor(_, _, _), L, L).
|
||||
% builtin_binds_(garbage_collect, L, L).
|
||||
% builtin_binds_(garbage_collect_atoms, L, L).
|
||||
% builtin_binds_(garbage_collect_clauses, L, L).
|
||||
% builtin_binds_(get(_), L, L).
|
||||
% builtin_binds_(get(_, _), L, L).
|
||||
% builtin_binds_(get0(_), L, L).
|
||||
% builtin_binds_(get0(_, _), L, L).
|
||||
% builtin_binds_(get_attr(_, _, _), L, L).
|
||||
% builtin_binds_(get_attrs(_, _), L, L).
|
||||
% builtin_binds_(get_byte(_), L, L).
|
||||
% builtin_binds_(get_byte(_, _), L, L).
|
||||
% builtin_binds_(get_char(_), L, L).
|
||||
% builtin_binds_(get_char(_, _), L, L).
|
||||
% builtin_binds_(get_code(_), L, L).
|
||||
% builtin_binds_(get_code(_, _), L, L).
|
||||
% builtin_binds_(get_single_char(_), L, L).
|
||||
% builtin_binds_(get_time(_), L, L).
|
||||
% builtin_binds_(getenv(_, _), L, L).
|
||||
% builtin_binds_(ground(_), L, L).
|
||||
% builtin_binds_(halt(_), L, L).
|
||||
% builtin_binds_(halt, L, L).
|
||||
% builtin_binds_(hash(_), L, L).
|
||||
% builtin_binds_(term_hash(_, _), L, L).
|
||||
% builtin_binds_(ignore(_), L, L).
|
||||
% builtin_binds_(import(_), L, L).
|
||||
% builtin_binds_(import_module(_, _), L, L).
|
||||
% builtin_binds_(index(_), L, L).
|
||||
% builtin_binds_(integer(_), L, L).
|
||||
% builtin_binds_(is_absolute_file_name(_), L, L).
|
||||
% builtin_binds_(is_list(_), L, L).
|
||||
% builtin_binds_(is_stream(_), L, L).
|
||||
% builtin_binds_(keysort(_, _), L, L).
|
||||
% builtin_binds_(leash(_), L, L).
|
||||
% builtin_binds_(length(_, _), L, L).
|
||||
% builtin_binds_(license(_), L, L).
|
||||
% builtin_binds_(license(_, _), L, L).
|
||||
% builtin_binds_(line_count(_, _), L, L).
|
||||
% builtin_binds_(line_position(_, _), L, L).
|
||||
% builtin_binds_(load_files(_), L, L).
|
||||
% builtin_binds_(load_files(_, _), L, L).
|
||||
% builtin_binds_(make_directory(_), L, L).
|
||||
% builtin_binds_(make_library_index(_), L, L).
|
||||
% builtin_binds_(make_library_index(_, _), L, L).
|
||||
% builtin_binds_(maplist(_, _), L, L).
|
||||
% builtin_binds_(maplist(_, _, _), L, L).
|
||||
% builtin_binds_(maplist(_, _, _, _), L, L).
|
||||
% builtin_binds_(memberchk(_, _), L, L).
|
||||
% builtin_binds_(message_queue_create(_), L, L).
|
||||
% builtin_binds_(message_queue_create(_, _), L, L).
|
||||
% builtin_binds_(message_queue_destroy(_), L, L).
|
||||
% builtin_binds_(message_queue_property(_, _), L, L).
|
||||
% builtin_binds_(message_to_string(_, _), L, L).
|
||||
% builtin_binds_(module(_), L, L).
|
||||
% builtin_binds_(msort(_, _), L, L).
|
||||
% builtin_binds_(mutex_create(_), L, L).
|
||||
% builtin_binds_(mutex_create(_, _), L, L).
|
||||
% builtin_binds_(mutex_destroy(_), L, L).
|
||||
% builtin_binds_(mutex_lock(_), L, L).
|
||||
% builtin_binds_(mutex_property(_, _), L, L).
|
||||
% builtin_binds_(mutex_statistics, L, L).
|
||||
% builtin_binds_(mutex_trylock(_), L, L).
|
||||
% builtin_binds_(mutex_unlock(_), L, L).
|
||||
% builtin_binds_(mutex_unlock_all, L, L).
|
||||
% builtin_binds_(name(_, _), L, L).
|
||||
% builtin_binds_(nb_current(_, _), L, L).
|
||||
% builtin_binds_(nb_delete(_), L, L).
|
||||
% builtin_binds_(nb_getval(_, _), L, L).
|
||||
% builtin_binds_(nb_linkarg(_, _, _), L, L).
|
||||
% builtin_binds_(nb_linkval(_, _), L, L).
|
||||
% builtin_binds_(nb_setarg(_, _, _), L, L).
|
||||
% builtin_binds_(nb_setval(_, _), L, L).
|
||||
% builtin_binds_(nl(_), L, L).
|
||||
% builtin_binds_(nl, L, L).
|
||||
% builtin_binds_(nonvar(_), L, L).
|
||||
% builtin_binds_(noprofile(_), L, L).
|
||||
% builtin_binds_(noprotocol, L, L).
|
||||
% builtin_binds_(nospy(_), L, L).
|
||||
% builtin_binds_(nospyall, L, L).
|
||||
% builtin_binds_(not(_), L, L).
|
||||
% builtin_binds_(notrace(_), L, L).
|
||||
% builtin_binds_(notrace, L, L).
|
||||
% builtin_binds_(nth_clause(_, _, _), L, L).
|
||||
% builtin_binds_(number(_), L, L).
|
||||
% builtin_binds_(number_chars(_, _), L, L).
|
||||
% builtin_binds_(number_codes(_, _), L, L).
|
||||
% builtin_binds_(numbervars(_, _, _), L, L).
|
||||
% builtin_binds_(numbervars(_, _, _, _), L, L).
|
||||
% builtin_binds_(on_signal(_, _, _), L, L).
|
||||
% builtin_binds_(once(_), L, L).
|
||||
% builtin_binds_(op(_, _, _), L, L).
|
||||
% builtin_binds_(open(_, _, _), L, L).
|
||||
% builtin_binds_(open(_, _, _, _), L, L).
|
||||
% builtin_binds_(open_null_stream(_), L, L).
|
||||
% builtin_binds_(open_resource(_, _, _), L, L).
|
||||
% builtin_binds_(open_resource(_, _, _, _), L, L).
|
||||
% builtin_binds_(open_shared_object(_, _), L, L).
|
||||
% builtin_binds_(open_shared_object(_, _, _), L, L).
|
||||
% builtin_binds_(open_xterm(_, _, _, _), L, L).
|
||||
% builtin_binds_(peek_byte(_), L, L).
|
||||
% builtin_binds_(peek_byte(_, _), L, L).
|
||||
% builtin_binds_(peek_char(_), L, L).
|
||||
% builtin_binds_(peek_char(_, _), L, L).
|
||||
% builtin_binds_(peek_code(_), L, L).
|
||||
% builtin_binds_(peek_code(_, _), L, L).
|
||||
% builtin_binds_(phrase(_, _), L, L).
|
||||
% builtin_binds_(phrase(_, _, _), L, L).
|
||||
% builtin_binds_(plus(_, _, _), L, L).
|
||||
% builtin_binds_(predicate_property(_, _), L, L).
|
||||
% builtin_binds_(preprocessor(_, _), L, L).
|
||||
% builtin_binds_(print(_), L, L).
|
||||
% builtin_binds_(print(_, _), L, L).
|
||||
% builtin_binds_(print_message(_, _), L, L).
|
||||
% builtin_binds_(print_message_lines(_, _, _), L, L).
|
||||
% builtin_binds_(profiler(_, _), L, L).
|
||||
% builtin_binds_(prolog, L, L).
|
||||
% builtin_binds_(prolog_choice_attribute(_, _, _), L, L).
|
||||
% builtin_binds_(prolog_current_frame(_), L, L).
|
||||
% builtin_binds_(prolog_frame_attribute(_, _, _), L, L).
|
||||
% builtin_binds_(prolog_load_context(_, _), L, L).
|
||||
% builtin_binds_(prolog_skip_level(_, _), L, L).
|
||||
% builtin_binds_(prolog_to_os_filename(_, _), L, L).
|
||||
% builtin_binds_(prompt(_, _), L, L).
|
||||
% builtin_binds_(prompt1(_), L, L).
|
||||
% builtin_binds_(protocol(_), L, L).
|
||||
% builtin_binds_(protocola(_), L, L).
|
||||
% builtin_binds_(protocolling(_), L, L).
|
||||
% builtin_binds_(put(_), L, L).
|
||||
% builtin_binds_(put(_, _), L, L).
|
||||
% builtin_binds_(put_attr(_, _, _), L, L).
|
||||
% builtin_binds_(put_attrs(_, _), L, L).
|
||||
% builtin_binds_(put_byte(_), L, L).
|
||||
% builtin_binds_(put_byte(_, _), L, L).
|
||||
% builtin_binds_(put_char(_), L, L).
|
||||
% builtin_binds_(put_char(_, _), L, L).
|
||||
% builtin_binds_(put_code(_), L, L).
|
||||
% builtin_binds_(put_code(_, _), L, L).
|
||||
% builtin_binds_(qcompile(_), L, L).
|
||||
% builtin_binds_(rational(_), L, L).
|
||||
% builtin_binds_(rational(_, _, _), L, L).
|
||||
% builtin_binds_(read(_), L, L).
|
||||
% builtin_binds_(read(_, _), L, L).
|
||||
% builtin_binds_(read_clause(_), L, L).
|
||||
% builtin_binds_(read_clause(_, _), L, L).
|
||||
% builtin_binds_(read_history(_, _, _, _, _, _), L, L).
|
||||
% builtin_binds_(read_link(_, _, _), L, L).
|
||||
% builtin_binds_(read_pending_input(_, _, _), L, L).
|
||||
% builtin_binds_(read_term(_, _), L, L).
|
||||
% builtin_binds_(read_term(_, _, _), L, L).
|
||||
% builtin_binds_(recorda(_, _), L, L).
|
||||
% builtin_binds_(recorda(_, _, _), L, L).
|
||||
% builtin_binds_(recorded(_, _), L, L).
|
||||
% builtin_binds_(recorded(_, _, _), L, L).
|
||||
% builtin_binds_(recordz(_, _), L, L).
|
||||
% builtin_binds_(recordz(_, _, _), L, L).
|
||||
% builtin_binds_(redefine_system_predicate(_), L, L).
|
||||
% builtin_binds_(reload_library_index, L, L).
|
||||
% builtin_binds_(rename_file(_, _), L, L).
|
||||
% builtin_binds_(repeat, L, L).
|
||||
% builtin_binds_(require(_), L, L).
|
||||
% builtin_binds_(reset_profiler, L, L).
|
||||
% builtin_binds_(retract(_), L, L).
|
||||
% builtin_binds_(retractall(_), L, L).
|
||||
% builtin_binds_(same_file(_, _), L, L).
|
||||
% builtin_binds_(same_term(_, _), L, L).
|
||||
% builtin_binds_(see(_), L, L).
|
||||
% builtin_binds_(seeing(_), L, L).
|
||||
% builtin_binds_(seek(_, _, _, _), L, L).
|
||||
% builtin_binds_(seen, L, L).
|
||||
% builtin_binds_(set_input(_), L, L).
|
||||
% builtin_binds_(set_output(_), L, L).
|
||||
% builtin_binds_(set_prolog_IO(_, _, _), L, L).
|
||||
% builtin_binds_(set_prolog_flag(_, _), L, L).
|
||||
% builtin_binds_(set_stream(_, _), L, L).
|
||||
% builtin_binds_(set_stream_position(_, _), L, L).
|
||||
% builtin_binds_(setarg(_, _, _), L, L).
|
||||
% builtin_binds_(setenv(_, _), L, L).
|
||||
% builtin_binds_(setlocale(_, _, _), L, L).
|
||||
% builtin_binds_(setof(_, _, _), L, L).
|
||||
% builtin_binds_(setup_and_call_cleanup(_, _, _), L, L).
|
||||
% builtin_binds_(setup_and_call_cleanup(_, _, _, _), L, L).
|
||||
% builtin_binds_(shell(_), L, L).
|
||||
% builtin_binds_(shell(_, _), L, L).
|
||||
% builtin_binds_(shell, L, L).
|
||||
% builtin_binds_(size_file(_, _), L, L).
|
||||
% builtin_binds_(skip(_), L, L).
|
||||
% builtin_binds_(skip(_, _), L, L).
|
||||
% builtin_binds_(sleep(_), L, L).
|
||||
% builtin_binds_(sort(_, _), L, L).
|
||||
% builtin_binds_(source_file(_), L, L).
|
||||
% builtin_binds_(source_file(_, _), L, L).
|
||||
% builtin_binds_(source_location(_, _), L, L).
|
||||
% builtin_binds_(spy(_), L, L).
|
||||
% builtin_binds_(stamp_date_time(_, _, _), L, L).
|
||||
% builtin_binds_(statistics(_, _), L, L).
|
||||
% builtin_binds_(statistics, L, L).
|
||||
% builtin_binds_(stream_position_data(_, _, _), L, L).
|
||||
% builtin_binds_(stream_property(_, _), L, L).
|
||||
% builtin_binds_(string(_), L, L).
|
||||
% builtin_binds_(string_concat(_, _, _), L, L).
|
||||
% builtin_binds_(string_length(_, _), L, L).
|
||||
% builtin_binds_(atom_string(_, _), L, L).
|
||||
% builtin_binds_(string_codes(_, _), L, L).
|
||||
% builtin_binds_(strip_module(_, _, _), L, L).
|
||||
% builtin_binds_(style_check(_), L, L).
|
||||
% builtin_binds_(sub_atom(_, _, _, _, _), L, L).
|
||||
% builtin_binds_(sub_string(_, _, _, _, _), L, L).
|
||||
% builtin_binds_(succ(_, _), L, L).
|
||||
% builtin_binds_(swritef(_, _), L, L).
|
||||
% builtin_binds_(swritef(_, _, _), L, L).
|
||||
% builtin_binds_(tab(_), L, L).
|
||||
% builtin_binds_(tab(_, _), L, L).
|
||||
% builtin_binds_(tell(_), L, L).
|
||||
% builtin_binds_(telling(_), L, L).
|
||||
% builtin_binds_(term_to_atom(_, _), L, L).
|
||||
% builtin_binds_(term_variables(_, _), L, L).
|
||||
% builtin_binds_(term_variables(_, _, _), L, L).
|
||||
% builtin_binds_(thread_at_exit(_), L, L).
|
||||
% builtin_binds_(thread_create(_, _, _), L, L).
|
||||
% builtin_binds_(thread_detach(_), L, L).
|
||||
% builtin_binds_(thread_exit(_), L, L).
|
||||
% builtin_binds_(thread_get_message(_), L, L).
|
||||
% builtin_binds_(thread_get_message(_, _), L, L).
|
||||
% builtin_binds_(thread_join(_, _), L, L).
|
||||
% builtin_binds_(thread_kill(_, _), L, L).
|
||||
% builtin_binds_(thread_peek_message(_), L, L).
|
||||
% builtin_binds_(thread_peek_message(_, _), L, L).
|
||||
% builtin_binds_(thread_property(_, _), L, L).
|
||||
% builtin_binds_(thread_self(_), L, L).
|
||||
% builtin_binds_(thread_send_message(_, _), L, L).
|
||||
% builtin_binds_(thread_setconcurrency(_, _), L, L).
|
||||
% builtin_binds_(thread_signal(_, _), L, L).
|
||||
% builtin_binds_(thread_statistics(_, _, _), L, L).
|
||||
% builtin_binds_(throw(_), L, L).
|
||||
% builtin_binds_(time_file(_, _), L, L).
|
||||
% builtin_binds_(tmp_file(_, _), L, L).
|
||||
% builtin_binds_(told, L, L).
|
||||
% builtin_binds_(trim_stacks, L, L).
|
||||
% builtin_binds_(tty_get_capability(_, _, _), L, L).
|
||||
% builtin_binds_(tty_goto(_, _), L, L).
|
||||
% builtin_binds_(tty_put(_, _), L, L).
|
||||
% builtin_binds_(tty_size(_, _), L, L).
|
||||
% builtin_binds_(ttyflush, L, L).
|
||||
% builtin_binds_(unifiable(_, _, _), L, L).
|
||||
% builtin_binds_(unify_with_occurs_check(_, _), L, L).
|
||||
% builtin_binds_(unsetenv(_), L, L).
|
||||
% builtin_binds_(upcase_atom(_, _), L, L).
|
||||
% builtin_binds_(wait_for_input(_, _, _), L, L).
|
||||
% builtin_binds_(wildcard_match(_, _), L, L).
|
||||
% builtin_binds_(with_mutex(_, _), L, L).
|
||||
% builtin_binds_(with_output_to(_, _), L, L).
|
||||
% builtin_binds_(working_directory(_, _), L, L).
|
||||
|
||||
|
||||
% builtin_binds_(functor(Term, Functor, Arity), [Term,Functor,Arity|T], T).
|
||||
% builtin_binds_(arg(Arg, Term, Pos), [Arg,Term,Pos|T], T).
|
||||
% builtin_binds_(term_variables(_, _), L, L).
|
||||
% builtin_binds_(X=Y, [X,Y|T], T).
|
||||
|
||||
|
||||
builtin_binds_(X is _,[X|L],L).
|
||||
builtin_binds_((G1,G2),L,T) :-
|
||||
builtin_binds_(G1,L,R),
|
||||
builtin_binds_(G2,R,T).
|
||||
builtin_binds_((G1;G2),L,T) :-
|
||||
builtin_binds_(G1,L,R),
|
||||
builtin_binds_(G2,R,T).
|
||||
builtin_binds_((G1->G2),L,T) :-
|
||||
builtin_binds_(G1,L,R),
|
||||
builtin_binds_(G2,R,T).
|
||||
|
||||
builtin_binds_(\+ G,L,T) :-
|
||||
builtin_binds_(G,L,T).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
binds_b(G,Vars) :-
|
||||
binds_(G,L,[]),
|
||||
sort(L,Vars).
|
||||
|
||||
binds_(var(_),L,L).
|
||||
binds_(nonvar(_),L,L).
|
||||
binds_(ground(_),L,L).
|
||||
binds_(compound(_),L,L).
|
||||
binds_(number(_),L,L).
|
||||
binds_(atom(_),L,L).
|
||||
binds_(atomic(_),L,L).
|
||||
binds_(integer(_),L,L).
|
||||
binds_(float(_),L,L).
|
||||
|
||||
binds_(_ > _ ,L,L).
|
||||
binds_(_ < _ ,L,L).
|
||||
binds_(_ =< _,L,L).
|
||||
binds_(_ >= _,L,L).
|
||||
binds_(_ =:= _,L,L).
|
||||
binds_(_ =\= _,L,L).
|
||||
binds_(_ == _,L,L).
|
||||
binds_(_ \== _,L,L).
|
||||
binds_(true,L,L).
|
||||
|
||||
binds_(write(_),L,L).
|
||||
binds_(writeln(_),L,L).
|
||||
binds_(format(_,_),L,L).
|
||||
|
||||
binds_(X is _,[X|L],L).
|
||||
binds_((G1,G2),L,T) :-
|
||||
binds_(G1,L,R),
|
||||
binds_(G2,R,T).
|
||||
binds_((G1;G2),L,T) :-
|
||||
binds_(G1,L,R),
|
||||
binds_(G2,R,T).
|
||||
binds_((G1->G2),L,T) :-
|
||||
binds_(G1,L,R),
|
||||
binds_(G2,R,T).
|
||||
|
||||
binds_(\+ G,L,T) :-
|
||||
binds_(G,L,T).
|
||||
|
||||
binds_(G,L,T) :- term_variables(G,GVars),append(GVars,T,L). %jon
|
|
@ -0,0 +1,538 @@
|
|||
%
|
||||
% chr.pl is generated automatically.
|
||||
% This package is just here to work as a stub for YAP analysis.
|
||||
%
|
||||
|
||||
/**
|
||||
|
||||
@defgroup CHR CHR: Constraint Handling Rules
|
||||
|
||||
@ingroup swi
|
||||
|
||||
This chapter is written by Tom Schrijvers, K.U. Leuven for the hProlog
|
||||
system. Adjusted by Jan Wielemaker to fit the SWI-Prolog documentation
|
||||
infrastructure and remove hProlog specific references.
|
||||
|
||||
The CHR system of SWI-Prolog is the K.U.Leuven CHR system. The runtime
|
||||
environment is written by Christian Holzbaur and Tom Schrijvers while the
|
||||
compiler is written by Tom Schrijvers. Both are integrated with SWI-Prolog
|
||||
and licenced under compatible conditions with permission from the authors.
|
||||
|
||||
The main reference for SWI-Prolog's CHR system is:
|
||||
|
||||
+ T. Schrijvers, and B. Demoen, <em>The K.U.Leuven CHR System: Implementation and Application</em>, First Workshop on Constraint Handling Rules: Selected
|
||||
Contributions (Fruwirth, T. and Meister, M., eds.), pp. 1--5, 2004.
|
||||
|
||||
# Introduction
|
||||
|
||||
Constraint Handling Rules (CHR) is a committed-choice bottom-up language
|
||||
embedded in Prolog. It is designed for writing constraint solvers and is
|
||||
particularily useful for providing application-specific constraints.
|
||||
It has been used in many kinds of applications, like scheduling,
|
||||
model checking, abduction, type checking among many others.
|
||||
|
||||
CHR has previously been implemented in other Prolog systems (SICStus,
|
||||
Eclipse, Yap), Haskell and Java. This CHR system is based on the
|
||||
compilation scheme and runtime environment of CHR in SICStus.
|
||||
|
||||
In this documentation we restrict ourselves to giving a short overview
|
||||
of CHR in general and mainly focus on elements specific to this
|
||||
implementation. For a more thorough review of CHR we refer the reader to
|
||||
[Freuhwirth:98]. More background on CHR can be found at the CHR web site.
|
||||
|
||||
### Syntax and Semantics
|
||||
|
||||
We present informally the syntax and semantics of CHR.
|
||||
|
||||
|
||||
#### CHR Syntax
|
||||
|
||||
The syntax of CHR rules in hProlog is the following:
|
||||
|
||||
~~~~~
|
||||
rules --> rule, rules.
|
||||
rules --> [].
|
||||
|
||||
rule --> name, actual_rule, pragma, [atom(`.`)].
|
||||
|
||||
name --> atom, [atom(`@`)].
|
||||
name --> [].
|
||||
|
||||
actual_rule --> simplification_rule.
|
||||
actual_rule --> propagation_rule.
|
||||
actual_rule --> simpagation_rule.
|
||||
|
||||
simplification_rule --> constraints, [atom(`<=>`)], guard, body.
|
||||
propagation_rule --> constraints, [atom(`==>`)], guard, body.
|
||||
simpagation_rule --> constraints, [atom(`\`)], constraints, [atom(`<=>`)],
|
||||
guard, body.
|
||||
|
||||
constraints --> constraint, constraint_id.
|
||||
constraints --> constraint, [atom(`,`)], constraints.
|
||||
|
||||
constraint --> compound_term.
|
||||
|
||||
constraint_id --> [].
|
||||
constraint_id --> [atom(`#`)], variable.
|
||||
|
||||
guard --> [].
|
||||
guard --> goal, [atom(`|`)].
|
||||
|
||||
body --> goal.
|
||||
|
||||
pragma --> [].
|
||||
pragma --> [atom(`pragma`)], actual_pragmas.
|
||||
|
||||
actual_pragmas --> actual_pragma.
|
||||
actual_pragmas --> actual_pragma, [atom(`,`)], actual_pragmas.
|
||||
|
||||
actual_pragma --> [atom(`passive(`)], variable, [atom(`)`)].
|
||||
|
||||
~~~~~
|
||||
|
||||
Additional syntax-related terminology:
|
||||
|
||||
+ *head:* the constraints in an `actual_rule` before
|
||||
the arrow (either `<=>` or `==>`)
|
||||
|
||||
|
||||
#### Semantics Semantics
|
||||
|
||||
In this subsection the operational semantics of CHR in Prolog are presented
|
||||
informally. They do not differ essentially from other CHR systems.
|
||||
|
||||
When a constraint is called, it is considered an active constraint and
|
||||
the system will try to apply the rules to it. Rules are tried and executed
|
||||
sequentially in the order they are written.
|
||||
|
||||
A rule is conceptually tried for an active constraint in the following
|
||||
way. The active constraint is matched with a constraint in the head of
|
||||
the rule. If more constraints appear in the head they are looked for
|
||||
among the suspended constraints, which are called passive constraints in
|
||||
this context. If the necessary passive constraints can be found and all
|
||||
match with the head of the rule and the guard of the rule succeeds, then
|
||||
the rule is committed and the body of the rule executed. If not all the
|
||||
necessary passive constraint can be found, the matching fails or the
|
||||
guard fails, then the body is not executed and the process of trying and
|
||||
executing simply continues with the following rules. If for a rule,
|
||||
there are multiple constraints in the head, the active constraint will
|
||||
try the rule sequentially multiple times, each time trying to match with
|
||||
another constraint.
|
||||
|
||||
This process ends either when the active constraint disappears, i.e. it
|
||||
is removed by some rule, or after the last rule has been processed. In
|
||||
the latter case the active constraint becomes suspended.
|
||||
|
||||
A suspended constraint is eligible as a passive constraint for an active
|
||||
constraint. The other way it may interact again with the rules, is when
|
||||
a variable appearing in the constraint becomes bound to either a nonvariable
|
||||
or another variable involved in one or more constraints. In that case the
|
||||
constraint is triggered, i.e. it becomes an active constraint and all
|
||||
the rules are tried.
|
||||
|
||||
### Rules
|
||||
|
||||
There are three different kinds of rules, each with their specific semantics:
|
||||
|
||||
+ simplification
|
||||
The simplification rule removes the constraints in its head and calls its body.
|
||||
|
||||
+ propagation
|
||||
The propagation rule calls its body exactly once for the constraints in
|
||||
its head.
|
||||
|
||||
+ simpagation
|
||||
The simpagation rule removes the constraints in its head after the
|
||||
`\` and then calls its body. It is an optimization of
|
||||
simplification rules of the form: \[constraints_1, constraints_2 <=>
|
||||
constraints_1, body \] Namely, in the simpagation form:
|
||||
|
||||
~~~~~
|
||||
constraints1 \ constraints2 <=> body
|
||||
~~~~~
|
||||
_constraints1_
|
||||
constraints are not called in the body.
|
||||
|
||||
|
||||
|
||||
#### Rule Names
|
||||
|
||||
Naming a rule is optional and has no semantical meaning. It only functions
|
||||
as documentation for the programmer.
|
||||
|
||||
### Pragmas
|
||||
|
||||
The semantics of the pragmas are:
|
||||
|
||||
+ passive(Identifier)
|
||||
The constraint in the head of a rule _Identifier_ can only act as a
|
||||
passive constraint in that rule.
|
||||
|
||||
|
||||
Additional pragmas may be released in the future.
|
||||
|
||||
### CHR_Options Options
|
||||
|
||||
It is possible to specify options that apply to all the CHR rules in the module.
|
||||
Options are specified with the `option/2` declaration:
|
||||
|
||||
~~~~~
|
||||
option(Option,Value).
|
||||
~~~~~
|
||||
|
||||
Available options are:
|
||||
|
||||
+ check_guard_bindings
|
||||
This option controls whether guards should be checked for illegal
|
||||
variable bindings or not. Possible values for this option are
|
||||
`on`, to enable the checks, and `off`, to disable the
|
||||
checks.
|
||||
|
||||
+ optimize
|
||||
This is an experimental option controlling the degree of optimization.
|
||||
Possible values are `full`, to enable all available
|
||||
optimizations, and `off` (default), to disable all optimizations.
|
||||
The default is derived from the SWI-Prolog flag `optimise`, where
|
||||
`true` is mapped to `full`. Therefore the commandline
|
||||
option `-O` provides full CHR optimization.
|
||||
If optimization is enabled, debugging should be disabled.
|
||||
|
||||
+ debug
|
||||
This options enables or disables the possibility to debug the CHR code.
|
||||
Possible values are `on` (default) and `off`. See
|
||||
`debugging` for more details on debugging. The default is
|
||||
derived from the prolog flag `generate_debug_info`, which
|
||||
is `true` by default. See `-nodebug`.
|
||||
If debugging is enabled, optimization should be disabled.
|
||||
|
||||
+ mode
|
||||
This option specifies the mode for a particular constraint. The
|
||||
value is a term with functor and arity equal to that of a constraint.
|
||||
The arguments can be one of `-`, `+` or `?`.
|
||||
The latter is the default. The meaning is the following:
|
||||
|
||||
+ -
|
||||
The corresponding argument of every occurrence
|
||||
of the constraint is always unbound.
|
||||
+ +
|
||||
The corresponding argument of every occurrence
|
||||
of the constraint is always ground.
|
||||
+ ?
|
||||
The corresponding argument of every occurrence
|
||||
of the constraint can have any instantiation, which may change
|
||||
over time. This is the default value.
|
||||
|
||||
The declaration is used by the compiler for various optimizations.
|
||||
Note that it is up to the user the ensure that the mode declaration
|
||||
is correct with respect to the use of the constraint.
|
||||
This option may occur once for each constraint.
|
||||
|
||||
+ type_declaration
|
||||
This option specifies the argument types for a particular constraint. The
|
||||
value is a term with functor and arity equal to that of a constraint.
|
||||
The arguments can be a user-defined type or one of
|
||||
the built-in types:
|
||||
|
||||
+ int
|
||||
The corresponding argument of every occurrence
|
||||
of the constraint is an integer number.
|
||||
+ float
|
||||
...{} a floating point number.
|
||||
+ number
|
||||
...{} a number.
|
||||
+ natural
|
||||
...{} a positive integer.
|
||||
+ any
|
||||
The corresponding argument of every occurrence
|
||||
of the constraint can have any type. This is the default value.
|
||||
|
||||
|
||||
Currently, type declarations are only used to improve certain
|
||||
optimizations (guard simplification, occurrence subsumption, ...{}).
|
||||
|
||||
+ type_definition
|
||||
This option defines a new user-defined type which can be used in
|
||||
type declarations. The value is a term of the form
|
||||
`type(` _name_`,` _list_`)`, where
|
||||
_name_ is a term and _list_ is a list of alternatives.
|
||||
Variables can be used to define generic types. Recursive definitions
|
||||
are allowed. Examples are
|
||||
|
||||
~~~~~
|
||||
type(bool,[true,false]).
|
||||
type(complex_number,[float + float * i]).
|
||||
type(binary_tree(T),[ leaf(T) | node(binary_tree(T),binary_tree(T)) ]).
|
||||
type(list(T),[ [] | [T | list(T)]).
|
||||
~~~~~
|
||||
|
||||
|
||||
|
||||
The mode, type_declaration and type_definition options are provided
|
||||
for backward compatibility. The new syntax is described below.
|
||||
|
||||
|
||||
|
||||
### CHR in Prolog Programs
|
||||
|
||||
|
||||
The CHR constraints defined in a particulary chr file are
|
||||
associated with a module. The default module is `user`. One should
|
||||
never load different chr files with the same CHR module name.
|
||||
|
||||
|
||||
|
||||
#### Constraint Declarations
|
||||
|
||||
|
||||
Every constraint used in CHR rules has to be declared.
|
||||
There are two ways to do this. The old style is as follows:
|
||||
|
||||
~~~~~
|
||||
option(type_definition,type(list(T),[ [] , [T|list(T)] ]).
|
||||
option(mode,foo(+,?)).
|
||||
option(type_declaration,foo(list(int),float)).
|
||||
:- constraints foo/2, bar/0.
|
||||
~~~~~
|
||||
|
||||
The new style is as follows:
|
||||
|
||||
~~~~~
|
||||
:- chr_type list(T) ---> [] ; [T|list(T)].
|
||||
:- constraints foo(+list(int),?float), bar.
|
||||
~~~~~
|
||||
|
||||
|
||||
|
||||
#### Compilation
|
||||
|
||||
The
|
||||
SWI-Prolog CHR compiler exploits term_expansion/2 rules to translate
|
||||
the constraint handling rules to plain Prolog. These rules are loaded
|
||||
from the library chr. They are activated if the compiled file
|
||||
has the chr extension or after finding a declaration of the
|
||||
format below.
|
||||
|
||||
~~~~~
|
||||
:- constraints ...
|
||||
~~~~~
|
||||
|
||||
It is adviced to define CHR rules in a module file, where the module
|
||||
declaration is immediately followed by including the chr
|
||||
library as examplified below:
|
||||
|
||||
~~~~~
|
||||
:- module(zebra, [ zebra/0 ]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints ...
|
||||
~~~~~
|
||||
|
||||
Using this style CHR rules can be defined in ordinary Prolog
|
||||
pl files and the operator definitions required by CHR do not
|
||||
leak into modules where they might cause conflicts.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#### CHR Debugging
|
||||
|
||||
The CHR debugging facilities are currently rather limited. Only tracing
|
||||
is currently available. To use the CHR debugging facilities for a CHR
|
||||
file it must be compiled for debugging. Generating debug info is
|
||||
controlled by the CHR option debug, whose default is derived
|
||||
from the SWI-Prolog flag `generate_debug_info`. Therefore debug
|
||||
info is provided unless the `-nodebug` is used.
|
||||
|
||||
#### Ports
|
||||
|
||||
For CHR constraints the four standard ports are defined:
|
||||
|
||||
+ call
|
||||
A new constraint is called and becomes active.
|
||||
+ exit
|
||||
An active constraint exits: it has either been inserted in the store after
|
||||
trying all rules or has been removed from the constraint store.
|
||||
+ fail
|
||||
An active constraint fails.
|
||||
+ redo
|
||||
An active constraint starts looking for an alternative solution.
|
||||
|
||||
|
||||
In addition to the above ports, CHR constraints have five additional
|
||||
ports:
|
||||
|
||||
+ wake
|
||||
A suspended constraint is woken and becomes active.
|
||||
+ insert
|
||||
An active constraint has tried all rules and is suspended in
|
||||
the constraint store.
|
||||
+ remove
|
||||
An active or passive constraint is removed from the constraint
|
||||
store, if it had been inserted.
|
||||
+ try
|
||||
An active constraints tries a rule with possibly
|
||||
some passive constraints. The try port is entered
|
||||
just before committing to the rule.
|
||||
+ apply
|
||||
An active constraints commits to a rule with possibly
|
||||
some passive constraints. The apply port is entered
|
||||
just after committing to the rule.
|
||||
|
||||
#### Tracing
|
||||
|
||||
Tracing is enabled with the chr_trace/0 predicate
|
||||
and disabled with the chr_notrace/0 predicate.
|
||||
|
||||
When enabled the tracer will step through the `call`,
|
||||
`exit`, `fail`, `wake` and `apply` ports,
|
||||
accepting debug commands, and simply write out the other ports.
|
||||
|
||||
The following debug commans are currently supported:
|
||||
|
||||
~~~~~
|
||||
CHR debug options:
|
||||
|
||||
<cr> creep c creep
|
||||
s skip
|
||||
g ancestors
|
||||
n nodebug
|
||||
b break
|
||||
a abort
|
||||
f fail
|
||||
? help h help
|
||||
~~~~~
|
||||
|
||||
Their meaning is:
|
||||
|
||||
+ creep
|
||||
Step to the next port.
|
||||
+ skip
|
||||
Skip to exit port of this call or wake port.
|
||||
+ ancestors
|
||||
Print list of ancestor call and wake ports.
|
||||
+ nodebug
|
||||
Disable the tracer.
|
||||
+ break
|
||||
Enter a recursive Prolog toplevel. See break/0.
|
||||
+ abort
|
||||
Exit to the toplevel. See abort/0.
|
||||
+ fail
|
||||
Insert failure in execution.
|
||||
+ help
|
||||
Print the above available debug options.
|
||||
|
||||
|
||||
#### CHR Debugging Predicates
|
||||
|
||||
|
||||
The chr module contains several predicates that allow
|
||||
inspecting and printing the content of the constraint store.
|
||||
|
||||
+ chr_trace
|
||||
Activate the CHR tracer. By default the CHR tracer is activated and
|
||||
deactivated automatically by the Prolog predicates trace/0 and
|
||||
notrace/0.
|
||||
|
||||
### CHR_Examples Examples
|
||||
|
||||
Here are two example constraint solvers written in CHR.
|
||||
|
||||
+
|
||||
The program below defines a solver with one constraint,
|
||||
`leq/2`, which is a less-than-or-equal constraint.
|
||||
|
||||
~~~~~
|
||||
:- module(leq,[cycle/3, leq/2]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints leq/2.
|
||||
reflexivity @ leq(X,X) <=> true.
|
||||
antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y.
|
||||
idempotence @ leq(X,Y) \ leq(X,Y) <=> true.
|
||||
transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z).
|
||||
|
||||
cycle(X,Y,Z):-
|
||||
leq(X,Y),
|
||||
leq(Y,Z),
|
||||
leq(Z,X).
|
||||
~~~~~
|
||||
|
||||
+
|
||||
The program below implements a simple finite domain
|
||||
constraint solver.
|
||||
|
||||
~~~~~
|
||||
:- module(dom,[dom/2]).
|
||||
:- use_module(library(chr)).
|
||||
|
||||
:- constraints dom/2.
|
||||
|
||||
dom(X,[]) <=> fail.
|
||||
dom(X,[Y]) <=> X = Y.
|
||||
dom(X,L1), dom(X,L2) <=> intersection(L1,L2,L3), dom(X,L3).
|
||||
|
||||
intersection([],_,[]).
|
||||
intersection([H|T],L2,[H|L3]) :-
|
||||
member(H,L2), !,
|
||||
intersection(T,L2,L3).
|
||||
intersection([_|T],L2,L3) :-
|
||||
intersection(T,L2,L3).
|
||||
~~~~~
|
||||
|
||||
|
||||
|
||||
### Compatibility with SICStus CHR
|
||||
|
||||
|
||||
There are small differences between CHR in SWI-Prolog and newer
|
||||
YAPs and SICStus and older versions of YAP. Besides differences in
|
||||
available options and pragmas, the following differences should be
|
||||
noted:
|
||||
|
||||
+ [The handler/1 declaration]
|
||||
In SICStus every CHR module requires a `handler/1`
|
||||
declaration declaring a unique handler name. This declaration is valid
|
||||
syntax in SWI-Prolog, but will have no effect. A warning will be given
|
||||
during compilation.
|
||||
|
||||
+ [The rules/1 declaration]
|
||||
In SICStus, for every CHR module it is possible to only enable a subset
|
||||
of the available rules through the `rules/1` declaration. The
|
||||
declaration is valid syntax in SWI-Prolog, but has no effect. A
|
||||
warning is given during compilation.
|
||||
|
||||
+ [Sourcefile naming]
|
||||
SICStus uses a two-step compiler, where chr files are
|
||||
first translated into pl files. For SWI-Prolog CHR
|
||||
rules may be defined in a file with any extension.
|
||||
|
||||
### Guidelines
|
||||
|
||||
In this section we cover several guidelines on how to use CHR to write
|
||||
constraint solvers and how to do so efficiently.
|
||||
|
||||
+ [Set semantics]
|
||||
The CHR system allows the presence of identical constraints, i.e.
|
||||
multiple constraints with the same functor, arity and arguments. For
|
||||
most constraint solvers, this is not desirable: it affects efficiency
|
||||
and possibly termination. Hence appropriate simpagation rules should be
|
||||
added of the form:
|
||||
|
||||
~~~~~
|
||||
{constraint \ constraint <=> true}.
|
||||
~~~~~
|
||||
|
||||
+ [Multi-headed rules]
|
||||
Multi-headed rules are executed more efficiently when the constraints
|
||||
share one or more variables.
|
||||
|
||||
+ [Mode and type declarations]
|
||||
Provide mode and type declarations to get more efficient program execution.
|
||||
Make sure to disable debug (`-nodebug`) and enable optimization
|
||||
(`-O`).
|
||||
|
||||
*/
|
||||
|
||||
:- include(chr_op).
|
||||
|
|
@ -0,0 +1,180 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR error handling
|
||||
%
|
||||
:- module(chr_compiler_errors,
|
||||
[
|
||||
chr_info/3,
|
||||
chr_warning/3,
|
||||
chr_error/3,
|
||||
print_chr_error/1
|
||||
]).
|
||||
|
||||
:- use_module(chr_compiler_options).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% chr_info(+Type,+FormattedMessage,+MessageParameters)
|
||||
|
||||
chr_info(_,Message,Params) :-
|
||||
( \+verbosity_on ->
|
||||
true
|
||||
;
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler:\n',[]),
|
||||
format(user_error,Message,Params),
|
||||
long_line_with_equality_signs
|
||||
).
|
||||
|
||||
|
||||
%% SWI begin
|
||||
verbosity_on :-
|
||||
current_prolog_flag(verbose,V), V \== silent,
|
||||
current_prolog_flag(verbose_load,true).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% verbosity_on. % at the moment
|
||||
%% SICStus end
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% chr_warning(+Type,+FormattedMessage,+MessageParameters)
|
||||
|
||||
chr_warning(deprecated(Term),Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler WARNING: deprecated syntax ~w.\n',[Term]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
format(user_error,' Support for deprecated syntax will be discontinued in the near future!\n',[]),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
chr_warning(internal,Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler WARNING: something unexpected happened in the CHR compiler.\n',[]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
format(user_error,' Your program may not have been compiled correctly!\n',[]),
|
||||
format(user_error,' Please contact tom.schrijvers@cs.kuleuven.be.\n',[]),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
chr_warning(unsupported_pragma(Pragma,Rule),Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler WARNING: unsupported pragma ~w in ~@.\n',[Pragma,format_rule(Rule)]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
format(user_error,' Pragma is ignored!\n',[]),
|
||||
long_line_with_equality_signs.
|
||||
chr_warning(problem_pragma(Pragma,Rule),Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler WARNING: unsupported pragma ~w in ~@.\n',[Pragma,format_rule(Rule)]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
chr_warning(_,Message,Params) :-
|
||||
( chr_pp_flag(verbosity,on) ->
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler WARNING:\n',[]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
long_line_with_equality_signs
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% chr_error(+Type,+FormattedMessage,+MessageParameters)
|
||||
|
||||
chr_error(Type,Message,Params) :-
|
||||
throw(chr_error(error(Type,Message,Params))).
|
||||
|
||||
print_chr_error(error(Type,Message,Params)) :-
|
||||
print_chr_error(Type,Message,Params).
|
||||
|
||||
print_chr_error(syntax(Term),Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler ERROR: invalid syntax "~w".\n',[Term]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
print_chr_error(type_error,Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler TYPE ERROR:\n',[]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
print_chr_error(internal,Message,Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler ERROR: something unexpected happened in the CHR compiler.\n',[]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
format(user_error,' Please contact tom.schrijvers@cs.kuleuven.be.\n',[]),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
print_chr_error(cyclic_alias(Alias),_Message,_Params) :- !,
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler ERROR: cyclic alias "~w".\n',[Alias]),
|
||||
format(user_error,' `--> Aborting compilation.\n',[]),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
print_chr_error(_,Message,Params) :-
|
||||
long_line_with_equality_signs,
|
||||
format(user_error,'CHR compiler ERROR:\n',[]),
|
||||
format(user_error,' `--> ',[]),
|
||||
format(user_error,Message,Params),
|
||||
long_line_with_equality_signs.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
|
||||
:- public
|
||||
format_rule/1. % called using format/3 `@'
|
||||
|
||||
format_rule(PragmaRule) :-
|
||||
PragmaRule = pragma(_,_,Pragmas,MaybeName,N),
|
||||
( MaybeName = yes(Name) ->
|
||||
write('rule '), write(Name)
|
||||
;
|
||||
write('rule number '), write(N)
|
||||
),
|
||||
( memberchk(line_number(LineNumber),Pragmas) ->
|
||||
write(' (line '),
|
||||
write(LineNumber),
|
||||
write(')')
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
long_line_with_equality_signs :-
|
||||
format(user_error,'================================================================================\n',[]).
|
|
@ -0,0 +1,383 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2005-2006, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR controlling the compiler
|
||||
%
|
||||
|
||||
:- module(chr_compiler_options,
|
||||
[ handle_option/2
|
||||
, init_chr_pp_flags/0
|
||||
, chr_pp_flag/2
|
||||
]).
|
||||
|
||||
%% SICStus begin
|
||||
%% :- use_module(hprolog, [nb_setval/2,nb_getval/2]).
|
||||
%% local_current_prolog_flag(_,_) :- fail.
|
||||
%% SICStus end
|
||||
|
||||
%% SWI begin
|
||||
local_current_prolog_flag(X,Y) :- current_prolog_flag(X,Y).
|
||||
%% SWI end
|
||||
|
||||
|
||||
:- use_module(chr_compiler_errors).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Global Options
|
||||
%
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
var(Name), !,
|
||||
chr_error(syntax((:- chr_option(Name,Value))),'First argument should be an atom, not a variable.\n',[]).
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
var(Value), !,
|
||||
chr_error(syntax((:- chr_option(Name,Value))),'Second argument cannot be a variable.\n',[]).
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
option_definition(Name,Value,Flags),
|
||||
!,
|
||||
set_chr_pp_flags(Flags).
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
\+ option_definition(Name,_,_), !,
|
||||
chr_error(syntax((:- chr_option(Name,Value))),'Invalid option name ~w: consult the manual for valid options.\n',[Name]).
|
||||
|
||||
handle_option(Name,Value) :-
|
||||
chr_error(syntax((:- chr_option(Name,Value))),'Invalid option value ~w: consult the manual for valid option values.\n',[Value]).
|
||||
|
||||
option_definition(optimize,experimental,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - on,
|
||||
check_unnecessary_active - full,
|
||||
reorder_heads - on,
|
||||
set_semantics_rule - on,
|
||||
storage_analysis - on,
|
||||
guard_via_reschedule - on,
|
||||
guard_simplification - on,
|
||||
check_impossible_rules - on,
|
||||
occurrence_subsumption - on,
|
||||
observation_analysis - on,
|
||||
ai_observation_analysis - on,
|
||||
late_allocation - on,
|
||||
reduced_indexing - on,
|
||||
term_indexing - on,
|
||||
inline_insertremove - on,
|
||||
mixed_stores - on
|
||||
].
|
||||
option_definition(optimize,full,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - on,
|
||||
check_unnecessary_active - full,
|
||||
reorder_heads - on,
|
||||
set_semantics_rule - on,
|
||||
storage_analysis - on,
|
||||
guard_via_reschedule - on,
|
||||
guard_simplification - on,
|
||||
check_impossible_rules - on,
|
||||
occurrence_subsumption - on,
|
||||
observation_analysis - on,
|
||||
ai_observation_analysis - on,
|
||||
late_allocation - on,
|
||||
reduced_indexing - on,
|
||||
inline_insertremove - on,
|
||||
mixed_stores - off,
|
||||
debugable - off
|
||||
].
|
||||
|
||||
option_definition(optimize,off,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - off,
|
||||
check_unnecessary_active - off,
|
||||
reorder_heads - off,
|
||||
set_semantics_rule - off,
|
||||
storage_analysis - off,
|
||||
guard_via_reschedule - off,
|
||||
guard_simplification - off,
|
||||
check_impossible_rules - off,
|
||||
occurrence_subsumption - off,
|
||||
observation_analysis - off,
|
||||
ai_observation_analysis - off,
|
||||
late_allocation - off,
|
||||
reduced_indexing - off
|
||||
].
|
||||
|
||||
option_definition(functional_dependency_analysis,on,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - on ].
|
||||
option_definition(functional_dependency_analysis,off,Flags) :-
|
||||
Flags = [ functional_dependency_analysis - off ].
|
||||
|
||||
option_definition(set_semantics_rule,on,Flags) :-
|
||||
Flags = [ set_semantics_rule - on ].
|
||||
option_definition(set_semantics_rule,off,Flags) :-
|
||||
Flags = [ set_semantics_rule - off ].
|
||||
|
||||
option_definition(check_unnecessary_active,full,Flags) :-
|
||||
Flags = [ check_unnecessary_active - full ].
|
||||
option_definition(check_unnecessary_active,simplification,Flags) :-
|
||||
Flags = [ check_unnecessary_active - simplification ].
|
||||
option_definition(check_unnecessary_active,off,Flags) :-
|
||||
Flags = [ check_unnecessary_active - off ].
|
||||
|
||||
option_definition(check_guard_bindings,on,Flags) :-
|
||||
Flags = [ guard_locks - on ].
|
||||
option_definition(check_guard_bindings,off,Flags) :-
|
||||
Flags = [ guard_locks - off ].
|
||||
option_definition(check_guard_bindings,error,Flags) :-
|
||||
Flags = [ guard_locks - error ].
|
||||
|
||||
option_definition(reduced_indexing,on,Flags) :-
|
||||
Flags = [ reduced_indexing - on ].
|
||||
option_definition(reduced_indexing,off,Flags) :-
|
||||
Flags = [ reduced_indexing - off ].
|
||||
|
||||
option_definition(storage_analysis,on,Flags) :-
|
||||
Flags = [ storage_analysis - on ].
|
||||
option_definition(storage_analysis,off,Flags) :-
|
||||
Flags = [ storage_analysis - off ].
|
||||
|
||||
option_definition(guard_simplification,on,Flags) :-
|
||||
Flags = [ guard_simplification - on ].
|
||||
option_definition(guard_simplification,off,Flags) :-
|
||||
Flags = [ guard_simplification - off ].
|
||||
|
||||
option_definition(check_impossible_rules,on,Flags) :-
|
||||
Flags = [ check_impossible_rules - on ].
|
||||
option_definition(check_impossible_rules,off,Flags) :-
|
||||
Flags = [ check_impossible_rules - off ].
|
||||
|
||||
option_definition(occurrence_subsumption,on,Flags) :-
|
||||
Flags = [ occurrence_subsumption - on ].
|
||||
option_definition(occurrence_subsumption,off,Flags) :-
|
||||
Flags = [ occurrence_subsumption - off ].
|
||||
|
||||
option_definition(late_allocation,on,Flags) :-
|
||||
Flags = [ late_allocation - on ].
|
||||
option_definition(late_allocation,off,Flags) :-
|
||||
Flags = [ late_allocation - off ].
|
||||
|
||||
option_definition(inline_insertremove,on,Flags) :-
|
||||
Flags = [ inline_insertremove - on ].
|
||||
option_definition(inline_insertremove,off,Flags) :-
|
||||
Flags = [ inline_insertremove - off ].
|
||||
|
||||
option_definition(type_definition,TypeDef,[]) :-
|
||||
( nonvar(TypeDef) ->
|
||||
TypeDef = type(T,D),
|
||||
chr_translate:type_definition(T,D)
|
||||
; true).
|
||||
option_definition(type_declaration,TypeDecl,[]) :-
|
||||
( nonvar(TypeDecl) ->
|
||||
functor(TypeDecl,F,A),
|
||||
TypeDecl =.. [_|ArgTypes],
|
||||
chr_translate:constraint_type(F/A,ArgTypes)
|
||||
; true).
|
||||
|
||||
option_definition(mode,ModeDecl,[]) :-
|
||||
( nonvar(ModeDecl) ->
|
||||
functor(ModeDecl,F,A),
|
||||
ModeDecl =.. [_|ArgModes],
|
||||
chr_translate:constraint_mode(F/A,ArgModes)
|
||||
; true).
|
||||
option_definition(store,FA-Store,[]) :-
|
||||
chr_translate:store_type(FA,Store).
|
||||
|
||||
%------------------------------------------------------------------------------%
|
||||
option_definition(declare_stored_constraints,off,[declare_stored_constraints-off]).
|
||||
option_definition(declare_stored_constraints,on ,[declare_stored_constraints-on]).
|
||||
|
||||
option_definition(stored,F/A,[]) :-
|
||||
chr_translate:stored_assertion(F/A).
|
||||
%------------------------------------------------------------------------------%
|
||||
option_definition(experiment,off,[experiment-off]).
|
||||
option_definition(experiment,on,[experiment-on]).
|
||||
option_definition(experimental,off,[experiment-off]).
|
||||
option_definition(experimental,on,[experiment-on]).
|
||||
option_definition(sss,off,[sss-off]).
|
||||
option_definition(sss,on,[sss-on]).
|
||||
%------------------------------------------------------------------------------%
|
||||
option_definition(debug,off,Flags) :-
|
||||
option_definition(optimize,full,Flags2),
|
||||
Flags = [ debugable - off | Flags2].
|
||||
option_definition(debug,on,Flags) :-
|
||||
( local_current_prolog_flag(generate_debug_info,false) ->
|
||||
% TODO: should not be allowed when nodebug flag is set in SWI-Prolog
|
||||
chr_warning(any,':- chr_option(debug,on) inconsistent with current_prolog_flag(generate_debug_info,off\n\tCHR option is ignored!\n)',[]),
|
||||
Flags = []
|
||||
;
|
||||
Flags = [ debugable - on ]
|
||||
).
|
||||
|
||||
option_definition(store_counter,off,[]).
|
||||
option_definition(store_counter,on,[store_counter-on]).
|
||||
|
||||
option_definition(observation,off,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - off,
|
||||
ai_observation_analysis - off,
|
||||
late_allocation - off,
|
||||
storage_analysis - off
|
||||
].
|
||||
option_definition(observation,on,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - on,
|
||||
ai_observation_analysis - on
|
||||
].
|
||||
option_definition(observation,regular,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - on,
|
||||
ai_observation_analysis - off
|
||||
].
|
||||
option_definition(observation,ai,Flags) :-
|
||||
Flags = [
|
||||
observation_analysis - off,
|
||||
ai_observation_analysis - on
|
||||
].
|
||||
|
||||
option_definition(store_in_guards, on, [store_in_guards - on]).
|
||||
option_definition(store_in_guards, off, [store_in_guards - off]).
|
||||
|
||||
option_definition(solver_events,NMod,Flags) :-
|
||||
Flags = [solver_events - NMod].
|
||||
|
||||
option_definition(toplevel_show_store,on,Flags) :-
|
||||
Flags = [toplevel_show_store - on].
|
||||
|
||||
option_definition(toplevel_show_store,off,Flags) :-
|
||||
Flags = [toplevel_show_store - off].
|
||||
|
||||
option_definition(term_indexing,on,Flags) :-
|
||||
Flags = [term_indexing - on].
|
||||
option_definition(term_indexing,off,Flags) :-
|
||||
Flags = [term_indexing - off].
|
||||
|
||||
option_definition(verbosity,on,Flags) :-
|
||||
Flags = [verbosity - on].
|
||||
option_definition(verbosity,off,Flags) :-
|
||||
Flags = [verbosity - off].
|
||||
|
||||
option_definition(ht_removal,on,Flags) :-
|
||||
Flags = [ht_removal - on].
|
||||
option_definition(ht_removal,off,Flags) :-
|
||||
Flags = [ht_removal - off].
|
||||
|
||||
option_definition(mixed_stores,on,Flags) :-
|
||||
Flags = [mixed_stores - on].
|
||||
option_definition(mixed_stores,off,Flags) :-
|
||||
Flags = [mixed_stores - off].
|
||||
|
||||
option_definition(line_numbers,on,Flags) :-
|
||||
Flags = [line_numbers - on].
|
||||
option_definition(line_numbers,off,Flags) :-
|
||||
Flags = [line_numbers - off].
|
||||
|
||||
option_definition(dynattr,on,Flags) :-
|
||||
Flags = [dynattr - on].
|
||||
option_definition(dynattr,off,Flags) :-
|
||||
Flags = [dynattr - off].
|
||||
|
||||
option_definition(verbose,off,[verbose-off]).
|
||||
option_definition(verbose,on,[verbose-on]).
|
||||
|
||||
option_definition(dump,off,[dump-off]).
|
||||
option_definition(dump,on,[dump-on]).
|
||||
|
||||
init_chr_pp_flags :-
|
||||
chr_pp_flag_definition(Name,[DefaultValue|_]),
|
||||
set_chr_pp_flag(Name,DefaultValue),
|
||||
fail.
|
||||
init_chr_pp_flags.
|
||||
|
||||
set_chr_pp_flags([]).
|
||||
set_chr_pp_flags([Name-Value|Flags]) :-
|
||||
set_chr_pp_flag(Name,Value),
|
||||
set_chr_pp_flags(Flags).
|
||||
|
||||
set_chr_pp_flag(Name,Value) :-
|
||||
atom_concat('$chr_pp_',Name,GlobalVar),
|
||||
nb_setval(GlobalVar,Value).
|
||||
|
||||
chr_pp_flag_definition(functional_dependency_analysis,[off,on]).
|
||||
chr_pp_flag_definition(check_unnecessary_active,[off,full,simplification]).
|
||||
chr_pp_flag_definition(reorder_heads,[off,on]).
|
||||
chr_pp_flag_definition(set_semantics_rule,[off,on]).
|
||||
chr_pp_flag_definition(guard_via_reschedule,[off,on]).
|
||||
chr_pp_flag_definition(guard_locks,[on,off,error]).
|
||||
chr_pp_flag_definition(storage_analysis,[off,on]).
|
||||
chr_pp_flag_definition(debugable,[on,off]).
|
||||
chr_pp_flag_definition(reduced_indexing,[off,on]).
|
||||
chr_pp_flag_definition(observation_analysis,[off,on]).
|
||||
chr_pp_flag_definition(ai_observation_analysis,[off,on]).
|
||||
chr_pp_flag_definition(store_in_guards,[off,on]).
|
||||
chr_pp_flag_definition(late_allocation,[off,on]).
|
||||
chr_pp_flag_definition(store_counter,[off,on]).
|
||||
chr_pp_flag_definition(guard_simplification,[off,on]).
|
||||
chr_pp_flag_definition(check_impossible_rules,[off,on]).
|
||||
chr_pp_flag_definition(occurrence_subsumption,[off,on]).
|
||||
chr_pp_flag_definition(observation,[off,on]).
|
||||
chr_pp_flag_definition(show,[off,on]).
|
||||
chr_pp_flag_definition(inline_insertremove,[on,off]).
|
||||
chr_pp_flag_definition(solver_events,[none,_]).
|
||||
chr_pp_flag_definition(toplevel_show_store,[on,off]).
|
||||
chr_pp_flag_definition(term_indexing,[off,on]).
|
||||
chr_pp_flag_definition(verbosity,[on,off]).
|
||||
chr_pp_flag_definition(ht_removal,[off,on]).
|
||||
chr_pp_flag_definition(mixed_stores,[on,off]).
|
||||
chr_pp_flag_definition(line_numbers,[off,on]).
|
||||
chr_pp_flag_definition(dynattr,[off,on]).
|
||||
chr_pp_flag_definition(experiment,[off,on]).
|
||||
chr_pp_flag_definition(sss,[off,on]).
|
||||
% emit compiler inferred code
|
||||
chr_pp_flag_definition(verbose,[off,on]).
|
||||
% emit input code and output code
|
||||
chr_pp_flag_definition(dump,[off,on]).
|
||||
|
||||
chr_pp_flag_definition(declare_stored_constraints,[off,on]).
|
||||
|
||||
chr_pp_flag(Name,Value) :-
|
||||
atom_concat('$chr_pp_',Name,GlobalVar),
|
||||
nb_getval(GlobalVar,V),
|
||||
( V == [] ->
|
||||
chr_pp_flag_definition(Name,[Value|_])
|
||||
;
|
||||
V = Value
|
||||
).
|
||||
|
||||
|
||||
% TODO: add whatever goes wrong with (debug,on), (optimize,full) combo here!
|
||||
% trivial example of what does go wrong:
|
||||
% b <=> true.
|
||||
% !!!
|
||||
sanity_check :-
|
||||
chr_pp_flag(store_in_guards, on),
|
||||
chr_pp_flag(ai_observation_analysis, on),
|
||||
chr_warning(any, 'ai_observation_analysis should be turned off when using store_in_guards\n', []),
|
||||
fail.
|
||||
sanity_check.
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
@ -0,0 +1,339 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2005-2006, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR compilation utilitities
|
||||
%
|
||||
|
||||
:- module(chr_compiler_utility,
|
||||
[ time/2
|
||||
, replicate/3
|
||||
, pair_all_with/3
|
||||
, conj2list/2
|
||||
, list2conj/2
|
||||
, disj2list/2
|
||||
, list2disj/2
|
||||
, variable_replacement/3
|
||||
, variable_replacement/4
|
||||
, identical_rules/2
|
||||
, identical_guarded_rules/2
|
||||
, copy_with_variable_replacement/3
|
||||
, my_term_copy/3
|
||||
, my_term_copy/4
|
||||
, atom_concat_list/2
|
||||
, init/2
|
||||
, member2/3
|
||||
, select2/6
|
||||
, set_elems/2
|
||||
, instrument_goal/4
|
||||
, sort_by_key/3
|
||||
, arg1/3
|
||||
, wrap_in_functor/3
|
||||
, tree_set_empty/1
|
||||
, tree_set_memberchk/2
|
||||
, tree_set_add/3
|
||||
, tree_set_merge/3
|
||||
, fold1/3
|
||||
, fold/4
|
||||
, maplist_dcg//3
|
||||
, maplist_dcg//4
|
||||
]).
|
||||
|
||||
:- use_module(pairlist).
|
||||
:- use_module(library(lists), [permutation/2]).
|
||||
:- use_module(library(assoc)).
|
||||
|
||||
:- meta_predicate
|
||||
fold1(3,+,-),
|
||||
fold(+,3,+,-).
|
||||
|
||||
%% SICStus begin
|
||||
%% use_module(library(terms),[term_variables/2]).
|
||||
%% SICStus end
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% time(Phase,Goal) :-
|
||||
% statistics(runtime,[T1|_]),
|
||||
% call(Goal),
|
||||
% statistics(runtime,[T2|_]),
|
||||
% T is T2 - T1,
|
||||
% format(' ~w ~46t ~D~80| ms\n',[Phase,T]),
|
||||
% deterministic(Det),
|
||||
% ( Det == true ->
|
||||
% true
|
||||
% ;
|
||||
% format('\t\tNOT DETERMINISTIC!\n',[])
|
||||
% ).
|
||||
time(_,Goal) :- call(Goal).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
replicate(N,E,L) :-
|
||||
( N =< 0 ->
|
||||
L = []
|
||||
;
|
||||
L = [E|T],
|
||||
M is N - 1,
|
||||
replicate(M,E,T)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
pair_all_with([],_,[]).
|
||||
pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
|
||||
pair_all_with(Xs,Y,Rest).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
conj2list(Conj,L) :- %% transform conjunctions to list
|
||||
conj2list(Conj,L,[]).
|
||||
|
||||
conj2list(Var,L,T) :-
|
||||
var(Var), !,
|
||||
L = [Var|T].
|
||||
conj2list(true,L,L) :- !.
|
||||
conj2list(Conj,L,T) :-
|
||||
Conj = (G1,G2), !,
|
||||
conj2list(G1,L,T1),
|
||||
conj2list(G2,T1,T).
|
||||
conj2list(G,[G | T],T).
|
||||
|
||||
disj2list(Conj,L) :- %% transform disjunctions to list
|
||||
disj2list(Conj,L,[]).
|
||||
disj2list(Conj,L,T) :-
|
||||
Conj = (fail;G2), !,
|
||||
disj2list(G2,L,T).
|
||||
disj2list(Conj,L,T) :-
|
||||
Conj = (G1;G2), !,
|
||||
disj2list(G1,L,T1),
|
||||
disj2list(G2,T1,T).
|
||||
disj2list(G,[G | T],T).
|
||||
|
||||
list2conj([],true).
|
||||
list2conj([G],X) :- !, X = G.
|
||||
list2conj([G|Gs],C) :-
|
||||
( G == true -> %% remove some redundant trues
|
||||
list2conj(Gs,C)
|
||||
;
|
||||
C = (G,R),
|
||||
list2conj(Gs,R)
|
||||
).
|
||||
|
||||
list2disj([],fail).
|
||||
list2disj([G],X) :- !, X = G.
|
||||
list2disj([G|Gs],C) :-
|
||||
( G == fail -> %% remove some redundant fails
|
||||
list2disj(Gs,C)
|
||||
;
|
||||
C = (G;R),
|
||||
list2disj(Gs,R)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% check wether two rules are identical
|
||||
|
||||
identical_guarded_rules(rule(H11,H21,G1,_),rule(H12,H22,G2,_)) :-
|
||||
G1 == G2,
|
||||
permutation(H11,P1),
|
||||
P1 == H12,
|
||||
permutation(H21,P2),
|
||||
P2 == H22.
|
||||
|
||||
identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
|
||||
G1 == G2,
|
||||
identical_bodies(B1,B2),
|
||||
permutation(H11,P1),
|
||||
P1 == H12,
|
||||
permutation(H21,P2),
|
||||
P2 == H22.
|
||||
|
||||
identical_bodies(B1,B2) :-
|
||||
( B1 = (X1 = Y1),
|
||||
B2 = (X2 = Y2) ->
|
||||
( X1 == X2,
|
||||
Y1 == Y2
|
||||
; X1 == Y2,
|
||||
X2 == Y1
|
||||
),
|
||||
!
|
||||
; B1 == B2
|
||||
).
|
||||
|
||||
% replace variables in list
|
||||
|
||||
copy_with_variable_replacement(X,Y,L) :-
|
||||
( var(X) ->
|
||||
( lookup_eq(L,X,Y) ->
|
||||
true
|
||||
; X = Y
|
||||
)
|
||||
; functor(X,F,A),
|
||||
functor(Y,F,A),
|
||||
X =.. [_|XArgs],
|
||||
Y =.. [_|YArgs],
|
||||
copy_with_variable_replacement_l(XArgs,YArgs,L)
|
||||
).
|
||||
|
||||
copy_with_variable_replacement_l([],[],_).
|
||||
copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
|
||||
copy_with_variable_replacement(X,Y,L),
|
||||
copy_with_variable_replacement_l(Xs,Ys,L).
|
||||
|
||||
% build variable replacement list
|
||||
|
||||
variable_replacement(X,Y,L) :-
|
||||
variable_replacement(X,Y,[],L).
|
||||
|
||||
variable_replacement(X,Y,L1,L2) :-
|
||||
( var(X) ->
|
||||
var(Y),
|
||||
( lookup_eq(L1,X,Z) ->
|
||||
Z == Y,
|
||||
L2 = L1
|
||||
; ( X == Y -> L2=L1 ; L2 = [X-Y,Y-X|L1])
|
||||
)
|
||||
; X =.. [F|XArgs],
|
||||
nonvar(Y),
|
||||
Y =.. [F|YArgs],
|
||||
variable_replacement_l(XArgs,YArgs,L1,L2)
|
||||
).
|
||||
|
||||
variable_replacement_l([],[],L,L).
|
||||
variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
|
||||
variable_replacement(X,Y,L1,L2),
|
||||
variable_replacement_l(Xs,Ys,L2,L3).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
my_term_copy(X,Dict,Y) :-
|
||||
my_term_copy(X,Dict,_,Y).
|
||||
|
||||
my_term_copy(X,Dict1,Dict2,Y) :-
|
||||
( var(X) ->
|
||||
( lookup_eq(Dict1,X,Y) ->
|
||||
Dict2 = Dict1
|
||||
; Dict2 = [X-Y|Dict1]
|
||||
)
|
||||
; functor(X,XF,XA),
|
||||
functor(Y,XF,XA),
|
||||
X =.. [_|XArgs],
|
||||
Y =.. [_|YArgs],
|
||||
my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
|
||||
).
|
||||
|
||||
my_term_copy_list([],Dict,Dict,[]).
|
||||
my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
|
||||
my_term_copy(X,Dict1,Dict2,Y),
|
||||
my_term_copy_list(Xs,Dict2,Dict3,Ys).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
atom_concat_list([X],X) :- ! .
|
||||
atom_concat_list([X|Xs],A) :-
|
||||
atom_concat_list(Xs,B),
|
||||
atomic_concat(X,B,A).
|
||||
|
||||
set_elems([],_).
|
||||
set_elems([X|Xs],X) :-
|
||||
set_elems(Xs,X).
|
||||
|
||||
init([],[]).
|
||||
init([_],[]) :- !.
|
||||
init([X|Xs],[X|R]) :-
|
||||
init(Xs,R).
|
||||
|
||||
member2([X|_],[Y|_],X-Y).
|
||||
member2([_|Xs],[_|Ys],P) :-
|
||||
member2(Xs,Ys,P).
|
||||
|
||||
select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
|
||||
select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
|
||||
select2(X, Y, Xs, Ys, NXs, NYs).
|
||||
|
||||
instrument_goal(Goal,Pre,Post,(Pre,Goal,Post)).
|
||||
|
||||
sort_by_key(List,Keys,SortedList) :-
|
||||
pairup(Keys,List,Pairs),
|
||||
sort(Pairs,SortedPairs),
|
||||
once(pairup(_,SortedList,SortedPairs)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
arg1(Term,Index,Arg) :- arg(Index,Term,Arg).
|
||||
|
||||
wrap_in_functor(Functor,X,Term) :-
|
||||
Term =.. [Functor,X].
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
tree_set_empty(TreeSet) :- empty_assoc(TreeSet).
|
||||
tree_set_memberchk(Element,TreeSet) :- get_assoc(Element,TreeSet,_).
|
||||
tree_set_add(TreeSet,Element,NTreeSet) :- put_assoc(Element,TreeSet,x,NTreeSet).
|
||||
tree_set_merge(TreeSet1,TreeSet2,TreeSet3) :-
|
||||
assoc_to_list(TreeSet1,List),
|
||||
fold(List,tree_set_add_pair,TreeSet2,TreeSet3).
|
||||
tree_set_add_pair(Key-Value,TreeSet,NTreeSet) :-
|
||||
put_assoc(Key,TreeSet,Value,NTreeSet).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
fold1(P,[Head|Tail],Result) :-
|
||||
fold(Tail,P,Head,Result).
|
||||
|
||||
fold([],_,Acc,Acc).
|
||||
fold([X|Xs],P,Acc,Res) :-
|
||||
call(P,X,Acc,NAcc),
|
||||
fold(Xs,P,NAcc,Res).
|
||||
|
||||
maplist_dcg(P,L1,L2,L) -->
|
||||
maplist_dcg_(L1,L2,L,P).
|
||||
|
||||
maplist_dcg_([],[],[],_) --> [].
|
||||
maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
|
||||
call(P,X,Y,Z),
|
||||
maplist_dcg_(Xs,Ys,Zs,P).
|
||||
|
||||
maplist_dcg(P,L1,L2) -->
|
||||
maplist_dcg_(L1,L2,P).
|
||||
|
||||
maplist_dcg_([],[],_) --> [].
|
||||
maplist_dcg_([X|Xs],[Y|Ys],P) -->
|
||||
call(P,X,Y),
|
||||
maplist_dcg_(Xs,Ys,P).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
:- dynamic
|
||||
user:goal_expansion/2.
|
||||
:- multifile
|
||||
user:goal_expansion/2.
|
||||
|
||||
user:goal_expansion(arg1(Term,Index,Arg), arg(Index,Term,Arg)).
|
||||
user:goal_expansion(wrap_in_functor(Functor,In,Out), Goal) :-
|
||||
( atom(Functor), var(Out) ->
|
||||
Out =.. [Functor,In],
|
||||
Goal = true
|
||||
;
|
||||
Goal = (Out =.. [Functor,In])
|
||||
).
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%% @addtogroup CHR_Debugging
|
||||
%
|
||||
% CHR debugger
|
||||
%
|
||||
:- module(chr_debug,
|
||||
[ chr_show_store/1, % +Module
|
||||
find_chr_constraint/1
|
||||
]).
|
||||
:- use_module(chr(chr_runtime)).
|
||||
:- use_module(library(lists)).
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
|
||||
%% chr_show_store(+Module)
|
||||
%
|
||||
% Prints all suspended constraints of module Mod to the standard
|
||||
% output.
|
||||
|
||||
chr_show_store(Mod) :-
|
||||
(
|
||||
Mod:'$enumerate_suspensions'(Susp),
|
||||
% arg(6,Susp,C),
|
||||
Susp =.. [_,_,_,_,_,_,F|Arg],
|
||||
functor(F,Fun,_),
|
||||
C =.. [Fun|Arg],
|
||||
print(C),nl, % allows use of portray to control printing
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
find_chr_constraint(C) :-
|
||||
chr:'$chr_module'(Mod),
|
||||
Mod:'$enumerate_suspensions'(Susp),
|
||||
arg(6,Susp,C).
|
|
@ -0,0 +1,425 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
% author: Tom Schrijvers
|
||||
% email: Tom.Schrijvers@cs.kuleuven.be
|
||||
% copyright: K.U.Leuven, 2004
|
||||
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR error handling
|
||||
%
|
||||
:- module(chr_hashtable_store,
|
||||
[ new_ht/1,
|
||||
lookup_ht/3,
|
||||
lookup_ht1/4,
|
||||
lookup_ht2/4,
|
||||
insert_ht/3,
|
||||
insert_ht1/4,
|
||||
insert_ht/4,
|
||||
delete_ht/3,
|
||||
delete_ht1/4,
|
||||
delete_first_ht/3,
|
||||
value_ht/2,
|
||||
stats_ht/1,
|
||||
stats_ht/1
|
||||
]).
|
||||
|
||||
:- use_module(pairlist).
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
:- multifile user:goal_expansion/2.
|
||||
:- dynamic user:goal_expansion/2.
|
||||
|
||||
initial_capacity(89).
|
||||
|
||||
new_ht(HT) :-
|
||||
initial_capacity(Capacity),
|
||||
new_ht(Capacity,HT).
|
||||
|
||||
new_ht(Capacity,HT) :-
|
||||
functor(T1,t,Capacity),
|
||||
HT = ht(Capacity,0,Table),
|
||||
Table = T1.
|
||||
|
||||
lookup_ht(HT,Key,Values) :-
|
||||
term_hash(Key,Hash),
|
||||
lookup_ht1(HT,Hash,Key,Values).
|
||||
/*
|
||||
HT = ht(Capacity,_,Table),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
nonvar(Bucket),
|
||||
( Bucket = K-Vs ->
|
||||
K == Key,
|
||||
Values = Vs
|
||||
;
|
||||
lookup(Bucket,Key,Values)
|
||||
).
|
||||
*/
|
||||
|
||||
% :- load_foreign_library(chr_support).
|
||||
|
||||
/*
|
||||
lookup_ht1(HT,Hash,Key,Values) :-
|
||||
( lookup_ht1_(HT,Hash,Key,Values) ->
|
||||
true
|
||||
;
|
||||
( lookup_ht1__(HT,Hash,Key,Values) ->
|
||||
writeln(lookup_ht1(HT,Hash,Key,Values)),
|
||||
throw(error)
|
||||
;
|
||||
fail
|
||||
)
|
||||
).
|
||||
*/
|
||||
|
||||
lookup_ht1(HT,Hash,Key,Values) :-
|
||||
HT = ht(Capacity,_,Table),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
nonvar(Bucket),
|
||||
( Bucket = K-Vs ->
|
||||
K == Key,
|
||||
Values = Vs
|
||||
;
|
||||
lookup(Bucket,Key,Values)
|
||||
).
|
||||
|
||||
lookup_ht2(HT,Key,Values,Index) :-
|
||||
term_hash(Key,Hash),
|
||||
HT = ht(Capacity,_,Table),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
nonvar(Bucket),
|
||||
( Bucket = K-Vs ->
|
||||
K == Key,
|
||||
Values = Vs
|
||||
;
|
||||
lookup(Bucket,Key,Values)
|
||||
).
|
||||
|
||||
lookup_pair_eq([P | KVs],Key,Pair) :-
|
||||
P = K-_,
|
||||
( K == Key ->
|
||||
P = Pair
|
||||
;
|
||||
lookup_pair_eq(KVs,Key,Pair)
|
||||
).
|
||||
|
||||
insert_ht(HT,Key,Value) :-
|
||||
term_hash(Key,Hash),
|
||||
HT = ht(Capacity0,Load,Table0),
|
||||
LookupIndex is (Hash mod Capacity0) + 1,
|
||||
arg(LookupIndex,Table0,LookupBucket),
|
||||
( var(LookupBucket) ->
|
||||
LookupBucket = Key - [Value]
|
||||
; LookupBucket = K-Values ->
|
||||
( K == Key ->
|
||||
setarg(2,LookupBucket,[Value|Values])
|
||||
;
|
||||
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
|
||||
)
|
||||
;
|
||||
( lookup_pair_eq(LookupBucket,Key,Pair) ->
|
||||
Pair = _-Values,
|
||||
setarg(2,Pair,[Value|Values])
|
||||
;
|
||||
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
|
||||
)
|
||||
),
|
||||
NLoad is Load + 1,
|
||||
setarg(2,HT,NLoad),
|
||||
( Load == Capacity0 ->
|
||||
expand_ht(HT,_Capacity)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
insert_ht1(HT,Key,Hash,Value) :-
|
||||
HT = ht(Capacity0,Load,Table0),
|
||||
LookupIndex is (Hash mod Capacity0) + 1,
|
||||
arg(LookupIndex,Table0,LookupBucket),
|
||||
( var(LookupBucket) ->
|
||||
LookupBucket = Key - [Value]
|
||||
; LookupBucket = K-Values ->
|
||||
( K == Key ->
|
||||
setarg(2,LookupBucket,[Value|Values])
|
||||
;
|
||||
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
|
||||
)
|
||||
;
|
||||
( lookup_pair_eq(LookupBucket,Key,Pair) ->
|
||||
Pair = _-Values,
|
||||
setarg(2,Pair,[Value|Values])
|
||||
;
|
||||
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
|
||||
)
|
||||
),
|
||||
NLoad is Load + 1,
|
||||
setarg(2,HT,NLoad),
|
||||
( Load == Capacity0 ->
|
||||
expand_ht(HT,_Capacity)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
% LDK: insert version with extra argument denoting result
|
||||
|
||||
insert_ht(HT,Key,Value,Result) :-
|
||||
HT = ht(Capacity,Load,Table),
|
||||
term_hash(Key,Hash),
|
||||
LookupIndex is (Hash mod Capacity) + 1,
|
||||
arg(LookupIndex,Table,LookupBucket),
|
||||
( var(LookupBucket)
|
||||
-> Result = [Value],
|
||||
LookupBucket = Key - Result,
|
||||
NewLoad is Load + 1
|
||||
; LookupBucket = K - V
|
||||
-> ( K = Key
|
||||
-> Result = [Value|V],
|
||||
setarg(2,LookupBucket,Result),
|
||||
NewLoad = Load
|
||||
; Result = [Value],
|
||||
setarg(LookupIndex,Table,[Key - Result,LookupBucket]),
|
||||
NewLoad is Load + 1
|
||||
)
|
||||
; ( lookup_pair_eq(LookupBucket,Key,Pair)
|
||||
-> Pair = _-Values,
|
||||
Result = [Value|Values],
|
||||
setarg(2,Pair,Result),
|
||||
NewLoad = Load
|
||||
; Result = [Value],
|
||||
setarg(LookupIndex,Table,[Key - Result|LookupBucket]),
|
||||
NewLoad is Load + 1
|
||||
)
|
||||
),
|
||||
setarg(2,HT,NewLoad),
|
||||
( NewLoad > Capacity
|
||||
-> expand_ht(HT,_)
|
||||
; true
|
||||
).
|
||||
|
||||
% LDK: deletion of the first element of a bucket
|
||||
delete_first_ht(HT,Key,Values) :-
|
||||
HT = ht(Capacity,Load,Table),
|
||||
term_hash(Key,Hash),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( Bucket = _-[_|Values]
|
||||
-> ( Values = []
|
||||
-> setarg(Index,Table,_),
|
||||
NewLoad is Load - 1
|
||||
; setarg(2,Bucket,Values),
|
||||
NewLoad = Load
|
||||
)
|
||||
; lookup_pair_eq(Bucket,Key,Pair)
|
||||
-> Pair = _-[_|Values],
|
||||
( Values = []
|
||||
-> pairlist_delete_eq(Bucket,Key,NewBucket),
|
||||
( NewBucket = []
|
||||
-> setarg(Index,Table,_)
|
||||
; NewBucket = [OtherPair]
|
||||
-> setarg(Index,Table,OtherPair)
|
||||
; setarg(Index,Table,NewBucket)
|
||||
),
|
||||
NewLoad is Load - 1
|
||||
; setarg(2,Pair,Values),
|
||||
NewLoad = Load
|
||||
)
|
||||
),
|
||||
setarg(2,HT,NewLoad).
|
||||
|
||||
delete_ht(HT,Key,Value) :-
|
||||
HT = ht(Capacity,Load,Table),
|
||||
NLoad is Load - 1,
|
||||
term_hash(Key,Hash),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( /* var(Bucket) ->
|
||||
true
|
||||
; */ Bucket = _K-Vs ->
|
||||
( /* _K == Key, */
|
||||
delete_first_fail(Vs,Value,NVs) ->
|
||||
setarg(2,HT,NLoad),
|
||||
( NVs == [] ->
|
||||
setarg(Index,Table,_)
|
||||
;
|
||||
setarg(2,Bucket,NVs)
|
||||
)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
( lookup_pair_eq(Bucket,Key,Pair),
|
||||
Pair = _-Vs,
|
||||
delete_first_fail(Vs,Value,NVs) ->
|
||||
setarg(2,HT,NLoad),
|
||||
( NVs == [] ->
|
||||
pairlist_delete_eq(Bucket,Key,NBucket),
|
||||
( NBucket = [Singleton] ->
|
||||
setarg(Index,Table,Singleton)
|
||||
;
|
||||
setarg(Index,Table,NBucket)
|
||||
)
|
||||
;
|
||||
setarg(2,Pair,NVs)
|
||||
)
|
||||
;
|
||||
true
|
||||
)
|
||||
).
|
||||
|
||||
delete_first_fail([X | Xs], Y, Zs) :-
|
||||
( X == Y ->
|
||||
Zs = Xs
|
||||
;
|
||||
Zs = [X | Zs1],
|
||||
delete_first_fail(Xs, Y, Zs1)
|
||||
).
|
||||
|
||||
delete_ht1(HT,Key,Value,Index) :-
|
||||
HT = ht(_Capacity,Load,Table),
|
||||
NLoad is Load - 1,
|
||||
% term_hash(Key,Hash),
|
||||
% Index is (Hash mod _Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( /* var(Bucket) ->
|
||||
true
|
||||
; */ Bucket = _K-Vs ->
|
||||
( /* _K == Key, */
|
||||
delete_first_fail(Vs,Value,NVs) ->
|
||||
setarg(2,HT,NLoad),
|
||||
( NVs == [] ->
|
||||
setarg(Index,Table,_)
|
||||
;
|
||||
setarg(2,Bucket,NVs)
|
||||
)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
( lookup_pair_eq(Bucket,Key,Pair),
|
||||
Pair = _-Vs,
|
||||
delete_first_fail(Vs,Value,NVs) ->
|
||||
setarg(2,HT,NLoad),
|
||||
( NVs == [] ->
|
||||
pairlist_delete_eq(Bucket,Key,NBucket),
|
||||
( NBucket = [Singleton] ->
|
||||
setarg(Index,Table,Singleton)
|
||||
;
|
||||
setarg(Index,Table,NBucket)
|
||||
)
|
||||
;
|
||||
setarg(2,Pair,NVs)
|
||||
)
|
||||
;
|
||||
true
|
||||
)
|
||||
).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
value_ht(HT,Value) :-
|
||||
HT = ht(Capacity,_,Table),
|
||||
value_ht(1,Capacity,Table,Value).
|
||||
|
||||
value_ht(I,N,Table,Value) :-
|
||||
I =< N,
|
||||
arg(I,Table,Bucket),
|
||||
(
|
||||
nonvar(Bucket),
|
||||
( Bucket = _-Vs ->
|
||||
true
|
||||
;
|
||||
member(_-Vs,Bucket)
|
||||
),
|
||||
member(Value,Vs)
|
||||
;
|
||||
J is I + 1,
|
||||
value_ht(J,N,Table,Value)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
expand_ht(HT,NewCapacity) :-
|
||||
HT = ht(Capacity,_,Table),
|
||||
NewCapacity is Capacity * 2 + 1,
|
||||
functor(NewTable,t,NewCapacity),
|
||||
setarg(1,HT,NewCapacity),
|
||||
setarg(3,HT,NewTable),
|
||||
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
|
||||
|
||||
expand_copy(Table,I,N,NewTable,NewCapacity) :-
|
||||
( I > N ->
|
||||
true
|
||||
;
|
||||
arg(I,Table,Bucket),
|
||||
( var(Bucket) ->
|
||||
true
|
||||
; Bucket = Key - Value ->
|
||||
expand_insert(NewTable,NewCapacity,Key,Value)
|
||||
;
|
||||
expand_inserts(Bucket,NewTable,NewCapacity)
|
||||
),
|
||||
J is I + 1,
|
||||
expand_copy(Table,J,N,NewTable,NewCapacity)
|
||||
).
|
||||
|
||||
expand_inserts([],_,_).
|
||||
expand_inserts([K-V|R],Table,Capacity) :-
|
||||
expand_insert(Table,Capacity,K,V),
|
||||
expand_inserts(R,Table,Capacity).
|
||||
|
||||
expand_insert(Table,Capacity,K,V) :-
|
||||
term_hash(K,Hash),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( var(Bucket) ->
|
||||
Bucket = K - V
|
||||
; Bucket = _-_ ->
|
||||
setarg(Index,Table,[K-V,Bucket])
|
||||
;
|
||||
setarg(Index,Table,[K-V|Bucket])
|
||||
).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
stats_ht(HT) :-
|
||||
HT = ht(Capacity,Load,Table),
|
||||
format('HT load = ~w / ~w\n',[Load,Capacity]),
|
||||
( between(1,Capacity,Index),
|
||||
arg(Index,Table,Entry),
|
||||
( var(Entry) -> Size = 0
|
||||
; Entry = _-_ -> Size = 1
|
||||
; length(Entry,Size)
|
||||
),
|
||||
format('~w : ~w\n',[Index,Size]),
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
|
@ -0,0 +1,140 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
based on chr_hashtable_store (by Tom Schrijvers)
|
||||
Author: Jon Sneyers
|
||||
E-mail: Jon.Sneyers@cs.kuleuven.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
% is it safe to use nb_setarg here?
|
||||
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR error handling
|
||||
%
|
||||
:- module(chr_integertable_store,
|
||||
[ new_iht/1,
|
||||
lookup_iht/3,
|
||||
insert_iht/3,
|
||||
delete_iht/3,
|
||||
value_iht/2
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
|
||||
%initial_capacity(65536).
|
||||
%initial_capacity(1024).
|
||||
initial_capacity(8).
|
||||
%initial_capacity(2).
|
||||
%initial_capacity(1).
|
||||
|
||||
|
||||
new_iht(HT) :-
|
||||
initial_capacity(Capacity),
|
||||
new_iht(Capacity,HT).
|
||||
|
||||
new_iht(Capacity,HT) :-
|
||||
functor(T1,t,Capacity),
|
||||
HT = ht(Capacity,Table),
|
||||
Table = T1.
|
||||
|
||||
lookup_iht(ht(_,Table),Int,Values) :-
|
||||
Index is Int + 1,
|
||||
arg(Index,Table,Values),
|
||||
Values \= [].
|
||||
% nonvar(Values).
|
||||
|
||||
insert_iht(HT,Int,Value) :-
|
||||
Index is Int + 1,
|
||||
arg(2,HT,Table),
|
||||
(arg(Index,Table,Bucket) ->
|
||||
( var(Bucket) ->
|
||||
Bucket = [Value]
|
||||
;
|
||||
setarg(Index,Table,[Value|Bucket])
|
||||
)
|
||||
; % index > capacity
|
||||
Capacity is 1<<ceil(log(Index)/log(2)),
|
||||
expand_iht(HT,Capacity),
|
||||
insert_iht(HT,Int,Value)
|
||||
).
|
||||
|
||||
delete_iht(ht(_,Table),Int,Value) :-
|
||||
% arg(2,HT,Table),
|
||||
Index is Int + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
( Bucket = [_Value] ->
|
||||
setarg(Index,Table,[])
|
||||
;
|
||||
delete_first_fail(Bucket,Value,NBucket),
|
||||
setarg(Index,Table,NBucket)
|
||||
).
|
||||
%delete_first_fail([], Y, []).
|
||||
%delete_first_fail([_], _, []) :- !.
|
||||
delete_first_fail([X | Xs], Y, Xs) :-
|
||||
X == Y, !.
|
||||
delete_first_fail([X | Xs], Y, [X | Zs]) :-
|
||||
delete_first_fail(Xs, Y, Zs).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
value_iht(HT,Value) :-
|
||||
HT = ht(Capacity,Table),
|
||||
value_iht(1,Capacity,Table,Value).
|
||||
|
||||
value_iht(I,N,Table,Value) :-
|
||||
I =< N,
|
||||
arg(I,Table,Bucket),
|
||||
(
|
||||
nonvar(Bucket),
|
||||
member(Value,Bucket)
|
||||
;
|
||||
J is I + 1,
|
||||
value_iht(J,N,Table,Value)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
expand_iht(HT,NewCapacity) :-
|
||||
HT = ht(Capacity,Table),
|
||||
functor(NewTable,t,NewCapacity),
|
||||
setarg(1,HT,NewCapacity),
|
||||
setarg(2,HT,NewTable),
|
||||
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
|
||||
|
||||
expand_copy(Table,I,N,NewTable,NewCapacity) :-
|
||||
( I > N ->
|
||||
true
|
||||
;
|
||||
arg(I,Table,Bucket),
|
||||
( var(Bucket) ->
|
||||
true
|
||||
;
|
||||
arg(I,NewTable,Bucket)
|
||||
),
|
||||
J is I + 1,
|
||||
expand_copy(Table,J,N,NewTable,NewCapacity)
|
||||
).
|
|
@ -0,0 +1,177 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Jan Wielemaker and Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR controlling the compiler
|
||||
%
|
||||
:- module(chr_messages,
|
||||
[ chr_message/3 % +CHR Message, Out, Rest
|
||||
]).
|
||||
:- use_module(chr(chr_runtime)).
|
||||
|
||||
:- discontiguous
|
||||
chr_message/3.
|
||||
|
||||
% compiler messages
|
||||
|
||||
chr_message(compilation_failed(From)) -->
|
||||
[ 'CHR Failed to compile ~w'-[From] ].
|
||||
|
||||
% debug messages
|
||||
|
||||
chr_message(prompt) -->
|
||||
[ at_same_line, ' ? ', flush_output ].
|
||||
chr_message(command(Command)) -->
|
||||
[ at_same_line, '[~w]'-[Command] ].
|
||||
chr_message(invalid_command) -->
|
||||
[ nl, 'CHR: Not a valid debug option. Use ? for help.' ].
|
||||
chr_message(debug_options) -->
|
||||
{ bagof(Ls-Cmd,
|
||||
bagof(L, 'chr debug command'(L, Cmd), Ls),
|
||||
Lines)
|
||||
},
|
||||
[ 'CHR Debugger commands:', nl, nl ],
|
||||
debug_commands(Lines),
|
||||
[ nl ].
|
||||
|
||||
debug_commands([]) -->
|
||||
[].
|
||||
debug_commands([Ls-Cmd|T]) -->
|
||||
[ '\t' ], chars(Ls), [ '~t~28|~w'-[Cmd], nl ],
|
||||
debug_commands(T).
|
||||
|
||||
chars([C]) --> !,
|
||||
char(C).
|
||||
chars([C|T]) -->
|
||||
char(C), [', '],
|
||||
chars(T).
|
||||
|
||||
char(' ') --> !, ['<space>'].
|
||||
char('\r') --> !, ['<cr>'].
|
||||
char(end_of_file) --> !, ['EOF'].
|
||||
char(C) --> [C].
|
||||
|
||||
|
||||
chr_message(ancestors(History, Depth)) -->
|
||||
[ 'CHR Ancestors:', nl ],
|
||||
ancestors(History, Depth).
|
||||
|
||||
ancestors([], _) -->
|
||||
[].
|
||||
ancestors([Event|Events], Depth) -->
|
||||
[ '\t' ], event(Event, Depth), [ nl ],
|
||||
{ NDepth is Depth - 1
|
||||
},
|
||||
ancestors(Events, NDepth).
|
||||
|
||||
|
||||
% debugging ports
|
||||
|
||||
chr_message(event(Port, Depth)) -->
|
||||
[ 'CHR: ' ],
|
||||
event(Port, Depth),
|
||||
[ flush_output ]. % do not emit a newline
|
||||
|
||||
event(Port, Depth) -->
|
||||
depth(Depth),
|
||||
port(Port).
|
||||
event(apply(H1,H2,G,B), Depth) -->
|
||||
depth(Depth),
|
||||
[ 'Apply: ' ],
|
||||
rule(H1,H2,G,B).
|
||||
event(try(H1,H2,G,B), Depth) -->
|
||||
depth(Depth),
|
||||
[ 'Try: ' ],
|
||||
rule(H1,H2,G,B).
|
||||
event(insert(#(_,Susp)), Depth) -->
|
||||
depth(Depth),
|
||||
[ 'Insert: ' ],
|
||||
head(Susp).
|
||||
|
||||
port(call(Susp)) -->
|
||||
[ 'Call: ' ],
|
||||
head(Susp).
|
||||
port(wake(Susp)) -->
|
||||
[ 'Wake: ' ],
|
||||
head(Susp).
|
||||
port(exit(Susp)) -->
|
||||
[ 'Exit: ' ],
|
||||
head(Susp).
|
||||
port(fail(Susp)) -->
|
||||
[ 'Fail: ' ],
|
||||
head(Susp).
|
||||
port(redo(Susp)) -->
|
||||
[ 'Redo: ' ],
|
||||
head(Susp).
|
||||
port(remove(Susp)) -->
|
||||
[ 'Remove: ' ],
|
||||
head(Susp).
|
||||
|
||||
|
||||
depth(Depth) -->
|
||||
[ '~t(~D)~10| '-[Depth] ].
|
||||
|
||||
head(Susp) -->
|
||||
{ Susp =.. [_,ID,_,_,_,_|GoalArgs], Goal =.. GoalArgs
|
||||
},
|
||||
[ '~w # <~w>'-[Goal, ID] ].
|
||||
|
||||
heads([H]) --> !,
|
||||
head(H).
|
||||
heads([H|T]) -->
|
||||
head(H),
|
||||
[ ', ' ],
|
||||
heads(T).
|
||||
|
||||
|
||||
% rule(H1, H2, G, B)
|
||||
%
|
||||
% Produce text for the CHR rule "H1 \ H2 [<=]=> G | B"
|
||||
|
||||
rule(H1, H2, G, B) -->
|
||||
rule_head(H1, H2),
|
||||
rule_body(G, B).
|
||||
|
||||
rule_head([], H2) --> !,
|
||||
heads(H2),
|
||||
[ ' ==> ' ].
|
||||
rule_head(H1, []) --> !,
|
||||
heads(H1),
|
||||
[ ' <=> ' ].
|
||||
rule_head(H1, H2) -->
|
||||
heads(H2), [ ' \\ ' ], heads(H1), [' <=> '].
|
||||
|
||||
|
||||
rule_body(true, B) --> !,
|
||||
[ '~w.'-[B] ].
|
||||
rule_body(G, B) -->
|
||||
[ '~w | ~w.'-[G, B] ].
|
|
@ -0,0 +1,50 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Operator Priorities
|
||||
|
||||
:- op(1180, xfx, ==>).
|
||||
:- op(1180, xfx, <=>).
|
||||
:- op(1150, fx, constraints).
|
||||
:- op(1150, fx, chr_constraint).
|
||||
:- op(1150, fx, handler).
|
||||
:- op(1150, fx, rules).
|
||||
:- op(1100, xfx, \).
|
||||
:- op(1200, xfx, @). % values from hProlog
|
||||
:- op(1190, xfx, pragma). % values from hProlog
|
||||
:- op( 500, yfx, #). % values from hProlog
|
||||
%:- op(1100, xfx, '|').
|
||||
:- op(1150, fx, chr_type).
|
||||
:- op(1130, xfx, --->).
|
||||
:- op(1150, fx, (?)).
|
||||
:- op(1150, fx, chr_declaration).
|
|
@ -0,0 +1,51 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%% Operator Priorities
|
||||
|
||||
|
||||
% old version, without the type/mode operators
|
||||
|
||||
:- op(1180, xfx, ==>).
|
||||
:- op(1180, xfx, <=>).
|
||||
:- op(1150, fx, constraints).
|
||||
:- op(1150, fx, chr_constraint).
|
||||
:- op(1150, fx, handler).
|
||||
:- op(1150, fx, rules).
|
||||
:- op(1100, xfx, \).
|
||||
:- op(1200, xfx, @). % values from hProlog
|
||||
:- op(1190, xfx, pragma). % values from hProlog
|
||||
:- op( 500, yfx, #). % values from hProlog
|
||||
%:- op(1100, xfx, '|').
|
||||
%:- op(1150, fx, chr_type).
|
||||
%:- op(1130, xfx, --->).
|
|
@ -0,0 +1,968 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Christian Holzbaur and Tom Schrijvers
|
||||
E-mail: christian@ai.univie.ac.at
|
||||
Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
|
||||
Distributed with SWI-Prolog under the above conditions with
|
||||
permission from the authors.
|
||||
*/
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% _ _ _
|
||||
%% ___| |__ _ __ _ __ _ _ _ __ | |_(_)_ __ ___ ___
|
||||
%% / __| '_ \| '__| | '__| | | | '_ \| __| | '_ ` _ \ / _ \
|
||||
%% | (__| | | | | | | | |_| | | | | |_| | | | | | | __/
|
||||
%% \___|_| |_|_| |_| \__,_|_| |_|\__|_|_| |_| |_|\___|
|
||||
%%
|
||||
%% hProlog CHR runtime:
|
||||
%%
|
||||
%% * based on the SICStus CHR runtime by Christian Holzbaur
|
||||
%%
|
||||
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% % Constraint Handling Rules version 2.2 %
|
||||
%% % %
|
||||
%% % (c) Copyright 1996-98 %
|
||||
%% % LMU, Muenchen %
|
||||
%% % %
|
||||
%% % File: chr.pl %
|
||||
%% % Author: Christian Holzbaur christian@ai.univie.ac.at %
|
||||
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%
|
||||
%%
|
||||
%% * modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.be
|
||||
%% - ported to hProlog
|
||||
%% - modified for eager suspension removal
|
||||
%%
|
||||
%% * First working version: 6 June 2003
|
||||
%%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% SWI-Prolog changes
|
||||
%%
|
||||
%% * Added initialization directives for saved-states
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%% @addtogroup CHR_Rule_Types
|
||||
%
|
||||
% CHR controlling the compiler
|
||||
%
|
||||
:- module(chr_runtime,
|
||||
[ 'chr sbag_del_element'/3,
|
||||
'chr sbag_member'/2,
|
||||
'chr merge_attributes'/3,
|
||||
|
||||
'chr run_suspensions'/1,
|
||||
'chr run_suspensions_loop'/1,
|
||||
|
||||
'chr run_suspensions_d'/1,
|
||||
'chr run_suspensions_loop_d'/1,
|
||||
|
||||
'chr insert_constraint_internal'/5,
|
||||
'chr remove_constraint_internal'/2,
|
||||
'chr allocate_constraint'/4,
|
||||
'chr activate_constraint'/3,
|
||||
|
||||
'chr default_store'/1,
|
||||
|
||||
'chr via_1'/2,
|
||||
'chr via_2'/3,
|
||||
'chr via'/2,
|
||||
'chr newvia_1'/2,
|
||||
'chr newvia_2'/3,
|
||||
'chr newvia'/2,
|
||||
|
||||
'chr lock'/1,
|
||||
'chr unlock'/1,
|
||||
'chr not_locked'/1,
|
||||
'chr none_locked'/1,
|
||||
|
||||
'chr error_lock'/1,
|
||||
'chr unerror_lock'/1,
|
||||
'chr not_error_locked'/1,
|
||||
'chr none_error_locked'/1,
|
||||
|
||||
'chr update_mutable'/2,
|
||||
'chr get_mutable'/2,
|
||||
'chr create_mutable'/2,
|
||||
|
||||
'chr novel_production'/2,
|
||||
'chr extend_history'/2,
|
||||
'chr empty_history'/1,
|
||||
|
||||
'chr gen_id'/1,
|
||||
|
||||
'chr debug_event'/1,
|
||||
'chr debug command'/2, % Char, Command
|
||||
|
||||
'chr chr_indexed_variables'/2,
|
||||
|
||||
'chr all_suspensions'/3,
|
||||
'chr new_merge_attributes'/3,
|
||||
'chr normalize_attr'/2,
|
||||
|
||||
'chr select'/3,
|
||||
|
||||
chr_show_store/1, % +Module
|
||||
find_chr_constraint/1,
|
||||
|
||||
chr_trace/0,
|
||||
chr_notrace/0,
|
||||
chr_leash/1
|
||||
]).
|
||||
|
||||
%% SWI begin
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
%% SWI end
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
:- include(chr_op).
|
||||
|
||||
%% SICStus begin
|
||||
%% :- use_module(hpattvars).
|
||||
%% :- use_module(b_globval).
|
||||
%% SICStus end
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
% I N I T I A L I S A T I O N
|
||||
|
||||
%% SWI begin
|
||||
:- dynamic user:exception/3.
|
||||
:- multifile user:exception/3.
|
||||
|
||||
user:exception(undefined_global_variable, Name, retry) :-
|
||||
chr_runtime_global_variable(Name),
|
||||
chr_init.
|
||||
|
||||
chr_runtime_global_variable(chr_id).
|
||||
chr_runtime_global_variable(chr_global).
|
||||
chr_runtime_global_variable(chr_debug).
|
||||
chr_runtime_global_variable(chr_debug_history).
|
||||
|
||||
chr_init :-
|
||||
nb_setval(chr_id,0),
|
||||
nb_setval(chr_global,_),
|
||||
nb_setval(chr_debug,mutable(off)), % XXX
|
||||
nb_setval(chr_debug_history,mutable([],0)). % XXX
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% chr_init :-
|
||||
%% nb_setval(chr_id,0).
|
||||
%% SICStus end
|
||||
|
||||
:- initialization chr_init.
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Contents of former chr_debug.pl
|
||||
%
|
||||
% chr_show_store(+Module)
|
||||
%
|
||||
% Prints all suspended constraints of module Mod to the standard
|
||||
% output.
|
||||
|
||||
chr_show_store(Mod) :-
|
||||
(
|
||||
Mod:'$enumerate_constraints'(Constraint),
|
||||
print(Constraint),nl, % allows use of portray to control printing
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
find_chr_constraint(Constraint) :-
|
||||
chr:'$chr_module'(Mod),
|
||||
Mod:'$enumerate_constraints'(Constraint).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Inlining of some goals is good for performance
|
||||
% That's the reason for the next section
|
||||
% There must be correspondence with the predicates as implemented in chr_mutable.pl
|
||||
% so that user:goal_expansion(G,G). also works (but do not add such a rule)
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%% SWI begin
|
||||
:- multifile user:goal_expansion/2.
|
||||
:- dynamic user:goal_expansion/2.
|
||||
|
||||
user:goal_expansion('chr get_mutable'(Val,Var), Var=mutable(Val)).
|
||||
user:goal_expansion('chr update_mutable'(Val,Var), setarg(1,Var,Val)).
|
||||
user:goal_expansion('chr create_mutable'(Val,Var), Var=mutable(Val)).
|
||||
user:goal_expansion('chr default_store'(X), nb_getval(chr_global,X)).
|
||||
%% SWI end
|
||||
|
||||
% goal_expansion seems too different in SICStus 4 for me to cater for in a
|
||||
% decent way at this moment - so I stick with the old way to do this
|
||||
% so that it doesn't get lost, the code from Mats for SICStus 4 is included in comments
|
||||
|
||||
|
||||
%% Mats begin
|
||||
%% goal_expansion('chr get_mutable'(Val,Var), Lay, _M, get_mutable(Val,Var), Lay).
|
||||
%% goal_expansion('chr update_mutable'(Val,Var), Lay, _M, update_mutable(Val,Var), Lay).
|
||||
%% goal_expansion('chr create_mutable'(Val,Var), Lay, _M, create_mutable(Val,Var), Lay).
|
||||
%% goal_expansion('chr default_store'(A), Lay, _M, global_term_ref_1(A), Lay).
|
||||
%% Mats begin
|
||||
|
||||
|
||||
%% SICStus begin
|
||||
%% :- multifile user:goal_expansion/2.
|
||||
%% :- dynamic user:goal_expansion/2.
|
||||
%%
|
||||
%% user:goal_expansion('chr get_mutable'(Val,Var), get_mutable(Val,Var)).
|
||||
%% user:goal_expansion('chr update_mutable'(Val,Var), update_mutable(Val,Var)).
|
||||
%% user:goal_expansion('chr create_mutable'(Val,Var), create_mutable(Val,Var)).
|
||||
%% user:goal_expansion('chr default_store'(A), global_term_ref_1(A)).
|
||||
%% SICStus end
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr run_suspensions'( Slots) :-
|
||||
run_suspensions( Slots).
|
||||
|
||||
'chr run_suspensions_loop'([]).
|
||||
'chr run_suspensions_loop'([L|Ls]) :-
|
||||
run_suspensions(L),
|
||||
'chr run_suspensions_loop'(Ls).
|
||||
|
||||
run_suspensions([]).
|
||||
run_suspensions([S|Next] ) :-
|
||||
arg( 2, S, Mref), % ARGXXX
|
||||
'chr get_mutable'( Status, Mref),
|
||||
( Status==active ->
|
||||
'chr update_mutable'( triggered, Mref),
|
||||
arg( 4, S, Gref), % ARGXXX
|
||||
'chr get_mutable'( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
'chr update_mutable'( Generation, Gref),
|
||||
arg( 3, S, Goal), % ARGXXX
|
||||
call( Goal),
|
||||
'chr get_mutable'( Post, Mref),
|
||||
( Post==triggered ->
|
||||
'chr update_mutable'( active, Mref) % catching constraints that did not do anything
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions( Next).
|
||||
|
||||
'chr run_suspensions_d'( Slots) :-
|
||||
run_suspensions_d( Slots).
|
||||
|
||||
'chr run_suspensions_loop_d'([]).
|
||||
'chr run_suspensions_loop_d'([L|Ls]) :-
|
||||
run_suspensions_d(L),
|
||||
'chr run_suspensions_loop_d'(Ls).
|
||||
|
||||
run_suspensions_d([]).
|
||||
run_suspensions_d([S|Next] ) :-
|
||||
arg( 2, S, Mref), % ARGXXX
|
||||
'chr get_mutable'( Status, Mref),
|
||||
( Status==active ->
|
||||
'chr update_mutable'( triggered, Mref),
|
||||
arg( 4, S, Gref), % ARGXXX
|
||||
'chr get_mutable'( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
'chr update_mutable'( Generation, Gref),
|
||||
arg( 3, S, Goal), % ARGXXX
|
||||
(
|
||||
'chr debug_event'(wake(S)),
|
||||
call( Goal)
|
||||
;
|
||||
'chr debug_event'(fail(S)), !,
|
||||
fail
|
||||
),
|
||||
(
|
||||
'chr debug_event'(exit(S))
|
||||
;
|
||||
'chr debug_event'(redo(S)),
|
||||
fail
|
||||
),
|
||||
'chr get_mutable'( Post, Mref),
|
||||
( Post==triggered ->
|
||||
'chr update_mutable'( active, Mref) % catching constraints that did not do anything
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions_d( Next).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% L O C K I N G
|
||||
%
|
||||
% locking of variables in guards
|
||||
|
||||
%= IMPLEMENTATION 1: SILENT FAILURE ============================================
|
||||
|
||||
%- attribute handler -----------------------------------------------------------
|
||||
% intercepts unification of locked variable unification
|
||||
|
||||
locked:attr_unify_hook(_,_) :- fail.
|
||||
|
||||
%- locking & unlocking ---------------------------------------------------------
|
||||
'chr lock'(T) :-
|
||||
( var(T)
|
||||
-> put_attr(T, locked, x)
|
||||
; term_variables(T,L),
|
||||
lockv(L)
|
||||
).
|
||||
|
||||
lockv([]).
|
||||
lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
|
||||
|
||||
'chr unlock'(T) :-
|
||||
( var(T)
|
||||
-> del_attr(T, locked)
|
||||
; term_variables(T,L),
|
||||
unlockv(L)
|
||||
).
|
||||
|
||||
unlockv([]).
|
||||
unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
|
||||
|
||||
%- checking for locks ----------------------------------------------------------
|
||||
|
||||
'chr none_locked'( []).
|
||||
'chr none_locked'( [V|Vs]) :-
|
||||
( get_attr(V, locked, _) ->
|
||||
fail
|
||||
;
|
||||
'chr none_locked'(Vs)
|
||||
).
|
||||
|
||||
'chr not_locked'(V) :-
|
||||
( var( V) ->
|
||||
( get_attr( V, locked, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%= IMPLEMENTATION 2: EXPLICT EXCEPTION =========================================
|
||||
|
||||
%- LOCK ERROR MESSAGE ----------------------------------------------------------
|
||||
lock_error(Term) :-
|
||||
throw(error(instantation_error(Term),context(_,'CHR Runtime Error: unification in guard not allowed!'))).
|
||||
|
||||
%- attribute handler -----------------------------------------------------------
|
||||
% intercepts unification of locked variable unification
|
||||
|
||||
error_locked:attr_unify_hook(_,Term) :- lock_error(Term).
|
||||
|
||||
%- locking & unlocking ---------------------------------------------------------
|
||||
'chr error_lock'(T) :-
|
||||
( var(T)
|
||||
-> put_attr(T, error_locked, x)
|
||||
; term_variables(T,L),
|
||||
error_lockv(L)
|
||||
).
|
||||
|
||||
error_lockv([]).
|
||||
error_lockv([T|R]) :- put_attr( T, error_locked, x), error_lockv(R).
|
||||
|
||||
'chr unerror_lock'(T) :-
|
||||
( var(T)
|
||||
-> del_attr(T, error_locked)
|
||||
; term_variables(T,L),
|
||||
unerror_lockv(L)
|
||||
).
|
||||
|
||||
unerror_lockv([]).
|
||||
unerror_lockv([T|R]) :- del_attr( T, error_locked), unerror_lockv(R).
|
||||
|
||||
%- checking for locks ----------------------------------------------------------
|
||||
|
||||
'chr none_error_locked'( []).
|
||||
'chr none_error_locked'( [V|Vs]) :-
|
||||
( get_attr(V, error_locked, _) ->
|
||||
fail
|
||||
;
|
||||
'chr none_error_locked'(Vs)
|
||||
).
|
||||
|
||||
'chr not_error_locked'(V) :-
|
||||
( var( V) ->
|
||||
( get_attr( V, error_locked, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
% Eager removal from all chains.
|
||||
%
|
||||
'chr remove_constraint_internal'( Susp, Agenda) :-
|
||||
arg( 2, Susp, Mref), % ARGXXX
|
||||
'chr get_mutable'( State, Mref),
|
||||
'chr update_mutable'( removed, Mref), % mark in any case
|
||||
( compound(State) -> % passive/1
|
||||
Agenda = []
|
||||
; State==removed ->
|
||||
Agenda = []
|
||||
%; State==triggered ->
|
||||
% Agenda = []
|
||||
;
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vars),
|
||||
'chr default_store'( Global),
|
||||
Agenda = [Global|Vars]
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr newvia_1'(X,V) :-
|
||||
( var(X) ->
|
||||
X = V
|
||||
;
|
||||
nonground(X,V)
|
||||
).
|
||||
|
||||
'chr newvia_2'(X,Y,V) :-
|
||||
( var(X) ->
|
||||
X = V
|
||||
; var(Y) ->
|
||||
Y = V
|
||||
; compound(X), nonground(X,V) ->
|
||||
true
|
||||
;
|
||||
compound(Y), nonground(Y,V)
|
||||
).
|
||||
|
||||
%
|
||||
% The second arg is a witness.
|
||||
% The formulation with term_variables/2 is
|
||||
% cycle safe, but it finds a list of all vars.
|
||||
% We need only one, and no list in particular.
|
||||
%
|
||||
'chr newvia'(L,V) :- nonground(L,V).
|
||||
%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
|
||||
|
||||
'chr via_1'(X,V) :-
|
||||
( var(X) ->
|
||||
X = V
|
||||
; atomic(X) ->
|
||||
'chr default_store'(V)
|
||||
; nonground(X,V) ->
|
||||
true
|
||||
;
|
||||
'chr default_store'(V)
|
||||
).
|
||||
|
||||
'chr via_2'(X,Y,V) :-
|
||||
( var(X) ->
|
||||
X = V
|
||||
; var(Y) ->
|
||||
Y = V
|
||||
; compound(X), nonground(X,V) ->
|
||||
true
|
||||
; compound(Y), nonground(Y,V) ->
|
||||
true
|
||||
;
|
||||
'chr default_store'(V)
|
||||
).
|
||||
|
||||
%
|
||||
% The second arg is a witness.
|
||||
% The formulation with term_variables/2 is
|
||||
% cycle safe, but it finds a list of all vars.
|
||||
% We need only one, and no list in particular.
|
||||
%
|
||||
'chr via'(L,V) :-
|
||||
( nonground(L,V) ->
|
||||
true
|
||||
;
|
||||
'chr default_store'(V)
|
||||
).
|
||||
|
||||
nonground( Term, V) :-
|
||||
term_variables( Term, Vs),
|
||||
Vs = [V|_].
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr novel_production'( Self, Tuple) :-
|
||||
arg( 5, Self, Ref), % ARGXXX
|
||||
'chr get_mutable'( History, Ref),
|
||||
( get_ds( Tuple, History, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%
|
||||
% Not folded with novel_production/2 because guard checking
|
||||
% goes in between the two calls.
|
||||
%
|
||||
'chr extend_history'( Self, Tuple) :-
|
||||
arg( 5, Self, Ref), % ARGXXX
|
||||
'chr get_mutable'( History, Ref),
|
||||
put_ds( Tuple, History, x, NewHistory),
|
||||
'chr update_mutable'( NewHistory, Ref).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr allocate_constraint'( Closure, Self, F, Args) :-
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
|
||||
'chr create_mutable'(0, Gref),
|
||||
'chr empty_history'(History),
|
||||
'chr create_mutable'(History, Href),
|
||||
'chr create_mutable'(passive(Args), Mref),
|
||||
'chr gen_id'( Id).
|
||||
|
||||
%
|
||||
% 'chr activate_constraint'( -, +, -).
|
||||
%
|
||||
% The transition gc->active should be rare
|
||||
%
|
||||
'chr activate_constraint'( Vars, Susp, Generation) :-
|
||||
arg( 2, Susp, Mref), % ARGXXX
|
||||
'chr get_mutable'( State, Mref),
|
||||
'chr update_mutable'( active, Mref),
|
||||
( nonvar(Generation) -> % aih
|
||||
true
|
||||
;
|
||||
arg( 4, Susp, Gref), % ARGXXX
|
||||
'chr get_mutable'( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
'chr update_mutable'( Generation, Gref)
|
||||
),
|
||||
( compound(State) -> % passive/1
|
||||
term_variables( State, Vs),
|
||||
'chr none_locked'( Vs),
|
||||
Vars = [Global|Vs],
|
||||
'chr default_store'(Global)
|
||||
; State == removed -> % the price for eager removal ...
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vs),
|
||||
Vars = [Global|Vs],
|
||||
'chr default_store'(Global)
|
||||
;
|
||||
Vars = []
|
||||
).
|
||||
|
||||
'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :-
|
||||
'chr default_store'(Global),
|
||||
term_variables(Args,Vars),
|
||||
'chr none_locked'(Vars),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
|
||||
'chr create_mutable'(active, Mref),
|
||||
'chr create_mutable'(0, Gref),
|
||||
'chr empty_history'(History),
|
||||
'chr create_mutable'(History, Href),
|
||||
'chr gen_id'(Id).
|
||||
|
||||
insert_constraint_internal([Global|Vars], Self, Term, Closure, F, Args) :-
|
||||
'chr default_store'(Global),
|
||||
term_variables( Term, Vars),
|
||||
'chr none_locked'( Vars),
|
||||
'chr empty_history'( History),
|
||||
'chr create_mutable'( active, Mref),
|
||||
'chr create_mutable'( 0, Gref),
|
||||
'chr create_mutable'( History, Href),
|
||||
'chr gen_id'( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args]. % SUSPXXX
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr empty_history'( E) :- empty_ds( E).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr gen_id'( Id) :-
|
||||
nb_getval(chr_id,Id),
|
||||
NextId is Id + 1,
|
||||
nb_setval(chr_id,NextId).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%% SWI begin
|
||||
'chr create_mutable'(V,mutable(V)).
|
||||
'chr get_mutable'(V,mutable(V)).
|
||||
'chr update_mutable'(V,M) :- setarg(1,M,V).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% 'chr create_mutable'(Val, Mut) :- create_mutable(Val, Mut).
|
||||
%% 'chr get_mutable'(Val, Mut) :- get_mutable(Val, Mut).
|
||||
%% 'chr update_mutable'(Val, Mut) :- update_mutable(Val, Mut).
|
||||
%% SICStus end
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% SWI begin
|
||||
'chr default_store'(X) :- nb_getval(chr_global,X).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% 'chr default_store'(A) :- global_term_ref_1(A).
|
||||
%% SICStus end
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
'chr sbag_member'( Element, [Head|Tail]) :-
|
||||
sbag_member( Element, Tail, Head).
|
||||
|
||||
% auxiliary to avoid choicepoint for last element
|
||||
% does it really avoid the choicepoint? -jon
|
||||
sbag_member( E, _, E).
|
||||
sbag_member( E, [Head|Tail], _) :-
|
||||
sbag_member( E, Tail, Head).
|
||||
|
||||
'chr sbag_del_element'( [], _, []).
|
||||
'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
|
||||
( X==Elem ->
|
||||
Set2 = Xs
|
||||
;
|
||||
Set2 = [X|Xss],
|
||||
'chr sbag_del_element'( Xs, Elem, Xss)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
'chr merge_attributes'([],Ys,Ys).
|
||||
'chr merge_attributes'([X | Xs],YL,R) :-
|
||||
( YL = [Y | Ys] ->
|
||||
arg(1,X,XId), % ARGXXX
|
||||
arg(1,Y,YId), % ARGXXX
|
||||
( XId < YId ->
|
||||
R = [X | T],
|
||||
'chr merge_attributes'(Xs,YL,T)
|
||||
; XId > YId ->
|
||||
R = [Y | T],
|
||||
'chr merge_attributes'([X|Xs],Ys,T)
|
||||
;
|
||||
R = [X | T],
|
||||
'chr merge_attributes'(Xs,Ys,T)
|
||||
)
|
||||
;
|
||||
R = [X | Xs]
|
||||
).
|
||||
|
||||
'chr new_merge_attributes'([],A2,A) :-
|
||||
A = A2.
|
||||
'chr new_merge_attributes'([E1|AT1],A2,A) :-
|
||||
( A2 = [E2|AT2] ->
|
||||
'chr new_merge_attributes'(E1,E2,AT1,AT2,A)
|
||||
;
|
||||
A = [E1|AT1]
|
||||
).
|
||||
|
||||
'chr new_merge_attributes'(Pos1-L1,Pos2-L2,AT1,AT2,A) :-
|
||||
( Pos1 < Pos2 ->
|
||||
A = [Pos1-L1|AT],
|
||||
'chr new_merge_attributes'(AT1,[Pos2-L2|AT2],AT)
|
||||
; Pos1 > Pos2 ->
|
||||
A = [Pos2-L2|AT],
|
||||
'chr new_merge_attributes'([Pos1-L1|AT1],AT2,AT)
|
||||
;
|
||||
'chr merge_attributes'(L1,L2,L),
|
||||
A = [Pos1-L|AT],
|
||||
'chr new_merge_attributes'(AT1,AT2,AT)
|
||||
).
|
||||
|
||||
'chr all_suspensions'([],_,_).
|
||||
'chr all_suspensions'([Susps|SuspsList],Pos,Attr) :-
|
||||
all_suspensions(Attr,Susps,SuspsList,Pos).
|
||||
|
||||
all_suspensions([],[],SuspsList,Pos) :-
|
||||
all_suspensions([],[],SuspsList,Pos). % all empty lists
|
||||
all_suspensions([APos-ASusps|RAttr],Susps,SuspsList,Pos) :-
|
||||
NPos is Pos + 1,
|
||||
( Pos == APos ->
|
||||
Susps = ASusps,
|
||||
'chr all_suspensions'(SuspsList,NPos,RAttr)
|
||||
;
|
||||
Susps = [],
|
||||
'chr all_suspensions'(SuspsList,NPos,[APos-ASusps|RAttr])
|
||||
).
|
||||
|
||||
'chr normalize_attr'([],[]).
|
||||
'chr normalize_attr'([Pos-L|R],[Pos-NL|NR]) :-
|
||||
sort(L,NL),
|
||||
'chr normalize_attr'(R,NR).
|
||||
|
||||
'chr select'([E|T],F,R) :-
|
||||
( E = F ->
|
||||
R = T
|
||||
;
|
||||
R = [E|NR],
|
||||
'chr select'(T,F,NR)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- multifile
|
||||
chr:debug_event/2, % +State, +Event
|
||||
chr:debug_interact/3. % +Event, +Depth, -Command
|
||||
|
||||
'chr debug_event'(Event) :-
|
||||
nb_getval(chr_debug,mutable(State)), % XXX
|
||||
( State == off ->
|
||||
true
|
||||
; chr:debug_event(State, Event) ->
|
||||
true
|
||||
; debug_event(State,Event)
|
||||
).
|
||||
|
||||
chr_trace :-
|
||||
nb_setval(chr_debug,mutable(trace)).
|
||||
chr_notrace :-
|
||||
nb_setval(chr_debug,mutable(off)).
|
||||
|
||||
% chr_leash(+Spec)
|
||||
%
|
||||
% Define the set of ports at which we prompt for user interaction
|
||||
|
||||
chr_leash(Spec) :-
|
||||
leashed_ports(Spec, Ports),
|
||||
nb_setval(chr_leash,mutable(Ports)).
|
||||
|
||||
leashed_ports(none, []).
|
||||
leashed_ports(off, []).
|
||||
leashed_ports(all, [call, exit, redo, fail, wake, try, apply, insert, remove]).
|
||||
leashed_ports(default, [call,exit,fail,wake,apply]).
|
||||
leashed_ports(One, Ports) :-
|
||||
atom(One), One \== [], !,
|
||||
leashed_ports([One], Ports).
|
||||
leashed_ports(Set, Ports) :-
|
||||
sort(Set, Ports), % make unique
|
||||
leashed_ports(all, All),
|
||||
valid_ports(Ports, All).
|
||||
|
||||
valid_ports([], _).
|
||||
valid_ports([H|T], Valid) :-
|
||||
( memberchk(H, Valid)
|
||||
-> true
|
||||
; throw(error(domain_error(chr_port, H), _))
|
||||
),
|
||||
valid_ports(T, Valid).
|
||||
|
||||
user:exception(undefined_global_variable, Name, retry) :-
|
||||
chr_runtime_debug_global_variable(Name),
|
||||
chr_debug_init.
|
||||
|
||||
chr_runtime_debug_global_variable(chr_leash).
|
||||
|
||||
chr_debug_init :-
|
||||
leashed_ports(default, Ports),
|
||||
nb_setval(chr_leash, mutable(Ports)).
|
||||
|
||||
:- initialization chr_debug_init.
|
||||
|
||||
% debug_event(+State, +Event)
|
||||
|
||||
|
||||
%debug_event(trace, Event) :-
|
||||
% functor(Event, Name, Arity),
|
||||
% writeln(Name/Arity), fail.
|
||||
debug_event(trace,Event) :-
|
||||
Event = call(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
chr_debug_interact(Event,NDepth),
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = wake(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
chr_debug_interact(Event,NDepth),
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = redo(_), !,
|
||||
get_debug_history(_History, Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = exit(_),!,
|
||||
get_debug_history([_|History],Depth),
|
||||
chr_debug_interact(Event,Depth),
|
||||
NDepth is Depth - 1,
|
||||
set_debug_history(History,NDepth).
|
||||
debug_event(trace,Event) :-
|
||||
Event = fail(_),!,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event,Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = remove(_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = insert(_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = try(_,_,_,_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event, Depth).
|
||||
debug_event(trace, Event) :-
|
||||
Event = apply(_,_,_,_), !,
|
||||
get_debug_history(_,Depth),
|
||||
chr_debug_interact(Event,Depth).
|
||||
|
||||
debug_event(skip(_,_),Event) :-
|
||||
Event = call(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(skip(_,_),Event) :-
|
||||
Event = wake(_), !,
|
||||
get_debug_history(History,Depth),
|
||||
NDepth is Depth + 1,
|
||||
set_debug_history([Event|History],NDepth).
|
||||
debug_event(skip(SkipSusp,SkipDepth),Event) :-
|
||||
Event = exit(Susp),!,
|
||||
get_debug_history([_|History],Depth),
|
||||
( SkipDepth == Depth,
|
||||
SkipSusp == Susp ->
|
||||
set_chr_debug(trace),
|
||||
chr_debug_interact(Event,Depth)
|
||||
;
|
||||
true
|
||||
),
|
||||
NDepth is Depth - 1,
|
||||
set_debug_history(History,NDepth).
|
||||
debug_event(skip(_,_),_) :- !,
|
||||
true.
|
||||
|
||||
% chr_debug_interact(+Event, +Depth)
|
||||
%
|
||||
% Interact with the user on Event that took place at Depth. First
|
||||
% calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
|
||||
% fails the event is printed and the system prompts for a command.
|
||||
|
||||
chr_debug_interact(Event, Depth) :-
|
||||
chr:debug_interact(Event, Depth, Command), !,
|
||||
handle_debug_command(Command,Event,Depth).
|
||||
chr_debug_interact(Event, Depth) :-
|
||||
print_event(Event, Depth),
|
||||
( leashed(Event)
|
||||
-> ask_continue(Command)
|
||||
; Command = creep
|
||||
),
|
||||
handle_debug_command(Command,Event,Depth).
|
||||
|
||||
leashed(Event) :-
|
||||
functor(Event, Port, _),
|
||||
nb_getval(chr_leash, mutable(Ports)),
|
||||
memberchk(Port, Ports).
|
||||
|
||||
ask_continue(Command) :-
|
||||
print_message(trace, chr(prompt)),
|
||||
get_single_char(CharCode),
|
||||
( CharCode == -1
|
||||
-> Char = end_of_file
|
||||
; char_code(Char, CharCode)
|
||||
),
|
||||
( debug_command(Char, Command)
|
||||
-> print_message(trace, chr(command(Command)))
|
||||
; print_message(help, chr(invalid_command)),
|
||||
ask_continue(Command)
|
||||
).
|
||||
|
||||
|
||||
'chr debug command'(Char, Command) :-
|
||||
debug_command(Char, Command).
|
||||
|
||||
debug_command(c, creep).
|
||||
debug_command(' ', creep).
|
||||
debug_command('\r', creep).
|
||||
debug_command(s, skip).
|
||||
debug_command(g, ancestors).
|
||||
debug_command(n, nodebug).
|
||||
debug_command(a, abort).
|
||||
debug_command(f, fail).
|
||||
debug_command(b, break).
|
||||
debug_command(?, help).
|
||||
debug_command(h, help).
|
||||
debug_command(end_of_file, exit).
|
||||
|
||||
|
||||
handle_debug_command(creep,_,_) :- !.
|
||||
handle_debug_command(skip, Event, Depth) :- !,
|
||||
Event =.. [Type|Rest],
|
||||
( Type \== call,
|
||||
Type \== wake ->
|
||||
handle_debug_command('c',Event,Depth)
|
||||
;
|
||||
Rest = [Susp],
|
||||
set_chr_debug(skip(Susp,Depth))
|
||||
).
|
||||
|
||||
handle_debug_command(ancestors,Event,Depth) :- !,
|
||||
print_chr_debug_history,
|
||||
chr_debug_interact(Event,Depth).
|
||||
handle_debug_command(nodebug,_,_) :- !,
|
||||
chr_notrace.
|
||||
handle_debug_command(abort,_,_) :- !,
|
||||
abort.
|
||||
handle_debug_command(exit,_,_) :- !,
|
||||
halt.
|
||||
handle_debug_command(fail,_,_) :- !,
|
||||
fail.
|
||||
handle_debug_command(break,Event,Depth) :- !,
|
||||
break,
|
||||
chr_debug_interact(Event,Depth).
|
||||
handle_debug_command(help,Event,Depth) :- !,
|
||||
print_message(help, chr(debug_options)),
|
||||
chr_debug_interact(Event,Depth).
|
||||
handle_debug_command(Cmd, _, _) :-
|
||||
throw(error(domain_error(chr_debug_command, Cmd), _)).
|
||||
|
||||
print_chr_debug_history :-
|
||||
get_debug_history(History,Depth),
|
||||
print_message(trace, chr(ancestors(History, Depth))).
|
||||
|
||||
print_event(Event, Depth) :-
|
||||
print_message(trace, chr(event(Event, Depth))).
|
||||
|
||||
% {set,get}_debug_history(Ancestors, Depth)
|
||||
%
|
||||
% Set/get the list of ancestors and the depth of the current goal.
|
||||
|
||||
get_debug_history(History,Depth) :-
|
||||
nb_getval(chr_debug_history,mutable(History,Depth)).
|
||||
|
||||
set_debug_history(History,Depth) :-
|
||||
nb_getval(chr_debug_history,Mutable),
|
||||
setarg(1,Mutable,History),
|
||||
setarg(2,Mutable,Depth).
|
||||
|
||||
set_chr_debug(State) :-
|
||||
nb_getval(chr_debug,Mutable),
|
||||
setarg(1,Mutable,State).
|
||||
|
||||
'chr chr_indexed_variables'(Susp,Vars) :-
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables(Args,Vars).
|
|
@ -0,0 +1,105 @@
|
|||
#include <SWI-Prolog.h>
|
||||
#include <stdlib.h>
|
||||
#include <ctype.h>
|
||||
|
||||
|
||||
/*
|
||||
lookup_ht(HT,Key,Values) :-
|
||||
term_hash(Key,Hash),
|
||||
HT = ht(Capacity,_,Table),
|
||||
Index is (Hash mod Capacity) + 1,
|
||||
arg(Index,Table,Bucket),
|
||||
nonvar(Bucket),
|
||||
( Bucket = K-Vs ->
|
||||
K == Key,
|
||||
Values = Vs
|
||||
;
|
||||
lookup(Bucket,Key,Values)
|
||||
).
|
||||
|
||||
lookup([K - V | KVs],Key,Value) :-
|
||||
( K = Key ->
|
||||
V = Value
|
||||
;
|
||||
lookup(KVs,Key,Value)
|
||||
).
|
||||
*/
|
||||
static foreign_t
|
||||
pl_lookup_ht1(term_t ht, term_t pl_hash, term_t key, term_t values)
|
||||
{
|
||||
int capacity;
|
||||
int hash;
|
||||
int index;
|
||||
|
||||
term_t pl_capacity = PL_new_term_ref();
|
||||
term_t table = PL_new_term_ref();
|
||||
term_t bucket = PL_new_term_ref();
|
||||
|
||||
/* HT = ht(Capacity,_,Table) */
|
||||
PL_get_arg(1, ht, pl_capacity);
|
||||
PL_get_integer(pl_capacity, &capacity);
|
||||
PL_get_arg(3, ht, table);
|
||||
|
||||
/* Index is (Hash mod Capacity) + 1 */
|
||||
PL_get_integer(pl_hash, &hash);
|
||||
index = (hash % capacity) + 1;
|
||||
|
||||
/* arg(Index,Table,Bucket) */
|
||||
PL_get_arg(index, table, bucket);
|
||||
|
||||
/* nonvar(Bucket) */
|
||||
if (PL_is_variable(bucket)) PL_fail;
|
||||
|
||||
if (PL_is_list(bucket)) {
|
||||
term_t pair = PL_new_term_ref();
|
||||
term_t k = PL_new_term_ref();
|
||||
term_t vs = PL_new_term_ref();
|
||||
while (PL_get_list(bucket, pair,bucket)) {
|
||||
PL_get_arg(1, pair, k);
|
||||
if ( PL_compare(k,key) == 0 ) {
|
||||
/* Values = Vs */
|
||||
PL_get_arg(2, pair, vs);
|
||||
return PL_unify(values,vs);
|
||||
}
|
||||
}
|
||||
PL_fail;
|
||||
} else {
|
||||
term_t k = PL_new_term_ref();
|
||||
term_t vs = PL_new_term_ref();
|
||||
PL_get_arg(1, bucket, k);
|
||||
/* K == Key */
|
||||
if ( PL_compare(k,key) == 0 ) {
|
||||
/* Values = Vs */
|
||||
PL_get_arg(2, bucket, vs);
|
||||
return PL_unify(values,vs);
|
||||
} else {
|
||||
PL_fail;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static foreign_t
|
||||
pl_memberchk_eq(term_t element, term_t maybe_list)
|
||||
{
|
||||
|
||||
term_t head = PL_new_term_ref(); /* variable for the elements */
|
||||
term_t list = PL_copy_term_ref(maybe_list); /* copy as we need to write */
|
||||
|
||||
while( PL_get_list(list, head, list) )
|
||||
{ if ( PL_compare(element,head) == 0 )
|
||||
PL_succeed ;
|
||||
}
|
||||
|
||||
PL_fail;
|
||||
|
||||
}
|
||||
|
||||
/* INSTALL */
|
||||
|
||||
install_t
|
||||
install_chr_support()
|
||||
{
|
||||
PL_register_foreign("memberchk_eq",2, pl_memberchk_eq, 0);
|
||||
PL_register_foreign("lookup_ht1",4, pl_lookup_ht1, 0);
|
||||
}
|
||||
|
|
@ -0,0 +1,449 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers and Jan Wielemaker
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%% SWI begin
|
||||
%% @addtogroup CHR
|
||||
%
|
||||
% SWI interface.
|
||||
%
|
||||
:- module(chr,
|
||||
[ op(1180, xfx, ==>),
|
||||
op(1180, xfx, <=>),
|
||||
op(1150, fx, constraints),
|
||||
op(1150, fx, chr_constraint),
|
||||
op(1150, fx, chr_preprocessor),
|
||||
op(1150, fx, handler),
|
||||
op(1150, fx, rules),
|
||||
op(1100, xfx, \),
|
||||
op(1200, xfx, @),
|
||||
op(1190, xfx, pragma),
|
||||
op( 500, yfx, #),
|
||||
op(1150, fx, chr_type),
|
||||
op(1150, fx, chr_declaration),
|
||||
op(1130, xfx, --->),
|
||||
op(1150, fx, (?)),
|
||||
chr_show_store/1, % +Module
|
||||
find_chr_constraint/1, % +Pattern
|
||||
chr_trace/0,
|
||||
chr_notrace/0,
|
||||
chr_leash/1 % +Ports
|
||||
]).
|
||||
|
||||
:- expects_dialect(swi).
|
||||
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
:- multifile user:file_search_path/2.
|
||||
:- dynamic user:file_search_path/2.
|
||||
:- dynamic chr_translated_program/1.
|
||||
|
||||
user:file_search_path(chr, library(chr)).
|
||||
|
||||
:- load_files([ chr(chr_translate),
|
||||
chr(chr_runtime),
|
||||
chr(chr_messages),
|
||||
chr(chr_hashtable_store),
|
||||
chr(chr_compiler_errors)
|
||||
],
|
||||
[ if(not_loaded),
|
||||
silent(true)
|
||||
]).
|
||||
|
||||
:- use_module(library(lists),[member/2]).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% :- module(chr,[
|
||||
%% chr_trace/0,
|
||||
%% chr_notrace/0,
|
||||
%% chr_leash/0,
|
||||
%% chr_flag/3,
|
||||
%% chr_show_store/1
|
||||
%% ]).
|
||||
%%
|
||||
%% :- op(1180, xfx, ==>),
|
||||
%% op(1180, xfx, <=>),
|
||||
%% op(1150, fx, constraints),
|
||||
%% op(1150, fx, handler),
|
||||
%% op(1150, fx, rules),
|
||||
%% op(1100, xfx, \),
|
||||
%% op(1200, xfx, @),
|
||||
%% op(1190, xfx, pragma),
|
||||
%% op( 500, yfx, #),
|
||||
%% op(1150, fx, chr_type),
|
||||
%% op(1130, xfx, --->),
|
||||
%% op(1150, fx, (?)).
|
||||
%%
|
||||
%% :- multifile user:file_search_path/2.
|
||||
%% :- dynamic chr_translated_program/1.
|
||||
%%
|
||||
%% user:file_search_path(chr, library(chr)).
|
||||
%%
|
||||
%%
|
||||
%% :- use_module('chr/chr_translate').
|
||||
%% :- use_module('chr/chr_runtime').
|
||||
%% :- use_module('chr/chr_hashtable_store').
|
||||
%% :- use_module('chr/hprolog').
|
||||
%% SICStus end
|
||||
|
||||
:- multifile chr:'$chr_module'/1.
|
||||
|
||||
:- dynamic chr_term/3. % File, Term
|
||||
|
||||
:- dynamic chr_pp/2. % File, Term
|
||||
|
||||
% chr_expandable(+Term)
|
||||
%
|
||||
% Succeeds if Term is a rule that must be handled by the CHR
|
||||
% compiler. Ideally CHR definitions should be between
|
||||
%
|
||||
% :- constraints ...
|
||||
% ...
|
||||
% :- end_constraints.
|
||||
%
|
||||
% As they are not we have to use some heuristics. We assume any
|
||||
% file is a CHR after we've seen :- constraints ...
|
||||
|
||||
chr_expandable((:- constraints _)).
|
||||
chr_expandable((constraints _)).
|
||||
chr_expandable((:- chr_constraint _)).
|
||||
chr_expandable((:- chr_type _)).
|
||||
chr_expandable((chr_type _)).
|
||||
chr_expandable((:- chr_declaration _)).
|
||||
chr_expandable(option(_, _)).
|
||||
chr_expandable((:- chr_option(_, _))).
|
||||
chr_expandable((handler _)).
|
||||
chr_expandable((rules _)).
|
||||
chr_expandable((_ <=> _)).
|
||||
chr_expandable((_ @ _)).
|
||||
chr_expandable((_ ==> _)).
|
||||
chr_expandable((_ pragma _)).
|
||||
|
||||
% chr_expand(+Term, -Expansion)
|
||||
%
|
||||
% Extract CHR declarations and rules from the file and run the
|
||||
% CHR compiler when reaching end-of-file.
|
||||
|
||||
%% SWI begin
|
||||
extra_declarations([ (:- use_module(chr(chr_runtime))),
|
||||
(:- style_check(-discontiguous)),
|
||||
(:- style_check(-singleton)),
|
||||
(:- style_check(-no_effect)),
|
||||
(:- set_prolog_flag(generate_debug_info, false))
|
||||
| Tail
|
||||
], Tail).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% extra_declarations([(:-use_module(chr(chr_runtime)))
|
||||
%% , (:- use_module(chr(hprolog),[term_variables/2,term_variables/3]))
|
||||
%% , (:-use_module(chr(hpattvars)))
|
||||
%% | Tail], Tail).
|
||||
%% SICStus end
|
||||
|
||||
chr_expand(Term, []) :-
|
||||
chr_expandable(Term), !,
|
||||
prolog_load_context(source,File),
|
||||
prolog_load_context(term_position,'$stream_position'(_, LineNumber, _, _, _)),
|
||||
add_pragma_to_chr_rule(Term,line_number(LineNumber),NTerm),
|
||||
assert(chr_term(File, LineNumber, NTerm)).
|
||||
chr_expand(Term, []) :-
|
||||
Term = (:- chr_preprocessor Preprocessor), !,
|
||||
prolog_load_context(source,File),
|
||||
assert(chr_pp(File, Preprocessor)).
|
||||
chr_expand(end_of_file, FinalProgram) :-
|
||||
extra_declarations(FinalProgram,Program),
|
||||
prolog_load_context(source,File),
|
||||
findall(T, retract(chr_term(File,_Line,T)), CHR0),
|
||||
CHR0 \== [],
|
||||
prolog_load_context(module, Module),
|
||||
add_debug_decl(CHR0, CHR1),
|
||||
add_optimise_decl(CHR1, CHR2),
|
||||
CHR3 = [ (:- module(Module, [])) | CHR2 ],
|
||||
findall(P, retract(chr_pp(File, P)), Preprocessors),
|
||||
( Preprocessors = [] ->
|
||||
CHR3 = CHR
|
||||
; Preprocessors = [Preprocessor] ->
|
||||
chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]),
|
||||
call_chr_preprocessor(Preprocessor,CHR3,CHR)
|
||||
;
|
||||
chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])),
|
||||
fail
|
||||
),
|
||||
catch(call_chr_translate(File,
|
||||
[ (:- module(Module, []))
|
||||
| CHR
|
||||
],
|
||||
Program0),
|
||||
chr_error(Error),
|
||||
( chr_compiler_errors:print_chr_error(Error),
|
||||
fail
|
||||
)
|
||||
),
|
||||
delete_header(Program0, Program).
|
||||
|
||||
|
||||
delete_header([(:- module(_,_))|T0], T) :- !,
|
||||
delete_header(T0, T).
|
||||
delete_header(L, L).
|
||||
|
||||
add_debug_decl(CHR, CHR) :-
|
||||
member(option(Name, _), CHR), Name == debug, !.
|
||||
add_debug_decl(CHR, CHR) :-
|
||||
member((:- chr_option(Name, _)), CHR), Name == debug, !.
|
||||
add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :-
|
||||
( chr_current_prolog_flag(generate_debug_info, true)
|
||||
-> Debug = on
|
||||
; Debug = off
|
||||
).
|
||||
|
||||
%% SWI begin
|
||||
chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).
|
||||
%% SWI end
|
||||
|
||||
add_optimise_decl(CHR, CHR) :-
|
||||
\+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !.
|
||||
add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :-
|
||||
chr_current_prolog_flag(optimize, full), !.
|
||||
add_optimise_decl(CHR, CHR).
|
||||
|
||||
|
||||
% call_chr_translate(+File, +In, -Out)
|
||||
%
|
||||
% The entire chr_translate/2 translation may fail, in which case we'd
|
||||
% better issue a warning rather than simply ignoring the CHR
|
||||
% declarations.
|
||||
|
||||
call_chr_translate(File, In, _Out) :-
|
||||
( chr_translate_line_info(In, File, Out0) ->
|
||||
nb_setval(chr_translated_program,Out0),
|
||||
fail
|
||||
).
|
||||
call_chr_translate(_, _In, Out) :-
|
||||
nb_current(chr_translated_program,Out), !,
|
||||
nb_delete(chr_translated_program).
|
||||
|
||||
call_chr_translate(File, _, []) :-
|
||||
print_message(error, chr(compilation_failed(File))).
|
||||
|
||||
call_chr_preprocessor(Preprocessor,CHR,_NCHR) :-
|
||||
( call(Preprocessor,CHR,CHR0) ->
|
||||
nb_setval(chr_preprocessed_program,CHR0),
|
||||
fail
|
||||
).
|
||||
call_chr_preprocessor(_,_,NCHR) :-
|
||||
nb_current(chr_preprocessed_program,NCHR), !,
|
||||
nb_delete(chr_preprocessed_program).
|
||||
call_chr_preprocessor(Preprocessor,_,_) :-
|
||||
chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])).
|
||||
|
||||
%% SWI begin
|
||||
|
||||
/*******************************
|
||||
* SYNCHRONISE TRACER *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3,
|
||||
chr:debug_event/2,
|
||||
chr:debug_interact/3.
|
||||
:- dynamic
|
||||
user:message_hook/3.
|
||||
|
||||
user:message_hook(trace_mode(OnOff), _, _) :-
|
||||
( OnOff == on
|
||||
-> chr_trace
|
||||
; chr_notrace
|
||||
),
|
||||
fail. % backtrack to other handlers
|
||||
|
||||
% chr:debug_event(+State, +Event)
|
||||
%
|
||||
% Hook into the CHR debugger. At this moment we will discard CHR
|
||||
% events if we are in a Prolog `skip' and we ignore the
|
||||
|
||||
chr:debug_event(_State, _Event) :-
|
||||
tracing, % are we tracing?
|
||||
prolog_skip_level(Skip, Skip),
|
||||
Skip \== very_deep,
|
||||
prolog_current_frame(Me),
|
||||
prolog_frame_attribute(Me, level, Level),
|
||||
Level > Skip, !.
|
||||
|
||||
% chr:debug_interact(+Event, +Depth, -Command)
|
||||
%
|
||||
% Hook into the CHR debugger to display Event and ask for the next
|
||||
% command to execute. This definition causes the normal Prolog
|
||||
% debugger to be used for the standard ports.
|
||||
|
||||
chr:debug_interact(Event, _Depth, creep) :-
|
||||
prolog_event(Event),
|
||||
tracing, !.
|
||||
|
||||
prolog_event(call(_)).
|
||||
prolog_event(exit(_)).
|
||||
prolog_event(fail(_)).
|
||||
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(chr(CHR)) -->
|
||||
chr_message(CHR).
|
||||
|
||||
:- multifile
|
||||
check:trivial_fail_goal/1.
|
||||
|
||||
check:trivial_fail_goal(_:Goal) :-
|
||||
functor(Goal, Name, _),
|
||||
sub_atom(Name, 0, _, _, '$chr_store_constants_').
|
||||
|
||||
/*******************************
|
||||
* TOPLEVEL PRINTING *
|
||||
*******************************/
|
||||
|
||||
:- create_prolog_flag(chr_toplevel_show_store, true, []).
|
||||
|
||||
prolog:message(query(YesNo)) --> !,
|
||||
['~@'-[chr:print_all_stores]],
|
||||
'$messages':prolog_message(query(YesNo)).
|
||||
|
||||
prolog:message(query(YesNo,Bindings)) --> !,
|
||||
['~@'-[chr:print_all_stores]],
|
||||
'$messages':prolog_message(query(YesNo,Bindings)).
|
||||
|
||||
print_all_stores :-
|
||||
( chr_current_prolog_flag(chr_toplevel_show_store,true),
|
||||
catch(nb_getval(chr_global, _), _, fail),
|
||||
chr:'$chr_module'(Mod),
|
||||
chr_show_store(Mod),
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
/*******************************
|
||||
* MUST BE LAST! *
|
||||
*******************************/
|
||||
:- multifile system:term_expansion/2.
|
||||
:- dynamic system:term_expansion/2.
|
||||
|
||||
system:term_expansion(In, Out) :-
|
||||
\+ current_prolog_flag(xref, true),
|
||||
chr_expand(In, Out).
|
||||
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%
|
||||
% :- dynamic
|
||||
% current_toplevel_show_store/1,
|
||||
% current_generate_debug_info/1,
|
||||
% current_optimize/1.
|
||||
%
|
||||
% current_toplevel_show_store(on).
|
||||
%
|
||||
% current_generate_debug_info(false).
|
||||
%
|
||||
% current_optimize(off).
|
||||
%
|
||||
% chr_current_prolog_flag(generate_debug_info, X) :-
|
||||
% chr_flag(generate_debug_info, X, X).
|
||||
% chr_current_prolog_flag(optimize, X) :-
|
||||
% chr_flag(optimize, X, X).
|
||||
%
|
||||
% chr_flag(Flag, Old, New) :-
|
||||
% Goal = chr_flag(Flag,Old,New),
|
||||
% g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1),
|
||||
% chr_flag(Flag, Old, New, Goal).
|
||||
%
|
||||
% chr_flag(toplevel_show_store, Old, New, Goal) :-
|
||||
% clause(current_toplevel_show_store(Old), true, Ref),
|
||||
% ( New==Old -> true
|
||||
% ; must_be(New, oneof([on,off]), Goal, 3),
|
||||
% erase(Ref),
|
||||
% assertz(current_toplevel_show_store(New))
|
||||
% ).
|
||||
% chr_flag(generate_debug_info, Old, New, Goal) :-
|
||||
% clause(current_generate_debug_info(Old), true, Ref),
|
||||
% ( New==Old -> true
|
||||
% ; must_be(New, oneof([false,true]), Goal, 3),
|
||||
% erase(Ref),
|
||||
% assertz(current_generate_debug_info(New))
|
||||
% ).
|
||||
% chr_flag(optimize, Old, New, Goal) :-
|
||||
% clause(current_optimize(Old), true, Ref),
|
||||
% ( New==Old -> true
|
||||
% ; must_be(New, oneof([full,off]), Goal, 3),
|
||||
% erase(Ref),
|
||||
% assertz(current_optimize(New))
|
||||
% ).
|
||||
%
|
||||
%
|
||||
% all_stores_goal(Goal, CVAs) :-
|
||||
% chr_flag(toplevel_show_store, on, on), !,
|
||||
% findall(C-CVAs, find_chr_constraint(C), Pairs),
|
||||
% andify(Pairs, Goal, CVAs).
|
||||
% all_stores_goal(true, _).
|
||||
%
|
||||
% andify([], true, _).
|
||||
% andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs).
|
||||
%
|
||||
% andify([], X, X, _).
|
||||
% andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs).
|
||||
%
|
||||
% :- multifile user:term_expansion/6.
|
||||
%
|
||||
% user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :-
|
||||
% nonvar(In),
|
||||
% nonmember(chr, Ids),
|
||||
% chr_expand(In, Out), !.
|
||||
%
|
||||
%% SICStus end
|
||||
|
||||
%%% for SSS %%%
|
||||
|
||||
add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :- !,
|
||||
add_pragma_to_chr_rule(Rule,Pragma,NRule),
|
||||
Result = (Name @ NRule).
|
||||
add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :- !,
|
||||
Result = (Rule pragma (Pragma,Pragmas)).
|
||||
add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :- !,
|
||||
Result = (Head ==> Body pragma Pragma).
|
||||
add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :- !,
|
||||
Result = (Head <=> Body pragma Pragma).
|
||||
add_pragma_to_chr_rule(Term,_,Term).
|
|
@ -0,0 +1,215 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(chr,
|
||||
[ chr_compile_step1/2 % +CHRFile, -PlFile
|
||||
, chr_compile_step2/2 % +CHRFile, -PlFile
|
||||
, chr_compile_step3/2 % +CHRFile, -PlFile
|
||||
, chr_compile_step4/2 % +CHRFile, -PlFile
|
||||
, chr_compile/3
|
||||
]).
|
||||
%% SWI begin
|
||||
% vsc:
|
||||
:- if(current_prolog_flag(dialect, yap)).
|
||||
|
||||
:- prolog_load_context(directory,D), add_to_path(D).
|
||||
|
||||
:- prolog_load_context(directory,D), atom_concat(D, '/../../library', D1), assert(user:library_directory(D1)).
|
||||
|
||||
:- prolog_load_context(directory,D), atom_concat(D, '/../../swi/library', D1), assert(user:library_directory(D1)).
|
||||
|
||||
:- else.
|
||||
|
||||
:- use_module(library(listing)). % portray_clause/2
|
||||
|
||||
:- endif.
|
||||
|
||||
:- expects_dialect(swi).
|
||||
|
||||
%% SWI end
|
||||
:- include(chr_op).
|
||||
|
||||
/*******************************
|
||||
* FILE-TO-FILE COMPILER *
|
||||
*******************************/
|
||||
|
||||
% chr_compile(+CHRFile, -PlFile)
|
||||
%
|
||||
% Compile a CHR specification into a Prolog file
|
||||
|
||||
chr_compile_step1(From, To) :-
|
||||
use_module('chr_translate_bootstrap.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
chr_compile_step2(From, To) :-
|
||||
use_module('chr_translate_bootstrap1.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
chr_compile_step3(From, To) :-
|
||||
use_module('chr_translate_bootstrap2.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
chr_compile_step4(From, To) :-
|
||||
use_module('chr_translate.pl'),
|
||||
chr_compile(From, To, informational).
|
||||
|
||||
chr_compile(From, To, MsgLevel) :-
|
||||
print_message(MsgLevel, chr(start(From))),
|
||||
read_chr_file_to_terms(From,Declarations),
|
||||
% read_file_to_terms(From, Declarations,
|
||||
% [ module(chr) % get operators from here
|
||||
% ]),
|
||||
print_message(silent, chr(translate(From))),
|
||||
chr_translate(Declarations, Declarations1),
|
||||
insert_declarations(Declarations1, NewDeclarations),
|
||||
print_message(silent, chr(write(To))),
|
||||
writefile(To, From, NewDeclarations),
|
||||
print_message(MsgLevel, chr(end(From, To))).
|
||||
|
||||
|
||||
%% SWI begin
|
||||
specific_declarations([ (:- use_module('chr_runtime')),
|
||||
(:- style_check(-discontiguous)),
|
||||
(:- style_check(-singleton)),
|
||||
(:- style_check(-no_effect))
|
||||
| Tail
|
||||
], Tail).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% specific_declarations([(:- use_module('chr_runtime')),
|
||||
%% (:-use_module(chr_hashtable_store)),
|
||||
%% (:- use_module('hpattvars')),
|
||||
%% (:- use_module('b_globval')),
|
||||
%% (:- use_module('hprolog')), % needed ?
|
||||
%% (:- set_prolog_flag(discontiguous_warnings,off)),
|
||||
%% (:- set_prolog_flag(single_var_warnings,off))|Tail], Tail).
|
||||
%% SICStus end
|
||||
|
||||
|
||||
|
||||
insert_declarations(Clauses0, Clauses) :-
|
||||
specific_declarations(Decls,Tail),
|
||||
(Clauses0 = [(:- module(M,E))|FileBody] ->
|
||||
Clauses = [ (:- module(M,E))|Decls],
|
||||
Tail = FileBody
|
||||
;
|
||||
Clauses = Decls,
|
||||
Tail = Clauses0
|
||||
).
|
||||
|
||||
% writefile(+File, +From, +Desclarations)
|
||||
%
|
||||
% Write translated CHR declarations to a File.
|
||||
|
||||
writefile(File, From, Declarations) :-
|
||||
open(File, write, Out),
|
||||
writeheader(From, Out),
|
||||
writecontent(Declarations, Out),
|
||||
close(Out).
|
||||
|
||||
writecontent([], _).
|
||||
writecontent([D|Ds], Out) :-
|
||||
portray_clause(Out, D), % SWI-Prolog
|
||||
writecontent(Ds, Out).
|
||||
|
||||
|
||||
writeheader(File, Out) :-
|
||||
format(Out, '/* Generated by CHR bootstrap compiler~n', []),
|
||||
format(Out, ' From: ~w~n', [File]),
|
||||
format_date(Out),
|
||||
format(Out, ' DO NOT EDIT. EDIT THE CHR FILE INSTEAD~n', []),
|
||||
format(Out, '*/~n~n', []).
|
||||
|
||||
%% SWI begin
|
||||
format_date(Out) :-
|
||||
get_time(Now),
|
||||
convert_time(Now, Date),
|
||||
format(Out, ' Date: ~w~n~n', [Date]).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% :- use_module(library(system), [datime/1]).
|
||||
%% format_date(Out) :-
|
||||
%% datime(datime(Year,Month,Day,Hour,Min,Sec)),
|
||||
%% format(Out, ' Date: ~d-~d-~d ~d:~d:~d~n~n', [Day,Month,Year,Hour,Min,Sec]).
|
||||
%% SICStus end
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(chr(start(File))) -->
|
||||
{ file_base_name(File, Base)
|
||||
},
|
||||
[ 'Translating CHR file ~w'-[Base] ].
|
||||
prolog:message(chr(end(_From, To))) -->
|
||||
{ file_base_name(To, Base)
|
||||
},
|
||||
[ 'Written translation to ~w'-[Base] ].
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
read_chr_file_to_terms(Spec, Terms) :-
|
||||
chr_absolute_file_name(Spec, [ access(read) ], Path),
|
||||
open(Path, read, Fd, []),
|
||||
read_chr_stream_to_terms(Fd, Terms),
|
||||
close(Fd).
|
||||
|
||||
read_chr_stream_to_terms(Fd, Terms) :-
|
||||
chr_local_only_read_term(Fd, C0, [ module(chr) ]),
|
||||
read_chr_stream_to_terms(C0, Fd, Terms).
|
||||
|
||||
read_chr_stream_to_terms(end_of_file, _, []) :- !.
|
||||
read_chr_stream_to_terms(C, Fd, [C|T]) :-
|
||||
( ground(C),
|
||||
C = (:- op(Priority,Type,Name)) ->
|
||||
op(Priority,Type,Name)
|
||||
;
|
||||
true
|
||||
),
|
||||
chr_local_only_read_term(Fd, C2, [module(chr)]),
|
||||
read_chr_stream_to_terms(C2, Fd, T).
|
||||
|
||||
|
||||
|
||||
|
||||
%% SWI begin
|
||||
chr_local_only_read_term(A,B,C) :- read_term(A,B,C).
|
||||
chr_absolute_file_name(A,B,C) :- absolute_file_name(A,B,C).
|
||||
%% SWI end
|
||||
|
||||
%% SICStus begin
|
||||
%% chr_local_only_read_term(A,B,_) :- read_term(A,B,[]).
|
||||
%% chr_absolute_file_name(A,B,C) :- absolute_file_name(A,C,B).
|
||||
%% SICStus end
|
|
@ -0,0 +1,170 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2005,2006, University of Amsterdam
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
:- asserta(user:file_search_path(chr, '.')).
|
||||
:- asserta(user:file_search_path(library, '.')).
|
||||
:- use_module(library(chr)).
|
||||
%% :- use_module(chr). % == library(chr)
|
||||
|
||||
:- set_prolog_flag(optimise, true).
|
||||
%:- set_prolog_flag(trace_gc, true).
|
||||
|
||||
:- format('CHR test suite. To run all tests run ?- test.~n~n', []).
|
||||
|
||||
/*******************************
|
||||
* SCRIPTS *
|
||||
*******************************/
|
||||
|
||||
|
||||
:- dynamic
|
||||
script_dir/1.
|
||||
|
||||
set_script_dir :-
|
||||
script_dir(_), !.
|
||||
set_script_dir :-
|
||||
find_script_dir(Dir),
|
||||
assert(script_dir(Dir)).
|
||||
|
||||
find_script_dir(Dir) :-
|
||||
prolog_load_context(file, File),
|
||||
follow_links(File, RealFile),
|
||||
file_directory_name(RealFile, Dir).
|
||||
|
||||
follow_links(File, RealFile) :-
|
||||
read_link(File, _, RealFile), !.
|
||||
follow_links(File, File).
|
||||
|
||||
|
||||
:- set_script_dir.
|
||||
|
||||
run_test_script(Script) :-
|
||||
file_base_name(Script, Base),
|
||||
file_name_extension(Pred, _, Base),
|
||||
format(' ~w~n',[Script]),
|
||||
load_files(Script, []), %[silent(true)]),
|
||||
Pred.
|
||||
|
||||
run_test_scripts(Directory) :-
|
||||
( script_dir(ScriptDir),
|
||||
concat_atom([ScriptDir, /, Directory], Dir),
|
||||
exists_directory(Dir)
|
||||
-> true
|
||||
; Dir = Directory
|
||||
),
|
||||
atom_concat(Dir, '/*.chr', Pattern),
|
||||
expand_file_name(Pattern, Files),
|
||||
file_base_name(Dir, BaseDir),
|
||||
format('Running scripts from ~w ', [BaseDir]), flush_output,
|
||||
run_scripts(Files),
|
||||
format(' done~n').
|
||||
|
||||
run_scripts([]).
|
||||
run_scripts([H|T]) :-
|
||||
( catch(run_test_script(H), Except, true)
|
||||
-> ( var(Except)
|
||||
-> put(.), flush_output
|
||||
; Except = blocked(Reason)
|
||||
-> assert(blocked(H, Reason)),
|
||||
put(!), flush_output
|
||||
; script_failed(H, Except)
|
||||
)
|
||||
; script_failed(H, fail)
|
||||
),
|
||||
run_scripts(T).
|
||||
|
||||
script_failed(File, fail) :-
|
||||
format('~NScript ~w failed~n', [File]),
|
||||
assert(failed(script(File))).
|
||||
script_failed(File, Except) :-
|
||||
message_to_string(Except, Error),
|
||||
format('~NScript ~w failed: ~w~n', [File, Error]),
|
||||
assert(failed(script(File))).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TEST MAIN-LOOP *
|
||||
*******************************/
|
||||
|
||||
testdir('Tests').
|
||||
|
||||
:- dynamic
|
||||
failed/1,
|
||||
blocked/2.
|
||||
|
||||
test :-
|
||||
retractall(failed(_)),
|
||||
retractall(blocked(_,_)),
|
||||
scripts,
|
||||
report_blocked,
|
||||
report_failed.
|
||||
|
||||
scripts :-
|
||||
forall(testdir(Dir), run_test_scripts(Dir)).
|
||||
|
||||
|
||||
report_blocked :-
|
||||
findall(Head-Reason, blocked(Head, Reason), L),
|
||||
( L \== []
|
||||
-> format('~nThe following tests are blocked:~n', []),
|
||||
( member(Head-Reason, L),
|
||||
format(' ~p~t~40|~w~n', [Head, Reason]),
|
||||
fail
|
||||
; true
|
||||
)
|
||||
; true
|
||||
).
|
||||
report_failed :-
|
||||
findall(X, failed(X), L),
|
||||
length(L, Len),
|
||||
( Len > 0
|
||||
-> format('~n*** ~w tests failed ***~n', [Len]),
|
||||
fail
|
||||
; format('~nAll tests passed~n', [])
|
||||
).
|
||||
|
||||
test_failed(R, Except) :-
|
||||
clause(Head, _, R),
|
||||
functor(Head, Name, 1),
|
||||
arg(1, Head, TestName),
|
||||
clause_property(R, line_count(Line)),
|
||||
clause_property(R, file(File)),
|
||||
( Except == fail
|
||||
-> format('~N~w:~d: Test ~w(~w) failed~n',
|
||||
[File, Line, Name, TestName])
|
||||
; message_to_string(Except, Error),
|
||||
format('~N~w:~d: Test ~w(~w):~n~t~8|ERROR: ~w~n',
|
||||
[File, Line, Name, TestName, Error])
|
||||
),
|
||||
assert(failed(Head)).
|
||||
|
||||
blocked(Reason) :-
|
||||
throw(blocked(Reason)).
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,249 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
% ____ _ ____ _ _
|
||||
% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
|
||||
% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
|
||||
% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
|
||||
% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
|
||||
% |___/
|
||||
%
|
||||
% To be done:
|
||||
% inline clauses
|
||||
|
||||
:- module(clean_code,
|
||||
[
|
||||
clean_clauses/2
|
||||
]).
|
||||
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
|
||||
clean_clauses(Clauses,NClauses) :-
|
||||
clean_clauses1(Clauses,Clauses1),
|
||||
merge_clauses(Clauses1,NClauses).
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% CLEAN CLAUSES
|
||||
%
|
||||
% - move neck unification into the head of the clause
|
||||
% - drop true body
|
||||
% - specialize control flow goal wrt true and fail
|
||||
%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
clean_clauses1([],[]).
|
||||
clean_clauses1([C|Cs],[NC|NCs]) :-
|
||||
clean_clause(C,NC),
|
||||
clean_clauses1(Cs,NCs).
|
||||
|
||||
clean_clause(Clause,NClause) :-
|
||||
( Clause = (Head :- Body) ->
|
||||
clean_goal(Body,Body1),
|
||||
move_unification_into_head(Head,Body1,NHead,NBody),
|
||||
( NBody == true ->
|
||||
NClause = NHead
|
||||
;
|
||||
NClause = (NHead :- NBody)
|
||||
)
|
||||
; Clause = '$source_location'(File,Line) : ActualClause ->
|
||||
NClause = '$source_location'(File,Line) : NActualClause,
|
||||
clean_clause(ActualClause,NActualClause)
|
||||
;
|
||||
NClause = Clause
|
||||
).
|
||||
|
||||
clean_goal(Goal,NGoal) :-
|
||||
var(Goal), !,
|
||||
NGoal = Goal.
|
||||
clean_goal((G1,G2),NGoal) :-
|
||||
!,
|
||||
clean_goal(G1,NG1),
|
||||
clean_goal(G2,NG2),
|
||||
( NG1 == true ->
|
||||
NGoal = NG2
|
||||
; NG2 == true ->
|
||||
NGoal = NG1
|
||||
;
|
||||
NGoal = (NG1,NG2)
|
||||
).
|
||||
clean_goal((If -> Then ; Else),NGoal) :-
|
||||
!,
|
||||
clean_goal(If,NIf),
|
||||
( NIf == true ->
|
||||
clean_goal(Then,NThen),
|
||||
NGoal = NThen
|
||||
; NIf == fail ->
|
||||
clean_goal(Else,NElse),
|
||||
NGoal = NElse
|
||||
;
|
||||
clean_goal(Then,NThen),
|
||||
clean_goal(Else,NElse),
|
||||
NGoal = (NIf -> NThen; NElse)
|
||||
).
|
||||
clean_goal((G1 ; G2),NGoal) :-
|
||||
!,
|
||||
clean_goal(G1,NG1),
|
||||
clean_goal(G2,NG2),
|
||||
( NG1 == fail ->
|
||||
NGoal = NG2
|
||||
; NG2 == fail ->
|
||||
NGoal = NG1
|
||||
;
|
||||
NGoal = (NG1 ; NG2)
|
||||
).
|
||||
clean_goal(once(G),NGoal) :-
|
||||
!,
|
||||
clean_goal(G,NG),
|
||||
( NG == true ->
|
||||
NGoal = true
|
||||
; NG == fail ->
|
||||
NGoal = fail
|
||||
;
|
||||
NGoal = once(NG)
|
||||
).
|
||||
clean_goal((G1 -> G2),NGoal) :-
|
||||
!,
|
||||
clean_goal(G1,NG1),
|
||||
( NG1 == true ->
|
||||
clean_goal(G2,NGoal)
|
||||
; NG1 == fail ->
|
||||
NGoal = fail
|
||||
;
|
||||
clean_goal(G2,NG2),
|
||||
NGoal = (NG1 -> NG2)
|
||||
).
|
||||
clean_goal(Goal,Goal).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
move_unification_into_head(Head,Body,NHead,NBody) :-
|
||||
conj2list(Body,BodyList),
|
||||
move_unification_into_head_(BodyList,Head,NHead,NBody).
|
||||
|
||||
move_unification_into_head_([],Head,Head,true).
|
||||
move_unification_into_head_([G|Gs],Head,NHead,NBody) :-
|
||||
( nonvar(G), G = (X = Y) ->
|
||||
term_variables(Gs,GsVars),
|
||||
( var(X), ( \+ memberchk_eq(X,GsVars) ; atomic(Y)) ->
|
||||
X = Y,
|
||||
move_unification_into_head_(Gs,Head,NHead,NBody)
|
||||
; var(Y), (\+ memberchk_eq(Y,GsVars) ; atomic(X)) ->
|
||||
X = Y,
|
||||
move_unification_into_head_(Gs,Head,NHead,NBody)
|
||||
;
|
||||
Head = NHead,
|
||||
list2conj([G|Gs],NBody)
|
||||
)
|
||||
;
|
||||
Head = NHead,
|
||||
list2conj([G|Gs],NBody)
|
||||
).
|
||||
|
||||
|
||||
conj2list(Conj,L) :- %% transform conjunctions to list
|
||||
conj2list(Conj,L,[]).
|
||||
|
||||
conj2list(G,L,T) :-
|
||||
var(G), !,
|
||||
L = [G|T].
|
||||
conj2list(true,L,L) :- !.
|
||||
conj2list(Conj,L,T) :-
|
||||
Conj = (G1,G2), !,
|
||||
conj2list(G1,L,T1),
|
||||
conj2list(G2,T1,T).
|
||||
conj2list(G,[G | T],T).
|
||||
|
||||
list2conj([],true).
|
||||
list2conj([G],X) :- !, X = G.
|
||||
list2conj([G|Gs],C) :-
|
||||
( G == true -> %% remove some redundant trues
|
||||
list2conj(Gs,C)
|
||||
;
|
||||
C = (G,R),
|
||||
list2conj(Gs,R)
|
||||
).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% MERGE CLAUSES
|
||||
%
|
||||
% Find common prefixes of successive clauses and share them.
|
||||
%
|
||||
% Note: we assume that the prefix does not generate a side effect.
|
||||
%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
merge_clauses([],[]).
|
||||
merge_clauses([C],[C]).
|
||||
merge_clauses([X,Y|Clauses],NClauses) :-
|
||||
( merge_two_clauses(X,Y,Clause) ->
|
||||
merge_clauses([Clause|Clauses],NClauses)
|
||||
;
|
||||
NClauses = [X|RClauses],
|
||||
merge_clauses([Y|Clauses],RClauses)
|
||||
).
|
||||
|
||||
merge_two_clauses('$source_location'(F1,L1) : C1,
|
||||
'$source_location'(_F2,_L2) : C2,
|
||||
Result) :- !,
|
||||
merge_two_clauses(C1,C2,C),
|
||||
Result = '$source_location'(F1,L1) : C.
|
||||
merge_two_clauses((H1 :- B1), (H2 :- B2), (H :- B)) :-
|
||||
H1 =@= H2,
|
||||
H1 = H,
|
||||
conj2list(B1,List1),
|
||||
conj2list(B2,List2),
|
||||
merge_lists(List1,List2,H1,H2,Unifier,List,NList1,NList2),
|
||||
List \= [],
|
||||
H1 = H2,
|
||||
call(Unifier),
|
||||
list2conj(List,Prefix),
|
||||
list2conj(NList1,NB1),
|
||||
( NList2 == (!) ->
|
||||
B = Prefix
|
||||
;
|
||||
list2conj(NList2,NB2),
|
||||
B = (Prefix,(NB1 ; NB2))
|
||||
).
|
||||
|
||||
merge_lists([],[],_,_,true,[],[],[]).
|
||||
merge_lists([],L2,_,_,true,[],[],L2).
|
||||
merge_lists([!|Xs],_,_,_,true,[!|Xs],[],!) :- !.
|
||||
merge_lists([X|Xs],[],_,_,true,[],[X|Xs],[]).
|
||||
merge_lists([X|Xs],[Y|Ys],H1,H2,Unifier,Common,N1,N2) :-
|
||||
( H1-X =@= H2-Y ->
|
||||
Unifier = (X = Y, RUnifier),
|
||||
Common = [X|NCommon],
|
||||
merge_lists(Xs,Ys,H1/X,H2/Y,RUnifier,NCommon,N1,N2)
|
||||
;
|
||||
Unifier = true,
|
||||
Common = [],
|
||||
N1 = [X|Xs],
|
||||
N2 = [Y|Ys]
|
||||
).
|
|
@ -0,0 +1,15 @@
|
|||
dnl Process this file with autoconf to produce a configure script.
|
||||
|
||||
AC_INIT(install-sh)
|
||||
AC_PREREQ([2.50])
|
||||
|
||||
AC_ARG_ENABLE(chr,
|
||||
[ --enable-chr install chr library ],
|
||||
use_chr="$enableval", use_chr=yes)
|
||||
|
||||
|
||||
AC_CONFIG_HEADER(config.h)
|
||||
|
||||
m4_include([../ac_swi_noc.m4])
|
||||
|
||||
AC_OUTPUT(Makefile)
|
|
@ -0,0 +1,79 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Bart Demoen, Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%% @addtogroup CHR_in_YAP_Programs
|
||||
%
|
||||
% CHR controlling the compiler
|
||||
%
|
||||
:- module(chr_find,
|
||||
[
|
||||
find_with_var_identity/4,
|
||||
forall/3,
|
||||
forsome/3
|
||||
]).
|
||||
|
||||
:- use_module(library(lists)).
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
:- meta_predicate
|
||||
find_with_var_identity(?, +, :, -),
|
||||
forall(-, +, :),
|
||||
forsome(-, +, :).
|
||||
|
||||
find_with_var_identity(Template, IdVars, Goal, Answers) :-
|
||||
Key = foo(IdVars),
|
||||
copy_term_nat(Template-Key-Goal,TemplateC-KeyC-GoalC),
|
||||
findall(KeyC - TemplateC, GoalC, As),
|
||||
smash(As,Key,Answers).
|
||||
|
||||
smash([],_,[]).
|
||||
smash([Key-T|R],Key,[T|NR]) :- smash(R,Key,NR).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
forall(X,L,G) :-
|
||||
\+ (member(X,L), \+ call(G)).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
forsome(X,L,G) :-
|
||||
member(X,L),
|
||||
call(G), !.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
:- dynamic
|
||||
user:goal_expansion/2.
|
||||
:- multifile
|
||||
user:goal_expansion/2.
|
||||
|
||||
user:goal_expansion(forall(Element,List,Test), GoalOut) :-
|
||||
nonvar(Test),
|
||||
Test =.. [Functor,Arg],
|
||||
Arg == Element,
|
||||
GoalOut = once(maplist(Functor,List)).
|
|
@ -0,0 +1,511 @@
|
|||
:- module(guard_entailment,
|
||||
[ entails_guard/2,
|
||||
simplify_guards/5
|
||||
]).
|
||||
:- include(chr_op).
|
||||
:- use_module(library(dialect/hprolog)).
|
||||
:- use_module(builtins).
|
||||
:- use_module(chr_compiler_errors).
|
||||
:- chr_option(debug, off).
|
||||
:- chr_option(optimize, full).
|
||||
:- chr_option(verbosity,off).
|
||||
%:- chr_option(dynattr,on).
|
||||
:- chr_constraint known/1, test/1, cleanup/0, variables/1.
|
||||
entails_guard(A, B) :-
|
||||
copy_term_nat((A, B), (C, F)),
|
||||
term_variables(C, D),
|
||||
variables(D),
|
||||
sort(C, E),
|
||||
entails_guard2(E), !,
|
||||
test(F), !,
|
||||
cleanup.
|
||||
entails_guard2([]).
|
||||
entails_guard2([A|B]) :-
|
||||
known(A),
|
||||
entails_guard2(B).
|
||||
simplify_guards(A, H, B, G, I) :-
|
||||
copy_term_nat((A, B), (C, E)),
|
||||
term_variables(C, D),
|
||||
variables(D),
|
||||
sort(C,Z),
|
||||
entails_guard2(Z), !,
|
||||
simplify(E, F),
|
||||
simplified(B, F, G, H, I), !,
|
||||
cleanup.
|
||||
simplified([], [], [], A, A).
|
||||
simplified([A|B], [keep|C], [A|D], E, F) :-
|
||||
simplified(B, C, D, E, F).
|
||||
simplified([_|_], [fail|_], fail, A, A).
|
||||
simplified([A|B], [true|L], [I|M], F, J) :-
|
||||
builtins:binds_b(A, C),
|
||||
term_variables(B, D),
|
||||
intersect_eq(C, D, E), !,
|
||||
( E=[]
|
||||
-> term_variables(F, G),
|
||||
intersect_eq(C, G, H), !,
|
||||
( H=[]
|
||||
-> I=true,
|
||||
J=K
|
||||
; I=true,
|
||||
J= (A, K)
|
||||
)
|
||||
; I=A,
|
||||
J=K
|
||||
),
|
||||
simplified(B, L, M, F, K).
|
||||
simplify([], []).
|
||||
simplify([A|D], [B|E]) :-
|
||||
( \+try(true, A)
|
||||
-> B=true
|
||||
; builtins:negate_b(A, C),
|
||||
( \+try(true, C)
|
||||
-> B=fail
|
||||
; B=keep
|
||||
)
|
||||
),
|
||||
known(A),
|
||||
simplify(D, E).
|
||||
try(A, B) :-
|
||||
( known(A)
|
||||
-> true
|
||||
; chr_error(internal, 'Entailment Checker: try/2.\n', [])
|
||||
),
|
||||
( test(B)
|
||||
-> fail
|
||||
; true
|
||||
).
|
||||
add_args_unif([], [], true).
|
||||
add_args_unif([A|C], [B|D], (A=B, E)) :-
|
||||
add_args_unif(C, D, E).
|
||||
add_args_nunif([], [], fail).
|
||||
add_args_nunif([A|C], [B|D], (A\=B;E)) :-
|
||||
add_args_nunif(C, D, E).
|
||||
add_args_nmatch([], [], fail).
|
||||
add_args_nmatch([A|C], [B|D], (A\==B;E)) :-
|
||||
add_args_nmatch(C, D, E).
|
||||
all_unique_vars(A, B) :-
|
||||
all_unique_vars(A, B, []).
|
||||
all_unique_vars([], _, _).
|
||||
all_unique_vars([A|D], B, C) :-
|
||||
var(A),
|
||||
\+memberchk_eq(A, B),
|
||||
\+memberchk_eq(A, C),
|
||||
all_unique_vars(D, [A|C]).
|
||||
:- chr_constraint'test/1_1_$default'/1, 'test/1_1_$special_,/2'/2, 'test/1_1_$special_\\+/1'/1, 'test/1_1_$special_integer/1'/1, 'test/1_1_$special_float/1'/1, 'test/1_1_$special_number/1'/1, 'test/1_1_$special_ground/1'/1, 'test/1_1_$special_=:=/2'/2, 'test/1_1_$special_==/2'/2, 'test/1_1_$special_true/0'/0, 'test/1_1_$special_functor/3'/3, 'test/1_1_$special_=/2'/2, 'test/1_1_$special_;/2'/2, 'test/1_1_$special_is/2'/2, 'test/1_1_$special_</2'/2, 'test/1_1_$special_>=/2'/2, 'test/1_1_$special_>/2'/2, 'test/1_1_$special_=\\=/2'/2, 'test/1_1_$special_=</2'/2, 'test/1_1_$special_\\==/2'/2, 'known/1_1_$default'/1, 'known/1_1_$special_;/2'/2, 'known/1_1_$special_nonvar/1'/1, 'known/1_1_$special_var/1'/1, 'known/1_1_$special_atom/1'/1, 'known/1_1_$special_atomic/1'/1, 'known/1_1_$special_compound/1'/1, 'known/1_1_$special_ground/1'/1, 'known/1_1_$special_integer/1'/1, 'known/1_1_$special_float/1'/1, 'known/1_1_$special_number/1'/1, 'known/1_1_$special_=\\=/2'/2, 'known/1_1_$special_\\+/1'/1, 'known/1_1_$special_functor/3'/3, 'known/1_1_$special_\\=/2'/2, 'known/1_1_$special_=/2'/2, 'known/1_1_$special_,/2'/2, 'known/1_1_$special_\\==/2'/2, 'known/1_1_$special_==/2'/2, 'known/1_1_$special_is/2'/2, 'known/1_1_$special_</2'/2, 'known/1_1_$special_>=/2'/2, 'known/1_1_$special_>/2'/2, 'known/1_1_$special_=</2'/2, 'known/1_1_$special_=:=/2'/2, 'known/1_1_$special_fail/0'/0.
|
||||
test((A, B))<=>'test/1_1_$special_,/2'(A, B).
|
||||
test(\+A)<=>'test/1_1_$special_\\+/1'(A).
|
||||
test(integer(A))<=>'test/1_1_$special_integer/1'(A).
|
||||
test(float(A))<=>'test/1_1_$special_float/1'(A).
|
||||
test(number(A))<=>'test/1_1_$special_number/1'(A).
|
||||
test(ground(A))<=>'test/1_1_$special_ground/1'(A).
|
||||
test(A=:=B)<=>'test/1_1_$special_=:=/2'(A, B).
|
||||
test(A==B)<=>'test/1_1_$special_==/2'(A, B).
|
||||
test(true)<=>'test/1_1_$special_true/0'.
|
||||
test(functor(A, B, C))<=>'test/1_1_$special_functor/3'(A, B, C).
|
||||
test(A=B)<=>'test/1_1_$special_=/2'(A, B).
|
||||
test((A;B))<=>'test/1_1_$special_;/2'(A, B).
|
||||
test(A is B)<=>'test/1_1_$special_is/2'(A, B).
|
||||
test(A<B)<=>'test/1_1_$special_</2'(A, B).
|
||||
test(A>=B)<=>'test/1_1_$special_>=/2'(A, B).
|
||||
test(A>B)<=>'test/1_1_$special_>/2'(A, B).
|
||||
test(A=\=B)<=>'test/1_1_$special_=\\=/2'(A, B).
|
||||
test(A=<B)<=>'test/1_1_$special_=</2'(A, B).
|
||||
test(A\==B)<=>'test/1_1_$special_\\==/2'(A, B).
|
||||
test(A)<=>'test/1_1_$default'(A).
|
||||
known((A;B))<=>'known/1_1_$special_;/2'(A, B).
|
||||
known(nonvar(A))<=>'known/1_1_$special_nonvar/1'(A).
|
||||
known(var(A))<=>'known/1_1_$special_var/1'(A).
|
||||
known(atom(A))<=>'known/1_1_$special_atom/1'(A).
|
||||
known(atomic(A))<=>'known/1_1_$special_atomic/1'(A).
|
||||
known(compound(A))<=>'known/1_1_$special_compound/1'(A).
|
||||
known(ground(A))<=>'known/1_1_$special_ground/1'(A).
|
||||
known(integer(A))<=>'known/1_1_$special_integer/1'(A).
|
||||
known(float(A))<=>'known/1_1_$special_float/1'(A).
|
||||
known(number(A))<=>'known/1_1_$special_number/1'(A).
|
||||
known(A=\=B)<=>'known/1_1_$special_=\\=/2'(A, B).
|
||||
known(\+A)<=>'known/1_1_$special_\\+/1'(A).
|
||||
known(functor(A, B, C))<=>'known/1_1_$special_functor/3'(A, B, C).
|
||||
known(A\=B)<=>'known/1_1_$special_\\=/2'(A, B).
|
||||
known(A=B)<=>'known/1_1_$special_=/2'(A, B).
|
||||
known((A, B))<=>'known/1_1_$special_,/2'(A, B).
|
||||
known(A\==B)<=>'known/1_1_$special_\\==/2'(A, B).
|
||||
known(A==B)<=>'known/1_1_$special_==/2'(A, B).
|
||||
known(A is B)<=>'known/1_1_$special_is/2'(A, B).
|
||||
known(A<B)<=>'known/1_1_$special_</2'(A, B).
|
||||
known(A>=B)<=>'known/1_1_$special_>=/2'(A, B).
|
||||
known(A>B)<=>'known/1_1_$special_>/2'(A, B).
|
||||
known(A=<B)<=>'known/1_1_$special_=</2'(A, B).
|
||||
known(A=:=B)<=>'known/1_1_$special_=:=/2'(A, B).
|
||||
known(fail)<=>'known/1_1_$special_fail/0'.
|
||||
known(A)<=>'known/1_1_$default'(A).
|
||||
'known/1_1_$special_;/2'(A, B)\'known/1_1_$special_;/2'(A, B)<=>true.
|
||||
'known/1_1_$special_nonvar/1'(A)\'known/1_1_$special_nonvar/1'(A)<=>true.
|
||||
'known/1_1_$special_var/1'(A)\'known/1_1_$special_var/1'(A)<=>true.
|
||||
'known/1_1_$special_atom/1'(A)\'known/1_1_$special_atom/1'(A)<=>true.
|
||||
'known/1_1_$special_atomic/1'(A)\'known/1_1_$special_atomic/1'(A)<=>true.
|
||||
'known/1_1_$special_compound/1'(A)\'known/1_1_$special_compound/1'(A)<=>true.
|
||||
'known/1_1_$special_ground/1'(A)\'known/1_1_$special_ground/1'(A)<=>true.
|
||||
'known/1_1_$special_integer/1'(A)\'known/1_1_$special_integer/1'(A)<=>true.
|
||||
'known/1_1_$special_float/1'(A)\'known/1_1_$special_float/1'(A)<=>true.
|
||||
'known/1_1_$special_number/1'(A)\'known/1_1_$special_number/1'(A)<=>true.
|
||||
'known/1_1_$special_=\\=/2'(A, B)\'known/1_1_$special_=\\=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_\\+/1'(A)<=>true.
|
||||
'known/1_1_$special_functor/3'(A, B, C)\'known/1_1_$special_functor/3'(A, B, C)<=>true.
|
||||
'known/1_1_$special_\\=/2'(A, B)\'known/1_1_$special_\\=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_=/2'(A, B)\'known/1_1_$special_=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_,/2'(A, B)\'known/1_1_$special_,/2'(A, B)<=>true.
|
||||
'known/1_1_$special_\\==/2'(A, B)\'known/1_1_$special_\\==/2'(A, B)<=>true.
|
||||
'known/1_1_$special_==/2'(A, B)\'known/1_1_$special_==/2'(A, B)<=>true.
|
||||
'known/1_1_$special_is/2'(A, B)\'known/1_1_$special_is/2'(A, B)<=>true.
|
||||
'known/1_1_$special_</2'(A, B)\'known/1_1_$special_</2'(A, B)<=>true.
|
||||
'known/1_1_$special_>=/2'(A, B)\'known/1_1_$special_>=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_>/2'(A, B)\'known/1_1_$special_>/2'(A, B)<=>true.
|
||||
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_=</2'(A, B)<=>true.
|
||||
'known/1_1_$special_=:=/2'(A, B)\'known/1_1_$special_=:=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_fail/0'<=>true.
|
||||
'known/1_1_$default'(A)\'known/1_1_$default'(A)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_,/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_\\+/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_integer/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_float/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_number/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_ground/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_=:=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_==/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_true/0'<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_functor/3'(_, _, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_;/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_is/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_</2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_>=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_>/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_=\\=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_=</2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$special_\\==/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$default'(_)<=>true.
|
||||
'known/1_1_$special_;/2'(A, B)\'test/1_1_$special_;/2'(A, B)<=>true.
|
||||
'known/1_1_$special_nonvar/1'(A)\'test/1_1_$default'(nonvar(A))<=>true.
|
||||
'known/1_1_$special_var/1'(A)\'test/1_1_$default'(var(A))<=>true.
|
||||
'known/1_1_$special_atom/1'(A)\'test/1_1_$default'(atom(A))<=>true.
|
||||
'known/1_1_$special_atomic/1'(A)\'test/1_1_$default'(atomic(A))<=>true.
|
||||
'known/1_1_$special_compound/1'(A)\'test/1_1_$default'(compound(A))<=>true.
|
||||
'known/1_1_$special_ground/1'(A)\'test/1_1_$special_ground/1'(A)<=>true.
|
||||
'known/1_1_$special_integer/1'(A)\'test/1_1_$special_integer/1'(A)<=>true.
|
||||
'known/1_1_$special_float/1'(A)\'test/1_1_$special_float/1'(A)<=>true.
|
||||
'known/1_1_$special_number/1'(A)\'test/1_1_$special_number/1'(A)<=>true.
|
||||
'known/1_1_$special_=\\=/2'(A, B)\'test/1_1_$special_=\\=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_\\+/1'(A)\'test/1_1_$special_\\+/1'(A)<=>true.
|
||||
'known/1_1_$special_functor/3'(A, B, C)\'test/1_1_$special_functor/3'(A, B, C)<=>true.
|
||||
'known/1_1_$special_\\=/2'(A, B)\'test/1_1_$default'(A\=B)<=>true.
|
||||
'known/1_1_$special_=/2'(A, B)\'test/1_1_$special_=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_,/2'(A, B)\'test/1_1_$special_,/2'(A, B)<=>true.
|
||||
'known/1_1_$special_\\==/2'(A, B)\'test/1_1_$special_\\==/2'(A, B)<=>true.
|
||||
'known/1_1_$special_==/2'(A, B)\'test/1_1_$special_==/2'(A, B)<=>true.
|
||||
'known/1_1_$special_is/2'(A, B)\'test/1_1_$special_is/2'(A, B)<=>true.
|
||||
'known/1_1_$special_</2'(A, B)\'test/1_1_$special_</2'(A, B)<=>true.
|
||||
'known/1_1_$special_>=/2'(A, B)\'test/1_1_$special_>=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_>/2'(A, B)\'test/1_1_$special_>/2'(A, B)<=>true.
|
||||
'known/1_1_$special_=</2'(A, B)\'test/1_1_$special_=</2'(A, B)<=>true.
|
||||
'known/1_1_$special_=:=/2'(A, B)\'test/1_1_$special_=:=/2'(A, B)<=>true.
|
||||
'known/1_1_$special_fail/0'\'test/1_1_$default'(fail)<=>true.
|
||||
'known/1_1_$default'(A)\'test/1_1_$default'(A)<=>true.
|
||||
'test/1_1_$special_\\==/2'(F, A)<=>nonvar(A), functor(A, C, B)|A=..[_|E], length(D, B), G=..[C|D], add_args_nmatch(D, E, H), I= (\+functor(F, C, B);functor(F, C, B), F=G, H), test(I).
|
||||
'test/1_1_$special_\\==/2'(A, B)<=>nonvar(A)|'test/1_1_$special_\\==/2'(B, A).
|
||||
'known/1_1_$special_=:=/2'(A, B)\'test/1_1_$special_=</2'(A, B)<=>true.
|
||||
'known/1_1_$special_=:=/2'(A, C)\'test/1_1_$special_=</2'(A, B)<=>number(B), number(C), C=<B|true.
|
||||
'known/1_1_$special_=:=/2'(A, C)\'test/1_1_$special_=</2'(B, A)<=>number(B), number(C), B=<C|true.
|
||||
'known/1_1_$special_=</2'(A, C)\'test/1_1_$special_=</2'(A, B)<=>number(B), number(C), C=<B|true.
|
||||
'known/1_1_$special_=</2'(B, A)\'test/1_1_$special_=</2'(C, A)<=>number(B), number(C), C=<B|true.
|
||||
'known/1_1_$special_=</2'(A, C)\'test/1_1_$special_=\\=/2'(A, B)<=>number(B), number(C), B>C|true.
|
||||
'known/1_1_$special_=</2'(B, A)\'test/1_1_$special_=\\=/2'(A, C)<=>number(B), number(C), C<B|true.
|
||||
'known/1_1_$special_>/2'(B, A)<=>'known/1_1_$special_</2'(A, B).
|
||||
'known/1_1_$special_>=/2'(B, A)<=>'known/1_1_$special_=</2'(A, B).
|
||||
'known/1_1_$special_</2'(A, B)<=>'known/1_1_$special_=</2'(A, B), 'known/1_1_$special_=\\=/2'(A, B).
|
||||
'known/1_1_$special_is/2'(A, B)<=>'known/1_1_$special_=:=/2'(A, B).
|
||||
'test/1_1_$special_>/2'(B, A)<=>'test/1_1_$special_</2'(A, B).
|
||||
'test/1_1_$special_>=/2'(B, A)<=>'test/1_1_$special_=</2'(A, B).
|
||||
'test/1_1_$special_</2'(A, B)<=>'test/1_1_$special_,/2'(A=<B, A=\=B).
|
||||
'test/1_1_$special_is/2'(A, B)<=>'test/1_1_$special_=:=/2'(A, B).
|
||||
'known/1_1_$special_==/2'(A, B)==>number(A)|'known/1_1_$special_=:=/2'(A, B).
|
||||
'known/1_1_$special_==/2'(B, A)==>number(A)|'known/1_1_$special_=:=/2'(B, A).
|
||||
'known/1_1_$special_\\==/2'(A, B)==>number(A)|'known/1_1_$special_=\\=/2'(A, B).
|
||||
'known/1_1_$special_\\==/2'(B, A)==>number(A)|'known/1_1_$special_=\\=/2'(B, A).
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_;/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_nonvar/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_var/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_atom/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_atomic/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_compound/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_ground/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_integer/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_float/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_number/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_=\\=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_\\+/1'(_)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_functor/3'(_, _, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_\\=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_,/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_\\==/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_==/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_is/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_</2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_>=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_>/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_=</2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_=:=/2'(_, _)<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_fail/0'<=>true.
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$default'(_)<=>true.
|
||||
'known/1_1_$special_,/2'(A, B)<=>known(A), known(B).
|
||||
'known/1_1_$special_=:=/2'(A, A)<=>true.
|
||||
'known/1_1_$special_==/2'(A, A)<=>true.
|
||||
'known/1_1_$special_=</2'(A, A)<=>true.
|
||||
'known/1_1_$special_=/2'(A, A)<=>true.
|
||||
'known/1_1_$special_=/2'(A, B)<=>var(A)|A=B.
|
||||
'known/1_1_$special_=/2'(B, A)<=>var(A)|B=A.
|
||||
'known/1_1_$special_\\=/2'(A, B)<=>ground(A), ground(B), A=B|'known/1_1_$special_fail/0'.
|
||||
variables(E), 'known/1_1_$special_functor/3'(A, B, C)<=>var(A), ground(B), ground(C)|functor(A, B, C), A=..[_|D], append(D, E, F), variables(F).
|
||||
'known/1_1_$special_functor/3'(A, B, C)<=>nonvar(A), \+functor(A, B, C)|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\+/1'(functor(A, B, C))<=>nonvar(A), functor(A, B, C)|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_functor/3'(A, B, C), 'known/1_1_$special_functor/3'(A, D, E)<=>nonvar(B), nonvar(C), nonvar(D), nonvar(E)|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\=/2'(A, A)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=/2'(A, B)<=>nonvar(A), nonvar(B), functor(A, C, D)|functor(B, C, D), A=B->true;'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\=/2'(A, B)<=>var(A), nonvar(B), functor(B, D, C), C>0|length(E, C), B=..[D|F], G=..[D|E], add_args_nunif(F, E, H), I= (\+functor(A, D, C);A=G, H), known(I).
|
||||
'known/1_1_$special_\\=/2'(A, B)<=>nonvar(A), nonvar(B), functor(A, C, D)|functor(B, C, D)->A=..[C|E], B=..[C|F], add_args_nunif(E, F, G), known(G);true.
|
||||
'known/1_1_$special_\\=/2'(B, A)==>'known/1_1_$special_\\=/2'(A, B).
|
||||
'known/1_1_$special_=</2'(A, B)<=>number(A), number(B), A>B|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_=</2'(A, C)<=>number(B), number(C), B=<C|true.
|
||||
'known/1_1_$special_=</2'(C, A)\'known/1_1_$special_=</2'(B, A)<=>number(B), number(C), B=<C|true.
|
||||
'known/1_1_$special_=</2'(B, A), 'known/1_1_$special_=</2'(A, B)<=>'known/1_1_$special_=:=/2'(B, A).
|
||||
'known/1_1_$special_=</2'(B, A), 'known/1_1_$special_=</2'(A, C)==>'known/1_1_$special_=</2'(B, C).
|
||||
'known/1_1_$special_=</2'(A, B), 'known/1_1_$special_=\\=/2'(A, B), 'known/1_1_$special_=</2'(B, C), 'known/1_1_$special_=\\=/2'(B, C)==>'known/1_1_$special_=\\=/2'(A, C).
|
||||
'known/1_1_$special_=:=/2'(A, B)<=>number(A), number(B), A=\=B|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=\\=/2'(A, B)<=>number(A), number(B), A=:=B|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=\\=/2'(A, A)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=:=/2'(A, B), 'known/1_1_$special_=\\=/2'(A, B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=:=/2'(B, A), 'known/1_1_$special_=:=/2'(A, C)==>B\==C|'known/1_1_$special_=:=/2'(B, C).
|
||||
'known/1_1_$special_=:=/2'(B, A)==>'known/1_1_$special_=:=/2'(A, B).
|
||||
'known/1_1_$special_=\\=/2'(B, A)==>'known/1_1_$special_=\\=/2'(A, B).
|
||||
'known/1_1_$special_number/1'(A)<=>nonvar(A), \+number(A)|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_float/1'(A)<=>nonvar(A), \+float(A)|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_integer/1'(A)<=>nonvar(A), \+integer(A)|'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_integer/1'(A)==>'known/1_1_$special_number/1'(A).
|
||||
'known/1_1_$special_float/1'(A)==>'known/1_1_$special_number/1'(A).
|
||||
'known/1_1_$special_;/2'(A, B), 'known/1_1_$special_\\+/1'((A;B))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_nonvar/1'(A), 'known/1_1_$special_\\+/1'(nonvar(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_var/1'(A), 'known/1_1_$special_\\+/1'(var(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_atom/1'(A), 'known/1_1_$special_\\+/1'(atom(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_atomic/1'(A), 'known/1_1_$special_\\+/1'(atomic(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_compound/1'(A), 'known/1_1_$special_\\+/1'(compound(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_ground/1'(A), 'known/1_1_$special_\\+/1'(ground(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_integer/1'(A), 'known/1_1_$special_\\+/1'(integer(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_float/1'(A), 'known/1_1_$special_\\+/1'(float(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_number/1'(A), 'known/1_1_$special_\\+/1'(number(A))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=\\=/2'(A, B), 'known/1_1_$special_\\+/1'(A=\=B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\+/1'(A), 'known/1_1_$special_\\+/1'(\+A)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_functor/3'(A, B, C), 'known/1_1_$special_\\+/1'(functor(A, B, C))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\=/2'(A, B), 'known/1_1_$special_\\+/1'(A\=B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=/2'(A, B), 'known/1_1_$special_\\+/1'(A=B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_,/2'(A, B), 'known/1_1_$special_\\+/1'((A, B))<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\==/2'(A, B), 'known/1_1_$special_\\+/1'(A\==B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_==/2'(A, B), 'known/1_1_$special_\\+/1'(A==B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_is/2'(A, B), 'known/1_1_$special_\\+/1'(A is B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_</2'(A, B), 'known/1_1_$special_\\+/1'(A<B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_>=/2'(A, B), 'known/1_1_$special_\\+/1'(A>=B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_>/2'(A, B), 'known/1_1_$special_\\+/1'(A>B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=</2'(A, B), 'known/1_1_$special_\\+/1'(A=<B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_=:=/2'(A, B), 'known/1_1_$special_\\+/1'(A=:=B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_fail/0', 'known/1_1_$special_\\+/1'(fail)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$default'(A), 'known/1_1_$special_\\+/1'(A)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\==/2'(A, B), 'known/1_1_$special_==/2'(A, B)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_==/2'(B, A), 'known/1_1_$special_==/2'(A, C)==>'known/1_1_$special_==/2'(B, C).
|
||||
'known/1_1_$special_==/2'(B, A), 'known/1_1_$special_\\==/2'(A, C)==>'known/1_1_$special_\\==/2'(B, C).
|
||||
'known/1_1_$special_==/2'(B, A)==>'known/1_1_$special_==/2'(A, B).
|
||||
'known/1_1_$special_\\==/2'(B, A)==>'known/1_1_$special_\\==/2'(A, B).
|
||||
'known/1_1_$special_\\==/2'(A, A)==>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_\\==/2'(A, B)<=>nonvar(A), nonvar(B), functor(A, C, D)|functor(B, C, D)->A=..[C|E], B=..[C|F], add_args_nmatch(E, F, G), known(G);true.
|
||||
'known/1_1_$special_==/2'(A, B)==>'known/1_1_$special_=/2'(A, B).
|
||||
'known/1_1_$special_ground/1'(A)==>'known/1_1_$special_nonvar/1'(A).
|
||||
'known/1_1_$special_compound/1'(A)==>'known/1_1_$special_nonvar/1'(A).
|
||||
'known/1_1_$special_atomic/1'(A)==>'known/1_1_$special_nonvar/1'(A).
|
||||
'known/1_1_$special_number/1'(A)==>'known/1_1_$special_nonvar/1'(A).
|
||||
'known/1_1_$special_atom/1'(A)==>'known/1_1_$special_nonvar/1'(A).
|
||||
'known/1_1_$special_var/1'(A), 'known/1_1_$special_nonvar/1'(A)<=>'known/1_1_$special_fail/0'.
|
||||
'known/1_1_$special_;/2'(A, B)\'known/1_1_$special_;/2'(\+ (A;B), C)<=>known(C).
|
||||
'known/1_1_$special_nonvar/1'(A)\'known/1_1_$special_;/2'(\+nonvar(A), B)<=>known(B).
|
||||
'known/1_1_$special_var/1'(A)\'known/1_1_$special_;/2'(\+var(A), B)<=>known(B).
|
||||
'known/1_1_$special_atom/1'(A)\'known/1_1_$special_;/2'(\+atom(A), B)<=>known(B).
|
||||
'known/1_1_$special_atomic/1'(A)\'known/1_1_$special_;/2'(\+atomic(A), B)<=>known(B).
|
||||
'known/1_1_$special_compound/1'(A)\'known/1_1_$special_;/2'(\+compound(A), B)<=>known(B).
|
||||
'known/1_1_$special_ground/1'(A)\'known/1_1_$special_;/2'(\+ground(A), B)<=>known(B).
|
||||
'known/1_1_$special_integer/1'(A)\'known/1_1_$special_;/2'(\+integer(A), B)<=>known(B).
|
||||
'known/1_1_$special_float/1'(A)\'known/1_1_$special_;/2'(\+float(A), B)<=>known(B).
|
||||
'known/1_1_$special_number/1'(A)\'known/1_1_$special_;/2'(\+number(A), B)<=>known(B).
|
||||
'known/1_1_$special_=\\=/2'(A, B)\'known/1_1_$special_;/2'(\+A=\=B, C)<=>known(C).
|
||||
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'(\+ \+A, B)<=>known(B).
|
||||
'known/1_1_$special_functor/3'(A, B, C)\'known/1_1_$special_;/2'(\+functor(A, B, C), D)<=>known(D).
|
||||
'known/1_1_$special_\\=/2'(A, B)\'known/1_1_$special_;/2'(\+A\=B, C)<=>known(C).
|
||||
'known/1_1_$special_=/2'(A, B)\'known/1_1_$special_;/2'(\+A=B, C)<=>known(C).
|
||||
'known/1_1_$special_,/2'(A, B)\'known/1_1_$special_;/2'(\+ (A, B), C)<=>known(C).
|
||||
'known/1_1_$special_\\==/2'(A, B)\'known/1_1_$special_;/2'(\+A\==B, C)<=>known(C).
|
||||
'known/1_1_$special_==/2'(A, B)\'known/1_1_$special_;/2'(\+A==B, C)<=>known(C).
|
||||
'known/1_1_$special_is/2'(A, B)\'known/1_1_$special_;/2'(\+A is B, C)<=>known(C).
|
||||
'known/1_1_$special_</2'(A, B)\'known/1_1_$special_;/2'(\+A<B, C)<=>known(C).
|
||||
'known/1_1_$special_>=/2'(A, B)\'known/1_1_$special_;/2'(\+A>=B, C)<=>known(C).
|
||||
'known/1_1_$special_>/2'(A, B)\'known/1_1_$special_;/2'(\+A>B, C)<=>known(C).
|
||||
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_;/2'(\+A=<B, C)<=>known(C).
|
||||
'known/1_1_$special_=:=/2'(A, B)\'known/1_1_$special_;/2'(\+A=:=B, C)<=>known(C).
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_;/2'(\+fail, A)<=>known(A).
|
||||
'known/1_1_$default'(A)\'known/1_1_$special_;/2'(\+A, B)<=>known(B).
|
||||
'known/1_1_$special_;/2'(A, B)\'known/1_1_$special_;/2'((\+ (A;B), _), C)<=>known(C).
|
||||
'known/1_1_$special_nonvar/1'(A)\'known/1_1_$special_;/2'((\+nonvar(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_var/1'(A)\'known/1_1_$special_;/2'((\+var(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_atom/1'(A)\'known/1_1_$special_;/2'((\+atom(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_atomic/1'(A)\'known/1_1_$special_;/2'((\+atomic(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_compound/1'(A)\'known/1_1_$special_;/2'((\+compound(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_ground/1'(A)\'known/1_1_$special_;/2'((\+ground(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_integer/1'(A)\'known/1_1_$special_;/2'((\+integer(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_float/1'(A)\'known/1_1_$special_;/2'((\+float(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_number/1'(A)\'known/1_1_$special_;/2'((\+number(A), _), B)<=>known(B).
|
||||
'known/1_1_$special_=\\=/2'(A, B)\'known/1_1_$special_;/2'((\+A=\=B, _), C)<=>known(C).
|
||||
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'((\+ \+A, _), B)<=>known(B).
|
||||
'known/1_1_$special_functor/3'(A, B, C)\'known/1_1_$special_;/2'((\+functor(A, B, C), _), D)<=>known(D).
|
||||
'known/1_1_$special_\\=/2'(A, B)\'known/1_1_$special_;/2'((\+A\=B, _), C)<=>known(C).
|
||||
'known/1_1_$special_=/2'(A, B)\'known/1_1_$special_;/2'((\+A=B, _), C)<=>known(C).
|
||||
'known/1_1_$special_,/2'(A, B)\'known/1_1_$special_;/2'((\+ (A, B), _), C)<=>known(C).
|
||||
'known/1_1_$special_\\==/2'(A, B)\'known/1_1_$special_;/2'((\+A\==B, _), C)<=>known(C).
|
||||
'known/1_1_$special_==/2'(A, B)\'known/1_1_$special_;/2'((\+A==B, _), C)<=>known(C).
|
||||
'known/1_1_$special_is/2'(A, B)\'known/1_1_$special_;/2'((\+A is B, _), C)<=>known(C).
|
||||
'known/1_1_$special_</2'(A, B)\'known/1_1_$special_;/2'((\+A<B, _), C)<=>known(C).
|
||||
'known/1_1_$special_>=/2'(A, B)\'known/1_1_$special_;/2'((\+A>=B, _), C)<=>known(C).
|
||||
'known/1_1_$special_>/2'(A, B)\'known/1_1_$special_;/2'((\+A>B, _), C)<=>known(C).
|
||||
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_;/2'((\+A=<B, _), C)<=>known(C).
|
||||
'known/1_1_$special_=:=/2'(A, B)\'known/1_1_$special_;/2'((\+A=:=B, _), C)<=>known(C).
|
||||
'known/1_1_$special_fail/0'\'known/1_1_$special_;/2'((\+fail, _), A)<=>known(A).
|
||||
'known/1_1_$default'(A)\'known/1_1_$special_;/2'((\+A, _), B)<=>known(B).
|
||||
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'(A, B)<=>known(B).
|
||||
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'((A, _), B)<=>known(B).
|
||||
'known/1_1_$special_;/2'(fail, A)<=>known(A).
|
||||
'known/1_1_$special_;/2'(A, fail)<=>known(A).
|
||||
'known/1_1_$special_;/2'(true, _)<=>true.
|
||||
'known/1_1_$special_;/2'(_, true)<=>true.
|
||||
'known/1_1_$special_functor/3'(A, _, _)\'known/1_1_$special_;/2'(\+functor(A, _, _), _)<=>true.
|
||||
'known/1_1_$special_;/2'(\+functor(A, B, C), D)<=>nonvar(A), functor(A, B, C)|known(D).
|
||||
'known/1_1_$special_;/2'(\+functor(A, B, C), _)<=>nonvar(A), \+functor(A, B, C)|true.
|
||||
'test/1_1_$special_;/2'(fail, A)<=>test(A).
|
||||
'test/1_1_$special_;/2'(A, fail)<=>test(A).
|
||||
% 'test/1_1_$special_=/2'(A, B)<=>A=B|A=B.
|
||||
'test/1_1_$special_=/2'(A, B)<=>ground(A), ground(B)|A=B.
|
||||
% 'test/1_1_$special_=/2'(A, B)<=>nonvar(A), var(B)|'test/1_1_$special_=/2'(B, A).
|
||||
% variables(F)\'test/1_1_$special_=/2'(A, B)<=>var(A), nonvar(B), functor(B, D, C), C>0, B=..[D|E], \+all_unique_vars(E, F)|G= (functor(A, D, C), A=B), test(G).
|
||||
|
||||
% variables(F) \ 'test/1_1_$special_=/2'(A, B) <=>
|
||||
% var(A),
|
||||
% nonvar(B),
|
||||
% \+ memberchk_eq(A,F),
|
||||
% functor(B, C, D),
|
||||
% B=..[C|_]
|
||||
% |
|
||||
% E=functor(A, C, D),
|
||||
% test(E).
|
||||
% 'test/1_1_$special_=/2'(A, B)<=>nonvar(A), nonvar(B), functor(B, C, D), B=..[C|F]|functor(A, C, D), A=..[C|E], add_args_unif(E, F, G), test(G).
|
||||
variables(D)\'test/1_1_$special_functor/3'(A, B, C)<=>var(A), ground(B), ground(C), \+memberchk_eq(A, D)|functor(A, B, C).
|
||||
'test/1_1_$special_true/0'<=>true.
|
||||
'test/1_1_$special_==/2'(A, B)<=>A==B|true.
|
||||
'test/1_1_$special_=:=/2'(A, B)<=>A==B|true.
|
||||
'test/1_1_$special_=</2'(A, B)<=>A==B|true.
|
||||
'test/1_1_$special_=</2'(A, B)<=>ground(A), ground(B), A=<B|true.
|
||||
'test/1_1_$special_=</2'(A, B)<=>ground(A), ground(B), A>B|fail.
|
||||
'test/1_1_$special_=:=/2'(A, B)<=>ground(A), ground(B), A=:=B|true.
|
||||
'test/1_1_$special_=:=/2'(A, B)<=>ground(A), ground(B), A=\=B|fail.
|
||||
'test/1_1_$special_=\\=/2'(A, B)<=>ground(A), ground(B), A=\=B|true.
|
||||
'test/1_1_$special_=\\=/2'(A, B)<=>ground(A), ground(B), A=:=B|fail.
|
||||
'test/1_1_$special_functor/3'(A, B, C)<=>nonvar(A), functor(A, B, C)|true.
|
||||
'test/1_1_$special_functor/3'(A, _, _)<=>nonvar(A)|fail.
|
||||
'test/1_1_$special_ground/1'(A)<=>ground(A)|true.
|
||||
'test/1_1_$special_number/1'(A)<=>number(A)|true.
|
||||
'test/1_1_$special_float/1'(A)<=>float(A)|true.
|
||||
'test/1_1_$special_integer/1'(A)<=>integer(A)|true.
|
||||
'test/1_1_$special_number/1'(A)<=>nonvar(A)|fail.
|
||||
'test/1_1_$special_float/1'(A)<=>nonvar(A)|fail.
|
||||
'test/1_1_$special_integer/1'(A)<=>nonvar(A)|fail.
|
||||
'test/1_1_$special_\\+/1'(functor(A, B, C))<=>nonvar(A), functor(A, B, C)|fail.
|
||||
'test/1_1_$special_\\+/1'(functor(A, _, _))<=>nonvar(A)|true.
|
||||
'test/1_1_$special_\\+/1'(ground(A))<=>ground(A)|fail.
|
||||
'test/1_1_$special_\\+/1'(number(A))<=>number(A)|fail.
|
||||
'test/1_1_$special_\\+/1'(float(A))<=>float(A)|fail.
|
||||
'test/1_1_$special_\\+/1'(integer(A))<=>integer(A)|fail.
|
||||
'test/1_1_$special_\\+/1'(number(A))<=>nonvar(A)|true.
|
||||
'test/1_1_$special_\\+/1'(float(A))<=>nonvar(A)|true.
|
||||
'test/1_1_$special_\\+/1'(integer(A))<=>nonvar(A)|true.
|
||||
'test/1_1_$special_,/2'(A, B)<=>test(A), known(A), test(B).
|
||||
'test/1_1_$special_;/2'(A, B)<=>true|negate_b(A, D), negate_b(B, C), (known(C), test(A);known(D), test(B)).
|
||||
'test/1_1_$special_,/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, (B, C)), !, negate_b(A, D), known(D), \+try(E, (B, C)).
|
||||
'test/1_1_$special_\\+/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, \+B), !, negate_b(A, C), known(C), \+try(D, \+B).
|
||||
'test/1_1_$special_integer/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, integer(B)), !, negate_b(A, C), known(C), \+try(D, integer(B)).
|
||||
'test/1_1_$special_float/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, float(B)), !, negate_b(A, C), known(C), \+try(D, float(B)).
|
||||
'test/1_1_$special_number/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, number(B)), !, negate_b(A, C), known(C), \+try(D, number(B)).
|
||||
'test/1_1_$special_ground/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, ground(B)), !, negate_b(A, C), known(C), \+try(D, ground(B)).
|
||||
'test/1_1_$special_=:=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=:=C), !, negate_b(A, D), known(D), \+try(E, B=:=C).
|
||||
'test/1_1_$special_==/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B==C), !, negate_b(A, D), known(D), \+try(E, B==C).
|
||||
'test/1_1_$special_true/0', 'known/1_1_$special_;/2'(A, C)<=>true|\+try(A, true), !, negate_b(A, B), known(B), \+try(C, true).
|
||||
'test/1_1_$special_functor/3'(B, C, D), 'known/1_1_$special_;/2'(A, F)<=>true|\+try(A, functor(B, C, D)), !, negate_b(A, E), known(E), \+try(F, functor(B, C, D)).
|
||||
'test/1_1_$special_=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=C), !, negate_b(A, D), known(D), \+try(E, B=C).
|
||||
'test/1_1_$special_;/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, (B;C)), !, negate_b(A, D), known(D), \+try(E, (B;C)).
|
||||
'test/1_1_$special_is/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B is C), !, negate_b(A, D), known(D), \+try(E, B is C).
|
||||
'test/1_1_$special_</2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B<C), !, negate_b(A, D), known(D), \+try(E, B<C).
|
||||
'test/1_1_$special_>=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B>=C), !, negate_b(A, D), known(D), \+try(E, B>=C).
|
||||
'test/1_1_$special_>/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B>C), !, negate_b(A, D), known(D), \+try(E, B>C).
|
||||
'test/1_1_$special_=\\=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=\=C), !, negate_b(A, D), known(D), \+try(E, B=\=C).
|
||||
'test/1_1_$special_=</2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=<C), !, negate_b(A, D), known(D), \+try(E, B=<C).
|
||||
'test/1_1_$special_\\==/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B\==C), !, negate_b(A, D), known(D), \+try(E, B\==C).
|
||||
'test/1_1_$default'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, B), !, negate_b(A, C), known(C), \+try(D, B).
|
||||
'test/1_1_$special_,/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_\\+/1'(_)<=>fail.
|
||||
'test/1_1_$special_integer/1'(_)<=>fail.
|
||||
'test/1_1_$special_float/1'(_)<=>fail.
|
||||
'test/1_1_$special_number/1'(_)<=>fail.
|
||||
'test/1_1_$special_ground/1'(_)<=>fail.
|
||||
'test/1_1_$special_=:=/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_==/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_true/0'<=>fail.
|
||||
'test/1_1_$special_functor/3'(_, _, _)<=>fail.
|
||||
'test/1_1_$special_=/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_;/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_is/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_</2'(_, _)<=>fail.
|
||||
'test/1_1_$special_>=/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_>/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_=\\=/2'(_, _)<=>fail.
|
||||
'test/1_1_$special_=</2'(_, _)<=>fail.
|
||||
'test/1_1_$special_\\==/2'(_, _)<=>fail.
|
||||
'test/1_1_$default'(_)<=>fail.
|
||||
cleanup\'known/1_1_$special_;/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_nonvar/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_var/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_atom/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_atomic/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_compound/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_ground/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_integer/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_float/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_number/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_=\\=/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_\\+/1'(_)<=>true.
|
||||
cleanup\'known/1_1_$special_functor/3'(_, _, _)<=>true.
|
||||
cleanup\'known/1_1_$special_\\=/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_=/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_,/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_\\==/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_==/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_is/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_</2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_>=/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_>/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_=</2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_=:=/2'(_, _)<=>true.
|
||||
cleanup\'known/1_1_$special_fail/0'<=>true.
|
||||
cleanup\'known/1_1_$default'(_)<=>true.
|
||||
cleanup\variables(_)<=>true.
|
||||
cleanup<=>true.
|
|
@ -0,0 +1,238 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# install - install a program, script, or datafile
|
||||
# This comes from X11R5.
|
||||
#
|
||||
# Calling this script install-sh is preferred over install.sh, to prevent
|
||||
# `make' implicit rules from creating a file called install from it
|
||||
# when there is no Makefile.
|
||||
#
|
||||
# This script is compatible with the BSD install script, but was written
|
||||
# from scratch.
|
||||
#
|
||||
|
||||
|
||||
# set DOITPROG to echo to test this script
|
||||
|
||||
# Don't use :- since 4.3BSD and earlier shells don't like it.
|
||||
doit="${DOITPROG-}"
|
||||
|
||||
|
||||
# put in absolute paths if you don't have them in your path; or use env. vars.
|
||||
|
||||
mvprog="${MVPROG-mv}"
|
||||
cpprog="${CPPROG-cp}"
|
||||
chmodprog="${CHMODPROG-chmod}"
|
||||
chownprog="${CHOWNPROG-chown}"
|
||||
chgrpprog="${CHGRPPROG-chgrp}"
|
||||
stripprog="${STRIPPROG-strip}"
|
||||
rmprog="${RMPROG-rm}"
|
||||
mkdirprog="${MKDIRPROG-mkdir}"
|
||||
|
||||
tranformbasename=""
|
||||
transform_arg=""
|
||||
instcmd="$mvprog"
|
||||
chmodcmd="$chmodprog 0755"
|
||||
chowncmd=""
|
||||
chgrpcmd=""
|
||||
stripcmd=""
|
||||
rmcmd="$rmprog -f"
|
||||
mvcmd="$mvprog"
|
||||
src=""
|
||||
dst=""
|
||||
dir_arg=""
|
||||
|
||||
while [ x"$1" != x ]; do
|
||||
case $1 in
|
||||
-c) instcmd="$cpprog"
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-d) dir_arg=true
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-m) chmodcmd="$chmodprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-o) chowncmd="$chownprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-g) chgrpcmd="$chgrpprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-s) stripcmd="$stripprog"
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
|
||||
shift
|
||||
continue;;
|
||||
|
||||
*) if [ x"$src" = x ]
|
||||
then
|
||||
src=$1
|
||||
else
|
||||
# this colon is to work around a 386BSD /bin/sh bug
|
||||
:
|
||||
dst=$1
|
||||
fi
|
||||
shift
|
||||
continue;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ x"$src" = x ]
|
||||
then
|
||||
echo "install: no input file specified"
|
||||
exit 1
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
if [ x"$dir_arg" != x ]; then
|
||||
dst=$src
|
||||
src=""
|
||||
|
||||
if [ -d $dst ]; then
|
||||
instcmd=:
|
||||
else
|
||||
instcmd=mkdir
|
||||
fi
|
||||
else
|
||||
|
||||
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
|
||||
# might cause directories to be created, which would be especially bad
|
||||
# if $src (and thus $dsttmp) contains '*'.
|
||||
|
||||
if [ -f $src -o -d $src ]
|
||||
then
|
||||
true
|
||||
else
|
||||
echo "install: $src does not exist"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ x"$dst" = x ]
|
||||
then
|
||||
echo "install: no destination specified"
|
||||
exit 1
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
# If destination is a directory, append the input filename; if your system
|
||||
# does not like double slashes in filenames, you may need to add some logic
|
||||
|
||||
if [ -d $dst ]
|
||||
then
|
||||
dst="$dst"/`basename $src`
|
||||
else
|
||||
true
|
||||
fi
|
||||
fi
|
||||
|
||||
## this sed command emulates the dirname command
|
||||
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
|
||||
|
||||
# Make sure that the destination directory exists.
|
||||
# this part is taken from Noah Friedman's mkinstalldirs script
|
||||
|
||||
# Skip lots of stat calls in the usual case.
|
||||
if [ ! -d "$dstdir" ]; then
|
||||
defaultIFS='
|
||||
'
|
||||
IFS="${IFS-${defaultIFS}}"
|
||||
|
||||
oIFS="${IFS}"
|
||||
# Some sh's can't handle IFS=/ for some reason.
|
||||
IFS='%'
|
||||
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
|
||||
IFS="${oIFS}"
|
||||
|
||||
pathcomp=''
|
||||
|
||||
while [ $# -ne 0 ] ; do
|
||||
pathcomp="${pathcomp}${1}"
|
||||
shift
|
||||
|
||||
if [ ! -d "${pathcomp}" ] ;
|
||||
then
|
||||
$mkdirprog "${pathcomp}"
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
pathcomp="${pathcomp}/"
|
||||
done
|
||||
fi
|
||||
|
||||
if [ x"$dir_arg" != x ]
|
||||
then
|
||||
$doit $instcmd $dst &&
|
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
|
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
|
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
|
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
|
||||
else
|
||||
|
||||
# If we're going to rename the final executable, determine the name now.
|
||||
|
||||
if [ x"$transformarg" = x ]
|
||||
then
|
||||
dstfile=`basename $dst`
|
||||
else
|
||||
dstfile=`basename $dst $transformbasename |
|
||||
sed $transformarg`$transformbasename
|
||||
fi
|
||||
|
||||
# don't allow the sed command to completely eliminate the filename
|
||||
|
||||
if [ x"$dstfile" = x ]
|
||||
then
|
||||
dstfile=`basename $dst`
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
# Make a temp file name in the proper directory.
|
||||
|
||||
dsttmp=$dstdir/#inst.$$#
|
||||
|
||||
# Move or copy the file name to the temp name
|
||||
|
||||
$doit $instcmd $src $dsttmp &&
|
||||
|
||||
trap "rm -f ${dsttmp}" 0 &&
|
||||
|
||||
# and set any options; do chmod last to preserve setuid bits
|
||||
|
||||
# If any of these fail, we abort the whole thing. If we want to
|
||||
# ignore errors from any of these, just make sure not to ignore
|
||||
# errors from the above "$doit $instcmd $src $dsttmp" command.
|
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
|
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
|
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
|
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
|
||||
|
||||
# Now rename the file to the real destination.
|
||||
|
||||
$doit $rmcmd -f $dstdir/$dstfile &&
|
||||
$doit $mvcmd $dsttmp $dstdir/$dstfile
|
||||
|
||||
fi &&
|
||||
|
||||
|
||||
exit 0
|
|
@ -0,0 +1,105 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CHR (Constraint Handling Rules)
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2003-2004, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(listmap,
|
||||
[
|
||||
listmap_empty/1,
|
||||
listmap_lookup/3,
|
||||
listmap_insert/4,
|
||||
listmap_remove/3,
|
||||
listmap_merge/5
|
||||
]).
|
||||
|
||||
listmap_empty([]).
|
||||
|
||||
listmap_lookup([K-V|R],Key,Q) :-
|
||||
( Key == K ->
|
||||
Q = V
|
||||
;
|
||||
Key @> K,
|
||||
listmap_lookup(R,Key,Q)
|
||||
).
|
||||
|
||||
listmap_insert([],Key,Value,[Key-Value]).
|
||||
listmap_insert([P|R],Key,Value,ML) :-
|
||||
P = K-_,
|
||||
compare(C,Key,K),
|
||||
( C == (=) ->
|
||||
ML = [K-Value|R]
|
||||
; C == (<) ->
|
||||
ML = [Key-Value,P|R]
|
||||
;
|
||||
ML = [P|Tail],
|
||||
listmap_insert(R,Key,Value,Tail)
|
||||
).
|
||||
|
||||
listmap_merge(ML1,ML2,F,G,ML) :-
|
||||
( ML1 == [] ->
|
||||
ML = ML2
|
||||
; ML2 == [] ->
|
||||
ML = ML1
|
||||
;
|
||||
ML1 = [P1|R1], P1 = K1-V1,
|
||||
ML2 = [P2|R2], P2 = K2-V2,
|
||||
compare(C,K1,K2),
|
||||
( C == (=) ->
|
||||
Call =.. [F,V1,V2,NV],
|
||||
call(Call),
|
||||
ML = [K1-NV|Tail],
|
||||
listmap_merge(R1,R2,F,G,Tail)
|
||||
; C == (<) ->
|
||||
Call =.. [G,V1,NV],
|
||||
call(Call),
|
||||
ML = [K1-NV|Tail],
|
||||
listmap_merge(R1,ML2,F,G,Tail)
|
||||
;
|
||||
Call =.. [G,V2,NV],
|
||||
call(Call),
|
||||
ML = [K2-NV|Tail],
|
||||
listmap_merge(ML1,R2,F,G,Tail)
|
||||
)
|
||||
).
|
||||
|
||||
|
||||
listmap_remove([],_,[]).
|
||||
listmap_remove([P|R],Key,NLM) :-
|
||||
P = K-_,
|
||||
compare(C,Key,K),
|
||||
( C == (=) ->
|
||||
NLM = R
|
||||
; C == (<) ->
|
||||
NLM = [P|R]
|
||||
;
|
||||
NLM = [P|Tail],
|
||||
listmap_remove(R,Key,Tail)
|
||||
).
|
||||
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%% _ _ _ _
|
||||
%% _ __ __ _(_)_ __| (_)___| |_
|
||||
%% | '_ \ / _` | | '__| | / __| __|
|
||||
%% | |_) | (_| | | | | | \__ \ |_
|
||||
%% | .__/ \__,_|_|_| |_|_|___/\__|
|
||||
%% |_|
|
||||
%%
|
||||
%% * author: Tom Schrijvers
|
||||
|
||||
:- module(pairlist,[
|
||||
fst_of_pairs/2,
|
||||
lookup/3,
|
||||
lookup_any/3,
|
||||
lookup_eq/3,
|
||||
lookup_any_eq/3,
|
||||
pairup/3,
|
||||
snd_of_pairs/2,
|
||||
translate/3,
|
||||
pairlist_delete_eq/3
|
||||
]).
|
||||
|
||||
fst_of_pairs([],[]).
|
||||
fst_of_pairs([X-_|XYs],[X|Xs]) :-
|
||||
fst_of_pairs(XYs,Xs).
|
||||
|
||||
snd_of_pairs([],[]).
|
||||
snd_of_pairs([_-Y|XYs],[Y|Ys]) :-
|
||||
snd_of_pairs(XYs,Ys).
|
||||
|
||||
pairup([],[],[]).
|
||||
pairup([X|Xs],[Y|Ys],[X-Y|XYs]) :-
|
||||
pairup(Xs,Ys,XYs).
|
||||
|
||||
lookup([K - V | KVs],Key,Value) :-
|
||||
( K = Key ->
|
||||
V = Value
|
||||
;
|
||||
lookup(KVs,Key,Value)
|
||||
).
|
||||
|
||||
lookup_any([K - V | KVs],Key,Value) :-
|
||||
(
|
||||
K = Key,
|
||||
V = Value
|
||||
;
|
||||
lookup_any(KVs,Key,Value)
|
||||
).
|
||||
|
||||
lookup_eq([K - V | KVs],Key,Value) :-
|
||||
( K == Key ->
|
||||
V = Value
|
||||
;
|
||||
lookup_eq(KVs,Key,Value)
|
||||
).
|
||||
|
||||
lookup_any_eq([K - V | KVs],Key,Value) :-
|
||||
(
|
||||
K == Key,
|
||||
V = Value
|
||||
;
|
||||
lookup_any_eq(KVs,Key,Value)
|
||||
).
|
||||
|
||||
translate([],_,[]).
|
||||
translate([X|Xs],Dict,[Y|Ys]) :-
|
||||
lookup_eq(Dict,X,Y),
|
||||
translate(Xs,Dict,Ys).
|
||||
|
||||
pairlist_delete_eq([], _, []).
|
||||
pairlist_delete_eq([K - V| KVs], Key, PL) :-
|
||||
( Key == K ->
|
||||
PL = KVs
|
||||
;
|
||||
PL = [ K - V | T ],
|
||||
pairlist_delete_eq(KVs, Key, T)
|
||||
).
|
||||
|
|
@ -1 +0,0 @@
|
|||
Subproject commit a66738b770cc3c3270e19de981a596e74a871220
|
|
@ -1 +0,0 @@
|
|||
Subproject commit 39a11c2d87fbd072ece4af19e5265997e06c56e1
|
|
@ -0,0 +1,63 @@
|
|||
[Sep 16 2009]
|
||||
|
||||
* ENHANCED: CLP(Q/R): Correct residual goals for suspendend non-linear
|
||||
constraints.
|
||||
|
||||
[Aug 9 2009]
|
||||
|
||||
* ENHANCED: CLP(Q/R): Working residual goals with copy_term/3. Please review.
|
||||
|
||||
[Mar 30 2009]
|
||||
|
||||
* FIXED: alarm handling on Win64 (Kerri Haris)
|
||||
|
||||
[Nov 21 2008]
|
||||
|
||||
* FIXED: wakeup issue in S_LIST and H_LIST_FF instructions. Matt Lilley.
|
||||
|
||||
[Mar 30 2009]
|
||||
|
||||
* FIXED: alarm handling on Win64 (Kerri Haris)
|
||||
|
||||
[Nov 21 2008]
|
||||
|
||||
* FIXED: wakeup issue in S_LIST and H_LIST_FF instructions. Matt Lilley.
|
||||
|
||||
[Nov 21 2008]
|
||||
|
||||
* FIXED: wakeup issue in S_LIST and H_LIST_FF instructions. Matt Lilley.
|
||||
|
||||
Sep 10, 2006
|
||||
|
||||
* JW: Removed dependency on C/3.
|
||||
|
||||
Mar 31, 2006
|
||||
|
||||
* JW: Removed SICStus ugraphs.pl and replaced by new SWI-Prolog library
|
||||
|
||||
Oct 17, 2005
|
||||
|
||||
* LDK: Changed floor and ceiling operators to cope with
|
||||
inaccurate floats.
|
||||
|
||||
Feb 25, 2005
|
||||
|
||||
* TS: Fix for Bugzilla Bug 19 by Leslie De Koninck.
|
||||
|
||||
Feb 21, 2005
|
||||
|
||||
* JW: Fixed various module imports and expanded SWI-Prolog
|
||||
library(ordsets) to support all of the clp(R) library.
|
||||
|
||||
Dec 16, 2004
|
||||
|
||||
* JW: Make loading parts silent
|
||||
* TS: Fixed bug toplevel printing. Now only pass different
|
||||
variables to dump/3.
|
||||
|
||||
Dec 15, 2004
|
||||
|
||||
* JW: Added version to CVS, updated copyright notices, etc.
|
||||
* TS: Added automatic printing of constraints on variables
|
||||
in toplevel query.
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
################################################################
|
||||
# SWI-Prolog CLPQR package
|
||||
# Author: Jan Wielemaker. jan@swi.psy.uva.nl
|
||||
# Copyright: LGPL (see COPYING or www.gnu.org
|
||||
################################################################
|
||||
|
||||
PACKAGE=clpqr
|
||||
|
||||
include ../Makefile.defs
|
||||
|
||||
CLPDIR=$(PLLIBDIR)
|
||||
CLPRDIR=$(CLPDIR)/clpr
|
||||
CLPQDIR=$(CLPDIR)/clpq
|
||||
CLPQRDIR=$(CLPDIR)/clpqr
|
||||
|
||||
CLPRPRIV= bb_r.pl bv_r.pl \
|
||||
fourmotz_r.pl ineq_r.pl \
|
||||
itf_r.pl nf_r.pl \
|
||||
store_r.pl
|
||||
CLPQPRIV= bb_q.pl bv_q.pl \
|
||||
fourmotz_q.pl ineq_q.pl \
|
||||
itf_q.pl nf_q.pl \
|
||||
store_q.pl
|
||||
CLPQRPRIV= class.pl dump.pl \
|
||||
geler.pl itf.pl \
|
||||
ordering.pl \
|
||||
project.pl redund.pl
|
||||
LIBPL= $(srcdir)/clpr.pl $(srcdir)/clpq.pl
|
||||
EXAMPLES=
|
||||
|
||||
all::
|
||||
@echo "Nothing to be done for this package"
|
||||
|
||||
install: $(LIBPL) install-examples
|
||||
mkdir -p $(DESTDIR)$(CLPDIR)
|
||||
mkdir -p $(DESTDIR)$(CLPRDIR)
|
||||
mkdir -p $(DESTDIR)$(CLPQDIR)
|
||||
mkdir -p $(DESTDIR)$(CLPQRDIR)
|
||||
$(INSTALL_DATA) $(LIBPL) $(DESTDIR)$(CLPDIR)
|
||||
for f in $(CLPRPRIV); do $(INSTALL_DATA) $(srcdir)/clpr/$$f $(DESTDIR)$(CLPRDIR); done
|
||||
for f in $(CLPQPRIV); do $(INSTALL_DATA) $(srcdir)/clpq/$$f $(DESTDIR)$(CLPQDIR); done
|
||||
for f in $(CLPQRPRIV); do $(INSTALL_DATA) $(srcdir)/clpqr/$$f $(DESTDIR)$(CLPQRDIR); done
|
||||
$(INSTALL_DATA) $(srcdir)/README $(DESTDIR)$(CLPQRDIR)
|
||||
|
||||
ln-install::
|
||||
@$(MAKE) INSTALL_DATA=$(LN_INSTALL_DATA) INSTALL_PROGRAM=$(LN_INSTALL_PROGRAM) install
|
||||
|
||||
rpm-install: install
|
||||
|
||||
pdf-install: install-examples
|
||||
|
||||
html-install: install-examples
|
||||
|
||||
install-examples::
|
||||
# mkdir -p $(DESTDIR)$(EXDIR)
|
||||
# (cd Examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR))
|
||||
|
||||
uninstall:
|
||||
(cd $(CLPDIR) && rm -f $(LIBPL))
|
||||
rm -rf $(CLPRDIR)
|
||||
rm -rf $(CLPQDIR)
|
||||
rm -rf $(CLPQRDIR)
|
||||
|
||||
check::
|
||||
# $(PL) -q -f $(srcdir)/clpr_test.pl -g test,halt -t 'halt(1)'
|
||||
|
||||
|
||||
################################################################
|
||||
# Clean
|
||||
################################################################
|
||||
|
||||
clean:
|
||||
rm -f *~ *% config.log
|
||||
|
||||
distclean: clean
|
||||
rm -f config.h config.cache config.status Makefile
|
||||
rm -rf autom4te.cache
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
################################################################
|
||||
# Install CLP(R) stuff for the MS-Windows build
|
||||
# Author: Jan Wielemaker
|
||||
#
|
||||
# Use:
|
||||
# nmake /f Makefile.mak
|
||||
# nmake /f Makefile.mak install
|
||||
################################################################
|
||||
|
||||
PLHOME=..\..
|
||||
!include $(PLHOME)\src\rules.mk
|
||||
LIBDIR=$(PLBASE)\library
|
||||
EXDIR=$(PKGDOC)\examples\clpr
|
||||
CLPDIR=$(LIBDIR)\clp
|
||||
CLPRDIR=$(CLPDIR)\clpr
|
||||
CLPQDIR=$(CLPDIR)\clpq
|
||||
CLPQRDIR=$(CLPDIR)\clpqr
|
||||
PL="$(PLHOME)\bin\swipl.exe"
|
||||
|
||||
CLPRPRIV= bb_r.pl bv_r.pl fourmotz_r.pl ineq_r.pl \
|
||||
itf_r.pl nf_r.pl store_r.pl
|
||||
CLPQPRIV= bb_q.pl bv_q.pl fourmotz_q.pl ineq_q.pl \
|
||||
itf_q.pl nf_q.pl store_q.pl
|
||||
CLPQRPRIV= class.pl dump.pl geler.pl itf.pl ordering.pl \
|
||||
project.pl redund.pl
|
||||
LIBPL= clpr.pl clpq.pl
|
||||
EXAMPLES=
|
||||
|
||||
all::
|
||||
@echo "Nothing to be done for this package"
|
||||
|
||||
check::
|
||||
# $(PL) -q -f chr_test.pl -g test,halt -t 'halt(1)'
|
||||
|
||||
|
||||
!IF "$(CFG)" == "rt"
|
||||
install::
|
||||
!ELSE
|
||||
install::
|
||||
@if not exist "$(CLPRDIR)\$(NULL)" $(MKDIR) "$(CLPRDIR)"
|
||||
@if not exist "$(CLPQDIR)\$(NULL)" $(MKDIR) "$(CLPQDIR)"
|
||||
@if not exist "$(CLPQRDIR)\$(NULL)" $(MKDIR) "$(CLPQRDIR)"
|
||||
@for %f in ($(LIBPL)) do \
|
||||
copy "%f" "$(CLPDIR)"
|
||||
@for %f in ($(CLPRPRIV)) do \
|
||||
copy "clpr\%f" "$(CLPRDIR)"
|
||||
@for %f in ($(CLPQPRIV)) do \
|
||||
copy "clpq\%f" "$(CLPQDIR)"
|
||||
@for %f in ($(CLPQRPRIV)) do \
|
||||
copy "clpqr\%f" "$(CLPQRDIR)"
|
||||
copy README "$(CLPQRDIR)\README.TXT"
|
||||
!ENDIF
|
||||
|
||||
html-install: install-examples
|
||||
pdf-install: install-examples
|
||||
|
||||
install-examples::
|
||||
# if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)"
|
||||
# cd examples & @for %f in ($(EXAMPLES)) do @copy %f "$(EXDIR)"
|
||||
|
||||
xpce-install::
|
||||
|
||||
uninstall::
|
||||
@for %f in ($(LIBPL)) do \
|
||||
del "$(CLPDIR)\%f"
|
||||
@for %f in ($(CLPRPRIV)) do \
|
||||
del "$(CLPRDIR)\%f"
|
||||
@for %f in ($(CLPQPRIV)) do \
|
||||
del "$(CLPQDIR)\%f"
|
||||
@for %f in ($(CLPQRPRIV)) do \
|
||||
del "$(CLPQRDIR)\%f"
|
||||
del "$(CLPQRDIR)\README.TXT"
|
||||
|
||||
clean::
|
||||
if exist *~ del *~
|
||||
|
||||
distclean: clean
|
|
@ -0,0 +1,19 @@
|
|||
SWI-Prolog CLP(Q,R)
|
||||
-------------------
|
||||
|
||||
Author: Leslie De Koninck, K.U.Leuven
|
||||
|
||||
This software is based on the CLP(Q,R) implementation by Christian
|
||||
Holzbauer and released with permission from all above mentioned authors
|
||||
and Christian Holzbauer under the standard SWI-Prolog license schema:
|
||||
GPL-2 + statement to allow linking with proprietary software.
|
||||
|
||||
The sources of this package are maintained in packages/clpr in the
|
||||
SWI-Prolog source distribution. The documentation source is in
|
||||
man/lib/clpr.doc as part of the overall SWI-Prolog documentation.
|
||||
|
||||
Full documentation on CLP(Q,R) can be found at
|
||||
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
/*
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(clpq,
|
||||
[
|
||||
{}/1,
|
||||
maximize/1,
|
||||
minimize/1,
|
||||
inf/2, inf/4, sup/2, sup/4,
|
||||
bb_inf/3,
|
||||
bb_inf/4,
|
||||
ordering/1,
|
||||
entailed/1,
|
||||
clp_type/2,
|
||||
dump/3%, projecting_assert/1
|
||||
]).
|
||||
|
||||
:- expects_dialect(swi).
|
||||
|
||||
%
|
||||
% Don't report export of private predicates from clpq
|
||||
%
|
||||
:- multifile
|
||||
user:portray_message/2.
|
||||
|
||||
:- dynamic
|
||||
user:portray_message/2.
|
||||
%
|
||||
user:portray_message(warning,import(_,_,clpq,private)).
|
||||
|
||||
:- load_files(
|
||||
[
|
||||
'clpq/bb_q',
|
||||
'clpq/bv_q',
|
||||
'clpq/fourmotz_q',
|
||||
'clpq/ineq_q',
|
||||
'clpq/itf_q',
|
||||
'clpq/nf_q',
|
||||
'clpq/store_q',
|
||||
'clpqr/class',
|
||||
'clpqr/dump',
|
||||
'clpqr/geler',
|
||||
'clpqr/itf',
|
||||
'clpqr/ordering',
|
||||
'clpqr/project',
|
||||
'clpqr/redund',
|
||||
library(ugraphs)
|
||||
],
|
||||
[
|
||||
if(not_loaded),
|
||||
silent(true)
|
||||
]).
|
||||
|
||||
/*******************************
|
||||
* TOPLEVEL PRINTING *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
% prolog:message(query(YesNo)) --> !,
|
||||
% ['~@'-[chr:print_all_stores]],
|
||||
% '$messages':prolog_message(query(YesNo)).
|
||||
|
||||
prolog:message(query(YesNo,Bindings)) --> !,
|
||||
{dump_toplevel_bindings(Bindings,Constraints)},
|
||||
{dump_format(Constraints,Format)},
|
||||
Format,
|
||||
'$messages':prolog_message(query(YesNo,Bindings)).
|
||||
|
||||
dump_toplevel_bindings(Bindings,Constraints) :-
|
||||
dump_vars_names(Bindings,[],Vars,Names),
|
||||
dump(Vars,Names,Constraints).
|
||||
|
||||
dump_vars_names([],_,[],[]).
|
||||
dump_vars_names([Name=Term|Rest],Seen,Vars,Names) :-
|
||||
( var(Term),
|
||||
( get_attr(Term,itf,_)
|
||||
; get_attr(Term,geler,_)
|
||||
),
|
||||
\+ memberchk_eq(Term,Seen)
|
||||
-> Vars = [Term|RVars],
|
||||
Names = [Name|RNames],
|
||||
NSeen = [Term|Seen]
|
||||
; Vars = RVars,
|
||||
Names = RNames,
|
||||
Seen = NSeen
|
||||
),
|
||||
dump_vars_names(Rest,NSeen,RVars,RNames).
|
||||
|
||||
dump_format([],[]).
|
||||
dump_format([X|Xs],['{~w}'-[X],nl|Rest]) :-
|
||||
dump_format(Xs,Rest).
|
||||
|
||||
memberchk_eq(X,[Y|Ys]) :-
|
||||
( X == Y
|
||||
-> true
|
||||
; memberchk_eq(X,Ys)
|
||||
).
|
|
@ -0,0 +1,240 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(bb_q,
|
||||
[
|
||||
bb_inf/3,
|
||||
bb_inf/4,
|
||||
vertex_value/2
|
||||
]).
|
||||
:- use_module(bv_q,
|
||||
[
|
||||
deref/2,
|
||||
deref_var/2,
|
||||
determine_active_dec/1,
|
||||
inf/2,
|
||||
iterate_dec/2,
|
||||
sup/2,
|
||||
var_with_def_assign/2
|
||||
]).
|
||||
:- use_module(nf_q,
|
||||
[
|
||||
{}/1,
|
||||
entailed/1,
|
||||
nf/2,
|
||||
nf_constant/2,
|
||||
repair/2,
|
||||
wait_linear/3
|
||||
]).
|
||||
|
||||
% bb_inf(Ints,Term,Inf)
|
||||
%
|
||||
% Finds the infimum of Term where the variables Ints are to be integers.
|
||||
% The infimum is stored in Inf.
|
||||
|
||||
bb_inf(Is,Term,Inf) :-
|
||||
bb_inf(Is,Term,Inf,_).
|
||||
|
||||
bb_inf(Is,Term,Inf,Vertex) :-
|
||||
wait_linear(Term,Nf,bb_inf_internal(Is,Nf,Inf,Vertex)).
|
||||
|
||||
% ---------------------------------------------------------------------
|
||||
|
||||
% bb_inf_internal(Is,Lin,Inf,Vertex)
|
||||
%
|
||||
% Finds an infimum <Inf> for linear expression in normal form <Lin>, where
|
||||
% all variables in <Is> are to be integers.
|
||||
|
||||
bb_inf_internal(Is,Lin,_,_) :-
|
||||
bb_intern(Is,IsNf),
|
||||
nb_delete(prov_opt),
|
||||
repair(Lin,LinR), % bb_narrow ...
|
||||
deref(LinR,Lind),
|
||||
var_with_def_assign(Dep,Lind),
|
||||
determine_active_dec(Lind),
|
||||
bb_loop(Dep,IsNf),
|
||||
fail.
|
||||
bb_inf_internal(_,_,Inf,Vertex) :-
|
||||
catch(nb_getval(prov_opt,InfVal-Vertex),_,fail),
|
||||
{Inf =:= InfVal},
|
||||
nb_delete(prov_opt).
|
||||
|
||||
% bb_loop(Opt,Is)
|
||||
%
|
||||
% Minimizes the value of Opt where variables Is have to be integer values.
|
||||
|
||||
bb_loop(Opt,Is) :-
|
||||
bb_reoptimize(Opt,Inf),
|
||||
bb_better_bound(Inf),
|
||||
vertex_value(Is,Ivs),
|
||||
( bb_first_nonint(Is,Ivs,Viol,Floor,Ceiling)
|
||||
-> bb_branch(Viol,Floor,Ceiling),
|
||||
bb_loop(Opt,Is)
|
||||
; nb_setval(prov_opt,Inf-Ivs) % new provisional optimum
|
||||
).
|
||||
|
||||
% bb_reoptimize(Obj,Inf)
|
||||
%
|
||||
% Minimizes the value of Obj and puts the result in Inf.
|
||||
% This new minimization is necessary as making a bound integer may yield a
|
||||
% different optimum. The added inequalities may also have led to binding.
|
||||
|
||||
bb_reoptimize(Obj,Inf) :-
|
||||
var(Obj),
|
||||
iterate_dec(Obj,Inf).
|
||||
bb_reoptimize(Obj,Inf) :-
|
||||
nonvar(Obj),
|
||||
Inf = Obj.
|
||||
|
||||
% bb_better_bound(Inf)
|
||||
%
|
||||
% Checks if the new infimum Inf is better than the previous one (if such exists).
|
||||
|
||||
bb_better_bound(Inf) :-
|
||||
catch((nb_getval(prov_opt,Inc-_),Inf < Inc),_,true).
|
||||
|
||||
% bb_branch(V,U,L)
|
||||
%
|
||||
% Stores that V =< U or V >= L, can be used for different strategies within
|
||||
% bb_loop/3.
|
||||
|
||||
bb_branch(V,U,_) :- {V =< U}.
|
||||
bb_branch(V,_,L) :- {V >= L}.
|
||||
|
||||
% vertex_value(Vars,Values)
|
||||
%
|
||||
% Returns in <Values> the current values of the variables in <Vars>.
|
||||
|
||||
vertex_value([],[]).
|
||||
vertex_value([X|Xs],[V|Vs]) :-
|
||||
rhs_value(X,V),
|
||||
vertex_value(Xs,Vs).
|
||||
|
||||
% rhs_value(X,Value)
|
||||
%
|
||||
% Returns in <Value> the current value of variable <X>.
|
||||
|
||||
rhs_value(Xn,Value) :-
|
||||
( nonvar(Xn)
|
||||
-> Value = Xn
|
||||
; var(Xn)
|
||||
-> deref_var(Xn,Xd),
|
||||
Xd = [I,R|_],
|
||||
Value is R+I
|
||||
).
|
||||
|
||||
% bb_first_nonint(Ints,Rhss,Eps,Viol,Floor,Ceiling)
|
||||
%
|
||||
% Finds the first variable in Ints which doesn't have an active integer bound.
|
||||
% Rhss contain the Rhs (R + I) values corresponding to the variables.
|
||||
% The first variable that hasn't got an active integer bound, is returned in
|
||||
% Viol. The floor and ceiling of its actual bound is returned in Floor and Ceiling.
|
||||
|
||||
bb_first_nonint([I|Is],[Rhs|Rhss],Viol,F,C) :-
|
||||
( integer(Rhs)
|
||||
-> bb_first_nonint(Is,Rhss,Viol,F,C)
|
||||
; Viol = I,
|
||||
F is floor(Rhs),
|
||||
C is ceiling(Rhs)
|
||||
).
|
||||
|
||||
% bb_intern([X|Xs],[Xi|Xis])
|
||||
%
|
||||
% Turns the elements of the first list into integers into the second
|
||||
% list via bb_intern/3.
|
||||
|
||||
bb_intern([],[]).
|
||||
bb_intern([X|Xs],[Xi|Xis]) :-
|
||||
nf(X,Xnf),
|
||||
bb_intern(Xnf,Xi,X),
|
||||
bb_intern(Xs,Xis).
|
||||
|
||||
|
||||
% bb_intern(Nf,X,Term)
|
||||
%
|
||||
% Makes sure that Term which is normalized into Nf, is integer.
|
||||
% X contains the possibly changed Term. If Term is a variable,
|
||||
% then its bounds are hightened or lowered to the next integer.
|
||||
% Otherwise, it is checked it Term is integer.
|
||||
|
||||
bb_intern([],X,_) :-
|
||||
!,
|
||||
X = 0.
|
||||
bb_intern([v(I,[])],X,_) :-
|
||||
!,
|
||||
integer(I),
|
||||
X = I.
|
||||
bb_intern([v(1,[V^1])],X,_) :-
|
||||
!,
|
||||
V = X,
|
||||
bb_narrow_lower(X),
|
||||
bb_narrow_upper(X).
|
||||
bb_intern(_,_,Term) :-
|
||||
throw(instantiation_error(bb_inf(Term,_),1)).
|
||||
|
||||
% bb_narrow_lower(X)
|
||||
%
|
||||
% Narrows the lower bound so that it is an integer bound.
|
||||
% We do this by finding the infimum of X and asserting that X
|
||||
% is larger than the first integer larger or equal to the infimum
|
||||
% (second integer if X is to be strict larger than the first integer).
|
||||
|
||||
bb_narrow_lower(X) :-
|
||||
( inf(X,Inf)
|
||||
-> Bound is ceiling(Inf),
|
||||
( entailed(X > Bound)
|
||||
-> {X >= Bound+1}
|
||||
; {X >= Bound}
|
||||
)
|
||||
; true
|
||||
).
|
||||
|
||||
% bb_narrow_upper(X)
|
||||
%
|
||||
% See bb_narrow_lower/1. This predicate handles the upper bound.
|
||||
|
||||
bb_narrow_upper(X) :-
|
||||
( sup(X,Sup)
|
||||
-> Bound is floor(Sup),
|
||||
( entailed(X < Bound)
|
||||
-> {X =< Bound-1}
|
||||
; {X =< Bound}
|
||||
)
|
||||
; true
|
||||
).
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,503 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(fourmotz_q,
|
||||
[
|
||||
fm_elim/3
|
||||
]).
|
||||
:- use_module(bv_q,
|
||||
[
|
||||
allvars/2,
|
||||
basis_add/2,
|
||||
detach_bounds/1,
|
||||
pivot/5,
|
||||
var_with_def_intern/4
|
||||
]).
|
||||
:- use_module('../clpqr/class',
|
||||
[
|
||||
class_allvars/2
|
||||
]).
|
||||
:- use_module('../clpqr/project',
|
||||
[
|
||||
drop_dep/1,
|
||||
drop_dep_one/1,
|
||||
make_target_indep/2
|
||||
]).
|
||||
:- use_module('../clpqr/redund',
|
||||
[
|
||||
redundancy_vars/1
|
||||
]).
|
||||
:- use_module(store_q,
|
||||
[
|
||||
add_linear_11/3,
|
||||
add_linear_f1/4,
|
||||
indep/2,
|
||||
nf_coeff_of/3,
|
||||
normalize_scalar/2
|
||||
]).
|
||||
|
||||
|
||||
|
||||
fm_elim(Vs,Target,Pivots) :-
|
||||
prefilter(Vs,Vsf),
|
||||
fm_elim_int(Vsf,Target,Pivots).
|
||||
|
||||
% prefilter(Vars,Res)
|
||||
%
|
||||
% filters out target variables and variables that do not occur in bounded linear equations.
|
||||
% Stores that the variables in Res are to be kept independent.
|
||||
|
||||
prefilter([],[]).
|
||||
prefilter([V|Vs],Res) :-
|
||||
( get_attr(V,itf,Att),
|
||||
arg(9,Att,n),
|
||||
occurs(V)
|
||||
-> % V is a nontarget variable that occurs in a bounded linear equation
|
||||
Res = [V|Tail],
|
||||
setarg(10,Att,keep_indep),
|
||||
prefilter(Vs,Tail)
|
||||
; prefilter(Vs,Res)
|
||||
).
|
||||
|
||||
%
|
||||
% the target variables are marked with an attribute, and we get a list
|
||||
% of them as an argument too
|
||||
%
|
||||
fm_elim_int([],_,Pivots) :- % done
|
||||
unkeep(Pivots).
|
||||
fm_elim_int(Vs,Target,Pivots) :-
|
||||
Vs = [_|_],
|
||||
( best(Vs,Best,Rest)
|
||||
-> occurences(Best,Occ),
|
||||
elim_min(Best,Occ,Target,Pivots,NewPivots)
|
||||
; % give up
|
||||
NewPivots = Pivots,
|
||||
Rest = []
|
||||
),
|
||||
fm_elim_int(Rest,Target,NewPivots).
|
||||
|
||||
% best(Vs,Best,Rest)
|
||||
%
|
||||
% Finds the variable with the best result (lowest Delta) in fm_cp_filter
|
||||
% and returns the other variables in Rest.
|
||||
|
||||
best(Vs,Best,Rest) :-
|
||||
findall(Delta-N,fm_cp_filter(Vs,Delta,N),Deltas),
|
||||
keysort(Deltas,[_-N|_]),
|
||||
select_nth(Vs,N,Best,Rest).
|
||||
|
||||
% fm_cp_filter(Vs,Delta,N)
|
||||
%
|
||||
% For an indepenent variable V in Vs, which is the N'th element in Vs,
|
||||
% find how many inequalities are generated when this variable is eliminated.
|
||||
% Note that target variables and variables that only occur in unbounded equations
|
||||
% should have been removed from Vs via prefilter/2
|
||||
|
||||
fm_cp_filter(Vs,Delta,N) :-
|
||||
length(Vs,Len), % Len = number of variables in Vs
|
||||
mem(Vs,X,Vst), % Selects a variable X in Vs, Vst is the list of elements after X in Vs
|
||||
get_attr(X,itf,Att),
|
||||
arg(4,Att,lin(Lin)),
|
||||
arg(5,Att,order(OrdX)),
|
||||
arg(9,Att,n), % no target variable
|
||||
indep(Lin,OrdX), % X is an independent variable
|
||||
occurences(X,Occ),
|
||||
Occ = [_|_],
|
||||
cp_card(Occ,0,Lnew),
|
||||
length(Occ,Locc),
|
||||
Delta is Lnew-Locc,
|
||||
length(Vst,Vstl),
|
||||
N is Len-Vstl. % X is the Nth element in Vs
|
||||
|
||||
% mem(Xs,X,XsT)
|
||||
%
|
||||
% If X is a member of Xs, XsT is the list of elements after X in Xs.
|
||||
|
||||
mem([X|Xs],X,Xs).
|
||||
mem([_|Ys],X,Xs) :- mem(Ys,X,Xs).
|
||||
|
||||
% select_nth(List,N,Nth,Others)
|
||||
%
|
||||
% Selects the N th element of List, stores it in Nth and returns the rest of the list in Others.
|
||||
|
||||
select_nth(List,N,Nth,Others) :-
|
||||
select_nth(List,1,N,Nth,Others).
|
||||
|
||||
select_nth([X|Xs],N,N,X,Xs) :- !.
|
||||
select_nth([Y|Ys],M,N,X,[Y|Xs]) :-
|
||||
M1 is M+1,
|
||||
select_nth(Ys,M1,N,X,Xs).
|
||||
|
||||
%
|
||||
% fm_detach + reverse_pivot introduce indep t_none, which
|
||||
% invalidates the invariants
|
||||
%
|
||||
elim_min(V,Occ,Target,Pivots,NewPivots) :-
|
||||
crossproduct(Occ,New,[]),
|
||||
activate_crossproduct(New),
|
||||
reverse_pivot(Pivots),
|
||||
fm_detach(Occ),
|
||||
allvars(V,All),
|
||||
redundancy_vars(All), % only for New \== []
|
||||
make_target_indep(Target,NewPivots),
|
||||
drop_dep(All).
|
||||
|
||||
%
|
||||
% restore NF by reverse pivoting
|
||||
%
|
||||
reverse_pivot([]).
|
||||
reverse_pivot([I:D|Ps]) :-
|
||||
get_attr(D,itf,AttD),
|
||||
arg(2,AttD,type(Dt)),
|
||||
setarg(11,AttD,n), % no longer
|
||||
get_attr(I,itf,AttI),
|
||||
arg(2,AttI,type(It)),
|
||||
arg(5,AttI,order(OrdI)),
|
||||
arg(6,AttI,class(ClI)),
|
||||
pivot(D,ClI,OrdI,Dt,It),
|
||||
reverse_pivot(Ps).
|
||||
|
||||
% unkeep(Pivots)
|
||||
%
|
||||
%
|
||||
|
||||
unkeep([]).
|
||||
unkeep([_:D|Ps]) :-
|
||||
get_attr(D,itf,Att),
|
||||
setarg(11,Att,n),
|
||||
drop_dep_one(D),
|
||||
unkeep(Ps).
|
||||
|
||||
|
||||
%
|
||||
% All we drop are bounds
|
||||
%
|
||||
fm_detach( []).
|
||||
fm_detach([V:_|Vs]) :-
|
||||
detach_bounds(V),
|
||||
fm_detach(Vs).
|
||||
|
||||
% activate_crossproduct(Lst)
|
||||
%
|
||||
% For each inequality Lin =< 0 (or Lin < 0) in Lst, a new variable is created:
|
||||
% Var = Lin and Var =< 0 (or Var < 0). Var is added to the basis.
|
||||
|
||||
activate_crossproduct([]).
|
||||
activate_crossproduct([lez(Strict,Lin)|News]) :-
|
||||
var_with_def_intern(t_u(0),Var,Lin,Strict),
|
||||
% Var belongs to same class as elements in Lin
|
||||
basis_add(Var,_),
|
||||
activate_crossproduct(News).
|
||||
|
||||
% ------------------------------------------------------------------------------
|
||||
|
||||
% crossproduct(Lst,Res,ResTail)
|
||||
%
|
||||
% See crossproduct/4
|
||||
% This predicate each time puts the next element of Lst as First in crossproduct/4
|
||||
% and lets the rest be Next.
|
||||
|
||||
crossproduct([]) --> [].
|
||||
crossproduct([A|As]) -->
|
||||
crossproduct(As,A),
|
||||
crossproduct(As).
|
||||
|
||||
% crossproduct(Next,First,Res,ResTail)
|
||||
%
|
||||
% Eliminates a variable in linear equations First + Next and stores the generated
|
||||
% inequalities in Res.
|
||||
% Let's say A:K1 = First and B:K2 = first equation in Next.
|
||||
% A = ... + K1*V + ...
|
||||
% B = ... + K2*V + ...
|
||||
% Let K = -K2/K1
|
||||
% then K*A + B = ... + 0*V + ...
|
||||
% from the bounds of A and B, via cross_lower/7 and cross_upper/7, new inequalities
|
||||
% are generated. Then the same is done for B:K2 = next element in Next.
|
||||
|
||||
crossproduct([],_) --> [].
|
||||
crossproduct([B:Kb|Bs],A:Ka) -->
|
||||
{
|
||||
get_attr(A,itf,AttA),
|
||||
arg(2,AttA,type(Ta)),
|
||||
arg(3,AttA,strictness(Sa)),
|
||||
arg(4,AttA,lin(LinA)),
|
||||
get_attr(B,itf,AttB),
|
||||
arg(2,AttB,type(Tb)),
|
||||
arg(3,AttB,strictness(Sb)),
|
||||
arg(4,AttB,lin(LinB)),
|
||||
K is -Kb rdiv Ka,
|
||||
add_linear_f1(LinA,K,LinB,Lin) % Lin doesn't contain the target variable anymore
|
||||
},
|
||||
( { K > 0 } % K > 0: signs were opposite
|
||||
-> { Strict is Sa \/ Sb },
|
||||
cross_lower(Ta,Tb,K,Lin,Strict),
|
||||
cross_upper(Ta,Tb,K,Lin,Strict)
|
||||
; % La =< A =< Ua -> -Ua =< -A =< -La
|
||||
{
|
||||
flip(Ta,Taf),
|
||||
flip_strict(Sa,Saf),
|
||||
Strict is Saf \/ Sb
|
||||
},
|
||||
cross_lower(Taf,Tb,K,Lin,Strict),
|
||||
cross_upper(Taf,Tb,K,Lin,Strict)
|
||||
),
|
||||
crossproduct(Bs,A:Ka).
|
||||
|
||||
% cross_lower(Ta,Tb,K,Lin,Strict,Res,ResTail)
|
||||
%
|
||||
% Generates a constraint following from the bounds of A and B.
|
||||
% When A = LinA and B = LinB then Lin = K*LinA + LinB. Ta is the type
|
||||
% of A and Tb is the type of B. Strict is the union of the strictness
|
||||
% of A and B. If K is negative, then Ta should have been flipped (flip/2).
|
||||
% The idea is that if La =< A =< Ua and Lb =< B =< Ub (=< can also be <)
|
||||
% then if K is positive, K*La + Lb =< K*A + B =< K*Ua + Ub.
|
||||
% if K is negative, K*Ua + Lb =< K*A + B =< K*La + Ub.
|
||||
% This predicate handles the first inequality and adds it to Res in the form
|
||||
% lez(Sl,Lhs) meaning K*La + Lb - (K*A + B) =< 0 or K*Ua + Lb - (K*A + B) =< 0
|
||||
% with Sl being the strictness and Lhs the lefthandside of the equation.
|
||||
% See also cross_upper/7
|
||||
|
||||
cross_lower(Ta,Tb,K,Lin,Strict) -->
|
||||
{
|
||||
lower(Ta,La),
|
||||
lower(Tb,Lb),
|
||||
!,
|
||||
L is K*La+Lb,
|
||||
normalize_scalar(L,Ln),
|
||||
add_linear_f1(Lin,-1,Ln,Lhs),
|
||||
Sl is Strict >> 1 % normalize to upper bound
|
||||
},
|
||||
[ lez(Sl,Lhs) ].
|
||||
cross_lower(_,_,_,_,_) --> [].
|
||||
|
||||
% cross_upper(Ta,Tb,K,Lin,Strict,Res,ResTail)
|
||||
%
|
||||
% See cross_lower/7
|
||||
% This predicate handles the second inequality:
|
||||
% -(K*Ua + Ub) + K*A + B =< 0 or -(K*La + Ub) + K*A + B =< 0
|
||||
|
||||
cross_upper(Ta,Tb,K,Lin,Strict) -->
|
||||
{
|
||||
upper(Ta,Ua),
|
||||
upper(Tb,Ub),
|
||||
!,
|
||||
U is -(K*Ua+Ub),
|
||||
normalize_scalar(U,Un),
|
||||
add_linear_11(Un,Lin,Lhs),
|
||||
Su is Strict /\ 1 % normalize to upper bound
|
||||
},
|
||||
[ lez(Su,Lhs) ].
|
||||
cross_upper(_,_,_,_,_) --> [].
|
||||
|
||||
% lower(Type,Lowerbound)
|
||||
%
|
||||
% Returns the lowerbound of type Type if it has one.
|
||||
% E.g. if type = t_l(L) then Lowerbound is L,
|
||||
% if type = t_lU(L,U) then Lowerbound is L,
|
||||
% if type = t_u(U) then fails
|
||||
|
||||
lower(t_l(L),L).
|
||||
lower(t_lu(L,_),L).
|
||||
lower(t_L(L),L).
|
||||
lower(t_Lu(L,_),L).
|
||||
lower(t_lU(L,_),L).
|
||||
|
||||
% upper(Type,Upperbound)
|
||||
%
|
||||
% Returns the upperbound of type Type if it has one.
|
||||
% See lower/2
|
||||
|
||||
upper(t_u(U),U).
|
||||
upper(t_lu(_,U),U).
|
||||
upper(t_U(U),U).
|
||||
upper(t_Lu(_,U),U).
|
||||
upper(t_lU(_,U),U).
|
||||
|
||||
% flip(Type,FlippedType)
|
||||
%
|
||||
% Flips the lower and upperbound, so the old lowerbound becomes the new upperbound and
|
||||
% vice versa.
|
||||
|
||||
flip(t_l(X),t_u(X)).
|
||||
flip(t_u(X),t_l(X)).
|
||||
flip(t_lu(X,Y),t_lu(Y,X)).
|
||||
flip(t_L(X),t_u(X)).
|
||||
flip(t_U(X),t_l(X)).
|
||||
flip(t_lU(X,Y),t_lu(Y,X)).
|
||||
flip(t_Lu(X,Y),t_lu(Y,X)).
|
||||
|
||||
% flip_strict(Strict,FlippedStrict)
|
||||
%
|
||||
% Does what flip/2 does, but for the strictness.
|
||||
|
||||
flip_strict(0,0).
|
||||
flip_strict(1,2).
|
||||
flip_strict(2,1).
|
||||
flip_strict(3,3).
|
||||
|
||||
% cp_card(Lst,CountIn,CountOut)
|
||||
%
|
||||
% Counts the number of bounds that may generate an inequality in
|
||||
% crossproduct/3
|
||||
|
||||
cp_card([],Ci,Ci).
|
||||
cp_card([A|As],Ci,Co) :-
|
||||
cp_card(As,A,Ci,Cii),
|
||||
cp_card(As,Cii,Co).
|
||||
|
||||
% cp_card(Next,First,CountIn,CountOut)
|
||||
%
|
||||
% Counts the number of bounds that may generate an inequality in
|
||||
% crossproduct/4.
|
||||
|
||||
cp_card([],_,Ci,Ci).
|
||||
cp_card([B:Kb|Bs],A:Ka,Ci,Co) :-
|
||||
get_attr(A,itf,AttA),
|
||||
arg(2,AttA,type(Ta)),
|
||||
get_attr(B,itf,AttB),
|
||||
arg(2,AttB,type(Tb)),
|
||||
( sign(Ka) =\= sign(Kb)
|
||||
-> cp_card_lower(Ta,Tb,Ci,Cii),
|
||||
cp_card_upper(Ta,Tb,Cii,Ciii)
|
||||
; flip(Ta,Taf),
|
||||
cp_card_lower(Taf,Tb,Ci,Cii),
|
||||
cp_card_upper(Taf,Tb,Cii,Ciii)
|
||||
),
|
||||
cp_card(Bs,A:Ka,Ciii,Co).
|
||||
|
||||
% cp_card_lower(TypeA,TypeB,SIn,SOut)
|
||||
%
|
||||
% SOut = SIn + 1 if both TypeA and TypeB have a lowerbound.
|
||||
|
||||
cp_card_lower(Ta,Tb,Si,So) :-
|
||||
lower(Ta,_),
|
||||
lower(Tb,_),
|
||||
!,
|
||||
So is Si+1.
|
||||
cp_card_lower(_,_,Si,Si).
|
||||
|
||||
% cp_card_upper(TypeA,TypeB,SIn,SOut)
|
||||
%
|
||||
% SOut = SIn + 1 if both TypeA and TypeB have an upperbound.
|
||||
|
||||
cp_card_upper(Ta,Tb,Si,So) :-
|
||||
upper(Ta,_),
|
||||
upper(Tb,_),
|
||||
!,
|
||||
So is Si+1.
|
||||
cp_card_upper(_,_,Si,Si).
|
||||
|
||||
% ------------------------------------------------------------------------------
|
||||
|
||||
% occurences(V,Occ)
|
||||
%
|
||||
% Returns in Occ the occurrences of variable V in the linear equations of dependent variables
|
||||
% with bound =\= t_none in the form of D:K where D is a dependent variable and K is the scalar
|
||||
% of V in the linear equation of D.
|
||||
|
||||
occurences(V,Occ) :-
|
||||
get_attr(V,itf,Att),
|
||||
arg(5,Att,order(OrdV)),
|
||||
arg(6,Att,class(C)),
|
||||
class_allvars(C,All),
|
||||
occurences(All,OrdV,Occ).
|
||||
|
||||
% occurences(De,OrdV,Occ)
|
||||
%
|
||||
% Returns in Occ the occurrences of variable V with order OrdV in the linear equations of
|
||||
% dependent variables De with bound =\= t_none in the form of D:K where D is a dependent
|
||||
% variable and K is the scalar of V in the linear equation of D.
|
||||
|
||||
occurences(De,_,[]) :-
|
||||
var(De),
|
||||
!.
|
||||
occurences([D|De],OrdV,Occ) :-
|
||||
( get_attr(D,itf,Att),
|
||||
arg(2,Att,type(Type)),
|
||||
arg(4,Att,lin(Lin)),
|
||||
occ_type_filter(Type),
|
||||
nf_coeff_of(Lin,OrdV,K)
|
||||
-> Occ = [D:K|Occt],
|
||||
occurences(De,OrdV,Occt)
|
||||
; occurences(De,OrdV,Occ)
|
||||
).
|
||||
|
||||
% occ_type_filter(Type)
|
||||
%
|
||||
% Succeeds when Type is any other type than t_none. Is used in occurences/3 and occurs/2
|
||||
|
||||
occ_type_filter(t_l(_)).
|
||||
occ_type_filter(t_u(_)).
|
||||
occ_type_filter(t_lu(_,_)).
|
||||
occ_type_filter(t_L(_)).
|
||||
occ_type_filter(t_U(_)).
|
||||
occ_type_filter(t_lU(_,_)).
|
||||
occ_type_filter(t_Lu(_,_)).
|
||||
|
||||
% occurs(V)
|
||||
%
|
||||
% Checks whether variable V occurs in a linear equation of a dependent variable with a bound
|
||||
% =\= t_none.
|
||||
|
||||
occurs(V) :-
|
||||
get_attr(V,itf,Att),
|
||||
arg(5,Att,order(OrdV)),
|
||||
arg(6,Att,class(C)),
|
||||
class_allvars(C,All),
|
||||
occurs(All,OrdV).
|
||||
|
||||
% occurs(De,OrdV)
|
||||
%
|
||||
% Checks whether variable V with order OrdV occurs in a linear equation of any dependent variable
|
||||
% in De with a bound =\= t_none.
|
||||
|
||||
occurs(De,_) :-
|
||||
var(De),
|
||||
!,
|
||||
fail.
|
||||
occurs([D|De],OrdV) :-
|
||||
( get_attr(D,itf,Att),
|
||||
arg(2,Att,type(Type)),
|
||||
arg(4,Att,lin(Lin)),
|
||||
occ_type_filter(Type),
|
||||
nf_coeff_of(Lin,OrdV,_)
|
||||
-> true
|
||||
; occurs(De,OrdV)
|
||||
).
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,222 @@
|
|||
/*
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(itf_q,
|
||||
[
|
||||
do_checks/8
|
||||
]).
|
||||
:- use_module(bv_q,
|
||||
[
|
||||
deref/2,
|
||||
detach_bounds_vlv/5,
|
||||
solve/1,
|
||||
solve_ord_x/3
|
||||
]).
|
||||
:- use_module(nf_q,
|
||||
[
|
||||
nf/2
|
||||
]).
|
||||
:- use_module(store_q,
|
||||
[
|
||||
add_linear_11/3,
|
||||
indep/2,
|
||||
nf_coeff_of/3
|
||||
]).
|
||||
:- use_module('../clpqr/class',
|
||||
[
|
||||
class_drop/2
|
||||
]).
|
||||
|
||||
do_checks(Y,Ty,St,Li,Or,Cl,No,Later) :-
|
||||
numbers_only(Y),
|
||||
verify_nonzero(No,Y),
|
||||
verify_type(Ty,St,Y,Later,[]),
|
||||
verify_lin(Or,Cl,Li,Y),
|
||||
maplist(call,Later).
|
||||
|
||||
numbers_only(Y) :-
|
||||
( var(Y)
|
||||
; rational(Y)
|
||||
; throw(type_error(_X = Y,2,'a rational number',Y))
|
||||
),
|
||||
!.
|
||||
|
||||
% verify_nonzero(Nonzero,Y)
|
||||
%
|
||||
% if Nonzero = nonzero, then verify that Y is not zero
|
||||
% (if possible, otherwise set Y to be nonzero)
|
||||
|
||||
verify_nonzero(nonzero,Y) :-
|
||||
( var(Y)
|
||||
-> ( get_attr(Y,itf,Att)
|
||||
-> setarg(8,Att,nonzero)
|
||||
; put_attr(Y,itf,t(clpq,n,n,n,n,n,n,nonzero,n,n,n))
|
||||
)
|
||||
; Y =\= 0
|
||||
).
|
||||
verify_nonzero(n,_). % X is not nonzero
|
||||
|
||||
% verify_type(type(Type),strictness(Strict),Y,[OL|OLT],OLT)
|
||||
%
|
||||
% if possible verifies whether Y satisfies the type and strictness of X
|
||||
% if not possible to verify, then returns the constraints that follow from
|
||||
% the type and strictness
|
||||
|
||||
verify_type(type(Type),strictness(Strict),Y) -->
|
||||
verify_type2(Y,Type,Strict).
|
||||
verify_type(n,n,_) --> [].
|
||||
|
||||
verify_type2(Y,TypeX,StrictX) -->
|
||||
{var(Y)},
|
||||
!,
|
||||
verify_type_var(TypeX,Y,StrictX).
|
||||
verify_type2(Y,TypeX,StrictX) -->
|
||||
{verify_type_nonvar(TypeX,Y,StrictX)}.
|
||||
|
||||
% verify_type_nonvar(Type,Nonvar,Strictness)
|
||||
%
|
||||
% verifies whether the type and strictness are satisfied with the Nonvar
|
||||
|
||||
verify_type_nonvar(t_none,_,_).
|
||||
verify_type_nonvar(t_l(L),Value,S) :- ilb(S,L,Value).
|
||||
verify_type_nonvar(t_u(U),Value,S) :- iub(S,U,Value).
|
||||
verify_type_nonvar(t_lu(L,U),Value,S) :-
|
||||
ilb(S,L,Value),
|
||||
iub(S,U,Value).
|
||||
verify_type_nonvar(t_L(L),Value,S) :- ilb(S,L,Value).
|
||||
verify_type_nonvar(t_U(U),Value,S) :- iub(S,U,Value).
|
||||
verify_type_nonvar(t_Lu(L,U),Value,S) :-
|
||||
ilb(S,L,Value),
|
||||
iub(S,U,Value).
|
||||
verify_type_nonvar(t_lU(L,U),Value,S) :-
|
||||
ilb(S,L,Value),
|
||||
iub(S,U,Value).
|
||||
|
||||
% ilb(Strict,Lower,Value) & iub(Strict,Upper,Value)
|
||||
%
|
||||
% check whether Value is satisfiable with the given lower/upper bound and
|
||||
% strictness.
|
||||
% strictness is encoded as follows:
|
||||
% 2 = strict lower bound
|
||||
% 1 = strict upper bound
|
||||
% 3 = strict lower and upper bound
|
||||
% 0 = no strict bounds
|
||||
|
||||
ilb(S,L,V) :-
|
||||
S /\ 2 =:= 0,
|
||||
!,
|
||||
L =< V. % non-strict
|
||||
ilb(_,L,V) :- L < V. % strict
|
||||
|
||||
iub(S,U,V) :-
|
||||
S /\ 1 =:= 0,
|
||||
!,
|
||||
V =< U. % non-strict
|
||||
iub(_,U,V) :- V < U. % strict
|
||||
|
||||
%
|
||||
% Running some goals after X=Y simplifies the coding. It should be possible
|
||||
% to run the goals here and taking care not to put_atts/2 on X ...
|
||||
%
|
||||
|
||||
% verify_type_var(Type,Var,Strictness,[OutList|OutListTail],OutListTail)
|
||||
%
|
||||
% returns the inequalities following from a type and strictness satisfaction
|
||||
% test with Var
|
||||
|
||||
verify_type_var(t_none,_,_) --> [].
|
||||
verify_type_var(t_l(L),Y,S) --> llb(S,L,Y).
|
||||
verify_type_var(t_u(U),Y,S) --> lub(S,U,Y).
|
||||
verify_type_var(t_lu(L,U),Y,S) -->
|
||||
llb(S,L,Y),
|
||||
lub(S,U,Y).
|
||||
verify_type_var(t_L(L),Y,S) --> llb(S,L,Y).
|
||||
verify_type_var(t_U(U),Y,S) --> lub(S,U,Y).
|
||||
verify_type_var(t_Lu(L,U),Y,S) -->
|
||||
llb(S,L,Y),
|
||||
lub(S,U,Y).
|
||||
verify_type_var(t_lU(L,U),Y,S) -->
|
||||
llb(S,L,Y),
|
||||
lub(S,U,Y).
|
||||
|
||||
% llb(Strict,Lower,Value,[OL|OLT],OLT) and lub(Strict,Upper,Value,[OL|OLT],OLT)
|
||||
%
|
||||
% returns the inequalities following from the lower and upper bounds and the
|
||||
% strictness see also lb and ub
|
||||
llb(S,L,V) -->
|
||||
{S /\ 2 =:= 0},
|
||||
!,
|
||||
[clpq:{L =< V}].
|
||||
llb(_,L,V) --> [clpq:{L < V}].
|
||||
|
||||
lub(S,U,V) -->
|
||||
{S /\ 1 =:= 0},
|
||||
!,
|
||||
[clpq:{V =< U}].
|
||||
lub(_,U,V) --> [clpq:{V < U}].
|
||||
|
||||
%
|
||||
% We used to drop X from the class/basis to avoid trouble with subsequent
|
||||
% put_atts/2 on X. Now we could let these dead but harmless updates happen.
|
||||
% In R however, exported bindings might conflict, e.g. 0 \== 0.0
|
||||
%
|
||||
% If X is indep and we do _not_ solve for it, we are in deep shit
|
||||
% because the ordering is violated.
|
||||
%
|
||||
verify_lin(order(OrdX),class(Class),lin(LinX),Y) :-
|
||||
!,
|
||||
( indep(LinX,OrdX)
|
||||
-> detach_bounds_vlv(OrdX,LinX,Class,Y,NewLinX),
|
||||
% if there were bounds, they are requeued already
|
||||
class_drop(Class,Y),
|
||||
nf(-Y,NfY),
|
||||
deref(NfY,LinY),
|
||||
add_linear_11(NewLinX,LinY,Lind),
|
||||
( nf_coeff_of(Lind,OrdX,_)
|
||||
-> % X is element of Lind
|
||||
solve_ord_x(Lind,OrdX,Class)
|
||||
; solve(Lind) % X is gone, can safely solve Lind
|
||||
)
|
||||
; class_drop(Class,Y),
|
||||
nf(-Y,NfY),
|
||||
deref(NfY,LinY),
|
||||
add_linear_11(LinX,LinY,Lind),
|
||||
solve(Lind)
|
||||
).
|
||||
verify_lin(_,_,_,_).
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,398 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(store_q,
|
||||
[
|
||||
add_linear_11/3,
|
||||
add_linear_f1/4,
|
||||
add_linear_ff/5,
|
||||
normalize_scalar/2,
|
||||
delete_factor/4,
|
||||
mult_linear_factor/3,
|
||||
nf_rhs_x/4,
|
||||
indep/2,
|
||||
isolate/3,
|
||||
nf_substitute/4,
|
||||
mult_hom/3,
|
||||
nf2sum/3,
|
||||
nf_coeff_of/3,
|
||||
renormalize/2
|
||||
]).
|
||||
|
||||
% normalize_scalar(S,[N,Z])
|
||||
%
|
||||
% Transforms a scalar S into a linear expression [S,0]
|
||||
|
||||
normalize_scalar(S,[S,0]).
|
||||
|
||||
% renormalize(List,Lin)
|
||||
%
|
||||
% Renormalizes the not normalized linear expression in List into
|
||||
% a normalized one. It does so to take care of unifications.
|
||||
% (e.g. when a variable X is bound to a constant, the constant is added to
|
||||
% the constant part of the linear expression; when a variable X is bound to
|
||||
% another variable Y, the scalars of both are added)
|
||||
|
||||
renormalize([I,R|Hom],Lin) :-
|
||||
length(Hom,Len),
|
||||
renormalize_log(Len,Hom,[],Lin0),
|
||||
add_linear_11([I,R],Lin0,Lin).
|
||||
|
||||
% renormalize_log(Len,Hom,HomTail,Lin)
|
||||
%
|
||||
% Logarithmically renormalizes the homogene part of a not normalized
|
||||
% linear expression. See also renormalize/2.
|
||||
|
||||
renormalize_log(1,[Term|Xs],Xs,Lin) :-
|
||||
!,
|
||||
Term = l(X*_,_),
|
||||
renormalize_log_one(X,Term,Lin).
|
||||
renormalize_log(2,[A,B|Xs],Xs,Lin) :-
|
||||
!,
|
||||
A = l(X*_,_),
|
||||
B = l(Y*_,_),
|
||||
renormalize_log_one(X,A,LinA),
|
||||
renormalize_log_one(Y,B,LinB),
|
||||
add_linear_11(LinA,LinB,Lin).
|
||||
renormalize_log(N,L0,L2,Lin) :-
|
||||
P is N>>1,
|
||||
Q is N-P,
|
||||
renormalize_log(P,L0,L1,Lp),
|
||||
renormalize_log(Q,L1,L2,Lq),
|
||||
add_linear_11(Lp,Lq,Lin).
|
||||
|
||||
% renormalize_log_one(X,Term,Res)
|
||||
%
|
||||
% Renormalizes a term in X: if X is a nonvar, the term becomes a scalar.
|
||||
|
||||
renormalize_log_one(X,Term,Res) :-
|
||||
var(X),
|
||||
Term = l(X*K,_),
|
||||
get_attr(X,itf,Att),
|
||||
arg(5,Att,order(OrdX)), % Order might have changed
|
||||
Res = [0,0,l(X*K,OrdX)].
|
||||
renormalize_log_one(X,Term,Res) :-
|
||||
nonvar(X),
|
||||
Term = l(X*K,_),
|
||||
Xk is X*K,
|
||||
normalize_scalar(Xk,Res).
|
||||
|
||||
% ----------------------------- sparse vector stuff ---------------------------- %
|
||||
|
||||
% add_linear_ff(LinA,Ka,LinB,Kb,LinC)
|
||||
%
|
||||
% Linear expression LinC is the result of the addition of the 2 linear expressions
|
||||
% LinA and LinB, each one multiplied by a scalar (Ka for LinA and Kb for LinB).
|
||||
|
||||
add_linear_ff(LinA,Ka,LinB,Kb,LinC) :-
|
||||
LinA = [Ia,Ra|Ha],
|
||||
LinB = [Ib,Rb|Hb],
|
||||
LinC = [Ic,Rc|Hc],
|
||||
Ic is Ia*Ka+Ib*Kb,
|
||||
Rc is Ra*Ka+Rb*Kb,
|
||||
add_linear_ffh(Ha,Ka,Hb,Kb,Hc).
|
||||
|
||||
% add_linear_ffh(Ha,Ka,Hb,Kb,Hc)
|
||||
%
|
||||
% Homogene part Hc is the result of the addition of the 2 homogene parts Ha and Hb,
|
||||
% each one multiplied by a scalar (Ka for Ha and Kb for Hb)
|
||||
|
||||
add_linear_ffh([],_,Ys,Kb,Zs) :- mult_hom(Ys,Kb,Zs).
|
||||
add_linear_ffh([l(X*Kx,OrdX)|Xs],Ka,Ys,Kb,Zs) :-
|
||||
add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb).
|
||||
|
||||
% add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb)
|
||||
%
|
||||
% Homogene part Zs is the result of the addition of the 2 homogene parts Ys and
|
||||
% [l(X*Kx,OrdX)|Xs], each one multiplied by a scalar (Ka for [l(X*Kx,OrdX)|Xs] and Kb for Ys)
|
||||
|
||||
add_linear_ffh([],X,Kx,OrdX,Xs,Zs,Ka,_) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs).
|
||||
add_linear_ffh([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka,Kb) :-
|
||||
compare(Rel,OrdX,OrdY),
|
||||
( Rel = (=)
|
||||
-> Kz is Kx*Ka+Ky*Kb,
|
||||
( Kz =:= 0
|
||||
-> add_linear_ffh(Xs,Ka,Ys,Kb,Zs)
|
||||
; Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
add_linear_ffh(Xs,Ka,Ys,Kb,Ztail)
|
||||
)
|
||||
; Rel = (<)
|
||||
-> Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
Kz is Kx*Ka,
|
||||
add_linear_ffh(Xs,Y,Ky,OrdY,Ys,Ztail,Kb,Ka)
|
||||
; Rel = (>)
|
||||
-> Zs = [l(Y*Kz,OrdY)|Ztail],
|
||||
Kz is Ky*Kb,
|
||||
add_linear_ffh(Ys,X,Kx,OrdX,Xs,Ztail,Ka,Kb)
|
||||
).
|
||||
|
||||
% add_linear_f1(LinA,Ka,LinB,LinC)
|
||||
%
|
||||
% special case of add_linear_ff with Kb = 1
|
||||
|
||||
add_linear_f1(LinA,Ka,LinB,LinC) :-
|
||||
LinA = [Ia,Ra|Ha],
|
||||
LinB = [Ib,Rb|Hb],
|
||||
LinC = [Ic,Rc|Hc],
|
||||
Ic is Ia*Ka+Ib,
|
||||
Rc is Ra*Ka+Rb,
|
||||
add_linear_f1h(Ha,Ka,Hb,Hc).
|
||||
|
||||
% add_linear_f1h(Ha,Ka,Hb,Hc)
|
||||
%
|
||||
% special case of add_linear_ffh/5 with Kb = 1
|
||||
|
||||
add_linear_f1h([],_,Ys,Ys).
|
||||
add_linear_f1h([l(X*Kx,OrdX)|Xs],Ka,Ys,Zs) :-
|
||||
add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka).
|
||||
|
||||
% add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka)
|
||||
%
|
||||
% special case of add_linear_ffh/8 with Kb = 1
|
||||
|
||||
add_linear_f1h([],X,Kx,OrdX,Xs,Zs,Ka) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs).
|
||||
add_linear_f1h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka) :-
|
||||
compare(Rel,OrdX,OrdY),
|
||||
( Rel = (=)
|
||||
-> Kz is Kx*Ka+Ky,
|
||||
( Kz =:= 0
|
||||
-> add_linear_f1h(Xs,Ka,Ys,Zs)
|
||||
; Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
add_linear_f1h(Xs,Ka,Ys,Ztail)
|
||||
)
|
||||
; Rel = (<)
|
||||
-> Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
Kz is Kx*Ka,
|
||||
add_linear_f1h(Xs,Ka,[l(Y*Ky,OrdY)|Ys],Ztail)
|
||||
; Rel = (>)
|
||||
-> Zs = [l(Y*Ky,OrdY)|Ztail],
|
||||
add_linear_f1h(Ys,X,Kx,OrdX,Xs,Ztail,Ka)
|
||||
).
|
||||
|
||||
% add_linear_11(LinA,LinB,LinC)
|
||||
%
|
||||
% special case of add_linear_ff with Ka = 1 and Kb = 1
|
||||
|
||||
add_linear_11(LinA,LinB,LinC) :-
|
||||
LinA = [Ia,Ra|Ha],
|
||||
LinB = [Ib,Rb|Hb],
|
||||
LinC = [Ic,Rc|Hc],
|
||||
Ic is Ia+Ib,
|
||||
Rc is Ra+Rb,
|
||||
add_linear_11h(Ha,Hb,Hc).
|
||||
|
||||
% add_linear_11h(Ha,Hb,Hc)
|
||||
%
|
||||
% special case of add_linear_ffh/5 with Ka = 1 and Kb = 1
|
||||
|
||||
add_linear_11h([],Ys,Ys).
|
||||
add_linear_11h([l(X*Kx,OrdX)|Xs],Ys,Zs) :-
|
||||
add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs).
|
||||
|
||||
% add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs)
|
||||
%
|
||||
% special case of add_linear_ffh/8 with Ka = 1 and Kb = 1
|
||||
|
||||
add_linear_11h([],X,Kx,OrdX,Xs,[l(X*Kx,OrdX)|Xs]).
|
||||
add_linear_11h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs) :-
|
||||
compare(Rel,OrdX,OrdY),
|
||||
( Rel = (=)
|
||||
-> Kz is Kx+Ky,
|
||||
( Kz =:= 0
|
||||
-> add_linear_11h(Xs,Ys,Zs)
|
||||
; Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
add_linear_11h(Xs,Ys,Ztail)
|
||||
)
|
||||
; Rel = (<)
|
||||
-> Zs = [l(X*Kx,OrdX)|Ztail],
|
||||
add_linear_11h(Xs,Y,Ky,OrdY,Ys,Ztail)
|
||||
; Rel = (>)
|
||||
-> Zs = [l(Y*Ky,OrdY)|Ztail],
|
||||
add_linear_11h(Ys,X,Kx,OrdX,Xs,Ztail)
|
||||
).
|
||||
|
||||
% mult_linear_factor(Lin,K,Res)
|
||||
%
|
||||
% Linear expression Res is the result of multiplication of linear
|
||||
% expression Lin by scalar K
|
||||
|
||||
mult_linear_factor(Lin,K,Mult) :-
|
||||
K =:= 1,
|
||||
!,
|
||||
Mult = Lin.
|
||||
mult_linear_factor(Lin,K,Res) :-
|
||||
Lin = [I,R|Hom],
|
||||
Res = [Ik,Rk|Mult],
|
||||
Ik is I*K,
|
||||
Rk is R*K,
|
||||
mult_hom(Hom,K,Mult).
|
||||
|
||||
% mult_hom(Hom,K,Res)
|
||||
%
|
||||
% Homogene part Res is the result of multiplication of homogene part
|
||||
% Hom by scalar K
|
||||
|
||||
mult_hom([],_,[]).
|
||||
mult_hom([l(A*Fa,OrdA)|As],F,[l(A*Fan,OrdA)|Afs]) :-
|
||||
Fan is F*Fa,
|
||||
mult_hom(As,F,Afs).
|
||||
|
||||
% nf_substitute(Ord,Def,Lin,Res)
|
||||
%
|
||||
% Linear expression Res is the result of substitution of Var in
|
||||
% linear expression Lin, by its definition in the form of linear
|
||||
% expression Def
|
||||
|
||||
nf_substitute(OrdV,LinV,LinX,LinX1) :-
|
||||
delete_factor(OrdV,LinX,LinW,K),
|
||||
add_linear_f1(LinV,K,LinW,LinX1).
|
||||
|
||||
% delete_factor(Ord,Lin,Res,Coeff)
|
||||
%
|
||||
% Linear expression Res is the result of the deletion of the term
|
||||
% Var*Coeff where Var has ordering Ord from linear expression Lin
|
||||
|
||||
delete_factor(OrdV,Lin,Res,Coeff) :-
|
||||
Lin = [I,R|Hom],
|
||||
Res = [I,R|Hdel],
|
||||
delete_factor_hom(OrdV,Hom,Hdel,Coeff).
|
||||
|
||||
% delete_factor_hom(Ord,Hom,Res,Coeff)
|
||||
%
|
||||
% Homogene part Res is the result of the deletion of the term
|
||||
% Var*Coeff from homogene part Hom
|
||||
|
||||
delete_factor_hom(VOrd,[Car|Cdr],RCdr,RKoeff) :-
|
||||
Car = l(_*Koeff,Ord),
|
||||
compare(Rel,VOrd,Ord),
|
||||
( Rel= (=)
|
||||
-> RCdr = Cdr,
|
||||
RKoeff=Koeff
|
||||
; Rel= (>)
|
||||
-> RCdr = [Car|RCdr1],
|
||||
delete_factor_hom(VOrd,Cdr,RCdr1,RKoeff)
|
||||
).
|
||||
|
||||
|
||||
% nf_coeff_of(Lin,OrdX,Coeff)
|
||||
%
|
||||
% Linear expression Lin contains the term l(X*Coeff,OrdX)
|
||||
|
||||
nf_coeff_of([_,_|Hom],VOrd,Coeff) :-
|
||||
nf_coeff_hom(Hom,VOrd,Coeff).
|
||||
|
||||
% nf_coeff_hom(Lin,OrdX,Coeff)
|
||||
%
|
||||
% Linear expression Lin contains the term l(X*Coeff,OrdX) where the
|
||||
% order attribute of X = OrdX
|
||||
|
||||
nf_coeff_hom([l(_*K,OVar)|Vs],OVid,Coeff) :-
|
||||
compare(Rel,OVid,OVar),
|
||||
( Rel = (=)
|
||||
-> Coeff = K
|
||||
; Rel = (>)
|
||||
-> nf_coeff_hom(Vs,OVid,Coeff)
|
||||
).
|
||||
|
||||
% nf_rhs_x(Lin,OrdX,Rhs,K)
|
||||
%
|
||||
% Rhs = R + I where Lin = [I,R|Hom] and l(X*K,OrdX) is a term of Hom
|
||||
|
||||
nf_rhs_x(Lin,OrdX,Rhs,K) :-
|
||||
Lin = [I,R|Tail],
|
||||
nf_coeff_hom(Tail,OrdX,K),
|
||||
Rhs is R+I. % late because X may not occur in H
|
||||
|
||||
% isolate(OrdN,Lin,Lin1)
|
||||
%
|
||||
% Linear expression Lin1 is the result of the transformation of linear expression
|
||||
% Lin = 0 which contains the term l(New*K,OrdN) into an equivalent expression Lin1 = New.
|
||||
|
||||
isolate(OrdN,Lin,Lin1) :-
|
||||
delete_factor(OrdN,Lin,Lin0,Coeff),
|
||||
K is -1 rdiv Coeff,
|
||||
mult_linear_factor(Lin0,K,Lin1).
|
||||
|
||||
% indep(Lin,OrdX)
|
||||
%
|
||||
% succeeds if Lin = [0,_|[l(X*1,OrdX)]]
|
||||
|
||||
indep(Lin,OrdX) :-
|
||||
Lin = [I,_|[l(_*K,OrdY)]],
|
||||
OrdX == OrdY,
|
||||
K =:= 1,
|
||||
I =:= 0.
|
||||
|
||||
% nf2sum(Lin,Sofar,Term)
|
||||
%
|
||||
% Transforms a linear expression into a sum
|
||||
% (e.g. the expression [5,_,[l(X*2,OrdX),l(Y*-1,OrdY)]] gets transformed into 5 + 2*X - Y)
|
||||
|
||||
nf2sum([],I,I).
|
||||
nf2sum([X|Xs],I,Sum) :-
|
||||
( I =:= 0
|
||||
-> X = l(Var*K,_),
|
||||
( K =:= 1
|
||||
-> hom2sum(Xs,Var,Sum)
|
||||
; K =:= -1
|
||||
-> hom2sum(Xs,-Var,Sum)
|
||||
; hom2sum(Xs,K*Var,Sum)
|
||||
)
|
||||
; hom2sum([X|Xs],I,Sum)
|
||||
).
|
||||
|
||||
% hom2sum(Hom,Sofar,Term)
|
||||
%
|
||||
% Transforms a linear expression into a sum
|
||||
% this predicate handles all but the first term
|
||||
% (the first term does not need a concatenation symbol + or -)
|
||||
% see also nf2sum/3
|
||||
|
||||
hom2sum([],Term,Term).
|
||||
hom2sum([l(Var*K,_)|Cs],Sofar,Term) :-
|
||||
( K =:= 1
|
||||
-> Next = Sofar + Var
|
||||
; K =:= -1
|
||||
-> Next = Sofar - Var
|
||||
; K < 0
|
||||
-> Ka is -K,
|
||||
Next = Sofar - Ka*Var
|
||||
; Next = Sofar + K*Var
|
||||
),
|
||||
hom2sum(Cs,Next,Term).
|
|
@ -0,0 +1,155 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(class,
|
||||
[
|
||||
class_allvars/2,
|
||||
class_new/5,
|
||||
class_drop/2,
|
||||
class_basis/2,
|
||||
class_basis_add/3,
|
||||
class_basis_drop/2,
|
||||
class_basis_pivot/3,
|
||||
class_get_clp/2,
|
||||
class_get_prio/2,
|
||||
class_put_prio/2,
|
||||
ordering/1,
|
||||
arrangement/2
|
||||
]).
|
||||
|
||||
:- use_module(ordering,
|
||||
[
|
||||
combine/3,
|
||||
ordering/1,
|
||||
arrangement/2
|
||||
]).
|
||||
:- use_module(library(lists),
|
||||
[ append/3
|
||||
]).
|
||||
|
||||
% called when two classes are unified: the allvars lists are appended to eachother, as well as the basis
|
||||
% lists.
|
||||
%
|
||||
% note: La=[A,B,...,C|Lat], Lb=[D,E,...,F|Lbt], so new La = [A,B,...,C,D,E,...,F|Lbt]
|
||||
|
||||
attr_unify_hook(class(CLP,La,Lat,ABasis,PrioA),Y) :-
|
||||
!,
|
||||
var(Y),
|
||||
get_attr(Y,class,class(CLP,Lb,Lbt,BBasis,PrioB)),
|
||||
Lat = Lb,
|
||||
append(ABasis,BBasis,CBasis),
|
||||
combine(PrioA,PrioB,PrioC),
|
||||
put_attr(Y,class,class(CLP,La,Lbt,CBasis,PrioC)).
|
||||
attr_unify_hook(_,_).
|
||||
|
||||
class_new(Class,CLP,All,AllT,Basis) :-
|
||||
put_attr(Su,class,class(CLP,All,AllT,Basis,[])),
|
||||
Su = Class.
|
||||
|
||||
class_get_prio(Class,Priority) :-
|
||||
get_attr(Class,class,class(_,_,_,_,Priority)).
|
||||
|
||||
class_get_clp(Class,CLP) :-
|
||||
get_attr(Class,class,class(CLP,_,_,_,_)).
|
||||
|
||||
class_put_prio(Class,Priority) :-
|
||||
get_attr(Class,class,class(CLP,All,AllT,Basis,_)),
|
||||
put_attr(Class,class,class(CLP,All,AllT,Basis,Priority)).
|
||||
|
||||
class_drop(Class,X) :-
|
||||
get_attr(Class,class,class(CLP,Allvars,Tail,Basis,Priority)),
|
||||
delete_first(Allvars,X,NewAllvars),
|
||||
delete_first(Basis,X,NewBasis),
|
||||
put_attr(Class,class,class(CLP,NewAllvars,Tail,NewBasis,Priority)).
|
||||
|
||||
class_allvars(Class,All) :- get_attr(Class,class,class(_,All,_,_,_)).
|
||||
|
||||
% class_basis(Class,Basis)
|
||||
%
|
||||
% Returns the basis of class Class.
|
||||
|
||||
class_basis(Class,Basis) :- get_attr(Class,class,class(_,_,_,Basis,_)).
|
||||
|
||||
% class_basis_add(Class,X,NewBasis)
|
||||
%
|
||||
% adds X in front of the basis and returns the new basis
|
||||
|
||||
class_basis_add(Class,X,NewBasis) :-
|
||||
NewBasis = [X|Basis],
|
||||
get_attr(Class,class,class(CLP,All,AllT,Basis,Priority)),
|
||||
put_attr(Class,class,class(CLP,All,AllT,NewBasis,Priority)).
|
||||
|
||||
% class_basis_drop(Class,X)
|
||||
%
|
||||
% removes the first occurence of X from the basis (if exists)
|
||||
|
||||
class_basis_drop(Class,X) :-
|
||||
get_attr(Class,class,class(CLP,All,AllT,Basis0,Priority)),
|
||||
delete_first(Basis0,X,Basis),
|
||||
Basis0 \== Basis, % anything deleted ?
|
||||
!,
|
||||
put_attr(Class,class,class(CLP,All,AllT,Basis,Priority)).
|
||||
class_basis_drop(_,_).
|
||||
|
||||
% class_basis_pivot(Class,Enter,Leave)
|
||||
%
|
||||
% removes first occurence of Leave from the basis and adds Enter in front of the basis
|
||||
|
||||
class_basis_pivot(Class,Enter,Leave) :-
|
||||
get_attr(Class,class,class(CLP,All,AllT,Basis0,Priority)),
|
||||
delete_first(Basis0,Leave,Basis1),
|
||||
put_attr(Class,class,class(CLP,All,AllT,[Enter|Basis1],Priority)).
|
||||
|
||||
% delete_first(Old,Element,New)
|
||||
%
|
||||
% removes the first occurence of Element from Old and returns the result in New
|
||||
%
|
||||
% note: test via syntactic equality, not unifiability
|
||||
|
||||
delete_first(L,_,Res) :-
|
||||
var(L),
|
||||
!,
|
||||
Res = L.
|
||||
delete_first([],_,[]).
|
||||
delete_first([Y|Ys],X,Res) :-
|
||||
( X==Y
|
||||
-> Res = Ys
|
||||
; Res = [Y|Tail],
|
||||
delete_first(Ys,X,Tail)
|
||||
).
|
|
@ -0,0 +1,334 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(dump,
|
||||
[
|
||||
dump/3,
|
||||
projecting_assert/1
|
||||
]).
|
||||
:- use_module(class,
|
||||
[
|
||||
class_allvars/2
|
||||
]).
|
||||
:- use_module(geler,
|
||||
[
|
||||
collect_nonlin/3
|
||||
]).
|
||||
:- use_module(library(assoc),
|
||||
[
|
||||
empty_assoc/1,
|
||||
get_assoc/3,
|
||||
put_assoc/4,
|
||||
assoc_to_list/2
|
||||
]).
|
||||
:- use_module(itf,
|
||||
[
|
||||
dump_linear/3,
|
||||
dump_nonzero/3
|
||||
]).
|
||||
:- use_module(project,
|
||||
[
|
||||
project_attributes/2
|
||||
]).
|
||||
:- use_module(ordering,
|
||||
[
|
||||
ordering/1
|
||||
]).
|
||||
|
||||
%% dump(+Target,-NewVars,-Constraints) is det.
|
||||
%
|
||||
% Returns in <Constraints>, the constraints that currently hold on Target where
|
||||
% all variables in <Target> are copied to new variables in <NewVars> and the
|
||||
% constraints are given on these new variables. In short, you can safely
|
||||
% manipulate <NewVars> and <Constraints> without changing the constraints on
|
||||
% <Target>.
|
||||
|
||||
dump([],[],[]) :- !.
|
||||
dump(Target,NewVars,Constraints) :-
|
||||
( ( proper_varlist(Target)
|
||||
-> true
|
||||
; % Target is not a list of variables
|
||||
throw(instantiation_error(dump(Target,NewVars,Constraints),1))
|
||||
),
|
||||
ordering(Target),
|
||||
related_linear_vars(Target,All), % All contains all variables of the classes of Target variables.
|
||||
nonlin_crux(All,Nonlin),
|
||||
project_attributes(Target,All),
|
||||
related_linear_vars(Target,Again), % project drops/adds vars
|
||||
all_attribute_goals(Again,Gs,Nonlin),
|
||||
empty_assoc(D0),
|
||||
mapping(Target,NewVars,D0,D1), % late (AVL suffers from put_atts)
|
||||
copy(Gs,Copy,D1,_), % strip constraints
|
||||
nb_setval(clpqr_dump,NewVars/Copy),
|
||||
fail % undo projection
|
||||
; catch(nb_getval(clpqr_dump,NewVars/Constraints),_,fail),
|
||||
nb_delete(clpqr_dump)
|
||||
).
|
||||
|
||||
:- meta_predicate projecting_assert(:).
|
||||
|
||||
projecting_assert(QClause) :-
|
||||
strip_module(QClause, Module, Clause), % JW: SWI-Prolog not always qualifies the term!
|
||||
copy_term_clpq(Clause,Copy,Constraints),
|
||||
l2c(Constraints,Conj), % fails for []
|
||||
( Sm = clpq
|
||||
; Sm = clpr
|
||||
), % proper module for {}/1
|
||||
!,
|
||||
( Copy = (H:-B)
|
||||
-> % former rule
|
||||
Module:assert((H:-Sm:{Conj},B))
|
||||
; % former fact
|
||||
Module:assert((Copy:-Sm:{Conj}))
|
||||
).
|
||||
projecting_assert(Clause) :- % not our business
|
||||
assert(Clause).
|
||||
|
||||
copy_term_clpq(Term,Copy,Constraints) :-
|
||||
( term_variables(Term,Target), % get all variables in Term
|
||||
related_linear_vars(Target,All), % get all variables of the classes of the variables in Term
|
||||
nonlin_crux(All,Nonlin), % get a list of all the nonlinear goals of these variables
|
||||
project_attributes(Target,All),
|
||||
related_linear_vars(Target,Again), % project drops/adds vars
|
||||
all_attribute_goals(Again,Gs,Nonlin),
|
||||
empty_assoc(D0),
|
||||
copy(Term/Gs,TmpCopy,D0,_), % strip constraints
|
||||
nb_setval(clpqr_dump,TmpCopy),
|
||||
fail
|
||||
; catch(nb_getval(clpqr_dump,Copy/Constraints),_,fail),
|
||||
nb_delete(clpqr_copy_term)
|
||||
).
|
||||
|
||||
% l2c(Lst,Conj)
|
||||
%
|
||||
% converts a list to a round list: [a,b,c] -> (a,b,c) and [a] becomes a
|
||||
|
||||
l2c([X|Xs],Conj) :-
|
||||
( Xs = []
|
||||
-> Conj = X
|
||||
; Conj = (X,Xc),
|
||||
l2c(Xs,Xc)
|
||||
).
|
||||
|
||||
% proper_varlist(List)
|
||||
%
|
||||
% Returns whether Lst is a list of variables.
|
||||
% First clause is to avoid unification of a variable with a list.
|
||||
|
||||
proper_varlist(X) :-
|
||||
var(X),
|
||||
!,
|
||||
fail.
|
||||
proper_varlist([]).
|
||||
proper_varlist([X|Xs]) :-
|
||||
var(X),
|
||||
proper_varlist(Xs).
|
||||
|
||||
% related_linear_vars(Vs,All)
|
||||
%
|
||||
% Generates a list of all variables that are in the classes of the variables in
|
||||
% Vs.
|
||||
|
||||
related_linear_vars(Vs,All) :-
|
||||
empty_assoc(S0),
|
||||
related_linear_sys(Vs,S0,Sys),
|
||||
related_linear_vars(Sys,All,[]).
|
||||
|
||||
% related_linear_sys(Vars,Assoc,List)
|
||||
%
|
||||
% Generates in List, a list of all to classes to which variables in Vars
|
||||
% belong.
|
||||
% Assoc should be an empty association list and is used internally.
|
||||
% List contains elements of the form C-C where C is a class and both C's are
|
||||
% equal.
|
||||
|
||||
related_linear_sys([],S0,L0) :- assoc_to_list(S0,L0).
|
||||
related_linear_sys([V|Vs],S0,S2) :-
|
||||
( get_attr(V,itf,Att),
|
||||
arg(6,Att,class(C))
|
||||
-> put_assoc(C,S0,C,S1)
|
||||
; S1 = S0
|
||||
),
|
||||
related_linear_sys(Vs,S1,S2).
|
||||
|
||||
% related_linear_vars(Classes,[Vars|VarsTail],VarsTail)
|
||||
%
|
||||
% Generates a difference list of all variables in the classes in Classes.
|
||||
% Classes contains elements of the form C-C where C is a class and both C's are
|
||||
% equal.
|
||||
|
||||
related_linear_vars([]) --> [].
|
||||
related_linear_vars([S-_|Ss]) -->
|
||||
{
|
||||
class_allvars(S,Otl)
|
||||
},
|
||||
cpvars(Otl),
|
||||
related_linear_vars(Ss).
|
||||
|
||||
% cpvars(Vars,Out,OutTail)
|
||||
%
|
||||
% Makes a new difference list of the difference list Vars.
|
||||
% All nonvars are removed.
|
||||
|
||||
cpvars(Xs) --> {var(Xs)}, !.
|
||||
cpvars([X|Xs]) -->
|
||||
( { var(X) }
|
||||
-> [X]
|
||||
; []
|
||||
),
|
||||
cpvars(Xs).
|
||||
|
||||
% nonlin_crux(All,Gss)
|
||||
%
|
||||
% Collects all pending non-linear constraints of variables in All.
|
||||
% This marks all nonlinear goals of the variables as run and cannot
|
||||
% be reversed manually.
|
||||
|
||||
nonlin_crux(All,Gss) :-
|
||||
collect_nonlin(All,Gs,[]), % collect the nonlinear goals of variables All
|
||||
% this marks the goals as run and cannot be reversed manually
|
||||
nonlin_strip(Gs,Gss).
|
||||
|
||||
% nonlin_strip(Gs,Solver,Res)
|
||||
%
|
||||
% Removes the goals from Gs that are not from solver Solver.
|
||||
|
||||
nonlin_strip([],[]).
|
||||
nonlin_strip([_:What|Gs],Res) :-
|
||||
( What = {G}
|
||||
-> Res = [G|Gss]
|
||||
; Res = [What|Gss]
|
||||
),
|
||||
nonlin_strip(Gs,Gss).
|
||||
|
||||
all_attribute_goals([]) --> [].
|
||||
all_attribute_goals([V|Vs]) -->
|
||||
dump_linear(V),
|
||||
dump_nonzero(V),
|
||||
all_attribute_goals(Vs).
|
||||
|
||||
% mapping(L1,L2,AssocIn,AssocOut)
|
||||
%
|
||||
% Makes an association mapping of lists L1 and L2:
|
||||
% L1 = [L1H|L1T] and L2 = [L2H|L2T] then the association L1H-L2H is formed
|
||||
% and the tails are mapped similarly.
|
||||
|
||||
mapping([],[],D0,D0).
|
||||
mapping([T|Ts],[N|Ns],D0,D2) :-
|
||||
put_assoc(T,D0,N,D1),
|
||||
mapping(Ts,Ns,D1,D2).
|
||||
|
||||
% copy(Term,Copy,AssocIn,AssocOut)
|
||||
%
|
||||
% Makes a copy of Term by changing all variables in it to new ones and
|
||||
% building an association between original variables and the new ones.
|
||||
% E.g. when Term = test(A,B,C), Copy = test(D,E,F) and an association between
|
||||
% A and D, B and E and C and F is formed in AssocOut. AssocIn is input
|
||||
% association.
|
||||
|
||||
copy(Term,Copy,D0,D1) :-
|
||||
var(Term),
|
||||
( get_assoc(Term,D0,New)
|
||||
-> Copy = New,
|
||||
D1 = D0
|
||||
; put_assoc(Term,D0,Copy,D1)
|
||||
).
|
||||
copy(Term,Copy,D0,D1) :-
|
||||
nonvar(Term), % Term is a functor
|
||||
functor(Term,N,A),
|
||||
functor(Copy,N,A), % Copy is new functor with the same name and arity as Term
|
||||
copy(A,Term,Copy,D0,D1).
|
||||
|
||||
% copy(Nb,Term,Copy,AssocIn,AssocOut)
|
||||
%
|
||||
% Makes a copy of the Nb arguments of Term by changing all variables in it to
|
||||
% new ones and building an association between original variables and the new
|
||||
% ones.
|
||||
% See also copy/4
|
||||
|
||||
copy(0,_,_,D0,D0) :- !.
|
||||
copy(1,T,C,D0,D1) :- !,
|
||||
arg(1,T,At1),
|
||||
arg(1,C,Ac1),
|
||||
copy(At1,Ac1,D0,D1).
|
||||
copy(2,T,C,D0,D2) :- !,
|
||||
arg(1,T,At1),
|
||||
arg(1,C,Ac1),
|
||||
copy(At1,Ac1,D0,D1),
|
||||
arg(2,T,At2),
|
||||
arg(2,C,Ac2),
|
||||
copy(At2,Ac2,D1,D2).
|
||||
copy(N,T,C,D0,D2) :-
|
||||
arg(N,T,At),
|
||||
arg(N,C,Ac),
|
||||
copy(At,Ac,D0,D1),
|
||||
N1 is N-1,
|
||||
copy(N1,T,C,D1,D2).
|
||||
|
||||
%% attribute_goals(@V)// is det.
|
||||
%
|
||||
% Translate attributes back into goals. This is used by
|
||||
% copy_term/3, which also determines the toplevel printing of
|
||||
% residual constraints.
|
||||
|
||||
itf:attribute_goals(V) -->
|
||||
( { term_attvars(V, Vs),
|
||||
dump(Vs, NVs, List),
|
||||
NVs = Vs,
|
||||
del_itf(Vs),
|
||||
list_to_conj(List, Conj) }
|
||||
-> [ {}(Conj) ]
|
||||
; []
|
||||
).
|
||||
|
||||
class:attribute_goals(_) --> [].
|
||||
|
||||
geler:attribute_goals(V) --> itf:attribute_goals(V).
|
||||
|
||||
del_itf([]).
|
||||
del_itf([H|T]) :-
|
||||
del_attr(H, itf),
|
||||
del_itf(T).
|
||||
|
||||
|
||||
list_to_conj([], true) :- !.
|
||||
list_to_conj([X], X) :- !.
|
||||
list_to_conj([H|T0], (H,T)) :-
|
||||
list_to_conj(T0, T).
|
|
@ -0,0 +1,192 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(geler,
|
||||
[
|
||||
geler/3,
|
||||
project_nonlin/3,
|
||||
collect_nonlin/3
|
||||
]).
|
||||
|
||||
% l2conj(List,Conj)
|
||||
%
|
||||
% turns a List into a conjunction of the form (El,Conj) where Conj
|
||||
% is of the same form recursively and El is an element of the list
|
||||
|
||||
l2conj([X|Xs],Conj) :-
|
||||
( X = [],
|
||||
Conj = X
|
||||
; Xs = [_|_],
|
||||
Conj = (X,Xc),
|
||||
l2conj(Xs,Xc)
|
||||
).
|
||||
|
||||
% nonexhausted(Goals,OutList,OutListTail)
|
||||
%
|
||||
% removes the goals that have already run from Goals
|
||||
% and puts the result in the difference list OutList
|
||||
|
||||
nonexhausted(run(Mutex,G)) -->
|
||||
( { var(Mutex) }
|
||||
-> [G]
|
||||
; []
|
||||
).
|
||||
nonexhausted((A,B)) -->
|
||||
nonexhausted(A),
|
||||
nonexhausted(B).
|
||||
|
||||
attr_unify_hook(g(CLP,goals(Gx),_),Y) :-
|
||||
!,
|
||||
( var(Y),
|
||||
( get_attr(Y,geler,g(A,B,C))
|
||||
-> ignore((CLP \== A,throw(error(permission_error(
|
||||
'apply CLP(Q) constraints on','CLP(R) variable',Y),
|
||||
context(_))))),
|
||||
( % possibly mutual goals. these need to be run.
|
||||
% other goals are run as well to remove redundant goals.
|
||||
B = goals(Gy)
|
||||
-> Later = [Gx,Gy],
|
||||
( C = n
|
||||
-> del_attr(Y,geler)
|
||||
; put_attr(Y,geler,g(CLP,n,C))
|
||||
)
|
||||
; % no goals in Y, so no mutual goals of X and Y, store
|
||||
% goals of X in Y
|
||||
% no need to run any goal.
|
||||
Later = [],
|
||||
put_attr(Y,geler,g(CLP,goals(Gx),C))
|
||||
)
|
||||
; Later = [],
|
||||
put_attr(Y,geler,g(CLP,goals(Gx),n))
|
||||
)
|
||||
; nonvar(Y),
|
||||
Later = [Gx]
|
||||
),
|
||||
maplist(call,Later).
|
||||
attr_unify_hook(_,_). % no goals in X
|
||||
|
||||
%
|
||||
% called from project.pl
|
||||
%
|
||||
project_nonlin(_,Cvas,Reachable) :-
|
||||
collect_nonlin(Cvas,L,[]),
|
||||
sort(L,Ls),
|
||||
term_variables(Ls,Reachable).
|
||||
%put_attr(_,all_nonlin(Ls)).
|
||||
|
||||
|
||||
collect_nonlin([]) --> [].
|
||||
collect_nonlin([X|Xs]) -->
|
||||
( { get_attr(X,geler,g(_,goals(Gx),_)) }
|
||||
-> trans(Gx),
|
||||
collect_nonlin(Xs)
|
||||
; collect_nonlin(Xs)
|
||||
).
|
||||
|
||||
% trans(Goals,OutList,OutListTail)
|
||||
%
|
||||
% transforms the goals (of the form run(Mutex,Goal)
|
||||
% that are in Goals (in the conjunction form, see also l2conj)
|
||||
% that have not been run (Mutex = variable) into a readable output format
|
||||
% and notes that they're done (Mutex = 'done'). Because of the Mutex
|
||||
% variable, each goal is only added once (so not for each variable).
|
||||
|
||||
trans((A,B)) -->
|
||||
trans(A),
|
||||
trans(B).
|
||||
trans(run(Mutex,Gs)) -->
|
||||
( { var(Mutex) }
|
||||
-> { Mutex = done },
|
||||
transg(Gs)
|
||||
; []
|
||||
).
|
||||
|
||||
transg((A,B)) -->
|
||||
!,
|
||||
transg(A),
|
||||
transg(B).
|
||||
transg(M:G) -->
|
||||
!,
|
||||
M:transg(G).
|
||||
transg(G) --> [G].
|
||||
|
||||
% run(Mutex,G)
|
||||
%
|
||||
% Calls goal G if it has not yet run (Mutex is still variable)
|
||||
% and stores that it has run (Mutex = done). This is done so
|
||||
% that when X = Y and X and Y are in the same goal, that goal
|
||||
% is called only once.
|
||||
|
||||
run(Mutex,_) :- nonvar(Mutex).
|
||||
run(Mutex,G) :-
|
||||
var(Mutex),
|
||||
Mutex = done,
|
||||
call(G).
|
||||
|
||||
% geler(Vars,Goal)
|
||||
%
|
||||
% called by nf.pl when an unsolvable non-linear expression is found
|
||||
% Vars contain the variables of the expression, Goal contains the predicate of
|
||||
% nf.pl to be called when the variables are bound.
|
||||
|
||||
geler(CLP,Vars,Goal) :-
|
||||
attach(Vars,CLP,run(_Mutex,Goal)).
|
||||
% one goal gets the same mutex on every var, so it is run only once
|
||||
|
||||
% attach(Vars,Goal)
|
||||
%
|
||||
% attaches a new goal to be awoken when the variables get bounded.
|
||||
% when the old value of the attribute goals = OldGoal, then the new value =
|
||||
% (Goal,OldGoal)
|
||||
|
||||
attach([],_,_).
|
||||
attach([V|Vs],CLP,Goal) :-
|
||||
var(V),
|
||||
( get_attr(V,geler,g(A,B,C))
|
||||
-> ( CLP \== A
|
||||
-> throw(error(permission_error('apply CLP(Q) constraints on',
|
||||
'CLP(R) variable',V),context(_)))
|
||||
; ( B = goals(Goals)
|
||||
-> put_attr(V,geler,g(A,goals((Goal,Goals)),C))
|
||||
; put_attr(V,geler,g(A,goals(Goal),C))
|
||||
)
|
||||
)
|
||||
; put_attr(V,geler,g(CLP,goals(Goal),n))
|
||||
),
|
||||
attach(Vs,CLP,Goal).
|
|
@ -0,0 +1,124 @@
|
|||
/*
|
||||
|
||||
Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
|
||||
% attribute = t(CLP,type(_),strictness(_),lin(_),order(_),class(_),forward(_),
|
||||
% nonzero,target,keep_indep,keep)
|
||||
|
||||
:- module(itf,
|
||||
[
|
||||
dump_linear/3,
|
||||
dump_nonzero/3,
|
||||
clp_type/2
|
||||
]).
|
||||
|
||||
|
||||
clp_type(Var,Type) :-
|
||||
( get_attr(Var,itf,Att)
|
||||
-> arg(1,Att,Type)
|
||||
; get_attr(Var,geler,Att)
|
||||
-> arg(1,Att,Type)
|
||||
).
|
||||
|
||||
dump_linear(V) -->
|
||||
{
|
||||
get_attr(V,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
arg(2,Att,type(Type)),
|
||||
arg(4,Att,lin(Lin)),
|
||||
!,
|
||||
Lin = [I,_|H]
|
||||
},
|
||||
( {
|
||||
Type=t_none
|
||||
; arg(9,Att,n)
|
||||
}
|
||||
-> []
|
||||
; dump_v(CLP,t_none,V,I,H)
|
||||
),
|
||||
( {
|
||||
Type=t_none,
|
||||
arg(9,Att,n) % attribute should not have changed by dump_v...
|
||||
}
|
||||
-> % nonzero produces such
|
||||
[]
|
||||
; dump_v(CLP,Type,V,I,H)
|
||||
).
|
||||
dump_linear(_) --> [].
|
||||
|
||||
dump_v(clpq,Type,V,I,H) --> bv_q:dump_var(Type,V,I,H).
|
||||
dump_v(clpr,Type,V,I,H) --> bv_r:dump_var(Type,V,I,H).
|
||||
|
||||
dump_nonzero(V) -->
|
||||
{
|
||||
get_attr(V,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
arg(4,Att,lin(Lin)),
|
||||
arg(8,Att,nonzero),
|
||||
!,
|
||||
Lin = [I,_|H]
|
||||
},
|
||||
dump_nz(CLP,V,H,I).
|
||||
dump_nonzero(_) --> [].
|
||||
|
||||
dump_nz(clpq,V,H,I) --> bv_q:dump_nz(V,H,I).
|
||||
dump_nz(clpr,V,H,I) --> bv_r:dump_nz(V,H,I).
|
||||
|
||||
attr_unify_hook(t(CLP,n,n,n,n,n,n,n,_,_,_),Y) :-
|
||||
!,
|
||||
( get_attr(Y,itf,AttY),
|
||||
\+ arg(1,AttY,CLP)
|
||||
-> throw(error(permission_error('mix CLP(Q) variables with',
|
||||
'CLP(R) variables:',Y),context(_)))
|
||||
; true
|
||||
).
|
||||
attr_unify_hook(t(CLP,Ty,St,Li,Or,Cl,_,No,_,_,_),Y) :-
|
||||
( get_attr(Y,itf,AttY),
|
||||
\+ arg(1,AttY,CLP)
|
||||
-> throw(error(permission_error('mix CLP(Q) variables with',
|
||||
'CLP(R) variables:',Y),context(_)))
|
||||
; true
|
||||
),
|
||||
do_checks(CLP,Y,Ty,St,Li,Or,Cl,No,Later),
|
||||
maplist(call,Later).
|
||||
|
||||
do_checks(clpq,Y,Ty,St,Li,Or,Cl,No,Later) :-
|
||||
itf_q:do_checks(Y,Ty,St,Li,Or,Cl,No,Later).
|
||||
do_checks(clpr,Y,Ty,St,Li,Or,Cl,No,Later) :-
|
||||
itf_r:do_checks(Y,Ty,St,Li,Or,Cl,No,Later).
|
|
@ -0,0 +1,198 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(Q) (Constraint Logic Programming over Rationals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(ordering,
|
||||
[
|
||||
combine/3,
|
||||
ordering/1,
|
||||
arrangement/2
|
||||
]).
|
||||
:- use_module(class,
|
||||
[
|
||||
class_get_clp/2,
|
||||
class_get_prio/2,
|
||||
class_put_prio/2
|
||||
]).
|
||||
:- use_module(itf,
|
||||
[
|
||||
clp_type/2
|
||||
]).
|
||||
:- use_module(library(ugraphs),
|
||||
[
|
||||
add_edges/3,
|
||||
add_vertices/3,
|
||||
top_sort/2,
|
||||
ugraph_union/3
|
||||
]).
|
||||
:- use_module(library(lists),
|
||||
[
|
||||
append/3
|
||||
]).
|
||||
|
||||
ordering(X) :-
|
||||
var(X),
|
||||
!,
|
||||
fail.
|
||||
ordering(A>B) :-
|
||||
!,
|
||||
ordering(B<A).
|
||||
ordering(A<B) :-
|
||||
join_class([A,B],Class),
|
||||
class_get_prio(Class,Ga),
|
||||
!,
|
||||
add_edges([],[A-B],Gb),
|
||||
combine(Ga,Gb,Gc),
|
||||
class_put_prio(Class,Gc).
|
||||
ordering(Pb) :-
|
||||
Pb = [_|Xs],
|
||||
join_class(Pb,Class),
|
||||
class_get_prio(Class,Ga),
|
||||
!,
|
||||
( Xs = [],
|
||||
add_vertices([],Pb,Gb)
|
||||
; Xs=[_|_],
|
||||
gen_edges(Pb,Es,[]),
|
||||
add_edges([],Es,Gb)
|
||||
),
|
||||
combine(Ga,Gb,Gc),
|
||||
class_put_prio(Class,Gc).
|
||||
ordering(_).
|
||||
|
||||
arrangement(Class,Arr) :-
|
||||
class_get_prio(Class,G),
|
||||
normalize(G,Gn),
|
||||
top_sort(Gn,Arr),
|
||||
!.
|
||||
arrangement(_,_) :- throw(unsatisfiable_ordering).
|
||||
|
||||
join_class([],_).
|
||||
join_class([X|Xs],Class) :-
|
||||
( var(X)
|
||||
-> clp_type(X,CLP),
|
||||
( CLP = clpr
|
||||
-> bv_r:var_intern(X,Class)
|
||||
; bv_q:var_intern(X,Class)
|
||||
)
|
||||
; true
|
||||
),
|
||||
join_class(Xs,Class).
|
||||
|
||||
% combine(Ga,Gb,Gc)
|
||||
%
|
||||
% Combines the vertices of Ga and Gb into Gc.
|
||||
|
||||
combine(Ga,Gb,Gc) :-
|
||||
normalize(Ga,Gan),
|
||||
normalize(Gb,Gbn),
|
||||
ugraph_union(Gan,Gbn,Gc).
|
||||
|
||||
%
|
||||
% both Ga and Gb might have their internal ordering invalidated
|
||||
% because of bindings and aliasings
|
||||
%
|
||||
|
||||
normalize([],[]) :- !.
|
||||
normalize(G,Gsgn) :-
|
||||
G = [_|_],
|
||||
keysort(G,Gs), % sort vertices on key
|
||||
group(Gs,Gsg), % concatenate vertices with the same key
|
||||
normalize_vertices(Gsg,Gsgn). % normalize
|
||||
|
||||
normalize_vertices([],[]).
|
||||
normalize_vertices([X-Xnb|Xs],Res) :-
|
||||
( normalize_vertex(X,Xnb,Xnorm)
|
||||
-> Res = [Xnorm|Xsn],
|
||||
normalize_vertices(Xs,Xsn)
|
||||
; normalize_vertices(Xs,Res)
|
||||
).
|
||||
|
||||
% normalize_vertex(X,Nbs,X-Nbss)
|
||||
%
|
||||
% Normalizes a vertex X-Nbs into X-Nbss by sorting Nbs, removing duplicates (also of X)
|
||||
% and removing non-vars.
|
||||
|
||||
normalize_vertex(X,Nbs,X-Nbsss) :-
|
||||
var(X),
|
||||
sort(Nbs,Nbss),
|
||||
strip_nonvar(Nbss,X,Nbsss).
|
||||
|
||||
% strip_nonvar(Nbs,X,Res)
|
||||
%
|
||||
% Turns vertext X-Nbs into X-Res by removing occurrences of X from Nbs and removing
|
||||
% non-vars. This to normalize after bindings have occurred. See also normalize_vertex/3.
|
||||
|
||||
strip_nonvar([],_,[]).
|
||||
strip_nonvar([X|Xs],Y,Res) :-
|
||||
( X==Y % duplicate of Y
|
||||
-> strip_nonvar(Xs,Y,Res)
|
||||
; var(X) % var: keep
|
||||
-> Res = [X|Stripped],
|
||||
strip_nonvar(Xs,Y,Stripped)
|
||||
; % nonvar: remove
|
||||
nonvar(X),
|
||||
Res = [] % because Vars<anything
|
||||
).
|
||||
|
||||
gen_edges([]) --> [].
|
||||
gen_edges([X|Xs]) -->
|
||||
gen_edges(Xs,X),
|
||||
gen_edges(Xs).
|
||||
|
||||
gen_edges([],_) --> [].
|
||||
gen_edges([Y|Ys],X) -->
|
||||
[X-Y],
|
||||
gen_edges(Ys,X).
|
||||
|
||||
% group(Vert,Res)
|
||||
%
|
||||
% Concatenates vertices with the same key.
|
||||
|
||||
group([],[]).
|
||||
group([K-Kl|Ks],Res) :-
|
||||
group(Ks,K,Kl,Res).
|
||||
|
||||
group([],K,Kl,[K-Kl]).
|
||||
group([L-Ll|Ls],K,Kl,Res) :-
|
||||
( K==L
|
||||
-> append(Kl,Ll,KLl),
|
||||
group(Ls,K,KLl,Res)
|
||||
; Res = [K-Kl|Tail],
|
||||
group(Ls,L,Ll,Tail)
|
||||
).
|
|
@ -0,0 +1,305 @@
|
|||
/*
|
||||
|
||||
Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
%
|
||||
% Answer constraint projection
|
||||
%
|
||||
|
||||
%:- public project_attributes/2. % xref.pl
|
||||
|
||||
:- module(project,
|
||||
[
|
||||
drop_dep/1,
|
||||
drop_dep_one/1,
|
||||
make_target_indep/2,
|
||||
project_attributes/2
|
||||
]).
|
||||
:- use_module(class,
|
||||
[
|
||||
class_allvars/2
|
||||
]).
|
||||
:- use_module(geler,
|
||||
[
|
||||
project_nonlin/3
|
||||
]).
|
||||
:- use_module(redund,
|
||||
[
|
||||
redundancy_vars/1,
|
||||
systems/3
|
||||
]).
|
||||
:- use_module(ordering,
|
||||
[
|
||||
arrangement/2
|
||||
]).
|
||||
|
||||
%
|
||||
% interface predicate
|
||||
%
|
||||
% May be destructive (either acts on a copy or in a failure loop)
|
||||
%
|
||||
project_attributes(TargetVars,Cvas) :-
|
||||
sort(TargetVars,Tvs), % duplicates ?
|
||||
sort(Cvas,Avs), % duplicates ?
|
||||
get_clp(TargetVars,CLP),
|
||||
( nonvar(CLP)
|
||||
-> mark_target(Tvs),
|
||||
project_nonlin(Tvs,Avs,NlReachable),
|
||||
( Tvs == []
|
||||
-> drop_lin_atts(Avs)
|
||||
; redundancy_vars(Avs), % removes redundant bounds (redund.pl)
|
||||
make_target_indep(Tvs,Pivots), % pivot partners are marked to be kept during elim.
|
||||
mark_target(NlReachable), % after make_indep to express priority
|
||||
drop_dep(Avs),
|
||||
fm_elim(CLP,Avs,Tvs,Pivots),
|
||||
impose_ordering(Avs)
|
||||
)
|
||||
; true
|
||||
).
|
||||
|
||||
fm_elim(clpq,Avs,Tvs,Pivots) :- fourmotz_q:fm_elim(Avs,Tvs,Pivots).
|
||||
fm_elim(clpr,Avs,Tvs,Pivots) :- fourmotz_r:fm_elim(Avs,Tvs,Pivots).
|
||||
|
||||
get_clp([],_).
|
||||
get_clp([H|T],CLP) :-
|
||||
( get_attr(H,itf,Att)
|
||||
-> arg(1,Att,CLP)
|
||||
; true
|
||||
),
|
||||
get_clp(T,CLP).
|
||||
|
||||
% mark_target(Vars)
|
||||
%
|
||||
% Marks the variables in Vars as target variables.
|
||||
|
||||
mark_target([]).
|
||||
mark_target([V|Vs]) :-
|
||||
( get_attr(V,itf,Att)
|
||||
-> setarg(9,Att,target)
|
||||
; true
|
||||
),
|
||||
mark_target(Vs).
|
||||
|
||||
|
||||
% mark_keep(Vars)
|
||||
%
|
||||
% Mark the variables in Vars to be kept during elimination.
|
||||
|
||||
mark_keep([]).
|
||||
mark_keep([V|Vs]) :-
|
||||
get_attr(V,itf,Att),
|
||||
setarg(11,Att,keep),
|
||||
mark_keep(Vs).
|
||||
|
||||
%
|
||||
% Collect the pivots in reverse order
|
||||
% We have to protect the target variables pivot partners
|
||||
% from redundancy eliminations triggered by fm_elim,
|
||||
% in order to allow for reverse pivoting.
|
||||
%
|
||||
make_target_indep(Ts,Ps) :- make_target_indep(Ts,[],Ps).
|
||||
|
||||
% make_target_indep(Targets,Pivots,PivotsTail)
|
||||
%
|
||||
% Tries to make as many targetvariables independent by pivoting them with a non-target
|
||||
% variable. The pivots are stored as T:NT where T is a target variable and NT a non-target
|
||||
% variable. The non-target variables are marked to be kept during redundancy eliminations.
|
||||
|
||||
make_target_indep([],Ps,Ps).
|
||||
make_target_indep([T|Ts],Ps0,Pst) :-
|
||||
( get_attr(T,itf,AttT),
|
||||
arg(1,AttT,CLP),
|
||||
arg(2,AttT,type(Type)),
|
||||
arg(4,AttT,lin([_,_|H])),
|
||||
nontarget(H,Nt)
|
||||
-> Ps1 = [T:Nt|Ps0],
|
||||
get_attr(Nt,itf,AttN),
|
||||
arg(2,AttN,type(IndAct)),
|
||||
arg(5,AttN,order(Ord)),
|
||||
arg(6,AttN,class(Class)),
|
||||
setarg(11,AttN,keep),
|
||||
pivot(CLP,T,Class,Ord,Type,IndAct)
|
||||
; Ps1 = Ps0
|
||||
),
|
||||
make_target_indep(Ts,Ps1,Pst).
|
||||
|
||||
% nontarget(Hom,Nt)
|
||||
%
|
||||
% Finds a nontarget variable in homogene part Hom.
|
||||
% Hom contains elements of the form l(V*K,OrdV).
|
||||
% A nontarget variable has no target attribute and no keep_indep attribute.
|
||||
|
||||
nontarget([l(V*_,_)|Vs],Nt) :-
|
||||
( get_attr(V,itf,Att),
|
||||
arg(9,Att,n),
|
||||
arg(10,Att,n)
|
||||
-> Nt = V
|
||||
; nontarget(Vs,Nt)
|
||||
).
|
||||
|
||||
% drop_dep(Vars)
|
||||
%
|
||||
% Does drop_dep_one/1 on each variable in Vars.
|
||||
|
||||
drop_dep(Vs) :-
|
||||
var(Vs),
|
||||
!.
|
||||
drop_dep([]).
|
||||
drop_dep([V|Vs]) :-
|
||||
drop_dep_one(V),
|
||||
drop_dep(Vs).
|
||||
|
||||
% drop_dep_one(V)
|
||||
%
|
||||
% If V is an unbounded dependent variable that isn't a target variable, shouldn't be kept
|
||||
% and is not nonzero, drops all linear attributes of V.
|
||||
% The linear attributes are: type, strictness, linear equation (lin), class and order.
|
||||
|
||||
drop_dep_one(V) :-
|
||||
get_attr(V,itf,Att),
|
||||
Att = t(CLP,type(t_none),_,lin(Lin),order(OrdV),_,_,n,n,_,n),
|
||||
\+ indep(CLP,Lin,OrdV),
|
||||
!,
|
||||
setarg(2,Att,n),
|
||||
setarg(3,Att,n),
|
||||
setarg(4,Att,n),
|
||||
setarg(5,Att,n),
|
||||
setarg(6,Att,n).
|
||||
drop_dep_one(_).
|
||||
|
||||
indep(clpq,Lin,OrdV) :- store_q:indep(Lin,OrdV).
|
||||
indep(clpr,Lin,OrdV) :- store_r:indep(Lin,OrdV).
|
||||
|
||||
pivot(clpq,T,Class,Ord,Type,IndAct) :- bv_q:pivot(T,Class,Ord,Type,IndAct).
|
||||
pivot(clpr,T,Class,Ord,Type,IndAct) :- bv_r:pivot(T,Class,Ord,Type,IndAct).
|
||||
|
||||
renormalize(clpq,Lin,New) :- store_q:renormalize(Lin,New).
|
||||
renormalize(clpr,Lin,New) :- store_r:renormalize(Lin,New).
|
||||
|
||||
% drop_lin_atts(Vs)
|
||||
%
|
||||
% Removes the linear attributes of the variables in Vs.
|
||||
% The linear attributes are type, strictness, linear equation (lin), order and class.
|
||||
|
||||
drop_lin_atts([]).
|
||||
drop_lin_atts([V|Vs]) :-
|
||||
get_attr(V,itf,Att),
|
||||
setarg(2,Att,n),
|
||||
setarg(3,Att,n),
|
||||
setarg(4,Att,n),
|
||||
setarg(5,Att,n),
|
||||
setarg(6,Att,n),
|
||||
drop_lin_atts(Vs).
|
||||
|
||||
impose_ordering(Cvas) :-
|
||||
systems(Cvas,[],Sys),
|
||||
impose_ordering_sys(Sys).
|
||||
|
||||
impose_ordering_sys([]).
|
||||
impose_ordering_sys([S|Ss]) :-
|
||||
arrangement(S,Arr), % ordering.pl
|
||||
arrange(Arr,S),
|
||||
impose_ordering_sys(Ss).
|
||||
|
||||
arrange([],_).
|
||||
arrange(Arr,S) :-
|
||||
Arr = [_|_],
|
||||
class_allvars(S,All),
|
||||
order(Arr,1,N),
|
||||
order(All,N,_),
|
||||
renorm_all(All),
|
||||
arrange_pivot(All).
|
||||
|
||||
order(Xs,N,M) :-
|
||||
var(Xs),
|
||||
!,
|
||||
N = M.
|
||||
order([],N,N).
|
||||
order([X|Xs],N,M) :-
|
||||
( get_attr(X,itf,Att),
|
||||
arg(5,Att,order(O)),
|
||||
var(O)
|
||||
-> O = N,
|
||||
N1 is N+1,
|
||||
order(Xs,N1,M)
|
||||
; order(Xs,N,M)
|
||||
).
|
||||
|
||||
% renorm_all(Vars)
|
||||
%
|
||||
% Renormalizes all linear equations of the variables in difference list Vars to reflect
|
||||
% their new ordering.
|
||||
|
||||
renorm_all(Xs) :-
|
||||
var(Xs),
|
||||
!.
|
||||
renorm_all([X|Xs]) :-
|
||||
( get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
arg(4,Att,lin(Lin))
|
||||
-> renormalize(CLP,Lin,New),
|
||||
setarg(4,Att,lin(New)),
|
||||
renorm_all(Xs)
|
||||
; renorm_all(Xs)
|
||||
).
|
||||
|
||||
% arrange_pivot(Vars)
|
||||
%
|
||||
% If variable X of Vars has type t_none and has a higher order than the first element of
|
||||
% its linear equation, then it is pivoted with that element.
|
||||
|
||||
arrange_pivot(Xs) :-
|
||||
var(Xs),
|
||||
!.
|
||||
arrange_pivot([X|Xs]) :-
|
||||
( get_attr(X,itf,AttX),
|
||||
%arg(8,AttX,n), % not for nonzero
|
||||
arg(1,AttX,CLP),
|
||||
arg(2,AttX,type(t_none)),
|
||||
arg(4,AttX,lin(Lin)),
|
||||
arg(5,AttX,order(OrdX)),
|
||||
Lin = [_,_,l(Y*_,_)|_],
|
||||
get_attr(Y,itf,AttY),
|
||||
arg(2,AttY,type(IndAct)),
|
||||
arg(5,AttY,order(OrdY)),
|
||||
arg(6,AttY,class(Class)),
|
||||
compare(>,OrdY,OrdX)
|
||||
-> pivot(CLP,X,Class,OrdY,t_none,IndAct),
|
||||
arrange_pivot(Xs)
|
||||
; arrange_pivot(Xs)
|
||||
).
|
|
@ -0,0 +1,297 @@
|
|||
/*
|
||||
|
||||
Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2006, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is based on CLP(Q,R) by Christian Holzbaur for SICStus
|
||||
Prolog and distributed under the license details below with permission from
|
||||
all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(redund,
|
||||
[
|
||||
redundancy_vars/1,
|
||||
systems/3
|
||||
]).
|
||||
:- use_module(class,
|
||||
[
|
||||
class_allvars/2
|
||||
]).
|
||||
|
||||
%
|
||||
% redundancy removal (semantic definition)
|
||||
%
|
||||
% done:
|
||||
% +) deal with active bounds
|
||||
% +) indep t_[lu] -> t_none invalidates invariants (fixed)
|
||||
%
|
||||
|
||||
% systems(Vars,SystemsIn,SystemsOut)
|
||||
%
|
||||
% Returns in SystemsOut the different classes to which variables in Vars
|
||||
% belong. Every class only appears once in SystemsOut.
|
||||
|
||||
systems([],Si,Si).
|
||||
systems([V|Vs],Si,So) :-
|
||||
( var(V),
|
||||
get_attr(V,itf,Att),
|
||||
arg(6,Att,class(C)),
|
||||
not_memq(Si,C)
|
||||
-> systems(Vs,[C|Si],So)
|
||||
; systems(Vs,Si,So)
|
||||
).
|
||||
|
||||
% not_memq(Lst,El)
|
||||
%
|
||||
% Succeeds if El is not a member of Lst (does not use unification).
|
||||
|
||||
not_memq([],_).
|
||||
not_memq([Y|Ys],X) :-
|
||||
X \== Y,
|
||||
not_memq(Ys,X).
|
||||
|
||||
% redundancy_systems(Classes)
|
||||
%
|
||||
% Does redundancy removal via redundancy_vs/1 on all variables in the classes Classes.
|
||||
|
||||
redundancy_systems([]).
|
||||
redundancy_systems([S|Sys]) :-
|
||||
class_allvars(S,All),
|
||||
redundancy_vs(All),
|
||||
redundancy_systems(Sys).
|
||||
|
||||
% redundancy_vars(Vs)
|
||||
%
|
||||
% Does the same thing as redundancy_vs/1 but has some extra timing facilities that
|
||||
% may be used.
|
||||
|
||||
redundancy_vars(Vs) :-
|
||||
!,
|
||||
redundancy_vs(Vs).
|
||||
redundancy_vars(Vs) :-
|
||||
statistics(runtime,[Start|_]),
|
||||
redundancy_vs(Vs),
|
||||
statistics(runtime,[End|_]),
|
||||
Duration is End-Start,
|
||||
format(user_error,"% Redundancy elimination took ~d msec~n",Duration).
|
||||
|
||||
|
||||
% redundancy_vs(Vs)
|
||||
%
|
||||
% Removes redundant bounds from the variables in Vs via redundant/3
|
||||
|
||||
redundancy_vs(Vs) :-
|
||||
var(Vs),
|
||||
!.
|
||||
redundancy_vs([]).
|
||||
redundancy_vs([V|Vs]) :-
|
||||
( get_attr(V,itf,Att),
|
||||
arg(2,Att,type(Type)),
|
||||
arg(3,Att,strictness(Strict)),
|
||||
redundant(Type,V,Strict)
|
||||
-> redundancy_vs(Vs)
|
||||
; redundancy_vs(Vs)
|
||||
).
|
||||
|
||||
% redundant(Type,Var,Strict)
|
||||
%
|
||||
% Removes redundant bounds from variable Var with type Type and strictness Strict.
|
||||
% A redundant bound is one that is satisfied anyway (so adding the inverse of the bound
|
||||
% makes the system infeasible. This predicate can either fail or succeed but a success
|
||||
% doesn't necessarily mean a redundant bound.
|
||||
|
||||
redundant(t_l(L),X,Strict) :-
|
||||
get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
detach_bounds(CLP,X), % drop temporarily
|
||||
% if not redundant, backtracking will restore bound
|
||||
negate_l(Strict,CLP,L,X),
|
||||
red_t_l. % negate_l didn't fail, redundant bound
|
||||
redundant(t_u(U),X,Strict) :-
|
||||
get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
detach_bounds(CLP,X),
|
||||
negate_u(Strict,CLP,U,X),
|
||||
red_t_u.
|
||||
redundant(t_lu(L,U),X,Strict) :-
|
||||
strictness_parts(Strict,Sl,Su),
|
||||
( get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
setarg(2,Att,type(t_u(U))),
|
||||
setarg(3,Att,strictness(Su)),
|
||||
negate_l(Strict,CLP,L,X)
|
||||
-> red_t_l,
|
||||
( redundant(t_u(U),X,Strict)
|
||||
-> true
|
||||
; true
|
||||
)
|
||||
; get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
setarg(2,Att,type(t_l(L))),
|
||||
setarg(3,Att,strictness(Sl)),
|
||||
negate_u(Strict,CLP,U,X)
|
||||
-> red_t_u
|
||||
; true
|
||||
).
|
||||
redundant(t_L(L),X,Strict) :-
|
||||
get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
Bound is -L,
|
||||
intro_at(CLP,X,Bound,t_none), % drop temporarily
|
||||
detach_bounds(CLP,X),
|
||||
negate_l(Strict,CLP,L,X),
|
||||
red_t_L.
|
||||
redundant(t_U(U),X,Strict) :-
|
||||
get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
Bound is -U,
|
||||
intro_at(CLP,X,Bound,t_none), % drop temporarily
|
||||
detach_bounds(CLP,X),
|
||||
negate_u(Strict,CLP,U,X),
|
||||
red_t_U.
|
||||
redundant(t_Lu(L,U),X,Strict) :-
|
||||
strictness_parts(Strict,Sl,Su),
|
||||
( Bound is -L,
|
||||
get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
intro_at(CLP,X,Bound,t_u(U)),
|
||||
get_attr(X,itf,Att2), % changed?
|
||||
setarg(3,Att2,strictness(Su)),
|
||||
negate_l(Strict,CLP,L,X)
|
||||
-> red_t_l,
|
||||
( redundant(t_u(U),X,Strict)
|
||||
-> true
|
||||
; true
|
||||
)
|
||||
; get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
setarg(2,Att,type(t_L(L))),
|
||||
setarg(3,Att,strictness(Sl)),
|
||||
negate_u(Strict,CLP,U,X)
|
||||
-> red_t_u
|
||||
; true
|
||||
).
|
||||
redundant(t_lU(L,U),X,Strict) :-
|
||||
strictness_parts(Strict,Sl,Su),
|
||||
( get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
setarg(2,Att,type(t_U(U))),
|
||||
setarg(3,Att,strictness(Su)),
|
||||
negate_l(Strict,CLP,L,X)
|
||||
-> red_t_l,
|
||||
( redundant(t_U(U),X,Strict)
|
||||
-> true
|
||||
; true
|
||||
)
|
||||
; get_attr(X,itf,Att),
|
||||
arg(1,Att,CLP),
|
||||
Bound is -U,
|
||||
intro_at(CLP,X,Bound,t_l(L)),
|
||||
get_attr(X,itf,Att2), % changed?
|
||||
setarg(3,Att2,strictness(Sl)),
|
||||
negate_u(Strict,CLP,U,X)
|
||||
-> red_t_u
|
||||
; true
|
||||
).
|
||||
|
||||
% strictness_parts(Strict,Lower,Upper)
|
||||
%
|
||||
% Splits strictness Strict into two parts: one related to the lowerbound and
|
||||
% one related to the upperbound.
|
||||
|
||||
strictness_parts(Strict,Lower,Upper) :-
|
||||
Lower is Strict /\ 2,
|
||||
Upper is Strict /\ 1.
|
||||
|
||||
% negate_l(Strict,Lowerbound,X)
|
||||
%
|
||||
% Fails if X does not necessarily satisfy the lowerbound and strictness
|
||||
% In other words: if adding the inverse of the lowerbound (X < L or X =< L)
|
||||
% does not result in a failure, this predicate fails.
|
||||
|
||||
negate_l(0,CLP,L,X) :-
|
||||
CLP:{L > X},
|
||||
!,
|
||||
fail.
|
||||
negate_l(1,CLP,L,X) :-
|
||||
CLP:{L > X},
|
||||
!,
|
||||
fail.
|
||||
negate_l(2,CLP,L,X) :-
|
||||
CLP:{L >= X},
|
||||
!,
|
||||
fail.
|
||||
negate_l(3,CLP,L,X) :-
|
||||
CLP:{L >= X},
|
||||
!,
|
||||
fail.
|
||||
negate_l(_,_,_,_).
|
||||
|
||||
% negate_u(Strict,Upperbound,X)
|
||||
%
|
||||
% Fails if X does not necessarily satisfy the upperbound and strictness
|
||||
% In other words: if adding the inverse of the upperbound (X > U or X >= U)
|
||||
% does not result in a failure, this predicate fails.
|
||||
|
||||
negate_u(0,CLP,U,X) :-
|
||||
CLP:{U < X},
|
||||
!,
|
||||
fail.
|
||||
negate_u(1,CLP,U,X) :-
|
||||
CLP:{U =< X},
|
||||
!,
|
||||
fail.
|
||||
negate_u(2,CLP,U,X) :-
|
||||
CLP:{U < X},
|
||||
!,
|
||||
fail.
|
||||
negate_u(3,CLP,U,X) :-
|
||||
CLP:{U =< X},
|
||||
!,
|
||||
fail.
|
||||
negate_u(_,_,_,_).
|
||||
|
||||
% CLP(Q,R)
|
||||
|
||||
detach_bounds(clpq,X) :- bv_q:detach_bounds(X).
|
||||
detach_bounds(clpr,X) :- bv_r:detach_bounds(X).
|
||||
|
||||
intro_at(clpq,A,B,C) :- bv_q:intro_at(A,B,C).
|
||||
intro_at(clpr,A,B,C) :- bv_r:intro_at(A,B,C).
|
||||
|
||||
% Profiling: these predicates are called during redundant and can be used
|
||||
% to count the number of redundant bounds.
|
||||
|
||||
red_t_l.
|
||||
red_t_u.
|
||||
red_t_L.
|
||||
red_t_U.
|
|
@ -0,0 +1,204 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(R) (Constraint Logic Programming over Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2004, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is part of Leslie De Koninck's master thesis, supervised
|
||||
by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R)
|
||||
by Christian Holzbaur for SICStus Prolog and distributed under the
|
||||
license details below with permission from all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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.
|
||||
*/
|
||||
|
||||
|
||||
|
||||
/** @pred bb_inf(+ _Ints_,+ _Expression_,- _Inf_)
|
||||
The same as bb_inf/5 but without returning the values of the integers
|
||||
and with an eps of 0.001.
|
||||
|
||||
|
||||
*/
|
||||
/** @pred bb_inf(+ _Ints_,+ _Expression_,- _Inf_,- _Vertext_,+ _Eps_)
|
||||
Computes the infimum of _Expression_ within the current constraint
|
||||
store, with the additional constraint that in that infimum, all
|
||||
variables in _Ints_ have integral values. _Vertex_ will contain
|
||||
the values of _Ints_ in the infimum. _Eps_ denotes how much a
|
||||
value may differ from an integer to be considered an integer. E.g. when
|
||||
_Eps_ = 0.001, then X = 4.999 will be considered as an integer (5 in
|
||||
this case). _Eps_ should be between 0 and 0.5.
|
||||
|
||||
|
||||
*/
|
||||
/** @pred dump(+ _Target_,+ _Newvars_,- _CodedAnswer_)
|
||||
Returns the constraints on _Target_ in the list _CodedAnswer_
|
||||
where all variables of _Target_ have veen replaced by _NewVars_.
|
||||
This operation does not change the constraint store. E.g. in
|
||||
|
||||
~~~~~
|
||||
dump([X,Y,Z],[x,y,z],Cons)
|
||||
~~~~~
|
||||
|
||||
_Cons_ will contain the constraints on _X_, _Y_ and
|
||||
_Z_ where these variables have been replaced by atoms `x`, `y` and `z`.
|
||||
|
||||
|
||||
|
||||
|
||||
*/
|
||||
/** @pred entailed(+ _Constraint_)
|
||||
Succeeds if _Constraint_ is necessarily true within the current
|
||||
constraint store. This means that adding the negation of the constraint
|
||||
to the store results in failure.
|
||||
|
||||
|
||||
*/
|
||||
/** @pred inf(+ _Expression_,- _Inf_)
|
||||
Computes the infimum of _Expression_ within the current state of the
|
||||
constraint store and returns that infimum in _Inf_. This predicate
|
||||
does not change the constraint store.
|
||||
|
||||
|
||||
*/
|
||||
/** @pred inf(+ _Expression_,- _Sup_)
|
||||
Computes the supremum of _Expression_ within the current state of
|
||||
the constraint store and returns that supremum in _Sup_. This
|
||||
predicate does not change the constraint store.
|
||||
|
||||
|
||||
*/
|
||||
/** @pred maximize( _V_)
|
||||
maximise variable _V_
|
||||
|
||||
|
||||
*/
|
||||
/** @pred minimize(<tt>V</tt>)
|
||||
minimise variable _V_
|
||||
|
||||
|
||||
|
||||
|
||||
*/
|
||||
:- module(clpr,
|
||||
[
|
||||
{}/1,
|
||||
maximize/1,
|
||||
minimize/1,
|
||||
inf/2, inf/4, sup/2, sup/4,
|
||||
bb_inf/3,
|
||||
bb_inf/5,
|
||||
ordering/1,
|
||||
entailed/1,
|
||||
clp_type/2,
|
||||
dump/3%, projecting_assert/1
|
||||
]).
|
||||
|
||||
:- expects_dialect(swi).
|
||||
|
||||
%
|
||||
% Don't report export of private predicates from clpr
|
||||
%
|
||||
:- multifile
|
||||
user:portray_message/2.
|
||||
|
||||
:- dynamic
|
||||
user:portray_message/2.
|
||||
%
|
||||
user:portray_message(warning,import(_,_,clpr,private)).
|
||||
|
||||
:- load_files(
|
||||
[
|
||||
'clpr/bb_r',
|
||||
'clpr/bv_r',
|
||||
'clpr/fourmotz_r',
|
||||
'clpr/ineq_r',
|
||||
'clpr/itf_r',
|
||||
'clpr/nf_r',
|
||||
'clpr/store_r',
|
||||
'clpqr/class',
|
||||
'clpqr/dump',
|
||||
'clpqr/geler',
|
||||
'clpqr/itf',
|
||||
'clpqr/ordering',
|
||||
'clpqr/project',
|
||||
'clpqr/redund',
|
||||
library(ugraphs)
|
||||
],
|
||||
[
|
||||
if(not_loaded),
|
||||
silent(true)
|
||||
]).
|
||||
|
||||
/*******************************
|
||||
* TOPLEVEL PRINTING *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
% prolog:message(query(YesNo)) --> !,
|
||||
% ['~@'-[chr:print_all_stores]],
|
||||
% '$messages':prolog_message(query(YesNo)).
|
||||
|
||||
prolog:message(query(YesNo,Bindings)) --> !,
|
||||
{dump_toplevel_bindings(Bindings,Constraints)},
|
||||
{dump_format(Constraints,Format)},
|
||||
Format,
|
||||
'$messages':prolog_message(query(YesNo,Bindings)).
|
||||
|
||||
dump_toplevel_bindings(Bindings,Constraints) :-
|
||||
dump_vars_names(Bindings,[],Vars,Names),
|
||||
dump(Vars,Names,Constraints).
|
||||
|
||||
dump_vars_names([],_,[],[]).
|
||||
dump_vars_names([Name=Term|Rest],Seen,Vars,Names) :-
|
||||
( var(Term),
|
||||
( get_attr(Term,itf,_)
|
||||
; get_attr(Term,geler,_)
|
||||
),
|
||||
\+ memberchk_eq(Term,Seen)
|
||||
-> Vars = [Term|RVars],
|
||||
Names = [Name|RNames],
|
||||
NSeen = [Term|Seen]
|
||||
; Vars = RVars,
|
||||
Names = RNames,
|
||||
Seen = NSeen
|
||||
),
|
||||
dump_vars_names(Rest,NSeen,RVars,RNames).
|
||||
|
||||
dump_format([],[]).
|
||||
dump_format([X|Xs],['{~w}'-[X],nl|Rest]) :-
|
||||
dump_format(Xs,Rest).
|
||||
|
||||
memberchk_eq(X,[Y|Ys]) :-
|
||||
( X == Y
|
||||
-> true
|
||||
; memberchk_eq(X,Ys)
|
||||
).
|
|
@ -0,0 +1,260 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CPL(R) (Constraint Logic Programming over Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2004, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is part of Leslie De Koninck's master thesis, supervised
|
||||
by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R)
|
||||
by Christian Holzbaur for SICStus Prolog and distributed under the
|
||||
license details below with permission from all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(bb_r,
|
||||
[
|
||||
bb_inf/3,
|
||||
bb_inf/5,
|
||||
vertex_value/2
|
||||
]).
|
||||
:- use_module(bv_r,
|
||||
[
|
||||
deref/2,
|
||||
deref_var/2,
|
||||
determine_active_dec/1,
|
||||
inf/2,
|
||||
iterate_dec/2,
|
||||
sup/2,
|
||||
var_with_def_assign/2
|
||||
]).
|
||||
:- use_module(nf_r,
|
||||
[
|
||||
{}/1,
|
||||
entailed/1,
|
||||
nf/2,
|
||||
nf_constant/2,
|
||||
repair/2,
|
||||
wait_linear/3
|
||||
]).
|
||||
|
||||
% bb_inf(Ints,Term,Inf)
|
||||
%
|
||||
% Finds the infimum of Term where the variables Ints are to be integers.
|
||||
% The infimum is stored in Inf.
|
||||
|
||||
bb_inf(Is,Term,Inf) :-
|
||||
bb_inf(Is,Term,Inf,_,0.001).
|
||||
|
||||
bb_inf(Is,Term,Inf,Vertex,Eps) :-
|
||||
nf(Eps,ENf),
|
||||
nf_constant(ENf,EpsN),
|
||||
wait_linear(Term,Nf,bb_inf_internal(Is,Nf,EpsN,Inf,Vertex)).
|
||||
|
||||
% ---------------------------------------------------------------------
|
||||
|
||||
% bb_inf_internal(Is,Lin,Eps,Inf,Vertex)
|
||||
%
|
||||
% Finds an infimum Inf for linear expression in normal form Lin, where
|
||||
% all variables in Is are to be integers. Eps denotes the margin in which
|
||||
% we accept a number as an integer (to deal with rounding errors etc.).
|
||||
|
||||
bb_inf_internal(Is,Lin,Eps,_,_) :-
|
||||
bb_intern(Is,IsNf,Eps),
|
||||
nb_delete(prov_opt),
|
||||
repair(Lin,LinR), % bb_narrow ...
|
||||
deref(LinR,Lind),
|
||||
var_with_def_assign(Dep,Lind),
|
||||
determine_active_dec(Lind),
|
||||
bb_loop(Dep,IsNf,Eps),
|
||||
fail.
|
||||
bb_inf_internal(_,_,_,Inf,Vertex) :-
|
||||
catch(nb_getval(prov_opt,InfVal-Vertex),_,fail),
|
||||
{Inf =:= InfVal},
|
||||
nb_delete(prov_opt).
|
||||
|
||||
% bb_loop(Opt,Is,Eps)
|
||||
%
|
||||
% Minimizes the value of Opt where variables Is have to be integer values.
|
||||
% Eps denotes the rounding error that is acceptable. This predicate can be
|
||||
% backtracked to try different strategies.
|
||||
|
||||
bb_loop(Opt,Is,Eps) :-
|
||||
bb_reoptimize(Opt,Inf),
|
||||
bb_better_bound(Inf),
|
||||
vertex_value(Is,Ivs),
|
||||
( bb_first_nonint(Is,Ivs,Eps,Viol,Floor,Ceiling)
|
||||
-> bb_branch(Viol,Floor,Ceiling),
|
||||
bb_loop(Opt,Is,Eps)
|
||||
; round_values(Ivs,RoundVertex),
|
||||
nb_setval(prov_opt,Inf-RoundVertex) % new provisional optimum
|
||||
).
|
||||
|
||||
% bb_reoptimize(Obj,Inf)
|
||||
%
|
||||
% Minimizes the value of Obj and puts the result in Inf.
|
||||
% This new minimization is necessary as making a bound integer may yield a
|
||||
% different optimum. The added inequalities may also have led to binding.
|
||||
|
||||
bb_reoptimize(Obj,Inf) :-
|
||||
var(Obj),
|
||||
iterate_dec(Obj,Inf).
|
||||
bb_reoptimize(Obj,Inf) :-
|
||||
nonvar(Obj),
|
||||
Inf = Obj.
|
||||
|
||||
% bb_better_bound(Inf)
|
||||
%
|
||||
% Checks if the new infimum Inf is better than the previous one (if such exists).
|
||||
|
||||
bb_better_bound(Inf) :-
|
||||
catch((nb_getval(prov_opt,Inc-_),Inf - Inc < -1.0e-10),_,true).
|
||||
|
||||
% bb_branch(V,U,L)
|
||||
%
|
||||
% Stores that V =< U or V >= L, can be used for different strategies within bb_loop/3.
|
||||
|
||||
bb_branch(V,U,_) :- {V =< U}.
|
||||
bb_branch(V,_,L) :- {V >= L}.
|
||||
|
||||
% vertex_value(Vars,Values)
|
||||
%
|
||||
% Returns in <Values> the current values of the variables in <Vars>.
|
||||
|
||||
vertex_value([],[]).
|
||||
vertex_value([X|Xs],[V|Vs]) :-
|
||||
rhs_value(X,V),
|
||||
vertex_value(Xs,Vs).
|
||||
|
||||
% rhs_value(X,Value)
|
||||
%
|
||||
% Returns in <Value> the current value of variable <X>.
|
||||
|
||||
rhs_value(Xn,Value) :-
|
||||
( nonvar(Xn)
|
||||
-> Value = Xn
|
||||
; var(Xn)
|
||||
-> deref_var(Xn,Xd),
|
||||
Xd = [I,R|_],
|
||||
Value is R+I
|
||||
).
|
||||
|
||||
% bb_first_nonint(Ints,Rhss,Eps,Viol,Floor,Ceiling)
|
||||
%
|
||||
% Finds the first variable in Ints which doesn't have an active integer bound.
|
||||
% Rhss contain the Rhs (R + I) values corresponding to the variables.
|
||||
% The first variable that hasn't got an active integer bound, is returned in
|
||||
% Viol. The floor and ceiling of its actual bound is returned in Floor and Ceiling.
|
||||
|
||||
bb_first_nonint([I|Is],[Rhs|Rhss],Eps,Viol,F,C) :-
|
||||
( Floor is floor(Rhs+1.0e-10),
|
||||
Ceiling is ceiling(Rhs-1.0e-10),
|
||||
Eps - min(Rhs-Floor,Ceiling-Rhs) < -1.0e-10
|
||||
-> Viol = I,
|
||||
F = Floor,
|
||||
C = Ceiling
|
||||
; bb_first_nonint(Is,Rhss,Eps,Viol,F,C)
|
||||
).
|
||||
|
||||
% round_values([X|Xs],[Xr|Xrs])
|
||||
%
|
||||
% Rounds of the values of the first list into the second list.
|
||||
|
||||
round_values([],[]).
|
||||
round_values([X|Xs],[Y|Ys]) :-
|
||||
Y is round(X),
|
||||
round_values(Xs,Ys).
|
||||
|
||||
% bb_intern([X|Xs],[Xi|Xis],Eps)
|
||||
%
|
||||
% Turns the elements of the first list into integers into the second
|
||||
% list via bb_intern/4.
|
||||
|
||||
bb_intern([],[],_).
|
||||
bb_intern([X|Xs],[Xi|Xis],Eps) :-
|
||||
nf(X,Xnf),
|
||||
bb_intern(Xnf,Xi,X,Eps),
|
||||
bb_intern(Xs,Xis,Eps).
|
||||
|
||||
|
||||
% bb_intern(Nf,X,Term,Eps)
|
||||
%
|
||||
% Makes sure that Term which is normalized into Nf, is integer.
|
||||
% X contains the possibly changed Term. If Term is a variable,
|
||||
% then its bounds are hightened or lowered to the next integer.
|
||||
% Otherwise, it is checked it Term is integer.
|
||||
|
||||
bb_intern([],X,_,_) :-
|
||||
!,
|
||||
X = 0.0.
|
||||
bb_intern([v(I,[])],X,_,Eps) :-
|
||||
!,
|
||||
X = I,
|
||||
min(I-floor(I+1e-010),ceiling(I-1e-010)-I) - Eps < 1e-010.
|
||||
bb_intern([v(One,[V^1])],X,_,_) :-
|
||||
Test is One - 1.0,
|
||||
Test =< 1e-010,
|
||||
Test >= -1e-010,
|
||||
!,
|
||||
V = X,
|
||||
bb_narrow_lower(X),
|
||||
bb_narrow_upper(X).
|
||||
bb_intern(_,_,Term,_) :-
|
||||
throw(instantiation_error(bb_inf(Term,_,_),1)).
|
||||
|
||||
% bb_narrow_lower(X)
|
||||
%
|
||||
% Narrows the lower bound so that it is an integer bound.
|
||||
% We do this by finding the infimum of X and asserting that X
|
||||
% is larger than the first integer larger or equal to the infimum
|
||||
% (second integer if X is to be strict larger than the first integer).
|
||||
|
||||
bb_narrow_lower(X) :-
|
||||
( inf(X,Inf)
|
||||
-> Bound is ceiling(Inf-1.0e-10),
|
||||
( entailed(X > Bound)
|
||||
-> {X >= Bound+1}
|
||||
; {X >= Bound}
|
||||
)
|
||||
; true
|
||||
).
|
||||
|
||||
% bb_narrow_upper(X)
|
||||
%
|
||||
% See bb_narrow_lower/1. This predicate handles the upper bound.
|
||||
|
||||
bb_narrow_upper(X) :-
|
||||
( sup(X,Sup)
|
||||
-> Bound is floor(Sup+1.0e-10),
|
||||
( entailed(X < Bound)
|
||||
-> {X =< Bound-1}
|
||||
; {X =< Bound}
|
||||
)
|
||||
; true
|
||||
).
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,504 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(R) (Constraint Logic Programming over Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2004, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is part of Leslie De Koninck's master thesis, supervised
|
||||
by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R)
|
||||
by Christian Holzbaur for SICStus Prolog and distributed under the
|
||||
license details below with permission from all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(fourmotz_r,
|
||||
[
|
||||
fm_elim/3
|
||||
]).
|
||||
:- use_module(bv_r,
|
||||
[
|
||||
allvars/2,
|
||||
basis_add/2,
|
||||
detach_bounds/1,
|
||||
pivot/5,
|
||||
var_with_def_intern/4
|
||||
]).
|
||||
:- use_module('../clpqr/class',
|
||||
[
|
||||
class_allvars/2
|
||||
]).
|
||||
:- use_module('../clpqr/project',
|
||||
[
|
||||
drop_dep/1,
|
||||
drop_dep_one/1,
|
||||
make_target_indep/2
|
||||
]).
|
||||
:- use_module('../clpqr/redund',
|
||||
[
|
||||
redundancy_vars/1
|
||||
]).
|
||||
:- use_module(store_r,
|
||||
[
|
||||
add_linear_11/3,
|
||||
add_linear_f1/4,
|
||||
indep/2,
|
||||
nf_coeff_of/3,
|
||||
normalize_scalar/2
|
||||
]).
|
||||
|
||||
|
||||
|
||||
fm_elim(Vs,Target,Pivots) :-
|
||||
prefilter(Vs,Vsf),
|
||||
fm_elim_int(Vsf,Target,Pivots).
|
||||
|
||||
% prefilter(Vars,Res)
|
||||
%
|
||||
% filters out target variables and variables that do not occur in bounded linear equations.
|
||||
% Stores that the variables in Res are to be kept independent.
|
||||
|
||||
prefilter([],[]).
|
||||
prefilter([V|Vs],Res) :-
|
||||
( get_attr(V,itf,Att),
|
||||
arg(9,Att,n),
|
||||
occurs(V) % V is a nontarget variable that occurs in a bounded linear equation
|
||||
-> Res = [V|Tail],
|
||||
setarg(10,Att,keep_indep),
|
||||
prefilter(Vs,Tail)
|
||||
; prefilter(Vs,Res)
|
||||
).
|
||||
|
||||
%
|
||||
% the target variables are marked with an attribute, and we get a list
|
||||
% of them as an argument too
|
||||
%
|
||||
fm_elim_int([],_,Pivots) :- % done
|
||||
unkeep(Pivots).
|
||||
fm_elim_int(Vs,Target,Pivots) :-
|
||||
Vs = [_|_],
|
||||
( best(Vs,Best,Rest)
|
||||
-> occurences(Best,Occ),
|
||||
elim_min(Best,Occ,Target,Pivots,NewPivots)
|
||||
; % give up
|
||||
NewPivots = Pivots,
|
||||
Rest = []
|
||||
),
|
||||
fm_elim_int(Rest,Target,NewPivots).
|
||||
|
||||
% best(Vs,Best,Rest)
|
||||
%
|
||||
% Finds the variable with the best result (lowest Delta) in fm_cp_filter
|
||||
% and returns the other variables in Rest.
|
||||
|
||||
best(Vs,Best,Rest) :-
|
||||
findall(Delta-N,fm_cp_filter(Vs,Delta,N),Deltas),
|
||||
keysort(Deltas,[_-N|_]),
|
||||
select_nth(Vs,N,Best,Rest).
|
||||
|
||||
% fm_cp_filter(Vs,Delta,N)
|
||||
%
|
||||
% For an indepenent variable V in Vs, which is the N'th element in Vs,
|
||||
% find how many inequalities are generated when this variable is eliminated.
|
||||
% Note that target variables and variables that only occur in unbounded equations
|
||||
% should have been removed from Vs via prefilter/2
|
||||
|
||||
fm_cp_filter(Vs,Delta,N) :-
|
||||
length(Vs,Len), % Len = number of variables in Vs
|
||||
mem(Vs,X,Vst), % Selects a variable X in Vs, Vst is the list of elements after X in Vs
|
||||
get_attr(X,itf,Att),
|
||||
arg(4,Att,lin(Lin)),
|
||||
arg(5,Att,order(OrdX)),
|
||||
arg(9,Att,n), % no target variable
|
||||
indep(Lin,OrdX), % X is an independent variable
|
||||
occurences(X,Occ),
|
||||
Occ = [_|_],
|
||||
cp_card(Occ,0,Lnew),
|
||||
length(Occ,Locc),
|
||||
Delta is Lnew-Locc,
|
||||
length(Vst,Vstl),
|
||||
N is Len-Vstl. % X is the Nth element in Vs
|
||||
|
||||
% mem(Xs,X,XsT)
|
||||
%
|
||||
% If X is a member of Xs, XsT is the list of elements after X in Xs.
|
||||
|
||||
mem([X|Xs],X,Xs).
|
||||
mem([_|Ys],X,Xs) :- mem(Ys,X,Xs).
|
||||
|
||||
% select_nth(List,N,Nth,Others)
|
||||
%
|
||||
% Selects the N th element of List, stores it in Nth and returns the rest of the list in Others.
|
||||
|
||||
select_nth(List,N,Nth,Others) :-
|
||||
select_nth(List,1,N,Nth,Others).
|
||||
|
||||
select_nth([X|Xs],N,N,X,Xs) :- !.
|
||||
select_nth([Y|Ys],M,N,X,[Y|Xs]) :-
|
||||
M1 is M+1,
|
||||
select_nth(Ys,M1,N,X,Xs).
|
||||
|
||||
%
|
||||
% fm_detach + reverse_pivot introduce indep t_none, which
|
||||
% invalidates the invariants
|
||||
%
|
||||
elim_min(V,Occ,Target,Pivots,NewPivots) :-
|
||||
crossproduct(Occ,New,[]),
|
||||
activate_crossproduct(New),
|
||||
reverse_pivot(Pivots),
|
||||
fm_detach(Occ),
|
||||
allvars(V,All),
|
||||
redundancy_vars(All), % only for New \== []
|
||||
make_target_indep(Target,NewPivots),
|
||||
drop_dep(All).
|
||||
|
||||
%
|
||||
% restore NF by reverse pivoting
|
||||
%
|
||||
reverse_pivot([]).
|
||||
reverse_pivot([I:D|Ps]) :-
|
||||
get_attr(D,itf,AttD),
|
||||
arg(2,AttD,type(Dt)),
|
||||
setarg(11,AttD,n), % no longer
|
||||
get_attr(I,itf,AttI),
|
||||
arg(2,AttI,type(It)),
|
||||
arg(5,AttI,order(OrdI)),
|
||||
arg(6,AttI,class(ClI)),
|
||||
pivot(D,ClI,OrdI,Dt,It),
|
||||
reverse_pivot(Ps).
|
||||
|
||||
% unkeep(Pivots)
|
||||
%
|
||||
%
|
||||
|
||||
unkeep([]).
|
||||
unkeep([_:D|Ps]) :-
|
||||
get_attr(D,itf,Att),
|
||||
setarg(11,Att,n),
|
||||
drop_dep_one(D),
|
||||
unkeep(Ps).
|
||||
|
||||
|
||||
%
|
||||
% All we drop are bounds
|
||||
%
|
||||
fm_detach( []).
|
||||
fm_detach([V:_|Vs]) :-
|
||||
detach_bounds(V),
|
||||
fm_detach(Vs).
|
||||
|
||||
% activate_crossproduct(Lst)
|
||||
%
|
||||
% For each inequality Lin =< 0 (or Lin < 0) in Lst, a new variable is created:
|
||||
% Var = Lin and Var =< 0 (or Var < 0). Var is added to the basis.
|
||||
|
||||
activate_crossproduct([]).
|
||||
activate_crossproduct([lez(Strict,Lin)|News]) :-
|
||||
var_with_def_intern(t_u(0.0),Var,Lin,Strict),
|
||||
% Var belongs to same class as elements in Lin
|
||||
basis_add(Var,_),
|
||||
activate_crossproduct(News).
|
||||
|
||||
% ------------------------------------------------------------------------------
|
||||
|
||||
% crossproduct(Lst,Res,ResTail)
|
||||
%
|
||||
% See crossproduct/4
|
||||
% This predicate each time puts the next element of Lst as First in crossproduct/4
|
||||
% and lets the rest be Next.
|
||||
|
||||
crossproduct([]) --> [].
|
||||
crossproduct([A|As]) -->
|
||||
crossproduct(As,A),
|
||||
crossproduct(As).
|
||||
|
||||
% crossproduct(Next,First,Res,ResTail)
|
||||
%
|
||||
% Eliminates a variable in linear equations First + Next and stores the generated
|
||||
% inequalities in Res.
|
||||
% Let's say A:K1 = First and B:K2 = first equation in Next.
|
||||
% A = ... + K1*V + ...
|
||||
% B = ... + K2*V + ...
|
||||
% Let K = -K2/K1
|
||||
% then K*A + B = ... + 0*V + ...
|
||||
% from the bounds of A and B, via cross_lower/7 and cross_upper/7, new inequalities
|
||||
% are generated. Then the same is done for B:K2 = next element in Next.
|
||||
|
||||
crossproduct([],_) --> [].
|
||||
crossproduct([B:Kb|Bs],A:Ka) -->
|
||||
{
|
||||
get_attr(A,itf,AttA),
|
||||
arg(2,AttA,type(Ta)),
|
||||
arg(3,AttA,strictness(Sa)),
|
||||
arg(4,AttA,lin(LinA)),
|
||||
get_attr(B,itf,AttB),
|
||||
arg(2,AttB,type(Tb)),
|
||||
arg(3,AttB,strictness(Sb)),
|
||||
arg(4,AttB,lin(LinB)),
|
||||
K is -Kb/Ka,
|
||||
add_linear_f1(LinA,K,LinB,Lin) % Lin doesn't contain the target variable anymore
|
||||
},
|
||||
( { K > 1.0e-10 } % K > 0: signs were opposite
|
||||
-> { Strict is Sa \/ Sb },
|
||||
cross_lower(Ta,Tb,K,Lin,Strict),
|
||||
cross_upper(Ta,Tb,K,Lin,Strict)
|
||||
; % La =< A =< Ua -> -Ua =< -A =< -La
|
||||
{
|
||||
flip(Ta,Taf),
|
||||
flip_strict(Sa,Saf),
|
||||
Strict is Saf \/ Sb
|
||||
},
|
||||
cross_lower(Taf,Tb,K,Lin,Strict),
|
||||
cross_upper(Taf,Tb,K,Lin,Strict)
|
||||
),
|
||||
crossproduct(Bs,A:Ka).
|
||||
|
||||
% cross_lower(Ta,Tb,K,Lin,Strict,Res,ResTail)
|
||||
%
|
||||
% Generates a constraint following from the bounds of A and B.
|
||||
% When A = LinA and B = LinB then Lin = K*LinA + LinB. Ta is the type
|
||||
% of A and Tb is the type of B. Strict is the union of the strictness
|
||||
% of A and B. If K is negative, then Ta should have been flipped (flip/2).
|
||||
% The idea is that if La =< A =< Ua and Lb =< B =< Ub (=< can also be <)
|
||||
% then if K is positive, K*La + Lb =< K*A + B =< K*Ua + Ub.
|
||||
% if K is negative, K*Ua + Lb =< K*A + B =< K*La + Ub.
|
||||
% This predicate handles the first inequality and adds it to Res in the form
|
||||
% lez(Sl,Lhs) meaning K*La + Lb - (K*A + B) =< 0 or K*Ua + Lb - (K*A + B) =< 0
|
||||
% with Sl being the strictness and Lhs the lefthandside of the equation.
|
||||
% See also cross_upper/7
|
||||
|
||||
cross_lower(Ta,Tb,K,Lin,Strict) -->
|
||||
{
|
||||
lower(Ta,La),
|
||||
lower(Tb,Lb),
|
||||
!,
|
||||
L is K*La+Lb,
|
||||
normalize_scalar(L,Ln),
|
||||
add_linear_f1(Lin,-1.0,Ln,Lhs),
|
||||
Sl is Strict >> 1 % normalize to upper bound
|
||||
},
|
||||
[ lez(Sl,Lhs) ].
|
||||
cross_lower(_,_,_,_,_) --> [].
|
||||
|
||||
% cross_upper(Ta,Tb,K,Lin,Strict,Res,ResTail)
|
||||
%
|
||||
% See cross_lower/7
|
||||
% This predicate handles the second inequality:
|
||||
% -(K*Ua + Ub) + K*A + B =< 0 or -(K*La + Ub) + K*A + B =< 0
|
||||
|
||||
cross_upper(Ta,Tb,K,Lin,Strict) -->
|
||||
{
|
||||
upper(Ta,Ua),
|
||||
upper(Tb,Ub),
|
||||
!,
|
||||
U is -(K*Ua+Ub),
|
||||
normalize_scalar(U,Un),
|
||||
add_linear_11(Un,Lin,Lhs),
|
||||
Su is Strict /\ 1 % normalize to upper bound
|
||||
},
|
||||
[ lez(Su,Lhs) ].
|
||||
cross_upper(_,_,_,_,_) --> [].
|
||||
|
||||
% lower(Type,Lowerbound)
|
||||
%
|
||||
% Returns the lowerbound of type Type if it has one.
|
||||
% E.g. if type = t_l(L) then Lowerbound is L,
|
||||
% if type = t_lU(L,U) then Lowerbound is L,
|
||||
% if type = t_u(U) then fails
|
||||
|
||||
lower(t_l(L),L).
|
||||
lower(t_lu(L,_),L).
|
||||
lower(t_L(L),L).
|
||||
lower(t_Lu(L,_),L).
|
||||
lower(t_lU(L,_),L).
|
||||
|
||||
% upper(Type,Upperbound)
|
||||
%
|
||||
% Returns the upperbound of type Type if it has one.
|
||||
% See lower/2
|
||||
|
||||
upper(t_u(U),U).
|
||||
upper(t_lu(_,U),U).
|
||||
upper(t_U(U),U).
|
||||
upper(t_Lu(_,U),U).
|
||||
upper(t_lU(_,U),U).
|
||||
|
||||
% flip(Type,FlippedType)
|
||||
%
|
||||
% Flips the lower and upperbound, so the old lowerbound becomes the new upperbound and
|
||||
% vice versa.
|
||||
|
||||
flip(t_l(X),t_u(X)).
|
||||
flip(t_u(X),t_l(X)).
|
||||
flip(t_lu(X,Y),t_lu(Y,X)).
|
||||
flip(t_L(X),t_u(X)).
|
||||
flip(t_U(X),t_l(X)).
|
||||
flip(t_lU(X,Y),t_lu(Y,X)).
|
||||
flip(t_Lu(X,Y),t_lu(Y,X)).
|
||||
|
||||
% flip_strict(Strict,FlippedStrict)
|
||||
%
|
||||
% Does what flip/2 does, but for the strictness.
|
||||
|
||||
flip_strict(0,0).
|
||||
flip_strict(1,2).
|
||||
flip_strict(2,1).
|
||||
flip_strict(3,3).
|
||||
|
||||
% cp_card(Lst,CountIn,CountOut)
|
||||
%
|
||||
% Counts the number of bounds that may generate an inequality in
|
||||
% crossproduct/3
|
||||
|
||||
cp_card([],Ci,Ci).
|
||||
cp_card([A|As],Ci,Co) :-
|
||||
cp_card(As,A,Ci,Cii),
|
||||
cp_card(As,Cii,Co).
|
||||
|
||||
% cp_card(Next,First,CountIn,CountOut)
|
||||
%
|
||||
% Counts the number of bounds that may generate an inequality in
|
||||
% crossproduct/4.
|
||||
|
||||
cp_card([],_,Ci,Ci).
|
||||
cp_card([B:Kb|Bs],A:Ka,Ci,Co) :-
|
||||
get_attr(A,itf,AttA),
|
||||
arg(2,AttA,type(Ta)),
|
||||
get_attr(B,itf,AttB),
|
||||
arg(2,AttB,type(Tb)),
|
||||
K is -Kb/Ka,
|
||||
( K > 1.0e-10 % K > 0: signs were opposite
|
||||
-> cp_card_lower(Ta,Tb,Ci,Cii),
|
||||
cp_card_upper(Ta,Tb,Cii,Ciii)
|
||||
; flip(Ta,Taf),
|
||||
cp_card_lower(Taf,Tb,Ci,Cii),
|
||||
cp_card_upper(Taf,Tb,Cii,Ciii)
|
||||
),
|
||||
cp_card(Bs,A:Ka,Ciii,Co).
|
||||
|
||||
% cp_card_lower(TypeA,TypeB,SIn,SOut)
|
||||
%
|
||||
% SOut = SIn + 1 if both TypeA and TypeB have a lowerbound.
|
||||
|
||||
cp_card_lower(Ta,Tb,Si,So) :-
|
||||
lower(Ta,_),
|
||||
lower(Tb,_),
|
||||
!,
|
||||
So is Si+1.
|
||||
cp_card_lower(_,_,Si,Si).
|
||||
|
||||
% cp_card_upper(TypeA,TypeB,SIn,SOut)
|
||||
%
|
||||
% SOut = SIn + 1 if both TypeA and TypeB have an upperbound.
|
||||
|
||||
cp_card_upper(Ta,Tb,Si,So) :-
|
||||
upper(Ta,_),
|
||||
upper(Tb,_),
|
||||
!,
|
||||
So is Si+1.
|
||||
cp_card_upper(_,_,Si,Si).
|
||||
|
||||
% ------------------------------------------------------------------------------
|
||||
|
||||
% occurences(V,Occ)
|
||||
%
|
||||
% Returns in Occ the occurrences of variable V in the linear equations of dependent variables
|
||||
% with bound =\= t_none in the form of D:K where D is a dependent variable and K is the scalar
|
||||
% of V in the linear equation of D.
|
||||
|
||||
occurences(V,Occ) :-
|
||||
get_attr(V,itf,Att),
|
||||
arg(5,Att,order(OrdV)),
|
||||
arg(6,Att,class(C)),
|
||||
class_allvars(C,All),
|
||||
occurences(All,OrdV,Occ).
|
||||
|
||||
% occurences(De,OrdV,Occ)
|
||||
%
|
||||
% Returns in Occ the occurrences of variable V with order OrdV in the linear equations of
|
||||
% dependent variables De with bound =\= t_none in the form of D:K where D is a dependent
|
||||
% variable and K is the scalar of V in the linear equation of D.
|
||||
|
||||
occurences(De,_,[]) :-
|
||||
var(De),
|
||||
!.
|
||||
occurences([D|De],OrdV,Occ) :-
|
||||
( get_attr(D,itf,Att),
|
||||
arg(2,Att,type(Type)),
|
||||
arg(4,Att,lin(Lin)),
|
||||
occ_type_filter(Type),
|
||||
nf_coeff_of(Lin,OrdV,K)
|
||||
-> Occ = [D:K|Occt],
|
||||
occurences(De,OrdV,Occt)
|
||||
; occurences(De,OrdV,Occ)
|
||||
).
|
||||
|
||||
% occ_type_filter(Type)
|
||||
%
|
||||
% Succeeds when Type is any other type than t_none. Is used in occurences/3 and occurs/2
|
||||
|
||||
occ_type_filter(t_l(_)).
|
||||
occ_type_filter(t_u(_)).
|
||||
occ_type_filter(t_lu(_,_)).
|
||||
occ_type_filter(t_L(_)).
|
||||
occ_type_filter(t_U(_)).
|
||||
occ_type_filter(t_lU(_,_)).
|
||||
occ_type_filter(t_Lu(_,_)).
|
||||
|
||||
% occurs(V)
|
||||
%
|
||||
% Checks whether variable V occurs in a linear equation of a dependent variable with a bound
|
||||
% =\= t_none.
|
||||
|
||||
occurs(V) :-
|
||||
get_attr(V,itf,Att),
|
||||
arg(5,Att,order(OrdV)),
|
||||
arg(6,Att,class(C)),
|
||||
class_allvars(C,All),
|
||||
occurs(All,OrdV).
|
||||
|
||||
% occurs(De,OrdV)
|
||||
%
|
||||
% Checks whether variable V with order OrdV occurs in a linear equation of any dependent variable
|
||||
% in De with a bound =\= t_none.
|
||||
|
||||
occurs(De,_) :-
|
||||
var(De),
|
||||
!,
|
||||
fail.
|
||||
occurs([D|De],OrdV) :-
|
||||
( get_attr(D,itf,Att),
|
||||
arg(2,Att,type(Type)),
|
||||
arg(4,Att,lin(Lin)),
|
||||
occ_type_filter(Type),
|
||||
nf_coeff_of(Lin,OrdV,_)
|
||||
-> true
|
||||
; occurs(De,OrdV)
|
||||
).
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,227 @@
|
|||
/*
|
||||
|
||||
Part of CLP(R) (Constraint Logic Programming over Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2004, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is part of Leslie De Koninck's master thesis, supervised
|
||||
by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R)
|
||||
by Christian Holzbaur for SICStus Prolog and distributed under the
|
||||
license details below with permission from all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(itf_r,
|
||||
[
|
||||
do_checks/8
|
||||
]).
|
||||
:- use_module(bv_r,
|
||||
[
|
||||
deref/2,
|
||||
detach_bounds_vlv/5,
|
||||
solve/1,
|
||||
solve_ord_x/3
|
||||
]).
|
||||
:- use_module(nf_r,
|
||||
[
|
||||
nf/2
|
||||
]).
|
||||
:- use_module(store_r,
|
||||
[
|
||||
add_linear_11/3,
|
||||
indep/2,
|
||||
nf_coeff_of/3
|
||||
]).
|
||||
:- use_module('../clpqr/class',
|
||||
[
|
||||
class_drop/2
|
||||
]).
|
||||
|
||||
do_checks(Y,Ty,St,Li,Or,Cl,No,Later) :-
|
||||
numbers_only(Y),
|
||||
verify_nonzero(No,Y),
|
||||
verify_type(Ty,St,Y,Later,[]),
|
||||
verify_lin(Or,Cl,Li,Y),
|
||||
maplist(call,Later).
|
||||
|
||||
numbers_only(Y) :-
|
||||
( var(Y)
|
||||
; integer(Y)
|
||||
; float(Y)
|
||||
; throw(type_error(_X = Y,2,'a real number',Y))
|
||||
),
|
||||
!.
|
||||
|
||||
% verify_nonzero(Nonzero,Y)
|
||||
%
|
||||
% if Nonzero = nonzero, then verify that Y is not zero
|
||||
% (if possible, otherwise set Y to be nonzero)
|
||||
|
||||
verify_nonzero(nonzero,Y) :-
|
||||
( var(Y)
|
||||
-> ( get_attr(Y,itf,Att)
|
||||
-> setarg(8,Att,nonzero)
|
||||
; put_attr(Y,itf,t(clpr,n,n,n,n,n,n,nonzero,n,n,n))
|
||||
)
|
||||
; ( Y < -1.0e-10
|
||||
-> true
|
||||
; Y > 1.0e-10
|
||||
)
|
||||
).
|
||||
verify_nonzero(n,_). % X is not nonzero
|
||||
|
||||
% verify_type(type(Type),strictness(Strict),Y,[OL|OLT],OLT)
|
||||
%
|
||||
% if possible verifies whether Y satisfies the type and strictness of X
|
||||
% if not possible to verify, then returns the constraints that follow from
|
||||
% the type and strictness
|
||||
|
||||
verify_type(type(Type),strictness(Strict),Y) -->
|
||||
verify_type2(Y,Type,Strict).
|
||||
verify_type(n,n,_) --> [].
|
||||
|
||||
verify_type2(Y,TypeX,StrictX) -->
|
||||
{var(Y)},
|
||||
!,
|
||||
verify_type_var(TypeX,Y,StrictX).
|
||||
verify_type2(Y,TypeX,StrictX) -->
|
||||
{verify_type_nonvar(TypeX,Y,StrictX)}.
|
||||
|
||||
% verify_type_nonvar(Type,Nonvar,Strictness)
|
||||
%
|
||||
% verifies whether the type and strictness are satisfied with the Nonvar
|
||||
|
||||
verify_type_nonvar(t_none,_,_).
|
||||
verify_type_nonvar(t_l(L),Value,S) :- ilb(S,L,Value).
|
||||
verify_type_nonvar(t_u(U),Value,S) :- iub(S,U,Value).
|
||||
verify_type_nonvar(t_lu(L,U),Value,S) :-
|
||||
ilb(S,L,Value),
|
||||
iub(S,U,Value).
|
||||
verify_type_nonvar(t_L(L),Value,S) :- ilb(S,L,Value).
|
||||
verify_type_nonvar(t_U(U),Value,S) :- iub(S,U,Value).
|
||||
verify_type_nonvar(t_Lu(L,U),Value,S) :-
|
||||
ilb(S,L,Value),
|
||||
iub(S,U,Value).
|
||||
verify_type_nonvar(t_lU(L,U),Value,S) :-
|
||||
ilb(S,L,Value),
|
||||
iub(S,U,Value).
|
||||
|
||||
% ilb(Strict,Lower,Value) & iub(Strict,Upper,Value)
|
||||
%
|
||||
% check whether Value is satisfiable with the given lower/upper bound and
|
||||
% strictness.
|
||||
% strictness is encoded as follows:
|
||||
% 2 = strict lower bound
|
||||
% 1 = strict upper bound
|
||||
% 3 = strict lower and upper bound
|
||||
% 0 = no strict bounds
|
||||
|
||||
ilb(S,L,V) :-
|
||||
S /\ 2 =:= 0,
|
||||
!,
|
||||
L - V < 1.0e-10. % non-strict
|
||||
ilb(_,L,V) :- L - V < -1.0e-10. % strict
|
||||
|
||||
iub(S,U,V) :-
|
||||
S /\ 1 =:= 0,
|
||||
!,
|
||||
V - U < 1.0e-10. % non-strict
|
||||
iub(_,U,V) :- V - U < -1.0e-10. % strict
|
||||
|
||||
%
|
||||
% Running some goals after X=Y simplifies the coding. It should be possible
|
||||
% to run the goals here and taking care not to put_atts/2 on X ...
|
||||
%
|
||||
|
||||
% verify_type_var(Type,Var,Strictness,[OutList|OutListTail],OutListTail)
|
||||
%
|
||||
% returns the inequalities following from a type and strictness satisfaction
|
||||
% test with Var
|
||||
|
||||
verify_type_var(t_none,_,_) --> [].
|
||||
verify_type_var(t_l(L),Y,S) --> llb(S,L,Y).
|
||||
verify_type_var(t_u(U),Y,S) --> lub(S,U,Y).
|
||||
verify_type_var(t_lu(L,U),Y,S) -->
|
||||
llb(S,L,Y),
|
||||
lub(S,U,Y).
|
||||
verify_type_var(t_L(L),Y,S) --> llb(S,L,Y).
|
||||
verify_type_var(t_U(U),Y,S) --> lub(S,U,Y).
|
||||
verify_type_var(t_Lu(L,U),Y,S) -->
|
||||
llb(S,L,Y),
|
||||
lub(S,U,Y).
|
||||
verify_type_var(t_lU(L,U),Y,S) -->
|
||||
llb(S,L,Y),
|
||||
lub(S,U,Y).
|
||||
|
||||
% llb(Strict,Lower,Value,[OL|OLT],OLT) and lub(Strict,Upper,Value,[OL|OLT],OLT)
|
||||
%
|
||||
% returns the inequalities following from the lower and upper bounds and the
|
||||
% strictness see also lb and ub
|
||||
llb(S,L,V) -->
|
||||
{S /\ 2 =:= 0},
|
||||
!,
|
||||
[clpr:{L =< V}].
|
||||
llb(_,L,V) --> [clpr:{L < V}].
|
||||
|
||||
lub(S,U,V) -->
|
||||
{S /\ 1 =:= 0},
|
||||
!,
|
||||
[clpr:{V =< U}].
|
||||
lub(_,U,V) --> [clpr:{V < U}].
|
||||
|
||||
%
|
||||
% We used to drop X from the class/basis to avoid trouble with subsequent
|
||||
% put_atts/2 on X. Now we could let these dead but harmless updates happen.
|
||||
% In R however, exported bindings might conflict, e.g. 0 \== 0.0
|
||||
%
|
||||
% If X is indep and we do _not_ solve for it, we are in deep shit
|
||||
% because the ordering is violated.
|
||||
%
|
||||
verify_lin(order(OrdX),class(Class),lin(LinX),Y) :-
|
||||
!,
|
||||
( indep(LinX,OrdX)
|
||||
-> detach_bounds_vlv(OrdX,LinX,Class,Y,NewLinX),
|
||||
% if there were bounds, they are requeued already
|
||||
class_drop(Class,Y),
|
||||
nf(-Y,NfY),
|
||||
deref(NfY,LinY),
|
||||
add_linear_11(NewLinX,LinY,Lind),
|
||||
( nf_coeff_of(Lind,OrdX,_)
|
||||
-> % X is element of Lind
|
||||
solve_ord_x(Lind,OrdX,Class)
|
||||
; solve(Lind) % X is gone, can safely solve Lind
|
||||
)
|
||||
; class_drop(Class,Y),
|
||||
nf(-Y,NfY),
|
||||
deref(NfY,LinY),
|
||||
add_linear_11(LinX,LinY,Lind),
|
||||
solve(Lind)
|
||||
).
|
||||
verify_lin(_,_,_,_).
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,427 @@
|
|||
/* $Id$
|
||||
|
||||
Part of CLP(R) (Constraint Logic Programming over Reals)
|
||||
|
||||
Author: Leslie De Koninck
|
||||
E-mail: Leslie.DeKoninck@cs.kuleuven.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09
|
||||
Copyright (C): 2004, K.U. Leuven and
|
||||
1992-1995, Austrian Research Institute for
|
||||
Artificial Intelligence (OFAI),
|
||||
Vienna, Austria
|
||||
|
||||
This software is part of Leslie De Koninck's master thesis, supervised
|
||||
by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R)
|
||||
by Christian Holzbaur for SICStus Prolog and distributed under the
|
||||
license details below with permission from all mentioned authors.
|
||||
|
||||
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(store_r,
|
||||
[
|
||||
add_linear_11/3,
|
||||
add_linear_f1/4,
|
||||
add_linear_ff/5,
|
||||
normalize_scalar/2,
|
||||
delete_factor/4,
|
||||
mult_linear_factor/3,
|
||||
nf_rhs_x/4,
|
||||
indep/2,
|
||||
isolate/3,
|
||||
nf_substitute/4,
|
||||
mult_hom/3,
|
||||
nf2sum/3,
|
||||
nf_coeff_of/3,
|
||||
renormalize/2
|
||||
]).
|
||||
|
||||
% normalize_scalar(S,[N,Z])
|
||||
%
|
||||
% Transforms a scalar S into a linear expression [S,0]
|
||||
|
||||
normalize_scalar(S,[S,0.0]).
|
||||
|
||||
% renormalize(List,Lin)
|
||||
%
|
||||
% Renormalizes the not normalized linear expression in List into
|
||||
% a normalized one. It does so to take care of unifications.
|
||||
% (e.g. when a variable X is bound to a constant, the constant is added to
|
||||
% the constant part of the linear expression; when a variable X is bound to
|
||||
% another variable Y, the scalars of both are added)
|
||||
|
||||
renormalize([I,R|Hom],Lin) :-
|
||||
length(Hom,Len),
|
||||
renormalize_log(Len,Hom,[],Lin0),
|
||||
add_linear_11([I,R],Lin0,Lin).
|
||||
|
||||
% renormalize_log(Len,Hom,HomTail,Lin)
|
||||
%
|
||||
% Logarithmically renormalizes the homogene part of a not normalized
|
||||
% linear expression. See also renormalize/2.
|
||||
|
||||
renormalize_log(1,[Term|Xs],Xs,Lin) :-
|
||||
!,
|
||||
Term = l(X*_,_),
|
||||
renormalize_log_one(X,Term,Lin).
|
||||
renormalize_log(2,[A,B|Xs],Xs,Lin) :-
|
||||
!,
|
||||
A = l(X*_,_),
|
||||
B = l(Y*_,_),
|
||||
renormalize_log_one(X,A,LinA),
|
||||
renormalize_log_one(Y,B,LinB),
|
||||
add_linear_11(LinA,LinB,Lin).
|
||||
renormalize_log(N,L0,L2,Lin) :-
|
||||
P is N>>1,
|
||||
Q is N-P,
|
||||
renormalize_log(P,L0,L1,Lp),
|
||||
renormalize_log(Q,L1,L2,Lq),
|
||||
add_linear_11(Lp,Lq,Lin).
|
||||
|
||||
% renormalize_log_one(X,Term,Res)
|
||||
%
|
||||
% Renormalizes a term in X: if X is a nonvar, the term becomes a scalar.
|
||||
|
||||
renormalize_log_one(X,Term,Res) :-
|
||||
var(X),
|
||||
Term = l(X*K,_),
|
||||
get_attr(X,itf,Att),
|
||||
arg(5,Att,order(OrdX)), % Order might have changed
|
||||
Res = [0.0,0.0,l(X*K,OrdX)].
|
||||
renormalize_log_one(X,Term,Res) :-
|
||||
nonvar(X),
|
||||
Term = l(X*K,_),
|
||||
Xk is X*K,
|
||||
normalize_scalar(Xk,Res).
|
||||
|
||||
% ----------------------------- sparse vector stuff ---------------------------- %
|
||||
|
||||
% add_linear_ff(LinA,Ka,LinB,Kb,LinC)
|
||||
%
|
||||
% Linear expression LinC is the result of the addition of the 2 linear expressions
|
||||
% LinA and LinB, each one multiplied by a scalar (Ka for LinA and Kb for LinB).
|
||||
|
||||
add_linear_ff(LinA,Ka,LinB,Kb,LinC) :-
|
||||
LinA = [Ia,Ra|Ha],
|
||||
LinB = [Ib,Rb|Hb],
|
||||
LinC = [Ic,Rc|Hc],
|
||||
Ic is Ia*Ka+Ib*Kb,
|
||||
Rc is Ra*Ka+Rb*Kb,
|
||||
add_linear_ffh(Ha,Ka,Hb,Kb,Hc).
|
||||
|
||||
% add_linear_ffh(Ha,Ka,Hb,Kb,Hc)
|
||||
%
|
||||
% Homogene part Hc is the result of the addition of the 2 homogene parts Ha and Hb,
|
||||
% each one multiplied by a scalar (Ka for Ha and Kb for Hb)
|
||||
|
||||
add_linear_ffh([],_,Ys,Kb,Zs) :- mult_hom(Ys,Kb,Zs).
|
||||
add_linear_ffh([l(X*Kx,OrdX)|Xs],Ka,Ys,Kb,Zs) :-
|
||||
add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb).
|
||||
|
||||
% add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb)
|
||||
%
|
||||
% Homogene part Zs is the result of the addition of the 2 homogene parts Ys and
|
||||
% [l(X*Kx,OrdX)|Xs], each one multiplied by a scalar (Ka for [l(X*Kx,OrdX)|Xs] and Kb for Ys)
|
||||
|
||||
add_linear_ffh([],X,Kx,OrdX,Xs,Zs,Ka,_) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs).
|
||||
add_linear_ffh([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka,Kb) :-
|
||||
compare(Rel,OrdX,OrdY),
|
||||
( Rel = (=)
|
||||
-> Kz is Kx*Ka+Ky*Kb,
|
||||
( % Kz =:= 0
|
||||
Kz =< 1.0e-10,
|
||||
Kz >= -1.0e-10
|
||||
-> add_linear_ffh(Xs,Ka,Ys,Kb,Zs)
|
||||
; Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
add_linear_ffh(Xs,Ka,Ys,Kb,Ztail)
|
||||
)
|
||||
; Rel = (<)
|
||||
-> Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
Kz is Kx*Ka,
|
||||
add_linear_ffh(Xs,Y,Ky,OrdY,Ys,Ztail,Kb,Ka)
|
||||
; Rel = (>)
|
||||
-> Zs = [l(Y*Kz,OrdY)|Ztail],
|
||||
Kz is Ky*Kb,
|
||||
add_linear_ffh(Ys,X,Kx,OrdX,Xs,Ztail,Ka,Kb)
|
||||
).
|
||||
|
||||
% add_linear_f1(LinA,Ka,LinB,LinC)
|
||||
%
|
||||
% special case of add_linear_ff with Kb = 1
|
||||
|
||||
add_linear_f1(LinA,Ka,LinB,LinC) :-
|
||||
LinA = [Ia,Ra|Ha],
|
||||
LinB = [Ib,Rb|Hb],
|
||||
LinC = [Ic,Rc|Hc],
|
||||
Ic is Ia*Ka+Ib,
|
||||
Rc is Ra*Ka+Rb,
|
||||
add_linear_f1h(Ha,Ka,Hb,Hc).
|
||||
|
||||
% add_linear_f1h(Ha,Ka,Hb,Hc)
|
||||
%
|
||||
% special case of add_linear_ffh/5 with Kb = 1
|
||||
|
||||
add_linear_f1h([],_,Ys,Ys).
|
||||
add_linear_f1h([l(X*Kx,OrdX)|Xs],Ka,Ys,Zs) :-
|
||||
add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka).
|
||||
|
||||
% add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka)
|
||||
%
|
||||
% special case of add_linear_ffh/8 with Kb = 1
|
||||
|
||||
add_linear_f1h([],X,Kx,OrdX,Xs,Zs,Ka) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs).
|
||||
add_linear_f1h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka) :-
|
||||
compare(Rel,OrdX,OrdY),
|
||||
( Rel = (=)
|
||||
-> Kz is Kx*Ka+Ky,
|
||||
( % Kz =:= 0.0
|
||||
Kz =< 1.0e-10,
|
||||
Kz >= -1.0e-10
|
||||
-> add_linear_f1h(Xs,Ka,Ys,Zs)
|
||||
; Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
add_linear_f1h(Xs,Ka,Ys,Ztail)
|
||||
)
|
||||
; Rel = (<)
|
||||
-> Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
Kz is Kx*Ka,
|
||||
add_linear_f1h(Xs,Ka,[l(Y*Ky,OrdY)|Ys],Ztail)
|
||||
; Rel = (>)
|
||||
-> Zs = [l(Y*Ky,OrdY)|Ztail],
|
||||
add_linear_f1h(Ys,X,Kx,OrdX,Xs,Ztail,Ka)
|
||||
).
|
||||
|
||||
% add_linear_11(LinA,LinB,LinC)
|
||||
%
|
||||
% special case of add_linear_ff with Ka = 1 and Kb = 1
|
||||
|
||||
add_linear_11(LinA,LinB,LinC) :-
|
||||
LinA = [Ia,Ra|Ha],
|
||||
LinB = [Ib,Rb|Hb],
|
||||
LinC = [Ic,Rc|Hc],
|
||||
Ic is Ia+Ib,
|
||||
Rc is Ra+Rb,
|
||||
add_linear_11h(Ha,Hb,Hc).
|
||||
|
||||
% add_linear_11h(Ha,Hb,Hc)
|
||||
%
|
||||
% special case of add_linear_ffh/5 with Ka = 1 and Kb = 1
|
||||
|
||||
add_linear_11h([],Ys,Ys).
|
||||
add_linear_11h([l(X*Kx,OrdX)|Xs],Ys,Zs) :-
|
||||
add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs).
|
||||
|
||||
% add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs)
|
||||
%
|
||||
% special case of add_linear_ffh/8 with Ka = 1 and Kb = 1
|
||||
|
||||
add_linear_11h([],X,Kx,OrdX,Xs,[l(X*Kx,OrdX)|Xs]).
|
||||
add_linear_11h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs) :-
|
||||
compare(Rel,OrdX,OrdY),
|
||||
( Rel = (=)
|
||||
-> Kz is Kx+Ky,
|
||||
( % Kz =:= 0.0
|
||||
Kz =< 1.0e-10,
|
||||
Kz >= -1.0e-10
|
||||
-> add_linear_11h(Xs,Ys,Zs)
|
||||
; Zs = [l(X*Kz,OrdX)|Ztail],
|
||||
add_linear_11h(Xs,Ys,Ztail)
|
||||
)
|
||||
; Rel = (<)
|
||||
-> Zs = [l(X*Kx,OrdX)|Ztail],
|
||||
add_linear_11h(Xs,Y,Ky,OrdY,Ys,Ztail)
|
||||
; Rel = (>)
|
||||
-> Zs = [l(Y*Ky,OrdY)|Ztail],
|
||||
add_linear_11h(Ys,X,Kx,OrdX,Xs,Ztail)
|
||||
).
|
||||
|
||||
% mult_linear_factor(Lin,K,Res)
|
||||
%
|
||||
% Linear expression Res is the result of multiplication of linear
|
||||
% expression Lin by scalar K
|
||||
|
||||
mult_linear_factor(Lin,K,Mult) :-
|
||||
TestK is K - 1.0, % K =:= 1
|
||||
TestK =< 1.0e-10,
|
||||
TestK >= -1.0e-10, % avoid copy
|
||||
!,
|
||||
Mult = Lin.
|
||||
mult_linear_factor(Lin,K,Res) :-
|
||||
Lin = [I,R|Hom],
|
||||
Res = [Ik,Rk|Mult],
|
||||
Ik is I*K,
|
||||
Rk is R*K,
|
||||
mult_hom(Hom,K,Mult).
|
||||
|
||||
% mult_hom(Hom,K,Res)
|
||||
%
|
||||
% Homogene part Res is the result of multiplication of homogene part
|
||||
% Hom by scalar K
|
||||
|
||||
mult_hom([],_,[]).
|
||||
mult_hom([l(A*Fa,OrdA)|As],F,[l(A*Fan,OrdA)|Afs]) :-
|
||||
Fan is F*Fa,
|
||||
mult_hom(As,F,Afs).
|
||||
|
||||
% nf_substitute(Ord,Def,Lin,Res)
|
||||
%
|
||||
% Linear expression Res is the result of substitution of Var in
|
||||
% linear expression Lin, by its definition in the form of linear
|
||||
% expression Def
|
||||
|
||||
nf_substitute(OrdV,LinV,LinX,LinX1) :-
|
||||
delete_factor(OrdV,LinX,LinW,K),
|
||||
add_linear_f1(LinV,K,LinW,LinX1).
|
||||
|
||||
% delete_factor(Ord,Lin,Res,Coeff)
|
||||
%
|
||||
% Linear expression Res is the result of the deletion of the term
|
||||
% Var*Coeff where Var has ordering Ord from linear expression Lin
|
||||
|
||||
delete_factor(OrdV,Lin,Res,Coeff) :-
|
||||
Lin = [I,R|Hom],
|
||||
Res = [I,R|Hdel],
|
||||
delete_factor_hom(OrdV,Hom,Hdel,Coeff).
|
||||
|
||||
% delete_factor_hom(Ord,Hom,Res,Coeff)
|
||||
%
|
||||
% Homogene part Res is the result of the deletion of the term
|
||||
% Var*Coeff from homogene part Hom
|
||||
|
||||
delete_factor_hom(VOrd,[Car|Cdr],RCdr,RKoeff) :-
|
||||
Car = l(_*Koeff,Ord),
|
||||
compare(Rel,VOrd,Ord),
|
||||
( Rel= (=)
|
||||
-> RCdr = Cdr,
|
||||
RKoeff=Koeff
|
||||
; Rel= (>)
|
||||
-> RCdr = [Car|RCdr1],
|
||||
delete_factor_hom(VOrd,Cdr,RCdr1,RKoeff)
|
||||
).
|
||||
|
||||
|
||||
% nf_coeff_of(Lin,OrdX,Coeff)
|
||||
%
|
||||
% Linear expression Lin contains the term l(X*Coeff,OrdX)
|
||||
|
||||
nf_coeff_of([_,_|Hom],VOrd,Coeff) :-
|
||||
nf_coeff_hom(Hom,VOrd,Coeff).
|
||||
|
||||
% nf_coeff_hom(Lin,OrdX,Coeff)
|
||||
%
|
||||
% Linear expression Lin contains the term l(X*Coeff,OrdX) where the
|
||||
% order attribute of X = OrdX
|
||||
|
||||
nf_coeff_hom([l(_*K,OVar)|Vs],OVid,Coeff) :-
|
||||
compare(Rel,OVid,OVar),
|
||||
( Rel = (=)
|
||||
-> Coeff = K
|
||||
; Rel = (>)
|
||||
-> nf_coeff_hom(Vs,OVid,Coeff)
|
||||
).
|
||||
|
||||
% nf_rhs_x(Lin,OrdX,Rhs,K)
|
||||
%
|
||||
% Rhs = R + I where Lin = [I,R|Hom] and l(X*K,OrdX) is a term of Hom
|
||||
|
||||
nf_rhs_x(Lin,OrdX,Rhs,K) :-
|
||||
Lin = [I,R|Tail],
|
||||
nf_coeff_hom(Tail,OrdX,K),
|
||||
Rhs is R+I. % late because X may not occur in H
|
||||
|
||||
% isolate(OrdN,Lin,Lin1)
|
||||
%
|
||||
% Linear expression Lin1 is the result of the transformation of linear expression
|
||||
% Lin = 0 which contains the term l(New*K,OrdN) into an equivalent expression Lin1 = New.
|
||||
|
||||
isolate(OrdN,Lin,Lin1) :-
|
||||
delete_factor(OrdN,Lin,Lin0,Coeff),
|
||||
K is -1.0/Coeff,
|
||||
mult_linear_factor(Lin0,K,Lin1).
|
||||
|
||||
% indep(Lin,OrdX)
|
||||
%
|
||||
% succeeds if Lin = [0,_|[l(X*1,OrdX)]]
|
||||
|
||||
indep(Lin,OrdX) :-
|
||||
Lin = [I,_|[l(_*K,OrdY)]],
|
||||
OrdX == OrdY,
|
||||
% K =:= 1.0
|
||||
TestK is K - 1.0,
|
||||
TestK =< 1.0e-10,
|
||||
TestK >= -1.0e-10,
|
||||
% I =:= 0
|
||||
I =< 1.0e-10,
|
||||
I >= -1.0e-10.
|
||||
|
||||
% nf2sum(Lin,Sofar,Term)
|
||||
%
|
||||
% Transforms a linear expression into a sum
|
||||
% (e.g. the expression [5,_,[l(X*2,OrdX),l(Y*-1,OrdY)]] gets transformed into 5 + 2*X - Y)
|
||||
|
||||
nf2sum([],I,I).
|
||||
nf2sum([X|Xs],I,Sum) :-
|
||||
( % I =:= 0.0
|
||||
I =< 1.0e-10,
|
||||
I >= -1.0e-10
|
||||
-> X = l(Var*K,_),
|
||||
( % K =:= 1.0
|
||||
TestK is K - 1.0,
|
||||
TestK =< 1.0e-10,
|
||||
TestK >= -1.0e-10
|
||||
-> hom2sum(Xs,Var,Sum)
|
||||
; % K =:= -1.0
|
||||
TestK is K + 1.0,
|
||||
TestK =< 1.0e-10,
|
||||
TestK >= -1.0e-10
|
||||
-> hom2sum(Xs,-Var,Sum)
|
||||
; hom2sum(Xs,K*Var,Sum)
|
||||
)
|
||||
; hom2sum([X|Xs],I,Sum)
|
||||
).
|
||||
|
||||
% hom2sum(Hom,Sofar,Term)
|
||||
%
|
||||
% Transforms a linear expression into a sum
|
||||
% this predicate handles all but the first term
|
||||
% (the first term does not need a concatenation symbol + or -)
|
||||
% see also nf2sum/3
|
||||
|
||||
hom2sum([],Term,Term).
|
||||
hom2sum([l(Var*K,_)|Cs],Sofar,Term) :-
|
||||
( % K =:= 1.0
|
||||
TestK is K - 1.0,
|
||||
TestK =< 1.0e-10,
|
||||
TestK >= -1.0e-10
|
||||
-> Next = Sofar + Var
|
||||
; % K =:= -1.0
|
||||
TestK is K + 1.0,
|
||||
TestK =< 1.0e-10,
|
||||
TestK >= -1.0e-10
|
||||
-> Next = Sofar - Var
|
||||
; % K < 0.0
|
||||
K < -1.0e-10
|
||||
-> Ka is -K,
|
||||
Next = Sofar - Ka*Var
|
||||
; Next = Sofar + K*Var
|
||||
),
|
||||
hom2sum(Cs,Next,Term).
|
|
@ -0,0 +1,12 @@
|
|||
dnl Process this file with autoconf to produce a configure script.
|
||||
|
||||
AC_INIT(install-sh)
|
||||
AC_PREREQ([2.50])
|
||||
|
||||
AC_ARG_ENABLE(clpqr,
|
||||
[ --enable-clpqr install clpqr library ],
|
||||
use_clpqr="$enableval", use_clpqr=yes)
|
||||
|
||||
m4_include([../ac_swi_noc.m4])
|
||||
|
||||
AC_OUTPUT(Makefile)
|
|
@ -0,0 +1,238 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# install - install a program, script, or datafile
|
||||
# This comes from X11R5.
|
||||
#
|
||||
# Calling this script install-sh is preferred over install.sh, to prevent
|
||||
# `make' implicit rules from creating a file called install from it
|
||||
# when there is no Makefile.
|
||||
#
|
||||
# This script is compatible with the BSD install script, but was written
|
||||
# from scratch.
|
||||
#
|
||||
|
||||
|
||||
# set DOITPROG to echo to test this script
|
||||
|
||||
# Don't use :- since 4.3BSD and earlier shells don't like it.
|
||||
doit="${DOITPROG-}"
|
||||
|
||||
|
||||
# put in absolute paths if you don't have them in your path; or use env. vars.
|
||||
|
||||
mvprog="${MVPROG-mv}"
|
||||
cpprog="${CPPROG-cp}"
|
||||
chmodprog="${CHMODPROG-chmod}"
|
||||
chownprog="${CHOWNPROG-chown}"
|
||||
chgrpprog="${CHGRPPROG-chgrp}"
|
||||
stripprog="${STRIPPROG-strip}"
|
||||
rmprog="${RMPROG-rm}"
|
||||
mkdirprog="${MKDIRPROG-mkdir}"
|
||||
|
||||
tranformbasename=""
|
||||
transform_arg=""
|
||||
instcmd="$mvprog"
|
||||
chmodcmd="$chmodprog 0755"
|
||||
chowncmd=""
|
||||
chgrpcmd=""
|
||||
stripcmd=""
|
||||
rmcmd="$rmprog -f"
|
||||
mvcmd="$mvprog"
|
||||
src=""
|
||||
dst=""
|
||||
dir_arg=""
|
||||
|
||||
while [ x"$1" != x ]; do
|
||||
case $1 in
|
||||
-c) instcmd="$cpprog"
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-d) dir_arg=true
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-m) chmodcmd="$chmodprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-o) chowncmd="$chownprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-g) chgrpcmd="$chgrpprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-s) stripcmd="$stripprog"
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
|
||||
shift
|
||||
continue;;
|
||||
|
||||
*) if [ x"$src" = x ]
|
||||
then
|
||||
src=$1
|
||||
else
|
||||
# this colon is to work around a 386BSD /bin/sh bug
|
||||
:
|
||||
dst=$1
|
||||
fi
|
||||
shift
|
||||
continue;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ x"$src" = x ]
|
||||
then
|
||||
echo "install: no input file specified"
|
||||
exit 1
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
if [ x"$dir_arg" != x ]; then
|
||||
dst=$src
|
||||
src=""
|
||||
|
||||
if [ -d $dst ]; then
|
||||
instcmd=:
|
||||
else
|
||||
instcmd=mkdir
|
||||
fi
|
||||
else
|
||||
|
||||
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
|
||||
# might cause directories to be created, which would be especially bad
|
||||
# if $src (and thus $dsttmp) contains '*'.
|
||||
|
||||
if [ -f $src -o -d $src ]
|
||||
then
|
||||
true
|
||||
else
|
||||
echo "install: $src does not exist"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ x"$dst" = x ]
|
||||
then
|
||||
echo "install: no destination specified"
|
||||
exit 1
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
# If destination is a directory, append the input filename; if your system
|
||||
# does not like double slashes in filenames, you may need to add some logic
|
||||
|
||||
if [ -d $dst ]
|
||||
then
|
||||
dst="$dst"/`basename $src`
|
||||
else
|
||||
true
|
||||
fi
|
||||
fi
|
||||
|
||||
## this sed command emulates the dirname command
|
||||
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
|
||||
|
||||
# Make sure that the destination directory exists.
|
||||
# this part is taken from Noah Friedman's mkinstalldirs script
|
||||
|
||||
# Skip lots of stat calls in the usual case.
|
||||
if [ ! -d "$dstdir" ]; then
|
||||
defaultIFS='
|
||||
'
|
||||
IFS="${IFS-${defaultIFS}}"
|
||||
|
||||
oIFS="${IFS}"
|
||||
# Some sh's can't handle IFS=/ for some reason.
|
||||
IFS='%'
|
||||
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
|
||||
IFS="${oIFS}"
|
||||
|
||||
pathcomp=''
|
||||
|
||||
while [ $# -ne 0 ] ; do
|
||||
pathcomp="${pathcomp}${1}"
|
||||
shift
|
||||
|
||||
if [ ! -d "${pathcomp}" ] ;
|
||||
then
|
||||
$mkdirprog "${pathcomp}"
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
pathcomp="${pathcomp}/"
|
||||
done
|
||||
fi
|
||||
|
||||
if [ x"$dir_arg" != x ]
|
||||
then
|
||||
$doit $instcmd $dst &&
|
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
|
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
|
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
|
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
|
||||
else
|
||||
|
||||
# If we're going to rename the final executable, determine the name now.
|
||||
|
||||
if [ x"$transformarg" = x ]
|
||||
then
|
||||
dstfile=`basename $dst`
|
||||
else
|
||||
dstfile=`basename $dst $transformbasename |
|
||||
sed $transformarg`$transformbasename
|
||||
fi
|
||||
|
||||
# don't allow the sed command to completely eliminate the filename
|
||||
|
||||
if [ x"$dstfile" = x ]
|
||||
then
|
||||
dstfile=`basename $dst`
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
# Make a temp file name in the proper directory.
|
||||
|
||||
dsttmp=$dstdir/#inst.$$#
|
||||
|
||||
# Move or copy the file name to the temp name
|
||||
|
||||
$doit $instcmd $src $dsttmp &&
|
||||
|
||||
trap "rm -f ${dsttmp}" 0 &&
|
||||
|
||||
# and set any options; do chmod last to preserve setuid bits
|
||||
|
||||
# If any of these fail, we abort the whole thing. If we want to
|
||||
# ignore errors from any of these, just make sure not to ignore
|
||||
# errors from the above "$doit $instcmd $src $dsttmp" command.
|
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
|
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
|
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
|
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
|
||||
|
||||
# Now rename the file to the real destination.
|
||||
|
||||
$doit $rmcmd -f $dstdir/$dstfile &&
|
||||
$doit $mvcmd $dsttmp $dstdir/$dstfile
|
||||
|
||||
fi &&
|
||||
|
||||
|
||||
exit 0
|
|
@ -1 +0,0 @@
|
|||
Subproject commit f98511b9c0f6113a04512abad346b2ee0c399478
|
|
@ -1 +0,0 @@
|
|||
Subproject commit 8b043d9f8261e701723d7e75391dcb99937206d5
|
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue