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

Deleted CHR

This commit is contained in:
Vitor Santos Costa 2008-08-23 02:45:57 +01:00
parent b6409fc980
commit 63d77c3561
45 changed files with 0 additions and 66268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
LGPL/chr/Benchmarks/benches.pl
View File

@ -1,25 +0,0 @@
benches :-
bench(B),
atom_concat(B, '.chr', File),
style_check(-singleton),
abolish(main,0),
abolish(main,1),
load_files(File,[silent(true)]),
% (main;main;main;main),
main,
fail.
benches.
bench(bool).
bench(fib).
bench(fibonacci).
bench(leq).
bench(primes).
bench(ta).
bench(wfs).
bench(zebra).
prolog:cputime(Time) :-
statistics(runtime, [_,Time]).
:- benches.

323
LGPL/chr/Benchmarks/bool.chr
View File

@ -1,323 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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
LGPL/chr/Benchmarks/fib.chr
View File

@ -1,34 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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
LGPL/chr/Benchmarks/fibonacci.chr
View File

@ -1,42 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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.

138
LGPL/chr/Benchmarks/fulladder.chr
View File

@ -1,138 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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]).
:- 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
LGPL/chr/Benchmarks/leq.chr
View File

@ -1,34 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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).

30
LGPL/chr/Benchmarks/primes.chr
View File

@ -1,30 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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.

386
LGPL/chr/Benchmarks/ta.chr
View File

@ -1,386 +0,0 @@
:- 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(ID).
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)
).
memberchk_eq(A,[A1|_]) :- A == A1, !.
memberchk_eq(A,[_|L]) :-
memberchk_eq(A,L).

263
LGPL/chr/Benchmarks/wfs.chr
View File

@ -1,263 +0,0 @@
:- 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).

129
LGPL/chr/Benchmarks/zebra.chr
View File

@ -1,129 +0,0 @@
:- 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(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) | 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):-
cputime(X),
test(N),
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).

208
LGPL/chr/Changelog
View File

@ -1,208 +0,0 @@
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.ac.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
* 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.

157
LGPL/chr/Makefile.in
View File

@ -1,157 +0,0 @@
#
# default base directory for YAP installation
# (EROOT for architecture-dependent files)
#
prefix = @prefix@
ROOTDIR = $(prefix)
EROOTDIR = @exec_prefix@
srcdir=@srcdir@
BINDIR = $(EROOTDIR)/bin
LIBDIR=$(EROOTDIR)/lib
YAPLIBDIR=$(EROOTDIR)/lib/Yap
SHAREDIR=$(ROOTDIR)/share
SHELL=@SHELL@
PL=@EXTEND_DYNLOADER_PATH@ $(DESTDIR)$(BINDIR)/yap $(DESTDIR)$(YAPLIBDIR)/startup
CHRDIR=$(SHAREDIR)/chr
EXDIR=$(CHRDIR)/examples/chr
LN_S=@LN_S@
DOCTOTEX=$(PCEHOME)/bin/doc2tex
PLTOTEX=$(PCEHOME)/bin/pl2tex
LATEX=latex
DOC=chr
TEX=$(DOC).tex
DVI=$(DOC).dvi
PDF=$(DOC).pdf
HTML=$(DOC).html
INSTALL=@INSTALL@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
INSTALL_DATA=@INSTALL_DATA@
LIBPL= $(srcdir)/chr_runtime.pl $(srcdir)/chr_op.pl chr_translate.pl $(srcdir)/chr_debug.pl \
$(srcdir)/chr_messages.pl $(srcdir)/hprolog.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_errors.pl \
$(srcdir)/chr_compiler_options.pl $(srcdir)/chr_compiler_utility.pl \
$(srcdir)/chr_integertable_store.pl
CHRPL= $(srcdir)/chr_swi.pl
EXAMPLES= $(srcdir)/Benchmarks/chrfreeze.chr $(srcdir)/Benchmarks/fib.chr $(srcdir)/Benchmarks/gcd.chr $(srcdir)/Benchmarks/primes.chr \
$(srcdir)/Benchmarks/bool.chr $(srcdir)/Benchmarks/family.chr $(srcdir)/Benchmarks/fibonacci.chr $(srcdir)/Benchmarks/leq.chr $(srcdir)/Benchmarks/listdom.chr \
$(srcdir)/Benchmarks/chrdif.chr
GPLDIR= $(srcdir)/../../GPL
LGPLDIR= $(srcdir)/../../LGPL
EXTRALIBDIR= $(srcdir)/../../library
GPLLIBPL= $(EXTRALIBDIR)/aggregate.pl $(EXTRALIBDIR)/error.pl $(EXTRALIBDIR)/occurs.yap $(EXTRALIBDIR)/pairs.pl
LGPLLIBPL= $(EXTRALIBDIR)/maplist.pl
EXTRALIBPL= $(GPLLIBPL) $(LGPLLIBPL)
all: chr_translate.pl
chr_translate_bootstrap1.pl: $(srcdir)/chr_translate_bootstrap1.chr $(EXTRALIBPL)
$(PL) -f -l chr_swi_bootstrap.yap \
-g "chr_compile_step1('$<','$@'),halt." \
-z 'halt(1).'
$(PL) -f -l chr_swi_bootstrap.yap \
-g "chr_compile_step2('$<','$@'),halt." \
-z 'halt(1).'
chr_translate_bootstrap2.pl: $(srcdir)/chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl
$(PL) -f -l chr_swi_bootstrap.yap \
-g "chr_compile_step2('$<','$@'),halt." \
-z 'halt(1).'
$(PL) -f -l chr_swi_bootstrap.yap \
-g "chr_compile_step3('$<','$@'),halt." \
-z 'halt(1).'
guard_entailment.pl: $(srcdir)/guard_entailment.chr chr_translate_bootstrap2.pl
$(PL) -f -l chr_swi_bootstrap.yap \
-g "chr_compile_step3('$<','$@'),halt." \
-z 'halt(1).'
chr_translate.pl: $(srcdir)/chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl
$(PL) -f -l chr_swi_bootstrap.yap \
-g "chr_compile_step3('$<','$@'),halt." \
-z 'halt(1).'
$(PL) -f -p chr=. -l chr_swi_bootstrap.yap \
-g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt." \
-z 'halt(1).'
$(PL) -f -p chr=. -l chr_swi_bootstrap.yap \
-g "chr_compile_step4('$<','$@'),halt." \
-z 'halt(1).'
chr.pl: chr_swi.pl
cp $< $@
$(GPLLIBPL): $(EXTRALIBDIR)/%: $(GPLDIR)/%
cp $< $@
$(LGPLLIBPL): $(EXTRALIBDIR)/%: $(LGPLDIR)/%
cp $< $@
install: chr_translate.pl guard_entailment.pl
mkdir -p $(DESTDIR)$(CHRDIR)
$(INSTALL) -m 644 $(LIBPL) $(DESTDIR)$(CHRDIR)
$(INSTALL) -m 644 $(CHRPL) $(DESTDIR)$(SHAREDIR)/chr.pl
$(INSTALL) -m 644 $(srcdir)/README $(DESTDIR)$(CHRDIR)
# $(PL) -f -g make -z halt
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 $(PLBASE)/library && rm -f $(LIBPL))
$(PL) -f none -g make -t halt
check: chr.pl
$(PL) -f chr_test.pl -g test,halt -t 'halt(1)'
################################################################
# Documentation
################################################################
doc: $(PDF) $(HTML)
pdf: $(PDF)
html: $(HTML)
$(HTML): $(TEX)
latex2html $(DOC)
mv html/index.html $@
$(PDF): $(TEX)
runtex --pdf $(DOC)
$(TEX): $(DOCTOTEX)
.doc.tex:
$(DOCTOTEX) $*.doc > $*.tex
.pl.tex:
$(PLTOTEX) $*.pl > $*.tex
################################################################
# Clean
################################################################
clean:
rm -f *~ *% 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 $(TARGETS) config.h config.cache config.status Makefile
rm -f $(TEX)
runtex --clean $(DOC)

141
LGPL/chr/Makefile.yap
View File

@ -1,141 +0,0 @@
################################################################
# SWI-Prolog CHR package
# Author: Jan Wielemaker. jan@swi.psy.uva.nl
# Copyright: LGPL (see COPYING or www.gnu.org
################################################################
.SUFFIXES: .tex .dvi .doc .pl
SHELL=/bin/sh
PLBASE=/usr/lib/pl-5.5.31
#PL=~/Yap/bins/devel/yap
PL=~/osx/yap
XPCEBASE=$(PLBASE)/xpce
PKGDOC=$(PLBASE)/doc/packages
PCEHOME=../../xpce
LIBDIR=$(PLBASE)/library
CHRDIR=$(LIBDIR)/chr
EXDIR=$(PKGDOC)/examples/chr
DESTDIR=
DOCTOTEX=$(PCEHOME)/bin/doc2tex
PLTOTEX=$(PCEHOME)/bin/pl2tex
LATEX=latex
DOC=chr
TEX=$(DOC).tex
DVI=$(DOC).dvi
PDF=$(DOC).pdf
HTML=$(DOC).html
INSTALL=/usr/bin/install -c
INSTALL_PROGRAM=${INSTALL}
INSTALL_DATA=/usr/bin/install -c -m 644
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
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_translate_bootstrap1.pl: chr_translate_bootstrap1.chr
$(PL) -l chr_swi_bootstrap.yap \
-g "chr_compile_step1('$<','$@'),halt." \
-z 'halt(1).'
$(PL) -l chr_swi_bootstrap.yap \
-g "chr_compile_step2('$<','$@'),halt." \
-z 'halt(1).'
chr_translate_bootstrap2.pl: chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl
$(PL) -l chr_swi_bootstrap.yap \
-g "chr_compile_step2('$<','$@'),halt." \
-z 'halt(1).'
$(PL) -l chr_swi_bootstrap.yap \
-g "chr_compile_step3('$<','$@'),halt." \
-z 'halt(1).'
guard_entailment.pl: guard_entailment.chr chr_translate_bootstrap2.pl
$(PL) -l chr_swi_bootstrap.yap \
-g "chr_compile_step3('$<','$@'),halt." \
-z 'halt(1).'
chr_translate.pl: chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl
$(PL) -l chr_swi_bootstrap.yap \
-g "chr_compile_step3('$<','$@'),halt." \
-z 'halt(1)'
$(PL) -p chr=. -l chr_swi_bootstrap.yap \
-g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt." \
-z 'halt(1).'
$(PL) -p chr=. -l chr_swi_bootstrap.yap \
-g "chr_compile_step4('$<','$@'),halt." \
-z 'halt(1).'
chr.pl: chr_swi.pl
cp $< $@
install: $(LIBPL)
mkdir -p $(DESTDIR)$(CHRDIR)
$(INSTALL) -m 644 $(LIBPL) $(DESTDIR)$(CHRDIR)
$(INSTALL) -m 644 $(CHRPL) $(DESTDIR)$(LIBDIR)/chr.pl
$(INSTALL) -m 644 README $(DESTDIR)$(CHRDIR)
$(PL) -f none -g make -z halt
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 $(PLBASE)/library && rm -f $(LIBPL))
$(PL) -f none -g make -z halt
check: chr.pl
$(PL) -f chr_test.pl -g "test,halt." -z 'halt(1).'
################################################################
# Documentation
################################################################
doc: $(PDF) $(HTML)
pdf: $(PDF)
html: $(HTML)
$(HTML): $(TEX)
latex2html $(DOC)
mv html/index.html $@
$(PDF): $(TEX)
runtex --pdf $(DOC)
$(TEX): $(DOCTOTEX)
.doc.tex:
$(DOCTOTEX) $*.doc > $*.tex
.pl.tex:
$(PLTOTEX) $*.pl > $*.tex
################################################################
# Clean
################################################################
clean:
rm -f *~ *% 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 $(TARGETS) config.h config.cache config.status Makefile
rm -f $(TEX)
runtex --clean $(DOC)

47
LGPL/chr/README
View File

@ -1,47 +0,0 @@
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.ac
* 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.

51
LGPL/chr/a_star.pl
View File

@ -1,51 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(a_star,
[
a_star/4
]).
:- use_module(binomialheap).
:- use_module(find).
:- use_module(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).

113
LGPL/chr/binomialheap.pl
View File

@ -1,113 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Binomial Heap imlementation based on
%
% Functional Binomial Queues
% James F. King
% University of Glasgow
%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- 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)
entry(Entry-_,Entry).
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,_))).

599
LGPL/chr/builtins.pl
View File

@ -1,599 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(builtins,
[
negate_b/2,
entails_b/2,
binds_b/2,
builtin_binds_b/2
]).
:- use_module(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),
\+ hprolog: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_(hash_term(_, _), 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_(string_to_atom(_, _), L, L).
% builtin_binds_(string_to_list(_, _), 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

5
LGPL/chr/chr.yap
View File

@ -1,5 +0,0 @@
:- include('chr.pl').

173
LGPL/chr/chr_compiler_errors.pl
View File

@ -1,173 +0,0 @@
/* $Id: chr_compiler_errors.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
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',[]).

372
LGPL/chr/chr_compiler_options.pl
View File

@ -1,372 +0,0 @@
/* $Id: chr_compiler_options.pl,v 1.4 2008-03-13 22:37:07 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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
].
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(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(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]).
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]).
% 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.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

314
LGPL/chr/chr_compiler_utility.pl
View File

@ -1,314 +0,0 @@
/* $Id: chr_compiler_utility.pl,v 1.4 2008-03-13 17:43:13 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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
, atomic_concat/3
, 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
]).
:- use_module(pairlist).
:- use_module(library(lists), [permutation/2]).
:- use_module(library(assoc)).
%% 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).
atomic_concat(A,B,C) :-
make_atom(A,AA),
make_atom(B,BB),
atom_concat(AA,BB,C).
make_atom(A,AA) :-
(
atom(A) ->
AA = A
;
number(A) ->
number_codes(A,AL),
atom_codes(AA,AL)
).
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).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- 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])
).

62
LGPL/chr/chr_debug.pl
View File

@ -1,62 +0,0 @@
/* $Id: chr_debug.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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).

423
LGPL/chr/chr_hashtable_store.pl
View File

@ -1,423 +0,0 @@
/* $Id: chr_hashtable_store.pl,v 1.4 2008-03-13 17:43:13 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
% author: Tom Schrijvers
% email: Tom.Schrijvers@cs.kuleuven.be
% copyright: K.U.Leuven, 2004
:- module(chr_hashtable_store,
[ new_ht/1,
lookup_ht/3,
lookup_ht1/4,
lookup_ht2/4,
insert_ht/3,
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(hprolog).
:- use_module(library(lists)).
:- multifile user:goal_expansion/2.
:- dynamic user:goal_expansion/2.
user:goal_expansion(term_hash(Term,Hash),hash_term(Term,Hash)).
% term_hash(Term,Hash) :-
% hash_term(Term,Hash).
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
)
).
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
).

136
LGPL/chr/chr_integertable_store.pl
View File

@ -1,136 +0,0 @@
/* $Id: chr_integertable_store.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
% is it safe to use nb_setarg here?
:- 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(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)
).

173
LGPL/chr/chr_messages.pl
View File

@ -1,173 +0,0 @@
/* $Id: chr_messages.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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 ].
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 ]. % 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
LGPL/chr/chr_op.pl
View File

@ -1,50 +0,0 @@
/* $Id: chr_op.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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
LGPL/chr/chr_op2.pl
View File

@ -1,51 +0,0 @@
/* $Id: chr_op2.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% 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, --->).

902
LGPL/chr/chr_runtime.pl
View File

@ -1,902 +0,0 @@
/* $Id: chr_runtime.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
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
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- 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 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(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).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
locked:attr_unify_hook(_,_) :- fail.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'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).
'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
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 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).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
constraint_generation( Susp, State, Generation) :-
arg( 2, Susp, Mref), % ARGXXX
'chr get_mutable'( State, Mref),
arg( 4, Susp, Gref), % ARGXXX
'chr get_mutable'( Generation, Gref). % not incremented meanwhile
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'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(debug, chr(prompt)),
get_single_char(CharCode),
( CharCode == -1
-> Char = end_of_file
; char_code(Char, CharCode)
),
( debug_command(Char, Command)
-> print_message(debug, 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(debug, chr(ancestors(History, Depth))).
print_event(Event, Depth) :-
print_message(debug, 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).

438
LGPL/chr/chr_swi.pl
View File

@ -1,438 +0,0 @@
/* $Id: chr_swi.pl,v 1.6 2008-03-31 22:56:21 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
%% SWI begin
:- 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).
:- if(current_prolog_flag(dialect, yap)).
:- hide(atomic_concat).
:- endif.
:- 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)) % no need to restore; file ends
,(:- 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(file,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(file,File),
assert(chr_pp(File, Preprocessor)).
chr_expand(end_of_file, FinalProgram) :-
extra_declarations(FinalProgram,Program),
prolog_load_context(file,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).
/*******************************
* TOPLEVEL PRINTING *
*******************************/
:- set_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 user:term_expansion/2.
:- dynamic user:term_expansion/2.
user:term_expansion(In, Out) :-
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).

202
LGPL/chr/chr_swi_bootstrap.pl
View File

@ -1,202 +0,0 @@
/* $Id: chr_swi_bootstrap.pl,v 1.4 2008-03-13 17:43:13 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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
:- if(current_prolog_flag(dialect, yap)).
:- hide(atomic_concat).
:- endif.
:- expects_dialect(swi).
:- use_module(library(listing)). % portray_clause/2
%% 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))|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),
% vsc: this is a string
format(Out, ' Date: ~s~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

13
LGPL/chr/chr_swi_bootstrap.yap
View File

@ -1,13 +0,0 @@
:- multifile user:file_search_path/2.
:- add_to_path('.').
:- use_module(library(swi)).
:- yap_flag(unknown,error).
:- include('chr_swi_bootstrap.pl').

13
LGPL/chr/chr_swi_bootstrap.yap.in
View File

@ -1,13 +0,0 @@
:- multifile user:file_search_path/2.
:- add_to_path('@srcdir@').
:- use_module(library(swi)).
:- yap_flag(unknown,error).
:- include('chr_swi_bootstrap.pl').

170
LGPL/chr/chr_test.pl
View File

@ -1,170 +0,0 @@
/* $Id: chr_test.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- 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,
run_scripts(Files),
format(' done~n').
run_scripts([]).
run_scripts([H|T]) :-
( catch(run_test_script(H), Except, true)
-> ( var(Except)
-> put(.), flush
; Except = blocked(Reason)
-> assert(blocked(H, Reason)),
put(!), flush
; 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)).

10791
LGPL/chr/chr_translate.chr
View File

File diff suppressed because it is too large Load Diff

21472
LGPL/chr/chr_translate.pl
View File

File diff suppressed because it is too large Load Diff

2508
LGPL/chr/chr_translate_bootstrap.pl
View File

File diff suppressed because it is too large Load Diff

2319
LGPL/chr/chr_translate_bootstrap1.chr
View File

File diff suppressed because it is too large Load Diff

3687
LGPL/chr/chr_translate_bootstrap2.chr
View File

File diff suppressed because it is too large Load Diff

224
LGPL/chr/clean_code.pl
View File

@ -1,224 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ ____ _ _
%% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
%% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
%% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
%% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
%% |___/
%%
%%
%% To be done:
%% inline clauses
:- module(clean_code,
[
clean_clauses/2
]).
:- use_module(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]
).

75
LGPL/chr/find.pl
View File

@ -1,75 +0,0 @@
/* $Id: find.pl,v 1.3 2008-03-13 14:38:01 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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
LGPL/chr/guard_entailment.chr
View File

@ -1,511 +0,0 @@
:- module(guard_entailment,
[ entails_guard/2,
simplify_guards/5
]).
:- include(chr_op).
:- use_module(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.

18061
LGPL/chr/guard_entailment.pl
View File

File diff suppressed because it is too large Load Diff

192
LGPL/chr/hprolog.pl
View File

@ -1,192 +0,0 @@
:- module(hprolog,
[ substitute_eq/4, % +OldVal, +OldList, +NewVal, -NewList
memberchk_eq/2, % +Val, +List
intersect_eq/3, % +List1, +List2, -Intersection
list_difference_eq/3, % +List, -Subtract, -Rest
take/3, % +N, +List, -FirstElements
drop/3, % +N, +List, -LastElements
split_at/4, % +N, +List, -FirstElements, -LastElements
max_go_list/2, % +List, -Max
or_list/2, % +ListOfInts, -BitwiseOr
sublist/2, % ?Sublist, +List
bounded_sublist/3, % ?Sublist, +List, +Bound
chr_delete/3,
init_store/2,
get_store/2,
update_store/2,
make_get_store_goal/3,
make_update_store_goal/3,
make_init_store_goal/3,
empty_ds/1,
ds_to_list/2,
get_ds/3,
put_ds/4
% lookup_ht1/4
]).
:- use_module(library(lists)).
:- use_module(library(assoc)).
empty_ds(DS) :- empty_assoc(DS).
ds_to_list(DS,LIST) :- assoc_to_list(DS,LIST).
get_ds(A,B,C) :- get_assoc(A,B,C).
put_ds(A,B,C,D) :- put_assoc(A,B,C,D).
init_store(Name,Value) :- nb_setval(Name,Value).
get_store(Name,Value) :- nb_getval(Name,Value).
update_store(Name,Value) :- b_setval(Name,Value).
make_init_store_goal(Name,Value,Goal) :- Goal = nb_setval(Name,Value).
make_get_store_goal(Name,Value,Goal) :- Goal = nb_getval(Name,Value).
make_update_store_goal(Name,Value,Goal) :- Goal = b_setval(Name,Value).
/*******************************
* MORE LIST OPERATIONS *
*******************************/
% substitute_eq(+OldVal, +OldList, +NewVal, -NewList)
%
% Substitute OldVal by NewVal in OldList and unify the result
% with NewList.
substitute_eq(_, [], _, []) :- ! .
substitute_eq(X, [U|Us], Y, [V|Vs]) :-
( X == U
-> V = Y,
substitute_eq(X, Us, Y, Vs)
; V = U,
substitute_eq(X, Us, Y, Vs)
).
% memberchk_eq(+Val, +List)
%
% Deterministic check of membership using == rather than
% unification.
memberchk_eq(X, [Y|Ys]) :-
( X == Y
-> true
; memberchk_eq(X, Ys)
).
% :- load_foreign_library(chr_support).
% list_difference_eq(+List, -Subtract, -Rest)
%
% Delete all elements of Subtract from List and unify the result
% with Rest. Element comparision is done using ==/2.
list_difference_eq([],_,[]).
list_difference_eq([X|Xs],Ys,L) :-
( memberchk_eq(X,Ys)
-> list_difference_eq(Xs,Ys,L)
; L = [X|T],
list_difference_eq(Xs,Ys,T)
).
% intersect_eq(+List1, +List2, -Intersection)
%
% Determine the intersection of two lists without unifying values.
intersect_eq([], _, []).
intersect_eq([X|Xs], Ys, L) :-
( memberchk_eq(X, Ys)
-> L = [X|T],
intersect_eq(Xs, Ys, T)
; intersect_eq(Xs, Ys, L)
).
% take(+N, +List, -FirstElements)
%
% Take the first N elements from List and unify this with
% FirstElements. The definition is based on the GNU-Prolog lists
% library. Implementation by Jan Wielemaker.
take(0, _, []) :- !.
take(N, [H|TA], [H|TB]) :-
N > 0,
N2 is N - 1,
take(N2, TA, TB).
% Drop the first N elements from List and unify the remainder with
% LastElements.
drop(0,LastElements,LastElements) :- !.
drop(N,[_|Tail],LastElements) :-
N > 0,
N1 is N - 1,
drop(N1,Tail,LastElements).
split_at(0,L,[],L) :- !.
split_at(N,[H|T],[H|L1],L2) :-
M is N -1,
split_at(M,T,L1,L2).
% max_go_list(+List, -Max)
%
% Return the maximum of List in the standard order of terms.
max_go_list([H|T], Max) :-
max_go_list(T, H, Max).
max_go_list([], Max, Max).
max_go_list([H|T], X, Max) :-
( H @=< X
-> max_go_list(T, X, Max)
; max_go_list(T, H, Max)
).
% or_list(+ListOfInts, -BitwiseOr)
%
% Do a bitwise disjuction over all integer members of ListOfInts.
or_list(L, Or) :-
or_list(L, 0, Or).
or_list([], Or, Or).
or_list([H|T], Or0, Or) :-
Or1 is H \/ Or0,
or_list(T, Or1, Or).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
sublist(L, L).
sublist(Sub, [H|T]) :-
'$sublist1'(T, H, Sub).
'$sublist1'(Sub, _, Sub).
'$sublist1'([H|T], _, Sub) :-
'$sublist1'(T, H, Sub).
'$sublist1'([H|T], X, [X|Sub]) :-
'$sublist1'(T, H, Sub).
bounded_sublist(Sublist,_,_) :-
Sublist = [].
bounded_sublist(Sublist,[H|List],Bound) :-
Bound > 0,
(
Sublist = [H|Rest],
NBound is Bound - 1,
bounded_sublist(Rest,List,NBound)
;
bounded_sublist(Sublist,List,Bound)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
chr_delete([], _, []).
chr_delete([H|T], X, L) :-
( H==X ->
chr_delete(T, X, L)
; L=[H|RT],
chr_delete(T, X, RT)
).

105
LGPL/chr/listmap.pl
View File

@ -1,105 +0,0 @@
/* $Id: listmap.pl,v 1.3 2008-03-13 14:38:01 vsc Exp $
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(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)
).

106
LGPL/chr/pairlist.pl
View File

@ -1,106 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% _ _ _ _
%% _ __ __ _(_)_ __| (_)___| |_
%% | '_ \ / _` | | '__| | / __| __|
%% | |_) | (_| | | | | | \__ \ |_
%% | .__/ \__,_|_|_| |_|_|___/\__|
%% |_|
%%
%% * 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([], _, []).
pairlist_delete([K - V| KVs], Key, PL) :-
( Key = K ->
PL = KVs
;
PL = [ K - V | T ],
pairlist_delete(KVs, Key, T)
).
pairlist_delete_all([], _, []).
pairlist_delete_all([K - V| KVs], Key, PL) :-
( Key = K ->
pairlist_delete_all(KVs, Key, PL)
;
PL = [ K - V | T ],
pairlist_delete_all(KVs, Key, T)
).
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)
).
pairlist_delete_all_eq([], _, []).
pairlist_delete_all_eq([K - V| KVs], Key, PL) :-
( Key == K ->
pairlist_delete_all_eq(KVs, Key, PL)
;
PL = [ K - V | T ],
pairlist_delete_all_eq(KVs, Key, T)
).