diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

stop using submodule

Browse Source
This commit is contained in:
Vítor Santos Costa 2015-10-13 08:17:51 +01:00
parent d47f59be09
commit 9b33c9d8ba
481 changed files with 115314 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
.gitmodules vendored
View File

@ -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
packages/RDF

@ -1 +0,0 @@
Subproject commit f19e64df267c6dbaf3c4f93b44f2b1e343e4b449

1
packages/archive

@ -1 +0,0 @@
Subproject commit 2095a5f288ae9cd6bed978295f78723a0ba62e6f

1
packages/chr

@ -1 +0,0 @@
Subproject commit 0e7ab5c61c1387b21fb64458be6e3534a493fb27

26
packages/chr/Benchmarks/benches.pl Normal file
View File

@ -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]).

322
packages/chr/Benchmarks/bool.chr Normal file
View File

@ -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]).

34
packages/chr/Benchmarks/fib.chr Normal file
View File

@ -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.

42
packages/chr/Benchmarks/fibonacci.chr Normal file
View File

@ -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.

139
packages/chr/Benchmarks/fulladder.chr Normal file
View File

@ -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).

34
packages/chr/Benchmarks/leq.chr Normal file
View File

@ -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).

29
packages/chr/Benchmarks/primes.chr Normal file
View File

@ -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.

381
packages/chr/Benchmarks/ta.chr Normal file
View File

@ -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)
).

262
packages/chr/Benchmarks/wfs.chr Normal file
View File

@ -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).

127
packages/chr/Benchmarks/zebra.chr Normal file
View File

@ -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
packages/chr/CMakeLists.txt Normal file
View File

861
packages/chr/ChangeLog Normal file
View File

@ -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.

281
packages/chr/Examples/bool.chr Normal file
View File

@ -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 */

84
packages/chr/Examples/chrdif.chr Normal file
View File

@ -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)
).

6
packages/chr/Examples/chrfreeze.chr Normal file
View File

@ -0,0 +1,6 @@
:- module(chrfreeze,[chrfreeze/2]).
:- use_module(library(chr)).
:- constraints chrfreeze/2.
chrfreeze(V,G) <=> nonvar(V) | call(G).

197
packages/chr/Examples/deadcode.pl Normal file
View File

@ -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)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

116
packages/chr/Examples/family.chr Normal file
View File

@ -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).
**************************************************/

24
packages/chr/Examples/fib.chr Normal file
View File

@ -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.

31
packages/chr/Examples/fibonacci.chr Normal file
View File

@ -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.

28
packages/chr/Examples/gcd.chr Normal file
View File

@ -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).
*/

34
packages/chr/Examples/leq.chr Normal file
View File

@ -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.

138
packages/chr/Examples/listdom.chr Normal file
View File

@ -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
*/

30
packages/chr/Examples/primes.chr Normal file
View File

@ -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.

114
packages/chr/Makefile.in Executable file
View File

@ -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)

111
packages/chr/Makefile.mak Normal file
View File

@ -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

47
packages/chr/README Normal file
View File

@ -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.

26
packages/chr/Tests/dense_int.chr Normal file
View File

@ -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.

40
packages/chr/Tests/fibonacci.chr Normal file
View File

@ -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].

27
packages/chr/Tests/leq.chr Normal file
View File

@ -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).

12
packages/chr/Tests/passive_check.chr Normal file
View File

@ -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(_).

12
packages/chr/Tests/passive_check2.chr Normal file
View File

@ -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.

41
packages/chr/Tests/primes.chr Normal file
View File

@ -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].

13
packages/chr/Tests/trigger_no_active_occurrence.chr Normal file
View File

@ -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.

117
packages/chr/Tests/zebra.chr Normal file
View File

@ -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).

77
packages/chr/a_star.pl Normal file
View File

@ -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).

139
packages/chr/binomialheap.pl Normal file
View File

@ -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,_))).

625
packages/chr/builtins.pl Normal file
View File

@ -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

538
packages/chr/chr.yap Normal file
View File

@ -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).

180
packages/chr/chr_compiler_errors.pl Normal file
View File

@ -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',[]).

383
packages/chr/chr_compiler_options.pl Normal file
View File

@ -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.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

339
packages/chr/chr_compiler_utility.pl Normal file
View File

@ -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])
).

66
packages/chr/chr_debug.pl Normal file
View File

@ -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).

425
packages/chr/chr_hashtable_store.pl Normal file
View File

@ -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
).

140
packages/chr/chr_integertable_store.pl Normal file
View File

@ -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)
).

177
packages/chr/chr_messages.pl Normal file
View File

@ -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] ].

50
packages/chr/chr_op.pl Normal file
View File

@ -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).

51
packages/chr/chr_op2.pl Normal file
View File

@ -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, --->).

968
packages/chr/chr_runtime.pl Normal file
View File

@ -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).

105
packages/chr/chr_support.c Normal file
View File

@ -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);
}

449
packages/chr/chr_swi.pl Normal file
View File

@ -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).

215
packages/chr/chr_swi_bootstrap.pl Normal file
View File

@ -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

170
packages/chr/chr_test.pl Normal file
View File

@ -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)).

11455
packages/chr/chr_translate.chr Normal file
View File

File diff suppressed because it is too large Load Diff

2495
packages/chr/chr_translate_bootstrap.pl Normal file
View File

File diff suppressed because it is too large Load Diff

2315
packages/chr/chr_translate_bootstrap1.chr Normal file
View File

File diff suppressed because it is too large Load Diff

3670
packages/chr/chr_translate_bootstrap2.chr Normal file
View File

File diff suppressed because it is too large Load Diff

249
packages/chr/clean_code.pl Normal file
View File

@ -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]
).

15
packages/chr/configure.in Normal file
View File

@ -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)

79
packages/chr/find.pl Normal file
View File

@ -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)).

511
packages/chr/guard_entailment.chr Normal file
View File

@ -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.

238
packages/chr/install-sh Executable file
View File

@ -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

105
packages/chr/listmap.pl Normal file
View File

@ -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)
).

78
packages/chr/pairlist.pl Normal file
View File

@ -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
packages/clib

@ -1 +0,0 @@
Subproject commit a66738b770cc3c3270e19de981a596e74a871220

1
packages/clpqr

@ -1 +0,0 @@
Subproject commit 39a11c2d87fbd072ece4af19e5265997e06c56e1

63
packages/clpqr/ChangeLog Normal file
View File

@ -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.

78
packages/clpqr/Makefile.in Executable file
View File

@ -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

77
packages/clpqr/Makefile.mak Normal file
View File

@ -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

19
packages/clpqr/README Normal file
View File

@ -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

135
packages/clpqr/clpq.pl Normal file
View File

@ -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)
).

240
packages/clpqr/clpq/bb_q.pl Normal file
View File

@ -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
).

1760
packages/clpqr/clpq/bv_q.pl Normal file
View File

File diff suppressed because it is too large Load Diff

503
packages/clpqr/clpq/fourmotz_q.pl Normal file
View File

@ -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)
).

1281
packages/clpqr/clpq/ineq_q.pl Normal file
View File

File diff suppressed because it is too large Load Diff

222
packages/clpqr/clpq/itf_q.pl Normal file
View File

@ -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(_,_,_,_).

1119
packages/clpqr/clpq/nf_q.pl Normal file
View File

File diff suppressed because it is too large Load Diff

398
packages/clpqr/clpq/store_q.pl Normal file
View File

@ -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).

155
packages/clpqr/clpqr/class.pl Normal file
View File

@ -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)
).

334
packages/clpqr/clpqr/dump.pl Normal file
View File

@ -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).

192
packages/clpqr/clpqr/geler.pl Normal file
View File

@ -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).

124
packages/clpqr/clpqr/itf.pl Normal file
View File

@ -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).

198
packages/clpqr/clpqr/ordering.pl Normal file
View File

@ -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)
).

305
packages/clpqr/clpqr/project.pl Normal file
View File

@ -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)
).

297
packages/clpqr/clpqr/redund.pl Normal file
View File

@ -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.

204
packages/clpqr/clpr.pl Normal file
View File

@ -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)
).

260
packages/clpqr/clpr/bb_r.pl Normal file
View File

@ -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
).

1786
packages/clpqr/clpr/bv_r.pl Normal file
View File

File diff suppressed because it is too large Load Diff

504
packages/clpqr/clpr/fourmotz_r.pl Normal file
View File

@ -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)
).

1384
packages/clpqr/clpr/ineq_r.pl Normal file
View File

File diff suppressed because it is too large Load Diff

227
packages/clpqr/clpr/itf_r.pl Normal file
View File

@ -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(_,_,_,_).

1205
packages/clpqr/clpr/nf_r.pl Normal file
View File

File diff suppressed because it is too large Load Diff

427
packages/clpqr/clpr/store_r.pl Normal file
View File

@ -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).

12
packages/clpqr/configure.in Normal file
View File

@ -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)

238
packages/clpqr/install-sh Executable file
View File

@ -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
packages/http

@ -1 +0,0 @@
Subproject commit f98511b9c0f6113a04512abad346b2ee0c399478

1
packages/jpl

@ -1 +0,0 @@
Subproject commit 8b043d9f8261e701723d7e75391dcb99937206d5

Some files were not shown because too many files have changed in this diff Show More