diff --git a/.gitmodules b/.gitmodules index 7e16cd398..e69de29bb 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,42 +0,0 @@ -[submodule "packages/chr"] - path = packages/chr - url = git://git.code.sf.net/p/yap/chr -[submodule "packages/clpqr"] - path = packages/clpqr - url = git://git.code.sf.net/p/yap/clpqr -[submodule "packages/jpl"] - path = packages/jpl - url = git://git.code.sf.net/p/yap/jpl -[submodule "packages/zlib"] - path = packages/zlib - url = git://git.code.sf.net/p/yap/zlib -[submodule "packages/http"] - path = packages/http - url = git://git.code.sf.net/p/yap/http -[submodule "packages/clib"] - path = packages/clib - url = git://git.code.sf.net/p/yap/clib -[submodule "packages/sgml"] - path = packages/sgml - url = git://git.code.sf.net/p/yap/sgml -[submodule "packages/RDF"] - path = packages/RDF - url = git://git.code.sf.net/p/yap/RDF -[submodule "packages/semweb"] - path = packages/semweb - url = git://git.code.sf.net/p/yap/semweb -[submodule "packages/plunit"] - path = packages/plunit - url = git://git.code.sf.net/p/yap/plunit -[submodule "packages/archive"] - path = packages/archive - url = git://git.code.sf.net/p/yap/archive -[submodule "packages/odbc"] - path = packages/odbc - url = git://git.code.sf.net/p/yap/odbc -[submodule "packages/udi"] - path = packages/udi - url = https://github.com/vscosta/yap-udi-indexers.git -[submodule "packages/raptor"] - path = packages/raptor - url = git://git.code.sf.net/p/yap/raptor diff --git a/packages/RDF b/packages/RDF deleted file mode 160000 index f19e64df2..000000000 --- a/packages/RDF +++ /dev/null @@ -1 +0,0 @@ -Subproject commit f19e64df267c6dbaf3c4f93b44f2b1e343e4b449 diff --git a/packages/archive b/packages/archive deleted file mode 160000 index 2095a5f28..000000000 --- a/packages/archive +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 2095a5f288ae9cd6bed978295f78723a0ba62e6f diff --git a/packages/chr b/packages/chr deleted file mode 160000 index 0e7ab5c61..000000000 --- a/packages/chr +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 0e7ab5c61c1387b21fb64458be6e3534a493fb27 diff --git a/packages/chr/Benchmarks/benches.pl b/packages/chr/Benchmarks/benches.pl new file mode 100644 index 000000000..bb750915b --- /dev/null +++ b/packages/chr/Benchmarks/benches.pl @@ -0,0 +1,26 @@ +:- prolog_load_context(directory, Dir), + working_directory(_, Dir). + +benches :- + bench(B), + atom_concat(B, '.chr', File), + style_check(-singleton), + abolish(main,0), + abolish(main,1), + [File], +% (main;main;main;main), + main, + fail. +benches. + +bench(bool). +bench(fib). +bench(fibonacci). +bench(leq). +bench(primes). +bench(ta). +bench(wfs). +bench(zebra). + +cputime(Time) :- + statistics(runtime, [_,Time]). diff --git a/packages/chr/Benchmarks/bool.chr b/packages/chr/Benchmarks/bool.chr new file mode 100644 index 000000000..4dfabca06 --- /dev/null +++ b/packages/chr/Benchmarks/bool.chr @@ -0,0 +1,322 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Thom Fruehwirth ECRC 1991-1993 +%% 910528 started boolean,and,or constraints +%% 910904 added xor,neg constraints +%% 911120 added imp constraint +%% 931110 ported to new release +%% 931111 added card constraint +%% 961107 Christian Holzbaur, SICStus mods +%% +%% ported to hProlog by Tom Schrijvers June 2003 + + +:- module(bool,[main/0,main/1]). + +:- use_module( library(chr)). +:- use_module(library(lists)). + +:- chr_constraint boolean/1, and/3, or/3, xor/3, neg/2, imp/2, labeling/0, card/4. + + +boolean(0) <=> true. +boolean(1) <=> true. + +labeling, boolean(A)#Pc <=> +( A=0 ; A=1), +labeling +pragma passive(Pc). + + +%% and/3 specification +%%and(0,0,0). +%%and(0,1,0). +%%and(1,0,0). +%%and(1,1,1). + +and(0,X,Y) <=> Y=0. +and(X,0,Y) <=> Y=0. +and(1,X,Y) <=> Y=X. +and(X,1,Y) <=> Y=X. +and(X,Y,1) <=> X=1,Y=1. +and(X,X,Z) <=> X=Z. +%%and(X,Y,X) <=> imp(X,Y). +%%and(X,Y,Y) <=> imp(Y,X). +and(X,Y,A) \ and(X,Y,B) <=> A=B. +and(X,Y,A) \ and(Y,X,B) <=> A=B. + +labeling, and(A,B,C)#Pc <=> +label_and(A,B,C), +labeling +pragma passive(Pc). + +label_and(0,X,0). +label_and(1,X,X). + + +%% or/3 specification +%%or(0,0,0). +%%or(0,1,1). +%%or(1,0,1). +%%or(1,1,1). + +or(0,X,Y) <=> Y=X. +or(X,0,Y) <=> Y=X. +or(X,Y,0) <=> X=0,Y=0. +or(1,X,Y) <=> Y=1. +or(X,1,Y) <=> Y=1. +or(X,X,Z) <=> X=Z. +%%or(X,Y,X) <=> imp(Y,X). +%%or(X,Y,Y) <=> imp(X,Y). +or(X,Y,A) \ or(X,Y,B) <=> A=B. +or(X,Y,A) \ or(Y,X,B) <=> A=B. + +labeling, or(A,B,C)#Pc <=> +label_or(A,B,C), +labeling +pragma passive(Pc). + +label_or(0,X,X). +label_or(1,X,1). + + +%% xor/3 specification +%%xor(0,0,0). +%%xor(0,1,1). +%%xor(1,0,1). +%%xor(1,1,0). + +xor(0,X,Y) <=> X=Y. +xor(X,0,Y) <=> X=Y. +xor(X,Y,0) <=> X=Y. +xor(1,X,Y) <=> neg(X,Y). +xor(X,1,Y) <=> neg(X,Y). +xor(X,Y,1) <=> neg(X,Y). +xor(X,X,Y) <=> Y=0. +xor(X,Y,X) <=> Y=0. +xor(Y,X,X) <=> Y=0. +xor(X,Y,A) \ xor(X,Y,B) <=> A=B. +xor(X,Y,A) \ xor(Y,X,B) <=> A=B. + +labeling, xor(A,B,C)#Pc <=> +label_xor(A,B,C), +labeling +pragma passive(Pc). + +label_xor(0,X,X). +label_xor(1,X,Y):- neg(X,Y). + + +%% neg/2 specification +%%neg(0,1). +%%neg(1,0). + +neg(0,X) <=> X=1. +neg(X,0) <=> X=1. +neg(1,X) <=> X=0. +neg(X,1) <=> X=0. +neg(X,X) <=> fail. +neg(X,Y) \ neg(Y,Z) <=> X=Z. +neg(X,Y) \ neg(Z,Y) <=> X=Z. +neg(Y,X) \ neg(Y,Z) <=> X=Z. +%% Interaction with other boolean constraints +neg(X,Y) \ and(X,Y,Z) <=> Z=0. +neg(Y,X) \ and(X,Y,Z) <=> Z=0. +neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0. +neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0. +neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0. +neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0. +neg(X,Y) \ or(X,Y,Z) <=> Z=1. +neg(Y,X) \ or(X,Y,Z) <=> Z=1. +neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1. +neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1. +neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1. +neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1. +neg(X,Y) \ xor(X,Y,Z) <=> Z=1. +neg(Y,X) \ xor(X,Y,Z) <=> Z=1. +neg(X,Z) \ xor(X,Y,Z) <=> Y=1. +neg(Z,X) \ xor(X,Y,Z) <=> Y=1. +neg(Y,Z) \ xor(X,Y,Z) <=> X=1. +neg(Z,Y) \ xor(X,Y,Z) <=> X=1. +neg(X,Y) , imp(X,Y) <=> X=0,Y=1. +neg(Y,X) , imp(X,Y) <=> X=0,Y=1. + +labeling, neg(A,B)#Pc <=> +label_neg(A,B), +labeling +pragma passive(Pc). + +label_neg(0,1). +label_neg(1,0). + + +%% imp/2 specification (implication) +%%imp(0,0). +%%imp(0,1). +%%imp(1,1). + +imp(0,X) <=> true. +imp(X,0) <=> X=0. +imp(1,X) <=> X=1. +imp(X,1) <=> true. +imp(X,X) <=> true. +imp(X,Y),imp(Y,X) <=> X=Y. + +labeling, imp(A,B)#Pc <=> +label_imp(A,B), +labeling +pragma passive(Pc). + +label_imp(0,X). +label_imp(1,1). + + + +%% Boolean cardinality operator +%% card(A,B,L,N) constrains list L of length N to have between A and B 1s + + +card(A,B,L):- + length(L,N), + A= A=<0,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), 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]). diff --git a/packages/chr/Benchmarks/fib.chr b/packages/chr/Benchmarks/fib.chr new file mode 100644 index 000000000..541841872 --- /dev/null +++ b/packages/chr/Benchmarks/fib.chr @@ -0,0 +1,34 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 991202 Slim Abdennadher, LMU +%% +%% ported to hProlog by Tom Schrijvers + +:- module(fib,[main/0,main/1]). + +:- use_module(library(chr)). + +:- chr_constraint fib/2. + +%% fib(N,M) is true if M is the Nth Fibonacci number. + +%% Top-down Evaluation with Tabulation + +fib(N,M1), fib(N,M2) <=> M1 = M2, fib(N,M1). + +fib(0,M) ==> M = 1. + +fib(1,M) ==> M = 1. + +fib(N,M) ==> N > 1 | N1 is N-1, fib(N1,M1), N2 is N-2, fib(N2,M2), M is M1 + M2. + +main :- + main(22). + +main(N):- + cputime(X), + fib(N,_), + cputime( Now), + Time is Now-X, + write(bench(fib ,N,Time, 0, hprolog)),write('.'), nl. + diff --git a/packages/chr/Benchmarks/fibonacci.chr b/packages/chr/Benchmarks/fibonacci.chr new file mode 100644 index 000000000..7f43cd257 --- /dev/null +++ b/packages/chr/Benchmarks/fibonacci.chr @@ -0,0 +1,42 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- module(fibonacci,[main/0,main/1]). + +:- use_module(library(chr)). + +:- chr_constraint fibonacci/2. + +%% fibonacci(N,M) is true iff M is the Nth Fibonacci number. + +%% Top-down Evaluation with effective Tabulation +%% Contrary to the version in the SICStus manual, this one does "true" +%% tabulation + +fibonacci(N,M1) # ID \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(ID). + +fibonacci(0,M) ==> M = 1. + +fibonacci(1,M) ==> M = 1. + +fibonacci(N,M) ==> + N > 1 | + N1 is N-1, + fibonacci(N1,M1), + N2 is N-2, + fibonacci(N2,M2), + M is M1 + M2. + +main :- + main(2000). + +main(N):- + cputime(X), + fibonacci(N,_), + cputime( Now), + Time is Now-X, + write(bench(fibonacci ,N,Time, 0, hprolog)),write('.'), nl. + diff --git a/packages/chr/Benchmarks/fulladder.chr b/packages/chr/Benchmarks/fulladder.chr new file mode 100644 index 000000000..800b9148d --- /dev/null +++ b/packages/chr/Benchmarks/fulladder.chr @@ -0,0 +1,139 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Thom Fruehwirth ECRC 1991-1993 +%% 910528 started boolean,and,or constraints +%% 910904 added xor,neg constraints +%% 911120 added imp constraint +%% 931110 ported to new release +%% 931111 added card constraint +%% 961107 Christian Holzbaur, SICStus mods +%% +%% ported to hProlog by Tom Schrijvers June 2003 + + +:- module(fulladder,[main/0,main/1]). +:- use_module(library(chr)). + +:- chr_constraint and/3, or/3, xor/3, neg/2. + +:- use_module(library(lists)). + +%% and/3 specification +%%and(0,0,0). +%%and(0,1,0). +%%and(1,0,0). +%%and(1,1,1). + +and(0,X,Y) <=> Y=0. +and(X,0,Y) <=> Y=0. +and(1,X,Y) <=> Y=X. +and(X,1,Y) <=> Y=X. +and(X,Y,1) <=> X=1,Y=1. +and(X,X,Z) <=> X=Z. +and(X,Y,A) \ and(X,Y,B) <=> A=B, chr_dummy. +and(X,Y,A) \ and(Y,X,B) <=> A=B, chr_dummy. + +%% or/3 specification +%%or(0,0,0). +%%or(0,1,1). +%%or(1,0,1). +%%or(1,1,1). + +or(0,X,Y) <=> Y=X. +or(X,0,Y) <=> Y=X. +or(X,Y,0) <=> X=0,Y=0. +or(1,X,Y) <=> Y=1. +or(X,1,Y) <=> Y=1. +or(X,X,Z) <=> X=Z. +or(X,Y,A) \ or(X,Y,B) <=> A=B, chr_dummy. +or(X,Y,A) \ or(Y,X,B) <=> A=B, chr_dummy. + +%% xor/3 specification +%%xor(0,0,0). +%%xor(0,1,1). +%%xor(1,0,1). +%%xor(1,1,0). + +xor(0,X,Y) <=> X=Y. +xor(X,0,Y) <=> X=Y. +xor(X,Y,0) <=> X=Y. +xor(1,X,Y) <=> neg(X,Y). +xor(X,1,Y) <=> neg(X,Y). +xor(X,Y,1) <=> neg(X,Y). +xor(X,X,Y) <=> Y=0. +xor(X,Y,X) <=> Y=0. +xor(Y,X,X) <=> Y=0. +xor(X,Y,A) \ xor(X,Y,B) <=> A=B, chr_dummy. +xor(X,Y,A) \ xor(Y,X,B) <=> A=B, chr_dummy. + +%% neg/2 specification +%%neg(0,1). +%%neg(1,0). + +neg(0,X) <=> X=1. +neg(X,0) <=> X=1. +neg(1,X) <=> X=0. +neg(X,1) <=> X=0. +neg(X,X) <=> fail. +neg(X,Y) \ neg(Y,Z) <=> X=Z, chr_dummy. +neg(X,Y) \ neg(Z,Y) <=> X=Z, chr_dummy. +neg(Y,X) \ neg(Y,Z) <=> X=Z, chr_dummy. +%% Interaction with other boolean constraints +neg(X,Y) \ and(X,Y,Z) <=> Z=0, chr_dummy. +neg(Y,X) \ and(X,Y,Z) <=> Z=0, chr_dummy. +neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0. +neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0. +neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0. +neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0. +neg(X,Y) \ or(X,Y,Z) <=> Z=1, chr_dummy. +neg(Y,X) \ or(X,Y,Z) <=> Z=1, chr_dummy. +neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1. +neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1. +neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1. +neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1. +neg(X,Y) \ xor(X,Y,Z) <=> Z=1, chr_dummy. +neg(Y,X) \ xor(X,Y,Z) <=> Z=1, chr_dummy. +neg(X,Z) \ xor(X,Y,Z) <=> Y=1, chr_dummy. +neg(Z,X) \ xor(X,Y,Z) <=> Y=1, chr_dummy. +neg(Y,Z) \ xor(X,Y,Z) <=> X=1, chr_dummy. +neg(Z,Y) \ xor(X,Y,Z) <=> X=1, chr_dummy. + +/* end of handler bool */ + +half_adder(X,Y,S,C) :- + xor(X,Y,S), + and(X,Y,C). + +full_adder(X,Y,Ci,S,Co) :- + half_adder(X,Y,S1,Co1), + half_adder(Ci,S1,S,Co2), + or(Co1,Co2,Co). + +main :- + main(6000). + +main(N) :- + cputime(X), + adder(N), + cputime(Now), + Time is Now - X, + write(bench(bool ,N,Time,0,hprolog)),write('.'),nl. + +adder(N) :- + length(Ys,N), + add(N,Ys). + +add(N,[Y|Ys]) :- + half_adder(1,Y,0,C), + add0(Ys,C). + +add0([],1). +add0([Y|Ys],C) :- + full_adder(0,Y,C,1,NC), + add1(Ys,NC). + +add1([],0). +add1([Y|Ys],C) :- + full_adder(1,Y,C,0,NC), + add0(Ys,NC). + diff --git a/packages/chr/Benchmarks/leq.chr b/packages/chr/Benchmarks/leq.chr new file mode 100644 index 000000000..1f82f70b6 --- /dev/null +++ b/packages/chr/Benchmarks/leq.chr @@ -0,0 +1,34 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% simple constraint solver for inequalities between variables +%% thom fruehwirth ECRC 950519, LMU 980207, 980311 +%% +%% ported to hProlog by Tom Schrijvers + +:- module(leq,[main/0,main/1]). +:- use_module(library(chr)). + +:- chr_constraint leq/2. + +reflexivity @ leq(X,X) <=> true. +antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. +idempotence @ leq(X,Y) \ leq(X,Y) <=> true. +transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). + +main :- + main(60). + +main(N):- + cputime(X), + length(L,N), + genleq(L,Last), + L=[First|_], + leq(Last,First), + cputime( Now), + Time is Now-X, + write(bench(leq ,N,Time,0,hprolog)), write('.'),nl. + +genleq([Last],Last) :- ! . +genleq([X,Y|Xs],Last):- + leq(X,Y), + genleq([Y|Xs],Last). diff --git a/packages/chr/Benchmarks/primes.chr b/packages/chr/Benchmarks/primes.chr new file mode 100644 index 000000000..7cd481c2b --- /dev/null +++ b/packages/chr/Benchmarks/primes.chr @@ -0,0 +1,29 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Sieve of eratosthenes to compute primes +%% thom fruehwirth 920218-20, 980311 +%% christian holzbaur 980207 for Sicstus CHR +%% +%% ported to hProlog by Tom Schrijvers + +:- module(primes,[main/0,main/1]). +:- use_module(library(chr)). + +:- chr_constraint candidate/1. +:- chr_constraint prime/1. + +candidate(1) <=> true. +candidate(N) <=> primes:prime(N), N1 is N - 1, primes:candidate(N1). + +absorb @ prime(Y) \ prime(X) <=> 0 =:= X mod Y | true. + +main :- + main(2500). + +main(N):- + cputime(X), + candidate(N), + cputime( Now), + Time is Now-X, + write(bench(primes ,N,Time,0,hprolog)), write('.'),nl. + diff --git a/packages/chr/Benchmarks/ta.chr b/packages/chr/Benchmarks/ta.chr new file mode 100644 index 000000000..69e45143a --- /dev/null +++ b/packages/chr/Benchmarks/ta.chr @@ -0,0 +1,381 @@ +:- module(ta,[main/0,main/1]). + +:- use_module(library(chr)). +:- use_module(library(lists)). + +/* + + Timed automaton => Constraints + + => + + X := N geq(X,N) + --------> + + X =< N leq(X,N) + --------> + + X >= N geq(X,N) + --------> + + +n > 1, 1 ------> v fincl(Xv,X1), + ... / ... + n ----/ fincl(Xv,Xn), + fub_init(Xv,[]) + +n >= 1, v ------> 1 bincl(Xv,X1), + \ ... ... + \----> n bincl(Xv,X1), + bub_init(Xv,[]) +*/ + +%% handler ta. + +:- chr_constraint + + fincl/2, % expresses that clock 1 includes clock 2 (union) + % in the sense that clock 2 is forward of clock 1 + + bincl/2, % expresses that clock 1 includes clock 2 (union) + % in the sense that clock 1 is forward of clock 2 + + leq/2, % expresses that clock 1 =< number 2 + + geq/2, % expresses that clock 1 >= number 2 + + fub_init/2, % collects the inital upper bounds + % from incoming arrows for clock 1 in list 2 + + fub/2, % collects the upper bounds for clock 1 + % from incoming arrows in list 2 + + flb_init/2, % collects the inital lower bounds + % from incoming arrows for clock 1 in list 2 + + flb/2, % collects the lower bounds for clock 1 + % from incoming arrows in list 2 + + bub_init/2, % collects the inital upper bounds + % from backward arrows for clock 1 in list 2 + + bub/2, % collects the upper bounds for clock 1 + % from outgoing arrows in list 2 + % values of clock 1 cannot exceed all + % values of the clocks in list 2 + + blb_init/2, % collects the inital lower bounds + % from backward arrows for clock 1 in list 2 + + blb/2, % collects the lower bounds for clock 1 + % from outgoing arrows in list 2 + % not all values of clock 1 can exceed any + % values of the clocks in list 2 + + compl/1, % indicate that all incoming arrows for clock 1 + % have been registerd + + dist/3, % indicates that clock 1 - clock 2 =< number 3 + + fdist_init/3, % records initial distances for clock 1 and clock 2 from + % incoming arrows in list 3 + + fdist/3, % records distances for clock 1 and clock 2 from + % incoming arrows in list 3 + + setdist/3. % sets distance between clock 1 and clock 2, where + % clock 1 is reset to value 3 + +/* More Constraints: + +*/ + +leq(X,N1) \ leq(X,N2) <=> N1 =< N2 | true. + +geq(X,N1) \ geq(X,N2) <=> N2 =< N1 | true. + +dist(X,Y,D1) \ dist(X,Y,D2) <=> D1 =< D2 | true. + +dist(X,Y,D), leq(Y,MY) \ leq(X,MX1) <=> + MX2 is MY + D, MX2 < MX1 | leq(X,MX2). + +dist(X,Y,D), geq(X,MX) \ geq(Y,MY1) <=> + MY2 is MX - D, MY2 > MY1 | geq(Y,MY2). + +fincl(X,Y), leq(Y,N) \ fub_init(X,L) + <=> \+ memberchk_eq(N-Y,L) | + insert_ub(L,Y,N,NL), + fub_init(X,NL). + +fincl(X,Y), geq(Y,N) \ flb_init(X,L) + <=> \+ memberchk_eq(N-Y,L) | + insert_lb(L,Y,N,NL), + flb_init(X,NL). + +dist(X1,Y1,D), fincl(X2,X1), fincl(Y2,Y1) \ fdist_init(X2,Y2,L) + <=> + \+ memberchk_eq(D-X1,L) | + insert_ub(L,X1,D,NL), + fdist_init(X2,Y2,NL). + +bincl(X,Y), leq(Y,N) \ bub_init(X,L) + <=> + \+ memberchk_eq(N-Y,L) | + insert_ub(L,Y,N,NL), + bub_init(X,NL). + +compl(X) \ fub_init(X,L) # ID + <=> + fub(X,L), + val(L,M), + leq(X,M) + pragma passive(ID). + +compl(X) \ flb_init(X,L) # ID + <=> + flb(X,L), + val(L,M), + geq(X,M) + pragma passive(ID). + +compl(X), compl(Y) \ fdist_init(X,Y,L) # ID + <=> + fdist(X,Y,L), + val(L,D), + dist(X,Y,D) + pragma passive(D). + +compl(X) \ bub_init(X,L) # ID + <=> + bub(X,L), + val(L,M), + leq(X,M) + pragma passive(ID). + +fincl(X,Y), leq(Y,N) \ fub(X,L) + <=> + \+ memberchk_eq(N-Y,L) | + insert_ub(L,Y,N,NL), + fub(X,NL), + val(NL,M), + leq(X,M). + +fincl(X,Y), geq(Y,N) \ flb(X,L) + <=> + \+ memberchk_eq(N-Y,L) | + insert_lb(L,Y,N,NL), + flb(X,NL), + val(NL,M), + geq(X,M). + +bincl(X,Y), leq(Y,N) \ bub(X,L) + <=> + \+ memberchk_eq(N-Y,L) | + insert_ub(L,Y,N,NL), + bub(X,NL), + val(NL,M), + leq(X,M). + +fincl(X2,X1), fincl(Y2,Y1), dist(X1,Y1,D) \ fdist(X2,Y2,L) + <=> + \+ memberchk_eq(D-X1,L) | + insert_ub(L,X1,D,NL), + fdist(X2,Y2,NL), + val(NL,MD), + dist(X2,Y2,MD). + +fincl(X,Y), leq(X,N) ==> leq(Y,N). + +fincl(X,Y), geq(X,N) ==> geq(Y,N). + +bincl(X,Y), geq(X,N) ==> geq(Y,N). + +bincl(X1,X2), bincl(Y1,Y2), dist(X1,Y1,D1) \ dist(X2,Y2,D2) <=> D1 < D2 | dist(X2,Y2,D1). + +setdist(X,Y,N), leq(Y,D1) ==> D2 is D1 - N, dist(Y,X,D2). +setdist(X,Y,N), geq(Y,D1) ==> D2 is N - D1, dist(X,Y,D2). + +val([N-_|_],N). + +insert_ub([],X,N,[N-X]). +insert_ub([M-Y|R],X,N,NL) :- + ( Y == X -> + insert_ub(R,X,N,NL) + ; M > N -> + NL = [M-Y|NR], + insert_ub(R,X,N,NR) + ; + NL = [N-X,M-Y|R] + ). + +insert_lb([],X,N,[N-X]). +insert_lb([M-Y|R],X,N,NL) :- + ( Y == X -> + insert_lb(R,X,N,NL) + ; M < N -> + NL = [M-Y|NR], + insert_lb(R,X,N,NR) + ; + NL = [N-X,M-Y|R] + ). + +couple(X,Y) :- + dist(X,Y,10000), + dist(Y,X,10000). + +giri :- + giri([x1,y1,x2,y2,x3,y3,x4,y4,x5,y5,x6,y6,x7,y7,x8,y8,x9,y9,x10,y10]). + +giri(L) :- + L = [X1,Y1,X2,Y2,X3,Y3,X4,Y4,X5,Y5,X6,Y6,X7,Y7,X8,Y8,X9,Y9,X10,Y10], + clocks(L), + + % 1. + couple(X1,Y1), + geq(X1,0), + geq(X2,0), + dist(X1,Y1,0), + dist(Y1,X1,0), + + % 2. + couple(X2,Y2), + + fincl(X2,X1), + fincl(X2,X8), + fincl(X2,X10), + fub_init(X2,[]), + flb_init(X2,[]), + + fincl(Y2,Y1), + fincl(Y2,Y8), + fincl(Y2,Y10), + fub_init(Y2,[]), + flb_init(Y2,[]), + + bincl(X2,X3), + bincl(X2,X4), + bub_init(X2,[]), + blb_init(X2,[]), + + bincl(Y2,Y3), + bincl(Y2,Y4), + bub_init(Y2,[]), + blb_init(Y2,[]), + + fdist_init(X2,Y2,[]), + fdist_init(Y2,X2,[]), + + % 3. + couple(X3,Y3), + leq(X3,3), + + bincl(X3,X9), + bincl(X3,X5), + bub_init(X3,[]), + blb_init(X3,[]), + + bincl(Y3,Y9), + bincl(Y3,Y5), + bub_init(Y3,[]), + blb_init(Y3,[]), + + %fdist_init(X3,Y3,[]), + %fdist_init(Y3,X3,[]), + + % 4. + couple(X4,Y4), + geq(Y4,2), + leq(Y4,5), + + % 5. + couple(X5,Y5), + geq(Y5,5), + leq(Y5,10), + + % 6. + couple(X6,Y6), + + fincl(X6,X4), + fincl(X6,X5), + fub_init(X6,[]), + flb_init(X6,[]), + + fincl(Y6,Y4), + fincl(Y6,Y5), + fub_init(Y6,[]), + flb_init(Y6,[]), + + bincl(X6,X7), + bub_init(X6,[]), + + bincl(Y6,Y7), + bub_init(Y6,[]), + + fdist_init(X6,Y6,[]), + fdist_init(Y6,X6,[]), + + % 7. + couple(X7,Y7), + geq(Y7,15), + leq(Y7,15), + + % 8. + couple(X8,Y8), + geq(X8,2), + geq(Y8,2), + dist(X8,Y8,0), + dist(Y8,X8,0), + + % 9. + couple(X9,Y9), + geq(Y9,5), + leq(Y9,5), + + + % 10. + couple(X10,Y10), + geq(X10,0), + geq(Y10,0), + dist(X10,Y10,0), + dist(Y10,X10,0), + + % finish + compl(X2), + compl(Y2), + + compl(X3), + compl(Y3), + + compl(X6), + compl(Y6). + + + +clocks([]). +clocks([C|Cs]) :- + clock(C), + clocks(Cs). + +clock(X) :- + geq(X,0), + leq(X,10000). + +main :- + main(100). + +main(N) :- + cputime(T1), + loop(N), + cputime(T2), + T is T2 - T1, + write(bench(ta ,N , T,0,hprolog)),write('.'),nl. + + +loop(N) :- + ( N =< 0 -> + true + ; + ( giri, fail ; true), + M is N - 1, + loop(M) + ). diff --git a/packages/chr/Benchmarks/wfs.chr b/packages/chr/Benchmarks/wfs.chr new file mode 100644 index 000000000..a06365642 --- /dev/null +++ b/packages/chr/Benchmarks/wfs.chr @@ -0,0 +1,262 @@ +:- module(wfs,[main/0, main/1]). + +:- use_module(library(chr)). +:- use_module(library(lists)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Schrijf het programma waarvan je de wellfounded semantics wil bepalen +% hieronder onder de vorm van prog/1 feiten. Let erop dat je een conjunctie +% in de body tussen haakjes zet zodat prog/1 geparsed wordt, ipv prog/n. + +/* + +prog(p :- p). + +prog(p :- \+ p). + + +prog(p :- (q, \+ r)). +prog(q :- (r, \+ p)). +prog(r :- (p, \+ q)). + +prog(p :- r). +prog(r :- q). +prog(q :- \+ q). + +prog(p :- r). +prog(r). + +prog(p :- p). +prog(s :- \+ p). +prog(y :- (s, \+ x)). +prog(x :- y). +*/ +prog(a :- a). +prog(b :- b). +prog(b :- \+ a). +prog(c :- \+ b). +prog(c :- c). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +:- chr_constraint true/1, false/1, undefined/1, aclause/2, pos/2, neg/2, nbulit/2, nbplit/2, nbucl/2, phase2/0, true2/1, undefined2/1, aclause2/2, pos2/2, nbplit2/2, phase1/0, witness1/0, witness2/0. + +true(At), aclause(Cl,At) \ pos(_,Cl) <=> true. + +true(At), aclause(Cl,At) \ neg(_,Cl) <=> true. + +false(At), aclause(Cl,At) \ pos(_,Cl) <=> true. + +false(At), aclause(Cl,At) \ neg(_,Cl) <=> true. + +true(At) \ nbucl(At,_) <=> true. + +true(At) \ aclause(Cl,At), nbulit(Cl,_), nbplit(Cl,_) <=> true. + +false(At) \ nbucl(At,_) <=> true. + +nbucl(At,0) <=> false(At). + +aclause(Cl,At), nbulit(Cl,0), nbplit(Cl,0) <=> true(At). + +true(At) \ pos(At,Cl), nbulit(Cl,NU), nbplit(Cl,NP) + <=> + NU1 is NU - 1, nbulit(Cl,NU1), + NP1 is NP - 1, nbplit(Cl,NP1). + +false(At) \ neg(At,Cl), nbulit(Cl,NU) + <=> + NU1 is NU - 1, nbulit(Cl,NU1). + +true(At) \ neg(At,Cl), aclause(Cl,OAt), nbulit(Cl,_), nbplit(Cl,_), nbucl(OAt,N) + <=> + N1 is N - 1, nbucl(OAt,N1). + +false(At) \ pos(At,Cl), aclause(Cl,OAt), nbulit(Cl,_), nbplit(Cl,_), nbucl(OAt,N) + <=> + N1 is N - 1, nbucl(OAt,N1). + +witness2 \ witness2 <=> true. +phase2, nbucl(At,_) ==> witness2, undefined2(At). +phase2, pos(At,Cl) ==> pos2(At,Cl). +phase2, aclause(Cl,At) ==> aclause2(Cl,At). +phase2, nbplit(Cl,N) ==> nbplit2(Cl,N). +phase2, witness2 # ID <=> phase1 pragma passive(ID). +phase2 \ nbplit2(_,_) # ID <=> true pragma passive(ID). +phase2 \ aclause2(_,_) # ID <=> true pragma passive(ID). +phase2 <=> true. + + +true2(At), aclause2(Cl,At) \ pos2(_,Cl) <=> true. +true2(At) \ undefined2(At) <=> true. +aclause2(Cl,At), nbplit2(Cl,0) <=> true2(At). +true2(At) \ pos2(At,Cl), nbplit2(Cl,NP) + <=> + NP1 is NP - 1, nbplit2(Cl,NP1). + +witness1 \ witness1 <=> true. +phase1, undefined2(At) # ID1 , aclause(Cl,At) # ID2 \ pos(_,Cl) # ID3 <=> true pragma passive(ID1), passive(ID2), passive(ID3). +phase1, undefined2(At) # ID1 , aclause(Cl,At) # ID2 \ neg(_,Cl) # ID3 <=> true pragma passive(ID1), passive(ID2), passive(ID3). +phase1, undefined2(At) # ID1 \ aclause(Cl,At) # ID2 , nbulit(Cl,_) # ID3, nbplit(Cl,_) # ID4 <=> true pragma passive(ID1), passive(ID2), passive(ID3), passive(ID4). +phase1 \ undefined2(At) # ID <=> witness1, false(At) pragma passive(ID). +phase1 \ true2(_) # ID <=> true pragma passive(ID). +phase1 \ aclause2(_,_) <=> true. +phase1 \ pos2(_,_) # ID <=> true pragma passive(ID). +phase1 \ nbplit2(_,_) # ID <=> true pragma passive(ID). +phase1, witness1 # ID <=> phase2 pragma passive(ID). +phase1 \ nbucl(At,_) # ID <=> undefined(At) pragma passive(ID). +phase1 \ pos(_,_) # ID <=> true. +phase1 \ neg(_,_) # ID <=> true pragma passive(ID). +phase1 \ aclause(_,_) # ID <=> true pragma passive(ID). +phase1 \ nbulit(_,_) # ID <=> true pragma passive(ID). +phase1 \ nbplit(_,_) # ID <=> true pragma passive(ID). +phase1 <=> true. + +/* + p :- r. + r. +*/ +program1 :- + nbucl(p,1), % aantal undefined clauses voor p + pos(r,cl1), % positief voorkomen van r in clause cl1 + aclause(cl1,p), % clause cl1 defineert p + nbulit(cl1,1), % aantal undefined literals in cl1 + nbplit(cl1,1), % aantal positieve undefined literals in cl1 + nbucl(r,1), + aclause(cl2,r), + nbulit(cl2,0), + nbplit(cl2,0). + +/* + p :- not r. + r. +*/ +program2 :- + nbucl(p,1), + neg(r,cl1), + aclause(cl1,p), + nbulit(cl1,1), + nbplit(cl1,1), + nbucl(r,1), + aclause(cl2,r), + nbulit(cl2,0), + nbplit(cl2,0). + +/* + p :- p. +*/ +program3 :- + nbucl(p,1), + pos(p,cl1), + aclause(cl1,p), + nbulit(cl1,1), + nbplit(cl1,1). + +/* + p :- not p. +*/ +program4 :- + nbucl(p,1), + neg(p,cl1), + aclause(cl1,p), + nbulit(cl1,1), + nbplit(cl1,0). + +/* + p :- q, not r. + q :- r, not p. + r :- p, not q. +*/ + +program5 :- + nbucl(p,1), + pos(p,cl3), + neg(p,cl2), + aclause(cl1,p), + nbulit(cl1,2), + nbplit(cl1,1), + nbucl(q,1), + pos(q,cl1), + neg(q,cl3), + aclause(cl2,q), + nbulit(cl2,2), + nbplit(cl2,1), + nbucl(r,1), + pos(r,cl2), + neg(r,cl1), + aclause(cl3,r), + nbulit(cl3,2), + nbplit(cl3,1). + + +main :- + main(1000). + +main(N) :- + cputime(T1), + loop(N), + cputime(T2), + T is T2 - T1, + write(bench(wfs ,N , T,0,hprolog)),write('.'),nl. + +loop(N) :- + ( N =< 0 -> + true + ; + ( prog, fail ; true), + M is N - 1, + loop(M) + ). + +prog :- + findall(Clause,wfs:prog(Clause),Clauses), + process(Clauses,1), + setof(At,B^(wfs:prog(At :- B) ; wfs:prog(At), atom(At)),Ats), + process_atoms(Ats), + phase2. + +process([],_). +process([C|Cs],N) :- + ( C = (HAt :- B) -> + aclause(N,HAt), + conj2list(B,Literals,[]), + process_literals(Literals,N,NbULit,NbPLit), + nbulit(N,NbULit), + nbplit(N,NbPLit) + ; + C = HAt, + aclause(N,HAt), + nbulit(N,0), + nbplit(N,0) + ), + N1 is N + 1, + process(Cs,N1). + +conj2list(G,L,T) :- + ( G = (G1,G2) -> + conj2list(G1,L,T1), + conj2list(G2,T1,T) + ; + L = [G|T] + ). + +process_literals([],_,0,0). +process_literals([L|R],Cl,U,P) :- + process_literals(R,Cl,U1,P1), + ( L = (\+ At) -> + neg(At,Cl), + P = P1, + U is U1 + 1 + ; + pos(L,Cl), + P is P1 + 1, + U is U1 + 1 + ). + +process_atoms([]). +process_atoms([A|As]) :- + findall(A,wfs:prog(A :- _),L), + length(L,N), + nbucl(A,N), + process_atoms(As). diff --git a/packages/chr/Benchmarks/zebra.chr b/packages/chr/Benchmarks/zebra.chr new file mode 100644 index 000000000..489b9ca9d --- /dev/null +++ b/packages/chr/Benchmarks/zebra.chr @@ -0,0 +1,127 @@ +:- module(zebra,[main/0, main/1]). + +:- use_module(library(chr)). +:- use_module(library(lists)). + +/* +1. The Englishman lives in the red house. +2. The Spaniard owns the dog. +3. Coffee is drunk in the green house. +4. The Ukrainian drinks tea. +5. The green house is immediately to the right of the ivory house. +6. The Porsche driver owns snails. +7. The Masserati is driven by the man who lives in the yellow house. +8. Milk is drunk in the middle house. +9. The Norwegian lives in the first house on the left. +10. The man who drives a Saab lives in the house next to the man + with the fox. +11. The Masserati is driven by the man in the house next to the + house where the horse is kept. +12. The Honda driver drinks orange juice. +13. The Japanese drives a Jaguar. +14. The Norwegian lives next to the blue house. +*/ + +:- chr_constraint domain/2, diff/2. + +domain(_,[]) <=> fail. +domain(X,[V]) <=> X = V. +domain(X,L1), domain(X,L2) <=> intersection(L1,L2,L3), domain(X,L3). + +diff(X,Y), domain(X,L) <=> nonvar(Y) | delete(L,Y,NL), domain(X,NL). +diff(X,Y) <=> nonvar(X), nonvar(Y) | X \== Y. + +all_different([]). +all_different([H|T]) :- + all_different(T,H), + all_different(T). + +all_different([],_). +all_different([H|T],E) :- + diff(H,E), + diff(E,H), + all_different(T,E). + +main :- + main(10). + +main(N):- + statistics(cputime, X), + test(N), + statistics(cputime, Now), + Time is Now-X, + write(bench(zebra, N,Time,0,hprolog)), write('.'),nl. + +test(N) :- + ( N > 0 -> + solve,!, + M is N - 1, + test(M) + ; + true + ). + +solve :- + [ [ ACo, AN, ACa, AD, AP ], + [ BCo, BN, BCa, BD, BP ], + [ CCo, CN, CCa, CD, CP ], + [ DCo, DN, DCa, DD, DP ], + [ ECo, EN, ECa, ED, EP ] ] = S, + domain(ACo,[red,green,ivory,yellow,blue]), + domain(BCo,[red,green,ivory,yellow,blue]), + domain(CCo,[red,green,ivory,yellow,blue]), + domain(DCo,[red,green,ivory,yellow,blue]), + domain(ECo,[red,green,ivory,yellow,blue]), + domain(AN ,[english,spanish,ukranian,norwegian,japanese]), + domain(BN ,[english,spanish,ukranian,norwegian,japanese]), + domain(CN ,[english,spanish,ukranian,norwegian,japanese]), + domain(DN ,[english,spanish,ukranian,norwegian,japanese]), + domain(EN ,[english,spanish,ukranian,norwegian,japanese]), + domain(ACa,[porsche,masserati,saab,honda,jaguar]), + domain(BCa,[porsche,masserati,saab,honda,jaguar]), + domain(CCa,[porsche,masserati,saab,honda,jaguar]), + domain(DCa,[porsche,masserati,saab,honda,jaguar]), + domain(ECa,[porsche,masserati,saab,honda,jaguar]), + domain(AD ,[coffee,tea,milk,orange,water]), + domain(BD ,[coffee,tea,milk,orange,water]), + domain(CD ,[coffee,tea,milk,orange,water]), + domain(DD ,[coffee,tea,milk,orange,water]), + domain(ED ,[coffee,tea,milk,orange,water]), + domain(AP ,[dog,snails,fox,horse,zebra]), + domain(BP ,[dog,snails,fox,horse,zebra]), + domain(CP ,[dog,snails,fox,horse,zebra]), + domain(DP ,[dog,snails,fox,horse,zebra]), + domain(EP ,[dog,snails,fox,horse,zebra]), + all_different([ACo,BCo,CCo,DCo,ECo]), + all_different([AN ,BN ,CN ,DN ,EN ]), + all_different([ACa,BCa,CCa,DCa,ECa]), + all_different([AD ,BD ,CD ,DD ,ED ]), + all_different([AP ,BP ,CP ,DP ,EP ]), + [_,_,[_,_,_,milk,_],_,_] = S, % clue 8 + [[_,norwegian,_,_,_],_,_,_,_] = S , % clue 9 + member( [green,_,_,coffee,_], S), % clue 3 + member( [red,english,_,_,_], S), % clue 1 + member( [_,ukranian,_,tea,_], S), % clue 4 + member( [yellow,_,masserati,_,_], S), % clue 7 + member( [_,_,honda,orange,_], S), % clue 12 + member( [_,japanese,jaguar,_,_], S), % clue 13 + member( [_,spanish,_,_,dog], S), % clue 2 + member( [_,_,porsche,_,snails], S), % clue 6 + left_right( [ivory,_,_,_,_], [green,_,_,_,_], S), % clue 5 + next_to( [_,norwegian,_,_,_],[blue,_,_,_,_], S), % clue 14 + next_to( [_,_,masserati,_,_],[_,_,_,_,horse], S), % clue 11 + next_to( [_,_,saab,_,_], [_,_,_,_,fox], S), % clue 10 + true. + +% left_right(L, R, X) is true when L is to the immediate left of R in list X + +left_right(L, R, [L, R | _]). + +left_right(L, R, [_ | X]) :- left_right(L, R, X). + + +% next_to(X, Y, L) is true when X and Y are next to each other in list L + +next_to(X, Y, L) :- left_right(X, Y, L). + +next_to(X, Y, L) :- left_right(Y, X, L). diff --git a/packages/chr/CMakeLists.txt b/packages/chr/CMakeLists.txt new file mode 100644 index 000000000..e69de29bb diff --git a/packages/chr/ChangeLog b/packages/chr/ChangeLog new file mode 100644 index 000000000..9e75cab1c --- /dev/null +++ b/packages/chr/ChangeLog @@ -0,0 +1,861 @@ +[Aug 12 2009] + + * CHR: no debugging instrumentation for optimized code + +[Jun 27 2008] + + * CHR: ADDED error value for check_guard_bindings option: + throw error on guard binding + + * CHR: ADDED error value for check_guard_bindings option: + throw error on guard binding + +[May 22 2008] + + * CHR: experimental detach code size reduction (bug fix) + +[May 21 2008] + + * CHR: reduce code size of attach and detach predicates (experimental) + +[May 20 2008] + + * CHR: chr_enum/1 (bug fix) and chr_enum/2 (with handler) + +[May 18 2008] + + * CHR: reinstate chr_enum/1 + +[May 14 2008] + + * CHR: suppress printing of put_attr/3 at toplevel + +[Apr 18 2008] + + * MODIFIED: Renamed hash_term/2 to term_hash/2. Added hash_term/2 to + library(backcomp), so most code should not notice this. + +[Feb 27 2008] + + * ENHANCED: CHR performance of find_chr_constraint when called with nonvar argument + +[Feb 14 2008] + + * ENHANCED: CHR performance (minor issues) + +[Feb 13 2008] + + * FIX: CHR new C file for Windows + + * FIX: CHR: single chr_support.c C file + +[Feb 12 2008] + + * ENHANCED: CHR: moved performance critical predicates to C + +[Feb 11 2008] + + * ENHANCED: CHR user-provided background knowledge (Jon Sneyers) + +[Feb 10 2008] + + * ENHANCED: CHR compiler performance + + * ENHANCED: CHR compiler performance + +[Jan 29 2008] + + * EHANCED: CHR performance: compacted indexing code + +[Jan 28 2008] + + * ADDED: CHR: chr_constants/1 built-in type for enumerated constants + +[Jan 27 2008] + + * ENHANCED: CHR: performance improvements (success continuation, Prolog code optimization) + + * COMPAT: Removed min_list/2 from library(hprolog) as this is now in library lists. + +Jan 24, 2008 + + * TS: Exploit success continuation information. + +Jan 23, 2008 + + * TS: Bug fix in continuation optimization. + * TS: Fixed singleton variable. + * TS: Suppress debug message. + +Jan 22, 2008 + + * TS: Rewrite Prolog code: common prefix elimination in + successive clauses of the same predicate. + * TS: Tries stores enabled by default again. + * TS: Success and failure continuation optimization for + propagation occurrences. + +Jan 14, 2008 + + * TS: Fix performance bug in locking of guard variables. + * TS: Fix performance bug in spurious hash_term call. + +Jan 10, 2008 + + * TS: Type check constraint declarations. + * TS: Trie stores hidden behind `experimental' option. + * TS: New option `verbose' prints constraint indices. + * TS: Don't compute term_hash for int and natural types. + +Jan 9, 2008 + + * TS: Avoid trivial warning for declare_stored_constraints. + * TS: Bug fix: missing full store was causing compiler to loop. + +Jan 9, 2008 + + * TS: Bug fix: atomic_constants store was causing compiler + to loop. + * TS: Clean-up and avoid adding additional global_ground store + if atomic_constants store covers all cases. + * TS: Clean-up and bug fix. + +Jan 7, 2008 + + * TS: Performance improvement: use new store + implementation for multi-argument lookups + on manifest ground terms. Should be faster than + hashtable. + +Jan 4, 2008 + + * TS: Performance improvement: use new store + implementation for single-argument lookups + on manifest atomics. Should be faster than + hashtable. Will be generalized to arbitrary + manifest ground lookups and non-manifest + atomically typed lookups . + +Jan 3, 2008 + + * TS: Modified error messages of declare_stored_constraints + option, to distinguish between stored, temporarily stored + and never stored. + * TS: write/1, writeln/1 and format/2 are now treated as non-binding + builtins. + * TS: Properly inline inthash constraint lookup. + +Dec 31, 2007 + + * TS: Additional assertion # default(Goal) for the + declare_stored_constraints, which specifies that + an unconditional simplification rule for the constraint + must be added to the end of the program. The Goal + parameter specifies the goal of that rule, e.g. + true or fail or throw(...). Experimental. + +Dec 29, 2007 + + * TS: Experimental option declare_stored_constraints for + telling the compiler to warn for stored constraints + that are not asserted to be stored. Use the + :- chr_constraint f(...) # stored. + notation for asserting that a constraint is expected to + be stored. + +Dec 27, 2007 + + * TS: Inline constraint lookup. + + * TS: Precompile term hashing. + +Sep 26, 2007 + + * TS: Code cleaning was hampered by line numbers. + Reported by Mike Elston. + +May 2, 2007 + + * PVW: Bug fix in observation analysis. + * PVW: Consistency checks of experimental history pragma. + +Apr 5, 2007 + + * TS: Lessened worst bottlenecks in CHR compiler, + in the guard simplification phase. + +Mar 26, 2007 + + * TS: Experimental dynattr option, for dynamic size attribute terms. + +Mar 16, 2007 + + * TS: Extended observation analysis (abstract interpretation) + to deal with disjunctions. With Paolo Tacchella. + +Mar 14, 2007 + + * TS: Renamed hprolog:substitute/4 to substitute_eq/4, because of + name conflict with library(edit). + +Mar 12, 2007 + + * TS: Use line numbers in error and warning messages. + +Mar 8, 2007 + + * TS: Added maintenance of line numbers through CHR compilation + as an option: chr_option(line_numbers,on). + +Mar 5, 2007 + + * TS: Bug fix: setarg/3 instantiation error reported by Mike Elston. + Caused by missing suspension argument in debug off, optimize off + mode. + +Feb 22, 2007 + + * LDK: O(1) removal from hashtables, with experimental + chr_option(ht_removal,on). + +Jan 25, 2007 + + * PVW: Bugfixes for optional use of CHR constraints in rule guards. + +Jan 18, 2007 + + * PVW: Optional use of CHR constraints in rule guards. + +Nov 20, 2006 + + * TS: Bug fix in compiler_errors.pl. + +Oct 25, 2006 + + * TS: Bug fix in occurrence subsumption by Jon Sneyers. + +Oct 18, 2006 + + * TS: New preprocessor feature. + + * TS: Parametrization of experimental chr_identifier type. + +Oct 16, 2006 + + * TS: More inlining. + + * TS: Stronger static type checking. + + * TS: Omitted buggy FD analysis from bootstrapping process. + +Oct 12, 2006 + + * TS: More inlining. + + * TS: Experimental chr_identifier type. + +Oct 10, 2006 + + * TS: Allow for empty type definitions aka phantom types. These are + useful for some type-level tricks. A warning is issued so the + user can check whether a phantom type is intended. No other + phantom type-specific checks are in place yet. + + * TS: Fixed static type checking of built-in types. + +Oct 9, 2006 + + * TS: The dense_int type can now appear on the rhs of type alias + definitions. + +Oct 3, 2006 + + * TS: Fixed bug concerning matchings between ground and possibly + non-ground arguments. + +Oct 2, 2006 + + * TS: Fixed a bug in code generation, overeager removal of a clause. + +Sep 28, 2006 + + * TS: Refactored some code. + +Sep 22, 2006 + + * TS: Add exception handler to initialize chr_leash in new threads. + +Sep 18. 2006 + + * TS: Bug fix for programs in debugging mode. + +Aug 30, 2006 + + * JW: Fixed make clean + * JW: Enlarged stacks to make build succeed + +Aug 24, 2006 + + * JW: Add target ln-install + +Aug 21, 2006 + + * TS: Fixed wrong arities in not inlined predicates. Mike Elston. + +Aug 18, 2006 + + * TS: Code clean-up, more inlining, only generate used imports. + +Aug 17, 2006 + + * TS: Inlining and more specialization of auxiliary predicates. + +Aug 10, 2006 + + * TS: Fixed bug for constraints without rules in debug mode. + + * TS: Compiler clean-up + + * TS: Experimental var_assoc_store. + + +Aug 9, 2006 + + * TS: Various minor code generation improvements, including smaller + suspension terms. + +Aug 8, 2006 + + * TS: Absolutely no lock checking when check_guard_bindings is disabled. + +Aug 4, 2006 + + * TS: Minor optimizations for (-) arguments. + + * TS: Important optimization for awakening fewer suspended constraints + +Aug 3, 2006 + + * TS: Fixed typo in static type checker. + + * TS: Documented static and dynamic type checking. + +Aug 2, 2006 + + * TS: Fixed bug (type alias related) in static type checker. Mike Elston. + + * TS: Added static type checking on variable matching in rule heads. + + * TS: Added static type checking on CHR constraints in rule bodies. + +Aug 1, 2006 + + * TS: New (limited) compile time type checking of rule heads. + +Jul 28, 2006 + + * TS: New experimental robustness feature in debug mode: + runtime type checking of CHR constraints. + +Jul 5, 2006 + + * TS: Minor bug fixes. + +Jun 22, 2006 + + * TS: Improved performance of ai_observation_analysis, + mainly via additional tabling and passive declarations. + +Jun 8, 2006 + + * TS: Disabled some code only intended for SICStus. + + * TS: Fixed bug in removal of constraints. Spotted by Leslie De Koninck. + +Jun 7, 2006 + + * TS: Next fix to tracer. Cconstraints in propagation + rules are shown in textual order. + +Jun 2, 2006 + + * TS: Next few fixes to tracer. Constraints in simpagation rules + are now shown on the right side of the backslash. + +Jun 1, 2006 + + * TS: Synchronization with SICStus version of K.U.Leuven CHR. + + * TS: First few fixes to tracer. Cconstraints in simplification + rules are shown in textual order. Constraint insertions + are always shown. + +May 17, 2006 + + * TS: Termination bug fixed in guard_entailment. + + * TS: Runtime library predicate run_suspensions is now specialized + per constraint, avoiding requirement of fixed suspension layout. + + * TS: Further update to suspension term layout. Only constraints for + which the propagation history is used get a history field. + +May 9, 2006 + + * TS: Ignore propagation rules with trivial body 'true'. + +Apr 24, 2006 + + * TS: Guard entailment now first simplifies the formula it processes, + in order to reduce the number of disjunctions, to obtain a smaller + search tree. + +Apr 22, 2006 + + * TS: Bug fix by Jon Sneyers: type aliases now support built-in types. + Spotted by Mike Elston. + + * TS: Small refactorings based on Ciao port experience. + + * TS: Removed -singleton stylecheck option now that portray_clause + prints singleton variables as _. + +Apr 19, 2006 + + * JW: Make library(chr) load its private stuff silent. + +Apr 14, 2006 + + * TS: Bug fix: too many guards were locked. + +Apr 11, 2006 + + * TS: Most runtime library predicates are now specialized + per constraint, avoiding generic =.. and lists code. + + Mayor update to suspension term layout. Layout may now + differ from one constraint to the other. Some unused suspension + fields (continuation goal and generation number) are omitted. + Further analysis can remove more fields. + + Default store constraints now each have + their own global variable: a list of all the suspensions. + Removal from this list is now O(1) thanks to setarg/1 and + back pointers in the suspension terms. This can cause time + time complexity improvements in solvers that always have + variable indexing on their constraints. + + Ground, non-indexed constraints are now removed from + their global list store in O(1), as for the default store. + + Minor bug fixes in a number of places. + +Mar 16, 2006 + + * TS: Fixed subtle bug in ai_observation analysis, + that caused goal sequences to only generate + the optimistic default answer pattern, leading + to invalid 'not observed' conclusions. + * TS: Variable indexing/suspension analysis now ignores functor/3 + in guards. Could be extended to other built-ins + that cause an error when arguments are not + properly instantiated. + +Mar 11, 2006 + + * TS: Renamed global variable id to chr_id in chr_runtime.pl. + +Mar 9, 2006 + * JS: Synchronization with experimental version: + - minor optimizations, e.g. efficient lookups with statically known + instantiated data + - new alternative syntax for passive declarations + - new dense_int built-in type + underlying store + - new type alias definitions, like in Mercury + +Mar 4, 2006 + * BD: small changes in chr_compiler_options.pl and chr_translate.chr + affecting only the SICStus port + +Mar 3, 2006 + * BD: lots of changes related to porting to SICStus + * TS: Now exception/3 hook is only used in SWI-Prolog + +Mar 2, 2006 + + * TS: Use exception/3 hook to catch undefined + global variables of chr_runtime.pl and CHR modules, + for multi-threaded programs and saved states. + +Feb 9, 2006 + + * JW: Fix "make check" path issues. + * TS: Removed all is_chr_file tests when loading file. + +Feb 8, 2006 + + * BD: chr_swi.pl: option(optimize --> :- chr_option(optimize + * TS: Removed obsolete experimental optimization option. + * TS: Correctly report variable pragmas! + * TS: No constraints declared is no longer a special case. + +Jan 19, 2006 + + * BD: chr_swi.pl - use_module(hprolog added for SICStus port + * TS: Removed operator declaration for '::'. No longer used. + +Dec 23, 2005 + + * TS: Removed chr_constraints declaration again, in favor + of only the chr_constraint declaration and modified + documentation accordingly. + * TS: Modified documentation based on recommendations of Bart Demoen. + * TS: Added chr_info/3 predicate to chr_compiler_errors, as suggested by + Jon Sneyers. Now print banner on calling compiler. + +Dec 13, 2005 + + * TS: warnings are now written to user_error stream. + +Dec 12, 2005 + + * TS: option and constraints declarations are now deprecated. They + are replaced by chr_option and chr_constraint(s). + * TR: Made an interface for warnings and errors. Errors now implemented + with exceptions. + * TR: Revised documentation. + +Dec 2, 2005 + * BD: chr_translate.chr, chr_translate_bootstrap2.chr + mutables "abstracted" + * BD: chr_translate_bootstrap1.chr + atomic_concat - some duplicate code of it is in more than one file :-( + create_get_mutable definitions if-deffed + verbosity_on/0 for porting + hprolog.pl + definitions of init_store/2, get_store/2, update_store/2 + and of make_init_store_goal/make_get_store_goal/make_update_store_goal + removed prolog_flag/3 (seemed nowhere used) + chr_translate_bootstrap2.chr + make_init_store_goal/make_get_store_goal/make_update_store_goal introduced + verbosity_on/0 for porting + chr_translate_bootstrap.pl + atom_concat -> atomic_concat + verbosity_on/0 for porting + conditional import van library(terms) + chr_translate.chr + make_init_store_goal etc. introduced + create_get_mutable_ref wherever needed (chr_translate*) + + +Nov 30, 2005 + * BD: chr_runtime.pl: + chr_init for SICStus + included contents of chr_debug.pl + removed show_store/1 + create_mutable changed into 'chr create_mutable' + got rid of explicit inlining and did it by goal expansion + inlining also of 'chr default_store' + * BD: chr_swi.pl: + removed :- use_module(chr(chr_debug)) + module header: version for SICStus + * BD: chr_debug.pl: emptied + * BD: chr_translate.chr: + system specific declarations factored out in insert_declarations + changed two atom_concat/3 into atomic_concat/3 (because arg 2 was sometimes an int) + * BD: chr_compiler_utility.pl: + put atomic_concat/3 there + adapted atom_concat_list/2 to use it + * BD: chr_swi_bootstrap.pl: + introduced chr_swi_bootstrap/2 for ease of porting + exported also chr_compile/3 + porting code for get_time stuff/read_term/absolute_file_name + * BD: builtins.pl, a_star.pl, clean_code.pl: + some ifdefs + + +Nov 29, 2005 + * BD: hprolog.pl: removed strip_attributes/2 and restore_attributes/2 + +Nov 29, 2005 + * BD: chr_swi.pl: Removed code that took Handler for Module (in chr_expand(end_of_file) + Added :- chr_option(_,_) with same meaning as option(_,_) + is_chr_file: .chr is no longer a recognised suffix + added use_module(library(lists)) + changed calls to source_location/2 into prolog_load_context/2 + * BD: chr_translate.chr: chr_translate/2: added end_of_file to translated program + adapted SICStus compatibility message + made :- chr_option(_,_) available + changed precedence of + - ? to 980 (these ops are + probably not local enough to the module) + +Nov 21, 2005 + + * TS: Further synchronization with hProlog. + +Nov 18, 2005 + + * TS: Removed dead code in guard_entailment.chr + * TS: Fixed performance bug: now lookup is indexed + on maximal number of arguments. + * TS: Removed some redundant intermediate predicates + in chr_runtime.pl. + * TS: It is now possible to disable the printing + of the CHR constraint store per module, + through the option toplevel_show_store on/off + * TS: Synchronized with hProlog + * TS: bug fix in functional dependency analysis + +Nov 17, 2005 + + * TS: Removed two dead predicates in chr_translate.chr + and hooked up the late_storage_analysis + that was being bypassed. + * TS: Renamed global_term_ref_1 to default_store. + * TS: Removed redundant predicate values_ht. + * TS: Compiler no longer generates dead code for never stored constraints, + i.e. attach/detach predicates. + This reduces the generated .pl by about 700 lines. + +Nov 10, 2005 + + * TS: Two more bug fixes for constraints without + active occurrences that trigger. + +Nov 4, 2005 + + * TS: Small optimization of code for constraints + without any active occurrence. + * TS: Fixed bug caused by previous bug fix: + added only_ground_indexed_arguments/1 test + to separate out that meaning from may_trigger/1. + +Nov 3, 2005 + + * TS: Removed strip_attributes code. + * TS: Fixed bug that causes new constraints to be added on triggering. + +Oct 25, 2005 + + * TS: Two minor bug fixes. + +Oct 19, 2005 + + * TS: Fixed bug due to overly aggressive inlining of get_mutable_value. + +Oct 18, 2005 + + * JS: Compiled code is broken, if debug is off and optimize too. + Debug off now entails optimize on. + + * TS: Some fixes of the documentation. Thanks to Bart Demoen + and Thom Fruehwirth. + +Sep 2, 2005 + + * TS: Synchronized with hProlog. + +Aug 31, 2005 + + * TS: Added missing operator declarations for prefix (?). + +Aug 9, 2005 + + * JW: import lists into chr_compiler_utility.pl + + * JW: make message hook for query(yes) detect CHR global variables. + + * JW: Exported pairlist_delete_eq/3 from pairlist and use this in + chr_hashtable_store.pl + +Aug 4, 2005 + + * TS: Renamed pairlist:delete/3 to pairlist:pairlist_delete/3. + Mike Elston. +Aug 1, 2005 + + * TS: Extended more efficient ground matching code to + removed simpagation occurrence code. + +Jul 28, 2005 + + * TS: New input verification: duplicate constraint declaration + now reported as an error. Requested by Mike Elston. + * TS: More efficient matching code for ground constraints + when matching an argument of a partner constraint with + a ground term + * JS: Bug fix in guard simplification. + +Jul 3, 2005 + + * TS: Factored out option functionality into separate module. + * TS: Factored out utility code into separate module. + +Jun 29, 2005 + + * TS: Changed chr_show_store/1 to use print/1 instead of write/1. + +Jun 28, 2005 + + * TS: Removed spurious and conflicting operator definitions + for +, - and ? as mode declarations. + +Jun 27, 2005 + + * TS: Added find_chr_constraint/1 functionality. + +Jun 8, 2005 + + * TS: Improved compiler scalability: use nb_setval/2 to + remember compiled code through backtracking over + compilation process instead of assert/1. + * TS: Removed spurious comma from file. + +Jun 1, 2005 + + * TS: Added option to disable toplevel constraint store printing. + * TS: Slightly improved hash table constraint store implementation. + +Apr 16, 2005 + + * JW: Added patch from Jon Sneyers. + +Mar 11, 2005 + + * TS: Improved head reordering heuristic. + * TS: Added support primitive for alternate built-in solver dependency. + +Mar 4, 2005 + + * TS: Fixed bug that causes wrong output in chr_show_store. + +Feb 25, 2005 + + * TS: Fixed several bugs in generation of debugable code. + +Feb 19, 2005 + + * JW: Cleanup integration in SWI-Prolog environment: + - Extended SWI-Prolog library ordsets. Renamed ord_delete/3 to + ord_del_element/3 and ord_difference/3 to ord_subtract/3 for + better compatibility. + - Renamed module find to chr_find to avoid name conflict and declared + preds as meta-predicate. + - Re-inserted and exported strip_attributes/2 and + restore_attributes/2 in hprolog.pl. Deleted hprolog: from + chr_translate.chr. + - Added dummy option declarations to bootstrap compiler. + - Fixed path problems in makefile (-p chr=.) and install new + components. + - Fixed typo 'chr show_store' --> chr_show_store. + +Feb 17, 2005 + + * JS: Added guard entailment optimizations and + new syntax for type and mode declarations. + +Dec 15, 2004 + + * TS: Use prolog:message/3 hook to automatically print + contents of CHR constraint stores with query bindings + on toplevel. + +Dec 3, 2004 + + * TS: Bugfix in code generation. Reported by Lyosha Ilyukhin. + +Jul 28, 2004 + + * TS: Updated hashtable stores. They now start small and expand. + +Jul 19, 2004 + + * JW: Removed chr_pp: module prefixes + * JW: Updated Windows makefile.mak (more similar organisation, added check) + +Jul 17, 2004 + + * TS: Added chr_hashtable_store library. + * TS: Added find library. + * TS: Added builtins library. + * TS: Added clean_code library. + * TS: Added binomial_heap library. + * TS: Added a_star library. + * TS: Added new intermediate bootstrapping step + * TS: Synchronized CHR compiler with most recent development version + + Summary of changes: + + "The new version of the compiler contains several new optimizations, both + fully automatic, such as the antimonotny-based delay avoidance (see + http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW385.abs.html for + the technical report), and enabled by mode declarations (see CHR + documentation), such as hashtable-based constraint indexes." + +Apr 9, 2004 + + * JW: Added chr_messages.pl. Make all debug messages use the print_message/2 + interface to enable future embedding. + +Apr 7, 2004 + + * JW: Added chr:debug_interact/3 hook. Defined in chr_swi.pl to void + showing constraints first as goal and then as CHR call. + * JW: Added chr:debug_event/2 hook. Defined in chr_swi.pl to make the + CHR debugger honour a skip command from the Prolog tracer. + +Apr 6, 2004 + + * JW: Added b (break) to the CHR debugger. + * TS: added chr_expandable/2 clause for pragma/2 + +Apr 5, 2004 + + * JW: fixed reference to format_rule/2. + * JW: Use select/3 rather than delete/3 in diff/2 in Tests/zebra.pl + * TS: CHR translation now leaves CHR store empty + +Apr 4, 2004 + + * JW: added :- use_module(library(chr)) to all examples. + * JW: mapped -O --> option(optimize, full). + * JW: introduced file-search-path `chr' for clarity and to enable running + make check from the local environment instead of the public installation. + * JW: mapped prolog flag generate_debug_info --> option(debug, on) + * JW: Replaced the chr -> pl step with term_expansion/2. + * JW: Moved insert_declarations/2 to chr_swi.pl + +Apr 2, 2004 + + * JW: fixed Undefined procedure: chr_runtime:run_suspensions_loop_d/1 + * TS: Added for creep and shortened debug line prefix to CHR: + +Mar 29, 2004 + + * JW: Use \+ \+ in chr_compile/3 to undo changes to the constraint + pool. Regression test suite using "make check" works again. + +Mar 25, 2004 + + * TS: Added skip and ancestor debug commands + +Mar 24, 2004 +G + * TS: Added bootstrapping process for CHR compiler using CHR. + * TS: CHR compiler now uses CHR. + * TS: Fixed bug in compilation of multi-headed simpagation rules. + * TS: Cleaned up compiler. + * TS: Added analysis + optimization for never attached constraints. + * TS: Exploit uniqueness (functional dependency) results to detect + set semantics type simpagation rules where one rule can be passive + * TS: Compiler generates 'chr debug_event'/1 calls + * TS: Rudimentary support for debugging. + option(debug,on) causes a trace of CHR events to be printed + +Mar 15, 2004 + + * JW: Fix operator handling. + +Mar 3, 2004 + + * JW: Integrated new version from Tom Schrijvers. diff --git a/packages/chr/Examples/bool.chr b/packages/chr/Examples/bool.chr new file mode 100644 index 000000000..fdc8e3b2b --- /dev/null +++ b/packages/chr/Examples/bool.chr @@ -0,0 +1,281 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Thom Fruehwirth ECRC 1991-1993 +%% 910528 started boolean,and,or constraints +%% 910904 added xor,neg constraints +%% 911120 added imp constraint +%% 931110 ported to new release +%% 931111 added card constraint +%% 961107 Christian Holzbaur, SICStus mods +%% +%% ported to hProlog by Tom Schrijvers June 2003 + + +:- module(bool,[]). +:- use_module(library(chr)). + +:- constraints boolean/1, and/3, or/3, xor/3, neg/2, imp/2, labeling/0, card/4. + + +boolean(0) <=> true. +boolean(1) <=> true. + +labeling, boolean(A)#Pc <=> +( A=0 ; A=1), +labeling +pragma passive(Pc). + + +%% and/3 specification +%%and(0,0,0). +%%and(0,1,0). +%%and(1,0,0). +%%and(1,1,1). + +and(0,X,Y) <=> Y=0. +and(X,0,Y) <=> Y=0. +and(1,X,Y) <=> Y=X. +and(X,1,Y) <=> Y=X. +and(X,Y,1) <=> X=1,Y=1. +and(X,X,Z) <=> X=Z. +%%and(X,Y,X) <=> imp(X,Y). +%%and(X,Y,Y) <=> imp(Y,X). +and(X,Y,A) \ and(X,Y,B) <=> A=B. +and(X,Y,A) \ and(Y,X,B) <=> A=B. + +labeling, and(A,B,C)#Pc <=> +label_and(A,B,C), +labeling +pragma passive(Pc). + +label_and(0,X,0). +label_and(1,X,X). + + +%% or/3 specification +%%or(0,0,0). +%%or(0,1,1). +%%or(1,0,1). +%%or(1,1,1). + +or(0,X,Y) <=> Y=X. +or(X,0,Y) <=> Y=X. +or(X,Y,0) <=> X=0,Y=0. +or(1,X,Y) <=> Y=1. +or(X,1,Y) <=> Y=1. +or(X,X,Z) <=> X=Z. +%%or(X,Y,X) <=> imp(Y,X). +%%or(X,Y,Y) <=> imp(X,Y). +or(X,Y,A) \ or(X,Y,B) <=> A=B. +or(X,Y,A) \ or(Y,X,B) <=> A=B. + +labeling, or(A,B,C)#Pc <=> +label_or(A,B,C), +labeling +pragma passive(Pc). + +label_or(0,X,X). +label_or(1,X,1). + + +%% xor/3 specification +%%xor(0,0,0). +%%xor(0,1,1). +%%xor(1,0,1). +%%xor(1,1,0). + +xor(0,X,Y) <=> X=Y. +xor(X,0,Y) <=> X=Y. +xor(X,Y,0) <=> X=Y. +xor(1,X,Y) <=> neg(X,Y). +xor(X,1,Y) <=> neg(X,Y). +xor(X,Y,1) <=> neg(X,Y). +xor(X,X,Y) <=> Y=0. +xor(X,Y,X) <=> Y=0. +xor(Y,X,X) <=> Y=0. +xor(X,Y,A) \ xor(X,Y,B) <=> A=B. +xor(X,Y,A) \ xor(Y,X,B) <=> A=B. + +labeling, xor(A,B,C)#Pc <=> +label_xor(A,B,C), +labeling +pragma passive(Pc). + +label_xor(0,X,X). +label_xor(1,X,Y):- neg(X,Y). + + +%% neg/2 specification +%%neg(0,1). +%%neg(1,0). + +neg(0,X) <=> X=1. +neg(X,0) <=> X=1. +neg(1,X) <=> X=0. +neg(X,1) <=> X=0. +neg(X,X) <=> fail. +neg(X,Y) \ neg(Y,Z) <=> X=Z. +neg(X,Y) \ neg(Z,Y) <=> X=Z. +neg(Y,X) \ neg(Y,Z) <=> X=Z. +%% Interaction with other boolean constraints +neg(X,Y) \ and(X,Y,Z) <=> Z=0. +neg(Y,X) \ and(X,Y,Z) <=> Z=0. +neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0. +neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0. +neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0. +neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0. +neg(X,Y) \ or(X,Y,Z) <=> Z=1. +neg(Y,X) \ or(X,Y,Z) <=> Z=1. +neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1. +neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1. +neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1. +neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1. +neg(X,Y) \ xor(X,Y,Z) <=> Z=1. +neg(Y,X) \ xor(X,Y,Z) <=> Z=1. +neg(X,Z) \ xor(X,Y,Z) <=> Y=1. +neg(Z,X) \ xor(X,Y,Z) <=> Y=1. +neg(Y,Z) \ xor(X,Y,Z) <=> X=1. +neg(Z,Y) \ xor(X,Y,Z) <=> X=1. +neg(X,Y) , imp(X,Y) <=> X=0,Y=1. +neg(Y,X) , imp(X,Y) <=> X=0,Y=1. + +labeling, neg(A,B)#Pc <=> +label_neg(A,B), +labeling +pragma passive(Pc). + +label_neg(0,1). +label_neg(1,0). + + +%% imp/2 specification (implication) +%%imp(0,0). +%%imp(0,1). +%%imp(1,1). + +imp(0,X) <=> true. +imp(X,0) <=> X=0. +imp(1,X) <=> X=1. +imp(X,1) <=> true. +imp(X,X) <=> true. +imp(X,Y),imp(Y,X) <=> X=Y. + +labeling, imp(A,B)#Pc <=> +label_imp(A,B), +labeling +pragma passive(Pc). + +label_imp(0,X). +label_imp(1,1). + + + +%% Boolean cardinality operator +%% card(A,B,L,N) constrains list L of length N to have between A and B 1s + + +card(A,B,L):- + length(L,N), + A= A=<0,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), 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 */ + diff --git a/packages/chr/Examples/chrdif.chr b/packages/chr/Examples/chrdif.chr new file mode 100644 index 000000000..2df0ecc0a --- /dev/null +++ b/packages/chr/Examples/chrdif.chr @@ -0,0 +1,84 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(chrdif,[chrdif/2]). +:- use_module(library(chr)). + +:- constraints dif/2, dif2/3, or/2, or_seq/2, del_or/1. + +chrdif(X,Y) :- dif(X,Y). + +dif(X,Y) <=> compound(X), compound(Y) | dif1(X,Y). +dif(X,X) <=> fail. +dif(X,Y) <=> nonvar(X), nonvar(Y) /* X \== Y holds */ | true. + +dif1(X,Y) :- + ( functor(X,F,A), + functor(Y,F,A) -> + X =.. [_|XL], + Y =.. [_|YL], + dif1l(XL,YL,A) + ; + true + ). + +dif1l(Xs,Ys,N) :- + or(Or,N), + dif1l_2(Xs,Ys,Or). + +dif1l_2([],[],_). +dif1l_2([X|Xs],[Y|Ys],Or) :- + dif2(X,Y,Or), + dif1l_2(Xs,Ys,Or). + +or_seq(OrP,Or) \ or(Or,0), or(OrP,N) <=> M is N - 1, or_seq(OrP,M). +or(_,0) <=> fail. + +dif2(X,Y,Or) <=> compound(X), compound(Y) | dif3(X,Y,Or). +dif2(X,X,Or), or(Or,N) <=> M is N - 1, or(Or,M). +dif2(X,Y,Or) <=> nonvar(X), nonvar(Y) /* X \== Y holds */ | del_or(Or). + +del_or(Or) \ or_seq(OrP,Or) <=> del_or(OrP). +del_or(Or) \ or_seq(Or,OrC) <=> del_or(OrC). +del_or(Or) \ or(Or,_) <=> true. +del_or(Or) \ dif2(_,_,Or) <=> true. +del_or(Or) <=> true. + +dif3(X,Y,Or) :- + ( functor(X,F,A), + functor(Y,F,A) -> + X =.. [_|XL], + Y =.. [_|YL], + or_seq(Or,Or2), + dif1l(XL,YL,A) + ; + del_or(Or) + ). diff --git a/packages/chr/Examples/chrfreeze.chr b/packages/chr/Examples/chrfreeze.chr new file mode 100644 index 000000000..ad297c947 --- /dev/null +++ b/packages/chr/Examples/chrfreeze.chr @@ -0,0 +1,6 @@ +:- module(chrfreeze,[chrfreeze/2]). +:- use_module(library(chr)). + +:- constraints chrfreeze/2. + +chrfreeze(V,G) <=> nonvar(V) | call(G). diff --git a/packages/chr/Examples/deadcode.pl b/packages/chr/Examples/deadcode.pl new file mode 100644 index 000000000..37468006c --- /dev/null +++ b/packages/chr/Examples/deadcode.pl @@ -0,0 +1,197 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(deadcode,[deadcode/2]). + +:- use_module(library(chr)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- constraints + defined_predicate(+any), + calls(+any,+any), + live(+any), + print_dead_predicates. + +defined_predicate(P) \ defined_predicate(P) <=> true. + +calls(P,Q) \ calls(P,Q) <=> true. + +live(P) \ live(P) <=> true. + +live(P), calls(P,Q) ==> live(Q). + +print_dead_predicates \ live(P), defined_predicate(P) <=> true. +print_dead_predicates \ defined_predicate(P) <=> + writeln(P). +print_dead_predicates \ calls(_,_) <=> true. +print_dead_predicates \ live(_) <=> true. +print_dead_predicates <=> true. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +deadcode(File,Starts) :- + readfile(File,Clauses), + exported_predicates(Clauses,Exports), + findall(C, ( member(C,Clauses), C \= (:- _) , C \= (?- _)), Cs), + process_clauses(Cs), + append(Starts,Exports,Alive), + live_predicates(Alive), + print_dead_predicates. + +exported_predicates(Clauses,Exports) :- + ( member( (:- module(_, Exports)), Clauses) -> + true + ; + Exports = [] + ). +process_clauses([]). +process_clauses([C|Cs]) :- + hb(C,H,B), + extract_predicates(B,Ps,[]), + functor(H,F,A), + defined_predicate(F/A), + calls_predicates(Ps,F/A), + process_clauses(Cs). + +calls_predicates([],FA). +calls_predicates([P|Ps],FA) :- + calls(FA,P), + calls_predicates(Ps,FA). + +hb(C,H,B) :- + ( C = (H :- B) -> + true + ; + C = H, + B = true + ). + +live_predicates([]). +live_predicates([P|Ps]) :- + live(P), + live_predicates(Ps). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +extract_predicates(!,L,L) :- ! . +extract_predicates(_ < _,L,L) :- ! . +extract_predicates(_ = _,L,L) :- ! . +extract_predicates(_ =.. _ ,L,L) :- ! . +extract_predicates(_ =:= _,L,L) :- ! . +extract_predicates(_ == _,L,L) :- ! . +extract_predicates(_ > _,L,L) :- ! . +extract_predicates(_ \= _,L,L) :- ! . +extract_predicates(_ \== _,L,L) :- ! . +extract_predicates(_ is _,L,L) :- ! . +extract_predicates(arg(_,_,_),L,L) :- ! . +extract_predicates(atom_concat(_,_,_),L,L) :- ! . +extract_predicates(atomic(_),L,L) :- ! . +extract_predicates(b_getval(_,_),L,L) :- ! . +extract_predicates(call(_),L,L) :- ! . +extract_predicates(compound(_),L,L) :- ! . +extract_predicates(copy_term(_,_),L,L) :- ! . +extract_predicates(del_attr(_,_),L,L) :- ! . +extract_predicates(fail,L,L) :- ! . +extract_predicates(functor(_,_,_),L,L) :- ! . +extract_predicates(get_attr(_,_,_),L,L) :- ! . +extract_predicates(length(_,_),L,L) :- ! . +extract_predicates(nb_setval(_,_),L,L) :- ! . +extract_predicates(nl,L,L) :- ! . +extract_predicates(nonvar(_),L,L) :- ! . +extract_predicates(once(G),L,T) :- !, + ( nonvar(G) -> + extract_predicates(G,L,T) + ; + L = T + ). +extract_predicates(op(_,_,_),L,L) :- ! . +extract_predicates(prolog_flag(_,_),L,L) :- ! . +extract_predicates(prolog_flag(_,_,_),L,L) :- ! . +extract_predicates(put_attr(_,_,_),L,L) :- ! . +extract_predicates(read(_),L,L) :- ! . +extract_predicates(see(_),L,L) :- ! . +extract_predicates(seen,L,L) :- ! . +extract_predicates(setarg(_,_,_),L,L) :- ! . +extract_predicates(tell(_),L,L) :- ! . +extract_predicates(term_variables(_,_),L,L) :- ! . +extract_predicates(told,L,L) :- ! . +extract_predicates(true,L,L) :- ! . +extract_predicates(var(_),L,L) :- ! . +extract_predicates(write(_),L,L) :- ! . +extract_predicates((G1,G2),L,T) :- ! , + extract_predicates(G1,L,T1), + extract_predicates(G2,T1,T). +extract_predicates((G1->G2),L,T) :- !, + extract_predicates(G1,L,T1), + extract_predicates(G2,T1,T). +extract_predicates((G1;G2),L,T) :- !, + extract_predicates(G1,L,T1), + extract_predicates(G2,T1,T). +extract_predicates(\+ G, L, T) :- !, + extract_predicates(G, L, T). +extract_predicates(findall(_,G,_),L,T) :- !, + extract_predicates(G,L,T). +extract_predicates(bagof(_,G,_),L,T) :- !, + extract_predicates(G,L,T). +extract_predicates(_^G,L,T) :- !, + extract_predicates(G,L,T). +extract_predicates(_:Call,L,T) :- !, + extract_predicates(Call,L,T). +extract_predicates(Call,L,T) :- + ( var(Call) -> + L = T + ; + functor(Call,F,A), + L = [F/A|T] + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% File Reading + +readfile(File,Declarations) :- + see(File), + readcontent(Declarations), + seen. + +readcontent(C) :- + read(X), + ( X = (:- op(Prec,Fix,Op)) -> + op(Prec,Fix,Op) + ; + true + ), + ( X == end_of_file -> + C = [] + ; + C = [X | Xs], + readcontent(Xs) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + diff --git a/packages/chr/Examples/family.chr b/packages/chr/Examples/family.chr new file mode 100644 index 000000000..c15b2c394 --- /dev/null +++ b/packages/chr/Examples/family.chr @@ -0,0 +1,116 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 000401 Slim Abdennadher and Henning Christiansen +%% +%% ported to hProlog by Tom Schrijvers + +:- module(family,[]). + +:- use_module(library(chr)). + +:- constraints + % extensional predicates: + person/2, father/2, mother/2, + orphan/1, + % intensional predicates: + parent/2, sibling/2, + % predefined: + diff/2, + % a little helper: + start/0. + +% Representing the test for failed state, i.e., +% that the 'predefined' are satisfiable + +diff(X,X) ==> false. + + + +% Definition rules: + +parent_def @ +parent(P,C) <=> (true | (father(P,C) ; mother(P,C))). + +sibling_def @ +sibling(C1,C2) <=> + diff(C1,C2), + parent(P,C1), parent(P,C2). + +ext_intro @ +start <=> father(john,mary), father(john,peter), + mother(jane,mary), + person(john,male), person(peter,male), + person(jane,female), person(mary,female), + person(paul,male). + + + +% Closing rules +father_close @ +father(X,Y) ==> ( true | ((X=john, Y=mary) ; (X=john, Y=peter))). + +% mother close @ +mother(X,Y) ==> X=jane, Y=mary. + +% person_close @ +person(X,Y) ==> ( true | ( (X=john, Y=male) ; + (X=peter, Y=male) ; + (X=jane, Y=female) ; + (X=mary, Y=female) ; + (X=paul, Y=male) + ) + ). + + + +% ICs + +ic_father_unique @ +father(F1,C),father(F2,C) ==> F1=F2. + + +ic_mother_unique @ +mother(M1,C),mother(M2,C) ==> M1=M2. + +ic_gender_unique @ +person(P,G1), person(P,G2) ==> G1=G2. + +ic_father_persons @ +father(F,C) ==> person(F,male), person(C,S). + +ic_mother_persons @ +mother(M,C) ==> person(M,female), person(C,G). + +% Indirect def. + +orphan1 @ +orphan(C) ==> person(C,G). + +orphan2 @ +orphan(C), /* person(F,male),*/ father(F,C) ==> false. + +orphan3 @ +orphan(C), /* person(M,female),*/ mother(M,C) ==> false. + + + +%%%% The following just to simplify output; + + +father(F,C) \ father(F,C)<=> true. +mother(M,C) \ mother(M,C)<=> true. +person(M,C) \ person(M,C)<=> true. +orphan(C) \ orphan(C)<=> true. + + +/************************************************* +Sample goals + + :- start, sibling(peter,mary). + + :- start, sibling(paul,mary). + + :- father(X,Y), mother(X,Y). + +**************************************************/ + diff --git a/packages/chr/Examples/fib.chr b/packages/chr/Examples/fib.chr new file mode 100644 index 000000000..1ddaf7f28 --- /dev/null +++ b/packages/chr/Examples/fib.chr @@ -0,0 +1,24 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 991202 Slim Abdennadher, LMU +%% +%% ported to hProlog by Tom Schrijvers + +:- module(fib,[]). + +:- use_module(library(chr)). + +:- constraints fib/2. + +%% fib(N,M) is true if M is the Nth Fibonacci number. + +%% Top-down Evaluation with Tabulation + +fib(N,M1), fib(N,M2) <=> M1 = M2, fib(N,M1). + +fib(0,M) ==> M = 1. + +fib(1,M) ==> M = 1. + +fib(N,M) ==> N > 1 | N1 is N-1, fib(N1,M1), N2 is N-2, fib(N2,M2), M is M1 + M2. + diff --git a/packages/chr/Examples/fibonacci.chr b/packages/chr/Examples/fibonacci.chr new file mode 100644 index 000000000..16eb37a24 --- /dev/null +++ b/packages/chr/Examples/fibonacci.chr @@ -0,0 +1,31 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- module(fibonacci,[]). + +:- use_module(library(chr)). + +:- constraints fibonacci/2. + +%% fibonacci(N,M) is true iff M is the Nth Fibonacci number. + +%% Top-down Evaluation with effective Tabulation +%% Contrary to the version in the SICStus manual, this one does "true" +%% tabulation + +fibonacci(N,M1) # Id \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(Id). + +fibonacci(0,M) ==> M = 1. + +fibonacci(1,M) ==> M = 1. + +fibonacci(N,M) ==> + N > 1 | + N1 is N-1, + fibonacci(N1,M1), + N2 is N-2, + fibonacci(N2,M2), + M is M1 + M2. diff --git a/packages/chr/Examples/gcd.chr b/packages/chr/Examples/gcd.chr new file mode 100644 index 000000000..4406c19e6 --- /dev/null +++ b/packages/chr/Examples/gcd.chr @@ -0,0 +1,28 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 980202, 980311 Thom Fruehwirth, LMU +%% computes greatest common divisor of positive numbers written each as gcd(N) +%% +%% ported to hProlog by Tom Schrijvers + +:- module(gcd,[]). + +:- use_module( library(chr)). + +:- constraints gcd/1. + +gcd(0) <=> true. +%%gcd(N) \ gcd(M) <=> N= N= true. +antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. +idempotence @ leq(X,Y) \ leq(X,Y) <=> true. +transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). + +t(N):- + cputime(X), + length(L,N), + genleq(L,Last), + L=[First|_], + leq(Last,First), + cputime( Now), + Time is Now-X, + write(N-Time), nl. + +genleq([Last],Last) :- ! . +genleq([X,Y|Xs],Last):- + leq(X,Y), + genleq([Y|Xs],Last). + +cputime( Ts) :- + statistics( runtime, [Tm,_]), + Ts is Tm/1000. diff --git a/packages/chr/Examples/listdom.chr b/packages/chr/Examples/listdom.chr new file mode 100644 index 000000000..09978c0a6 --- /dev/null +++ b/packages/chr/Examples/listdom.chr @@ -0,0 +1,138 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Slim Abdennadher, Thom Fruehwirth, LMU, July 1998 +%% Finite (enumeration, list) domain solver over integers +%% +%% * ported to hProlog by Tom Schrijvers, K.U.Leuven + +% :- module(listdom,[]). + +:- use_module( library(chr)). + +:- use_module( library(lists)). + + +%% for domain constraints +:- op( 700,xfx,'::'). +:- op( 600,xfx,'..'). + +%% for inequality constraints +:- op( 700,xfx,lt). +:- op( 700,xfx,le). +:- op( 700,xfx,ne). + +%% for domain constraints +?- op( 700,xfx,'::'). +?- op( 600,xfx,'..'). + +%% for inequality constraints +?- op( 700,xfx,lt). +?- op( 700,xfx,le). +?- op( 700,xfx,ne). + +:- constraints (::)/2, (le)/2, (lt)/2, (ne)/2, add/3, mult/3. +%% X::Dom - X must be element of the finite list domain Dom + +%% special cases +X::[] <=> fail. +%%X::[Y] <=> X=Y. +%%X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true). + +%% intersection of domains for the same variable +X::L1, X::L2 <=> is_list(L1), is_list(L2) | +intersection(L1,L2,L) , X::L. + +X::L, X::Min..Max <=> is_list(L) | +remove_lower(Min,L,L1), remove_higher(Max,L1,L2), +X::L2. + + +%% interaction with inequalities + +X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2), +min_list(L1,MinX), min_list(L2,MinY), MinX > MinY | +max_list(L2,MaxY), Y::MinX..MaxY. +X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2), +max_list(L1,MaxX), max_list(L2,MaxY), MaxX > MaxY | +min_list(L1,MinX), X::MinX..MaxY. + +X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2), +max_list(L1,MaxX), max_list(L2,MaxY), +MaxY1 is MaxY - 1, MaxY1 < MaxX | +min_list(L1,MinX), X::MinX..MaxY1. +X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2), +min_list(L1,MinX), min_list(L2,MinY), +MinX1 is MinX + 1, MinX1 > MinY | +max_list(L2,MaxY), Y :: MinX1..MaxY. + +X ne Y \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1. +Y ne X \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1. +Y::D \ X ne Y <=> ground(X), is_list(D), \+ member(X,D) | true. +Y::D \ Y ne X <=> ground(X), is_list(D), \+ member(X,D) | true. + + +%% interaction with addition +%% no backpropagation yet! + +add(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) | +all_addition(L1,L2,L3), Z::L3. + +%% interaction with multiplication +%% no backpropagation yet! + +mult(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) | +all_multiplication(L1,L2,L3), Z::L3. + + +%% auxiliary predicates ============================================= + +remove_lower(_,[],L1):- !, L1=[]. +remove_lower(Min,[X|L],L1):- + X@Max, + !, + remove_higher(Max,L,L1). +remove_higher(Max,[X|L],[X|L1]):- + remove_higher(Max,L,L1). + +intersection([], _, []). +intersection([Head|L1tail], L2, L3) :- + memberchk(Head, L2), + !, + L3 = [Head|L3tail], + intersection(L1tail, L2, L3tail). +intersection([_|L1tail], L2, L3) :- + intersection(L1tail, L2, L3). + +all_addition(L1,L2,L3) :- + setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X + Y), L3). + +all_multiplication(L1,L2,L3) :- + setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X * Y), L3). + + +%% EXAMPLE ========================================================== + +/* +?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y, +add(X,Y,Z), mult(X,Y,Z). +*/ + +%% end of handler listdom.pl ================================================= +%% =========================================================================== + + +/* + +?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y, + add(X,Y,Z), mult(X,Y,Z). + +Bad call to builtin predicate: _9696 =.. ['add/3__0',AttVar4942,AttVar5155,AttVar6836|_9501] in predicate mknewterm / 3 +*/ \ No newline at end of file diff --git a/packages/chr/Examples/primes.chr b/packages/chr/Examples/primes.chr new file mode 100644 index 000000000..df9963963 --- /dev/null +++ b/packages/chr/Examples/primes.chr @@ -0,0 +1,30 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Sieve of eratosthenes to compute primes +%% thom fruehwirth 920218-20, 980311 +%% christian holzbaur 980207 for Sicstus CHR +%% +%% ported to hProlog by Tom Schrijvers + +:- module(primes,[]). +:- use_module(library(chr)). + +:- constraints candidate/1. +:- constraints prime/1. + + +candidate(1) <=> true. +candidate(N) <=> primes:prime(N), N1 is N - 1, primes:candidate(N1). + +absorb @ prime(Y) \ prime(X) <=> 0 is X mod Y | true. + +time(N):- + cputime(X), + candidate(N), + cputime( Now), + Time is Now-X, + write(N-Time), nl. + +cputime( Ts) :- + statistics( runtime, [Tm,_]), + Ts is Tm/1000. diff --git a/packages/chr/Makefile.in b/packages/chr/Makefile.in new file mode 100755 index 000000000..82ff783ee --- /dev/null +++ b/packages/chr/Makefile.in @@ -0,0 +1,114 @@ +################################################################ +# SWI-Prolog CHR package +# Author: Tom Schrijvers and many others +# Copyright: LGPL (see COPYING or www.gnu.org +################################################################ + +PACKAGE=chr +include ../Makefile.defs + +CHRDIR=$(PLLIBDIR)/chr +EXDIR=$(PKGEXDIR)/chr + +LIBPL= $(srcdir)/chr_runtime.pl $(srcdir)/chr_op.pl \ + chr_translate.pl $(srcdir)/chr_debug.pl \ + $(srcdir)/chr_messages.pl \ + $(srcdir)/pairlist.pl $(srcdir)/clean_code.pl \ + $(srcdir)/find.pl $(srcdir)/a_star.pl \ + $(srcdir)/binomialheap.pl $(srcdir)/builtins.pl \ + $(srcdir)/chr_hashtable_store.pl $(srcdir)/listmap.pl \ + guard_entailment.pl \ + $(srcdir)/chr_compiler_options.pl \ + $(srcdir)/chr_compiler_utility.pl \ + $(srcdir)/chr_compiler_errors.pl \ + $(srcdir)/chr_integertable_store.pl +CHRPL= $(srcdir)/chr_swi.pl +EXAMPLES= chrfreeze.chr fib.chr gcd.chr primes.chr \ + bool.chr family.chr fibonacci.chr leq.chr listdom.chr \ + chrdif.chr + +all: chr_translate.pl + +chr_translate_bootstrap.pl: + +chr_translate_bootstrap1.pl: $(srcdir)/chr_translate_bootstrap1.chr $(srcdir)/chr_translate_bootstrap.pl + $(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step1('$<','$@'),halt" \ + -t 'halt(1)' + $(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step2('$<','$@'),halt" \ + -t 'halt(1)' + +chr_translate_bootstrap2.pl: $(srcdir)/chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl + $(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step2('$<','$@'),halt" \ + -t 'halt(1)' + $(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step3('$<','$@'),halt" \ + -t 'halt(1)' + +guard_entailment.pl: $(srcdir)/guard_entailment.chr chr_translate_bootstrap2.pl + $(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step3('$<','$@'),halt" \ + -t 'halt(1)' + +chr_translate.pl: $(srcdir)/chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl + $(PL) -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step3('$<','$@'),halt" \ + -t 'halt(1)' + $(PL) -p chr=. -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt" \ + -t 'halt(1)' + $(PL) -p chr=. -q -f $(srcdir)/chr_swi_bootstrap.pl \ + -g "chr_compile_step4('$<','$@'),halt" \ + -t 'halt(1)' + +chr.pl: $(srcdir)/chr_swi.pl + cp $< $@ + +install: all $(DESTDIR)$(PLLIBDIR) install-examples + mkdir -p $(DESTDIR)$(CHRDIR) + $(INSTALL_DATA) $(LIBPL) $(DESTDIR)$(CHRDIR) + $(INSTALL_DATA) $(CHRPL) $(DESTDIR)$(PLLIBDIR)/chr.pl + $(INSTALL_DATA) $(srcdir)/README $(DESTDIR)$(CHRDIR) + $(MKINDEX) + +$(DESTDIR)$(PLLIBDIR): + mkdir $@ + +ln-install:: + @$(MAKE) INSTALL_DATA='../ln-install' install + +rpm-install: install + +pdf-install: install-examples + +html-install: install-examples + +install-examples:: + mkdir -p $(DESTDIR)$(EXDIR) + for i in $(EXAMPLES); do \ + $(INSTALL_DATA) $(srcdir)/Examples/$$i $(DESTDIR)$(EXDIR); \ + done + +uninstall: + (cd $(PLBASE)/library && rm -f $(LIBPL)) + @IN_SWI@$$(PL) -f none -g make -t halt + +check: chr.pl + $(PL) -q -f $(srcdir)/chr_test.pl -g test,halt -t 'halt(1)' + + +################################################################ +# Clean +################################################################ + +clean: + rm -f *~ *.o *.@SO@ *% config.log + rm -f chr.pl chr_translate.pl + rm -f chr_translate_bootstrap1.pl chr_translate_bootstrap2.pl + rm -f guard_entailment.pl + +distclean: clean + rm -f config.h config.cache config.status Makefile + rm -f $(TEX) diff --git a/packages/chr/Makefile.mak b/packages/chr/Makefile.mak new file mode 100644 index 000000000..25b295bf3 --- /dev/null +++ b/packages/chr/Makefile.mak @@ -0,0 +1,111 @@ +################################################################ +# Install CHR stuff for the MS-Windows build +# Author: Jan Wielemaker +# +# Use: +# nmake /f Makefile.mak +# nmake /f Makefile.mak install +################################################################ + +PLHOME=..\.. +!include $(PLHOME)\src\rules.mk +CFLAGS=$(CFLAGS) /D__SWI_PROLOG__ +LIBDIR=$(PLBASE)\library +EXDIR=$(PKGDOC)\examples\chr +CHR=$(LIBDIR)\chr +PL="$(PLHOME)\bin\swipl.exe" + +LIBPL= chr_runtime.pl chr_op.pl chr_translate.pl chr_debug.pl \ + chr_messages.pl hprolog.pl pairlist.pl clean_code.pl \ + find.pl a_star.pl binomialheap.pl builtins.pl \ + chr_hashtable_store.pl listmap.pl guard_entailment.pl \ + chr_compiler_options.pl chr_compiler_utility.pl \ + chr_compiler_errors.pl \ + chr_integertable_store.pl +CHRPL= chr_swi.pl +EXAMPLES= chrfreeze.chr fib.chr gcd.chr primes.chr \ + bool.chr family.chr fibonacci.chr leq.chr listdom.chr \ + chrdif.chr + + +all: chr_translate.pl + +chr_support.dll: chr_support.obj + $(LD) /dll /out:$@ $(LDFLAGS) chr_support.obj $(PLLIB) + +chr_translate_bootstrap1.pl: chr_translate_bootstrap1.chr + $(PL) -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step1('chr_translate_bootstrap1.chr','chr_translate_bootstrap1.pl'),halt" \ + -t "halt(1)" + $(PL) -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step2('chr_translate_bootstrap1.chr','chr_translate_bootstrap1.pl'),halt" \ + -t "halt(1)" + +chr_translate_bootstrap2.pl: chr_translate_bootstrap2.chr chr_translate_bootstrap1.pl + $(PL) -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step2('chr_translate_bootstrap2.chr','chr_translate_bootstrap2.pl'),halt" \ + -t 'halt(1)' + $(PL) -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step3('chr_translate_bootstrap2.chr','chr_translate_bootstrap2.pl'),halt" \ + -t 'halt(1)' + +guard_entailment.pl: guard_entailment.chr chr_translate_bootstrap2.pl + $(PL) -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step3('guard_entailment.chr','guard_entailment.pl'),halt" \ + -t 'halt(1)' + +chr_translate.pl: chr_translate.chr chr_translate_bootstrap2.pl guard_entailment.pl + $(PL) -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step3('chr_translate.chr','chr_translate.pl'),halt" \ + -t 'halt(1)' + $(PL) -p chr=. -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step4('guard_entailment.chr','guard_entailment.pl'),halt" \ + -t 'halt(1)' + $(PL) -p chr=. -q -f chr_swi_bootstrap.pl \ + -g "chr_compile_step4('chr_translate.chr','chr_translate.pl'),halt" \ + -t 'halt(1)' + +chr.pl: chr_swi.pl + copy chr_swi.pl chr.pl + +check: chr.pl + $(PL) -q -f chr_test.pl -g test,halt -t 'halt(1)' + + +!IF "$(CFG)" == "rt" +install:: +!ELSE +install:: + @if not exist "$(CHR)\$(NULL)" $(MKDIR) "$(CHR)" + @for %f in ($(LIBPL)) do \ + copy "%f" "$(CHR)" + copy $(CHRPL) "$(LIBDIR)\chr.pl" + copy README "$(CHR)\README.TXT" + $(MAKEINDEX) +!ENDIF + +html-install: install-examples +pdf-install: install-examples + +install-examples:: + if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)" + cd examples & @for %f in ($(EXAMPLES)) do @copy %f "$(EXDIR)" + +xpce-install:: + +uninstall:: + @for %f in ($(LIBPL)) do \ + del "$(CHR)\%f" + del "$(CHR)\README.TXT" + del "$(LIBDIR)\chr.pl" + $(MAKEINDEX) + +clean:: + if exist *~ del *~ + -del chr.pl chr_translate.pl + -del chr_translate_bootstrap1.pl chr_translate_bootstrap2.pl + -del guard_entailment.pl + +distclean: clean + + diff --git a/packages/chr/README b/packages/chr/README new file mode 100644 index 000000000..972ebec5e --- /dev/null +++ b/packages/chr/README @@ -0,0 +1,47 @@ + CHR for SWI-Prolog + ================== + +Authors and license +==================== + +This package contains code from the following authors. All code is +distributed under the SWI-Prolog conditions with permission from the +authors. + + + * Tom Schrijvers, K.U.Leuven Tom.Schrijvers@cs.kuleuven.be + * Christian Holzbaur christian@ai.univie.ac.at + * Jan Wielemaker jan@swi-prolog.org + + +Files and their roles: +====================== + + # library(chr) chr_swi.pl + Make user-predicates and hooks for loading CHR files available + to the user. + + # library(chr/chr_op) + Include file containing the operator declaractions + + # library(chr/chr_translate) + Core translation module. Defines chr_translate/2. + + # library(chr/chr_debug) + Debugging routines, made available to the user through + library(chr). Very incomplete. + + # library(chr/hprolog) + Compatibility to hProlog. Should be abstracted. + + # library(chr/pairlist) + Deal with lists of Name-Value. Used by chr_translate.pl + + +Status +====== + +Work in progress. The compiler source (chr_translate.pl) contains +various `todo' issues. The debugger is almost non existent. Future work +should improve on the compatibility with the reference CHR +documentation. Details on loading CHR files are subject to change. diff --git a/packages/chr/Tests/dense_int.chr b/packages/chr/Tests/dense_int.chr new file mode 100644 index 000000000..1d0aba9f5 --- /dev/null +++ b/packages/chr/Tests/dense_int.chr @@ -0,0 +1,26 @@ +:- module(dense_int,[dense_int/0]). + +:-use_module(library(chr)). + +:-chr_type 'Arity' == dense_int. + +:-chr_constraint c1(+'Arity'). + +:-chr_option(line_numbers, on). +:-chr_option(check_guard_bindings, on). +:-chr_option(debug, off). +:-chr_option(optimize, full). + +dense_int :- + c1(1), + c1(1). + + +no_duplicates @ + c1(X) + \ + c1(X) + <=> + true. + + diff --git a/packages/chr/Tests/fibonacci.chr b/packages/chr/Tests/fibonacci.chr new file mode 100644 index 000000000..3a0b7c375 --- /dev/null +++ b/packages/chr/Tests/fibonacci.chr @@ -0,0 +1,40 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% 16 June 2003 Bart Demoen, Tom Schrijvers, K.U.Leuven +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- module(fibonacci,[fibonacci/0]). +:- use_module(library(chr)). + +:- chr_constraint fibonacci/2, cleanup/1. + +%% fibonacci(N,M) is true iff M is the Nth Fibonacci number. + +%% Top-down Evaluation with effective Tabulation +%% Contrary to the version in the SICStus manual, this one does "true" +%% tabulation + +fibonacci(N,M1) # ID \ fibonacci(N,M2) <=> var(M2) | M1 = M2 pragma passive(ID). + +fibonacci(0,M) ==> M = 1. + +fibonacci(1,M) ==> M = 1. + +fibonacci(N,M) ==> + N > 1 | + N1 is N-1, + fibonacci(N1,M1), + N2 is N-2, + fibonacci(N2,M2), + M is M1 + M2. + +cleanup(L), fibonacci(N,F) <=> L = [N-F|T], cleanup(T). +cleanup(L) <=> L = []. + +fibonacci :- + fibonacci(15,F), + F == 987, + cleanup(L), + sort(L,SL), + SL == [0 - 1,1 - 1,2 - 2,3 - 3,4 - 5,5 - 8,6 - 13,7 - 21,8 - 34,9 - 55,10 - 89,11 - 144,12 - 233,13 - 377,14 - 610,15 - 987]. diff --git a/packages/chr/Tests/leq.chr b/packages/chr/Tests/leq.chr new file mode 100644 index 000000000..7afe951eb --- /dev/null +++ b/packages/chr/Tests/leq.chr @@ -0,0 +1,27 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% simple constraint solver for inequalities between variables +%% thom fruehwirth ECRC 950519, LMU 980207, 980311 +%% +%% ported to hProlog by Tom Schrijvers + +:- module(leq,[leq/0]). +:- use_module(library(chr)). + +:- chr_constraint leq/2. + +reflexivity @ leq(X,X) <=> true. +antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. +idempotence @ leq(X,Y) \ leq(X,Y) <=> true. +transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). + +leq :- + circle(X, Y, Z), + \+ attvar(X), + X == Y, + Y == Z. + +circle(X, Y, Z) :- + leq(X, Y), + leq(Y, Z), + leq(Z, X). diff --git a/packages/chr/Tests/passive_check.chr b/packages/chr/Tests/passive_check.chr new file mode 100644 index 000000000..86e3f9c69 --- /dev/null +++ b/packages/chr/Tests/passive_check.chr @@ -0,0 +1,12 @@ +:- module(passive_check,[passive_check/0]). +:- use_module(library(chr)). + +:- chr_constraint a/1, b/1. + +:- chr_option(debug,off). +:- chr_option(optimize,full). + +a(X) # ID, b(X) <=> true pragma passive(ID). + +passive_check :- + a(_). diff --git a/packages/chr/Tests/passive_check2.chr b/packages/chr/Tests/passive_check2.chr new file mode 100644 index 000000000..d5b571984 --- /dev/null +++ b/packages/chr/Tests/passive_check2.chr @@ -0,0 +1,12 @@ +:- module(passive_check2,[passive_check2/0]). +:- use_module(library(chr)). + +:- chr_constraint a/1, b/2. + +:- chr_option(debug,off). +:- chr_option(optimize,full). + +a(X) # ID, b(X,R) <=> R = 1 pragma passive(ID). + +passive_check2 :- + a(X), b(X,R), R == 1. diff --git a/packages/chr/Tests/primes.chr b/packages/chr/Tests/primes.chr new file mode 100644 index 000000000..1cd0bf835 --- /dev/null +++ b/packages/chr/Tests/primes.chr @@ -0,0 +1,41 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Sieve of eratosthenes to compute primes +%% thom fruehwirth 920218-20, 980311 +%% christian holzbaur 980207 for Sicstus CHR +%% +%% ported to hProlog by Tom Schrijvers + +:- module(primes,[primes/0]). +:- use_module(library(chr)). + +:- chr_constraint candidate/1. +:- chr_constraint prime/1. +:- chr_constraint cleanup/1. + +:- chr_option(debug,off). +:- chr_option(optimize,full). + +candidate(1) <=> true. +candidate(N) <=> prime(N), N1 is N - 1, candidate(N1). + +absorb @ prime(Y) \ prime(X) <=> 0 =:= X mod Y | true. + +cleanup(_L), candidate(_X) <=> fail. +cleanup(L), prime(N) <=> L = [N|T], cleanup(T). +cleanup(L) <=> L = []. + +primes :- + candidate(100), + cleanup(L), + sort(L,SL), + SL == [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]. + + + + + + + + + diff --git a/packages/chr/Tests/trigger_no_active_occurrence.chr b/packages/chr/Tests/trigger_no_active_occurrence.chr new file mode 100644 index 000000000..1e620860c --- /dev/null +++ b/packages/chr/Tests/trigger_no_active_occurrence.chr @@ -0,0 +1,13 @@ +:- module(trigger_no_active_occurrence,[trigger_no_active_occurrence/0]). + +:- use_module(library(chr)). + +:- chr_constraint a/1, b/2. + +a(X) # ID , b(X,R) <=> R = 1 pragma passive(ID). + +trigger_no_active_occurrence :- + a(X), + X = 1, + b(1,R), + R == 1. diff --git a/packages/chr/Tests/zebra.chr b/packages/chr/Tests/zebra.chr new file mode 100644 index 000000000..5c245a473 --- /dev/null +++ b/packages/chr/Tests/zebra.chr @@ -0,0 +1,117 @@ +:- module(zebra,[zebra/0]). +:- use_module(library(chr)). + +:- use_module(library(lists)). + +/* +1. The Englishman lives in the red house. +2. The Spaniard owns the dog. +3. Coffee is drunk in the green house. +4. The Ukrainian drinks tea. +5. The green house is immediately to the right of the ivory house. +6. The Porsche driver owns snails. +7. The Masserati is driven by the man who lives in the yellow house. +8. Milk is drunk in the middle house. +9. The Norwegian lives in the first house on the left. +10. The man who drives a Saab lives in the house next to the man + with the fox. +11. The Masserati is driven by the man in the house next to the + house where the horse is kept. +12. The Honda driver drinks orange juice. +13. The Japanese drives a Jaguar. +14. The Norwegian lives next to the blue house. +*/ + +:- chr_constraint domain/2, diff/2, cleanup/0. + +zebra :- + solve(Solution), + cleanup, + Solution == [[yellow,norwegian,masserati,water,fox],[blue,ukranian,saab,tea,horse],[red,english,porsche,milk,snails],[ivory,spanish,honda,orange,dog],[green,japanese,jaguar,coffee,zebra]]. + +domain(_X,[]) <=> fail. +domain(X,[V]) <=> X = V. +domain(X,L1), domain(X,L2) <=> intersection(L1,L2,L3), domain(X,L3). + +diff(X,Y), domain(X,L) <=> nonvar(Y) | select(Y,L,NL), domain(X,NL). +diff(X,Y) <=> nonvar(X), nonvar(Y) | X \== Y. + +cleanup, domain(_,_) <=> writeln(a), fail. +cleanup, diff(_,_) <=> writeln(b), fail. +cleanup <=> true. + +all_different([]). +all_different([H|T]) :- + all_different(T,H), + all_different(T). + +all_different([],_). +all_different([H|T],E) :- + diff(H,E), + diff(E,H), + all_different(T,E). + +solve(S) :- + [ [ ACo, AN, ACa, AD, AP ], + [ BCo, BN, BCa, BD, BP ], + [ CCo, CN, CCa, CD, CP ], + [ DCo, DN, DCa, DD, DP ], + [ ECo, EN, ECa, ED, EP ] ] = S, + domain(ACo,[red,green,ivory,yellow,blue]), + domain(BCo,[red,green,ivory,yellow,blue]), + domain(CCo,[red,green,ivory,yellow,blue]), + domain(DCo,[red,green,ivory,yellow,blue]), + domain(ECo,[red,green,ivory,yellow,blue]), + domain(AN ,[english,spanish,ukranian,norwegian,japanese]), + domain(BN ,[english,spanish,ukranian,norwegian,japanese]), + domain(CN ,[english,spanish,ukranian,norwegian,japanese]), + domain(DN ,[english,spanish,ukranian,norwegian,japanese]), + domain(EN ,[english,spanish,ukranian,norwegian,japanese]), + domain(ACa,[porsche,masserati,saab,honda,jaguar]), + domain(BCa,[porsche,masserati,saab,honda,jaguar]), + domain(CCa,[porsche,masserati,saab,honda,jaguar]), + domain(DCa,[porsche,masserati,saab,honda,jaguar]), + domain(ECa,[porsche,masserati,saab,honda,jaguar]), + domain(AD ,[coffee,tea,milk,orange,water]), + domain(BD ,[coffee,tea,milk,orange,water]), + domain(CD ,[coffee,tea,milk,orange,water]), + domain(DD ,[coffee,tea,milk,orange,water]), + domain(ED ,[coffee,tea,milk,orange,water]), + domain(AP ,[dog,snails,fox,horse,zebra]), + domain(BP ,[dog,snails,fox,horse,zebra]), + domain(CP ,[dog,snails,fox,horse,zebra]), + domain(DP ,[dog,snails,fox,horse,zebra]), + domain(EP ,[dog,snails,fox,horse,zebra]), + all_different([ACo,BCo,CCo,DCo,ECo]), + all_different([AN ,BN ,CN ,DN ,EN ]), + all_different([ACa,BCa,CCa,DCa,ECa]), + all_different([AD ,BD ,CD ,DD ,ED ]), + all_different([AP ,BP ,CP ,DP ,EP ]), + [_,_,[_,_,_,milk,_],_,_] = S, % clue 8 + [[_,norwegian,_,_,_],_,_,_,_] = S , % clue 9 + member( [green,_,_,coffee,_], S), % clue 3 + member( [red,english,_,_,_], S), % clue 1 + member( [_,ukranian,_,tea,_], S), % clue 4 + member( [yellow,_,masserati,_,_], S), % clue 7 + member( [_,_,honda,orange,_], S), % clue 12 + member( [_,japanese,jaguar,_,_], S), % clue 13 + member( [_,spanish,_,_,dog], S), % clue 2 + member( [_,_,porsche,_,snails], S), % clue 6 + left_right( [ivory,_,_,_,_], [green,_,_,_,_], S), % clue 5 + next_to( [_,norwegian,_,_,_],[blue,_,_,_,_], S), % clue 14 + next_to( [_,_,masserati,_,_],[_,_,_,_,horse], S), % clue 11 + next_to( [_,_,saab,_,_], [_,_,_,_,fox], S), % clue 10 + true. + +% left_right(L, R, X) is true when L is to the immediate left of R in list X + +left_right(L, R, [L, R | _]). + +left_right(L, R, [_ | X]) :- left_right(L, R, X). + + +% next_to(X, Y, L) is true when X and Y are next to each other in list L + +next_to(X, Y, L) :- left_right(X, Y, L). + +next_to(X, Y, L) :- left_right(Y, X, L). diff --git a/packages/chr/a_star.pl b/packages/chr/a_star.pl new file mode 100644 index 000000000..4797a75b3 --- /dev/null +++ b/packages/chr/a_star.pl @@ -0,0 +1,77 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(a_star, + [ + a_star/4 + ]). + +:- use_module(binomialheap). + +:- use_module(find). + +:- use_module(library(dialect/hprolog)). + +a_star(DataIn,FinalData,ExpandData,DataOut) :- + a_star_node(DataIn,0,InitialNode), + empty_q(NewQueue), + insert_q(NewQueue,InitialNode,Queue), + a_star_aux(Queue,FinalData,ExpandData,EndNode), + a_star_node(DataOut,_,EndNode). + +a_star_aux(Queue,FinalData,ExpandData,EndNode) :- + delete_min_q(Queue,Queue1,Node), + ( final_node(FinalData,Node) -> + Node = EndNode + ; + expand_node(ExpandData,Node,Nodes), + insert_list_q(Nodes,Queue1,NQueue), + a_star_aux(NQueue,FinalData,ExpandData,EndNode) + ). + +final_node(D^Call,Node) :- + a_star_node(Data,_,Node), + term_variables(Call,Vars), + chr_delete(Vars,D,DVars), + copy_term(D^Call-DVars,Data^NCall-DVars), + call(NCall). + +expand_node(D^Ds^C^Call,Node,Nodes) :- + a_star_node(Data,Score,Node), + term_variables(Call,Vars), + chr_delete(Vars,D,DVars0), + chr_delete(DVars0,Ds,DVars1), + chr_delete(DVars1,C,DVars), + copy_term(D^Ds^C^Call-DVars,Data^EData^Cost^NCall-DVars), + term_variables(Node,NVars,DVars), + find_with_var_identity(ENode,NVars,(NCall,EScore is Cost + Score,a_star:a_star_node(EData,EScore,ENode)),Nodes). + +a_star_node(Data,Score,Data-Score). diff --git a/packages/chr/binomialheap.pl b/packages/chr/binomialheap.pl new file mode 100644 index 000000000..f05522716 --- /dev/null +++ b/packages/chr/binomialheap.pl @@ -0,0 +1,139 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Binomial Heap imlementation based on +% +% Functional Binomial Queues +% James F. King +% University of Glasgow +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- module(binomialheap, + [ + empty_q/1, + insert_q/3, + insert_list_q/3, + delete_min_q/3, + find_min_q/2 + ]). + +:- use_module(library(lists),[reverse/2]). + +% data Tree a = Node a [Tree a] +% type BinQueue a = [Maybe (Tree a)] +% data Maybe a = Zero | One a +% type Item = (Entry,Key) + +key(_-Key,Key). + +empty_q([]). + +meld_q(P,Q,R) :- + meld_qc(P,Q,zero,R). + +meld_qc([],Q,zero,Q) :- !. +meld_qc([],Q,C,R) :- !, + meld_q(Q,[C],R). +meld_qc(P,[],C,R) :- !, + meld_qc([],P,C,R). +meld_qc([zero|Ps],[zero|Qs],C,R) :- !, + R = [C | Rs], + meld_q(Ps,Qs,Rs). +meld_qc([one(node(X,Xs))|Ps],[one(node(Y,Ys))|Qs],C,R) :- !, + key(X,KX), + key(Y,KY), + ( KX < KY -> + T = node(X,[node(Y,Ys)|Xs]) + ; + T = node(Y,[node(X,Xs)|Ys]) + ), + R = [C|Rs], + meld_qc(Ps,Qs,one(T),Rs). +meld_qc([P|Ps],[Q|Qs],C,Rs) :- + meld_qc([Q|Ps],[C|Qs],P,Rs). + +insert_q(Q,I,NQ) :- + meld_q([one(node(I,[]))],Q,NQ). + +insert_list_q([],Q,Q). +insert_list_q([I|Is],Q,NQ) :- + insert_q(Q,I,Q1), + insert_list_q(Is,Q1,NQ). + +min_tree([T|Ts],MT) :- + min_tree_acc(Ts,T,MT). + +min_tree_acc([],MT,MT). +min_tree_acc([T|Ts],Acc,MT) :- + least(T,Acc,NAcc), + min_tree_acc(Ts,NAcc,MT). + +least(zero,T,T) :- !. +least(T,zero,T) :- !. +least(one(node(X,Xs)),one(node(Y,Ys)),T) :- + key(X,KX), + key(Y,KY), + ( KX < KY -> + T = one(node(X,Xs)) + ; + T = one(node(Y,Ys)) + ). + +remove_tree([],_,[]). +remove_tree([T|Ts],I,[NT|NTs]) :- + ( T == zero -> + NT = T + ; + T = one(node(X,_)), + ( X == I -> + NT = zero + ; + NT = T + ) + ), + remove_tree(Ts,I,NTs). + +delete_min_q(Q,NQ,Min) :- + min_tree(Q,one(node(Min,Ts))), + remove_tree(Q,Min,Q1), + reverse(Ts,RTs), + make_ones(RTs,Q2), + meld_q(Q2,Q1,NQ). + +make_ones([],[]). +make_ones([N|Ns],[one(N)|RQ]) :- + make_ones(Ns,RQ). + +find_min_q(Q,I) :- + min_tree(Q,one(node(I,_))). + + diff --git a/packages/chr/builtins.pl b/packages/chr/builtins.pl new file mode 100644 index 000000000..7727136d8 --- /dev/null +++ b/packages/chr/builtins.pl @@ -0,0 +1,625 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(builtins, + [ + negate_b/2, + entails_b/2, + binds_b/2, + builtin_binds_b/2 + ]). + +:- use_module(library(dialect/hprolog)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +negate_b(A,B) :- once(negate(A,B)). +negate((A,B),NotB) :- A==true,negate(B,NotB). % added by jon +negate((A,B),NotA) :- B==true,negate(A,NotA). % added by jon +negate((A,B),(NotA;NotB)) :- negate(A,NotA),negate(B,NotB). % added by jon +negate((A;B),(NotA,NotB)) :- negate(A,NotA),negate(B,NotB). % added by jon +negate(true,fail). +negate(fail,true). +negate(X =< Y, Y < X). +negate(X > Y, Y >= X). +negate(X >= Y, Y > X). +negate(X < Y, Y =< X). +negate(X == Y, X \== Y). % added by jon +negate(X \== Y, X == Y). % added by jon +negate(X =:= Y, X =\= Y). % added by jon +negate(X is Y, X =\= Y). % added by jon +negate(X =\= Y, X =:= Y). % added by jon +negate(X = Y, X \= Y). % added by jon +negate(X \= Y, X = Y). % added by jon +negate(var(X),nonvar(X)). +negate(nonvar(X),var(X)). +negate(\+ X,X). % added by jon +negate(X,\+ X). % added by jon + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +entails_b(fail,_) :-!. +entails_b(A,B) :- + ( var(B) -> + entails(A,B,[A]) + ; + once(( + entails(A,C,[A]), + B == C + )) + ). + +entails(A,A,_). +entails(A,C,History) :- + entails_(A,B), + \+ memberchk_eq(B,History), + entails(B,C,[B|History]). + +entails_(X > Y, X >= Y). +entails_(X > Y, Y < X). +entails_(X >= Y, Y =< X). +entails_(X =< Y, Y >= X). %added by jon +entails_(X < Y, Y > X). +entails_(X < Y, X =< Y). +entails_(X > Y, X \== Y). +entails_(X \== Y, Y \== X). +entails_(X == Y, Y == X). +entails_(X == Y, X =:= Y) :- ground(X). %added by jon +entails_(X == Y, X =:= Y) :- ground(Y). %added by jon +entails_(X \== Y, X =\= Y) :- ground(X). %added by jon +entails_(X \== Y, X =\= Y) :- ground(Y). %added by jon +entails_(X =:= Y, Y =:= X). %added by jon +entails_(X =\= Y, Y =\= X). %added by jon +entails_(X == Y, X >= Y). %added by jon +entails_(X == Y, X =< Y). %added by jon +entails_(ground(X),nonvar(X)). +entails_(compound(X),nonvar(X)). +entails_(atomic(X),nonvar(X)). +entails_(number(X),nonvar(X)). +entails_(atom(X),nonvar(X)). +entails_(fail,true). + +builtin_binds_b(G,Vars) :- + builtin_binds_(G,L,[]), + sort(L,Vars). + +builtin_binds_(var(_),L,L). +builtin_binds_(nonvar(_),L,L). +builtin_binds_(ground(_),L,L). +builtin_binds_(compound(_),L,L). +builtin_binds_(number(_),L,L). +builtin_binds_(atom(_),L,L). +builtin_binds_(atomic(_),L,L). +builtin_binds_(integer(_),L,L). +builtin_binds_(float(_),L,L). + +builtin_binds_(?=(_, _), L, L). +builtin_binds_(_<_, L, L). +builtin_binds_(_=:=_, L, L). +builtin_binds_(_=<_, L, L). +builtin_binds_(_==_, L, L). +builtin_binds_(_=@=_, L, L). +builtin_binds_(_=\=_, L, L). +builtin_binds_(_>=_, L, L). +builtin_binds_(_>_, L, L). +builtin_binds_(_@<_, L, L). +builtin_binds_(_@=<_, L, L). +builtin_binds_(_@>=_, L, L). +builtin_binds_(_@>_, L, L). +builtin_binds_(_\==_, L, L). +builtin_binds_(_\=@=_, L, L). +builtin_binds_(true,L,L). + +% TODO: check all these SWI-Prolog built-ins for binding behavior. +% +% builtin_binds_(format(_,_),L,L). +% builtin_binds_(portray(_), L, L). +% builtin_binds_(write(_), L, L). +% builtin_binds_(write(_),L,L). +% builtin_binds_(write(_, _), L, L). +% builtin_binds_(write_canonical(_), L, L). +% builtin_binds_(write_canonical(_, _), L, L). +% builtin_binds_(write_term(_, _), L, L). +% builtin_binds_(write_term(_, _, _), L, L). +% builtin_binds_(writef(_), L, L). +% builtin_binds_(writef(_, _), L, L). +% builtin_binds_(writeln(_), L, L). +% builtin_binds_(writeln(_),L,L). +% builtin_binds_(writeq(_), L, L). +% builtin_binds_(writeq(_, _), L, L). +% +% builtin_binds_(!(_), L, L). +% builtin_binds_(!, L, L). +% builtin_binds_((_'|'_), L, L). +% builtin_binds_((_*->_), L, L). +% builtin_binds_(abolish(_), L, L). +% builtin_binds_(abolish(_, _), L, L). +% builtin_binds_(abort, L, L). +% builtin_binds_(absolute_file_name(_, _), L, L). +% builtin_binds_(absolute_file_name(_, _, _), L, L). +% builtin_binds_(access_file(_, _), L, L). +% builtin_binds_(acyclic_term(_), L, L). +% builtin_binds_(add_import_module(_, _, _), L, L). +% builtin_binds_(append(_), L, L). +% builtin_binds_(apply(_, _), L, L). +% builtin_binds_(arg(_, _, _), L, L). +% builtin_binds_(arithmetic_function(_), L, L). +% builtin_binds_(assert(_), L, L). +% builtin_binds_(assert(_, _), L, L). +% builtin_binds_(asserta(_), L, L). +% builtin_binds_(asserta(_, _), L, L). +% builtin_binds_(assertz(_), L, L). +% builtin_binds_(assertz(_, _), L, L). +% builtin_binds_(at_end_of_stream(_), L, L). +% builtin_binds_(at_end_of_stream, L, L). +% builtin_binds_(at_halt(_), L, L). +% builtin_binds_(at_initialization(_), L, L). +% builtin_binds_(atom(_), L, L). +% builtin_binds_(atom_chars(_, _), L, L). +% builtin_binds_(atom_codes(_, _), L, L). +% builtin_binds_(atom_concat(_, _, _), L, L). +% builtin_binds_(atom_length(_, _), L, L). +% builtin_binds_(atom_number(_, _), L, L). +% builtin_binds_(atom_prefix(_, _), L, L). +% builtin_binds_(atom_to_term(_, _, _), L, L). +% builtin_binds_(atomic(_), L, L). +% builtin_binds_(attvar(_), L, L). +% builtin_binds_(autoload(_), L, L). +% builtin_binds_(autoload, L, L). +% builtin_binds_(b_getval(_, _), L, L). +% builtin_binds_(b_setval(_, _), L, L). +% builtin_binds_(bagof(_, _, _), L, L). +% builtin_binds_(between(_, _, _), L, L). +% builtin_binds_(block(_, _, _), L, L). +% builtin_binds_(break, L, L). +% builtin_binds_(byte_count(_, _), L, L). +% builtin_binds_(call(_), L, L). +% builtin_binds_(call(_, _), L, L). +% builtin_binds_(call(_, _, _), L, L). +% builtin_binds_(call(_, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _, _, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _, _, _, _, _, _), L, L). +% builtin_binds_(call(_, _, _, _, _, _, _, _, _, _, _), L, L). +% builtin_binds_(call_cleanup(_, _), L, L). +% builtin_binds_(call_cleanup(_, _, _), L, L). +% builtin_binds_(call_shared_object_function(_, _), L, L). +% builtin_binds_(call_with_depth_limit(_, _, _), L, L). +% builtin_binds_(callable(_), L, L). +% builtin_binds_(catch(_, _, _), L, L). +% builtin_binds_(char_code(_, _), L, L). +% builtin_binds_(char_conversion(_, _), L, L). +% builtin_binds_(char_type(_, _), L, L). +% builtin_binds_(character_count(_, _), L, L). +% builtin_binds_(clause(_, _), L, L). +% builtin_binds_(clause(_, _, _), L, L). +% builtin_binds_(clause_property(_, _), L, L). +% builtin_binds_(close(_), L, L). +% builtin_binds_(close(_, _), L, L). +% builtin_binds_(close_shared_object(_), L, L). +% builtin_binds_(code_type(_, _), L, L). +% builtin_binds_(collation_key(_, _), L, L). +% builtin_binds_(compare(_, _, _), L, L). +% builtin_binds_(compile_aux_clauses(_), L, L). +% builtin_binds_(compile_predicates(_), L, L). +% builtin_binds_(compiling, L, L). +% builtin_binds_(compound(_), L, L). +% builtin_binds_(concat_atom(_, _), L, L). +% builtin_binds_(concat_atom(_, _, _), L, L). +% builtin_binds_(consult(_), L, L). +% builtin_binds_(context_module(_), L, L). +% builtin_binds_(copy_stream_data(_, _), L, L). +% builtin_binds_(copy_stream_data(_, _, _), L, L). +% builtin_binds_(copy_term(_, _), L, L). +% builtin_binds_(copy_term_nat(_, _), L, L). +% builtin_binds_(current_arithmetic_function(_), L, L). +% builtin_binds_(current_atom(_), L, L). +% builtin_binds_(current_blob(_, _), L, L). +% builtin_binds_(current_char_conversion(_, _), L, L). +% builtin_binds_(current_flag(_), L, L). +% builtin_binds_(current_format_predicate(_, _), L, L). +% builtin_binds_(current_functor(_, _), L, L). +% builtin_binds_(current_input(_), L, L). +% builtin_binds_(current_key(_), L, L). +% builtin_binds_(current_module(_), L, L). +% builtin_binds_(current_module(_, _), L, L). +% builtin_binds_(current_op(_, _, _), L, L). +% builtin_binds_(current_output(_), L, L). +% builtin_binds_(current_predicate(_), L, L). +% builtin_binds_(current_predicate(_, _), L, L). +% builtin_binds_(current_prolog_flag(_, _), L, L). +% builtin_binds_(current_resource(_, _, _), L, L). +% builtin_binds_(current_signal(_, _, _), L, L). +% builtin_binds_(cyclic_term(_), L, L). +% builtin_binds_(date_time_stamp(_, _), L, L). +% builtin_binds_(debugging, L, L). +% builtin_binds_(default_module(_, _), L, L). +% builtin_binds_(del_attr(_, _), L, L). +% builtin_binds_(delete_directory(_), L, L). +% builtin_binds_(delete_file(_), L, L). +% builtin_binds_(delete_import_module(_, _), L, L). +% builtin_binds_(deterministic(_), L, L). +% builtin_binds_(downcase_atom(_, _), L, L). +% builtin_binds_(duplicate_term(_, _), L, L). +% builtin_binds_(dwim_match(_, _), L, L). +% builtin_binds_(dwim_match(_, _, _), L, L). +% builtin_binds_(dwim_predicate(_, _), L, L). +% builtin_binds_(ensure_loaded(_), L, L). +% builtin_binds_(erase(_), L, L). +% builtin_binds_(eval_license, L, L). +% builtin_binds_(exists_directory(_), L, L). +% builtin_binds_(exists_file(_), L, L). +% builtin_binds_(exit(_, _), L, L). +% builtin_binds_(expand_file_name(_, _), L, L). +% builtin_binds_(expand_file_search_path(_, _), L, L). +% builtin_binds_(expand_goal(_, _), L, L). +% builtin_binds_(expand_term(_, _), L, L). +% builtin_binds_(export(_), L, L). +% builtin_binds_(export_list(_, _), L, L). +% builtin_binds_(fail(_), L, L). +% builtin_binds_(fail, L, L). +% builtin_binds_(file_base_name(_, _), L, L). +% builtin_binds_(file_directory_name(_, _), L, L). +% builtin_binds_(file_name_extension(_, _, _), L, L). +% builtin_binds_(fileerrors(_, _), L, L). +% builtin_binds_(findall(_, _, _), L, L). +% builtin_binds_(findall(_, _, _, _), L, L). +% builtin_binds_(flag(_, _, _), L, L). +% builtin_binds_(float(_), L, L). +% builtin_binds_(flush_output(_), L, L). +% builtin_binds_(flush_output, L, L). +% builtin_binds_(forall(_, _), L, L). +% builtin_binds_(format(_), L, L). +% builtin_binds_(format(_, _), L, L). +% builtin_binds_(format(_, _, _), L, L). +% builtin_binds_(format_predicate(_, _), L, L). +% builtin_binds_(format_time(_, _, _), L, L). +% builtin_binds_(format_time(_, _, _, _), L, L). +% builtin_binds_(freeze(_, _), L, L). +% builtin_binds_(frozen(_, _), L, L). +% builtin_binds_(functor(_, _, _), L, L). +% builtin_binds_(garbage_collect, L, L). +% builtin_binds_(garbage_collect_atoms, L, L). +% builtin_binds_(garbage_collect_clauses, L, L). +% builtin_binds_(get(_), L, L). +% builtin_binds_(get(_, _), L, L). +% builtin_binds_(get0(_), L, L). +% builtin_binds_(get0(_, _), L, L). +% builtin_binds_(get_attr(_, _, _), L, L). +% builtin_binds_(get_attrs(_, _), L, L). +% builtin_binds_(get_byte(_), L, L). +% builtin_binds_(get_byte(_, _), L, L). +% builtin_binds_(get_char(_), L, L). +% builtin_binds_(get_char(_, _), L, L). +% builtin_binds_(get_code(_), L, L). +% builtin_binds_(get_code(_, _), L, L). +% builtin_binds_(get_single_char(_), L, L). +% builtin_binds_(get_time(_), L, L). +% builtin_binds_(getenv(_, _), L, L). +% builtin_binds_(ground(_), L, L). +% builtin_binds_(halt(_), L, L). +% builtin_binds_(halt, L, L). +% builtin_binds_(hash(_), L, L). +% builtin_binds_(term_hash(_, _), L, L). +% builtin_binds_(ignore(_), L, L). +% builtin_binds_(import(_), L, L). +% builtin_binds_(import_module(_, _), L, L). +% builtin_binds_(index(_), L, L). +% builtin_binds_(integer(_), L, L). +% builtin_binds_(is_absolute_file_name(_), L, L). +% builtin_binds_(is_list(_), L, L). +% builtin_binds_(is_stream(_), L, L). +% builtin_binds_(keysort(_, _), L, L). +% builtin_binds_(leash(_), L, L). +% builtin_binds_(length(_, _), L, L). +% builtin_binds_(license(_), L, L). +% builtin_binds_(license(_, _), L, L). +% builtin_binds_(line_count(_, _), L, L). +% builtin_binds_(line_position(_, _), L, L). +% builtin_binds_(load_files(_), L, L). +% builtin_binds_(load_files(_, _), L, L). +% builtin_binds_(make_directory(_), L, L). +% builtin_binds_(make_library_index(_), L, L). +% builtin_binds_(make_library_index(_, _), L, L). +% builtin_binds_(maplist(_, _), L, L). +% builtin_binds_(maplist(_, _, _), L, L). +% builtin_binds_(maplist(_, _, _, _), L, L). +% builtin_binds_(memberchk(_, _), L, L). +% builtin_binds_(message_queue_create(_), L, L). +% builtin_binds_(message_queue_create(_, _), L, L). +% builtin_binds_(message_queue_destroy(_), L, L). +% builtin_binds_(message_queue_property(_, _), L, L). +% builtin_binds_(message_to_string(_, _), L, L). +% builtin_binds_(module(_), L, L). +% builtin_binds_(msort(_, _), L, L). +% builtin_binds_(mutex_create(_), L, L). +% builtin_binds_(mutex_create(_, _), L, L). +% builtin_binds_(mutex_destroy(_), L, L). +% builtin_binds_(mutex_lock(_), L, L). +% builtin_binds_(mutex_property(_, _), L, L). +% builtin_binds_(mutex_statistics, L, L). +% builtin_binds_(mutex_trylock(_), L, L). +% builtin_binds_(mutex_unlock(_), L, L). +% builtin_binds_(mutex_unlock_all, L, L). +% builtin_binds_(name(_, _), L, L). +% builtin_binds_(nb_current(_, _), L, L). +% builtin_binds_(nb_delete(_), L, L). +% builtin_binds_(nb_getval(_, _), L, L). +% builtin_binds_(nb_linkarg(_, _, _), L, L). +% builtin_binds_(nb_linkval(_, _), L, L). +% builtin_binds_(nb_setarg(_, _, _), L, L). +% builtin_binds_(nb_setval(_, _), L, L). +% builtin_binds_(nl(_), L, L). +% builtin_binds_(nl, L, L). +% builtin_binds_(nonvar(_), L, L). +% builtin_binds_(noprofile(_), L, L). +% builtin_binds_(noprotocol, L, L). +% builtin_binds_(nospy(_), L, L). +% builtin_binds_(nospyall, L, L). +% builtin_binds_(not(_), L, L). +% builtin_binds_(notrace(_), L, L). +% builtin_binds_(notrace, L, L). +% builtin_binds_(nth_clause(_, _, _), L, L). +% builtin_binds_(number(_), L, L). +% builtin_binds_(number_chars(_, _), L, L). +% builtin_binds_(number_codes(_, _), L, L). +% builtin_binds_(numbervars(_, _, _), L, L). +% builtin_binds_(numbervars(_, _, _, _), L, L). +% builtin_binds_(on_signal(_, _, _), L, L). +% builtin_binds_(once(_), L, L). +% builtin_binds_(op(_, _, _), L, L). +% builtin_binds_(open(_, _, _), L, L). +% builtin_binds_(open(_, _, _, _), L, L). +% builtin_binds_(open_null_stream(_), L, L). +% builtin_binds_(open_resource(_, _, _), L, L). +% builtin_binds_(open_resource(_, _, _, _), L, L). +% builtin_binds_(open_shared_object(_, _), L, L). +% builtin_binds_(open_shared_object(_, _, _), L, L). +% builtin_binds_(open_xterm(_, _, _, _), L, L). +% builtin_binds_(peek_byte(_), L, L). +% builtin_binds_(peek_byte(_, _), L, L). +% builtin_binds_(peek_char(_), L, L). +% builtin_binds_(peek_char(_, _), L, L). +% builtin_binds_(peek_code(_), L, L). +% builtin_binds_(peek_code(_, _), L, L). +% builtin_binds_(phrase(_, _), L, L). +% builtin_binds_(phrase(_, _, _), L, L). +% builtin_binds_(plus(_, _, _), L, L). +% builtin_binds_(predicate_property(_, _), L, L). +% builtin_binds_(preprocessor(_, _), L, L). +% builtin_binds_(print(_), L, L). +% builtin_binds_(print(_, _), L, L). +% builtin_binds_(print_message(_, _), L, L). +% builtin_binds_(print_message_lines(_, _, _), L, L). +% builtin_binds_(profiler(_, _), L, L). +% builtin_binds_(prolog, L, L). +% builtin_binds_(prolog_choice_attribute(_, _, _), L, L). +% builtin_binds_(prolog_current_frame(_), L, L). +% builtin_binds_(prolog_frame_attribute(_, _, _), L, L). +% builtin_binds_(prolog_load_context(_, _), L, L). +% builtin_binds_(prolog_skip_level(_, _), L, L). +% builtin_binds_(prolog_to_os_filename(_, _), L, L). +% builtin_binds_(prompt(_, _), L, L). +% builtin_binds_(prompt1(_), L, L). +% builtin_binds_(protocol(_), L, L). +% builtin_binds_(protocola(_), L, L). +% builtin_binds_(protocolling(_), L, L). +% builtin_binds_(put(_), L, L). +% builtin_binds_(put(_, _), L, L). +% builtin_binds_(put_attr(_, _, _), L, L). +% builtin_binds_(put_attrs(_, _), L, L). +% builtin_binds_(put_byte(_), L, L). +% builtin_binds_(put_byte(_, _), L, L). +% builtin_binds_(put_char(_), L, L). +% builtin_binds_(put_char(_, _), L, L). +% builtin_binds_(put_code(_), L, L). +% builtin_binds_(put_code(_, _), L, L). +% builtin_binds_(qcompile(_), L, L). +% builtin_binds_(rational(_), L, L). +% builtin_binds_(rational(_, _, _), L, L). +% builtin_binds_(read(_), L, L). +% builtin_binds_(read(_, _), L, L). +% builtin_binds_(read_clause(_), L, L). +% builtin_binds_(read_clause(_, _), L, L). +% builtin_binds_(read_history(_, _, _, _, _, _), L, L). +% builtin_binds_(read_link(_, _, _), L, L). +% builtin_binds_(read_pending_input(_, _, _), L, L). +% builtin_binds_(read_term(_, _), L, L). +% builtin_binds_(read_term(_, _, _), L, L). +% builtin_binds_(recorda(_, _), L, L). +% builtin_binds_(recorda(_, _, _), L, L). +% builtin_binds_(recorded(_, _), L, L). +% builtin_binds_(recorded(_, _, _), L, L). +% builtin_binds_(recordz(_, _), L, L). +% builtin_binds_(recordz(_, _, _), L, L). +% builtin_binds_(redefine_system_predicate(_), L, L). +% builtin_binds_(reload_library_index, L, L). +% builtin_binds_(rename_file(_, _), L, L). +% builtin_binds_(repeat, L, L). +% builtin_binds_(require(_), L, L). +% builtin_binds_(reset_profiler, L, L). +% builtin_binds_(retract(_), L, L). +% builtin_binds_(retractall(_), L, L). +% builtin_binds_(same_file(_, _), L, L). +% builtin_binds_(same_term(_, _), L, L). +% builtin_binds_(see(_), L, L). +% builtin_binds_(seeing(_), L, L). +% builtin_binds_(seek(_, _, _, _), L, L). +% builtin_binds_(seen, L, L). +% builtin_binds_(set_input(_), L, L). +% builtin_binds_(set_output(_), L, L). +% builtin_binds_(set_prolog_IO(_, _, _), L, L). +% builtin_binds_(set_prolog_flag(_, _), L, L). +% builtin_binds_(set_stream(_, _), L, L). +% builtin_binds_(set_stream_position(_, _), L, L). +% builtin_binds_(setarg(_, _, _), L, L). +% builtin_binds_(setenv(_, _), L, L). +% builtin_binds_(setlocale(_, _, _), L, L). +% builtin_binds_(setof(_, _, _), L, L). +% builtin_binds_(setup_and_call_cleanup(_, _, _), L, L). +% builtin_binds_(setup_and_call_cleanup(_, _, _, _), L, L). +% builtin_binds_(shell(_), L, L). +% builtin_binds_(shell(_, _), L, L). +% builtin_binds_(shell, L, L). +% builtin_binds_(size_file(_, _), L, L). +% builtin_binds_(skip(_), L, L). +% builtin_binds_(skip(_, _), L, L). +% builtin_binds_(sleep(_), L, L). +% builtin_binds_(sort(_, _), L, L). +% builtin_binds_(source_file(_), L, L). +% builtin_binds_(source_file(_, _), L, L). +% builtin_binds_(source_location(_, _), L, L). +% builtin_binds_(spy(_), L, L). +% builtin_binds_(stamp_date_time(_, _, _), L, L). +% builtin_binds_(statistics(_, _), L, L). +% builtin_binds_(statistics, L, L). +% builtin_binds_(stream_position_data(_, _, _), L, L). +% builtin_binds_(stream_property(_, _), L, L). +% builtin_binds_(string(_), L, L). +% builtin_binds_(string_concat(_, _, _), L, L). +% builtin_binds_(string_length(_, _), L, L). +% builtin_binds_(atom_string(_, _), L, L). +% builtin_binds_(string_codes(_, _), L, L). +% builtin_binds_(strip_module(_, _, _), L, L). +% builtin_binds_(style_check(_), L, L). +% builtin_binds_(sub_atom(_, _, _, _, _), L, L). +% builtin_binds_(sub_string(_, _, _, _, _), L, L). +% builtin_binds_(succ(_, _), L, L). +% builtin_binds_(swritef(_, _), L, L). +% builtin_binds_(swritef(_, _, _), L, L). +% builtin_binds_(tab(_), L, L). +% builtin_binds_(tab(_, _), L, L). +% builtin_binds_(tell(_), L, L). +% builtin_binds_(telling(_), L, L). +% builtin_binds_(term_to_atom(_, _), L, L). +% builtin_binds_(term_variables(_, _), L, L). +% builtin_binds_(term_variables(_, _, _), L, L). +% builtin_binds_(thread_at_exit(_), L, L). +% builtin_binds_(thread_create(_, _, _), L, L). +% builtin_binds_(thread_detach(_), L, L). +% builtin_binds_(thread_exit(_), L, L). +% builtin_binds_(thread_get_message(_), L, L). +% builtin_binds_(thread_get_message(_, _), L, L). +% builtin_binds_(thread_join(_, _), L, L). +% builtin_binds_(thread_kill(_, _), L, L). +% builtin_binds_(thread_peek_message(_), L, L). +% builtin_binds_(thread_peek_message(_, _), L, L). +% builtin_binds_(thread_property(_, _), L, L). +% builtin_binds_(thread_self(_), L, L). +% builtin_binds_(thread_send_message(_, _), L, L). +% builtin_binds_(thread_setconcurrency(_, _), L, L). +% builtin_binds_(thread_signal(_, _), L, L). +% builtin_binds_(thread_statistics(_, _, _), L, L). +% builtin_binds_(throw(_), L, L). +% builtin_binds_(time_file(_, _), L, L). +% builtin_binds_(tmp_file(_, _), L, L). +% builtin_binds_(told, L, L). +% builtin_binds_(trim_stacks, L, L). +% builtin_binds_(tty_get_capability(_, _, _), L, L). +% builtin_binds_(tty_goto(_, _), L, L). +% builtin_binds_(tty_put(_, _), L, L). +% builtin_binds_(tty_size(_, _), L, L). +% builtin_binds_(ttyflush, L, L). +% builtin_binds_(unifiable(_, _, _), L, L). +% builtin_binds_(unify_with_occurs_check(_, _), L, L). +% builtin_binds_(unsetenv(_), L, L). +% builtin_binds_(upcase_atom(_, _), L, L). +% builtin_binds_(wait_for_input(_, _, _), L, L). +% builtin_binds_(wildcard_match(_, _), L, L). +% builtin_binds_(with_mutex(_, _), L, L). +% builtin_binds_(with_output_to(_, _), L, L). +% builtin_binds_(working_directory(_, _), L, L). + + +% builtin_binds_(functor(Term, Functor, Arity), [Term,Functor,Arity|T], T). +% builtin_binds_(arg(Arg, Term, Pos), [Arg,Term,Pos|T], T). +% builtin_binds_(term_variables(_, _), L, L). +% builtin_binds_(X=Y, [X,Y|T], T). + + +builtin_binds_(X is _,[X|L],L). +builtin_binds_((G1,G2),L,T) :- + builtin_binds_(G1,L,R), + builtin_binds_(G2,R,T). +builtin_binds_((G1;G2),L,T) :- + builtin_binds_(G1,L,R), + builtin_binds_(G2,R,T). +builtin_binds_((G1->G2),L,T) :- + builtin_binds_(G1,L,R), + builtin_binds_(G2,R,T). + +builtin_binds_(\+ G,L,T) :- + builtin_binds_(G,L,T). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +binds_b(G,Vars) :- + binds_(G,L,[]), + sort(L,Vars). + +binds_(var(_),L,L). +binds_(nonvar(_),L,L). +binds_(ground(_),L,L). +binds_(compound(_),L,L). +binds_(number(_),L,L). +binds_(atom(_),L,L). +binds_(atomic(_),L,L). +binds_(integer(_),L,L). +binds_(float(_),L,L). + +binds_(_ > _ ,L,L). +binds_(_ < _ ,L,L). +binds_(_ =< _,L,L). +binds_(_ >= _,L,L). +binds_(_ =:= _,L,L). +binds_(_ =\= _,L,L). +binds_(_ == _,L,L). +binds_(_ \== _,L,L). +binds_(true,L,L). + +binds_(write(_),L,L). +binds_(writeln(_),L,L). +binds_(format(_,_),L,L). + +binds_(X is _,[X|L],L). +binds_((G1,G2),L,T) :- + binds_(G1,L,R), + binds_(G2,R,T). +binds_((G1;G2),L,T) :- + binds_(G1,L,R), + binds_(G2,R,T). +binds_((G1->G2),L,T) :- + binds_(G1,L,R), + binds_(G2,R,T). + +binds_(\+ G,L,T) :- + binds_(G,L,T). + +binds_(G,L,T) :- term_variables(G,GVars),append(GVars,T,L). %jon diff --git a/packages/chr/chr.yap b/packages/chr/chr.yap new file mode 100644 index 000000000..fc0854697 --- /dev/null +++ b/packages/chr/chr.yap @@ -0,0 +1,538 @@ +% +% chr.pl is generated automatically. +% This package is just here to work as a stub for YAP analysis. +% + +/** + +@defgroup CHR CHR: Constraint Handling Rules + +@ingroup swi + +This chapter is written by Tom Schrijvers, K.U. Leuven for the hProlog +system. Adjusted by Jan Wielemaker to fit the SWI-Prolog documentation +infrastructure and remove hProlog specific references. + +The CHR system of SWI-Prolog is the K.U.Leuven CHR system. The runtime +environment is written by Christian Holzbaur and Tom Schrijvers while the +compiler is written by Tom Schrijvers. Both are integrated with SWI-Prolog +and licenced under compatible conditions with permission from the authors. + +The main reference for SWI-Prolog's CHR system is: + ++ T. Schrijvers, and B. Demoen, The K.U.Leuven CHR System: Implementation and Application, First Workshop on Constraint Handling Rules: Selected +Contributions (Fruwirth, T. and Meister, M., eds.), pp. 1--5, 2004. + +# Introduction + +Constraint Handling Rules (CHR) is a committed-choice bottom-up language +embedded in Prolog. It is designed for writing constraint solvers and is +particularily useful for providing application-specific constraints. +It has been used in many kinds of applications, like scheduling, +model checking, abduction, type checking among many others. + +CHR has previously been implemented in other Prolog systems (SICStus, +Eclipse, Yap), Haskell and Java. This CHR system is based on the +compilation scheme and runtime environment of CHR in SICStus. + +In this documentation we restrict ourselves to giving a short overview +of CHR in general and mainly focus on elements specific to this +implementation. For a more thorough review of CHR we refer the reader to +[Freuhwirth:98]. More background on CHR can be found at the CHR web site. + +### Syntax and Semantics + +We present informally the syntax and semantics of CHR. + + +#### CHR Syntax + +The syntax of CHR rules in hProlog is the following: + +~~~~~ +rules --> rule, rules. +rules --> []. + +rule --> name, actual_rule, pragma, [atom(`.`)]. + +name --> atom, [atom(`@`)]. +name --> []. + +actual_rule --> simplification_rule. +actual_rule --> propagation_rule. +actual_rule --> simpagation_rule. + +simplification_rule --> constraints, [atom(`<=>`)], guard, body. +propagation_rule --> constraints, [atom(`==>`)], guard, body. +simpagation_rule --> constraints, [atom(`\`)], constraints, [atom(`<=>`)], + guard, body. + +constraints --> constraint, constraint_id. +constraints --> constraint, [atom(`,`)], constraints. + +constraint --> compound_term. + +constraint_id --> []. +constraint_id --> [atom(`#`)], variable. + +guard --> []. +guard --> goal, [atom(`|`)]. + +body --> goal. + +pragma --> []. +pragma --> [atom(`pragma`)], actual_pragmas. + +actual_pragmas --> actual_pragma. +actual_pragmas --> actual_pragma, [atom(`,`)], actual_pragmas. + +actual_pragma --> [atom(`passive(`)], variable, [atom(`)`)]. + +~~~~~ + +Additional syntax-related terminology: + ++ *head:* the constraints in an `actual_rule` before +the arrow (either `<=>` or `==>`) + + +#### Semantics Semantics + +In this subsection the operational semantics of CHR in Prolog are presented +informally. They do not differ essentially from other CHR systems. + +When a constraint is called, it is considered an active constraint and +the system will try to apply the rules to it. Rules are tried and executed +sequentially in the order they are written. + +A rule is conceptually tried for an active constraint in the following +way. The active constraint is matched with a constraint in the head of +the rule. If more constraints appear in the head they are looked for +among the suspended constraints, which are called passive constraints in +this context. If the necessary passive constraints can be found and all +match with the head of the rule and the guard of the rule succeeds, then +the rule is committed and the body of the rule executed. If not all the +necessary passive constraint can be found, the matching fails or the +guard fails, then the body is not executed and the process of trying and +executing simply continues with the following rules. If for a rule, +there are multiple constraints in the head, the active constraint will +try the rule sequentially multiple times, each time trying to match with +another constraint. + +This process ends either when the active constraint disappears, i.e. it +is removed by some rule, or after the last rule has been processed. In +the latter case the active constraint becomes suspended. + +A suspended constraint is eligible as a passive constraint for an active +constraint. The other way it may interact again with the rules, is when +a variable appearing in the constraint becomes bound to either a nonvariable +or another variable involved in one or more constraints. In that case the +constraint is triggered, i.e. it becomes an active constraint and all +the rules are tried. + +### Rules + +There are three different kinds of rules, each with their specific semantics: + ++ simplification +The simplification rule removes the constraints in its head and calls its body. + ++ propagation +The propagation rule calls its body exactly once for the constraints in +its head. + ++ simpagation +The simpagation rule removes the constraints in its head after the +`\` and then calls its body. It is an optimization of +simplification rules of the form: \[constraints_1, constraints_2 <=> +constraints_1, body \] Namely, in the simpagation form: + +~~~~~ +constraints1 \ constraints2 <=> body +~~~~~ + _constraints1_ +constraints are not called in the body. + + + +#### Rule Names + +Naming a rule is optional and has no semantical meaning. It only functions +as documentation for the programmer. + +### Pragmas + +The semantics of the pragmas are: + ++ passive(Identifier) +The constraint in the head of a rule _Identifier_ can only act as a +passive constraint in that rule. + + +Additional pragmas may be released in the future. + +### CHR_Options Options + +It is possible to specify options that apply to all the CHR rules in the module. +Options are specified with the `option/2` declaration: + +~~~~~ + option(Option,Value). +~~~~~ + +Available options are: + ++ check_guard_bindings +This option controls whether guards should be checked for illegal +variable bindings or not. Possible values for this option are +`on`, to enable the checks, and `off`, to disable the +checks. + ++ optimize +This is an experimental option controlling the degree of optimization. +Possible values are `full`, to enable all available +optimizations, and `off` (default), to disable all optimizations. +The default is derived from the SWI-Prolog flag `optimise`, where +`true` is mapped to `full`. Therefore the commandline +option `-O` provides full CHR optimization. +If optimization is enabled, debugging should be disabled. + ++ debug +This options enables or disables the possibility to debug the CHR code. +Possible values are `on` (default) and `off`. See +`debugging` for more details on debugging. The default is +derived from the prolog flag `generate_debug_info`, which +is `true` by default. See `-nodebug`. +If debugging is enabled, optimization should be disabled. + ++ mode +This option specifies the mode for a particular constraint. The +value is a term with functor and arity equal to that of a constraint. +The arguments can be one of `-`, `+` or `?`. +The latter is the default. The meaning is the following: + ++ - +The corresponding argument of every occurrence +of the constraint is always unbound. ++ + +The corresponding argument of every occurrence +of the constraint is always ground. ++ ? +The corresponding argument of every occurrence +of the constraint can have any instantiation, which may change +over time. This is the default value. + +The declaration is used by the compiler for various optimizations. +Note that it is up to the user the ensure that the mode declaration +is correct with respect to the use of the constraint. +This option may occur once for each constraint. + ++ type_declaration +This option specifies the argument types for a particular constraint. The +value is a term with functor and arity equal to that of a constraint. +The arguments can be a user-defined type or one of +the built-in types: + ++ int +The corresponding argument of every occurrence +of the constraint is an integer number. ++ float +...{} a floating point number. ++ number +...{} a number. ++ natural +...{} a positive integer. ++ any +The corresponding argument of every occurrence +of the constraint can have any type. This is the default value. + + +Currently, type declarations are only used to improve certain +optimizations (guard simplification, occurrence subsumption, ...{}). + ++ type_definition +This option defines a new user-defined type which can be used in +type declarations. The value is a term of the form +`type(` _name_`,` _list_`)`, where + _name_ is a term and _list_ is a list of alternatives. +Variables can be used to define generic types. Recursive definitions +are allowed. Examples are + +~~~~~ +type(bool,[true,false]). +type(complex_number,[float + float * i]). +type(binary_tree(T),[ leaf(T) | node(binary_tree(T),binary_tree(T)) ]). +type(list(T),[ [] | [T | list(T)]). +~~~~~ + + + +The mode, type_declaration and type_definition options are provided +for backward compatibility. The new syntax is described below. + + + +### CHR in Prolog Programs + + +The CHR constraints defined in a particulary chr file are +associated with a module. The default module is `user`. One should +never load different chr files with the same CHR module name. + + + +#### Constraint Declarations + + +Every constraint used in CHR rules has to be declared. +There are two ways to do this. The old style is as follows: + +~~~~~ +option(type_definition,type(list(T),[ [] , [T|list(T)] ]). +option(mode,foo(+,?)). +option(type_declaration,foo(list(int),float)). +:- constraints foo/2, bar/0. +~~~~~ + +The new style is as follows: + +~~~~~ +:- chr_type list(T) ---> [] ; [T|list(T)]. +:- constraints foo(+list(int),?float), bar. +~~~~~ + + + +#### Compilation + +The + SWI-Prolog CHR compiler exploits term_expansion/2 rules to translate +the constraint handling rules to plain Prolog. These rules are loaded +from the library chr. They are activated if the compiled file +has the chr extension or after finding a declaration of the +format below. + +~~~~~ +:- constraints ... +~~~~~ + +It is adviced to define CHR rules in a module file, where the module +declaration is immediately followed by including the chr +library as examplified below: + +~~~~~ +:- module(zebra, [ zebra/0 ]). +:- use_module(library(chr)). + +:- constraints ... +~~~~~ + +Using this style CHR rules can be defined in ordinary Prolog +pl files and the operator definitions required by CHR do not +leak into modules where they might cause conflicts. + + + + + +#### CHR Debugging + +The CHR debugging facilities are currently rather limited. Only tracing +is currently available. To use the CHR debugging facilities for a CHR +file it must be compiled for debugging. Generating debug info is +controlled by the CHR option debug, whose default is derived +from the SWI-Prolog flag `generate_debug_info`. Therefore debug +info is provided unless the `-nodebug` is used. + +#### Ports + +For CHR constraints the four standard ports are defined: + ++ call +A new constraint is called and becomes active. ++ exit +An active constraint exits: it has either been inserted in the store after +trying all rules or has been removed from the constraint store. ++ fail +An active constraint fails. ++ redo +An active constraint starts looking for an alternative solution. + + +In addition to the above ports, CHR constraints have five additional +ports: + ++ wake +A suspended constraint is woken and becomes active. ++ insert +An active constraint has tried all rules and is suspended in +the constraint store. ++ remove +An active or passive constraint is removed from the constraint +store, if it had been inserted. ++ try +An active constraints tries a rule with possibly +some passive constraints. The try port is entered +just before committing to the rule. ++ apply +An active constraints commits to a rule with possibly +some passive constraints. The apply port is entered +just after committing to the rule. + +#### Tracing + +Tracing is enabled with the chr_trace/0 predicate +and disabled with the chr_notrace/0 predicate. + +When enabled the tracer will step through the `call`, +`exit`, `fail`, `wake` and `apply` ports, +accepting debug commands, and simply write out the other ports. + +The following debug commans are currently supported: + +~~~~~ + CHR debug options: + + creep c creep + s skip + g ancestors + n nodebug + b break + a abort + f fail + ? help h help +~~~~~ + +Their meaning is: + ++ creep +Step to the next port. ++ skip +Skip to exit port of this call or wake port. ++ ancestors +Print list of ancestor call and wake ports. ++ nodebug +Disable the tracer. ++ break +Enter a recursive Prolog toplevel. See break/0. ++ abort +Exit to the toplevel. See abort/0. ++ fail +Insert failure in execution. ++ help +Print the above available debug options. + + +#### CHR Debugging Predicates + + +The chr module contains several predicates that allow +inspecting and printing the content of the constraint store. + ++ chr_trace +Activate the CHR tracer. By default the CHR tracer is activated and +deactivated automatically by the Prolog predicates trace/0 and +notrace/0. + +### CHR_Examples Examples + +Here are two example constraint solvers written in CHR. + ++ +The program below defines a solver with one constraint, +`leq/2`, which is a less-than-or-equal constraint. + +~~~~~ +:- module(leq,[cycle/3, leq/2]). +:- use_module(library(chr)). + +:- constraints leq/2. +reflexivity @ leq(X,X) <=> true. +antisymmetry @ leq(X,Y), leq(Y,X) <=> X = Y. +idempotence @ leq(X,Y) \ leq(X,Y) <=> true. +transitivity @ leq(X,Y), leq(Y,Z) ==> leq(X,Z). + +cycle(X,Y,Z):- + leq(X,Y), + leq(Y,Z), + leq(Z,X). +~~~~~ + ++ +The program below implements a simple finite domain +constraint solver. + +~~~~~ +:- module(dom,[dom/2]). +:- use_module(library(chr)). + +:- constraints dom/2. + +dom(X,[]) <=> fail. +dom(X,[Y]) <=> X = Y. +dom(X,L1), dom(X,L2) <=> intersection(L1,L2,L3), dom(X,L3). + +intersection([],_,[]). +intersection([H|T],L2,[H|L3]) :- + member(H,L2), !, + intersection(T,L2,L3). +intersection([_|T],L2,L3) :- + intersection(T,L2,L3). +~~~~~ + + + +### Compatibility with SICStus CHR + + +There are small differences between CHR in SWI-Prolog and newer +YAPs and SICStus and older versions of YAP. Besides differences in +available options and pragmas, the following differences should be +noted: + ++ [The handler/1 declaration] +In SICStus every CHR module requires a `handler/1` +declaration declaring a unique handler name. This declaration is valid +syntax in SWI-Prolog, but will have no effect. A warning will be given +during compilation. + ++ [The rules/1 declaration] +In SICStus, for every CHR module it is possible to only enable a subset +of the available rules through the `rules/1` declaration. The +declaration is valid syntax in SWI-Prolog, but has no effect. A +warning is given during compilation. + ++ [Sourcefile naming] +SICStus uses a two-step compiler, where chr files are +first translated into pl files. For SWI-Prolog CHR +rules may be defined in a file with any extension. + +### Guidelines + +In this section we cover several guidelines on how to use CHR to write +constraint solvers and how to do so efficiently. + ++ [Set semantics] +The CHR system allows the presence of identical constraints, i.e. +multiple constraints with the same functor, arity and arguments. For +most constraint solvers, this is not desirable: it affects efficiency +and possibly termination. Hence appropriate simpagation rules should be +added of the form: + +~~~~~ +{constraint \ constraint <=> true}. +~~~~~ + ++ [Multi-headed rules] +Multi-headed rules are executed more efficiently when the constraints +share one or more variables. + ++ [Mode and type declarations] +Provide mode and type declarations to get more efficient program execution. +Make sure to disable debug (`-nodebug`) and enable optimization +(`-O`). + +*/ + +:- include(chr_op). + diff --git a/packages/chr/chr_compiler_errors.pl b/packages/chr/chr_compiler_errors.pl new file mode 100644 index 000000000..ed33b9a4a --- /dev/null +++ b/packages/chr/chr_compiler_errors.pl @@ -0,0 +1,180 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2005, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ +%% @addtogroup CHR_in_YAP_Programs +% +% CHR error handling +% +:- module(chr_compiler_errors, + [ + chr_info/3, + chr_warning/3, + chr_error/3, + print_chr_error/1 + ]). + +:- use_module(chr_compiler_options). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% chr_info(+Type,+FormattedMessage,+MessageParameters) + +chr_info(_,Message,Params) :- + ( \+verbosity_on -> + true + ; + long_line_with_equality_signs, + format(user_error,'CHR compiler:\n',[]), + format(user_error,Message,Params), + long_line_with_equality_signs + ). + + +%% SWI begin +verbosity_on :- + current_prolog_flag(verbose,V), V \== silent, + current_prolog_flag(verbose_load,true). +%% SWI end + +%% SICStus begin +%% verbosity_on. % at the moment +%% SICStus end + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% chr_warning(+Type,+FormattedMessage,+MessageParameters) + +chr_warning(deprecated(Term),Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler WARNING: deprecated syntax ~w.\n',[Term]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + format(user_error,' Support for deprecated syntax will be discontinued in the near future!\n',[]), + long_line_with_equality_signs. + +chr_warning(internal,Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler WARNING: something unexpected happened in the CHR compiler.\n',[]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + format(user_error,' Your program may not have been compiled correctly!\n',[]), + format(user_error,' Please contact tom.schrijvers@cs.kuleuven.be.\n',[]), + long_line_with_equality_signs. + +chr_warning(unsupported_pragma(Pragma,Rule),Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler WARNING: unsupported pragma ~w in ~@.\n',[Pragma,format_rule(Rule)]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + format(user_error,' Pragma is ignored!\n',[]), + long_line_with_equality_signs. +chr_warning(problem_pragma(Pragma,Rule),Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler WARNING: unsupported pragma ~w in ~@.\n',[Pragma,format_rule(Rule)]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + long_line_with_equality_signs. + +chr_warning(_,Message,Params) :- + ( chr_pp_flag(verbosity,on) -> + long_line_with_equality_signs, + format(user_error,'CHR compiler WARNING:\n',[]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + long_line_with_equality_signs + ; + true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% chr_error(+Type,+FormattedMessage,+MessageParameters) + +chr_error(Type,Message,Params) :- + throw(chr_error(error(Type,Message,Params))). + +print_chr_error(error(Type,Message,Params)) :- + print_chr_error(Type,Message,Params). + +print_chr_error(syntax(Term),Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler ERROR: invalid syntax "~w".\n',[Term]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + long_line_with_equality_signs. + +print_chr_error(type_error,Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler TYPE ERROR:\n',[]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + long_line_with_equality_signs. + +print_chr_error(internal,Message,Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler ERROR: something unexpected happened in the CHR compiler.\n',[]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + format(user_error,' Please contact tom.schrijvers@cs.kuleuven.be.\n',[]), + long_line_with_equality_signs. + +print_chr_error(cyclic_alias(Alias),_Message,_Params) :- !, + long_line_with_equality_signs, + format(user_error,'CHR compiler ERROR: cyclic alias "~w".\n',[Alias]), + format(user_error,' `--> Aborting compilation.\n',[]), + long_line_with_equality_signs. + +print_chr_error(_,Message,Params) :- + long_line_with_equality_signs, + format(user_error,'CHR compiler ERROR:\n',[]), + format(user_error,' `--> ',[]), + format(user_error,Message,Params), + long_line_with_equality_signs. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +:- public + format_rule/1. % called using format/3 `@' + +format_rule(PragmaRule) :- + PragmaRule = pragma(_,_,Pragmas,MaybeName,N), + ( MaybeName = yes(Name) -> + write('rule '), write(Name) + ; + write('rule number '), write(N) + ), + ( memberchk(line_number(LineNumber),Pragmas) -> + write(' (line '), + write(LineNumber), + write(')') + ; + true + ). + +long_line_with_equality_signs :- + format(user_error,'================================================================================\n',[]). diff --git a/packages/chr/chr_compiler_options.pl b/packages/chr/chr_compiler_options.pl new file mode 100644 index 000000000..891c7ac2e --- /dev/null +++ b/packages/chr/chr_compiler_options.pl @@ -0,0 +1,383 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2005-2006, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ +%% @addtogroup CHR_in_YAP_Programs +% +% CHR controlling the compiler +% + +:- module(chr_compiler_options, + [ handle_option/2 + , init_chr_pp_flags/0 + , chr_pp_flag/2 + ]). + +%% SICStus begin +%% :- use_module(hprolog, [nb_setval/2,nb_getval/2]). +%% local_current_prolog_flag(_,_) :- fail. +%% SICStus end + +%% SWI begin +local_current_prolog_flag(X,Y) :- current_prolog_flag(X,Y). +%% SWI end + + +:- use_module(chr_compiler_errors). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Global Options +% + +handle_option(Name,Value) :- + var(Name), !, + chr_error(syntax((:- chr_option(Name,Value))),'First argument should be an atom, not a variable.\n',[]). + +handle_option(Name,Value) :- + var(Value), !, + chr_error(syntax((:- chr_option(Name,Value))),'Second argument cannot be a variable.\n',[]). + +handle_option(Name,Value) :- + option_definition(Name,Value,Flags), + !, + set_chr_pp_flags(Flags). + +handle_option(Name,Value) :- + \+ option_definition(Name,_,_), !, + chr_error(syntax((:- chr_option(Name,Value))),'Invalid option name ~w: consult the manual for valid options.\n',[Name]). + +handle_option(Name,Value) :- + chr_error(syntax((:- chr_option(Name,Value))),'Invalid option value ~w: consult the manual for valid option values.\n',[Value]). + +option_definition(optimize,experimental,Flags) :- + Flags = [ functional_dependency_analysis - on, + check_unnecessary_active - full, + reorder_heads - on, + set_semantics_rule - on, + storage_analysis - on, + guard_via_reschedule - on, + guard_simplification - on, + check_impossible_rules - on, + occurrence_subsumption - on, + observation_analysis - on, + ai_observation_analysis - on, + late_allocation - on, + reduced_indexing - on, + term_indexing - on, + inline_insertremove - on, + mixed_stores - on + ]. +option_definition(optimize,full,Flags) :- + Flags = [ functional_dependency_analysis - on, + check_unnecessary_active - full, + reorder_heads - on, + set_semantics_rule - on, + storage_analysis - on, + guard_via_reschedule - on, + guard_simplification - on, + check_impossible_rules - on, + occurrence_subsumption - on, + observation_analysis - on, + ai_observation_analysis - on, + late_allocation - on, + reduced_indexing - on, + inline_insertremove - on, + mixed_stores - off, + debugable - off + ]. + +option_definition(optimize,off,Flags) :- + Flags = [ functional_dependency_analysis - off, + check_unnecessary_active - off, + reorder_heads - off, + set_semantics_rule - off, + storage_analysis - off, + guard_via_reschedule - off, + guard_simplification - off, + check_impossible_rules - off, + occurrence_subsumption - off, + observation_analysis - off, + ai_observation_analysis - off, + late_allocation - off, + reduced_indexing - off + ]. + +option_definition(functional_dependency_analysis,on,Flags) :- + Flags = [ functional_dependency_analysis - on ]. +option_definition(functional_dependency_analysis,off,Flags) :- + Flags = [ functional_dependency_analysis - off ]. + +option_definition(set_semantics_rule,on,Flags) :- + Flags = [ set_semantics_rule - on ]. +option_definition(set_semantics_rule,off,Flags) :- + Flags = [ set_semantics_rule - off ]. + +option_definition(check_unnecessary_active,full,Flags) :- + Flags = [ check_unnecessary_active - full ]. +option_definition(check_unnecessary_active,simplification,Flags) :- + Flags = [ check_unnecessary_active - simplification ]. +option_definition(check_unnecessary_active,off,Flags) :- + Flags = [ check_unnecessary_active - off ]. + +option_definition(check_guard_bindings,on,Flags) :- + Flags = [ guard_locks - on ]. +option_definition(check_guard_bindings,off,Flags) :- + Flags = [ guard_locks - off ]. +option_definition(check_guard_bindings,error,Flags) :- + Flags = [ guard_locks - error ]. + +option_definition(reduced_indexing,on,Flags) :- + Flags = [ reduced_indexing - on ]. +option_definition(reduced_indexing,off,Flags) :- + Flags = [ reduced_indexing - off ]. + +option_definition(storage_analysis,on,Flags) :- + Flags = [ storage_analysis - on ]. +option_definition(storage_analysis,off,Flags) :- + Flags = [ storage_analysis - off ]. + +option_definition(guard_simplification,on,Flags) :- + Flags = [ guard_simplification - on ]. +option_definition(guard_simplification,off,Flags) :- + Flags = [ guard_simplification - off ]. + +option_definition(check_impossible_rules,on,Flags) :- + Flags = [ check_impossible_rules - on ]. +option_definition(check_impossible_rules,off,Flags) :- + Flags = [ check_impossible_rules - off ]. + +option_definition(occurrence_subsumption,on,Flags) :- + Flags = [ occurrence_subsumption - on ]. +option_definition(occurrence_subsumption,off,Flags) :- + Flags = [ occurrence_subsumption - off ]. + +option_definition(late_allocation,on,Flags) :- + Flags = [ late_allocation - on ]. +option_definition(late_allocation,off,Flags) :- + Flags = [ late_allocation - off ]. + +option_definition(inline_insertremove,on,Flags) :- + Flags = [ inline_insertremove - on ]. +option_definition(inline_insertremove,off,Flags) :- + Flags = [ inline_insertremove - off ]. + +option_definition(type_definition,TypeDef,[]) :- + ( nonvar(TypeDef) -> + TypeDef = type(T,D), + chr_translate:type_definition(T,D) + ; true). +option_definition(type_declaration,TypeDecl,[]) :- + ( nonvar(TypeDecl) -> + functor(TypeDecl,F,A), + TypeDecl =.. [_|ArgTypes], + chr_translate:constraint_type(F/A,ArgTypes) + ; true). + +option_definition(mode,ModeDecl,[]) :- + ( nonvar(ModeDecl) -> + functor(ModeDecl,F,A), + ModeDecl =.. [_|ArgModes], + chr_translate:constraint_mode(F/A,ArgModes) + ; true). +option_definition(store,FA-Store,[]) :- + chr_translate:store_type(FA,Store). + +%------------------------------------------------------------------------------% +option_definition(declare_stored_constraints,off,[declare_stored_constraints-off]). +option_definition(declare_stored_constraints,on ,[declare_stored_constraints-on]). + +option_definition(stored,F/A,[]) :- + chr_translate:stored_assertion(F/A). +%------------------------------------------------------------------------------% +option_definition(experiment,off,[experiment-off]). +option_definition(experiment,on,[experiment-on]). +option_definition(experimental,off,[experiment-off]). +option_definition(experimental,on,[experiment-on]). +option_definition(sss,off,[sss-off]). +option_definition(sss,on,[sss-on]). +%------------------------------------------------------------------------------% +option_definition(debug,off,Flags) :- + option_definition(optimize,full,Flags2), + Flags = [ debugable - off | Flags2]. +option_definition(debug,on,Flags) :- + ( local_current_prolog_flag(generate_debug_info,false) -> + % TODO: should not be allowed when nodebug flag is set in SWI-Prolog + chr_warning(any,':- chr_option(debug,on) inconsistent with current_prolog_flag(generate_debug_info,off\n\tCHR option is ignored!\n)',[]), + Flags = [] + ; + Flags = [ debugable - on ] + ). + +option_definition(store_counter,off,[]). +option_definition(store_counter,on,[store_counter-on]). + +option_definition(observation,off,Flags) :- + Flags = [ + observation_analysis - off, + ai_observation_analysis - off, + late_allocation - off, + storage_analysis - off + ]. +option_definition(observation,on,Flags) :- + Flags = [ + observation_analysis - on, + ai_observation_analysis - on + ]. +option_definition(observation,regular,Flags) :- + Flags = [ + observation_analysis - on, + ai_observation_analysis - off + ]. +option_definition(observation,ai,Flags) :- + Flags = [ + observation_analysis - off, + ai_observation_analysis - on + ]. + +option_definition(store_in_guards, on, [store_in_guards - on]). +option_definition(store_in_guards, off, [store_in_guards - off]). + +option_definition(solver_events,NMod,Flags) :- + Flags = [solver_events - NMod]. + +option_definition(toplevel_show_store,on,Flags) :- + Flags = [toplevel_show_store - on]. + +option_definition(toplevel_show_store,off,Flags) :- + Flags = [toplevel_show_store - off]. + +option_definition(term_indexing,on,Flags) :- + Flags = [term_indexing - on]. +option_definition(term_indexing,off,Flags) :- + Flags = [term_indexing - off]. + +option_definition(verbosity,on,Flags) :- + Flags = [verbosity - on]. +option_definition(verbosity,off,Flags) :- + Flags = [verbosity - off]. + +option_definition(ht_removal,on,Flags) :- + Flags = [ht_removal - on]. +option_definition(ht_removal,off,Flags) :- + Flags = [ht_removal - off]. + +option_definition(mixed_stores,on,Flags) :- + Flags = [mixed_stores - on]. +option_definition(mixed_stores,off,Flags) :- + Flags = [mixed_stores - off]. + +option_definition(line_numbers,on,Flags) :- + Flags = [line_numbers - on]. +option_definition(line_numbers,off,Flags) :- + Flags = [line_numbers - off]. + +option_definition(dynattr,on,Flags) :- + Flags = [dynattr - on]. +option_definition(dynattr,off,Flags) :- + Flags = [dynattr - off]. + +option_definition(verbose,off,[verbose-off]). +option_definition(verbose,on,[verbose-on]). + +option_definition(dump,off,[dump-off]). +option_definition(dump,on,[dump-on]). + +init_chr_pp_flags :- + chr_pp_flag_definition(Name,[DefaultValue|_]), + set_chr_pp_flag(Name,DefaultValue), + fail. +init_chr_pp_flags. + +set_chr_pp_flags([]). +set_chr_pp_flags([Name-Value|Flags]) :- + set_chr_pp_flag(Name,Value), + set_chr_pp_flags(Flags). + +set_chr_pp_flag(Name,Value) :- + atom_concat('$chr_pp_',Name,GlobalVar), + nb_setval(GlobalVar,Value). + +chr_pp_flag_definition(functional_dependency_analysis,[off,on]). +chr_pp_flag_definition(check_unnecessary_active,[off,full,simplification]). +chr_pp_flag_definition(reorder_heads,[off,on]). +chr_pp_flag_definition(set_semantics_rule,[off,on]). +chr_pp_flag_definition(guard_via_reschedule,[off,on]). +chr_pp_flag_definition(guard_locks,[on,off,error]). +chr_pp_flag_definition(storage_analysis,[off,on]). +chr_pp_flag_definition(debugable,[on,off]). +chr_pp_flag_definition(reduced_indexing,[off,on]). +chr_pp_flag_definition(observation_analysis,[off,on]). +chr_pp_flag_definition(ai_observation_analysis,[off,on]). +chr_pp_flag_definition(store_in_guards,[off,on]). +chr_pp_flag_definition(late_allocation,[off,on]). +chr_pp_flag_definition(store_counter,[off,on]). +chr_pp_flag_definition(guard_simplification,[off,on]). +chr_pp_flag_definition(check_impossible_rules,[off,on]). +chr_pp_flag_definition(occurrence_subsumption,[off,on]). +chr_pp_flag_definition(observation,[off,on]). +chr_pp_flag_definition(show,[off,on]). +chr_pp_flag_definition(inline_insertremove,[on,off]). +chr_pp_flag_definition(solver_events,[none,_]). +chr_pp_flag_definition(toplevel_show_store,[on,off]). +chr_pp_flag_definition(term_indexing,[off,on]). +chr_pp_flag_definition(verbosity,[on,off]). +chr_pp_flag_definition(ht_removal,[off,on]). +chr_pp_flag_definition(mixed_stores,[on,off]). +chr_pp_flag_definition(line_numbers,[off,on]). +chr_pp_flag_definition(dynattr,[off,on]). +chr_pp_flag_definition(experiment,[off,on]). +chr_pp_flag_definition(sss,[off,on]). + % emit compiler inferred code +chr_pp_flag_definition(verbose,[off,on]). + % emit input code and output code +chr_pp_flag_definition(dump,[off,on]). + +chr_pp_flag_definition(declare_stored_constraints,[off,on]). + +chr_pp_flag(Name,Value) :- + atom_concat('$chr_pp_',Name,GlobalVar), + nb_getval(GlobalVar,V), + ( V == [] -> + chr_pp_flag_definition(Name,[Value|_]) + ; + V = Value + ). + + +% TODO: add whatever goes wrong with (debug,on), (optimize,full) combo here! +% trivial example of what does go wrong: +% b <=> true. +% !!! +sanity_check :- + chr_pp_flag(store_in_guards, on), + chr_pp_flag(ai_observation_analysis, on), + chr_warning(any, 'ai_observation_analysis should be turned off when using store_in_guards\n', []), + fail. +sanity_check. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/packages/chr/chr_compiler_utility.pl b/packages/chr/chr_compiler_utility.pl new file mode 100644 index 000000000..bbfb45d4b --- /dev/null +++ b/packages/chr/chr_compiler_utility.pl @@ -0,0 +1,339 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2005-2006, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ +%% @addtogroup CHR_in_YAP_Programs +% +% CHR compilation utilitities +% + +:- module(chr_compiler_utility, + [ time/2 + , replicate/3 + , pair_all_with/3 + , conj2list/2 + , list2conj/2 + , disj2list/2 + , list2disj/2 + , variable_replacement/3 + , variable_replacement/4 + , identical_rules/2 + , identical_guarded_rules/2 + , copy_with_variable_replacement/3 + , my_term_copy/3 + , my_term_copy/4 + , atom_concat_list/2 + , init/2 + , member2/3 + , select2/6 + , set_elems/2 + , instrument_goal/4 + , sort_by_key/3 + , arg1/3 + , wrap_in_functor/3 + , tree_set_empty/1 + , tree_set_memberchk/2 + , tree_set_add/3 + , tree_set_merge/3 + , fold1/3 + , fold/4 + , maplist_dcg//3 + , maplist_dcg//4 + ]). + +:- use_module(pairlist). +:- use_module(library(lists), [permutation/2]). +:- use_module(library(assoc)). + +:- meta_predicate + fold1(3,+,-), + fold(+,3,+,-). + +%% SICStus begin +%% use_module(library(terms),[term_variables/2]). +%% SICStus end + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% time(Phase,Goal) :- +% statistics(runtime,[T1|_]), +% call(Goal), +% statistics(runtime,[T2|_]), +% T is T2 - T1, +% format(' ~w ~46t ~D~80| ms\n',[Phase,T]), +% deterministic(Det), +% ( Det == true -> +% true +% ; +% format('\t\tNOT DETERMINISTIC!\n',[]) +% ). +time(_,Goal) :- call(Goal). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +replicate(N,E,L) :- + ( N =< 0 -> + L = [] + ; + L = [E|T], + M is N - 1, + replicate(M,E,T) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pair_all_with([],_,[]). +pair_all_with([X|Xs],Y,[X-Y|Rest]) :- + pair_all_with(Xs,Y,Rest). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +conj2list(Conj,L) :- %% transform conjunctions to list + conj2list(Conj,L,[]). + +conj2list(Var,L,T) :- + var(Var), !, + L = [Var|T]. +conj2list(true,L,L) :- !. +conj2list(Conj,L,T) :- + Conj = (G1,G2), !, + conj2list(G1,L,T1), + conj2list(G2,T1,T). +conj2list(G,[G | T],T). + +disj2list(Conj,L) :- %% transform disjunctions to list + disj2list(Conj,L,[]). +disj2list(Conj,L,T) :- + Conj = (fail;G2), !, + disj2list(G2,L,T). +disj2list(Conj,L,T) :- + Conj = (G1;G2), !, + disj2list(G1,L,T1), + disj2list(G2,T1,T). +disj2list(G,[G | T],T). + +list2conj([],true). +list2conj([G],X) :- !, X = G. +list2conj([G|Gs],C) :- + ( G == true -> %% remove some redundant trues + list2conj(Gs,C) + ; + C = (G,R), + list2conj(Gs,R) + ). + +list2disj([],fail). +list2disj([G],X) :- !, X = G. +list2disj([G|Gs],C) :- + ( G == fail -> %% remove some redundant fails + list2disj(Gs,C) + ; + C = (G;R), + list2disj(Gs,R) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% check wether two rules are identical + +identical_guarded_rules(rule(H11,H21,G1,_),rule(H12,H22,G2,_)) :- + G1 == G2, + permutation(H11,P1), + P1 == H12, + permutation(H21,P2), + P2 == H22. + +identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :- + G1 == G2, + identical_bodies(B1,B2), + permutation(H11,P1), + P1 == H12, + permutation(H21,P2), + P2 == H22. + +identical_bodies(B1,B2) :- + ( B1 = (X1 = Y1), + B2 = (X2 = Y2) -> + ( X1 == X2, + Y1 == Y2 + ; X1 == Y2, + X2 == Y1 + ), + ! + ; B1 == B2 + ). + +% replace variables in list + +copy_with_variable_replacement(X,Y,L) :- + ( var(X) -> + ( lookup_eq(L,X,Y) -> + true + ; X = Y + ) + ; functor(X,F,A), + functor(Y,F,A), + X =.. [_|XArgs], + Y =.. [_|YArgs], + copy_with_variable_replacement_l(XArgs,YArgs,L) + ). + +copy_with_variable_replacement_l([],[],_). +copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :- + copy_with_variable_replacement(X,Y,L), + copy_with_variable_replacement_l(Xs,Ys,L). + +% build variable replacement list + +variable_replacement(X,Y,L) :- + variable_replacement(X,Y,[],L). + +variable_replacement(X,Y,L1,L2) :- + ( var(X) -> + var(Y), + ( lookup_eq(L1,X,Z) -> + Z == Y, + L2 = L1 + ; ( X == Y -> L2=L1 ; L2 = [X-Y,Y-X|L1]) + ) + ; X =.. [F|XArgs], + nonvar(Y), + Y =.. [F|YArgs], + variable_replacement_l(XArgs,YArgs,L1,L2) + ). + +variable_replacement_l([],[],L,L). +variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :- + variable_replacement(X,Y,L1,L2), + variable_replacement_l(Xs,Ys,L2,L3). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +my_term_copy(X,Dict,Y) :- + my_term_copy(X,Dict,_,Y). + +my_term_copy(X,Dict1,Dict2,Y) :- + ( var(X) -> + ( lookup_eq(Dict1,X,Y) -> + Dict2 = Dict1 + ; Dict2 = [X-Y|Dict1] + ) + ; functor(X,XF,XA), + functor(Y,XF,XA), + X =.. [_|XArgs], + Y =.. [_|YArgs], + my_term_copy_list(XArgs,Dict1,Dict2,YArgs) + ). + +my_term_copy_list([],Dict,Dict,[]). +my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :- + my_term_copy(X,Dict1,Dict2,Y), + my_term_copy_list(Xs,Dict2,Dict3,Ys). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +atom_concat_list([X],X) :- ! . +atom_concat_list([X|Xs],A) :- + atom_concat_list(Xs,B), + atomic_concat(X,B,A). + +set_elems([],_). +set_elems([X|Xs],X) :- + set_elems(Xs,X). + +init([],[]). +init([_],[]) :- !. +init([X|Xs],[X|R]) :- + init(Xs,R). + +member2([X|_],[Y|_],X-Y). +member2([_|Xs],[_|Ys],P) :- + member2(Xs,Ys,P). + +select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys). +select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :- + select2(X, Y, Xs, Ys, NXs, NYs). + +instrument_goal(Goal,Pre,Post,(Pre,Goal,Post)). + +sort_by_key(List,Keys,SortedList) :- + pairup(Keys,List,Pairs), + sort(Pairs,SortedPairs), + once(pairup(_,SortedList,SortedPairs)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +arg1(Term,Index,Arg) :- arg(Index,Term,Arg). + +wrap_in_functor(Functor,X,Term) :- + Term =.. [Functor,X]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +tree_set_empty(TreeSet) :- empty_assoc(TreeSet). +tree_set_memberchk(Element,TreeSet) :- get_assoc(Element,TreeSet,_). +tree_set_add(TreeSet,Element,NTreeSet) :- put_assoc(Element,TreeSet,x,NTreeSet). +tree_set_merge(TreeSet1,TreeSet2,TreeSet3) :- + assoc_to_list(TreeSet1,List), + fold(List,tree_set_add_pair,TreeSet2,TreeSet3). +tree_set_add_pair(Key-Value,TreeSet,NTreeSet) :- + put_assoc(Key,TreeSet,Value,NTreeSet). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +fold1(P,[Head|Tail],Result) :- + fold(Tail,P,Head,Result). + +fold([],_,Acc,Acc). +fold([X|Xs],P,Acc,Res) :- + call(P,X,Acc,NAcc), + fold(Xs,P,NAcc,Res). + +maplist_dcg(P,L1,L2,L) --> + maplist_dcg_(L1,L2,L,P). + +maplist_dcg_([],[],[],_) --> []. +maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) --> + call(P,X,Y,Z), + maplist_dcg_(Xs,Ys,Zs,P). + +maplist_dcg(P,L1,L2) --> + maplist_dcg_(L1,L2,P). + +maplist_dcg_([],[],_) --> []. +maplist_dcg_([X|Xs],[Y|Ys],P) --> + call(P,X,Y), + maplist_dcg_(Xs,Ys,P). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- dynamic + user:goal_expansion/2. +:- multifile + user:goal_expansion/2. + +user:goal_expansion(arg1(Term,Index,Arg), arg(Index,Term,Arg)). +user:goal_expansion(wrap_in_functor(Functor,In,Out), Goal) :- + ( atom(Functor), var(Out) -> + Out =.. [Functor,In], + Goal = true + ; + Goal = (Out =.. [Functor,In]) + ). + diff --git a/packages/chr/chr_debug.pl b/packages/chr/chr_debug.pl new file mode 100644 index 000000000..376ab1440 --- /dev/null +++ b/packages/chr/chr_debug.pl @@ -0,0 +1,66 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.ac.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%% @addtogroup CHR_Debugging +% +% CHR debugger +% +:- module(chr_debug, + [ chr_show_store/1, % +Module + find_chr_constraint/1 + ]). +:- use_module(chr(chr_runtime)). +:- use_module(library(lists)). +:- set_prolog_flag(generate_debug_info, false). + + +%% chr_show_store(+Module) +% +% Prints all suspended constraints of module Mod to the standard +% output. + +chr_show_store(Mod) :- + ( + Mod:'$enumerate_suspensions'(Susp), +% arg(6,Susp,C), + Susp =.. [_,_,_,_,_,_,F|Arg], + functor(F,Fun,_), + C =.. [Fun|Arg], + print(C),nl, % allows use of portray to control printing + fail + ; + true + ). + +find_chr_constraint(C) :- + chr:'$chr_module'(Mod), + Mod:'$enumerate_suspensions'(Susp), + arg(6,Susp,C). diff --git a/packages/chr/chr_hashtable_store.pl b/packages/chr/chr_hashtable_store.pl new file mode 100644 index 000000000..befb9e9a6 --- /dev/null +++ b/packages/chr/chr_hashtable_store.pl @@ -0,0 +1,425 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ +% author: Tom Schrijvers +% email: Tom.Schrijvers@cs.kuleuven.be +% copyright: K.U.Leuven, 2004 + +%% @addtogroup CHR_in_YAP_Programs +% +% CHR error handling +% +:- module(chr_hashtable_store, + [ new_ht/1, + lookup_ht/3, + lookup_ht1/4, + lookup_ht2/4, + insert_ht/3, + insert_ht1/4, + insert_ht/4, + delete_ht/3, + delete_ht1/4, + delete_first_ht/3, + value_ht/2, + stats_ht/1, + stats_ht/1 + ]). + +:- use_module(pairlist). +:- use_module(library(dialect/hprolog)). +:- use_module(library(lists)). + +:- multifile user:goal_expansion/2. +:- dynamic user:goal_expansion/2. + +initial_capacity(89). + +new_ht(HT) :- + initial_capacity(Capacity), + new_ht(Capacity,HT). + +new_ht(Capacity,HT) :- + functor(T1,t,Capacity), + HT = ht(Capacity,0,Table), + Table = T1. + +lookup_ht(HT,Key,Values) :- + term_hash(Key,Hash), + lookup_ht1(HT,Hash,Key,Values). +/* + HT = ht(Capacity,_,Table), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + nonvar(Bucket), + ( Bucket = K-Vs -> + K == Key, + Values = Vs + ; + lookup(Bucket,Key,Values) + ). +*/ + +% :- load_foreign_library(chr_support). + +/* +lookup_ht1(HT,Hash,Key,Values) :- + ( lookup_ht1_(HT,Hash,Key,Values) -> + true + ; + ( lookup_ht1__(HT,Hash,Key,Values) -> + writeln(lookup_ht1(HT,Hash,Key,Values)), + throw(error) + ; + fail + ) + ). +*/ + +lookup_ht1(HT,Hash,Key,Values) :- + HT = ht(Capacity,_,Table), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + nonvar(Bucket), + ( Bucket = K-Vs -> + K == Key, + Values = Vs + ; + lookup(Bucket,Key,Values) + ). + +lookup_ht2(HT,Key,Values,Index) :- + term_hash(Key,Hash), + HT = ht(Capacity,_,Table), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + nonvar(Bucket), + ( Bucket = K-Vs -> + K == Key, + Values = Vs + ; + lookup(Bucket,Key,Values) + ). + +lookup_pair_eq([P | KVs],Key,Pair) :- + P = K-_, + ( K == Key -> + P = Pair + ; + lookup_pair_eq(KVs,Key,Pair) + ). + +insert_ht(HT,Key,Value) :- + term_hash(Key,Hash), + HT = ht(Capacity0,Load,Table0), + LookupIndex is (Hash mod Capacity0) + 1, + arg(LookupIndex,Table0,LookupBucket), + ( var(LookupBucket) -> + LookupBucket = Key - [Value] + ; LookupBucket = K-Values -> + ( K == Key -> + setarg(2,LookupBucket,[Value|Values]) + ; + setarg(LookupIndex,Table0,[Key-[Value],LookupBucket]) + ) + ; + ( lookup_pair_eq(LookupBucket,Key,Pair) -> + Pair = _-Values, + setarg(2,Pair,[Value|Values]) + ; + setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket]) + ) + ), + NLoad is Load + 1, + setarg(2,HT,NLoad), + ( Load == Capacity0 -> + expand_ht(HT,_Capacity) + ; + true + ). + +insert_ht1(HT,Key,Hash,Value) :- + HT = ht(Capacity0,Load,Table0), + LookupIndex is (Hash mod Capacity0) + 1, + arg(LookupIndex,Table0,LookupBucket), + ( var(LookupBucket) -> + LookupBucket = Key - [Value] + ; LookupBucket = K-Values -> + ( K == Key -> + setarg(2,LookupBucket,[Value|Values]) + ; + setarg(LookupIndex,Table0,[Key-[Value],LookupBucket]) + ) + ; + ( lookup_pair_eq(LookupBucket,Key,Pair) -> + Pair = _-Values, + setarg(2,Pair,[Value|Values]) + ; + setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket]) + ) + ), + NLoad is Load + 1, + setarg(2,HT,NLoad), + ( Load == Capacity0 -> + expand_ht(HT,_Capacity) + ; + true + ). + +% LDK: insert version with extra argument denoting result + +insert_ht(HT,Key,Value,Result) :- + HT = ht(Capacity,Load,Table), + term_hash(Key,Hash), + LookupIndex is (Hash mod Capacity) + 1, + arg(LookupIndex,Table,LookupBucket), + ( var(LookupBucket) + -> Result = [Value], + LookupBucket = Key - Result, + NewLoad is Load + 1 + ; LookupBucket = K - V + -> ( K = Key + -> Result = [Value|V], + setarg(2,LookupBucket,Result), + NewLoad = Load + ; Result = [Value], + setarg(LookupIndex,Table,[Key - Result,LookupBucket]), + NewLoad is Load + 1 + ) + ; ( lookup_pair_eq(LookupBucket,Key,Pair) + -> Pair = _-Values, + Result = [Value|Values], + setarg(2,Pair,Result), + NewLoad = Load + ; Result = [Value], + setarg(LookupIndex,Table,[Key - Result|LookupBucket]), + NewLoad is Load + 1 + ) + ), + setarg(2,HT,NewLoad), + ( NewLoad > Capacity + -> expand_ht(HT,_) + ; true + ). + +% LDK: deletion of the first element of a bucket +delete_first_ht(HT,Key,Values) :- + HT = ht(Capacity,Load,Table), + term_hash(Key,Hash), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + ( Bucket = _-[_|Values] + -> ( Values = [] + -> setarg(Index,Table,_), + NewLoad is Load - 1 + ; setarg(2,Bucket,Values), + NewLoad = Load + ) + ; lookup_pair_eq(Bucket,Key,Pair) + -> Pair = _-[_|Values], + ( Values = [] + -> pairlist_delete_eq(Bucket,Key,NewBucket), + ( NewBucket = [] + -> setarg(Index,Table,_) + ; NewBucket = [OtherPair] + -> setarg(Index,Table,OtherPair) + ; setarg(Index,Table,NewBucket) + ), + NewLoad is Load - 1 + ; setarg(2,Pair,Values), + NewLoad = Load + ) + ), + setarg(2,HT,NewLoad). + +delete_ht(HT,Key,Value) :- + HT = ht(Capacity,Load,Table), + NLoad is Load - 1, + term_hash(Key,Hash), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + ( /* var(Bucket) -> + true + ; */ Bucket = _K-Vs -> + ( /* _K == Key, */ + delete_first_fail(Vs,Value,NVs) -> + setarg(2,HT,NLoad), + ( NVs == [] -> + setarg(Index,Table,_) + ; + setarg(2,Bucket,NVs) + ) + ; + true + ) + ; + ( lookup_pair_eq(Bucket,Key,Pair), + Pair = _-Vs, + delete_first_fail(Vs,Value,NVs) -> + setarg(2,HT,NLoad), + ( NVs == [] -> + pairlist_delete_eq(Bucket,Key,NBucket), + ( NBucket = [Singleton] -> + setarg(Index,Table,Singleton) + ; + setarg(Index,Table,NBucket) + ) + ; + setarg(2,Pair,NVs) + ) + ; + true + ) + ). + +delete_first_fail([X | Xs], Y, Zs) :- + ( X == Y -> + Zs = Xs + ; + Zs = [X | Zs1], + delete_first_fail(Xs, Y, Zs1) + ). + +delete_ht1(HT,Key,Value,Index) :- + HT = ht(_Capacity,Load,Table), + NLoad is Load - 1, + % term_hash(Key,Hash), + % Index is (Hash mod _Capacity) + 1, + arg(Index,Table,Bucket), + ( /* var(Bucket) -> + true + ; */ Bucket = _K-Vs -> + ( /* _K == Key, */ + delete_first_fail(Vs,Value,NVs) -> + setarg(2,HT,NLoad), + ( NVs == [] -> + setarg(Index,Table,_) + ; + setarg(2,Bucket,NVs) + ) + ; + true + ) + ; + ( lookup_pair_eq(Bucket,Key,Pair), + Pair = _-Vs, + delete_first_fail(Vs,Value,NVs) -> + setarg(2,HT,NLoad), + ( NVs == [] -> + pairlist_delete_eq(Bucket,Key,NBucket), + ( NBucket = [Singleton] -> + setarg(Index,Table,Singleton) + ; + setarg(Index,Table,NBucket) + ) + ; + setarg(2,Pair,NVs) + ) + ; + true + ) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +value_ht(HT,Value) :- + HT = ht(Capacity,_,Table), + value_ht(1,Capacity,Table,Value). + +value_ht(I,N,Table,Value) :- + I =< N, + arg(I,Table,Bucket), + ( + nonvar(Bucket), + ( Bucket = _-Vs -> + true + ; + member(_-Vs,Bucket) + ), + member(Value,Vs) + ; + J is I + 1, + value_ht(J,N,Table,Value) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +expand_ht(HT,NewCapacity) :- + HT = ht(Capacity,_,Table), + NewCapacity is Capacity * 2 + 1, + functor(NewTable,t,NewCapacity), + setarg(1,HT,NewCapacity), + setarg(3,HT,NewTable), + expand_copy(Table,1,Capacity,NewTable,NewCapacity). + +expand_copy(Table,I,N,NewTable,NewCapacity) :- + ( I > N -> + true + ; + arg(I,Table,Bucket), + ( var(Bucket) -> + true + ; Bucket = Key - Value -> + expand_insert(NewTable,NewCapacity,Key,Value) + ; + expand_inserts(Bucket,NewTable,NewCapacity) + ), + J is I + 1, + expand_copy(Table,J,N,NewTable,NewCapacity) + ). + +expand_inserts([],_,_). +expand_inserts([K-V|R],Table,Capacity) :- + expand_insert(Table,Capacity,K,V), + expand_inserts(R,Table,Capacity). + +expand_insert(Table,Capacity,K,V) :- + term_hash(K,Hash), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + ( var(Bucket) -> + Bucket = K - V + ; Bucket = _-_ -> + setarg(Index,Table,[K-V,Bucket]) + ; + setarg(Index,Table,[K-V|Bucket]) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +stats_ht(HT) :- + HT = ht(Capacity,Load,Table), + format('HT load = ~w / ~w\n',[Load,Capacity]), + ( between(1,Capacity,Index), + arg(Index,Table,Entry), + ( var(Entry) -> Size = 0 + ; Entry = _-_ -> Size = 1 + ; length(Entry,Size) + ), + format('~w : ~w\n',[Index,Size]), + fail + ; + true + ). diff --git a/packages/chr/chr_integertable_store.pl b/packages/chr/chr_integertable_store.pl new file mode 100644 index 000000000..e1fbdfefa --- /dev/null +++ b/packages/chr/chr_integertable_store.pl @@ -0,0 +1,140 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + based on chr_hashtable_store (by Tom Schrijvers) + Author: Jon Sneyers + E-mail: Jon.Sneyers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2005, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +% is it safe to use nb_setarg here? + +%% @addtogroup CHR_in_YAP_Programs +% +% CHR error handling +% +:- module(chr_integertable_store, + [ new_iht/1, + lookup_iht/3, + insert_iht/3, + delete_iht/3, + value_iht/2 + ]). +:- use_module(library(lists)). +:- use_module(library(dialect/hprolog)). + +%initial_capacity(65536). +%initial_capacity(1024). +initial_capacity(8). +%initial_capacity(2). +%initial_capacity(1). + + +new_iht(HT) :- + initial_capacity(Capacity), + new_iht(Capacity,HT). + +new_iht(Capacity,HT) :- + functor(T1,t,Capacity), + HT = ht(Capacity,Table), + Table = T1. + +lookup_iht(ht(_,Table),Int,Values) :- + Index is Int + 1, + arg(Index,Table,Values), + Values \= []. +% nonvar(Values). + +insert_iht(HT,Int,Value) :- + Index is Int + 1, + arg(2,HT,Table), + (arg(Index,Table,Bucket) -> + ( var(Bucket) -> + Bucket = [Value] + ; + setarg(Index,Table,[Value|Bucket]) + ) + ; % index > capacity + Capacity is 1< + 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) + ). diff --git a/packages/chr/chr_messages.pl b/packages/chr/chr_messages.pl new file mode 100644 index 000000000..f06ee4186 --- /dev/null +++ b/packages/chr/chr_messages.pl @@ -0,0 +1,177 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Jan Wielemaker and Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%% @addtogroup CHR_in_YAP_Programs +% +% CHR controlling the compiler +% +:- module(chr_messages, + [ chr_message/3 % +CHR Message, Out, Rest + ]). +:- use_module(chr(chr_runtime)). + +:- discontiguous + chr_message/3. + +% compiler messages + +chr_message(compilation_failed(From)) --> + [ 'CHR Failed to compile ~w'-[From] ]. + +% debug messages + +chr_message(prompt) --> + [ at_same_line, ' ? ', flush_output ]. +chr_message(command(Command)) --> + [ at_same_line, '[~w]'-[Command] ]. +chr_message(invalid_command) --> + [ nl, 'CHR: Not a valid debug option. Use ? for help.' ]. +chr_message(debug_options) --> + { bagof(Ls-Cmd, + bagof(L, 'chr debug command'(L, Cmd), Ls), + Lines) + }, + [ 'CHR Debugger commands:', nl, nl ], + debug_commands(Lines), + [ nl ]. + +debug_commands([]) --> + []. +debug_commands([Ls-Cmd|T]) --> + [ '\t' ], chars(Ls), [ '~t~28|~w'-[Cmd], nl ], + debug_commands(T). + +chars([C]) --> !, + char(C). +chars([C|T]) --> + char(C), [', '], + chars(T). + +char(' ') --> !, ['']. +char('\r') --> !, ['']. +char(end_of_file) --> !, ['EOF']. +char(C) --> [C]. + + +chr_message(ancestors(History, Depth)) --> + [ 'CHR Ancestors:', nl ], + ancestors(History, Depth). + +ancestors([], _) --> + []. +ancestors([Event|Events], Depth) --> + [ '\t' ], event(Event, Depth), [ nl ], + { NDepth is Depth - 1 + }, + ancestors(Events, NDepth). + + +% debugging ports + +chr_message(event(Port, Depth)) --> + [ 'CHR: ' ], + event(Port, Depth), + [ flush_output ]. % do not emit a newline + +event(Port, Depth) --> + depth(Depth), + port(Port). +event(apply(H1,H2,G,B), Depth) --> + depth(Depth), + [ 'Apply: ' ], + rule(H1,H2,G,B). +event(try(H1,H2,G,B), Depth) --> + depth(Depth), + [ 'Try: ' ], + rule(H1,H2,G,B). +event(insert(#(_,Susp)), Depth) --> + depth(Depth), + [ 'Insert: ' ], + head(Susp). + +port(call(Susp)) --> + [ 'Call: ' ], + head(Susp). +port(wake(Susp)) --> + [ 'Wake: ' ], + head(Susp). +port(exit(Susp)) --> + [ 'Exit: ' ], + head(Susp). +port(fail(Susp)) --> + [ 'Fail: ' ], + head(Susp). +port(redo(Susp)) --> + [ 'Redo: ' ], + head(Susp). +port(remove(Susp)) --> + [ 'Remove: ' ], + head(Susp). + + +depth(Depth) --> + [ '~t(~D)~10| '-[Depth] ]. + +head(Susp) --> + { Susp =.. [_,ID,_,_,_,_|GoalArgs], Goal =.. GoalArgs + }, + [ '~w # <~w>'-[Goal, ID] ]. + +heads([H]) --> !, + head(H). +heads([H|T]) --> + head(H), + [ ', ' ], + heads(T). + + +% rule(H1, H2, G, B) +% +% Produce text for the CHR rule "H1 \ H2 [<=]=> G | B" + +rule(H1, H2, G, B) --> + rule_head(H1, H2), + rule_body(G, B). + +rule_head([], H2) --> !, + heads(H2), + [ ' ==> ' ]. +rule_head(H1, []) --> !, + heads(H1), + [ ' <=> ' ]. +rule_head(H1, H2) --> + heads(H2), [ ' \\ ' ], heads(H1), [' <=> ']. + + +rule_body(true, B) --> !, + [ '~w.'-[B] ]. +rule_body(G, B) --> + [ '~w | ~w.'-[G, B] ]. diff --git a/packages/chr/chr_op.pl b/packages/chr/chr_op.pl new file mode 100644 index 000000000..565156f93 --- /dev/null +++ b/packages/chr/chr_op.pl @@ -0,0 +1,50 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Operator Priorities + +:- op(1180, xfx, ==>). +:- op(1180, xfx, <=>). +:- op(1150, fx, constraints). +:- op(1150, fx, chr_constraint). +:- op(1150, fx, handler). +:- op(1150, fx, rules). +:- op(1100, xfx, \). +:- op(1200, xfx, @). % values from hProlog +:- op(1190, xfx, pragma). % values from hProlog +:- op( 500, yfx, #). % values from hProlog +%:- op(1100, xfx, '|'). +:- op(1150, fx, chr_type). +:- op(1130, xfx, --->). +:- op(1150, fx, (?)). +:- op(1150, fx, chr_declaration). diff --git a/packages/chr/chr_op2.pl b/packages/chr/chr_op2.pl new file mode 100644 index 000000000..f09484c51 --- /dev/null +++ b/packages/chr/chr_op2.pl @@ -0,0 +1,51 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Operator Priorities + + +% old version, without the type/mode operators + +:- op(1180, xfx, ==>). +:- op(1180, xfx, <=>). +:- op(1150, fx, constraints). +:- op(1150, fx, chr_constraint). +:- op(1150, fx, handler). +:- op(1150, fx, rules). +:- op(1100, xfx, \). +:- op(1200, xfx, @). % values from hProlog +:- op(1190, xfx, pragma). % values from hProlog +:- op( 500, yfx, #). % values from hProlog +%:- op(1100, xfx, '|'). +%:- op(1150, fx, chr_type). +%:- op(1130, xfx, --->). diff --git a/packages/chr/chr_runtime.pl b/packages/chr/chr_runtime.pl new file mode 100644 index 000000000..0058e9742 --- /dev/null +++ b/packages/chr/chr_runtime.pl @@ -0,0 +1,968 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Christian Holzbaur and Tom Schrijvers + E-mail: christian@ai.univie.ac.at + Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. + + Distributed with SWI-Prolog under the above conditions with + permission from the authors. +*/ + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% _ _ _ +%% ___| |__ _ __ _ __ _ _ _ __ | |_(_)_ __ ___ ___ +%% / __| '_ \| '__| | '__| | | | '_ \| __| | '_ ` _ \ / _ \ +%% | (__| | | | | | | | |_| | | | | |_| | | | | | | __/ +%% \___|_| |_|_| |_| \__,_|_| |_|\__|_|_| |_| |_|\___| +%% +%% hProlog CHR runtime: +%% +%% * based on the SICStus CHR runtime by Christian Holzbaur +%% +%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% % Constraint Handling Rules version 2.2 % +%% % % +%% % (c) Copyright 1996-98 % +%% % LMU, Muenchen % +%% % % +%% % File: chr.pl % +%% % Author: Christian Holzbaur christian@ai.univie.ac.at % +%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% +%% * modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.be +%% - ported to hProlog +%% - modified for eager suspension removal +%% +%% * First working version: 6 June 2003 +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% SWI-Prolog changes +%% +%% * Added initialization directives for saved-states +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% @addtogroup CHR_Rule_Types +% +% CHR controlling the compiler +% +:- module(chr_runtime, + [ 'chr sbag_del_element'/3, + 'chr sbag_member'/2, + 'chr merge_attributes'/3, + + 'chr run_suspensions'/1, + 'chr run_suspensions_loop'/1, + + 'chr run_suspensions_d'/1, + 'chr run_suspensions_loop_d'/1, + + 'chr insert_constraint_internal'/5, + 'chr remove_constraint_internal'/2, + 'chr allocate_constraint'/4, + 'chr activate_constraint'/3, + + 'chr default_store'/1, + + 'chr via_1'/2, + 'chr via_2'/3, + 'chr via'/2, + 'chr newvia_1'/2, + 'chr newvia_2'/3, + 'chr newvia'/2, + + 'chr lock'/1, + 'chr unlock'/1, + 'chr not_locked'/1, + 'chr none_locked'/1, + + 'chr error_lock'/1, + 'chr unerror_lock'/1, + 'chr not_error_locked'/1, + 'chr none_error_locked'/1, + + 'chr update_mutable'/2, + 'chr get_mutable'/2, + 'chr create_mutable'/2, + + 'chr novel_production'/2, + 'chr extend_history'/2, + 'chr empty_history'/1, + + 'chr gen_id'/1, + + 'chr debug_event'/1, + 'chr debug command'/2, % Char, Command + + 'chr chr_indexed_variables'/2, + + 'chr all_suspensions'/3, + 'chr new_merge_attributes'/3, + 'chr normalize_attr'/2, + + 'chr select'/3, + + chr_show_store/1, % +Module + find_chr_constraint/1, + + chr_trace/0, + chr_notrace/0, + chr_leash/1 + ]). + +%% SWI begin +:- set_prolog_flag(generate_debug_info, false). +%% SWI end + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- use_module(library(dialect/hprolog)). +:- include(chr_op). + +%% SICStus begin +%% :- use_module(hpattvars). +%% :- use_module(b_globval). +%% SICStus end + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% I N I T I A L I S A T I O N + +%% SWI begin +:- dynamic user:exception/3. +:- multifile user:exception/3. + +user:exception(undefined_global_variable, Name, retry) :- + chr_runtime_global_variable(Name), + chr_init. + +chr_runtime_global_variable(chr_id). +chr_runtime_global_variable(chr_global). +chr_runtime_global_variable(chr_debug). +chr_runtime_global_variable(chr_debug_history). + +chr_init :- + nb_setval(chr_id,0), + nb_setval(chr_global,_), + nb_setval(chr_debug,mutable(off)), % XXX + nb_setval(chr_debug_history,mutable([],0)). % XXX +%% SWI end + +%% SICStus begin +%% chr_init :- +%% nb_setval(chr_id,0). +%% SICStus end + +:- initialization chr_init. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Contents of former chr_debug.pl +% +% chr_show_store(+Module) +% +% Prints all suspended constraints of module Mod to the standard +% output. + +chr_show_store(Mod) :- + ( + Mod:'$enumerate_constraints'(Constraint), + print(Constraint),nl, % allows use of portray to control printing + fail + ; + true + ). + +find_chr_constraint(Constraint) :- + chr:'$chr_module'(Mod), + Mod:'$enumerate_constraints'(Constraint). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Inlining of some goals is good for performance +% That's the reason for the next section +% There must be correspondence with the predicates as implemented in chr_mutable.pl +% so that user:goal_expansion(G,G). also works (but do not add such a rule) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% SWI begin +:- multifile user:goal_expansion/2. +:- dynamic user:goal_expansion/2. + +user:goal_expansion('chr get_mutable'(Val,Var), Var=mutable(Val)). +user:goal_expansion('chr update_mutable'(Val,Var), setarg(1,Var,Val)). +user:goal_expansion('chr create_mutable'(Val,Var), Var=mutable(Val)). +user:goal_expansion('chr default_store'(X), nb_getval(chr_global,X)). +%% SWI end + +% goal_expansion seems too different in SICStus 4 for me to cater for in a +% decent way at this moment - so I stick with the old way to do this +% so that it doesn't get lost, the code from Mats for SICStus 4 is included in comments + + +%% Mats begin +%% goal_expansion('chr get_mutable'(Val,Var), Lay, _M, get_mutable(Val,Var), Lay). +%% goal_expansion('chr update_mutable'(Val,Var), Lay, _M, update_mutable(Val,Var), Lay). +%% goal_expansion('chr create_mutable'(Val,Var), Lay, _M, create_mutable(Val,Var), Lay). +%% goal_expansion('chr default_store'(A), Lay, _M, global_term_ref_1(A), Lay). +%% Mats begin + + +%% SICStus begin +%% :- multifile user:goal_expansion/2. +%% :- dynamic user:goal_expansion/2. +%% +%% user:goal_expansion('chr get_mutable'(Val,Var), get_mutable(Val,Var)). +%% user:goal_expansion('chr update_mutable'(Val,Var), update_mutable(Val,Var)). +%% user:goal_expansion('chr create_mutable'(Val,Var), create_mutable(Val,Var)). +%% user:goal_expansion('chr default_store'(A), global_term_ref_1(A)). +%% SICStus end + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr run_suspensions'( Slots) :- + run_suspensions( Slots). + +'chr run_suspensions_loop'([]). +'chr run_suspensions_loop'([L|Ls]) :- + run_suspensions(L), + 'chr run_suspensions_loop'(Ls). + +run_suspensions([]). +run_suspensions([S|Next] ) :- + arg( 2, S, Mref), % ARGXXX + 'chr get_mutable'( Status, Mref), + ( Status==active -> + 'chr update_mutable'( triggered, Mref), + arg( 4, S, Gref), % ARGXXX + 'chr get_mutable'( Gen, Gref), + Generation is Gen+1, + 'chr update_mutable'( Generation, Gref), + arg( 3, S, Goal), % ARGXXX + call( Goal), + 'chr get_mutable'( Post, Mref), + ( Post==triggered -> + 'chr update_mutable'( active, Mref) % catching constraints that did not do anything + ; + true + ) + ; + true + ), + run_suspensions( Next). + +'chr run_suspensions_d'( Slots) :- + run_suspensions_d( Slots). + +'chr run_suspensions_loop_d'([]). +'chr run_suspensions_loop_d'([L|Ls]) :- + run_suspensions_d(L), + 'chr run_suspensions_loop_d'(Ls). + +run_suspensions_d([]). +run_suspensions_d([S|Next] ) :- + arg( 2, S, Mref), % ARGXXX + 'chr get_mutable'( Status, Mref), + ( Status==active -> + 'chr update_mutable'( triggered, Mref), + arg( 4, S, Gref), % ARGXXX + 'chr get_mutable'( Gen, Gref), + Generation is Gen+1, + 'chr update_mutable'( Generation, Gref), + arg( 3, S, Goal), % ARGXXX + ( + 'chr debug_event'(wake(S)), + call( Goal) + ; + 'chr debug_event'(fail(S)), !, + fail + ), + ( + 'chr debug_event'(exit(S)) + ; + 'chr debug_event'(redo(S)), + fail + ), + 'chr get_mutable'( Post, Mref), + ( Post==triggered -> + 'chr update_mutable'( active, Mref) % catching constraints that did not do anything + ; + true + ) + ; + true + ), + run_suspensions_d( Next). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% L O C K I N G +% +% locking of variables in guards + +%= IMPLEMENTATION 1: SILENT FAILURE ============================================ + +%- attribute handler ----------------------------------------------------------- +% intercepts unification of locked variable unification + +locked:attr_unify_hook(_,_) :- fail. + +%- locking & unlocking --------------------------------------------------------- +'chr lock'(T) :- + ( var(T) + -> put_attr(T, locked, x) + ; term_variables(T,L), + lockv(L) + ). + +lockv([]). +lockv([T|R]) :- put_attr( T, locked, x), lockv(R). + +'chr unlock'(T) :- + ( var(T) + -> del_attr(T, locked) + ; term_variables(T,L), + unlockv(L) + ). + +unlockv([]). +unlockv([T|R]) :- del_attr( T, locked), unlockv(R). + +%- checking for locks ---------------------------------------------------------- + +'chr none_locked'( []). +'chr none_locked'( [V|Vs]) :- + ( get_attr(V, locked, _) -> + fail + ; + 'chr none_locked'(Vs) + ). + +'chr not_locked'(V) :- + ( var( V) -> + ( get_attr( V, locked, _) -> + fail + ; + true + ) + ; + true + ). + +%= IMPLEMENTATION 2: EXPLICT EXCEPTION ========================================= + +%- LOCK ERROR MESSAGE ---------------------------------------------------------- +lock_error(Term) :- + throw(error(instantation_error(Term),context(_,'CHR Runtime Error: unification in guard not allowed!'))). + +%- attribute handler ----------------------------------------------------------- +% intercepts unification of locked variable unification + +error_locked:attr_unify_hook(_,Term) :- lock_error(Term). + +%- locking & unlocking --------------------------------------------------------- +'chr error_lock'(T) :- + ( var(T) + -> put_attr(T, error_locked, x) + ; term_variables(T,L), + error_lockv(L) + ). + +error_lockv([]). +error_lockv([T|R]) :- put_attr( T, error_locked, x), error_lockv(R). + +'chr unerror_lock'(T) :- + ( var(T) + -> del_attr(T, error_locked) + ; term_variables(T,L), + unerror_lockv(L) + ). + +unerror_lockv([]). +unerror_lockv([T|R]) :- del_attr( T, error_locked), unerror_lockv(R). + +%- checking for locks ---------------------------------------------------------- + +'chr none_error_locked'( []). +'chr none_error_locked'( [V|Vs]) :- + ( get_attr(V, error_locked, _) -> + fail + ; + 'chr none_error_locked'(Vs) + ). + +'chr not_error_locked'(V) :- + ( var( V) -> + ( get_attr( V, error_locked, _) -> + fail + ; + true + ) + ; + true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Eager removal from all chains. +% +'chr remove_constraint_internal'( Susp, Agenda) :- + arg( 2, Susp, Mref), % ARGXXX + 'chr get_mutable'( State, Mref), + 'chr update_mutable'( removed, Mref), % mark in any case + ( compound(State) -> % passive/1 + Agenda = [] + ; State==removed -> + Agenda = [] + %; State==triggered -> + % Agenda = [] + ; + Susp =.. [_,_,_,_,_,_,_|Args], + term_variables( Args, Vars), + 'chr default_store'( Global), + Agenda = [Global|Vars] + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr newvia_1'(X,V) :- + ( var(X) -> + X = V + ; + nonground(X,V) + ). + +'chr newvia_2'(X,Y,V) :- + ( var(X) -> + X = V + ; var(Y) -> + Y = V + ; compound(X), nonground(X,V) -> + true + ; + compound(Y), nonground(Y,V) + ). + +% +% The second arg is a witness. +% The formulation with term_variables/2 is +% cycle safe, but it finds a list of all vars. +% We need only one, and no list in particular. +% +'chr newvia'(L,V) :- nonground(L,V). +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- + +'chr via_1'(X,V) :- + ( var(X) -> + X = V + ; atomic(X) -> + 'chr default_store'(V) + ; nonground(X,V) -> + true + ; + 'chr default_store'(V) + ). + +'chr via_2'(X,Y,V) :- + ( var(X) -> + X = V + ; var(Y) -> + Y = V + ; compound(X), nonground(X,V) -> + true + ; compound(Y), nonground(Y,V) -> + true + ; + 'chr default_store'(V) + ). + +% +% The second arg is a witness. +% The formulation with term_variables/2 is +% cycle safe, but it finds a list of all vars. +% We need only one, and no list in particular. +% +'chr via'(L,V) :- + ( nonground(L,V) -> + true + ; + 'chr default_store'(V) + ). + +nonground( Term, V) :- + term_variables( Term, Vs), + Vs = [V|_]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr novel_production'( Self, Tuple) :- + arg( 5, Self, Ref), % ARGXXX + 'chr get_mutable'( History, Ref), + ( get_ds( Tuple, History, _) -> + fail + ; + true + ). + +% +% Not folded with novel_production/2 because guard checking +% goes in between the two calls. +% +'chr extend_history'( Self, Tuple) :- + arg( 5, Self, Ref), % ARGXXX + 'chr get_mutable'( History, Ref), + put_ds( Tuple, History, x, NewHistory), + 'chr update_mutable'( NewHistory, Ref). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr allocate_constraint'( Closure, Self, F, Args) :- + Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX + 'chr create_mutable'(0, Gref), + 'chr empty_history'(History), + 'chr create_mutable'(History, Href), + 'chr create_mutable'(passive(Args), Mref), + 'chr gen_id'( Id). + +% +% 'chr activate_constraint'( -, +, -). +% +% The transition gc->active should be rare +% +'chr activate_constraint'( Vars, Susp, Generation) :- + arg( 2, Susp, Mref), % ARGXXX + 'chr get_mutable'( State, Mref), + 'chr update_mutable'( active, Mref), + ( nonvar(Generation) -> % aih + true + ; + arg( 4, Susp, Gref), % ARGXXX + 'chr get_mutable'( Gen, Gref), + Generation is Gen+1, + 'chr update_mutable'( Generation, Gref) + ), + ( compound(State) -> % passive/1 + term_variables( State, Vs), + 'chr none_locked'( Vs), + Vars = [Global|Vs], + 'chr default_store'(Global) + ; State == removed -> % the price for eager removal ... + Susp =.. [_,_,_,_,_,_,_|Args], + term_variables( Args, Vs), + Vars = [Global|Vs], + 'chr default_store'(Global) + ; + Vars = [] + ). + +'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :- + 'chr default_store'(Global), + term_variables(Args,Vars), + 'chr none_locked'(Vars), + Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX + 'chr create_mutable'(active, Mref), + 'chr create_mutable'(0, Gref), + 'chr empty_history'(History), + 'chr create_mutable'(History, Href), + 'chr gen_id'(Id). + +insert_constraint_internal([Global|Vars], Self, Term, Closure, F, Args) :- + 'chr default_store'(Global), + term_variables( Term, Vars), + 'chr none_locked'( Vars), + 'chr empty_history'( History), + 'chr create_mutable'( active, Mref), + 'chr create_mutable'( 0, Gref), + 'chr create_mutable'( History, Href), + 'chr gen_id'( Id), + Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args]. % SUSPXXX + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr empty_history'( E) :- empty_ds( E). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr gen_id'( Id) :- + nb_getval(chr_id,Id), + NextId is Id + 1, + nb_setval(chr_id,NextId). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% SWI begin +'chr create_mutable'(V,mutable(V)). +'chr get_mutable'(V,mutable(V)). +'chr update_mutable'(V,M) :- setarg(1,M,V). +%% SWI end + +%% SICStus begin +%% 'chr create_mutable'(Val, Mut) :- create_mutable(Val, Mut). +%% 'chr get_mutable'(Val, Mut) :- get_mutable(Val, Mut). +%% 'chr update_mutable'(Val, Mut) :- update_mutable(Val, Mut). +%% SICStus end + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% SWI begin +'chr default_store'(X) :- nb_getval(chr_global,X). +%% SWI end + +%% SICStus begin +%% 'chr default_store'(A) :- global_term_ref_1(A). +%% SICStus end + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +'chr sbag_member'( Element, [Head|Tail]) :- + sbag_member( Element, Tail, Head). + +% auxiliary to avoid choicepoint for last element + % does it really avoid the choicepoint? -jon + sbag_member( E, _, E). + sbag_member( E, [Head|Tail], _) :- + sbag_member( E, Tail, Head). + +'chr sbag_del_element'( [], _, []). +'chr sbag_del_element'( [X|Xs], Elem, Set2) :- + ( X==Elem -> + Set2 = Xs + ; + Set2 = [X|Xss], + 'chr sbag_del_element'( Xs, Elem, Xss) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +'chr merge_attributes'([],Ys,Ys). +'chr merge_attributes'([X | Xs],YL,R) :- + ( YL = [Y | Ys] -> + arg(1,X,XId), % ARGXXX + arg(1,Y,YId), % ARGXXX + ( XId < YId -> + R = [X | T], + 'chr merge_attributes'(Xs,YL,T) + ; XId > YId -> + R = [Y | T], + 'chr merge_attributes'([X|Xs],Ys,T) + ; + R = [X | T], + 'chr merge_attributes'(Xs,Ys,T) + ) + ; + R = [X | Xs] + ). + +'chr new_merge_attributes'([],A2,A) :- + A = A2. +'chr new_merge_attributes'([E1|AT1],A2,A) :- + ( A2 = [E2|AT2] -> + 'chr new_merge_attributes'(E1,E2,AT1,AT2,A) + ; + A = [E1|AT1] + ). + +'chr new_merge_attributes'(Pos1-L1,Pos2-L2,AT1,AT2,A) :- + ( Pos1 < Pos2 -> + A = [Pos1-L1|AT], + 'chr new_merge_attributes'(AT1,[Pos2-L2|AT2],AT) + ; Pos1 > Pos2 -> + A = [Pos2-L2|AT], + 'chr new_merge_attributes'([Pos1-L1|AT1],AT2,AT) + ; + 'chr merge_attributes'(L1,L2,L), + A = [Pos1-L|AT], + 'chr new_merge_attributes'(AT1,AT2,AT) + ). + +'chr all_suspensions'([],_,_). +'chr all_suspensions'([Susps|SuspsList],Pos,Attr) :- + all_suspensions(Attr,Susps,SuspsList,Pos). + +all_suspensions([],[],SuspsList,Pos) :- + all_suspensions([],[],SuspsList,Pos). % all empty lists +all_suspensions([APos-ASusps|RAttr],Susps,SuspsList,Pos) :- + NPos is Pos + 1, + ( Pos == APos -> + Susps = ASusps, + 'chr all_suspensions'(SuspsList,NPos,RAttr) + ; + Susps = [], + 'chr all_suspensions'(SuspsList,NPos,[APos-ASusps|RAttr]) + ). + +'chr normalize_attr'([],[]). +'chr normalize_attr'([Pos-L|R],[Pos-NL|NR]) :- + sort(L,NL), + 'chr normalize_attr'(R,NR). + +'chr select'([E|T],F,R) :- + ( E = F -> + R = T + ; + R = [E|NR], + 'chr select'(T,F,NR) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- multifile + chr:debug_event/2, % +State, +Event + chr:debug_interact/3. % +Event, +Depth, -Command + +'chr debug_event'(Event) :- + nb_getval(chr_debug,mutable(State)), % XXX + ( State == off -> + true + ; chr:debug_event(State, Event) -> + true + ; debug_event(State,Event) + ). + +chr_trace :- + nb_setval(chr_debug,mutable(trace)). +chr_notrace :- + nb_setval(chr_debug,mutable(off)). + +% chr_leash(+Spec) +% +% Define the set of ports at which we prompt for user interaction + +chr_leash(Spec) :- + leashed_ports(Spec, Ports), + nb_setval(chr_leash,mutable(Ports)). + +leashed_ports(none, []). +leashed_ports(off, []). +leashed_ports(all, [call, exit, redo, fail, wake, try, apply, insert, remove]). +leashed_ports(default, [call,exit,fail,wake,apply]). +leashed_ports(One, Ports) :- + atom(One), One \== [], !, + leashed_ports([One], Ports). +leashed_ports(Set, Ports) :- + sort(Set, Ports), % make unique + leashed_ports(all, All), + valid_ports(Ports, All). + +valid_ports([], _). +valid_ports([H|T], Valid) :- + ( memberchk(H, Valid) + -> true + ; throw(error(domain_error(chr_port, H), _)) + ), + valid_ports(T, Valid). + +user:exception(undefined_global_variable, Name, retry) :- + chr_runtime_debug_global_variable(Name), + chr_debug_init. + +chr_runtime_debug_global_variable(chr_leash). + +chr_debug_init :- + leashed_ports(default, Ports), + nb_setval(chr_leash, mutable(Ports)). + +:- initialization chr_debug_init. + +% debug_event(+State, +Event) + + +%debug_event(trace, Event) :- +% functor(Event, Name, Arity), +% writeln(Name/Arity), fail. +debug_event(trace,Event) :- + Event = call(_), !, + get_debug_history(History,Depth), + NDepth is Depth + 1, + chr_debug_interact(Event,NDepth), + set_debug_history([Event|History],NDepth). +debug_event(trace,Event) :- + Event = wake(_), !, + get_debug_history(History,Depth), + NDepth is Depth + 1, + chr_debug_interact(Event,NDepth), + set_debug_history([Event|History],NDepth). +debug_event(trace,Event) :- + Event = redo(_), !, + get_debug_history(_History, Depth), + chr_debug_interact(Event, Depth). +debug_event(trace,Event) :- + Event = exit(_),!, + get_debug_history([_|History],Depth), + chr_debug_interact(Event,Depth), + NDepth is Depth - 1, + set_debug_history(History,NDepth). +debug_event(trace,Event) :- + Event = fail(_),!, + get_debug_history(_,Depth), + chr_debug_interact(Event,Depth). +debug_event(trace, Event) :- + Event = remove(_), !, + get_debug_history(_,Depth), + chr_debug_interact(Event, Depth). +debug_event(trace, Event) :- + Event = insert(_), !, + get_debug_history(_,Depth), + chr_debug_interact(Event, Depth). +debug_event(trace, Event) :- + Event = try(_,_,_,_), !, + get_debug_history(_,Depth), + chr_debug_interact(Event, Depth). +debug_event(trace, Event) :- + Event = apply(_,_,_,_), !, + get_debug_history(_,Depth), + chr_debug_interact(Event,Depth). + +debug_event(skip(_,_),Event) :- + Event = call(_), !, + get_debug_history(History,Depth), + NDepth is Depth + 1, + set_debug_history([Event|History],NDepth). +debug_event(skip(_,_),Event) :- + Event = wake(_), !, + get_debug_history(History,Depth), + NDepth is Depth + 1, + set_debug_history([Event|History],NDepth). +debug_event(skip(SkipSusp,SkipDepth),Event) :- + Event = exit(Susp),!, + get_debug_history([_|History],Depth), + ( SkipDepth == Depth, + SkipSusp == Susp -> + set_chr_debug(trace), + chr_debug_interact(Event,Depth) + ; + true + ), + NDepth is Depth - 1, + set_debug_history(History,NDepth). +debug_event(skip(_,_),_) :- !, + true. + +% chr_debug_interact(+Event, +Depth) +% +% Interact with the user on Event that took place at Depth. First +% calls chr:debug_interact(+Event, +Depth, -Command) hook. If this +% fails the event is printed and the system prompts for a command. + +chr_debug_interact(Event, Depth) :- + chr:debug_interact(Event, Depth, Command), !, + handle_debug_command(Command,Event,Depth). +chr_debug_interact(Event, Depth) :- + print_event(Event, Depth), + ( leashed(Event) + -> ask_continue(Command) + ; Command = creep + ), + handle_debug_command(Command,Event,Depth). + +leashed(Event) :- + functor(Event, Port, _), + nb_getval(chr_leash, mutable(Ports)), + memberchk(Port, Ports). + +ask_continue(Command) :- + print_message(trace, chr(prompt)), + get_single_char(CharCode), + ( CharCode == -1 + -> Char = end_of_file + ; char_code(Char, CharCode) + ), + ( debug_command(Char, Command) + -> print_message(trace, chr(command(Command))) + ; print_message(help, chr(invalid_command)), + ask_continue(Command) + ). + + +'chr debug command'(Char, Command) :- + debug_command(Char, Command). + +debug_command(c, creep). +debug_command(' ', creep). +debug_command('\r', creep). +debug_command(s, skip). +debug_command(g, ancestors). +debug_command(n, nodebug). +debug_command(a, abort). +debug_command(f, fail). +debug_command(b, break). +debug_command(?, help). +debug_command(h, help). +debug_command(end_of_file, exit). + + +handle_debug_command(creep,_,_) :- !. +handle_debug_command(skip, Event, Depth) :- !, + Event =.. [Type|Rest], + ( Type \== call, + Type \== wake -> + handle_debug_command('c',Event,Depth) + ; + Rest = [Susp], + set_chr_debug(skip(Susp,Depth)) + ). + +handle_debug_command(ancestors,Event,Depth) :- !, + print_chr_debug_history, + chr_debug_interact(Event,Depth). +handle_debug_command(nodebug,_,_) :- !, + chr_notrace. +handle_debug_command(abort,_,_) :- !, + abort. +handle_debug_command(exit,_,_) :- !, + halt. +handle_debug_command(fail,_,_) :- !, + fail. +handle_debug_command(break,Event,Depth) :- !, + break, + chr_debug_interact(Event,Depth). +handle_debug_command(help,Event,Depth) :- !, + print_message(help, chr(debug_options)), + chr_debug_interact(Event,Depth). +handle_debug_command(Cmd, _, _) :- + throw(error(domain_error(chr_debug_command, Cmd), _)). + +print_chr_debug_history :- + get_debug_history(History,Depth), + print_message(trace, chr(ancestors(History, Depth))). + +print_event(Event, Depth) :- + print_message(trace, chr(event(Event, Depth))). + +% {set,get}_debug_history(Ancestors, Depth) +% +% Set/get the list of ancestors and the depth of the current goal. + +get_debug_history(History,Depth) :- + nb_getval(chr_debug_history,mutable(History,Depth)). + +set_debug_history(History,Depth) :- + nb_getval(chr_debug_history,Mutable), + setarg(1,Mutable,History), + setarg(2,Mutable,Depth). + +set_chr_debug(State) :- + nb_getval(chr_debug,Mutable), + setarg(1,Mutable,State). + +'chr chr_indexed_variables'(Susp,Vars) :- + Susp =.. [_,_,_,_,_,_,_|Args], + term_variables(Args,Vars). diff --git a/packages/chr/chr_support.c b/packages/chr/chr_support.c new file mode 100644 index 000000000..b097ebf3e --- /dev/null +++ b/packages/chr/chr_support.c @@ -0,0 +1,105 @@ +#include +#include +#include + + +/* + lookup_ht(HT,Key,Values) :- + term_hash(Key,Hash), + HT = ht(Capacity,_,Table), + Index is (Hash mod Capacity) + 1, + arg(Index,Table,Bucket), + nonvar(Bucket), + ( Bucket = K-Vs -> + K == Key, + Values = Vs + ; + lookup(Bucket,Key,Values) + ). + + lookup([K - V | KVs],Key,Value) :- + ( K = Key -> + V = Value + ; + lookup(KVs,Key,Value) + ). +*/ +static foreign_t +pl_lookup_ht1(term_t ht, term_t pl_hash, term_t key, term_t values) +{ + int capacity; + int hash; + int index; + + term_t pl_capacity = PL_new_term_ref(); + term_t table = PL_new_term_ref(); + term_t bucket = PL_new_term_ref(); + + /* HT = ht(Capacity,_,Table) */ + PL_get_arg(1, ht, pl_capacity); + PL_get_integer(pl_capacity, &capacity); + PL_get_arg(3, ht, table); + + /* Index is (Hash mod Capacity) + 1 */ + PL_get_integer(pl_hash, &hash); + index = (hash % capacity) + 1; + + /* arg(Index,Table,Bucket) */ + PL_get_arg(index, table, bucket); + + /* nonvar(Bucket) */ + if (PL_is_variable(bucket)) PL_fail; + + if (PL_is_list(bucket)) { + term_t pair = PL_new_term_ref(); + term_t k = PL_new_term_ref(); + term_t vs = PL_new_term_ref(); + while (PL_get_list(bucket, pair,bucket)) { + PL_get_arg(1, pair, k); + if ( PL_compare(k,key) == 0 ) { + /* Values = Vs */ + PL_get_arg(2, pair, vs); + return PL_unify(values,vs); + } + } + PL_fail; + } else { + term_t k = PL_new_term_ref(); + term_t vs = PL_new_term_ref(); + PL_get_arg(1, bucket, k); + /* K == Key */ + if ( PL_compare(k,key) == 0 ) { + /* Values = Vs */ + PL_get_arg(2, bucket, vs); + return PL_unify(values,vs); + } else { + PL_fail; + } + } +} + +static foreign_t +pl_memberchk_eq(term_t element, term_t maybe_list) +{ + + term_t head = PL_new_term_ref(); /* variable for the elements */ + term_t list = PL_copy_term_ref(maybe_list); /* copy as we need to write */ + + while( PL_get_list(list, head, list) ) + { if ( PL_compare(element,head) == 0 ) + PL_succeed ; + } + + PL_fail; + +} + + /* INSTALL */ + +install_t +install_chr_support() +{ + PL_register_foreign("memberchk_eq",2, pl_memberchk_eq, 0); + PL_register_foreign("lookup_ht1",4, pl_lookup_ht1, 0); +} + diff --git a/packages/chr/chr_swi.pl b/packages/chr/chr_swi.pl new file mode 100644 index 000000000..09140d1da --- /dev/null +++ b/packages/chr/chr_swi.pl @@ -0,0 +1,449 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers and Jan Wielemaker + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%% SWI begin +%% @addtogroup CHR +% +% SWI interface. +% +:- module(chr, + [ op(1180, xfx, ==>), + op(1180, xfx, <=>), + op(1150, fx, constraints), + op(1150, fx, chr_constraint), + op(1150, fx, chr_preprocessor), + op(1150, fx, handler), + op(1150, fx, rules), + op(1100, xfx, \), + op(1200, xfx, @), + op(1190, xfx, pragma), + op( 500, yfx, #), + op(1150, fx, chr_type), + op(1150, fx, chr_declaration), + op(1130, xfx, --->), + op(1150, fx, (?)), + chr_show_store/1, % +Module + find_chr_constraint/1, % +Pattern + chr_trace/0, + chr_notrace/0, + chr_leash/1 % +Ports + ]). + +:- expects_dialect(swi). + +:- set_prolog_flag(generate_debug_info, false). + +:- multifile user:file_search_path/2. +:- dynamic user:file_search_path/2. +:- dynamic chr_translated_program/1. + +user:file_search_path(chr, library(chr)). + +:- load_files([ chr(chr_translate), + chr(chr_runtime), + chr(chr_messages), + chr(chr_hashtable_store), + chr(chr_compiler_errors) + ], + [ if(not_loaded), + silent(true) + ]). + +:- use_module(library(lists),[member/2]). +%% SWI end + +%% SICStus begin +%% :- module(chr,[ +%% chr_trace/0, +%% chr_notrace/0, +%% chr_leash/0, +%% chr_flag/3, +%% chr_show_store/1 +%% ]). +%% +%% :- op(1180, xfx, ==>), +%% op(1180, xfx, <=>), +%% op(1150, fx, constraints), +%% op(1150, fx, handler), +%% op(1150, fx, rules), +%% op(1100, xfx, \), +%% op(1200, xfx, @), +%% op(1190, xfx, pragma), +%% op( 500, yfx, #), +%% op(1150, fx, chr_type), +%% op(1130, xfx, --->), +%% op(1150, fx, (?)). +%% +%% :- multifile user:file_search_path/2. +%% :- dynamic chr_translated_program/1. +%% +%% user:file_search_path(chr, library(chr)). +%% +%% +%% :- use_module('chr/chr_translate'). +%% :- use_module('chr/chr_runtime'). +%% :- use_module('chr/chr_hashtable_store'). +%% :- use_module('chr/hprolog'). +%% SICStus end + +:- multifile chr:'$chr_module'/1. + +:- dynamic chr_term/3. % File, Term + +:- dynamic chr_pp/2. % File, Term + +% chr_expandable(+Term) +% +% Succeeds if Term is a rule that must be handled by the CHR +% compiler. Ideally CHR definitions should be between +% +% :- constraints ... +% ... +% :- end_constraints. +% +% As they are not we have to use some heuristics. We assume any +% file is a CHR after we've seen :- constraints ... + +chr_expandable((:- constraints _)). +chr_expandable((constraints _)). +chr_expandable((:- chr_constraint _)). +chr_expandable((:- chr_type _)). +chr_expandable((chr_type _)). +chr_expandable((:- chr_declaration _)). +chr_expandable(option(_, _)). +chr_expandable((:- chr_option(_, _))). +chr_expandable((handler _)). +chr_expandable((rules _)). +chr_expandable((_ <=> _)). +chr_expandable((_ @ _)). +chr_expandable((_ ==> _)). +chr_expandable((_ pragma _)). + +% chr_expand(+Term, -Expansion) +% +% Extract CHR declarations and rules from the file and run the +% CHR compiler when reaching end-of-file. + +%% SWI begin +extra_declarations([ (:- use_module(chr(chr_runtime))), + (:- style_check(-discontiguous)), + (:- style_check(-singleton)), + (:- style_check(-no_effect)), + (:- set_prolog_flag(generate_debug_info, false)) + | Tail + ], Tail). +%% SWI end + +%% SICStus begin +%% extra_declarations([(:-use_module(chr(chr_runtime))) +%% , (:- use_module(chr(hprolog),[term_variables/2,term_variables/3])) +%% , (:-use_module(chr(hpattvars))) +%% | Tail], Tail). +%% SICStus end + +chr_expand(Term, []) :- + chr_expandable(Term), !, + prolog_load_context(source,File), + prolog_load_context(term_position,'$stream_position'(_, LineNumber, _, _, _)), + add_pragma_to_chr_rule(Term,line_number(LineNumber),NTerm), + assert(chr_term(File, LineNumber, NTerm)). +chr_expand(Term, []) :- + Term = (:- chr_preprocessor Preprocessor), !, + prolog_load_context(source,File), + assert(chr_pp(File, Preprocessor)). +chr_expand(end_of_file, FinalProgram) :- + extra_declarations(FinalProgram,Program), + prolog_load_context(source,File), + findall(T, retract(chr_term(File,_Line,T)), CHR0), + CHR0 \== [], + prolog_load_context(module, Module), + add_debug_decl(CHR0, CHR1), + add_optimise_decl(CHR1, CHR2), + CHR3 = [ (:- module(Module, [])) | CHR2 ], + findall(P, retract(chr_pp(File, P)), Preprocessors), + ( Preprocessors = [] -> + CHR3 = CHR + ; Preprocessors = [Preprocessor] -> + chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]), + call_chr_preprocessor(Preprocessor,CHR3,CHR) + ; + chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])), + fail + ), + catch(call_chr_translate(File, + [ (:- module(Module, [])) + | CHR + ], + Program0), + chr_error(Error), + ( chr_compiler_errors:print_chr_error(Error), + fail + ) + ), + delete_header(Program0, Program). + + +delete_header([(:- module(_,_))|T0], T) :- !, + delete_header(T0, T). +delete_header(L, L). + +add_debug_decl(CHR, CHR) :- + member(option(Name, _), CHR), Name == debug, !. +add_debug_decl(CHR, CHR) :- + member((:- chr_option(Name, _)), CHR), Name == debug, !. +add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :- + ( chr_current_prolog_flag(generate_debug_info, true) + -> Debug = on + ; Debug = off + ). + +%% SWI begin +chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val). +%% SWI end + +add_optimise_decl(CHR, CHR) :- + \+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !. +add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :- + chr_current_prolog_flag(optimize, full), !. +add_optimise_decl(CHR, CHR). + + +% call_chr_translate(+File, +In, -Out) +% +% The entire chr_translate/2 translation may fail, in which case we'd +% better issue a warning rather than simply ignoring the CHR +% declarations. + +call_chr_translate(File, In, _Out) :- + ( chr_translate_line_info(In, File, Out0) -> + nb_setval(chr_translated_program,Out0), + fail + ). +call_chr_translate(_, _In, Out) :- + nb_current(chr_translated_program,Out), !, + nb_delete(chr_translated_program). + +call_chr_translate(File, _, []) :- + print_message(error, chr(compilation_failed(File))). + +call_chr_preprocessor(Preprocessor,CHR,_NCHR) :- + ( call(Preprocessor,CHR,CHR0) -> + nb_setval(chr_preprocessed_program,CHR0), + fail + ). +call_chr_preprocessor(_,_,NCHR) :- + nb_current(chr_preprocessed_program,NCHR), !, + nb_delete(chr_preprocessed_program). +call_chr_preprocessor(Preprocessor,_,_) :- + chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])). + +%% SWI begin + + /******************************* + * SYNCHRONISE TRACER * + *******************************/ + +:- multifile + user:message_hook/3, + chr:debug_event/2, + chr:debug_interact/3. +:- dynamic + user:message_hook/3. + +user:message_hook(trace_mode(OnOff), _, _) :- + ( OnOff == on + -> chr_trace + ; chr_notrace + ), + fail. % backtrack to other handlers + +% chr:debug_event(+State, +Event) +% +% Hook into the CHR debugger. At this moment we will discard CHR +% events if we are in a Prolog `skip' and we ignore the + +chr:debug_event(_State, _Event) :- + tracing, % are we tracing? + prolog_skip_level(Skip, Skip), + Skip \== very_deep, + prolog_current_frame(Me), + prolog_frame_attribute(Me, level, Level), + Level > Skip, !. + +% chr:debug_interact(+Event, +Depth, -Command) +% +% Hook into the CHR debugger to display Event and ask for the next +% command to execute. This definition causes the normal Prolog +% debugger to be used for the standard ports. + +chr:debug_interact(Event, _Depth, creep) :- + prolog_event(Event), + tracing, !. + +prolog_event(call(_)). +prolog_event(exit(_)). +prolog_event(fail(_)). + + + + + /******************************* + * MESSAGES * + *******************************/ + +:- multifile + prolog:message/3. + +prolog:message(chr(CHR)) --> + chr_message(CHR). + +:- multifile + check:trivial_fail_goal/1. + +check:trivial_fail_goal(_:Goal) :- + functor(Goal, Name, _), + sub_atom(Name, 0, _, _, '$chr_store_constants_'). + + /******************************* + * TOPLEVEL PRINTING * + *******************************/ + +:- create_prolog_flag(chr_toplevel_show_store, true, []). + +prolog:message(query(YesNo)) --> !, + ['~@'-[chr:print_all_stores]], + '$messages':prolog_message(query(YesNo)). + +prolog:message(query(YesNo,Bindings)) --> !, + ['~@'-[chr:print_all_stores]], + '$messages':prolog_message(query(YesNo,Bindings)). + +print_all_stores :- + ( chr_current_prolog_flag(chr_toplevel_show_store,true), + catch(nb_getval(chr_global, _), _, fail), + chr:'$chr_module'(Mod), + chr_show_store(Mod), + fail + ; + true + ). + + /******************************* + * MUST BE LAST! * + *******************************/ +:- multifile system:term_expansion/2. +:- dynamic system:term_expansion/2. + +system:term_expansion(In, Out) :- + \+ current_prolog_flag(xref, true), + chr_expand(In, Out). + +%% SWI end + +%% SICStus begin +% +% :- dynamic +% current_toplevel_show_store/1, +% current_generate_debug_info/1, +% current_optimize/1. +% +% current_toplevel_show_store(on). +% +% current_generate_debug_info(false). +% +% current_optimize(off). +% +% chr_current_prolog_flag(generate_debug_info, X) :- +% chr_flag(generate_debug_info, X, X). +% chr_current_prolog_flag(optimize, X) :- +% chr_flag(optimize, X, X). +% +% chr_flag(Flag, Old, New) :- +% Goal = chr_flag(Flag,Old,New), +% g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1), +% chr_flag(Flag, Old, New, Goal). +% +% chr_flag(toplevel_show_store, Old, New, Goal) :- +% clause(current_toplevel_show_store(Old), true, Ref), +% ( New==Old -> true +% ; must_be(New, oneof([on,off]), Goal, 3), +% erase(Ref), +% assertz(current_toplevel_show_store(New)) +% ). +% chr_flag(generate_debug_info, Old, New, Goal) :- +% clause(current_generate_debug_info(Old), true, Ref), +% ( New==Old -> true +% ; must_be(New, oneof([false,true]), Goal, 3), +% erase(Ref), +% assertz(current_generate_debug_info(New)) +% ). +% chr_flag(optimize, Old, New, Goal) :- +% clause(current_optimize(Old), true, Ref), +% ( New==Old -> true +% ; must_be(New, oneof([full,off]), Goal, 3), +% erase(Ref), +% assertz(current_optimize(New)) +% ). +% +% +% all_stores_goal(Goal, CVAs) :- +% chr_flag(toplevel_show_store, on, on), !, +% findall(C-CVAs, find_chr_constraint(C), Pairs), +% andify(Pairs, Goal, CVAs). +% all_stores_goal(true, _). +% +% andify([], true, _). +% andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs). +% +% andify([], X, X, _). +% andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs). +% +% :- multifile user:term_expansion/6. +% +% user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :- +% nonvar(In), +% nonmember(chr, Ids), +% chr_expand(In, Out), !. +% +%% SICStus end + +%%% for SSS %%% + +add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :- !, + add_pragma_to_chr_rule(Rule,Pragma,NRule), + Result = (Name @ NRule). +add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :- !, + Result = (Rule pragma (Pragma,Pragmas)). +add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :- !, + Result = (Head ==> Body pragma Pragma). +add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :- !, + Result = (Head <=> Body pragma Pragma). +add_pragma_to_chr_rule(Term,_,Term). diff --git a/packages/chr/chr_swi_bootstrap.pl b/packages/chr/chr_swi_bootstrap.pl new file mode 100644 index 000000000..b050d55ea --- /dev/null +++ b/packages/chr/chr_swi_bootstrap.pl @@ -0,0 +1,215 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(chr, + [ chr_compile_step1/2 % +CHRFile, -PlFile + , chr_compile_step2/2 % +CHRFile, -PlFile + , chr_compile_step3/2 % +CHRFile, -PlFile + , chr_compile_step4/2 % +CHRFile, -PlFile + , chr_compile/3 + ]). +%% SWI begin +% vsc: +:- if(current_prolog_flag(dialect, yap)). + +:- prolog_load_context(directory,D), add_to_path(D). + +:- prolog_load_context(directory,D), atom_concat(D, '/../../library', D1), assert(user:library_directory(D1)). + +:- prolog_load_context(directory,D), atom_concat(D, '/../../swi/library', D1), assert(user:library_directory(D1)). + +:- else. + +:- use_module(library(listing)). % portray_clause/2 + +:- endif. + +:- expects_dialect(swi). + +%% SWI end +:- include(chr_op). + + /******************************* + * FILE-TO-FILE COMPILER * + *******************************/ + +% chr_compile(+CHRFile, -PlFile) +% +% Compile a CHR specification into a Prolog file + +chr_compile_step1(From, To) :- + use_module('chr_translate_bootstrap.pl'), + chr_compile(From, To, informational). +chr_compile_step2(From, To) :- + use_module('chr_translate_bootstrap1.pl'), + chr_compile(From, To, informational). +chr_compile_step3(From, To) :- + use_module('chr_translate_bootstrap2.pl'), + chr_compile(From, To, informational). +chr_compile_step4(From, To) :- + use_module('chr_translate.pl'), + chr_compile(From, To, informational). + +chr_compile(From, To, MsgLevel) :- + print_message(MsgLevel, chr(start(From))), + read_chr_file_to_terms(From,Declarations), + % read_file_to_terms(From, Declarations, + % [ module(chr) % get operators from here + % ]), + print_message(silent, chr(translate(From))), + chr_translate(Declarations, Declarations1), + insert_declarations(Declarations1, NewDeclarations), + print_message(silent, chr(write(To))), + writefile(To, From, NewDeclarations), + print_message(MsgLevel, chr(end(From, To))). + + +%% SWI begin +specific_declarations([ (:- use_module('chr_runtime')), + (:- style_check(-discontiguous)), + (:- style_check(-singleton)), + (:- style_check(-no_effect)) + | Tail + ], Tail). +%% SWI end + +%% SICStus begin +%% specific_declarations([(:- use_module('chr_runtime')), +%% (:-use_module(chr_hashtable_store)), +%% (:- use_module('hpattvars')), +%% (:- use_module('b_globval')), +%% (:- use_module('hprolog')), % needed ? +%% (:- set_prolog_flag(discontiguous_warnings,off)), +%% (:- set_prolog_flag(single_var_warnings,off))|Tail], Tail). +%% SICStus end + + + +insert_declarations(Clauses0, Clauses) :- + specific_declarations(Decls,Tail), + (Clauses0 = [(:- module(M,E))|FileBody] -> + Clauses = [ (:- module(M,E))|Decls], + Tail = FileBody + ; + Clauses = Decls, + Tail = Clauses0 + ). + +% writefile(+File, +From, +Desclarations) +% +% Write translated CHR declarations to a File. + +writefile(File, From, Declarations) :- + open(File, write, Out), + writeheader(From, Out), + writecontent(Declarations, Out), + close(Out). + +writecontent([], _). +writecontent([D|Ds], Out) :- + portray_clause(Out, D), % SWI-Prolog + writecontent(Ds, Out). + + +writeheader(File, Out) :- + format(Out, '/* Generated by CHR bootstrap compiler~n', []), + format(Out, ' From: ~w~n', [File]), + format_date(Out), + format(Out, ' DO NOT EDIT. EDIT THE CHR FILE INSTEAD~n', []), + format(Out, '*/~n~n', []). + +%% SWI begin +format_date(Out) :- + get_time(Now), + convert_time(Now, Date), + format(Out, ' Date: ~w~n~n', [Date]). +%% SWI end + +%% SICStus begin +%% :- use_module(library(system), [datime/1]). +%% format_date(Out) :- +%% datime(datime(Year,Month,Day,Hour,Min,Sec)), +%% format(Out, ' Date: ~d-~d-~d ~d:~d:~d~n~n', [Day,Month,Year,Hour,Min,Sec]). +%% SICStus end + + + + /******************************* + * MESSAGES * + *******************************/ + + +:- multifile + prolog:message/3. + +prolog:message(chr(start(File))) --> + { file_base_name(File, Base) + }, + [ 'Translating CHR file ~w'-[Base] ]. +prolog:message(chr(end(_From, To))) --> + { file_base_name(To, Base) + }, + [ 'Written translation to ~w'-[Base] ]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +read_chr_file_to_terms(Spec, Terms) :- + chr_absolute_file_name(Spec, [ access(read) ], Path), + open(Path, read, Fd, []), + read_chr_stream_to_terms(Fd, Terms), + close(Fd). + +read_chr_stream_to_terms(Fd, Terms) :- + chr_local_only_read_term(Fd, C0, [ module(chr) ]), + read_chr_stream_to_terms(C0, Fd, Terms). + +read_chr_stream_to_terms(end_of_file, _, []) :- !. +read_chr_stream_to_terms(C, Fd, [C|T]) :- + ( ground(C), + C = (:- op(Priority,Type,Name)) -> + op(Priority,Type,Name) + ; + true + ), + chr_local_only_read_term(Fd, C2, [module(chr)]), + read_chr_stream_to_terms(C2, Fd, T). + + + + +%% SWI begin +chr_local_only_read_term(A,B,C) :- read_term(A,B,C). +chr_absolute_file_name(A,B,C) :- absolute_file_name(A,B,C). +%% SWI end + +%% SICStus begin +%% chr_local_only_read_term(A,B,_) :- read_term(A,B,[]). +%% chr_absolute_file_name(A,B,C) :- absolute_file_name(A,C,B). +%% SICStus end diff --git a/packages/chr/chr_test.pl b/packages/chr/chr_test.pl new file mode 100644 index 000000000..228d62568 --- /dev/null +++ b/packages/chr/chr_test.pl @@ -0,0 +1,170 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 2005,2006, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- asserta(user:file_search_path(chr, '.')). +:- asserta(user:file_search_path(library, '.')). +:- use_module(library(chr)). +%% :- use_module(chr). % == library(chr) + +:- set_prolog_flag(optimise, true). +%:- set_prolog_flag(trace_gc, true). + +:- format('CHR test suite. To run all tests run ?- test.~n~n', []). + + /******************************* + * SCRIPTS * + *******************************/ + + +:- dynamic + script_dir/1. + +set_script_dir :- + script_dir(_), !. +set_script_dir :- + find_script_dir(Dir), + assert(script_dir(Dir)). + +find_script_dir(Dir) :- + prolog_load_context(file, File), + follow_links(File, RealFile), + file_directory_name(RealFile, Dir). + +follow_links(File, RealFile) :- + read_link(File, _, RealFile), !. +follow_links(File, File). + + +:- set_script_dir. + +run_test_script(Script) :- + file_base_name(Script, Base), + file_name_extension(Pred, _, Base), + format(' ~w~n',[Script]), + load_files(Script, []), %[silent(true)]), + Pred. + +run_test_scripts(Directory) :- + ( script_dir(ScriptDir), + concat_atom([ScriptDir, /, Directory], Dir), + exists_directory(Dir) + -> true + ; Dir = Directory + ), + atom_concat(Dir, '/*.chr', Pattern), + expand_file_name(Pattern, Files), + file_base_name(Dir, BaseDir), + format('Running scripts from ~w ', [BaseDir]), flush_output, + run_scripts(Files), + format(' done~n'). + +run_scripts([]). +run_scripts([H|T]) :- + ( catch(run_test_script(H), Except, true) + -> ( var(Except) + -> put(.), flush_output + ; Except = blocked(Reason) + -> assert(blocked(H, Reason)), + put(!), flush_output + ; script_failed(H, Except) + ) + ; script_failed(H, fail) + ), + run_scripts(T). + +script_failed(File, fail) :- + format('~NScript ~w failed~n', [File]), + assert(failed(script(File))). +script_failed(File, Except) :- + message_to_string(Except, Error), + format('~NScript ~w failed: ~w~n', [File, Error]), + assert(failed(script(File))). + + + /******************************* + * TEST MAIN-LOOP * + *******************************/ + +testdir('Tests'). + +:- dynamic + failed/1, + blocked/2. + +test :- + retractall(failed(_)), + retractall(blocked(_,_)), + scripts, + report_blocked, + report_failed. + +scripts :- + forall(testdir(Dir), run_test_scripts(Dir)). + + +report_blocked :- + findall(Head-Reason, blocked(Head, Reason), L), + ( L \== [] + -> format('~nThe following tests are blocked:~n', []), + ( member(Head-Reason, L), + format(' ~p~t~40|~w~n', [Head, Reason]), + fail + ; true + ) + ; true + ). +report_failed :- + findall(X, failed(X), L), + length(L, Len), + ( Len > 0 + -> format('~n*** ~w tests failed ***~n', [Len]), + fail + ; format('~nAll tests passed~n', []) + ). + +test_failed(R, Except) :- + clause(Head, _, R), + functor(Head, Name, 1), + arg(1, Head, TestName), + clause_property(R, line_count(Line)), + clause_property(R, file(File)), + ( Except == fail + -> format('~N~w:~d: Test ~w(~w) failed~n', + [File, Line, Name, TestName]) + ; message_to_string(Except, Error), + format('~N~w:~d: Test ~w(~w):~n~t~8|ERROR: ~w~n', + [File, Line, Name, TestName, Error]) + ), + assert(failed(Head)). + +blocked(Reason) :- + throw(blocked(Reason)). + diff --git a/packages/chr/chr_translate.chr b/packages/chr/chr_translate.chr new file mode 100644 index 000000000..6a311f879 --- /dev/null +++ b/packages/chr/chr_translate.chr @@ -0,0 +1,11455 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% ____ _ _ ____ ____ _ _ +%% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __ +%% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__| +%% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ | +%% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_| +%% |_| +%% +%% hProlog CHR compiler: +%% +%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be +%% +%% * based on the SICStus CHR compilation by Christian Holzbaur +%% +%% First working version: 6 June 2003 +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% TODO {{{ +%% +%% URGENTLY TODO +%% +%% * add mode checking to debug mode +%% * add groundness info to a.i.-based observation analysis +%% * proper fd/index analysis +%% * re-add generation checking +%% * untangle CHR-level and target source-level generation & optimization +%% +%% AGGRESSIVE OPTIMISATION IDEAS +%% +%% * analyze history usage to determine whether/when +%% cheaper suspension is possible: +%% don't use history when all partners are passive and self never triggers +%% * store constraint unconditionally for unconditional propagation rule, +%% if first, i.e. without checking history and set trigger cont to next occ +%% * get rid of suspension passing for never triggered constraints, +%% up to allocation occurrence +%% * get rid of call indirection for never triggered constraints +%% up to first allocation occurrence. +%% * get rid of unnecessary indirection if last active occurrence +%% before unconditional removal is head2, e.g. +%% a \ b <=> true. +%% a <=> true. +%% * Eliminate last clause of never stored constraint, if its body +%% is fail, e.g. +%% a ... +%% a <=> fail. +%% * Specialize lookup operations and indexes for functional dependencies. +%% +%% MORE TODO +%% +%% * map A \ B <=> true | true rules +%% onto efficient code that empties the constraint stores of B +%% in O(1) time for ground constraints where A and B do not share +%% any variables +%% * ground matching seems to be not optimized for compound terms +%% in case of simpagation_head2 and propagation occurrences +%% * analysis for storage delaying (see primes for case) +%% * internal constraints declaration + analyses? +%% * Do not store in global variable store if not necessary +%% NOTE: affects show_store/1 +%% * var_assoc multi-level store: variable - ground +%% * Do not maintain/check unnecessary propagation history +%% for reasons of anti-monotony +%% * Strengthen storage analysis for propagation rules +%% reason about bodies of rules only containing constraints +%% -> fixpoint with observation analysis +%% * instantiation declarations +%% COMPOUND (bound to nonvar) +%% avoid nonvar tests +%% +%% * make difference between cheap guards for reordering +%% and non-binding guards for lock removal +%% * fd -> once/[] transformation for propagation +%% * cheap guards interleaved with head retrieval + faster +%% via-retrieval + non-empty checking for propagation rules +%% redo for simpagation_head2 prelude +%% * intelligent backtracking for simplification/simpagation rule +%% generator_1(X),'_$savecp'(CP_1), +%% ... +%% if( ( +%% generator_n(Y), +%% test(X,Y) +%% ), +%% true, +%% ('_$cutto'(CP_1), fail) +%% ), +%% ... +%% +%% or recently developped cascading-supported approach +%% * intelligent backtracking for propagation rule +%% use additional boolean argument for each possible smart backtracking +%% when boolean at end of list true -> no smart backtracking +%% false -> smart backtracking +%% only works for rules with at least 3 constraints in the head +%% * (set semantics + functional dependency) declaration + resolution +%% }}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- module(chr_translate, + [ chr_translate/2 % +Decls, -TranslatedDecls + , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls + ]). +%% SWI begin {{{ +:- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]). +:- use_module(library(ordsets)). +:- use_module(library(aggregate)). +:- use_module(library(apply_macros)). +:- use_module(library(occurs)). +:- use_module(library(assoc)). +:- use_module(library(dialect/hprolog)). +%% SWI end }}} + +% imports and operators {{{ +:- use_module(pairlist). +:- use_module(a_star). +:- use_module(listmap). +:- use_module(clean_code). +:- use_module(builtins). +:- use_module(find). +:- use_module(binomialheap). +:- use_module(guard_entailment). +:- use_module(chr_compiler_options). +:- use_module(chr_compiler_utility). +:- use_module(chr_compiler_errors). +:- include(chr_op). +:- op(1150, fx, chr_type). +:- op(1150, fx, chr_declaration). +:- op(1130, xfx, --->). +:- op(980, fx, (+)). +:- op(980, fx, (-)). +:- op(980, fx, (?)). +:- op(1150, fx, constraints). +:- op(1150, fx, chr_constraint). +% }}} + +:- chr_option(debug,off). +:- chr_option(optimize,full). +:- chr_option(check_guard_bindings,off). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Type Declarations {{{ +:- chr_type list(T) ---> [] ; [T|list(T)]. + +:- chr_type list == list(any). + +:- chr_type mode ---> (+) ; (-) ; (?). + +:- chr_type maybe(T) ---> yes(T) ; no. + +:- chr_type constraint ---> any / any. + +:- chr_type module_name == any. + +:- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb). +:- chr_type rule ---> rule(list(any),list(any),goal,goal). +:- chr_type idspair ---> ids(list(id),list(id)). + +:- chr_type pragma_type ---> passive(id) + ; mpassive(list(id)) + ; already_in_heads + ; already_in_heads(id) + ; no_history + ; history(history_name,list(id)). +:- chr_type history_name== any. + +:- chr_type rule_name == any. +:- chr_type rule_nb == natural. +:- chr_type id == natural. +:- chr_type occurrence == int. + +:- chr_type goal == any. + +:- chr_type store_type ---> default + ; multi_store(list(store_type)) + ; multi_hash(list(list(int))) + ; multi_inthash(list(list(int))) + ; global_singleton + ; global_ground + % EXPERIMENTAL STORES + ; atomic_constants(list(int),list(any),coverage) + ; ground_constants(list(int),list(any),coverage) + ; var_assoc_store(int,list(int)) + ; identifier_store(int) + ; type_indexed_identifier_store(int,any). +:- chr_type coverage ---> complete ; incomplete. +% }}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%------------------------------------------------------------------------------% +:- chr_constraint chr_source_file/1. +:- chr_option(mode,chr_source_file(+)). +:- chr_option(type_declaration,chr_source_file(module_name)). +%------------------------------------------------------------------------------% +chr_source_file(_) \ chr_source_file(_) <=> true. + +%------------------------------------------------------------------------------% +:- chr_constraint get_chr_source_file/1. +:- chr_option(mode,get_chr_source_file(-)). +:- chr_option(type_declaration,get_chr_source_file(module_name)). +%------------------------------------------------------------------------------% +chr_source_file(Mod) \ get_chr_source_file(Query) + <=> Query = Mod . +get_chr_source_file(Query) + <=> Query = user. + + +%------------------------------------------------------------------------------% +:- chr_constraint target_module/1. +:- chr_option(mode,target_module(+)). +:- chr_option(type_declaration,target_module(module_name)). +%------------------------------------------------------------------------------% +target_module(_) \ target_module(_) <=> true. + +%------------------------------------------------------------------------------% +:- chr_constraint get_target_module/1. +:- chr_option(mode,get_target_module(-)). +:- chr_option(type_declaration,get_target_module(module_name)). +%------------------------------------------------------------------------------% +target_module(Mod) \ get_target_module(Query) + <=> Query = Mod . +get_target_module(Query) + <=> Query = user. + +%------------------------------------------------------------------------------% +:- chr_constraint line_number/2. +:- chr_option(mode,line_number(+,+)). +:- chr_option(type_declaration,line_number(rule_nb,int)). +%------------------------------------------------------------------------------% +line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true. + +%------------------------------------------------------------------------------% +:- chr_constraint get_line_number/2. +:- chr_option(mode,get_line_number(+,-)). +:- chr_option(type_declaration,get_line_number(rule_nb,int)). +%------------------------------------------------------------------------------% +line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb. +get_line_number(RuleNb,Q) <=> Q = 0. % no line number available + +:- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule +:- chr_option(mode,indexed_argument(+,+)). +:- chr_option(type_declaration,indexed_argument(constraint,int)). + +:- chr_constraint is_indexed_argument/2. +:- chr_option(mode,is_indexed_argument(+,+)). +:- chr_option(type_declaration,is_indexed_argument(constraint,int)). + +:- chr_constraint constraint_mode/2. +:- chr_option(mode,constraint_mode(+,+)). +:- chr_option(type_declaration,constraint_mode(constraint,list(mode))). + +:- chr_constraint get_constraint_mode/2. +:- chr_option(mode,get_constraint_mode(+,-)). +:- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))). + +:- chr_constraint may_trigger/1. +:- chr_option(mode,may_trigger(+)). +:- chr_option(type_declaration,may_trigger(constraint)). + +:- chr_constraint only_ground_indexed_arguments/1. +:- chr_option(mode,only_ground_indexed_arguments(+)). +:- chr_option(type_declaration,only_ground_indexed_arguments(constraint)). + +:- chr_constraint none_suspended_on_variables/0. + +:- chr_constraint are_none_suspended_on_variables/0. + +:- chr_constraint store_type/2. +:- chr_option(mode,store_type(+,+)). +:- chr_option(type_declaration,store_type(constraint,store_type)). + +:- chr_constraint get_store_type/2. +:- chr_option(mode,get_store_type(+,?)). +:- chr_option(type_declaration,get_store_type(constraint,store_type)). + +:- chr_constraint update_store_type/2. +:- chr_option(mode,update_store_type(+,+)). +:- chr_option(type_declaration,update_store_type(constraint,store_type)). + +:- chr_constraint actual_store_types/2. +:- chr_option(mode,actual_store_types(+,+)). +:- chr_option(type_declaration,actual_store_types(constraint,list(store_type))). + +:- chr_constraint assumed_store_type/2. +:- chr_option(mode,assumed_store_type(+,+)). +:- chr_option(type_declaration,assumed_store_type(constraint,store_type)). + +:- chr_constraint validate_store_type_assumption/1. +:- chr_option(mode,validate_store_type_assumption(+)). +:- chr_option(type_declaration,validate_store_type_assumption(constraint)). + +:- chr_constraint rule_count/1. +:- chr_option(mode,rule_count(+)). +:- chr_option(type_declaration,rule_count(natural)). + +:- chr_constraint inc_rule_count/1. +:- chr_option(mode,inc_rule_count(-)). +:- chr_option(type_declaration,inc_rule_count(natural)). + +rule_count(_) \ rule_count(_) + <=> true. +rule_count(C), inc_rule_count(NC) + <=> NC is C + 1, rule_count(NC). +inc_rule_count(NC) + <=> NC = 1, rule_count(NC). + +:- chr_constraint passive/2. +:- chr_option(mode,passive(+,+)). +:- chr_option(type_declaration,passive(rule_nb,id)). + +:- chr_constraint is_passive/2. +:- chr_option(mode,is_passive(+,+)). +:- chr_option(type_declaration,is_passive(rule_nb,id)). + +:- chr_constraint any_passive_head/1. +:- chr_option(mode,any_passive_head(+)). + +:- chr_constraint new_occurrence/4. +:- chr_option(mode,new_occurrence(+,+,+,+)). + +:- chr_constraint occurrence/5. +:- chr_option(mode,occurrence(+,+,+,+,+)). + +:- chr_type occurrence_type ---> simplification ; propagation. +:- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)). + +:- chr_constraint get_occurrence/4. +:- chr_option(mode,get_occurrence(+,+,-,-)). + +:- chr_constraint get_occurrence/5. +:- chr_option(mode,get_occurrence(+,+,-,-,-)). + +:- chr_constraint get_occurrence_from_id/4. +:- chr_option(mode,get_occurrence_from_id(+,-,+,+)). + +:- chr_constraint max_occurrence/2. +:- chr_option(mode,max_occurrence(+,+)). + +:- chr_constraint get_max_occurrence/2. +:- chr_option(mode,get_max_occurrence(+,-)). + +:- chr_constraint allocation_occurrence/2. +:- chr_option(mode,allocation_occurrence(+,+)). + +:- chr_constraint get_allocation_occurrence/2. +:- chr_option(mode,get_allocation_occurrence(+,-)). + +:- chr_constraint rule/2. +:- chr_option(mode,rule(+,+)). +:- chr_option(type_declaration,rule(rule_nb,pragma_rule)). + +:- chr_constraint get_rule/2. +:- chr_option(mode,get_rule(+,-)). +:- chr_option(type_declaration,get_rule(int,pragma_rule)). + +:- chr_constraint least_occurrence/2. +:- chr_option(mode,least_occurrence(+,+)). +:- chr_option(type_declaration,least_occurrence(any,list)). + +:- chr_constraint is_least_occurrence/1. +:- chr_option(mode,is_least_occurrence(+)). + + +indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true. +indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true. +is_indexed_argument(_,_) <=> fail. + +%%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true. +constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=> + Q = Mode. +get_constraint_mode(FA,Q) <=> + FA = _ / N, + replicate(N,(?),Q). + +%%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail. +constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=> + nth1(I,Mode,M), + M \== (+) | + is_stored(FA). +may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered + +constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA) + <=> + nth1(I,Mode,M), + M \== (+) + | + fail. +only_ground_indexed_arguments(_) <=> + true. + +none_suspended_on_variables \ none_suspended_on_variables <=> true. +none_suspended_on_variables \ are_none_suspended_on_variables <=> true. +are_none_suspended_on_variables <=> fail. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% STORE TYPES +% +% The functionality for inspecting and deciding on the different types of constraint +% store / indexes for constraints. + +store_type(FA,StoreType) + ==> chr_pp_flag(verbose,on) + | + format('The indexes for ~w are:\n',[FA]), + format_storetype(StoreType). + % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]). + +format_storetype(multi_store(StoreTypes)) :- !, + maplist(format_storetype,StoreTypes). +format_storetype(atomic_constants(Index,Constants,_)) :- + format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]). +format_storetype(ground_constants(Index,Constants,_)) :- + format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]). +format_storetype(StoreType) :- + format('\t* ~w\n',[StoreType]). + + +% 1. Inspection +% ~~~~~~~~~~~~~ +% +% + +get_store_type_normal @ +store_type(FA,Store) \ get_store_type(FA,Query) + <=> Query = Store. + +get_store_type_assumed @ +assumed_store_type(FA,Store) \ get_store_type(FA,Query) + <=> Query = Store. + +get_store_type_default @ +get_store_type(_,Query) + <=> Query = default. + +% 2. Store type registration +% ~~~~~~~~~~~~~~~~~~~~~~~~~~ + +actual_store_types(C,STs) \ update_store_type(C,ST) + <=> memberchk(ST,STs) | true. +update_store_type(C,ST), actual_store_types(C,STs) + <=> + actual_store_types(C,[ST|STs]). +update_store_type(C,ST) + <=> + actual_store_types(C,[ST]). + +% 3. Final decision on store types +% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys) + <=> + true % chr_pp_flag(experiment,on) + | + selectchk(multi_hash([Index]),STs,STs0), + Index = [IndexPos], + ( get_constraint_arg_type(C,IndexPos,Type), + enumerated_atomic_type(Type,Atoms) -> + /* use the type constants rather than the collected keys */ + Constants = Atoms, + Completeness = complete + ; + Constants = Keys, + Completeness = incomplete + ), + actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]). +validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0) + <=> + true % chr_pp_flag(experiment,on) + | + ( Index = [IndexPos], + get_constraint_arg_type(C,IndexPos,Type), + Type = chr_enum(Constants) + -> + Completeness = complete + ; + Constants = Constants0, + Completeness = incomplete + ), + selectchk(multi_hash([Index]),STs,STs0), + actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]). + +get_constraint_arg_type(C,Pos,Type) :- + get_constraint_type(C,Types), + nth1(Pos,Types,Type0), + unalias_type(Type0,Type). + +validate_store_type_assumption(C) \ actual_store_types(C,STs) + <=> + % chr_pp_flag(experiment,on), + memberchk(multi_hash([[Index]]),STs), + get_constraint_type(C,Types), + nth1(Index,Types,Type), + enumerated_atomic_type(Type,Atoms) + | + selectchk(multi_hash([[Index]]),STs,STs0), + actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]). +validate_store_type_assumption(C) \ actual_store_types(C,STs) + <=> + memberchk(multi_hash([[Index]]),STs), + get_constraint_arg_type(C,Index,Type), + Type = chr_enum(Constants) + | + selectchk(multi_hash([[Index]]),STs,STs0), + actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]). +validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption + <=> + ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) -> + Stores = [global_ground|STs] + ; + Stores = STs + ), + store_type(C,multi_store(Stores)). +validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption + <=> + store_type(C,multi_store(STs)). +validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode + <=> + chr_pp_flag(debugable,on) + | + store_type(C,default). +validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint + <=> store_type(C,global_ground). +validate_store_type_assumption(C) + <=> true. + +partial_store(ground_constants(_,_,incomplete)). +partial_store(atomic_constants(_,_,incomplete)). + +%%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +passive(R,ID) \ passive(R,ID) <=> true. + +passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true. +is_passive(_,_) <=> fail. + +passive(RuleNb,_) \ any_passive_head(RuleNb) + <=> true. +any_passive_head(_) + <=> fail. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +max_occurrence(C,N) \ max_occurrence(C,M) + <=> N >= M | true. + +max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=> + NO is MO + 1, + occurrence(C,NO,RuleNb,ID,Type), + max_occurrence(C,NO). +new_occurrence(C,RuleNb,ID,_) <=> + chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]). + +max_occurrence(C,MON) \ get_max_occurrence(C,Q) + <=> Q = MON. +get_max_occurrence(C,Q) + <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]). + +occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID) + <=> Rule = QRule, ID = QID. +get_occurrence(C,O,_,_) + <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]). + +occurrence(C,ON,Rule,ID,OccType) \ get_occurrence(C,ON,QRule,QID,QOccType) + <=> Rule = QRule, ID = QID, OccType = QOccType. +get_occurrence(C,O,_,_,_) + <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]). + +occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID) + <=> QC = C, QON = ON. +get_occurrence_from_id(C,O,_,_) + <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Late allocation + +late_allocation_analysis(Cs) :- + ( chr_pp_flag(late_allocation,on) -> + maplist(late_allocation, Cs) + ; + true + ). + +late_allocation(C) :- late_allocation(C,0). +late_allocation(C,O) :- allocation_occurrence(C,O), !. +late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO). + +% A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0). + +rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==> + \+ is_passive(RuleNb,Id), + Type == propagation, + ( stored_in_guard_before_next_kept_occurrence(C,O) -> + true + ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule + is_observed(C,O) + ; is_least_occurrence(RuleNb) -> % propagation rule + is_observed(C,O) + ; + true + ). + +stored_in_guard_before_next_kept_occurrence(C,O) :- + chr_pp_flag(store_in_guards, on), + NO is O + 1, + stored_in_guard_lookahead(C,NO). + +:- chr_constraint stored_in_guard_lookahead/2. +:- chr_option(mode, stored_in_guard_lookahead(+,+)). + +occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=> + NO is O + 1, stored_in_guard_lookahead(C,NO). +occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=> + Type == simplification, + ( is_stored_in_guard(C,RuleNb) -> + true + ; + NO is O + 1, stored_in_guard_lookahead(C,NO) + ). +stored_in_guard_lookahead(_,_) <=> fail. + + +rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO) + \ least_occurrence(RuleNb,[ID|IDs]) + <=> AO >= O, \+ may_trigger(C) | + least_occurrence(RuleNb,IDs). +rule(RuleNb,Rule), passive(RuleNb,ID) + \ least_occurrence(RuleNb,[ID|IDs]) + <=> least_occurrence(RuleNb,IDs). + +rule(RuleNb,Rule) + ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) | + least_occurrence(RuleNb,IDs). + +least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb) + <=> true. +is_least_occurrence(_) + <=> fail. + +allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q) + <=> Q = O. +get_allocation_occurrence(_,Q) + <=> chr_pp_flag(late_allocation,off), Q=0. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +rule(RuleNb,Rule) \ get_rule(RuleNb,Q) + <=> Q = Rule. +get_rule(_,_) + <=> fail. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Default store constraint index assignment. + +:- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex) +:- chr_option(mode,constraint_index(+,+)). +:- chr_option(type_declaration,constraint_index(constraint,int)). + +:- chr_constraint get_constraint_index/2. +:- chr_option(mode,get_constraint_index(+,-)). +:- chr_option(type_declaration,get_constraint_index(constraint,int)). + +:- chr_constraint get_indexed_constraint/2. +:- chr_option(mode,get_indexed_constraint(+,-)). +:- chr_option(type_declaration,get_indexed_constraint(int,constraint)). + +:- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex) +:- chr_option(mode,max_constraint_index(+)). +:- chr_option(type_declaration,max_constraint_index(int)). + +:- chr_constraint get_max_constraint_index/1. +:- chr_option(mode,get_max_constraint_index(-)). +:- chr_option(type_declaration,get_max_constraint_index(int)). + +constraint_index(C,Index) \ get_constraint_index(C,Query) + <=> Query = Index. +get_constraint_index(C,Query) + <=> fail. + +constraint_index(C,Index) \ get_indexed_constraint(Index,Q) + <=> Q = C. +get_indexed_constraint(Index,Q) + <=> fail. + +max_constraint_index(Index) \ get_max_constraint_index(Query) + <=> Query = Index. +get_max_constraint_index(Query) + <=> Query = 0. + +set_constraint_indices(Constraints) :- + set_constraint_indices(Constraints,1). +set_constraint_indices([],M) :- + N is M - 1, + max_constraint_index(N). +set_constraint_indices([C|Cs],N) :- + ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default) + ; get_store_type(C,var_assoc_store(_,_))) -> + constraint_index(C,N), + M is N + 1, + set_constraint_indices(Cs,M) + ; + set_constraint_indices(Cs,N) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Identifier Indexes + +:- chr_constraint identifier_size/1. +:- chr_option(mode,identifier_size(+)). +:- chr_option(type_declaration,identifier_size(natural)). + +identifier_size(_) \ identifier_size(_) + <=> + true. + +:- chr_constraint get_identifier_size/1. +:- chr_option(mode,get_identifier_size(-)). +:- chr_option(type_declaration,get_identifier_size(natural)). + +identifier_size(Size) \ get_identifier_size(Q) + <=> + Q = Size. + +get_identifier_size(Q) + <=> + Q = 1. + +:- chr_constraint identifier_index/3. +:- chr_option(mode,identifier_index(+,+,+)). +:- chr_option(type_declaration,identifier_index(constraint,natural,natural)). + +identifier_index(C,I,_) \ identifier_index(C,I,_) + <=> + true. + +:- chr_constraint get_identifier_index/3. +:- chr_option(mode,get_identifier_index(+,+,-)). +:- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)). + +identifier_index(C,I,II) \ get_identifier_index(C,I,Q) + <=> + Q = II. +identifier_size(Size), get_identifier_index(C,I,Q) + <=> + NSize is Size + 1, + identifier_index(C,I,NSize), + identifier_size(NSize), + Q = NSize. +get_identifier_index(C,I,Q) + <=> + identifier_index(C,I,2), + identifier_size(2), + Q = 2. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Type Indexed Identifier Indexes + +:- chr_constraint type_indexed_identifier_size/2. +:- chr_option(mode,type_indexed_identifier_size(+,+)). +:- chr_option(type_declaration,type_indexed_identifier_size(any,natural)). + +type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_) + <=> + true. + +:- chr_constraint get_type_indexed_identifier_size/2. +:- chr_option(mode,get_type_indexed_identifier_size(+,-)). +:- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)). + +type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q) + <=> + Q = Size. + +get_type_indexed_identifier_size(IndexType,Q) + <=> + Q = 1. + +:- chr_constraint type_indexed_identifier_index/4. +:- chr_option(mode,type_indexed_identifier_index(+,+,+,+)). +:- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)). + +type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_) + <=> + true. + +:- chr_constraint get_type_indexed_identifier_index/4. +:- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)). +:- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)). + +type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q) + <=> + Q = II. +type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q) + <=> + NSize is Size + 1, + type_indexed_identifier_index(IndexType,C,I,NSize), + type_indexed_identifier_size(IndexType,NSize), + Q = NSize. +get_type_indexed_identifier_index(IndexType,C,I,Q) + <=> + type_indexed_identifier_index(IndexType,C,I,2), + type_indexed_identifier_size(IndexType,2), + Q = 2. + +type_indexed_identifier_structure(IndexType,Structure) :- + type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor), + get_type_indexed_identifier_size(IndexType,Arity), + functor(Structure,Functor,Arity). +type_indexed_identifier_name(IndexType,Prefix,Name) :- + ( atom(IndexType) -> + IndexTypeName = IndexType + ; + term_to_atom(IndexType,IndexTypeName) + ), + atom_concat_list([Prefix,'_',IndexTypeName],Name). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Translation + +chr_translate(Declarations,NewDeclarations) :- + chr_translate_line_info(Declarations,'bootstrap',NewDeclarations). + +chr_translate_line_info(Declarations0,File,NewDeclarations) :- + chr_banner, + restart_after_flattening(Declarations0,Declarations), + init_chr_pp_flags, + chr_source_file(File), + /* sort out the interesting stuff from the input */ + partition_clauses(Declarations,Constraints0,Rules0,OtherClauses), + chr_compiler_options:sanity_check, + + dump_code(Declarations), + + check_declared_constraints(Constraints0), + generate_show_constraint(Constraints0,Constraints,Rules0,Rules1), + add_constraints(Constraints), + add_rules(Rules1), + generate_never_stored_rules(Constraints,NewRules), + add_rules(NewRules), + append(Rules1,NewRules,Rules), + chr_analysis(Rules,Constraints,Declarations), + time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)), + time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)), + phase_end(validate_store_type_assumptions), + used_states_known, + time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used + insert_declarations(OtherClauses, Clauses0), + chr_module_declaration(CHRModuleDeclaration), + append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses), + clean_clauses(StuffyGeneratedClauses,GeneratedClauses), + append([Clauses0,GeneratedClauses], NewDeclarations), + dump_code(NewDeclarations), + !. /* cut choicepoint of restart_after_flattening */ + +chr_analysis(Rules,Constraints,Declarations) :- + maplist(pragma_rule_to_ast_rule,Rules,AstRules), + check_rules(Rules,AstRules,Constraints), + time('type checking',chr_translate:static_type_check(Rules,AstRules)), + /* constants */ + collect_constants(Rules,AstRules,Constraints,Declarations), + add_occurrences(Rules,AstRules), + time('functional dependency',chr_translate:functional_dependency_analysis(Rules)), + time('set semantics',chr_translate:set_semantics_rules(Rules)), + time('symmetry analysis',chr_translate:symmetry_analysis(Rules)), + time('guard simplification',chr_translate:guard_simplification), + time('late storage',chr_translate:storage_analysis(Constraints)), + time('observation',chr_translate:observation_analysis(Constraints)), + time('ai observation',chr_translate:ai_observation_analysis(Constraints)), + time('late allocation',chr_translate:late_allocation_analysis(Constraints)), + partial_wake_analysis, + time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)), + time('default constraint indices',chr_translate:set_constraint_indices(Constraints)), + time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)), + time('continuation analysis',chr_translate:continuation_analysis(Constraints)). + +store_management_preds(Constraints,Clauses) :- + generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses), + generate_attr_unify_hook(AttrUnifyHookClauses), + generate_attach_increment(AttachIncrementClauses), + generate_extra_clauses(Constraints,ExtraClauses), + generate_insert_delete_constraints(Constraints,DeleteClauses), + generate_attach_code(Constraints,StoreClauses), + generate_counter_code(CounterClauses), + generate_dynamic_type_check_clauses(TypeCheckClauses), + append([AttachAConstraintClauses + ,AttachIncrementClauses + ,AttrUnifyHookClauses + ,ExtraClauses + ,DeleteClauses + ,StoreClauses + ,CounterClauses + ,TypeCheckClauses + ] + ,Clauses). + + +insert_declarations(Clauses0, Clauses) :- + findall((:- use_module(chr(Module))),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls), + append(Clauses0, [(:- use_module(chr(chr_runtime)))|Decls], Clauses). + +auxiliary_module(chr_hashtable_store). +auxiliary_module(chr_integertable_store). +auxiliary_module(chr_assoc_store). + +generate_counter_code(Clauses) :- + ( chr_pp_flag(store_counter,on) -> + Clauses = [ + ('$counter_init'(N1) :- nb_setval(N1,0)) , + ('$counter'(N2,X1) :- nb_getval(N2,X1)), + ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)), + (:- '$counter_init'('$insert_counter')), + (:- '$counter_init'('$delete_counter')), + ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')), + ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')), + ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D)) + ] + ; + Clauses = [] + ). + +% for systems with multifile declaration +chr_module_declaration(CHRModuleDeclaration) :- + get_target_module(Mod), + ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) -> + CHRModuleDeclaration = [ + (:- multifile chr:'$chr_module'/1), + chr:'$chr_module'(Mod) + ] + ; + CHRModuleDeclaration = [] + ). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Partitioning of clauses into constraint declarations, chr rules and other +%% clauses + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +partition_clauses([],[],[],[]). +partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :- + ( parse_rule(Clause,Rule) -> + ConstraintDeclarations = RestConstraintDeclarations, + Rules = [Rule|RestRules], + OtherClauses = RestOtherClauses + ; is_declaration(Clause,ConstraintDeclaration) -> + append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations), + Rules = RestRules, + OtherClauses = RestOtherClauses + ; is_module_declaration(Clause,Mod) -> + target_module(Mod), + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = [Clause|RestOtherClauses] + ; is_type_definition(Clause) -> + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = RestOtherClauses + ; is_chr_declaration(Clause) -> + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = RestOtherClauses + ; Clause = (handler _) -> + chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]), + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = RestOtherClauses + ; Clause = (rules _) -> + chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]), + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = RestOtherClauses + ; Clause = option(OptionName,OptionValue) -> + chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]), + handle_option(OptionName,OptionValue), + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = RestOtherClauses + ; Clause = (:-chr_option(OptionName,OptionValue)) -> + handle_option(OptionName,OptionValue), + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = RestOtherClauses + ; Clause = ('$chr_compiled_with_version'(_)) -> + ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses] + ; ConstraintDeclarations = RestConstraintDeclarations, + Rules = RestRules, + OtherClauses = [Clause|RestOtherClauses] + ), + partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses). + +'$chr_compiled_with_version'(2). + +is_declaration(D, Constraints) :- %% constraint declaration + ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) -> + conj2list(Cs,Constraints0) + ; + ( D = (:- Decl) -> + Decl =.. [constraints,Cs] + ; + D =.. [constraints,Cs] + ), + conj2list(Cs,Constraints0), + chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs]) + ), + extract_type_mode(Constraints0,Constraints). + +extract_type_mode([],[]). +extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2). +extract_type_mode([C0|R],[ConstraintSymbol|R2]) :- + ( C0 = C # Annotation -> + functor(C,F,A), + extract_annotation(Annotation,F/A) + ; + C0 = C, + functor(C,F,A) + ), + ConstraintSymbol = F/A, + C =.. [_|Args], + extract_types_and_modes(Args,ArgTypes,ArgModes), + assert_constraint_type(ConstraintSymbol,ArgTypes), + constraint_mode(ConstraintSymbol,ArgModes), + extract_type_mode(R,R2). + +extract_annotation(stored,Symbol) :- + stored_assertion(Symbol). +extract_annotation(default(Goal),Symbol) :- + never_stored_default(Symbol,Goal). + +extract_types_and_modes([],[],[]). +extract_types_and_modes([X|R],[T|R2],[M|R3]) :- + extract_type_and_mode(X,T,M), + extract_types_and_modes(R,R2,R3). + +extract_type_and_mode(+(T),T,(+)) :- !. +extract_type_and_mode(?(T),T,(?)) :- !. +extract_type_and_mode(-(T),T,(-)) :- !. +extract_type_and_mode((+),any,(+)) :- !. +extract_type_and_mode((?),any,(?)) :- !. +extract_type_and_mode((-),any,(-)) :- !. +extract_type_and_mode(Illegal,_,_) :- + chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]). + +is_chr_declaration(Declaration) :- + Declaration = (:- chr_declaration Decl), + ( Decl = (Pattern ---> Information) -> + background_info(Pattern,Information) + ; Decl = Information -> + background_info([Information]) + ). +is_type_definition(Declaration) :- + is_type_definition(Declaration,Result), + assert_type_definition(Result). + +assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList). +assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name). + +is_type_definition(Declaration,Result) :- + ( Declaration = (:- TDef) -> + true + ; + Declaration = TDef + ), + TDef =.. [chr_type,TypeDef], + ( TypeDef = (Name ---> Def) -> + tdisj2list(Def,DefList), + Result = typedef(Name,DefList) + ; TypeDef = (Alias == Name) -> + Result = alias(Alias,Name) + ; + Result = typedef(TypeDef,[]), + chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration]) + ). + +%% tdisj2list(+Goal,-ListOfGoals) is det. +% +% no removal of fails, e.g. :- type bool ---> true ; fail. +tdisj2list(Conj,L) :- + tdisj2list(Conj,L,[]). + +tdisj2list(Conj,L,T) :- + Conj = (G1;G2), !, + tdisj2list(G1,L,T1), + tdisj2list(G2,T1,T). +tdisj2list(G,[G | T],T). + + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% parse_rule(+term,-pragma_rule) is semidet. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +parse_rule(RI,R) :- %% name @ rule + RI = (Name @ RI2), !, + rule(RI2,yes(Name),R). +parse_rule(RI,R) :- + rule(RI,no,R). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% parse_rule(+term,-pragma_rule) is semidet. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +rule(RI,Name,R) :- + RI = (RI2 pragma P), !, %% pragmas + ( var(P) -> + Ps = [_] % intercept variable + ; + conj2list(P,Ps) + ), + inc_rule_count(RuleCount), + R = pragma(R1,IDs,Ps,Name,RuleCount), + is_rule(RI2,R1,IDs,R). +rule(RI,Name,R) :- + inc_rule_count(RuleCount), + R = pragma(R1,IDs,[],Name,RuleCount), + is_rule(RI,R1,IDs,R). + +is_rule(RI,R,IDs,RC) :- %% propagation rule + RI = (H ==> B), !, + conj2list(H,Head2i), + get_ids(Head2i,IDs2,Head2,RC), + IDs = ids([],IDs2), + ( B = (G | RB) -> + R = rule([],Head2,G,RB) + ; + R = rule([],Head2,true,B) + ). +is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule + RI = (H <=> B), !, + ( B = (G | RB) -> + Guard = G, + Body = RB + ; Guard = true, + Body = B + ), + ( H = (H1 \ H2) -> + conj2list(H1,Head2i), + conj2list(H2,Head1i), + get_ids(Head2i,IDs2,Head2,0,N,RC), + get_ids(Head1i,IDs1,Head1,N,_,RC), + IDs = ids(IDs1,IDs2) + ; conj2list(H,Head1i), + Head2 = [], + get_ids(Head1i,IDs1,Head1,RC), + IDs = ids(IDs1,[]) + ), + R = rule(Head1,Head2,Guard,Body). + +get_ids(Cs,IDs,NCs,RC) :- + get_ids(Cs,IDs,NCs,0,_,RC). + +get_ids([],[],[],N,N,_). +get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :- + ( C = (NC # N1) -> + ( var(N1) -> + N1 = N + ; + check_direct_pragma(N1,N,RC) + ) + ; + NC = C + ), + M is N + 1, + get_ids(Cs,IDs,NCs, M,NN,RC). + +check_direct_pragma(passive,Id,PragmaRule) :- !, + PragmaRule = pragma(_,_,_,_,RuleNb), + passive(RuleNb,Id). +check_direct_pragma(Abbrev,Id,PragmaRule) :- + ( direct_pragma(FullPragma), + atom_concat(Abbrev,Remainder,FullPragma) -> + chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma]) + ; + chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[]) + ). + +direct_pragma(passive). + +is_module_declaration((:- module(Mod)),Mod). +is_module_declaration((:- module(Mod,_)),Mod). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Add constraints +add_constraints([]). +add_constraints([C|Cs]) :- + max_occurrence(C,0), + C = _/A, + length(Mode,A), + set_elems(Mode,?), + constraint_mode(C,Mode), + add_constraints(Cs). + +% Add rules +add_rules([]). +add_rules([Rule|Rules]) :- + Rule = pragma(_,_,_,_,RuleNb), + rule(RuleNb,Rule), + add_rules(Rules). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Some input verification: + +check_declared_constraints(Constraints) :- + tree_set_empty(Acc), + check_declared_constraints(Constraints,Acc). + +check_declared_constraints([],_). +check_declared_constraints([C|Cs],Acc) :- + ( tree_set_memberchk(C,Acc) -> + chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C]) + ; + true + ), + tree_set_add(Acc,C,NAcc), + check_declared_constraints(Cs,NAcc). + +%% - all constraints in heads are declared constraints +%% - all passive pragmas refer to actual head constraints + +check_rules(PragmaRules,AstRules,Decls) :- + maplist(check_rule(Decls),PragmaRules,AstRules). + +check_rule(Decls,PragmaRule,AstRule) :- + PragmaRule = pragma(_Rule,_IDs,Pragmas,_Name,_N), + check_ast_rule_indexing(AstRule,PragmaRule), + % check_rule_indexing(PragmaRule), + check_ast_trivial_propagation_rule(AstRule,PragmaRule), + % check_trivial_propagation_rule(PragmaRule), + check_ast_head_constraints(AstRule,Decls,PragmaRule), + % Rule = rule(H1,H2,_,_), + % check_head_constraints(H1,Decls,PragmaRule), + % check_head_constraints(H2,Decls,PragmaRule), + check_pragmas(Pragmas,PragmaRule). + +%------------------------------------------------------------------------------- +% Make all heads passive in trivial propagation rule +% ... ==> ... | true. +check_ast_trivial_propagation_rule(AstRule,PragmaRule) :- + AstRule = ast_rule(AstHead,_,_,AstBody,_), + ( AstHead = propagation(_), + AstBody == [] -> + chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]), + set_rule_passive(PragmaRule) + ; + true + ). + +set_rule_passive(PragmaRule) :- + PragmaRule = pragma(_Rule,_IDs,_Pragmas,_Name,RuleNb), + set_all_passive(RuleNb). + +check_trivial_propagation_rule(PragmaRule) :- + PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb), + ( Rule = rule([],_,_,true) -> + chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]), + set_all_passive(RuleNb) + ; + true + ). + +%------------------------------------------------------------------------------- +check_ast_head_constraints(ast_rule(AstHead,_,_,_,_),Decls,PragmaRule) :- + check_ast_head_constraints_(AstHead,Decls,PragmaRule). + +check_ast_head_constraints_(simplification(AstConstraints),Decls,PragmaRule) :- + maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints). +check_ast_head_constraints_(propagation(AstConstraints),Decls,PragmaRule) :- + maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints). +check_ast_head_constraints_(simpagation(AstConstraints1,AstConstraints2),Decls,PragmaRule) :- + maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints1), + maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints2). + +check_ast_head_constraint(Decls,PragmaRule,chr_constraint(Symbol,_,Constraint)) :- + ( memberchk(Symbol,Decls) -> + true + ; + chr_error(syntax(Constraint),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) + ). + +check_head_constraints([],_,_). +check_head_constraints([Constr|Rest],Decls,PragmaRule) :- + functor(Constr,F,A), + ( memberchk(F/A,Decls) -> + check_head_constraints(Rest,Decls,PragmaRule) + ; + chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) + ). +%------------------------------------------------------------------------------- + +check_pragmas([],_). +check_pragmas([Pragma|Pragmas],PragmaRule) :- + check_pragma(Pragma,PragmaRule), + check_pragmas(Pragmas,PragmaRule). + +check_pragma(Pragma,PragmaRule) :- + var(Pragma), !, + chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]). +check_pragma(passive(ID), PragmaRule) :- + !, + PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), + ( memberchk_eq(ID,IDs1) -> + true + ; memberchk_eq(ID,IDs2) -> + true + ; + chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)]) + ), + passive(RuleNb,ID). + +check_pragma(mpassive(IDs), PragmaRule) :- + !, + PragmaRule = pragma(_,_,_,_,RuleNb), + chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]), + maplist(passive(RuleNb),IDs). + +check_pragma(Pragma, PragmaRule) :- + Pragma = already_in_heads, + !, + chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]). + +check_pragma(Pragma, PragmaRule) :- + Pragma = already_in_head(_), + !, + chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]). + +check_pragma(Pragma, PragmaRule) :- + Pragma = no_history, + !, + chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]), + PragmaRule = pragma(_,_,_,_,N), + no_history(N). + +check_pragma(Pragma, PragmaRule) :- + Pragma = history(HistoryName,IDs), + !, + PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), + chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]), + ( IDs1 \== [] -> + chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[]) + ; \+ atom(HistoryName) -> + chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb]) + ; \+ is_set(IDs) -> + chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb]) + ; check_history_pragma_ids(IDs,IDs1,IDs2) -> + history(RuleNb,HistoryName,IDs) + ; + chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb]) + ). +check_pragma(Pragma,PragmaRule) :- + Pragma = line_number(LineNumber), + !, + PragmaRule = pragma(_,_,_,_,RuleNb), + line_number(RuleNb,LineNumber). + +check_history_pragma_ids([], _, _). +check_history_pragma_ids([ID|IDs],IDs1,IDs2) :- + ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ), + check_history_pragma_ids(IDs,IDs1,IDs2). + +check_pragma(Pragma,PragmaRule) :- + chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% no_history(+RuleNb) is det. +:- chr_constraint no_history/1. +:- chr_option(mode,no_history(+)). +:- chr_option(type_declaration,no_history(int)). + +%% has_no_history(+RuleNb) is semidet. +:- chr_constraint has_no_history/1. +:- chr_option(mode,has_no_history(+)). +:- chr_option(type_declaration,has_no_history(int)). + +no_history(RuleNb) \ has_no_history(RuleNb) <=> true. +has_no_history(_) <=> fail. + +:- chr_constraint history/3. +:- chr_option(mode,history(+,+,+)). +:- chr_option(type_declaration,history(any,any,list)). + +:- chr_constraint named_history/3. + +history(RuleNb,_,_), history(RuleNb,_,_) ==> + chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %' + +history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==> + length(IDs1,L1), length(IDs2,L2), + ( L1 \== L2 -> + chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name]) + ; + test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2) + ). + +test_named_history_id_pairs(_, [], _, []). +test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :- + test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2), + test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2). + +:- chr_constraint test_named_history_id_pair/4. +:- chr_option(mode,test_named_history_id_pair(+,+,+,+)). + +occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_) + \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true. +test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> + chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]). + +history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs. +named_history(_,_,_) <=> fail. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +format_rule(PragmaRule) :- + PragmaRule = pragma(_,_,_,MaybeName,RuleNumber), + ( MaybeName = yes(Name) -> + write('rule '), write(Name) + ; + write('rule number '), write(RuleNumber) + ), + get_line_number(RuleNumber,LineNumber), + write(' (line '), + write(LineNumber), + write(')'). + +check_ast_rule_indexing(AstRule,PragmaRule) :- + AstRule = ast_rule(AstHead,AstGuard,_,_,_), + tree_set_empty(EmptyVarSet), + ast_head_variables(AstHead,EmptyVarSet,VarSet), + ast_remove_anti_monotonic_guards(AstGuard,VarSet,MonotonicAstGuard), + ast_term_list_variables(MonotonicAstGuard,EmptyVarSet,GuardVarSet), + check_ast_head_indexing(AstHead,GuardVarSet), + % check_indexing(H1,NG-H2), + % check_indexing(H2,NG-H1), + % EXPERIMENT + ( chr_pp_flag(term_indexing,on) -> + PragmaRule = pragma(Rule,_,_,_,_), + Rule = rule(H1,H2,G,_), + term_variables(H1-H2,HeadVars), + remove_anti_monotonic_guards(G,HeadVars,NG), + term_variables(NG,GuardVariables), + append(H1,H2,Heads), + check_specs_indexing(Heads,GuardVariables,Specs) + ; + true + ). + +check_ast_head_indexing(simplification(H1),VarSet) :- + check_ast_indexing(H1,VarSet). +check_ast_head_indexing(propagation(H2),VarSet) :- + check_ast_indexing(H2,VarSet). +check_ast_head_indexing(simpagation(H1,H2),VarSet) :- + ast_constraint_list_variables(H2,VarSet,VarSet1), + check_ast_indexing(H1,VarSet1), + ast_constraint_list_variables(H1,VarSet,VarSet2), + check_ast_indexing(H2,VarSet2). + +check_rule_indexing(PragmaRule) :- + PragmaRule = pragma(Rule,_,_,_,_), + Rule = rule(H1,H2,G,_), + term_variables(H1-H2,HeadVars), + remove_anti_monotonic_guards(G,HeadVars,NG), + check_indexing(H1,NG-H2), + check_indexing(H2,NG-H1), + % EXPERIMENT + ( chr_pp_flag(term_indexing,on) -> + term_variables(NG,GuardVariables), + append(H1,H2,Heads), + check_specs_indexing(Heads,GuardVariables,Specs) + ; + true + ). + +:- chr_constraint indexing_spec/2. +:- chr_option(mode,indexing_spec(+,+)). + +:- chr_constraint get_indexing_spec/2. +:- chr_option(mode,get_indexing_spec(+,-)). + + +indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec. +get_indexing_spec(_,Spec) <=> Spec = []. + +indexing_spec(FA,Specs1), indexing_spec(FA,Specs2) + <=> + append(Specs1,Specs2,Specs), + indexing_spec(FA,Specs). + +remove_anti_monotonic_guards(G,Vars,NG) :- + conj2list(G,GL), + remove_anti_monotonic_guard_list(GL,Vars,NGL), + list2conj(NGL,NG). + +remove_anti_monotonic_guard_list([],_,[]). +remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :- + ( G = var(X), memberchk_eq(X,Vars) -> + NGs = RGs + ; + NGs = [G|RGs] + ), + remove_anti_monotonic_guard_list(Gs,Vars,RGs). + +ast_remove_anti_monotonic_guards([],_,[]). +ast_remove_anti_monotonic_guards([G|Gs],VarSet,NGs) :- + ( G = compound(var,1,[X],_), + ast_var_memberchk(X,VarSet) -> + NGs = RGs + ; + NGs = [G|RGs] + ), + ast_remove_anti_monotonic_guards(Gs,VarSet,RGs). +%------------------------------------------------------------------------------- + +check_ast_indexing([],_). +check_ast_indexing([Head|Heads],VarSet) :- + Head = chr_constraint(Symbol,Args,_Constraint), + ast_constraint_list_variables(Heads,VarSet,VarSet1), + check_ast_indexing(Args,1,Symbol,VarSet1), + ast_constraint_variables(Head,VarSet,NVarSet), + check_ast_indexing(Heads,NVarSet). + +check_ast_indexing([],_,_,_). +check_ast_indexing([Arg|Args],I,Symbol,VarSet) :- + ( is_indexed_argument(Symbol,I) -> + true + ; ast_nonvar(Arg) -> + indexed_argument(Symbol,I) + ; % ast_var(Arg) -> + ast_term_list_variables(Args,VarSet,VarSet1), + ( ast_var_memberchk(Arg,VarSet1) -> + indexed_argument(Symbol,I) + ; + true + ) + ), + J is I + 1, + ast_term_variables(Arg,VarSet,NVarSet), + check_ast_indexing(Args,J,Symbol,NVarSet). + +% check_indexing(list(chr_constraint),variables) +check_indexing([],_). +check_indexing([Head|Heads],Other) :- + functor(Head,F,A), + Head =.. [_|Args], + term_variables(Heads-Other,OtherVars), + check_indexing(Args,1,F/A,OtherVars), + check_indexing(Heads,[Head|Other]). + +check_indexing([],_,_,_). +check_indexing([Arg|Args],I,FA,OtherVars) :- + ( is_indexed_argument(FA,I) -> + true + ; nonvar(Arg) -> + indexed_argument(FA,I) + ; % var(Arg) -> + term_variables(Args,ArgsVars), + append(ArgsVars,OtherVars,RestVars), + ( memberchk_eq(Arg,RestVars) -> + indexed_argument(FA,I) + ; + true + ) + ), + J is I + 1, + term_variables(Arg,NVars), + append(NVars,OtherVars,NOtherVars), + check_indexing(Args,J,FA,NOtherVars). +%------------------------------------------------------------------------------- + +check_specs_indexing([],_,[]). +check_specs_indexing([Head|Heads],Variables,Specs) :- + Specs = [Spec|RSpecs], + term_variables(Heads,OtherVariables,Variables), + check_spec_indexing(Head,OtherVariables,Spec), + term_variables(Head,NVariables,Variables), + check_specs_indexing(Heads,NVariables,RSpecs). + +check_spec_indexing(Head,OtherVariables,Spec) :- + functor(Head,F,A), + Spec = spec(F,A,ArgSpecs), + Head =.. [_|Args], + check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs), + indexing_spec(F/A,[ArgSpecs]). + +check_args_spec_indexing([],_,_,[]). +check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :- + term_variables(Args,Variables,OtherVariables), + ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) -> + ArgSpecs = [ArgSpec|RArgSpecs] + ; + ArgSpecs = RArgSpecs + ), + J is I + 1, + term_variables(Arg,NOtherVariables,OtherVariables), + check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs). + +check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :- + ( var(Arg) -> + memberchk_eq(Arg,Variables), + ArgSpec = specinfo(I,any,[]) + ; + functor(Arg,F,A), + ArgSpec = specinfo(I,F/A,[ArgSpecs]), + Arg =.. [_|Args], + check_args_spec_indexing(Args,1,Variables,ArgSpecs) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Occurrences + +add_occurrences(PragmaRules,AstRules) :- + maplist(add_rule_occurrences,PragmaRules,AstRules). + +add_rule_occurrences(PragmaRule,AstRule) :- + PragmaRule = pragma(_,IDs,_,_,Nb), + AstRule = ast_rule(AstHead,_,_,_,_), + add_head_occurrences(AstHead,IDs,Nb). + +add_head_occurrences(simplification(H1),ids(IDs1,_),Nb) :- + maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1). +add_head_occurrences(propagation(H2),ids(_,IDs2),Nb) :- + maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2). +add_head_occurrences(simpagation(H1,H2),ids(IDs1,IDs2),Nb) :- + maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1), + maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2). + +add_constraint_occurrence(Nb,OccType,Constraint,ID) :- + Constraint = chr_constraint(Symbol,_,_), + new_occurrence(Symbol,Nb,ID,OccType). + +% add_occurrences([],[]). +% add_occurrences([Rule|Rules],[]) :- +% Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb), +% add_occurrences(H1,IDs1,simplification,Nb), +% add_occurrences(H2,IDs2,propagation,Nb), +% add_occurrences(Rules). +% +% add_occurrences([],[],_,_). +% add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :- +% functor(H,F,A), +% FA = F/A, +% new_occurrence(FA,RuleNb,ID,Type), +% add_occurrences(Hs,IDs,Type,RuleNb). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Observation Analysis +% +% CLASSIFICATION +% +% +% +% +% +% + +:- chr_constraint observation_analysis/1. +:- chr_option(mode, observation_analysis(+)). + +observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==> + PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_), + ( chr_pp_flag(store_in_guards, on) -> + observation_analysis(RuleNb, Guard, guard, Cs) + ; + true + ), + observation_analysis(RuleNb, Body, body, Cs) + + pragma passive(Id). +observation_analysis(_) <=> true. + +observation_analysis(RuleNb, Term, GB, Cs) :- + ( all_spawned(RuleNb,GB) -> + true + ; var(Term) -> + spawns_all(RuleNb,GB) + ; Term = true -> + true + ; Term = fail -> + true + ; Term = '!' -> + true + ; Term = (T1,T2) -> + observation_analysis(RuleNb,T1,GB,Cs), + observation_analysis(RuleNb,T2,GB,Cs) + ; Term = (T1;T2) -> + observation_analysis(RuleNb,T1,GB,Cs), + observation_analysis(RuleNb,T2,GB,Cs) + ; Term = (T1->T2) -> + observation_analysis(RuleNb,T1,GB,Cs), + observation_analysis(RuleNb,T2,GB,Cs) + ; Term = (\+ T) -> + observation_analysis(RuleNb,T,GB,Cs) + ; functor(Term,F,A), memberchk(F/A,Cs) -> + spawns(RuleNb,GB,F/A) + ; Term = (_ = _) -> + spawns_all_triggers(RuleNb,GB) + ; Term = (_ is _) -> + spawns_all_triggers(RuleNb,GB) + ; builtin_binds_b(Term,Vars) -> + ( Vars == [] -> + true + ; + spawns_all_triggers(RuleNb,GB) + ) + ; + spawns_all(RuleNb,GB) + ). + +:- chr_constraint spawns/3. +:- chr_option(mode, spawns(+,+,+)). +:- chr_type spawns_type ---> guard ; body. +:- chr_option(type_declaration,spawns(any,spawns_type,any)). + +:- chr_constraint spawns_all/2, spawns_all_triggers/2. +:- chr_option(mode, spawns_all(+,+)). +:- chr_option(type_declaration,spawns_all(any,spawns_type)). +:- chr_option(mode, spawns_all_triggers(+,+)). +:- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)). + +spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true. +spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true. +spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true. +spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true. +spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true. +spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true. + +spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true. +spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true. +spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true. +spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true. + +spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true. +spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true. + +spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id + \ + spawns(RuleNb1,GB,C1) + <=> + \+ is_passive(RuleNb2,O) + | + spawns_all(RuleNb1,GB) + pragma + passive(Id). + +occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_) + ==> + \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early... + \+ is_passive(RuleNb2,O), may_trigger(C1) + | + spawns_all_triggers_implies_spawns_all + pragma + passive(Id). + +:- chr_constraint spawns_all_triggers_implies_spawns_all/0. +spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail. +spawns_all_triggers_implies_spawns_all \ + spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB). + +spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id + \ + spawns(RuleNb1,GB,C1) + <=> + may_trigger(C1), + \+ is_passive(RuleNb2,O) + | + spawns_all_triggers(RuleNb1,GB) + pragma + passive(Id). + +spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id, + spawns(RuleNb1,GB,C1) + ==> + \+ may_trigger(C1), + \+ is_passive(RuleNb2,O) + | + spawns_all_triggers(RuleNb1,GB) + pragma + passive(Id). + +% a bit dangerous this rule: could start propagating too much too soon? +spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id, + spawns(RuleNb1,GB,C1) + ==> + RuleNb1 \== RuleNb2, C1 \== C2, + \+ is_passive(RuleNb2,O) + | + spawns(RuleNb1,GB,C2) + pragma + passive(Id). + +spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id, + spawns_all_triggers(RuleNb1,GB) + ==> + \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2) + | + spawns(RuleNb1,GB,C2) + pragma + passive(Id). + + +:- chr_constraint all_spawned/2. +:- chr_option(mode, all_spawned(+,+)). +spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true. +spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true. +all_spawned(RuleNb,GB) <=> fail. + + +% Overview of the supported queries: +% is_observed(+functor/artiy, +occurrence_number, +(guard;body)) +% only succeeds if the occurrence is observed by the +% guard resp. body (depending on the last argument) of its rule +% is_observed(+functor/artiy, +occurrence_number, -) +% succeeds if the occurrence is observed by either the guard or +% the body of its rule +% NOTE: the last argument is NOT bound by this query +% +% do_is_observed(+functor/artiy,+rule_number,+(guard;body)) +% succeeds if the given constraint is observed by the given +% guard resp. body +% do_is_observed(+functor/artiy,+rule_number) +% succeeds if the given constraint is observed by the given +% rule (either its guard or its body) + + +is_observed(C,O) :- + is_observed(C,O,_), + ai_is_observed(C,O). + +is_stored_in_guard(C,RuleNb) :- + chr_pp_flag(store_in_guards, on), + do_is_observed(C,RuleNb,guard). + +:- chr_constraint is_observed/3. +:- chr_option(mode, is_observed(+,+,+)). +occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB). +is_observed(_,_,_) <=> fail. % this will not happen in practice + + +:- chr_constraint do_is_observed/3. +:- chr_option(mode, do_is_observed(+,+,?)). +:- chr_constraint do_is_observed/2. +:- chr_option(mode, do_is_observed(+,+)). + +do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb). + +% (1) spawns_all +% a constraint C is observed if the GB of the rule it occurs in spawns all, +% and some non-passive occurrence of some (possibly other) constraint +% exists in a rule (could be same rule) with at least one occurrence of C + +spawns_all(RuleNb,GB), + occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) + \ + do_is_observed(C,RuleNb,GB) + <=> + \+ is_passive(RuleNb2,O) + | + true. + +spawns_all(RuleNb,_), + occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) + \ + do_is_observed(C,RuleNb) + <=> + \+ is_passive(RuleNb2,O) + | + true. + +% (2) spawns +% a constraint C is observed if the GB of the rule it occurs in spawns a +% constraint C2 that occurs non-passively in a rule (possibly the same rule) +% as an occurrence of C + +spawns(RuleNb,GB,C2), + occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) + \ + do_is_observed(C,RuleNb,GB) + <=> + \+ is_passive(RuleNb2,O) + | + true. + +spawns(RuleNb,_,C2), + occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) + \ + do_is_observed(C,RuleNb) + <=> + \+ is_passive(RuleNb2,O) + | + true. + +% (3) spawns_all_triggers +% a constraint C is observed if the GB of the rule it occurs in spawns all triggers +% and some non-passive occurrence of some (possibly other) constraint that may trigger +% exists in a rule (could be same rule) with at least one occurrence of C + +spawns_all_triggers(RuleNb,GB), + occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) + \ + do_is_observed(C,RuleNb,GB) + <=> + \+ is_passive(RuleNb2,O), may_trigger(C2) + | + true. + +spawns_all_triggers(RuleNb,_), + occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) + \ + do_is_observed(C,RuleNb) + <=> + \+ is_passive(RuleNb2,O), may_trigger(C2) + | + true. + +% (4) conservativeness +do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off). +do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% +%% Generated predicates +%% attach_$CONSTRAINT +%% attach_increment +%% detach_$CONSTRAINT +%% attr_unify_hook + +%% attach_$CONSTRAINT +generate_attach_detach_a_constraint_all([],[]). +generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :- + ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) -> + generate_attach_a_constraint(Constraint,Clauses1), + generate_detach_a_constraint(Constraint,Clauses2) + ; + Clauses1 = [], + Clauses2 = [] + ), + generate_attach_detach_a_constraint_all(Constraints,Clauses3), + append([Clauses1,Clauses2,Clauses3],Clauses). + +generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :- + generate_attach_a_constraint_nil(Constraint,Clause1), + generate_attach_a_constraint_cons(Constraint,Clause2). + +attach_constraint_atom(FA,Vars,Susp,Atom) :- + make_name('attach_',FA,Name), + Atom =.. [Name,Vars,Susp]. + +generate_attach_a_constraint_nil(FA,Clause) :- + Clause = (Head :- true), + attach_constraint_atom(FA,[],_,Head). + +generate_attach_a_constraint_cons(FA,Clause) :- + Clause = (Head :- Body), + attach_constraint_atom(FA,[Var|Vars],Susp,Head), + attach_constraint_atom(FA,Vars,Susp,RecursiveCall), + Body = ( AttachBody, Subscribe, RecursiveCall ), + get_max_constraint_index(N), + ( N == 1 -> + generate_attach_body_1(FA,Var,Susp,AttachBody) + ; + generate_attach_body_n(FA,Var,Susp,AttachBody) + ), + % SWI-Prolog specific code + chr_pp_flag(solver_events,NMod), + ( NMod \== none -> + Args = [[Var|_],Susp], + get_target_module(Mod), + use_auxiliary_predicate(run_suspensions), + Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp])) + ; + Subscribe = true + ). + +generate_attach_body_1(FA,Var,Susp,Body) :- + get_target_module(Mod), + Body = + ( get_attr(Var, Mod, Susps) -> + put_attr(Var, Mod, [Susp|Susps]) + ; + put_attr(Var, Mod, [Susp]) + ). + +generate_attach_body_n(F/A,Var,Susp,Body) :- + chr_pp_flag(experiment,off), !, + get_constraint_index(F/A,Position), + get_max_constraint_index(Total), + get_target_module(Mod), + add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr), + singleton_attr(Total,Susp,Position,NewAttr3), + Body = + ( get_attr(Var,Mod,TAttr) -> + AddGoal, + put_attr(Var,Mod,NTAttr) + ; + put_attr(Var,Mod,NewAttr3) + ), !. +generate_attach_body_n(F/A,Var,Susp,Body) :- + chr_pp_flag(experiment,on), !, + get_constraint_index(F/A,Position), + or_pattern(Position,Pattern), + Position1 is Position + 1, + get_max_constraint_index(Total), + get_target_module(Mod), + singleton_attr(Total,Susp,Position,NewAttr3), + Body = + ( get_attr(Var,Mod,TAttr) -> + arg(1,TAttr,BitVector), + arg(Position1,TAttr,Susps), + NBitVector is BitVector \/ Pattern, + setarg(1,TAttr,NBitVector), + setarg(Position1,TAttr,[Susp|Susps]) + ; + put_attr(Var,Mod,NewAttr3) + ), !. + +%% detach_$CONSTRAINT +generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :- + generate_detach_a_constraint_nil(Constraint,Clause1), + generate_detach_a_constraint_cons(Constraint,Clause2). + +detach_constraint_atom(FA,Vars,Susp,Atom) :- + make_name('detach_',FA,Name), + Atom =.. [Name,Vars,Susp]. + +generate_detach_a_constraint_nil(FA,Clause) :- + Clause = ( Head :- true), + detach_constraint_atom(FA,[],_,Head). + +generate_detach_a_constraint_cons(FA,Clause) :- + Clause = (Head :- Body), + detach_constraint_atom(FA,[Var|Vars],Susp,Head), + detach_constraint_atom(FA,Vars,Susp,RecursiveCall), + Body = ( DetachBody, RecursiveCall ), + get_max_constraint_index(N), + ( N == 1 -> + generate_detach_body_1(FA,Var,Susp,DetachBody) + ; + generate_detach_body_n(FA,Var,Susp,DetachBody) + ). + +generate_detach_body_1(FA,Var,Susp,Body) :- + get_target_module(Mod), + Body = + ( get_attr(Var,Mod,Susps) -> + 'chr sbag_del_element'(Susps,Susp,NewSusps), + ( NewSusps == [] -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,NewSusps) + ) + ; + true + ). + +generate_detach_body_n(F/A,Var,Susp,Body) :- + get_constraint_index(F/A,Position), + get_max_constraint_index(Total), + rem_attr(Total,Var,Susp,Position,TAttr,RemGoal), + get_target_module(Mod), + Body = + ( get_attr(Var,Mod,TAttr) -> + RemGoal + ; + true + ), !. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%------------------------------------------------------------------------------- +%% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det. +:- chr_constraint generate_indexed_variables_body/4. +:- chr_option(mode,generate_indexed_variables_body(+,?,+,?)). +:- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)). +%------------------------------------------------------------------------------- +constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=> + get_indexing_spec(F/A,Specs), + ( chr_pp_flag(term_indexing,on) -> + spectermvars(Specs,Args,F,A,Body,Vars) + ; + get_constraint_type_det(F/A,ArgTypes), + create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N), + ( MaybeBody == empty -> + Body = true, + Vars = [] + ; N == 0 -> + ( Args = [Term] -> + true + ; + Term =.. [term|Args] + ), + Body = term_variables(Term,Vars) + ; + MaybeBody = Body + ) + ). +generate_indexed_variables_body(FA,_,_,_) <=> + chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]). +%=============================================================================== + +create_indexed_variables_body([],[],[],_,_,_,empty,0). +create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :- + J is I + 1, + create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M), + ( Mode == (?), + is_indexed_argument(FA,I) -> + ( atomic_type(Type) -> + Body = + ( + ( var(V) -> + Vars = [V|Tail] + ; + Vars = Tail + ), + Continuation + ), + ( RBody == empty -> + Continuation = true, Tail = [] + ; + Continuation = RBody + ) + ; + ( RBody == empty -> + Body = term_variables(V,Vars) + ; + Body = (term_variables(V,Vars,Tail),RBody) + ) + ), + N = M + ; Mode == (-), is_indexed_argument(FA,I) -> + ( RBody == empty -> + Body = (Vars = [V]) + ; + Body = (Vars = [V|Tail],RBody) + ), + N is M + 1 + ; + Vars = Tail, + Body = RBody, + N is M + 1 + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% EXPERIMENTAL +spectermvars(Specs,Args,F,A,Goal,Vars) :- + spectermvars(Args,1,Specs,F,A,Vars,[],Goal). + +spectermvars([],B,_,_,A,L,L,true) :- B > A, !. +spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :- + Goal = (ArgGoal,RGoal), + argspecs(Specs,I,TempArgSpecs,RSpecs), + merge_argspecs(TempArgSpecs,ArgSpecs), + arggoal(ArgSpecs,Arg,ArgGoal,L,L1), + J is I + 1, + spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal). + +argspecs([],_,[],[]). +argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :- + argspecs(Rest,I,ArgSpecs,RestSpecs). +argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :- + ( I == J -> + ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs], + ( Specs = [] -> + RRestSpecs = RestSpecs + ; + RestSpecs = [Specs|RRestSpecs] + ) + ; + ArgSpecs = RArgSpecs, + RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs] + ), + argspecs(Rest,I,RArgSpecs,RRestSpecs). + +merge_argspecs(In,Out) :- + sort(In,Sorted), + merge_argspecs_(Sorted,Out). + +merge_argspecs_([],[]). +merge_argspecs_([X],R) :- !, R = [X]. +merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :- + ( (F1 == any ; F2 == any) -> + merge_argspecs_([specinfo(I,any,[])|Rest],R) + ; F1 == F2 -> + append(A1,A2,A), + merge_argspecs_([specinfo(I,F1,A)|Rest],R) + ; + R = [specinfo(I,F1,A1)|RR], + merge_argspecs_([specinfo(I,F2,A2)|Rest],RR) + ). + +arggoal(List,Arg,Goal,L,T) :- + ( List == [] -> + L = T, + Goal = true + ; List = [specinfo(_,any,_)] -> + Goal = term_variables(Arg,L,T) + ; + Goal = + ( var(Arg) -> + L = [Arg|T] + ; + Cases + ), + arggoal_cases(List,Arg,L,T,Cases) + ). + +arggoal_cases([],_,L,T,L=T). +arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :- + ( ArgSpecs == [] -> + Cases = RCases + ; ArgSpecs == [[]] -> + Cases = RCases + ; FA = F/A -> + Cases = (Case ; RCases), + functor(Term,F,A), + Term =.. [_|Args], + Case = (Arg = Term -> ArgsGoal), + spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal) + ), + arggoal_cases(Rest,Arg,L,T,RCases). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +generate_extra_clauses(Constraints,List) :- + generate_activate_clauses(Constraints,List,Tail0), + generate_remove_clauses(Constraints,Tail0,Tail1), + generate_allocate_clauses(Constraints,Tail1,Tail2), + generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3), + generate_novel_production(Tail3,Tail4), + generate_extend_history(Tail4,Tail5), + generate_run_suspensions_clauses(Constraints,Tail5,Tail6), + generate_empty_named_history_initialisations(Tail6,Tail7), + Tail7 = []. + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% remove_constraint_internal/[1/3] + +generate_remove_clauses([],List,List). +generate_remove_clauses([C|Cs],List,Tail) :- + generate_remove_clause(C,List,List1), + generate_remove_clauses(Cs,List1,Tail). + +remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :- + uses_state(Constraint,removed), + ( chr_pp_flag(inline_insertremove,off) -> + use_auxiliary_predicate(remove_constraint_internal,Constraint), + Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ), + remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal) + ; + delay_phase_end(validate_store_type_assumptions, + generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) + ) + ). + +remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :- + make_name('$remove_constraint_internal_',Constraint,Name), + ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) -> + Goal =.. [Name, Susp,Delete] + ; + Goal =.. [Name,Susp,Agenda,Delete] + ). + +generate_remove_clause(Constraint,List,Tail) :- + ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) -> + List = [RemoveClause|Tail], + RemoveClause = (Head :- RemoveBody), + remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head), + generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody) + ; + List = Tail + ). + +generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :- + ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) -> + ( Role == active -> + get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState), + if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), + if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete) + ; Role == partner -> + get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState), + GetStateValue = true, + MaybeDelete = DeleteYes + ), + RemoveBody = + ( + GetState, + GetStateValue, + UpdateState, + MaybeDelete + ) + ; + static_suspension_term(Constraint,Susp2), + get_static_suspension_term_field(arguments,Constraint,Susp2,Args), + generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda), + ( chr_pp_flag(debugable,on) -> + Constraint = Functor / _, + get_static_suspension_term_field(functor,Constraint,Susp2,Functor) + ; + true + ), + ( Role == active -> + get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState), + if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), + if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete) + ; Role == partner -> + get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState), + GetStateValue = true, + MaybeDelete = (IndexedVariablesBody, DeleteYes) + ), + RemoveBody = + ( + Susp = Susp2, + GetStateValue, + UpdateState, + MaybeDelete + ) + ). + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% activate_constraint/4 + +generate_activate_clauses([],List,List). +generate_activate_clauses([C|Cs],List,Tail) :- + generate_activate_clause(C,List,List1), + generate_activate_clauses(Cs,List1,Tail). + +activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :- + ( chr_pp_flag(inline_insertremove,off) -> + use_auxiliary_predicate(activate_constraint,Constraint), + Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ), + activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal) + ; + delay_phase_end(validate_store_type_assumptions, + activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal) + ) + ). + +activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :- + make_name('$activate_constraint_',Constraint,Name), + ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) -> + Goal =.. [Name,Store, Susp] + ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) -> + Goal =.. [Name,Store, Susp, Generation] + ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) -> + Goal =.. [Name,Store, Vars, Susp, Generation] + ; + Goal =.. [Name,Store, Vars, Susp] + ). + +generate_activate_clause(Constraint,List,Tail) :- + ( is_used_auxiliary_predicate(activate_constraint,Constraint) -> + List = [Clause|Tail], + Clause = (Head :- Body), + activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head), + activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body) + ; + List = Tail + ). + +activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :- + ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) -> + get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration), + GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration) + ; + GenerationHandling = true + ), + get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState), + if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), + ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) -> + if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal) + ; + get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal), + generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars), + chr_none_locked(Vars,NoneLocked), + if_used_state(Constraint,not_stored_yet, + ( State == not_stored_yet -> + ArgumentsGoal, + IndexedVariablesBody, + NoneLocked, + StoreYes + ; + % Vars = [], + StoreNo + ), + % (Vars = [],StoreNo),StoreVarsGoal) + StoreNo,StoreVarsGoal) + ), + Body = + ( + GetState, + GetStateValue, + UpdateState, + GenerationHandling, + StoreVarsGoal + ). +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% allocate_constraint/4 + +generate_allocate_clauses([],List,List). +generate_allocate_clauses([C|Cs],List,Tail) :- + generate_allocate_clause(C,List,List1), + generate_allocate_clauses(Cs,List1,Tail). + +allocate_constraint_goal(Constraint,Susp,Args,Goal) :- + uses_state(Constraint,not_stored_yet), + ( chr_pp_flag(inline_insertremove,off) -> + use_auxiliary_predicate(allocate_constraint,Constraint), + allocate_constraint_atom(Constraint,Susp,Args,Goal) + ; + Goal = (Susp = Suspension, Goal0), + delay_phase_end(validate_store_type_assumptions, + allocate_constraint_body(Constraint,Suspension,Args,Goal0) + ) + ). + +allocate_constraint_atom(Constraint, Susp, Args,Goal) :- + make_name('$allocate_constraint_',Constraint,Name), + Goal =.. [Name,Susp|Args]. + +generate_allocate_clause(Constraint,List,Tail) :- + ( is_used_auxiliary_predicate(allocate_constraint,Constraint) -> + List = [Clause|Tail], + Clause = (Head :- Body), + Constraint = _/A, + length(Args,A), + allocate_constraint_atom(Constraint,Susp,Args,Head), + allocate_constraint_body(Constraint,Susp,Args,Body) + ; + List = Tail + ). + +allocate_constraint_body(Constraint,Susp,Args,Body) :- + static_suspension_term(Constraint,Suspension), + get_static_suspension_term_field(arguments,Constraint,Suspension,Args), + ( chr_pp_flag(debugable,on) -> + Constraint = Functor / _, + get_static_suspension_term_field(functor,Constraint,Suspension,Functor) + ; + true + ), + ( chr_pp_flag(debugable,on) -> + ( may_trigger(Constraint) -> + append(Args,[Susp],VarsSusp), + build_head(F,A,[0],VarsSusp, ContinuationGoal), + get_target_module(Mod), + Continuation = Mod : ContinuationGoal + ; + Continuation = true + ), + Init = (Susp = Suspension), + create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation), + create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) + ; may_trigger(Constraint), uses_field(Constraint,generation) -> + create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration), + Susp = Suspension, Init = true, CreateContinuation = true + ; + CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true + ), + ( uses_history(Constraint) -> + create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory) + ; + CreateHistory = true + ), + create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState), + ( has_suspension_field(Constraint,id) -> + get_static_suspension_term_field(id,Constraint,Suspension,Id), + gen_id(Id,GenID) + ; + GenID = true + ), + Body = + ( + Init, + CreateContinuation, + CreateGeneration, + CreateHistory, + CreateState, + GenID + ). + +gen_id(Id,'chr gen_id'(Id)). +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% insert_constraint_internal + +generate_insert_constraint_internal_clauses([],List,List). +generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :- + generate_insert_constraint_internal_clause(C,List,List1), + generate_insert_constraint_internal_clauses(Cs,List1,Tail). + +insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :- + ( chr_pp_flag(inline_insertremove,off) -> + use_auxiliary_predicate(remove_constraint_internal,Constraint), + insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal) + ; + delay_phase_end(validate_store_type_assumptions, + generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal) + ) + ). + + +insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :- + insert_constraint_internal_constraint_name(Constraint,Name), + ( chr_pp_flag(debugable,on) -> + Goal =.. [Name, Vars, Self, Closure | Args] + ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))-> + Goal =.. [Name,Self | Args] + ; + Goal =.. [Name,Vars, Self | Args] + ). + +insert_constraint_internal_constraint_name(Constraint,Name) :- + make_name('$insert_constraint_internal_',Constraint,Name). + +generate_insert_constraint_internal_clause(Constraint,List,Tail) :- + ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) -> + List = [Clause|Tail], + Clause = (Head :- Body), + Constraint = _/A, + length(Args,A), + insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head), + generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body) + ; + List = Tail + ). + + +generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :- + static_suspension_term(Constraint,Suspension), + create_static_suspension_field(Constraint,Suspension,state,active,CreateState), + ( chr_pp_flag(debugable,on) -> + get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation), + create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) + ; may_trigger(Constraint), uses_field(Constraint,generation) -> + create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) + ; + CreateGeneration = true + ), + ( chr_pp_flag(debugable,on) -> + Constraint = Functor / _, + get_static_suspension_term_field(functor,Constraint,Suspension,Functor) + ; + true + ), + ( uses_history(Constraint) -> + create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory) + ; + CreateHistory = true + ), + get_static_suspension_term_field(arguments,Constraint,Suspension,Args), + List = [Clause|Tail], + ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))-> + suspension_term_base_fields(Constraint,BaseFields), + ( has_suspension_field(Constraint,id) -> + get_static_suspension_term_field(id,Constraint,Suspension,Id), + gen_id(Id,GenID) + ; + GenID = true + ), + Body = + ( + Susp = Suspension, + CreateState, + CreateGeneration, + CreateHistory, + GenID + ) + ; + ( has_suspension_field(Constraint,id) -> + get_static_suspension_term_field(id,Constraint,Suspension,Id), + gen_id(Id,GenID) + ; + GenID = true + ), + generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars), + chr_none_locked(Vars,NoneLocked), + Body = + ( + Susp = Suspension, + IndexedVariablesBody, + NoneLocked, + CreateState, + CreateGeneration, + CreateHistory, + GenID + ) + ). + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% novel_production/2 + +generate_novel_production(List,Tail) :- + ( is_used_auxiliary_predicate(novel_production) -> + List = [Clause|Tail], + Clause = + ( + '$novel_production'( Self, Tuple) :- + % arg( 3, Self, Ref), % ARGXXX + % 'chr get_mutable'( History, Ref), + arg( 3, Self, History), % ARGXXX + ( hprolog:get_ds( Tuple, History, _) -> + fail + ; + true + ) + ) + ; + List = Tail + ). + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% extend_history/2 + +generate_extend_history(List,Tail) :- + ( is_used_auxiliary_predicate(extend_history) -> + List = [Clause|Tail], + Clause = + ( + '$extend_history'( Self, Tuple) :- + % arg( 3, Self, Ref), % ARGXXX + % 'chr get_mutable'( History, Ref), + arg( 3, Self, History), % ARGXXX + hprolog:put_ds( Tuple, History, x, NewHistory), + setarg( 3, Self, NewHistory) % ARGXXX + ) + ; + List = Tail + ). + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% +:- chr_constraint + empty_named_history_initialisations/2, + generate_empty_named_history_initialisation/1, + find_empty_named_histories/0. + +generate_empty_named_history_initialisations(List, Tail) :- + empty_named_history_initialisations(List, Tail), + find_empty_named_histories. + +find_empty_named_histories, history(_, Name, []) ==> + generate_empty_named_history_initialisation(Name). + +generate_empty_named_history_initialisation(Name) \ + generate_empty_named_history_initialisation(Name) <=> true. +generate_empty_named_history_initialisation(Name) \ + empty_named_history_initialisations(List, Tail) # Passive + <=> + empty_named_history_global_variable(Name, GlobalVariable), + List = [(:- nb_setval(GlobalVariable, 0))|Rest], + empty_named_history_initialisations(Rest, Tail) + pragma passive(Passive). + +find_empty_named_histories \ + generate_empty_named_history_initialisation(_) # Passive <=> true +pragma passive(Passive). + +find_empty_named_histories, + empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail +pragma passive(Passive). + +find_empty_named_histories <=> + chr_error(internal, 'find_empty_named_histories was not removed', []). + + +empty_named_history_global_variable(Name, GlobalVariable) :- + atom_concat('chr empty named history ', Name, GlobalVariable). + +empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :- + empty_named_history_global_variable(Name, GlobalVariable). + +empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :- + empty_named_history_global_variable(Name, GlobalVariable). + + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- +% run_suspensions/2 + +generate_run_suspensions_clauses([],List,List). +generate_run_suspensions_clauses([C|Cs],List,Tail) :- + generate_run_suspensions_clause(C,List,List1), + generate_run_suspensions_clauses(Cs,List1,Tail). + +run_suspensions_goal(Constraint,Suspensions,Goal) :- + make_name('$run_suspensions_',Constraint,Name), + Goal =.. [Name,Suspensions]. + +generate_run_suspensions_clause(Constraint,List,Tail) :- + ( is_used_auxiliary_predicate(run_suspensions,Constraint) -> + List = [Clause1,Clause2|Tail], + run_suspensions_goal(Constraint,[],Clause1), + ( chr_pp_flag(debugable,on) -> + run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head), + get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState), + get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost), + get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration), + get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation), + run_suspensions_goal(Constraint,Suspensions,Clause2Recursion), + Clause2 = + ( + Clause2Head :- + GetState, + GetStateValue, + ( State==active -> + UpdateState, + GetGeneration, + GetGenerationValue, + Generation is Gen+1, + UpdateGeneration, + GetContinuation, + ( + 'chr debug_event'(wake(Suspension)), + call(Continuation) + ; + 'chr debug_event'(fail(Suspension)), !, + fail + ), + ( + 'chr debug_event'(exit(Suspension)) + ; + 'chr debug_event'(redo(Suspension)), + fail + ), + GetPost, + GetPostValue, + ( Post==triggered -> + UpdatePost % catching constraints that did not do anything + ; + true + ) + ; + true + ), + Clause2Recursion + ) + ; + run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head), + static_suspension_term(Constraint,SuspensionTerm), + get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments), + append(Arguments,[Suspension],VarsSusp), + make_suspension_continuation_goal(Constraint,VarsSusp,Continuation), + run_suspensions_goal(Constraint,Suspensions,Clause2Recursion), + ( uses_field(Constraint,generation) -> + get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration), + GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration) + ; + GenerationHandling = true + ), + get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState), + get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState), + if_used_state(Constraint,removed, + ( GetState, + ( State==active + -> ReactivateConstraint + ; true) + ),ReactivateConstraint,CondReactivate), + ReactivateConstraint = + ( + UpdateState, + GenerationHandling, + Continuation, + GetPostState, + ( Post==triggered -> + UpdatePostState % catching constraints that did not do anything + ; + true + ) + ), + Clause2 = + ( + Clause2Head :- + Suspension = SuspensionTerm, + CondReactivate, + Clause2Recursion + ) + ) + ; + List = Tail + ). + +%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +generate_attach_increment(Clauses) :- + get_max_constraint_index(N), + ( is_used_auxiliary_predicate(attach_increment), N > 0 -> + Clauses = [Clause1,Clause2], + generate_attach_increment_empty(Clause1), + ( N == 1 -> + generate_attach_increment_one(Clause2) + ; + generate_attach_increment_many(N,Clause2) + ) + ; + Clauses = [] + ). + +generate_attach_increment_empty((attach_increment([],_) :- true)). + +generate_attach_increment_one(Clause) :- + Head = attach_increment([Var|Vars],Susps), + get_target_module(Mod), + chr_not_locked(Var,NotLocked), + Body = + ( + NotLocked, + ( get_attr(Var,Mod,VarSusps) -> + sort(VarSusps,SortedVarSusps), + 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps), + put_attr(Var,Mod,MergedSusps) + ; + put_attr(Var,Mod,Susps) + ), + attach_increment(Vars,Susps) + ), + Clause = (Head :- Body). + +generate_attach_increment_many(N,Clause) :- + Head = attach_increment([Var|Vars],TAttr1), + % writeln(merge_attributes_1_before), + merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr), + % writeln(merge_attributes_1_after), + get_target_module(Mod), + chr_not_locked(Var,NotLocked), + Body = + ( + NotLocked, + ( get_attr(Var,Mod,TAttr2) -> + MergeGoal, + put_attr(Var,Mod,Attr) + ; + put_attr(Var,Mod,TAttr1) + ), + attach_increment(Vars,TAttr1) + ), + Clause = (Head :- Body). + +%% attr_unify_hook +generate_attr_unify_hook(Clauses) :- + get_max_constraint_index(N), + ( N == 0 -> + Clauses = [] + ; + Clauses = [GoalsClause|HookClauses], + GoalsClause = attribute_goals(_,Goals,Goals), + ( N == 1 -> + generate_attr_unify_hook_one(HookClauses) + ; + generate_attr_unify_hook_many(N,HookClauses) + ) + ). + +generate_attr_unify_hook_one([Clause]) :- + Head = attr_unify_hook(Susps,Other), + get_target_module(Mod), + get_indexed_constraint(1,C), + ( get_store_type(C,ST), + ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) -> + make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps), + make_run_suspensions(SortedSusps,SortedSusps,WakeSusps), + ( atomic_types_suspended_constraint(C) -> + SortGoal1 = true, + SortedSusps = Susps, + SortGoal2 = true, + SortedOtherSusps = OtherSusps, + MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)), + NonvarBody = true + ; + SortGoal1 = sort(Susps, SortedSusps), + SortGoal2 = sort(OtherSusps,SortedOtherSusps), + MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps), + use_auxiliary_predicate(attach_increment), + NonvarBody = + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars, SortedSusps) + ; + true + ) + ), + Body = + ( + SortGoal1, + ( var(Other) -> + ( get_attr(Other,Mod,OtherSusps) -> + SortGoal2, + MergeGoal, + put_attr(Other,Mod,NewSusps), + WakeNewSusps + ; + put_attr(Other,Mod,SortedSusps), + WakeSusps + ) + ; + NonvarBody, + WakeSusps + ) + ), + Clause = (Head :- Body) + ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) -> + make_run_suspensions(List,List,WakeNewSusps), + MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)), + Body = + ( get_attr(Other,Mod,OtherSusps) -> + MergeGoal, + WakeNewSusps + ; + put_attr(Other,Mod,Susps) + ), + Clause = (Head :- Body) + ). + + +generate_attr_unify_hook_many(N,[Clause]) :- + chr_pp_flag(dynattr,off), !, + Head = attr_unify_hook(Attr,Other), + get_target_module(Mod), + make_attr(N,Mask,SuspsList,Attr), + bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList), + list2conj(SortGoalList,SortGoals), + bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList), + merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr), + get_all_suspensions2(N,MergedAttr,MergedSuspsList), + make_attr(N,Mask,SortedSuspsList,SortedAttr), + make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps), + make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps), + ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) -> + NonvarBody = true + ; + use_auxiliary_predicate(attach_increment), + NonvarBody = + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars,SortedAttr) + ; + true + ) + ), + Body = + ( + SortGoals, + ( var(Other) -> + ( get_attr(Other,Mod,TOtherAttr) -> + MergeGoal, + put_attr(Other,Mod,MergedAttr), + WakeMergedSusps + ; + put_attr(Other,Mod,SortedAttr), + WakeSortedSusps + ) + ; + NonvarBody, + WakeSortedSusps + ) + ), + Clause = (Head :- Body). + +% NEW +generate_attr_unify_hook_many(N,Clauses) :- + Head = attr_unify_hook(Attr,Other), + get_target_module(Mod), + normalize_attr(Attr,NormalGoal,NormalAttr), + normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr), + merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr), + make_run_suspensions(N), + ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) -> + NonvarBody = true + ; + use_auxiliary_predicate(attach_increment), + NonvarBody = + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars,NormalAttr) + ; + true + ) + ), + Body = + ( + NormalGoal, + ( var(Other) -> + ( get_attr(Other,Mod,OtherAttr) -> + NormalOtherGoal, + MergeGoal, + put_attr(Other,Mod,MergedAttr), + '$dispatch_run_suspensions'(MergedAttr) + ; + put_attr(Other,Mod,NormalAttr), + '$dispatch_run_suspensions'(NormalAttr) + ) + ; + NonvarBody, + '$dispatch_run_suspensions'(NormalAttr) + ) + ), + Clause = (Head :- Body), + Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers], + DispatchList1 = ('$dispatch_run_suspensions'([])), + DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)), + run_suspensions_dispatchers(N,[],Dispatchers). + +% NEW +run_suspensions_dispatchers(N,Acc,Dispatchers) :- + ( N > 0 -> + get_indexed_constraint(N,C), + NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc], + ( may_trigger(C) -> + run_suspensions_goal(C,List,Body) + ; + Body = true + ), + M is N - 1, + run_suspensions_dispatchers(M,NAcc,Dispatchers) + ; + Dispatchers = Acc + ). + +% NEW +make_run_suspensions(N) :- + ( N > 0 -> + ( get_indexed_constraint(N,C), + may_trigger(C) -> + use_auxiliary_predicate(run_suspensions,C) + ; + true + ), + M is N - 1, + make_run_suspensions(M) + ; + true + ). + +make_run_suspensions(AllSusps,OneSusps,Goal) :- + make_run_suspensions(1,AllSusps,OneSusps,Goal). + +make_run_suspensions(Index,AllSusps,OneSusps,Goal) :- + ( get_indexed_constraint(Index,C), may_trigger(C) -> + use_auxiliary_predicate(run_suspensions,C), + ( wakes_partially(C) -> + run_suspensions_goal(C,OneSusps,Goal) + ; + run_suspensions_goal(C,AllSusps,Goal) + ) + ; + Goal = true + ). + +make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :- + make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal). + +make_run_suspensions_loop([],[],_,true). +make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :- + make_run_suspensions(I,AllSusps,OneSusps,Goal), + J is I + 1, + make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% $insert_in_store_F/A +% $delete_from_store_F/A + +generate_insert_delete_constraints([],[]). +generate_insert_delete_constraints([FA|Rest],Clauses) :- + ( is_stored(FA) -> + generate_insert_delete_constraint(FA,Clauses,RestClauses) + ; + Clauses = RestClauses + ), + generate_insert_delete_constraints(Rest,RestClauses). + +generate_insert_delete_constraint(FA,Clauses,RestClauses) :- + insert_constraint_clause(FA,Clauses,RestClauses1), + delete_constraint_clause(FA,RestClauses1,RestClauses). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% insert_in_store + +insert_constraint_goal(FA,Susp,Vars,Goal) :- + ( chr_pp_flag(inline_insertremove,off) -> + use_auxiliary_predicate(insert_in_store,FA), + insert_constraint_atom(FA,Susp,Goal) + ; + delay_phase_end(validate_store_type_assumptions, + ( insert_constraint_body(FA,Susp,UsedVars,Goal), + insert_constraint_direct_used_vars(UsedVars,Vars) + ) + ) + ). + +insert_constraint_direct_used_vars([],_). +insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :- + nth1(Index,Vars,Var), + insert_constraint_direct_used_vars(Rest,Vars). + +insert_constraint_atom(FA,Susp,Call) :- + make_name('$insert_in_store_',FA,Functor), + Call =.. [Functor,Susp]. + +insert_constraint_clause(C,Clauses,RestClauses) :- + ( is_used_auxiliary_predicate(insert_in_store,C) -> + Clauses = [Clause|RestClauses], + Clause = (Head :- InsertCounterInc,VarsBody,Body), + insert_constraint_atom(C,Susp,Head), + insert_constraint_body(C,Susp,UsedVars,Body), + insert_constraint_used_vars(UsedVars,C,Susp,VarsBody), + ( chr_pp_flag(store_counter,on) -> + InsertCounterInc = '$insert_counter_inc' + ; + InsertCounterInc = true + ) + ; + Clauses = RestClauses + ). + +insert_constraint_used_vars([],_,_,true). +insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :- + get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal), + insert_constraint_used_vars(Rest,C,Susp,Goals). + +insert_constraint_body(C,Susp,UsedVars,Body) :- + get_store_type(C,StoreType), + insert_constraint_body(StoreType,C,Susp,UsedVars,Body). + +insert_constraint_body(default,C,Susp,[],Body) :- + global_list_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,Cell,UpdateStoreGoal), + ( chr_pp_flag(debugable,on) -> + Cell = [Susp|Store], + Body = + ( + GetStoreGoal, + UpdateStoreGoal + ) + ; + set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal), + Body = + ( + GetStoreGoal, + Cell = [Susp|Store], + UpdateStoreGoal, + ( Store = [NextSusp|_] -> + SetGoal + ; + true + ) + ) + ). +% get_target_module(Mod), +% get_max_constraint_index(Total), +% ( Total == 1 -> +% generate_attach_body_1(C,Store,Susp,AttachBody) +% ; +% generate_attach_body_n(C,Store,Susp,AttachBody) +% ), +% Body = +% ( +% 'chr default_store'(Store), +% AttachBody +% ). +insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :- + generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body). +insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :- + generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars), + sort_out_used_vars(MixedUsedVars,UsedVars). +insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :- + multi_hash_key_direct(C,Index,Susp,Key,UsedVars), + constants_store_index_name(C,Index,IndexName), + IndexLookup =.. [IndexName,Key,StoreName], + Body = + ( IndexLookup -> + nb_getval(StoreName,Store), + b_setval(StoreName,[Susp|Store]) + ; + true + ). +insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :- + multi_hash_key_direct(C,Index,Susp,Key,UsedVars), + constants_store_index_name(C,Index,IndexName), + IndexLookup =.. [IndexName,Key,StoreName], + Body = + ( IndexLookup -> + nb_getval(StoreName,Store), + b_setval(StoreName,[Susp|Store]) + ; + true + ). +insert_constraint_body(global_ground,C,Susp,[],Body) :- + global_ground_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,Cell,UpdateStoreGoal), + ( chr_pp_flag(debugable,on) -> + Cell = [Susp|Store], + Body = + ( + GetStoreGoal, + UpdateStoreGoal + ) + ; + set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal), + Body = + ( + GetStoreGoal, + Cell = [Susp|Store], + UpdateStoreGoal, + ( Store = [NextSusp|_] -> + SetGoal + ; + true + ) + ) + ). +% global_ground_store_name(C,StoreName), +% make_get_store_goal(StoreName,Store,GetStoreGoal), +% make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal), +% Body = +% ( +% GetStoreGoal, % nb_getval(StoreName,Store), +% UpdateStoreGoal % b_setval(StoreName,[Susp|Store]) +% ). +insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :- + % TODO: generalize to more than one !!! + get_target_module(Module), + Body = ( get_attr(Variable,Module,AssocStore) -> + insert_assoc_store(AssocStore,Key,Susp) + ; + new_assoc_store(AssocStore), + put_attr(Variable,Module,AssocStore), + insert_assoc_store(AssocStore,Key,Susp) + ). + +insert_constraint_body(global_singleton,C,Susp,[],Body) :- + global_singleton_store_name(C,StoreName), + make_update_store_goal(StoreName,Susp,UpdateStoreGoal), + Body = + ( + UpdateStoreGoal + ). +insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :- + maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies), + list2conj(Bodies,Body), + sort_out_used_vars(NestedUsedVars,UsedVars). +insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :- + insert_constraint_body(StoreType,C,Susp,UsedVars,Body). +insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :- + UsedVars = [Index-Var], + get_identifier_size(ISize), + functor(Struct,struct,ISize), + get_identifier_index(C,Index,IIndex), + arg(IIndex,Struct,Susps), + Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])). +insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :- + UsedVars = [Index-Var], + type_indexed_identifier_structure(IndexType,Struct), + get_type_indexed_identifier_index(IndexType,C,Index,IIndex), + arg(IIndex,Struct,Susps), + Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])). + +sort_out_used_vars(NestedUsedVars,UsedVars) :- + flatten(NestedUsedVars,FlatUsedVars), + sort(FlatUsedVars,SortedFlatUsedVars), + sort_out_used_vars1(SortedFlatUsedVars,UsedVars). + +sort_out_used_vars1([],[]). +sort_out_used_vars1([I-V],L) :- !, L = [I-V]. +sort_out_used_vars1([I-X,J-Y|R],L) :- + ( I == J -> + X = Y, + sort_out_used_vars1([I-X|R],L) + ; + L = [I-X|T], + sort_out_used_vars1([J-Y|R],T) + ). + +generate_multi_inthash_insert_constraint_bodies([],_,_,true). +generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- + multi_hash_store_name(FA,Index,StoreName), + multi_hash_key(FA,Index,Susp,KeyBody,Key), + Body = + ( + KeyBody, + nb_getval(StoreName,Store), + insert_iht(Store,Key,Susp) + ), + generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies). + +generate_multi_hash_insert_constraint_bodies([],_,_,true,[]). +generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :- + multi_hash_store_name(FA,Index,StoreName), + multi_hash_key_direct(FA,Index,Susp,Key,UsedVars), + make_get_store_goal(StoreName,Store,GetStoreGoal), + ( chr_pp_flag(ht_removal,on) + -> ht_prev_field(Index,PrevField), + set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result, + SetGoal), + Body = + ( + GetStoreGoal, + insert_ht(Store,Key,Susp,Result), + ( Result = [_,NextSusp|_] + -> SetGoal + ; true + ) + ) + ; Body = + ( + GetStoreGoal, + insert_ht(Store,Key,Susp) + ) + ), + generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% Delete + +delete_constraint_clause(C,Clauses,RestClauses) :- + ( is_used_auxiliary_predicate(delete_from_store,C) -> + Clauses = [Clause|RestClauses], + Clause = (Head :- Body), + delete_constraint_atom(C,Susp,Head), + C = F/A, + functor(Head,F,A), + delete_constraint_body(C,Head,Susp,[],Body) + ; + Clauses = RestClauses + ). + +delete_constraint_goal(Head,Susp,VarDict,Goal) :- + functor(Head,F,A), + C = F/A, + ( chr_pp_flag(inline_insertremove,off) -> + use_auxiliary_predicate(delete_from_store,C), + delete_constraint_atom(C,Susp,Goal) + ; + delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal)) + ). + +delete_constraint_atom(C,Susp,Atom) :- + make_name('$delete_from_store_',C,Functor), + Atom =.. [Functor,Susp]. + + +delete_constraint_body(C,Head,Susp,VarDict,Body) :- + Body = (CounterBody,DeleteBody), + ( chr_pp_flag(store_counter,on) -> + CounterBody = '$delete_counter_inc' + ; + CounterBody = true + ), + get_store_type(C,StoreType), + delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody). + +delete_constraint_body(default,C,_,Susp,_,Body) :- + ( chr_pp_flag(debugable,on) -> + global_list_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,NStore,UpdateStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,Store), + 'chr sbag_del_element'(Store,Susp,NStore), + UpdateStoreGoal % b_setval(StoreName,NStore) + ) + ; + get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal), + global_list_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,Tail,UpdateStoreGoal), + set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1), + set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2), + Body = + ( + GetGoal, + ( var(PredCell) -> + GetStoreGoal, % nb_getval(StoreName,Store), + Store = [_|Tail], + UpdateStoreGoal, + ( Tail = [NextSusp|_] -> + SetGoal1 + ; + true + ) + ; + PredCell = [_,_|Tail], + setarg(2,PredCell,Tail), + ( Tail = [NextSusp|_] -> + SetGoal2 + ; + true + ) + ) + ) + ). +% get_target_module(Mod), +% get_max_constraint_index(Total), +% ( Total == 1 -> +% generate_detach_body_1(C,Store,Susp,DetachBody), +% Body = +% ( +% 'chr default_store'(Store), +% DetachBody +% ) +% ; +% generate_detach_body_n(C,Store,Susp,DetachBody), +% Body = +% ( +% 'chr default_store'(Store), +% DetachBody +% ) +% ). +delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :- + generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body). +delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :- + generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body). +delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :- + multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), + constants_store_index_name(C,Index,IndexName), + IndexLookup =.. [IndexName,Key,StoreName], + Body = + ( KeyBody, + ( IndexLookup -> + nb_getval(StoreName,Store), + 'chr sbag_del_element'(Store,Susp,NStore), + b_setval(StoreName,NStore) + ; + true + )). +delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :- + multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), + constants_store_index_name(C,Index,IndexName), + IndexLookup =.. [IndexName,Key,StoreName], + Body = + ( KeyBody, + ( IndexLookup -> + nb_getval(StoreName,Store), + 'chr sbag_del_element'(Store,Susp,NStore), + b_setval(StoreName,NStore) + ; + true + )). +delete_constraint_body(global_ground,C,_,Susp,_,Body) :- + ( chr_pp_flag(debugable,on) -> + global_ground_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,NStore,UpdateStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,Store), + 'chr sbag_del_element'(Store,Susp,NStore), + UpdateStoreGoal % b_setval(StoreName,NStore) + ) + ; + get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal), + global_ground_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,Tail,UpdateStoreGoal), + set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1), + set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2), + Body = + ( + GetGoal, + ( var(PredCell) -> + GetStoreGoal, % nb_getval(StoreName,Store), + Store = [_|Tail], + UpdateStoreGoal, + ( Tail = [NextSusp|_] -> + SetGoal1 + ; + true + ) + ; + PredCell = [_,_|Tail], + setarg(2,PredCell,Tail), + ( Tail = [NextSusp|_] -> + SetGoal2 + ; + true + ) + ) + ) + ). +% global_ground_store_name(C,StoreName), +% make_get_store_goal(StoreName,Store,GetStoreGoal), +% make_update_store_goal(StoreName,NStore,UpdateStoreGoal), +% Body = +% ( +% GetStoreGoal, % nb_getval(StoreName,Store), +% 'chr sbag_del_element'(Store,Susp,NStore), +% UpdateStoreGoal % b_setval(StoreName,NStore) +% ). +delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :- + get_target_module(Module), + get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal), + get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal), + Body = ( + VariableGoal, + get_attr(Variable,Module,AssocStore), + KeyGoal, + delete_assoc_store(AssocStore,Key,Susp) + ). +delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :- + global_singleton_store_name(C,StoreName), + make_update_store_goal(StoreName,[],UpdateStoreGoal), + Body = + ( + UpdateStoreGoal % b_setval(StoreName,[]) + ). +delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :- + maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies), + list2conj(Bodies,Body). +delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :- + delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body). +delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :- + get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal), + get_identifier_size(ISize), + functor(Struct,struct,ISize), + get_identifier_index(C,Index,IIndex), + arg(IIndex,Struct,Susps), + Body = ( + VariableGoal, + Variable = Struct, + 'chr sbag_del_element'(Susps,Susp,NSusps), + setarg(IIndex,Variable,NSusps) + ). +delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :- + get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal), + type_indexed_identifier_structure(IndexType,Struct), + get_type_indexed_identifier_index(IndexType,C,Index,IIndex), + arg(IIndex,Struct,Susps), + Body = ( + VariableGoal, + Variable = Struct, + 'chr sbag_del_element'(Susps,Susp,NSusps), + setarg(IIndex,Variable,NSusps) + ). + +generate_multi_inthash_delete_constraint_bodies([],_,_,true). +generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- + multi_hash_store_name(FA,Index,StoreName), + multi_hash_key(FA,Index,Susp,KeyBody,Key), + Body = + ( + KeyBody, + nb_getval(StoreName,Store), + delete_iht(Store,Key,Susp) + ), + generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies). +generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true). +generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :- + multi_hash_store_name(C,Index,StoreName), + multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), + make_get_store_goal(StoreName,Store,GetStoreGoal), + ( chr_pp_flag(ht_removal,on) + -> ht_prev_field(Index,PrevField), + get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal), + set_dynamic_suspension_term_field(PrevField,C,NextSusp,_, + SetGoal1), + set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev, + SetGoal2), + Body = + ( + GetGoal, + ( var(Prev) + -> GetStoreGoal, + KeyBody, + delete_first_ht(Store,Key,Values), + ( Values = [NextSusp|_] + -> SetGoal1 + ; true + ) + ; Prev = [_,_|Values], + setarg(2,Prev,Values), + ( Values = [NextSusp|_] + -> SetGoal2 + ; true + ) + ) + ) + ; Body = + ( + KeyBody, + GetStoreGoal, % nb_getval(StoreName,Store), + delete_ht(Store,Key,Susp) + ) + ), + generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- chr_constraint + module_initializer/1, + module_initializers/1. + +module_initializers(G), module_initializer(Initializer) <=> + G = (Initializer,Initializers), + module_initializers(Initializers). + +module_initializers(G) <=> + G = true. + +generate_attach_code(Constraints,Clauses) :- + enumerate_stores_code(Constraints,Enumerate), + append(Enumerate,L,Clauses), + generate_attach_code(Constraints,L,T), + module_initializers(Initializers), + prolog_global_variables_code(PrologGlobalVariables), + % Do not rename or the 'chr_initialization' predicate + % without warning SSS + T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables]. + +generate_attach_code([],L,L). +generate_attach_code([C|Cs],L,T) :- + get_store_type(C,StoreType), + generate_attach_code(StoreType,C,L,L1), + generate_attach_code(Cs,L1,T). + +generate_attach_code(default,C,L,T) :- + global_list_store_initialisation(C,L,T). +generate_attach_code(multi_inthash(Indexes),C,L,T) :- + multi_inthash_store_initialisations(Indexes,C,L,L1), + multi_inthash_via_lookups(Indexes,C,L1,T). +generate_attach_code(multi_hash(Indexes),C,L,T) :- + multi_hash_store_initialisations(Indexes,C,L,L1), + multi_hash_lookups(Indexes,C,L1,T). +generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :- + constants_initializers(C,Index,Constants), + atomic_constants_code(C,Index,Constants,L,T). +generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :- + constants_initializers(C,Index,Constants), + ground_constants_code(C,Index,Constants,L,T). +generate_attach_code(global_ground,C,L,T) :- + global_ground_store_initialisation(C,L,T). +generate_attach_code(var_assoc_store(_,_),_,L,L) :- + use_auxiliary_module(chr_assoc_store). +generate_attach_code(global_singleton,C,L,T) :- + global_singleton_store_initialisation(C,L,T). +generate_attach_code(multi_store(StoreTypes),C,L,T) :- + multi_store_generate_attach_code(StoreTypes,C,L,T). +generate_attach_code(identifier_store(Index),C,L,T) :- + get_identifier_index(C,Index,IIndex), + ( IIndex == 2 -> + get_identifier_size(ISize), + functor(Struct,struct,ISize), + Struct =.. [_,Label|Stores], + set_elems(Stores,[]), + Clause1 = new_identifier(Label,Struct), + functor(Struct2,struct,ISize), + arg(1,Struct2,Label2), + Clause2 = + ( user:portray(Struct2) :- + write('') + ), + functor(Struct3,struct,ISize), + arg(1,Struct3,Label3), + Clause3 = identifier_label(Struct3,Label3), + L = [Clause1,Clause2,Clause3|T] + ; + L = T + ). +generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :- + get_type_indexed_identifier_index(IndexType,C,Index,IIndex), + ( IIndex == 2 -> + identifier_store_initialization(IndexType,L,L1), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + get_type_indexed_identifier_size(IndexType,ISize), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + type_indexed_identifier_structure(IndexType,Struct), + Struct =.. [_,Label|Stores], + set_elems(Stores,[]), + type_indexed_identifier_name(IndexType,new_identifier,Name1), + Clause1 =.. [Name1,Label,Struct], + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + Goal1 =.. [Name1,Label1b,S1b], + type_indexed_identifier_structure(IndexType,Struct1b), + Struct1b =.. [_,Label1b|Stores1b], + set_elems(Stores1b,[]), + Expansion1 = (S1b = Struct1b), + Clause1b = user:goal_expansion(Goal1,Expansion1), + % writeln(Clause1-Clause1b), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + type_indexed_identifier_structure(IndexType,Struct2), + arg(1,Struct2,Label2), + Clause2 = + ( user:portray(Struct2) :- + write('') + ), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + type_indexed_identifier_structure(IndexType,Struct3), + arg(1,Struct3,Label3), + type_indexed_identifier_name(IndexType,identifier_label,Name3), + Clause3 =.. [Name3,Struct3,Label3], + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + Goal3b =.. [Name3,S3b,L3b], + type_indexed_identifier_structure(IndexType,Struct3b), + arg(1,Struct3b,L3b), + Expansion3b = (S3b = Struct3b), + Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + identifier_store_name(IndexType,GlobalVariable), + lookup_identifier_atom(IndexType,X,IX,LookupAtom), + type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor), + NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX], + Clause4 = + ( LookupAtom :- + nb_getval(GlobalVariable,HT), + ( lookup_ht(HT,X,[IX]) -> + true + ; + NewIdentifierGoal, + insert_ht(HT,X,IX) + ) + ), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + lookup_only_identifier_atom(IndexType,Y,IY,LookupOnlyAtom), + Clause5 = + ( LookupOnlyAtom :- + nb_getval(GlobalVariable,HT0), + lookup_ht(HT0,Y,[IY]) + ), + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4,Clause5|T] + ; + L = T + ). + +constants_initializers(C,Index,Constants) :- + maplist(constant_initializer(C,Index),Constants). + +constant_initializer(C,Index,Constant) :- + constants_store_name(C,Index,Constant,StoreName), + prolog_global_variable(StoreName), + module_initializer(nb_setval(StoreName,[])). + +lookup_identifier_atom(Key,X,IX,Atom) :- + atom_concat('lookup_identifier_',Key,LookupFunctor), + Atom =.. [LookupFunctor,X,IX]. + +lookup_only_identifier_atom(Key,X,IX,Atom) :- + atom_concat('lookup_only_identifier_',Key,LookupFunctor), + Atom =.. [LookupFunctor,X,IX]. + +identifier_label_atom(IndexType,IX,X,Atom) :- + type_indexed_identifier_name(IndexType,identifier_label,Name), + Atom =.. [Name,IX,X]. + +multi_store_generate_attach_code([],_,L,L). +multi_store_generate_attach_code([ST|STs],C,L,T) :- + generate_attach_code(ST,C,L,L1), + multi_store_generate_attach_code(STs,C,L1,T). + +multi_inthash_store_initialisations([],_,L,L). +multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :- + use_auxiliary_module(chr_integertable_store), + multi_hash_store_name(FA,Index,StoreName), + module_initializer((new_iht(HT),nb_setval(StoreName,HT))), + % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1], + L1 = L, + multi_inthash_store_initialisations(Indexes,FA,L1,T). +multi_hash_store_initialisations([],_,L,L). +multi_hash_store_initialisations([Index|Indexes],FA,L,T) :- + use_auxiliary_module(chr_hashtable_store), + multi_hash_store_name(FA,Index,StoreName), + prolog_global_variable(StoreName), + make_init_store_goal(StoreName,HT,InitStoreGoal), + module_initializer((new_ht(HT),InitStoreGoal)), + L1 = L, + multi_hash_store_initialisations(Indexes,FA,L1,T). + +global_list_store_initialisation(C,L,T) :- + ( is_stored(C) -> + global_list_store_name(C,StoreName), + prolog_global_variable(StoreName), + make_init_store_goal(StoreName,[],InitStoreGoal), + module_initializer(InitStoreGoal) + ; + true + ), + L = T. +global_ground_store_initialisation(C,L,T) :- + global_ground_store_name(C,StoreName), + prolog_global_variable(StoreName), + make_init_store_goal(StoreName,[],InitStoreGoal), + module_initializer(InitStoreGoal), + L = T. +global_singleton_store_initialisation(C,L,T) :- + global_singleton_store_name(C,StoreName), + prolog_global_variable(StoreName), + make_init_store_goal(StoreName,[],InitStoreGoal), + module_initializer(InitStoreGoal), + L = T. +identifier_store_initialization(IndexType,L,T) :- + use_auxiliary_module(chr_hashtable_store), + identifier_store_name(IndexType,StoreName), + prolog_global_variable(StoreName), + make_init_store_goal(StoreName,HT,InitStoreGoal), + module_initializer((new_ht(HT),InitStoreGoal)), + L = T. + + +multi_inthash_via_lookups([],_,L,L). +multi_inthash_via_lookups([Index|Indexes],C,L,T) :- + multi_hash_lookup_head(C,Index,Key,SuspsList,Head), + multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body), + L = [(Head :- Body)|L1], + multi_inthash_via_lookups(Indexes,C,L1,T). +multi_hash_lookups([],_,L,L). +multi_hash_lookups([Index|Indexes],C,L,T) :- + multi_hash_lookup_head(C,Index,Key,SuspsList,Head), + multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body), + L = [(Head :- Body)|L1], + multi_hash_lookups(Indexes,C,L1,T). + +multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :- + multi_hash_lookup_name(ConstraintSymbol,Index,Name), + Head =.. [Name,Key,SuspsList]. + +%% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det. +% +% Returns goal that performs hash table lookup. +multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :- + % INLINED: + get_store_type(ConstraintSymbol,multi_store(Stores)), + ( memberchk(atomic_constants(Index,Constants,_),Stores) -> + ( ground(Key) -> + constants_store_name(ConstraintSymbol,Index,Key,StoreName), + Goal = nb_getval(StoreName,SuspsList) + ; + constants_store_index_name(ConstraintSymbol,Index,IndexName), + Lookup =.. [IndexName,Key,StoreName], + Goal = (Lookup, nb_getval(StoreName,SuspsList)) + ) + ; memberchk(ground_constants(Index,Constants,_),Stores) -> + ( ground(Key) -> + constants_store_name(ConstraintSymbol,Index,Key,StoreName), + Goal = nb_getval(StoreName,SuspsList) + ; + constants_store_index_name(ConstraintSymbol,Index,IndexName), + Lookup =.. [IndexName,Key,StoreName], + Goal = (Lookup, nb_getval(StoreName,SuspsList)) + ) + ; memberchk(multi_hash([Index]),Stores) -> + multi_hash_store_name(ConstraintSymbol,Index,StoreName), + make_get_store_goal(StoreName,HT,GetStoreGoal), + ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) -> + Goal = + ( + GetStoreGoal, % nb_getval(StoreName,HT), + HashCall, % hash_term(Key,Hash), + lookup_ht1(HT,Hash,Key,SuspsList) + ) + ; + lookup_hash_call(HashType,HT,Key,SuspsList,Lookup), + Goal = + ( + GetStoreGoal, % nb_getval(StoreName,HT), + Lookup + ) + ) + ; HashType == inthash -> + multi_hash_store_name(ConstraintSymbol,Index,StoreName), + make_get_store_goal(StoreName,HT,GetStoreGoal), + lookup_hash_call(HashType,HT,Key,SuspsList,Lookup), + Goal = + ( + GetStoreGoal, % nb_getval(StoreName,HT), + Lookup + ) + % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol]) + % find alternative index + % -> SubIndex + RestIndex + % -> SubKey + RestKeys + % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal), + % instantiate rest goal? + % Goal = (SubGoal,RestGoal) + ). + + +lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)). +lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)). + +specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :- + ( ground(Key) -> + % This is based on a property of SWI-Prolog's + % hash_term/2 predicate: + % the hash value is stable over repeated invocations + % of SWI-Prolog + hash_term(Key,Hash), + Call = true +% ; Index = [IndexPos], +% get_constraint_type(Constraint,ArgTypes), +% nth1(IndexPos,ArgTypes,Type), +% unalias_type(Type,NormalType), +% memberchk_eq(NormalType,[int,natural]) -> +% ( NormalType == int -> +% Call = (Hash is abs(Key)) +% ; +% Hash = Key, +% Call = true +% ) +% ; +% nonvar(Key), +% specialize_hash_term(Key,NewKey), +% NewKey \== Key, +% Call = hash_term(NewKey,Hash) + ). + +% specialize_hash_term(Term,NewTerm) :- +% ( ground(Term) -> +% hash_term(Term,NewTerm) +% ; var(Term) -> +% NewTerm = Term +% ; +% Term =.. [F|Args], +% maplist(specialize_hash_term,Args,NewArgs), +% NewTerm =.. [F|NewArgs] +% ). + +multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :- + % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]), + ( /* chr_pp_flag(experiment,off) -> + true + ; */ atomic(Key) -> + actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key]) + ; ground(Key) -> + actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key]) + ; + ( Index = [Pos], + get_constraint_arg_type(ConstraintSymbol,Pos,Type), + is_chr_constants_type(Type,_,_) + -> + true + ; + actual_non_ground_multi_hash_key(ConstraintSymbol,Index) + ) + ), + delay_phase_end(validate_store_type_assumptions, + multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)). + +:- chr_constraint actual_atomic_multi_hash_keys/3. +:- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)). + +:- chr_constraint actual_ground_multi_hash_keys/3. +:- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)). + +:- chr_constraint actual_non_ground_multi_hash_key/2. +:- chr_option(mode,actual_non_ground_multi_hash_key(+,+)). + +/* +actual_atomic_multi_hash_keys(C,Index,Keys) + ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]). + +actual_ground_multi_hash_keys(C,Index,Keys) + ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]). + +actual_non_ground_multi_hash_key(C,Index) + ==> format('Keys: ~w - ~w : N/A\n', [C,Index]). +*/ +actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2) + <=> append(Keys1,Keys2,Keys0), + sort(Keys0,Keys), + actual_atomic_multi_hash_keys(C,Index,Keys). + +actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2) + <=> append(Keys1,Keys2,Keys0), + sort(Keys0,Keys), + actual_ground_multi_hash_keys(C,Index,Keys). + +actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2) + <=> append(Keys1,Keys2,Keys0), + sort(Keys0,Keys), + actual_ground_multi_hash_keys(C,Index,Keys). + +actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index) + <=> true. + +actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_) + <=> true. + +actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_) + <=> true. + +%% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name) +% +% Returns predicate name of hash table lookup predicate. +multi_hash_lookup_name(F/A,Index,Name) :- + atom_concat_list(Index,IndexName), + atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name). + +multi_hash_store_name(F/A,Index,Name) :- + get_target_module(Mod), + atom_concat_list(Index,IndexName), + atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name). + +multi_hash_key(FA,Index,Susp,KeyBody,Key) :- + ( Index = [I] -> + get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody) + ; + maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies), + Key =.. [k|Keys], + list2conj(Bodies,KeyBody) + ). + +get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :- + get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal). + +multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :- + ( Index = [I] -> + get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody) + ; + maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies), + Key =.. [k|Keys], + list2conj(Bodies,KeyBody) + ). + +get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :- + arg(Index,Head,OriginalArg), + ( ground(OriginalArg), OriginalArg = '$chr_identifier_match'(Value,KeyType) -> + functor(Head,F,A), + lookup_identifier_atom(KeyType,Value,Arg,Goal) + ; term_variables(OriginalArg,OriginalVars), + copy_term_nat(OriginalArg-OriginalVars,Arg-Vars), + translate(OriginalVars,VarDict,Vars) -> + Goal = true + ; + functor(Head,F,A), + C = F/A, + get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal) + ). + +multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :- + ( Index = [I] -> + UsedVars = [I-Key] + ; + pairup(Index,Keys,UsedVars), + Key =.. [k|Keys] + ). + +args(Index,Head,KeyArgs) :- + maplist(arg1(Head),Index,KeyArgs). + +split_args(Indexes,Args,IArgs,NIArgs) :- + split_args(Indexes,Args,1,IArgs,NIArgs). + +split_args([],Args,_,[],Args). +split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :- + NJ is J + 1, + ( I == J -> + IArgs = [Arg|Rest], + split_args(Is,Args,NJ,Rest,NIArgs) + ; + NIArgs = [Arg|Rest], + split_args([I|Is],Args,NJ,IArgs,Rest) + ). + + +%------------------------------------------------------------------------------- +atomic_constants_code(C,Index,Constants,L,T) :- + constants_store_index_name(C,Index,IndexName), + maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses), + append(Clauses,T,L). + +atomic_constant_code(C,Index,IndexName,Constant,Clause) :- + constants_store_name(C,Index,Constant,StoreName), + Clause =.. [IndexName,Constant,StoreName]. + +%------------------------------------------------------------------------------- +ground_constants_code(C,Index,Terms,L,T) :- + constants_store_index_name(C,Index,IndexName), + maplist(constants_store_name(C,Index),Terms,StoreNames), + length(Terms,N), + replicate(N,[],More), + trie_index([Terms|More],StoreNames,IndexName,L,T). + +constants_store_name(F/A,Index,Term,Name) :- + get_target_module(Mod), + term_to_atom(Term,Constant), + term_to_atom(Index,IndexAtom), + atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name). + +constants_store_index_name(F/A,Index,Name) :- + get_target_module(Mod), + term_to_atom(Index,IndexAtom), + atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name). + +% trie index code {{{ +trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :- + trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail). + +trie_step([],_,_,[],[],L,L) :- !. + % length MorePatterns == length Patterns == length Results +trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :- + MorePatterns = [List|_], + length(List,N), + aggregate_all(set(F/A), + ( member(Pattern,Patterns), + functor(Pattern,F,A) + ), + FAs), + N1 is N + 1, + trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T). + +trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses). +trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :- + trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1), + trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail). + +trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :- + Clause = (Head :- Body), + /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */ + N1 is N + 1, + functor(Head,Symbol,N1), + arg(1,Head,IndexPattern), + Head =.. [_,_|RestArgs], + once(append(Vs,[Result],RestArgs)), + /* IndexPattern = F() */ + functor(IndexPattern,F,A), + IndexPattern =.. [_|Args], + append(Args,RestArgs,RecArgs), + ( RecArgs == [Result] -> + /* nothing more to match on */ + List = Tail, + Body = true, + rec_cases(Patterns,_,Results,F/A,_,_,MoreResults), + MoreResults = [Result] + ; /* more things to match on */ + rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults), + ( MoreCases = [OneMoreCase] -> + /* only one more thing to match on */ + List = Tail, + Body = true, + append([Cases,OneMoreCase,MoreResults],RecArgs) + ; + /* more than one thing to match on */ + /* [ x1,..., xn] + [xs1,...,xsn] + */ + pairup(Cases,MoreCases,CasePairs), + common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences), + append(Args,Vs,[First|Rest]), + First-Rest = CommonPatternPair, + % Body = RSymbol(DiffVars,Result) + fresh_symbol(Prefix,RSymbol), + append(DiffVars,[Result],RecCallVars), + Body =.. [RSymbol|RecCallVars], + maplist(head_tail,Differences,CHs,CTs), + trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail) + ) + ). + +:- chr_constraint symbol_count/2. +:- chr_constraint fresh_symbol/2. + +symbol_count(Atom,N), fresh_symbol(Atom,Symbol) <=> + atom_concat(Atom,N,Symbol), + M is N + 1, + symbol_count(Atom,M). + +fresh_symbol(Atom,Symbol) ==> + symbol_count(Atom,0). + +head_tail([H|T],H,T). + +rec_cases([],[],[],_,[],[],[]). +rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :- + ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) -> + Cases = [Case|NCases], + MoreCases = [MoreCase|NMoreCases], + MoreResults = [Result|NMoreResults], + rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults) + ; + rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults) + ). +% }}} + +%% common_pattern(+terms,-term,-vars,-differences) is det. +common_pattern(Ts,T,Vars,Differences) :- + fold1(chr_translate:gct,Ts,T), + term_variables(T,Vars), + findall(Vars,member(T,Ts),Differences). + +gct(T1,T2,T) :- + gct_(T1,T2,T,[],_). + +gct_(T1,T2,T,Dict0,Dict) :- + ( nonvar(T1), + nonvar(T2), + functor(T1,F1,A1), + functor(T2,F2,A2), + F1 == F2, + A1 == A2 -> + functor(T,F1,A1), + T1 =.. [_|Args1], + T2 =.. [_|Args2], + T =.. [_|Args], + maplist_dcg(chr_translate:gct_,Args1,Args2,Args,Dict0,Dict) + ; + /* T is a variable */ + ( lookup_eq(Dict0,T1+T2,T) -> + /* we already have a variable for this difference */ + Dict = Dict0 + ; + /* T is a fresh variable */ + Dict = [(T1+T2)-T|Dict0] + ) + ). + + +%------------------------------------------------------------------------------- +global_list_store_name(F/A,Name) :- + get_target_module(Mod), + atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name). +global_ground_store_name(F/A,Name) :- + get_target_module(Mod), + atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name). +global_singleton_store_name(F/A,Name) :- + get_target_module(Mod), + atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name). + +identifier_store_name(TypeName,Name) :- + get_target_module(Mod), + atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name). + +:- chr_constraint prolog_global_variable/1. +:- chr_option(mode,prolog_global_variable(+)). + +:- chr_constraint prolog_global_variables/1. +:- chr_option(mode,prolog_global_variables(-)). + +prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true. + +prolog_global_variables(List), prolog_global_variable(Name) <=> + List = [Name|Tail], + prolog_global_variables(Tail). +prolog_global_variables(List) <=> List = []. + +%% SWI begin +prolog_global_variables_code(Code) :- + prolog_global_variables(Names), + ( Names == [] -> + Code = [] + ; + maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations), + Code = [(:- dynamic user:exception/3), + (:- multifile user:exception/3), + (user:exception(undefined_global_variable,Name,retry) :- + ( + '$chr_prolog_global_variable'(Name), + '$chr_initialization' + ) + ) + | + NameDeclarations + ] + ). +%% SWI end +%% SICStus begin +% prolog_global_variables_code([]). +%% SICStus end +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%sbag_member_call(S,L,sysh:mem(S,L)). +sbag_member_call(S,L,'chr sbag_member'(S,L)). +%sbag_member_call(S,L,member(S,L)). +update_mutable_call(A,B,'chr update_mutable'( A, B)). +%update_mutable_call(A,B,setarg(1, B, A)). +create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value). +% create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)). + +% get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :- +% get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0), +% create_get_mutable(Value,Field,Get1). +% +% update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :- +% get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get), +% update_mutable_call(NewValue,Field,Set). +% +% get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :- +% get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0), +% create_get_mutable_ref(Value,Field,Get1), +% update_mutable_call(NewValue,Field,Set). +% +% create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :- +% get_static_suspension_term_field(FieldName,Constraint,Susp,Field), +% create_mutable_call(Value,Field,Create). +% +% get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :- +% get_static_suspension_term_field(FieldName,Constraint,Susp,Field), +% create_get_mutable(Value,Field,Get). +% +% get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :- +% get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field), +% create_get_mutable_ref(Value,Field,Get), +% update_mutable_call(NewValue,Field,Set). + +get_suspension_field(Constraint,Susp,FieldName,Value,Get) :- + get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get). + +update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :- + set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). + +get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :- + get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get), + set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). + +create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :- + get_static_suspension_term_field(FieldName,Constraint,Susp,Value). + +get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :- + get_static_suspension_term_field(FieldName,Constraint,Susp,Value). + +get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :- + get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value), + set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +enumerate_stores_code(Constraints,[Clause|List]) :- + Head = '$enumerate_constraints'(Constraint), + Clause = ( Head :- Body), + enumerate_store_bodies(Constraints,Constraint,List), + ( List = [] -> + Body = fail + ; + Body = ( nonvar(Constraint) -> + functor(Constraint,Functor,_), + '$enumerate_constraints'(Functor,Constraint) + ; + '$enumerate_constraints'(_,Constraint) + ) + ). + +enumerate_store_bodies([],_,[]). +enumerate_store_bodies([C|Cs],Constraint,L) :- + ( is_stored(C) -> + get_store_type(C,StoreType), + ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) -> + true + ; + chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C]) + ), + get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal), + C = F/_, + Constraint0 =.. [F|Arguments], + Head = '$enumerate_constraints'(F,Constraint), + Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0), + L = [(Head :- Body)|T] + ; + L = T + ), + enumerate_store_bodies(Cs,Constraint,T). + +enumerate_store_body(default,C,Susp,Body) :- + global_list_store_name(C,StoreName), + sbag_member_call(Susp,List,Sbag), + make_get_store_goal(StoreName,List,GetStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,List), + Sbag + ). +% get_constraint_index(C,Index), +% get_target_module(Mod), +% get_max_constraint_index(MaxIndex), +% Body1 = +% ( +% 'chr default_store'(GlobalStore), +% get_attr(GlobalStore,Mod,Attr) +% ), +% ( MaxIndex > 1 -> +% NIndex is Index + 1, +% sbag_member_call(Susp,List,Sbag), +% Body2 = +% ( +% arg(NIndex,Attr,List), +% Sbag +% ) +% ; +% sbag_member_call(Susp,Attr,Sbag), +% Body2 = Sbag +% ), +% Body = (Body1,Body2). +enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :- + multi_inthash_enumerate_store_body(Index,C,Susp,Body). +enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :- + multi_hash_enumerate_store_body(Index,C,Susp,Body). +enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :- + Completeness == complete, % fail if incomplete + maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts), + list2disj(Disjuncts, Disjunction), + Body = ( Disjunction, member(Susp,Susps) ). +enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :- + constants_store_name(C,Index,Constant,StoreName). + +enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :- + enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body). +enumerate_store_body(global_ground,C,Susp,Body) :- + global_ground_store_name(C,StoreName), + sbag_member_call(Susp,List,Sbag), + make_get_store_goal(StoreName,List,GetStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,List), + Sbag + ). +enumerate_store_body(var_assoc_store(_,_),C,_,Body) :- + Body = fail. +enumerate_store_body(global_singleton,C,Susp,Body) :- + global_singleton_store_name(C,StoreName), + make_get_store_goal(StoreName,Susp,GetStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,Susp), + Susp \== [] + ). +enumerate_store_body(multi_store(STs),C,Susp,Body) :- + ( memberchk(global_ground,STs) -> + enumerate_store_body(global_ground,C,Susp,Body) + ; + once(( + member(ST,STs), + enumerate_store_body(ST,C,Susp,Body) + )) + ). +enumerate_store_body(identifier_store(Index),C,Susp,Body) :- + Body = fail. +enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :- + Body = fail. + +multi_inthash_enumerate_store_body(I,C,Susp,B) :- + multi_hash_store_name(C,I,StoreName), + B = + ( + nb_getval(StoreName,HT), + value_iht(HT,Susp) + ). +multi_hash_enumerate_store_body(I,C,Susp,B) :- + multi_hash_store_name(C,I,StoreName), + make_get_store_goal(StoreName,HT,GetStoreGoal), + B = + ( + GetStoreGoal, % nb_getval(StoreName,HT), + value_ht(HT,Susp) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% BACKGROUND INFORMATION (declared using :- chr_declaration) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- chr_constraint + background_info/1, + background_info/2, + get_bg_info/1, + get_bg_info/2, + get_bg_info_answer/1. + +background_info(X), background_info(Y) <=> + append(X,Y,XY), background_info(XY). +background_info(X) \ get_bg_info(Q) <=> Q=X. +get_bg_info(Q) <=> Q = []. + +background_info(T,I), get_bg_info(A,Q) ==> + copy_term_nat(T,T1), + subsumes_chk(T1,A) + | + copy_term_nat(T-I,A-X), + get_bg_info_answer([X]). +get_bg_info_answer(X), get_bg_info_answer(Y) <=> + append(X,Y,XY), get_bg_info_answer(XY). + +get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id). +get_bg_info(_,Q) <=> Q=[]. % no info found on this term + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +:- chr_constraint + prev_guard_list/8, + prev_guard_list/6, + simplify_guards/1, + set_all_passive/1. + +:- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)). +:- chr_option(mode,prev_guard_list(+,+,+,+,+,+)). +:- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)). +:- chr_option(mode,simplify_guards(+)). +:- chr_option(mode,set_all_passive(+)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% GUARD SIMPLIFICATION +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% If the negation of the guards of earlier rules entails (part of) +% the current guard, the current guard can be simplified. We can only +% use earlier rules with a head that matches if the head of the current +% rule does, and which make it impossible for the current rule to match +% if they fire (i.e. they shouldn't be propagation rules and their +% head constraints must be subsets of those of the current rule). +% At this point, we know for sure that the negation of the guard +% of such a rule has to be true (otherwise the earlier rule would have +% fired, because of the refined operational semantics), so we can use +% that information to simplify the guard by replacing all entailed +% conditions by true/0. As a consequence, the never-stored analysis +% (in a further phase) will detect more cases of never-stored constraints. +% +% e.g. c(X),d(Y) <=> X > 0 | ... +% e(X) <=> X < 0 | ... +% c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ... +% \____________/ +% true + +guard_simplification :- + ( chr_pp_flag(guard_simplification,on) -> + precompute_head_matchings, + simplify_guards(1) + ; + true + ). + +% for every rule, we create a prev_guard_list where the last argument +% eventually is a list of the negations of earlier guards +rule(RuleNb,Rule) \ simplify_guards(RuleNb) + <=> + Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb), + append(Head1,Head2,Heads), + make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings), + tree_set_empty(Done), + multiple_occ_constraints_checked(Done), + apply_guard_wrt_term(Heads,Guard,SubstitutedHeads), + + append(IDs1,IDs2,IDs), + findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData), + empty_q(EmptyHeap), + insert_list_q(HeapData,EmptyHeap,Heap), + next_prev_rule(Heap,_,Heap1), + next_prev_rule(Heap1,PrevRuleNb,NHeap), + prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]), + NextRule is RuleNb+1, + simplify_guards(NextRule). + +next_prev_rule(Heap,RuleNb,NHeap) :- + ( find_min_q(Heap,_-Priority) -> + Priority = (-RuleNb), + normalize_heap(Heap,Priority,NHeap) + ; + RuleNb = 0, + NHeap = Heap + ). + +normalize_heap(Heap,Priority,NHeap) :- + ( find_min_q(Heap,_-Priority) -> + delete_min_q(Heap,Heap1,tuple(C,O,_)-_), + ( O > 1 -> + NO is O -1, + get_occurrence(C,NO,RuleNb,_), + insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2) + ; + Heap2 = Heap1 + ), + normalize_heap(Heap2,Priority,NHeap) + ; + NHeap = Heap + ). + +% no more rule +simplify_guards(_) + <=> + true. + +% The negation of the guard of a non-propagation rule is added +% if its kept head constraints are a subset of the kept constraints of +% the rule we're working on, and its removed head constraints (at least one) +% are a subset of the removed constraints. + +rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH) + <=> + PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb + H1 \== [], + make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings), + setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings) + | + append(H1,H2,Heads), + compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1), + append(GuardList,DerivedInfo,GL1), + normalize_conj_list(GL1,GL), + append(GH_New1,GH,GH1), + normalize_conj_list(GH1,GH_New), + next_prev_rule(Heap,PrevPrevRuleNb,NHeap), + % PrevPrevRuleNb is PrevRuleNb-1, + prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New). + +% if this isn't the case, we skip this one and try the next rule +prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH) + <=> + ( N > 0 -> + next_prev_rule(Heap,N1,NHeap), + % N1 is N-1, + prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH) + ; + prev_guard_list(RuleNb,H,G,GuardList,M,GH) + ). + +prev_guard_list(RuleNb,H,G,GuardList,M,GH) + <=> + GH \== [] + | + head_types_modes_condition(GH,H,TypeInfo), + conj2list(TypeInfo,TI), + term_variables(H,HeadVars), + append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info), + normalize_conj_list(Info,InfoL), + append(H,InfoL,RelevantTerms), + add_background_info([G|RelevantTerms],BGInfo), + append(InfoL,BGInfo,AllInfo_), + normalize_conj_list(AllInfo_,AllInfo), + prev_guard_list(RuleNb,H,G,AllInfo,M,[]). + +head_types_modes_condition([],H,true). +head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :- + types_modes_condition(H,GH,TI1), + head_types_modes_condition(GHs,H,TI2). + +add_background_info(Term,Info) :- + get_bg_info(GeneralInfo), + add_background_info2(Term,TermInfo), + append(GeneralInfo,TermInfo,Info). + +add_background_info2(X,[]) :- var(X), !. +add_background_info2([],[]) :- !. +add_background_info2([X|Xs],Info) :- !, + add_background_info2(X,Info1), + add_background_info2(Xs,Infos), + append(Info1,Infos,Info). + +add_background_info2(X,Info) :- + (functor(X,_,A), A>0 -> + X =.. [_|XArgs], + add_background_info2(XArgs,XArgInfo) + ; + XArgInfo = [] + ), + get_bg_info(X,XInfo), + append(XInfo,XArgInfo,Info). + +%% +% when all earlier guards are added or skipped, we simplify the guard. +% if it's different from the original one, we change the rule + +prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule) + <=> + Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), + G \== true, % let's not try to simplify this ;) + append(M,GuardList,Info), + (% if guard + context is a contradiction, it should be simplified to "fail" + conj2list(G,GL), append(Info,GL,GuardWithContext), + guard_entailment:entails_guard(GuardWithContext,fail) -> + SimpleGuard = fail + ; + % otherwise we try to remove redundant conjuncts + simplify_guard(G,B,Info,SimpleGuard,NB) + ), + G \== SimpleGuard % only do this if we can change the guard + | + rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)), + prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]). + +%% normalize_conj_list(+List,-NormalList) is det. +% +% Removes =true= elements and flattens out conjunctions. + +normalize_conj_list(List,NormalList) :- + list2conj(List,Conj), + conj2list(Conj,NormalList). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% AUXILIARY PREDICATES (GUARD SIMPLIFICATION) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]). +compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :- + copy_term(PrevMatchings-PrevGuard,FreshMatchings), + variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming), + append(Renaming1,ExtraRenaming,Renaming2), + list2conj(PrevMatchings,Match), + negate_b(Match,HeadsDontMatch), + make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch), + list2conj(HeadsMatch,HeadsMatchBut), + term_variables(Renaming2,RenVars), + term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars), + new_vars(MGVars,RenVars,ExtraRenaming2), + append(Renaming2,ExtraRenaming2,Renaming), + ( PrevGuard == true -> % true can't fail + Info_ = HeadsDontMatch + ; + negate_b(PrevGuard,TheGuardFailed), + Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed)) + ), + copy_with_variable_replacement(Info_,DerivedInfo1,Renaming), + copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming), + copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming), + list2conj(RenamedMatchings_,RenamedMatchings), + apply_guard_wrt_term(H,RenamedG2,GH2), + apply_guard_wrt_term(GH2,RenamedMatchings,GH3), + compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2). + +simplify_guard(G,B,Info,SG,NB) :- + conj2list(G,LG), + % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl, + guard_entailment:simplify_guards(Info,B,LG,SGL,NB), + list2conj(SGL,SG). + + +new_vars([],_,[]). +new_vars([A|As],RV,ER) :- + ( memberchk_eq(A,RV) -> + new_vars(As,RV,ER) + ; + ER = [A-NewA,NewA-A|ER2], + new_vars(As,RV,ER2) + ). + +%% head_subset(+Subset,+MultiSet,-Renaming) is nondet. +% +% check if a list of constraints is a subset of another list of constraints +% (multiset-subset), meanwhile computing a variable renaming to convert +% one into the other. +head_subset(H,Head,Renaming) :- + head_subset(H,Head,Renaming,[],_). + +head_subset([],Remainder,Renaming,Renaming,Remainder). +head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :- + head_member(MultiSet,X,NAcc,Acc,Remainder1), + head_subset(Xs,Remainder1,Renaming,NAcc,Remainder). + +% check if A is in the list, remove it from Headleft +head_member([X|Xs],A,Renaming,Acc,Remainder) :- + ( variable_replacement(A,X,Acc,Renaming), + Remainder = Xs + ; + Remainder = [X|RRemainder], + head_member(Xs,A,Renaming,Acc,RRemainder) + ). +%-------------------------------------------------------------------------------% +% memoing code to speed up repeated computation + +:- chr_constraint precompute_head_matchings/0. + +rule(RuleNb,PragmaRule), precompute_head_matchings ==> + PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), + append(H1,H2,Heads), + make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings), + copy_term_nat(MatchingFreeHeads-Matchings,A-B), + make_head_matchings_explicit_memo_table(RuleNb,A,B). + +precompute_head_matchings <=> true. + +:- chr_constraint make_head_matchings_explicit_memo_table/3. +:- chr_constraint make_head_matchings_explicit_memo_lookup/3. + +:- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)). +:- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)). + +make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \ + make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2) + <=> + Q1 = NHeads, + Q2 = Matchings. +make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail. + +make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :- + make_head_matchings_explicit_memo_lookup(RuleNb,A,B), + copy_term_nat(A-B,MatchingFreeHeads-Matchings). +%-------------------------------------------------------------------------------% + +make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :- + extract_arguments(Heads,Arguments), + make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings), + substitute_arguments(Heads,FreeVariables,MatchingFreeHeads). + +make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :- + extract_arguments(Heads,Arguments), + make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings), + substitute_arguments(Heads,FreshVariables,MatchingFreeHeads). + +make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :- + extract_arguments(Heads,Arguments1), + extract_arguments(MatchingFreeHeads,Arguments2), + make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings). + +%% extract_arguments(+ListOfConstraints,-ListOfVariables) is det. +% +% Returns list of arguments of given list of constraints. +extract_arguments([],[]). +extract_arguments([Constraint|Constraints],AllArguments) :- + Constraint =.. [_|Arguments], + append(Arguments,RestArguments,AllArguments), + extract_arguments(Constraints,RestArguments). + +%% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det. +% +% Substitutes arguments of constraints with those in the given list. + +substitute_arguments([],[],[]). +substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :- + functor(Constraint,F,N), + split_at(N,Variables,Arguments,RestVariables), + NConstraint =.. [F|Arguments], + substitute_arguments(Constraints,RestVariables,NConstraints). + +make_matchings_explicit([],[],_,MC,MC,[]). +make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :- + ( var(Arg) -> + ( memberchk_eq(Arg,VarAcc) -> + list2disj(MatchingCondition,MatchingCondition_disj), + Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ?? + NVarAcc = VarAcc + ; + Matchings = RestMatchings, + NewVar = Arg, + NVarAcc = [Arg|VarAcc] + ), + MatchingCondition2 = MatchingCondition + ; + functor(Arg,F,A), + Arg =.. [F|RecArgs], + make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings), + FlatArg =.. [F|RecVars], + ( RecMatchings == [] -> + Matchings = [functor(NewVar,F,A)|RestMatchings] + ; + list2conj(RecMatchings,ArgM_conj), + list2disj(MatchingCondition,MatchingCondition_disj), + ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj), + Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings] + ), + MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_], + term_variables(Args,ArgVars), + append(ArgVars,VarAcc,NVarAcc) + ), + make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings). + + +%% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det. +% +% Returns list of new variables and list of pairwise unifications between given list and variables. + +make_matchings_explicit_not_negated([],[],[]). +make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :- + Matchings = [Var = X|RMatchings], + make_matchings_explicit_not_negated(Xs,Vars,RMatchings). + +%% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det. +% +% (Partially) applies substitutions of =Goal= to given list. + +apply_guard_wrt_term([],_Guard,[]). +apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :- + ( var(Term) -> + apply_guard_wrt_variable(Guard,Term,NTerm) + ; + Term =.. [F|HArgs], + apply_guard_wrt_term(HArgs,Guard,NewHArgs), + NTerm =.. [F|NewHArgs] + ), + apply_guard_wrt_term(RH,Guard,RGH). + +%% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det. +% +% (Partially) applies goal =Guard= wrt variable. + +apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !, + apply_guard_wrt_variable(Guard1,Variable,NVariable1), + apply_guard_wrt_variable(Guard2,NVariable1,NVariable). +apply_guard_wrt_variable(Guard,Variable,NVariable) :- + ( Guard = (X = Y), Variable == X -> + NVariable = Y + ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) -> + functor(NVariable,Functor,Arity) + ; + NVariable = Variable + ). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% ALWAYS FAILING GUARDS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule) + ==> + chr_pp_flag(check_impossible_rules,on), + Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb), + conj2list(G,GL), + append(M,GuardList,Info), + append(Info,GL,GuardWithContext), + guard_entailment:entails_guard(GuardWithContext,fail) + | + chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]), + set_all_passive(RuleNb). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% HEAD SIMPLIFICATION +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% now we check the head matchings (guard may have been simplified meanwhile) +prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) + <=> + Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), + simplify_heads(M,GuardList,G,B,NewM,NewB), + NewM \== [], + extract_arguments(Head1,VH1), + extract_arguments(Head2,VH2), + extract_arguments(H,VH), + replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_), + substitute_arguments(Head1,H1,NewH1), + substitute_arguments(Head2,H2,NewH2), + append(NewB,NewB_,NewBody), + list2conj(NewBody,BodyMatchings), + NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb), + (Head1 \== NewH1 ; Head2 \== NewH2 ) + | + rule(RuleNb,NewRule). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% AUXILIARY PREDICATES (HEAD SIMPLIFICATION) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !. +replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !, + ( NH == M -> + H2_ = M, + replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB) + ; + (M = functor(X,F,A), NH == X -> + length(A_args,A), + (var(H2) -> + NewB1 = [], + H2_ =.. [F|A_args] + ; + H2 =.. [F|OrigArgs], + use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1), + H2_ =.. [F|A_args_] + ), + replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2), + append(NewB1,NewB2,NewB) + ; + H2_ = H2, + replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB) + ) + ). + +replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !, + ( NH == M -> + H1_ = M, + replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB) + ; + (M = functor(X,F,A), NH == X -> + length(A_args,A), + (var(H1) -> + NewB1 = [], + H1_ =.. [F|A_args] + ; + H1 =.. [F|OrigArgs], + use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1), + H1_ =.. [F|A_args_] + ), + replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2), + append(NewB1,NewB2,NewB) + ; + H1_ = H1, + replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB) + ) + ). + +use_same_args([],[],[],_,_,[]). +use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :- + var(OA),!, + Out = OA, + use_same_args(ROA,RNA,ROut,G,Body,NewB). +use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :- + nonvar(OA),!, + ( common_variables(OA,Body) -> + NewB = [NA = OA|NextB] + ; + NewB = NextB + ), + Out = NA, + use_same_args(ROA,RNA,ROut,G,Body,NextB). + + +simplify_heads([],_GuardList,_G,_Body,[],[]). +simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :- + M = (A = B), + ( (nonvar(B) ; common_variables(B,RM-GuardList)), + guard_entailment:entails_guard(GuardList,(A=B)) -> + ( common_variables(B,G-RM-GuardList) -> + NewB = NextB, + NewM = NextM + ; + ( common_variables(B,Body) -> + NewB = [A = B|NextB] + ; + NewB = NextB + ), + NewM = [A|NextM] + ) + ; + ( nonvar(B), functor(B,BFu,BAr), + guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) -> + NewB = NextB, + ( common_variables(B,G-RM-GuardList) -> + NewM = NextM + ; + NewM = [functor(A,BFu,BAr)|NextM] + ) + ; + NewM = NextM, + NewB = NextB + ) + ), + simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB). + +common_variables(B,G) :- + term_variables(B,BVars), + term_variables(G,GVars), + intersect_eq(BVars,GVars,L), + L \== []. + + +set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID). +set_all_passive(_) <=> true. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% OCCURRENCE SUBSUMPTION +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- chr_constraint + first_occ_in_rule/4, + next_occ_in_rule/6. + +:- chr_option(mode,first_occ_in_rule(+,+,+,+)). +:- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)). + +:- chr_constraint multiple_occ_constraints_checked/1. +:- chr_option(mode,multiple_occ_constraints_checked(+)). + +prev_guard_list(RuleNb,H,G,GuardList,M,[]), + occurrence(C,O,RuleNb,ID,_), + occurrence(C,O2,RuleNb,ID2,_), + rule(RuleNb,Rule) + \ + multiple_occ_constraints_checked(Done) + <=> + O < O2, + chr_pp_flag(occurrence_subsumption,on), + Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb + H1 \== [], + \+ tree_set_memberchk(C,Done) + | + first_occ_in_rule(RuleNb,C,O,ID), + tree_set_add(Done,C,NDone), + multiple_occ_constraints_checked(NDone). + +% Find first occurrence of constraint =C= in rule =RuleNb= +occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_) + <=> + O < O2 + | + first_occ_in_rule(RuleNb,C,O,ID). + +first_occ_in_rule(RuleNb,C,O,ID_o1) + <=> + C = F/A, + functor(FreshHead,F,A), + next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead). + +% Skip passive occurrences. +passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) + <=> + O2 is O+1 + | + next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH). + +prev_guard_list(RuleNb,H,G,GuardList,M,[]), occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) + <=> + O2 is O+1, + Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb) + | + append(H1,H2,Heads), + add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl), + ( ExtraCond == [chr_pp_void_info] -> + next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH) + ; + append(ExtraCond,Cond,NewCond), + add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2), + copy_term(GuardList,FGuardList), + variable_replacement(GuardList,FGuardList,GLRepl), + copy_with_variable_replacement(GuardList,GuardList2,Repl), + copy_with_variable_replacement(GuardList,GuardList3_,Repl2), + copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl), + append(NewCond,GuardList2,BigCond), + append(BigCond,GuardList3,BigCond2), + copy_with_variable_replacement(M,M2,Repl), + copy_with_variable_replacement(M,M3,Repl2), + append(M3,BigCond2,BigCond3), + append([chr_pp_active_constraint(FH)|M2],BigCond3,Info), + list2conj(CheckCond,OccSubsum), + copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)), + ( OccSubsum \= chr_pp_void_info -> + ( guard_entailment:entails_guard(Info2,OccSubsum2) -> + passive(RuleNb,ID_o2) + ; + true + ) + ; + true + ),!, + next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH) + ). + + +next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) + <=> + true. + +prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done) + <=> + true. + +add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :- + Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb), + append(ID2,ID1,IDs), + missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C), + copy_term((H,Heads,NH),(FH2,FHeads,NH2)), + variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl), + copy_with_variable_replacement(G,FG,Repl), + extract_explicit_matchings(FG,FG2), + negate_b(FG2,NotFG), + copy_with_variable_replacement(MPCond,FMPCond,Repl), + ( subsumes(FH,FH2) -> + FailCond = [(NotFG;FMPCond)] + ; + % in this case, not much can be done + % e.g. c(f(...)), c(g(...)) <=> ... + FailCond = [chr_pp_void_info] + ). + +missing_partner_cond([],[],[],ID_o1,fail,H2,C). +missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !, + missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C). +missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :- + Cond = (chr_pp_not_in_store(H);Cond1), + missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A). + +extract_explicit_matchings((A,B),D) :- !, + ( extract_explicit_matchings(A) -> + extract_explicit_matchings(B,D) + ; + D = (A,E), + extract_explicit_matchings(B,E) + ). +extract_explicit_matchings(A,D) :- !, + ( extract_explicit_matchings(A) -> + D = true + ; + D = A + ). + +extract_explicit_matchings(A=B) :- + var(A), var(B), !, A=B. +extract_explicit_matchings(A==B) :- + var(A), var(B), !, A=B. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% TYPE INFORMATION +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- chr_constraint + type_definition/2, + type_alias/2, + constraint_type/2, + get_type_definition/2, + get_constraint_type/2. + + +:- chr_option(mode,type_definition(?,?)). +:- chr_option(mode,get_type_definition(?,?)). +:- chr_option(mode,type_alias(?,?)). +:- chr_option(mode,constraint_type(+,+)). +:- chr_option(mode,get_constraint_type(+,-)). + +assert_constraint_type(Constraint,ArgTypes) :- + ( ground(ArgTypes) -> + constraint_type(Constraint,ArgTypes) + ; + chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint]) + ). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Consistency checks of type aliases + +type_alias(T1,T2) <=> + var(T1) + | + chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]). + +type_alias(T1,T2) <=> + var(T2) + | + chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]). + +type_alias(T,T2) <=> + functor(T,F,A), + functor(T2,F,A), + copy_term((T,T2),(X,Y)), subsumes(X,Y) + | + chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]). + +type_alias(T1,A1), type_alias(T2,A2) <=> + functor(T1,F,A), + functor(T2,F,A), + \+ (T1\=T2) + | + copy_term_nat(T1,T1_), + copy_term_nat(T2,T2_), + T1_ = T2_, + chr_error(type_error, + 'Ambiguous type aliases: you have defined \n\t`~w\'\n\t`~w\'\n\tresulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]). + +type_alias(T,B) \ type_alias(X,T2) <=> + functor(T,F,A), + functor(T2,F,A), + copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)), + subsumes(T1,T3) + | + % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]), + type_alias(X2,D1). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Consistency checks of type definitions + +type_definition(T1,_), type_definition(T2,_) + <=> + functor(T1,F,A), functor(T2,F,A) + | + chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]). + +type_definition(T1,_), type_alias(T2,_) + <=> + functor(T1,F,A), functor(T2,F,A) + | + chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%% get_type_definition(+Type,-Definition) is semidet. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +get_type_definition(T,Def) + <=> + \+ ground(T) + | + chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]). + +type_alias(T,D) \ get_type_definition(T2,Def) + <=> + nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), + copy_term_nat((T,D),(T1,D1)),T1=T2 + | + ( get_type_definition(D1,Def) -> + true + ; + chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail + ). + +type_definition(T,D) \ get_type_definition(T2,Def) + <=> + nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), + copy_term_nat((T,D),(T1,D1)),T1=T2 + | + Def = D1. + +get_type_definition(Type,Def) + <=> + atomic_builtin_type(Type,_,_) + | + Def = [Type]. + +get_type_definition(Type,Def) + <=> + compound_builtin_type(Type,_,_,_) + | + Def = [Type]. + +get_type_definition(X,Y) <=> fail. + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%% get_type_definition_det(+Type,-Definition) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +get_type_definition_det(Type,Definition) :- + ( get_type_definition(Type,Definition) -> + true + ; + chr_error(type,'Could not find type definition for type `~w\'.\n',[Type]) + ). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% get_constraint_type(+ConstraintSymbol,-Types) is semidet. +% +% Return argument types of =ConstraintSymbol=, but fails if none where +% declared. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T. +get_constraint_type(_,_) <=> fail. + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% get_constraint_type_det(+ConstraintSymbol,-Types) is det. +% +% Like =get_constraint_type/2=, but returns list of =any= types when +% no types are declared. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +get_constraint_type_det(ConstraintSymbol,Types) :- + ( get_constraint_type(ConstraintSymbol,Types) -> + true + ; + ConstraintSymbol = _ / N, + replicate(N,any,Types) + ). +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% unalias_type(+Alias,-Type) is det. +% +% Follows alias chain until base type is reached. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +:- chr_constraint unalias_type/2. + +unalias_var @ +unalias_type(Alias,BaseType) + <=> + var(Alias) + | + BaseType = Alias. + +unalias_alias @ +type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType) + <=> + nonvar(AliasProtoType), + nonvar(Alias), + functor(AliasProtoType,F,A), + functor(Alias,F,A), + copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)), + Alias = AliasInstance + | + unalias_type(Type,BaseType). + +unalias_type_definition @ +type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType) + <=> + nonvar(ProtoType), + nonvar(Alias), + functor(ProtoType,F,A), + functor(Alias,F,A) + | + BaseType = Alias. + +unalias_atomic_builtin @ +unalias_type(Alias,BaseType) + <=> + atomic_builtin_type(Alias,_,_) + | + BaseType = Alias. + +unalias_compound_builtin @ +unalias_type(Alias,BaseType) + <=> + compound_builtin_type(Alias,_,_,_) + | + BaseType = Alias. + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +:- chr_constraint types_modes_condition/3. +:- chr_option(mode,types_modes_condition(+,+,?)). +:- chr_option(type_declaration,types_modes_condition(list,list,goal)). + +types_modes_condition([],[],T) <=> T=true. + +constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition) + <=> + functor(Head,F,A) + | + Head =.. [_|Args], + Condition = (ModesCondition, TypesCondition, RestCondition), + modes_condition(Modes,Args,ModesCondition), + get_constraint_type_det(F/A,Types), + UnrollHead =.. [_|RealArgs], + types_condition(Types,Args,RealArgs,Modes,TypesCondition), + types_modes_condition(Heads,UnrollHeads,RestCondition). + +types_modes_condition([Head|_],_,_) + <=> + functor(Head,F,A), + chr_error(internal,'Mode information missing for ~w.\n',[F/A]). + + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% modes_condition(+Modes,+Args,-Condition) is det. +% +% Return =Condition= on =Args= that checks =Modes=. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +modes_condition([],[],true). +modes_condition([Mode|Modes],[Arg|Args],Condition) :- + ( Mode == (+) -> + Condition = ( ground(Arg) , RCondition ) + ; Mode == (-) -> + Condition = ( var(Arg) , RCondition ) + ; + Condition = RCondition + ), + modes_condition(Modes,Args,RCondition). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det. +% +% Return =Condition= on =Args= that checks =Types= given =Modes=. +% =UnrollArgs= controls the depth of type definition unrolling. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +types_condition([],[],[],[],true). +types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :- + ( Mode == (-) -> + TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition + ; + get_type_definition_det(Type,Def), + type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1), + ( Mode == (+) -> + TypeConditionList = TypeConditionList1 + ; + TypeConditionList = [(\+ ground(Arg))|TypeConditionList1] + ) + ), + list2disj(TypeConditionList,DisjTypeConditionList), + types_condition(Types,Args,UnrollArgs,Modes,RCondition). + +type_condition([],_,_,_,[]). +type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :- + ( var(DefCase) -> + chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true + ; atomic_builtin_type(DefCase,Arg,Condition) -> + true + ; compound_builtin_type(DefCase,Arg,Condition,_) -> + true + ; + type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) + ), + type_condition(DefCases,Arg,UnrollArg,Mode,Conditions). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +:- chr_type atomic_builtin_type ---> any + ; number + ; float + ; int + ; natural + ; dense_int + ; chr_identifier + ; chr_identifier(any) + ; /* all possible values are given + */ + chr_enum(list(any)) + ; /* all values of interest are given + for the other values a handler is provided */ + chr_enum(list(any),any) + ; /* all possible values appear in rule heads; + to distinguish between multiple chr_constants + we have a key*/ + chr_constants(any) + ; /* all relevant values appear in rule heads; + for other values a handler is provided */ + chr_constants(any,any). +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% + +ast_atomic_builtin_type(Type,AstTerm,Goal) :- + ast_term_to_term(AstTerm,Term), + atomic_builtin_type(Type,Term,Goal). + +ast_compound_builtin_type(Type,AstTerm,Goal) :- + ast_term_to_term(AstTerm,Term), + compound_builtin_type(Type,Term,_,Goal). + +atomic_builtin_type(any,_Arg,true). +atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)). +atomic_builtin_type(int,Arg,integer(Arg)). +atomic_builtin_type(number,Arg,number(Arg)). +atomic_builtin_type(float,Arg,float(Arg)). +atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)). +atomic_builtin_type(chr_identifier,_Arg,true). + +compound_builtin_type(chr_constants(_),_Arg,true,true). +compound_builtin_type(chr_constants(_,_),_Arg,true,true). +compound_builtin_type(chr_identifier(_),_Arg,true,true). +compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)), + once(( member(Constant,Constants), + unifiable(Arg,Constant,_) + ) + ) + ). +compound_builtin_type(chr_enum(_,_),Arg,true,true). + +is_chr_constants_type(chr_constants(Key),Key,no). +is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)). + +is_chr_enum_type(chr_enum(Constants), Constants, no). +is_chr_enum_type(chr_enum(Constants,Handler), Constants, yes(Handler)). + +type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :- + ( nonvar(DefCase) -> + functor(DefCase,F,A), + ( A == 0 -> + Condition = (Arg = DefCase) + ; var(UnrollArg) -> + Condition = functor(Arg,F,A) + ; functor(UnrollArg,F,A) -> + Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition), + DefCase =.. [_|ArgTypes], + UnrollArg =.. [_|UnrollArgs], + functor(Template,F,A), + Template =.. [_|TemplateArgs], + replicate(A,Mode,ArgModes), + types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition) + ; + Condition = functor(Arg,F,A) + ) + ; + chr_error(internal,'Illegal type definition (must be nonvar).\n',[]) + ). + + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% STATIC TYPE CHECKING +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Checks head constraints and CHR constraint calls in bodies. +% +% TODO: +% - type clashes involving built-in types +% - Prolog built-ins in guard and body +% - indicate position in terms in error messages +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +:- chr_constraint + static_type_check/2. + +% 1. Check the declared types + +constraint_type(Constraint,ArgTypes), static_type_check(_,_) + ==> + forall( + ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ), + ( get_type_definition(Type,_) -> + true + ; + chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint]) + ) + ). + +% 2. Check the rules + +:- chr_type type_error_src ---> head(any) ; body(any). + +static_type_check(PragmaRules,AstRules) + <=> + maplist(static_type_check_rule,PragmaRules,AstRules). + +static_type_check_rule(PragmaRule,AstRule) :- + AstRule = ast_rule(AstHead,_AstGuard,_Guard,AstBody,_Body), + ( + catch( + ( ast_static_type_check_head(AstHead), + ast_static_type_check_body(AstBody) + ), + type_error(Error), + ( Error = invalid_functor(Src,Term,Type) -> + chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n', + [chr_translate:format_src(Src),format_rule(PragmaRule),Term,Type]) + ; Error = type_clash(Var,Src1,Src2,Type1,Type2) -> + chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n', + [Var,format_rule(PragmaRule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)]) + ) + ), + fail % cleanup constraints + ; + true + ). + +%------------------------------------------------------------------------------% +% Static Type Checking: Head Constraints {{{ +ast_static_type_check_head(simplification(AstConstraints)) :- + maplist(ast_static_type_check_head_constraint,AstConstraints). +ast_static_type_check_head(propagation(AstConstraints)) :- + maplist(ast_static_type_check_head_constraint,AstConstraints). +ast_static_type_check_head(simpagation(AstConstraints1,AstConstraints2)) :- + maplist(ast_static_type_check_head_constraint,AstConstraints1), + maplist(ast_static_type_check_head_constraint,AstConstraints2). + +ast_static_type_check_head_constraint(AstConstraint) :- + AstConstraint = chr_constraint(Symbol,Arguments,_), + get_constraint_type_det(Symbol,Types), + maplist(ast_static_type_check_term(head(Head)),Arguments,Types). +% }}} +%------------------------------------------------------------------------------% +% Static Type Checking: Terms {{{ +:- chr_constraint ast_static_type_check_term/3. +:- chr_option(mode,ast_static_type_check_term(?,?,?)). +:- chr_option(type_declaration,ast_static_type_check_term(type_error_src,any,any)). + +ast_static_type_check_term(_,_,any) + <=> + true. + +ast_static_type_check_term(Src,var(Id,Var),Type) + <=> + ast_static_type_check_var(Id,var(Id,Var),Type,Src). + +ast_static_type_check_term(Src,Term,Type) + <=> + ast_atomic_builtin_type(Type,Term,Goal) + | + ( call(Goal) -> + true + ; + throw(type_error(invalid_functor(Src,Term,Type))) + ). +ast_static_type_check_term(Src,Term,Type) + <=> + ast_compound_builtin_type(Type,Term,Goal) + | + ( call(Goal) -> + true + ; + throw(type_error(invalid_functor(Src,Term,Type))) + ). +type_alias(AType,ADef) \ ast_static_type_check_term(Src,Term,Type) + <=> + functor(Type,F,A), + functor(AType,F,A) + | + copy_term_nat(AType-ADef,Type-Def), + ast_static_type_check_term(Src,Term,Def). + +type_definition(AType,ADef) \ ast_static_type_check_term(Src,Term,Type) + <=> + functor(Type,F,A), + functor(AType,F,A) + | + copy_term_nat(AType-ADef,Type-Variants), + ast_functor(Term,TF,TA), + ( member(Variant,Variants), functor(Variant,TF,TA) -> + ast_args(Term,Args), + Variant =.. [_|Types], + maplist(ast_static_type_check_term(Src),Args,Types) + ; + throw(type_error(invalid_functor(Src,Term,Type))) + ). + +ast_static_type_check_term(Src,Term,Type) + <=> + chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]). +% }}} +%------------------------------------------------------------------------------% +% Static Type Checking: Variables {{{ + +:- chr_constraint ast_static_type_check_var/4. +:- chr_option(mode,ast_static_type_check_var(+,?,?,?)). +:- chr_option(type_declaration,ast_static_type_check_var(var_id,any,any,type_error_src)). + +type_alias(AType,ADef) \ ast_static_type_check_var(VarId,Var,Type,Src) + <=> + functor(AType,F,A), + functor(Type,F,A) + | + copy_term_nat(AType-ADef,Type-Def), + ast_static_type_check_var(VarId,Var,Def,Src). + +ast_static_type_check_var(VarId,Var,Type,Src) + <=> + atomic_builtin_type(Type,_,_) + | + ast_static_atomic_builtin_type_check_var(VarId,Var,Type,Src). + +ast_static_type_check_var(VarId,Var,Type,Src) + <=> + compound_builtin_type(Type,_,_,_) + | + true. + + +ast_static_type_check_var(VarId,Var,Type1,Src1), ast_static_type_check_var(VarId,_Var,Type2,Src2) + <=> + Type1 \== Type2 + | + throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +:- chr_constraint ast_static_atomic_builtin_type_check_var/4. +:- chr_option(mode,ast_static_atomic_builtin_type_check_var(+,?,+,?)). +:- chr_option(type_declaration,ast_static_atomic_builtin_type_check_var(var_id,any,atomic_builtin_type,type_error_src)). + +ast_static_atomic_builtin_type_check_var(_,_,any,_) <=> true. +ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,float,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) + <=> + true. +ast_static_atomic_builtin_type_check_var(VarId,Var,Type1,Src1), ast_static_atomic_builtin_type_check_var(VarId,_Var,Type2,Src2) + <=> + throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))). +% }}} +%------------------------------------------------------------------------------% +% Static Type Checking: Bodies {{{ +ast_static_type_check_body([]). +ast_static_type_check_body([Goal|Goals]) :- + ast_symbol(Goal,Symbol), + get_constraint_type_det(Symbol,Types), + ast_args(Goal,Args), + maplist(ast_static_type_check_term(body(Goal)),Args,Types), + ast_static_type_check_body(Goals). + +% }}} +%------------------------------------------------------------------------------% + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% format_src(+type_error_src) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +format_src(head(Head)) :- format('head ~w',[Head]). +format_src(body(Goal)) :- format('body goal ~w',[Goal]). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Dynamic type checking +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:- chr_constraint + dynamic_type_check/0, + dynamic_type_check_clauses/1, + get_dynamic_type_check_clauses/1. + +generate_dynamic_type_check_clauses(Clauses) :- + ( chr_pp_flag(debugable,on) -> + dynamic_type_check, + get_dynamic_type_check_clauses(Clauses0), + append(Clauses0, + [('$dynamic_type_check'(Type,Term) :- + throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error'))) + )], + Clauses) + ; + Clauses = [] + ). + +type_definition(T,D), dynamic_type_check + ==> + copy_term_nat(T-D,Type-Definition), + maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks), + dynamic_type_check_clauses(DynamicChecks). +type_alias(A,B), dynamic_type_check + ==> + copy_term_nat(A-B,Alias-Body), + dynamic_type_check_alias_clause(Alias,Body,Clause), + dynamic_type_check_clauses([Clause]). + +dynamic_type_check <=> + findall( + ('$dynamic_type_check'(Type,Term) :- Goal), + ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ), + BuiltinChecks + ), + dynamic_type_check_clauses(BuiltinChecks). + +dynamic_type_check_clause(T,DC,Clause) :- + copy_term(T-DC,Type-DefinitionClause), + functor(DefinitionClause,F,A), + functor(Term,F,A), + DefinitionClause =.. [_|DCArgs], + Term =.. [_|TermArgs], + maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList), + list2conj(RecursiveCallList,RecursiveCalls), + Clause = ( + '$dynamic_type_check'(Type,Term) :- + RecursiveCalls + ). + +dynamic_type_check_alias_clause(Alias,Body,Clause) :- + Clause = ( + '$dynamic_type_check'(Alias,Term) :- + '$dynamic_type_check'(Body,Term) + ). + +dynamic_type_check_call(Type,Term,Call) :- + % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) -> + % Call = when(nonvar(Term),Goal) + % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) -> + % Call = when(nonvar(Term),Goal) + % ; + ( Type == any -> + Call = true + ; + Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term))) + ) + % ) + . + +dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2) + <=> + append(C1,C2,C), + dynamic_type_check_clauses(C). + +get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C) + <=> + Q = C. +get_dynamic_type_check_clauses(Q) + <=> + Q = []. + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Atomic Types +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Some optimizations can be applied for atomic types... +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +atomic_types_suspended_constraint(C) :- + C = _/N, + get_constraint_type(C,ArgTypes), + get_constraint_mode(C,ArgModes), + numlist(1,N,Indexes), + maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes). + +atomic_types_suspended_constraint(C,Type,Mode,Index) :- + ( is_indexed_argument(C,Index) -> + ( Mode == (?) -> + atomic_type(Type) + ; + true + ) + ; + true + ). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% atomic_type(+Type) is semidet. +% +% Succeeds when all values of =Type= are atomic. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +:- chr_constraint atomic_type/1. + +atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any. + +type_definition(TypePat,Def) \ atomic_type(Type) + <=> + functor(Type,F,A), functor(TypePat,F,A) + | + maplist(atomic,Def). + +type_alias(TypePat,Alias) \ atomic_type(Type) + <=> + functor(Type,F,A), functor(TypePat,F,A) + | + atomic(Alias), + copy_term_nat(TypePat-Alias,Type-NType), + atomic_type(NType). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% enumerated_atomic_type(+Type,-Atoms) is semidet. +% +% Succeeds when all values of =Type= are atomic +% and the atom values are finitely enumerable. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +:- chr_constraint enumerated_atomic_type/2. + +enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail. + +type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms) + <=> + functor(Type,F,A), functor(TypePat,F,A) + | + maplist(atomic,Def), + Atoms = Def. + +type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms) + <=> + functor(Type,F,A), functor(TypePat,F,A) + | + atomic(Alias), + copy_term_nat(TypePat-Alias,Type-NType), + enumerated_atomic_type(NType,Atoms). + +enumerated_atomic_type(_,_) + <=> + fail. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- chr_constraint + stored/3, % constraint,occurrence,(yes/no/maybe) + stored_completing/3, + stored_complete/3, + is_stored/1, + is_finally_stored/1, + check_all_passive/2. + +:- chr_option(mode,stored(+,+,+)). +:- chr_option(type_declaration,stored(any,int,storedinfo)). +:- chr_type storedinfo ---> yes ; no ; maybe. +:- chr_option(mode,stored_complete(+,+,+)). +:- chr_option(mode,maybe_complementary_guards(+,+,?,?)). +:- chr_option(mode,guard_list(+,+,+,+)). +:- chr_option(mode,check_all_passive(+,+)). +:- chr_option(type_declaration,check_all_passive(any,list)). + +% change yes in maybe when yes becomes passive +passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \ + stored(C,O,yes), stored_complete(C,RO,Yesses) + <=> O < RO | NYesses is Yesses - 1, + stored(C,O,maybe), stored_complete(C,RO,NYesses). +% change yes in maybe when not observed +ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses) + <=> O < RO | + NYesses is Yesses - 1, + stored(C,O,maybe), stored_complete(C,RO,NYesses). + +occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2) + ==> RO =< MO2 | % C2 is never stored + passive(RuleNb,ID). + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +rule(RuleNb,Rule),passive(RuleNb,Id) ==> + Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) | + append(IDs1,IDs2,I), check_all_passive(RuleNb,I). + +rule(RuleNb,Rule),passive(RuleNb,Id) ==> + Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) | + check_all_passive(RuleNb,IDs2). + +passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=> + check_all_passive(RuleNb,IDs). + +rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=> + chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% collect the storage information +stored(C,O,yes) \ stored_completing(C,O,Yesses) + <=> NO is O + 1, NYesses is Yesses + 1, + stored_completing(C,NO,NYesses). +stored(C,O,maybe) \ stored_completing(C,O,Yesses) + <=> NO is O + 1, + stored_completing(C,NO,Yesses). + +stored(C,O,no) \ stored_completing(C,O,Yesses) + <=> stored_complete(C,O,Yesses). +stored_completing(C,O,Yesses) + <=> stored_complete(C,O,Yesses). + +stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==> + O2 > O | passive(RuleNb,Id). + +% decide whether a constraint is stored +max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C) + <=> RO =< MO | fail. +is_stored(C) <=> true. + +% decide whether a constraint is suspends after occurrences +max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C) + <=> RO =< MO | fail. +is_finally_stored(C) <=> true. + +storage_analysis(Constraints) :- + ( chr_pp_flag(storage_analysis,on) -> + check_constraint_storages(Constraints) + ; + true + ). + +check_constraint_storages(Symbols) :- maplist(check_constraint_storage,Symbols). + +check_constraint_storage(C) :- + get_max_occurrence(C,MO), + check_occurrences_storage(C,1,MO). + +check_occurrences_storage(C,O,MO) :- + ( O > MO -> + stored_completing(C,1,0) + ; + check_occurrence_storage(C,O), + NO is O + 1, + check_occurrences_storage(C,NO,MO) + ). + +check_occurrence_storage(C,O) :- + get_occurrence(C,O,RuleNb,ID,OccType), + ( is_passive(RuleNb,ID) -> + stored(C,O,maybe) + ; + get_rule(RuleNb,PragmaRule), + PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_), + ( OccType == simplification, select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> + check_storage_head1(Head1,O,Heads1,Heads2,Guard) + ; OccType == propagation, select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> + check_storage_head2(Head2,O,Heads1,Body) + ) + ). + +check_storage_head1(Head,O,H1,H2,G) :- + functor(Head,F,A), + C = F/A, + ( H1 == [Head], + H2 == [], + % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl, + guard_entailment:entails_guard([chr_pp_headvariables(Head)],G), + Head =.. [_|L], + no_matching(L,[]) -> + stored(C,O,no) + ; + stored(C,O,maybe) + ). + +no_matching([],_). +no_matching([X|Xs],Prev) :- + var(X), + \+ memberchk_eq(X,Prev), + no_matching(Xs,[X|Prev]). + +check_storage_head2(Head,O,H1,B) :- + functor(Head,F,A), + C = F/A, + ( %( + ( H1 \== [], B == true ) + %; + % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet + %) + -> + stored(C,O,maybe) + ; + stored(C,O,yes) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ _ _ +%% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __ +%% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \ +%% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | | +%% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_| +%% |_| + +constraints_code(Constraints,Clauses) :- + (chr_pp_flag(reduced_indexing,on), + forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) -> + none_suspended_on_variables + ; + true + ), + constraints_code1(Constraints,Clauses,[]). + +%=============================================================================== +:- chr_constraint constraints_code1/3. +:- chr_option(mode,constraints_code1(+,+,+)). +:- chr_option(type_declaration,constraints_code1(list,any,any)). +%------------------------------------------------------------------------------- +constraints_code1([],L,T) <=> L = T. +constraints_code1([C|RCs],L,T) + <=> + constraint_code(C,L,T1), + constraints_code1(RCs,T1,T). +%=============================================================================== +:- chr_constraint constraint_code/3. +:- chr_option(mode,constraint_code(+,+,+)). +%------------------------------------------------------------------------------- +%% Generate code for a single CHR constraint +constraint_code(Constraint, L, T) + <=> true + | ( (chr_pp_flag(debugable,on) ; + is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)), + ( may_trigger(Constraint) ; + get_allocation_occurrence(Constraint,AO), + get_max_occurrence(Constraint,MO), MO >= AO ) ) + -> + constraint_prelude(Constraint,Clause), + add_dummy_location(Clause,LocatedClause), + L = [LocatedClause | L1] + ; + L = L1 + ), + Id = [0], + occurrences_code(Constraint,1,Id,NId,L1,L2), + gen_cond_attach_clause(Constraint,NId,L2,T). + +%=============================================================================== +%% Generate prelude predicate for a constraint. +%% f(...) :- f/a_0(...,Susp). +constraint_prelude(F/A, Clause) :- + vars_susp(A,Vars,Susp,VarsSusp), + Head =.. [ F | Vars], + make_suspension_continuation_goal(F/A,VarsSusp,Continuation), + build_head(F,A,[0],VarsSusp,Delegate), + ( chr_pp_flag(debugable,on) -> + insert_constraint_goal(F/A,Susp,Vars,InsertCall), + attach_constraint_atom(F/A,Vars2,Susp,AttachCall), + delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)), + insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal), + + ( get_constraint_type(F/A,ArgTypeList) -> + maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList), + list2conj(DynamicTypeCheckList,DynamicTypeChecks) + ; + DynamicTypeChecks = true + ), + + Clause = + ( Head :- + DynamicTypeChecks, + InsertGoal, + InsertCall, + AttachCall, + Inactive, + 'chr debug_event'(insert(Head#Susp)), + ( + 'chr debug_event'(call(Susp)), + Delegate + ; + 'chr debug_event'(fail(Susp)), !, + fail + ), + ( + 'chr debug_event'(exit(Susp)) + ; + 'chr debug_event'(redo(Susp)), + fail + ) + ) + ; get_allocation_occurrence(F/A,0) -> + gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp), + delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)), + Clause = ( Head :- Goal, Inactive, Delegate ) + ; + Clause = ( Head :- Delegate ) + ). + +make_suspension_continuation_goal(F/A,VarsSusp,Goal) :- + ( may_trigger(F/A) -> + build_head(F,A,[0],VarsSusp,Delegate), + ( chr_pp_flag(debugable,off) -> + Goal = Delegate + ; + get_target_module(Mod), + Goal = Mod:Delegate + ) + ; + Goal = true + ). + +%=============================================================================== +:- chr_constraint has_active_occurrence/1, has_active_occurrence/2. +:- chr_option(mode,has_active_occurrence(+)). +:- chr_option(mode,has_active_occurrence(+,+)). + +:- chr_constraint memo_has_active_occurrence/1. +:- chr_option(mode,memo_has_active_occurrence(+)). +%------------------------------------------------------------------------------- +memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true. +has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C). + +max_occurrence(C,MO) \ has_active_occurrence(C,O) <=> + O > MO | fail. +passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \ + has_active_occurrence(C,O) <=> + NO is O + 1, + has_active_occurrence(C,NO). +has_active_occurrence(C,O) <=> true. +%=============================================================================== + +gen_cond_attach_clause(F/A,Id,L,T) :- + ( is_finally_stored(F/A) -> + get_allocation_occurrence(F/A,AllocationOccurrence), + get_max_occurrence(F/A,MaxOccurrence), + ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence -> + ( only_ground_indexed_arguments(F/A) -> + gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp) + ; + gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp) + ) + ; vars_susp(A,Args,Susp,AllArgs), + gen_uncond_attach_goal(F/A,Susp,Args,Body,_) + ), + build_head(F,A,Id,AllArgs,Head), + Clause = ( Head :- Body ), + add_dummy_location(Clause,LocatedClause), + L = [LocatedClause | T] + ; + L = T + ). + +:- chr_constraint use_auxiliary_predicate/1. +:- chr_option(mode,use_auxiliary_predicate(+)). + +:- chr_constraint use_auxiliary_predicate/2. +:- chr_option(mode,use_auxiliary_predicate(+,+)). + +:- chr_constraint is_used_auxiliary_predicate/1. +:- chr_option(mode,is_used_auxiliary_predicate(+)). + +:- chr_constraint is_used_auxiliary_predicate/2. +:- chr_option(mode,is_used_auxiliary_predicate(+,+)). + + +use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true. + +use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true. + +use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true. + +use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true. + +is_used_auxiliary_predicate(P) <=> fail. + +use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true. +use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true. + +is_used_auxiliary_predicate(P,C) <=> fail. + +%------------------------------------------------------------------------------% +% Only generate import statements for actually used modules. +%------------------------------------------------------------------------------% + +:- chr_constraint use_auxiliary_module/1. +:- chr_option(mode,use_auxiliary_module(+)). + +:- chr_constraint is_used_auxiliary_module/1. +:- chr_option(mode,is_used_auxiliary_module(+)). + + +use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true. + +use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true. + +is_used_auxiliary_module(P) <=> fail. + + % only called for constraints with + % at least one + % non-ground indexed argument +gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :- + vars_susp(A,Args,Susp,AllArgs), + make_suspension_continuation_goal(F/A,AllArgs,Closure), + ( get_store_type(F/A,var_assoc_store(_,_)) -> + Attach = true + ; + attach_constraint_atom(F/A,Vars,Susp,Attach) + ), + FTerm =.. [F|Args], + insert_constraint_goal(F/A,Susp,Args,InsertCall), + insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal), + ( may_trigger(F/A) -> + activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal), + Goal = + ( + ( var(Susp) -> + InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args) + InsertCall, + Attach + ; + ActivateGoal % activate_constraint(Stored,Vars,Susp,_) + ) + ) + ; + Goal = + ( + InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args), + InsertCall, + Attach + ) + ). + +gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :- + vars_susp(A,Args,Susp,AllArgs), + make_suspension_continuation_goal(F/A,AllArgs,Cont), + ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) -> + attach_constraint_atom(F/A,Vars,Susp,Attach) + ; + Attach = true + ), + FTerm =.. [F|Args], + insert_constraint_goal(F/A,Susp,Args,InsertCall), + insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal), + ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) -> + Goal = + ( + InsertInternalGoal, % insert_constraint_internal(Susp,F,Args), + InsertCall + ) + ; + Goal = + ( + InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args), + InsertCall, + Attach + ) + ). + +gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :- + ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) -> + attach_constraint_atom(FA,Vars,Susp,Attach) + ; + Attach = true + ), + insert_constraint_goal(FA,Susp,Args,InsertCall), + ( chr_pp_flag(late_allocation,on) -> + activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal) + ; + activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal) + ). + +%------------------------------------------------------------------------------- +:- chr_constraint occurrences_code/6. +:- chr_option(mode,occurrences_code(+,+,+,+,+,+)). +%------------------------------------------------------------------------------- +max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T) + <=> O > MO + | NId = Id, L = T. +occurrences_code(C,O,Id,NId,L,T) + <=> + occurrence_code(C,O,Id,Id1,L,L1), + NO is O + 1, + occurrences_code(C,NO,Id1,NId,L1,T). +%------------------------------------------------------------------------------- +:- chr_constraint occurrence_code/6. +:- chr_option(mode,occurrence_code(+,+,+,+,+,+)). +%------------------------------------------------------------------------------- +occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T) + <=> + ( named_history(RuleNb,_,_) -> + does_use_history(C,O) + ; + true + ), + NId = Id, + L = T. +occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T) + <=> true | + PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_), + ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> + NId = Id, + head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T) + ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> + + head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1), + ( should_skip_to_next_id(C,O) -> + inc_id(Id,NId), + ( unconditional_occurrence(C,O) -> + L1 = T + ; + gen_alloc_inc_clause(C,O,Id,L1,T) + ) + ; + NId = Id, + L1 = T + ) + ). + +occurrence_code(C,O,_,_,_,_) + <=> + chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]). +%------------------------------------------------------------------------------- + +%% Generate code based on one removed head of a CHR rule +head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_Name,RuleNb), + Rule = rule(_,Head2,_,_), + ( Head2 == [] -> + reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), + simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T) + ; + simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) + ). + +%% Generate code based on one persistent head of a CHR rule +head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_Name,RuleNb), + Rule = rule(Head1,_,_,_), + ( Head1 == [] -> + reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), + propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T) + ; + simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) + ). + +gen_alloc_inc_clause(F/A,O,Id,L,T) :- + vars_susp(A,Vars,Susp,VarsSusp), + build_head(F,A,Id,VarsSusp,Head), + inc_id(Id,IncId), + build_head(F,A,IncId,VarsSusp,CallHead), + gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc), + Clause = + ( + Head :- + ConditionalAlloc, + CallHead + ), + add_dummy_location(Clause,LocatedClause), + L = [LocatedClause|T]. + +gen_occ_allocation(FA,O,Vars,Susp,Goal) :- + get_allocation_occurrence(FA,AO), + get_occurrence_code_id(FA,AO,AId), + get_occurrence_code_id(FA,O,Id), + ( chr_pp_flag(debugable,off), Id == AId -> + allocate_constraint_goal(FA,Susp,Vars,Goal0), + ( may_trigger(FA) -> + Goal = (var(Susp) -> Goal0 ; true) + ; + Goal = Goal0 + ) + ; + Goal = true + ). + +gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :- + get_allocation_occurrence(FA,AO), + ( chr_pp_flag(debugable,off), O < AO -> + allocate_constraint_goal(FA,Susp,Vars,Goal0), + ( may_trigger(FA) -> + Goal = (var(Susp) -> Goal0 ; true) + ; + Goal = Goal0 + ) + ; + Goal = true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Reorders guard goals with respect to partner constraint retrieval goals and +% active constraint. Returns combined partner retrieval + guard goal. + +guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :- + ( chr_pp_flag(guard_via_reschedule,on) -> + guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton), + list2conj(ScheduleSkeleton,GoalSkeleton) + ; + length(Retrievals,RL), length(LookupSkeleton,RL), + length(GuardList,GL), length(GuardListSkeleton,GL), + append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton), + list2conj(GoalListSkeleton,GoalSkeleton) + ). +guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead, + GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :- + initialize_unit_dictionary(ActiveHead,Dict), + maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups), + maplist(wrap_in_functor(guard),GuardList,WrappedGuardList), + build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units), + dependency_reorder(Units,NUnits), + wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton), + sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton), + snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton). + +wrappedunits2lists([],[],[],[]). +wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :- + Ss = [GoalCopy|TSs], + ( WrappedGoal = lookup(Goal) -> + Ls = [GoalCopy|TLs], + Gs = TGs + ; WrappedGoal = guard(Goal) -> + Gs = [N-GoalCopy|TGs], + Ls = TLs + ), + wrappedunits2lists(Units,TGs,TLs,TSs). + +guard_splitting(Rule,SplitGuardList) :- + Rule = rule(H1,H2,Guard,_), + append(H1,H2,Heads), + conj2list(Guard,GuardList), + term_variables(Heads,HeadVars), + split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList), + append(GuardPrefix,[RestGuard],SplitGuardList), + term_variables(RestGuardList,GuardVars1), + % variables that are declared to be ground don't need to be locked + ground_vars(Heads,GroundVars), + list_difference_eq(HeadVars,GroundVars,LockableHeadVars), + intersect_eq(LockableHeadVars,GuardVars1,GuardVars), + maplist(chr_lock,GuardVars,Locks), + maplist(chr_unlock,GuardVars,Unlocks), + list2conj(Locks,LockPhase), + list2conj(Unlocks,UnlockPhase), + list2conj(RestGuardList,RestGuard1), + RestGuard = (LockPhase,(RestGuard1,UnlockPhase)). + +guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :- + Rule = rule(_,_,_,Body), + my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList), + my_term_copy(Body,VarDict2,BodyCopy). + + +split_off_simple_guard_new([],_,[],[]). +split_off_simple_guard_new([G|Gs],VarDict,S,C) :- + ( simple_guard_new(G,VarDict) -> + S = [G|Ss], + split_off_simple_guard_new(Gs,VarDict,Ss,C) + ; + S = [], + C = [G|Gs] + ). + +% simple guard: cheap and benign (does not bind variables) +simple_guard_new(G,Vars) :- + builtin_binds_b(G,BoundVars), + not(( member(V,BoundVars), + memberchk_eq(V,Vars) + )). + +dependency_reorder(Units,NUnits) :- + dependency_reorder(Units,[],NUnits). + +dependency_reorder([],Acc,Result) :- + reverse(Acc,Result). + +dependency_reorder([Unit|Units],Acc,Result) :- + Unit = unit(_GID,_Goal,Type,GIDs), + ( Type == fixed -> + NAcc = [Unit|Acc] + ; + dependency_insert(Acc,Unit,GIDs,NAcc) + ), + dependency_reorder(Units,NAcc,Result). + +dependency_insert([],Unit,_,[Unit]). +dependency_insert([X|Xs],Unit,GIDs,L) :- + X = unit(GID,_,_,_), + ( memberchk(GID,GIDs) -> + L = [Unit,X|Xs] + ; + L = [X | T], + dependency_insert(Xs,Unit,GIDs,T) + ). + +build_units(Retrievals,Guard,InitialDict,Units) :- + build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail), + build_guard_units(Guard,N,Dict,Tail). + +build_retrieval_units([],N,N,Dict,Dict,L,L). +build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :- + term_variables(U,Vs), + update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs), + L = [unit(N,U,fixed,GIDs)|L1], + N1 is N + 1, + build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T). + +initialize_unit_dictionary(Term,Dict) :- + term_variables(Term,Vars), + pair_all_with(Vars,0,Dict). + +update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs). +update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :- + ( lookup_eq(Dict,V,GID) -> + ( (GID == This ; memberchk(GID,GIDs) ) -> + GIDs1 = GIDs + ; + GIDs1 = [GID|GIDs] + ), + Dict1 = Dict + ; + Dict1 = [V - This|Dict], + GIDs1 = GIDs + ), + update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs). + +build_guard_units(Guard,N,Dict,Units) :- + ( Guard = [Goal] -> + Units = [unit(N,Goal,fixed,[])] + ; Guard = [Goal|Goals] -> + term_variables(Goal,Vs), + update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs), + Units = [unit(N,Goal,movable,GIDs)|RUnits], + N1 is N + 1, + build_guard_units(Goals,N1,NDict,RUnits) + ). + +update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs). +update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :- + ( lookup_eq(Dict,V,GID) -> + ( (GID == This ; memberchk(GID,GIDs) ) -> + GIDs1 = GIDs + ; + GIDs1 = [GID|GIDs] + ), + Dict1 = [V - This|Dict] + ; + Dict1 = [V - This|Dict], + GIDs1 = GIDs + ), + update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ +%% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _ +%% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_) +%% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_ +%% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_) +%% +%% _ _ _ ___ __ +%% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___ +%% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \ +%% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/ +%% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___| +%% |_| +:- chr_constraint + functional_dependency/4, + get_functional_dependency/4. + +:- chr_option(mode,functional_dependency(+,+,?,?)). +:- chr_option(mode,get_functional_dependency(+,+,?,?)). + +allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key) + <=> + RuleNb > 1, AO > O + | + functional_dependency(C,1,Pattern,Key). + +functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey) + <=> + RuleNb2 >= RuleNb1 + | + QPattern = Pattern, QKey = Key. +get_functional_dependency(_,_,_,_) + <=> + fail. + +functional_dependency_analysis(Rules) :- + ( fail, chr_pp_flag(functional_dependency_analysis,on) -> + functional_dependency_analysis_main(Rules) + ; + true + ). + +functional_dependency_analysis_main([]). +functional_dependency_analysis_main([PRule|PRules]) :- + ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) -> + functional_dependency(C,RuleNb,Pattern,Key) + ; + true + ), + functional_dependency_analysis_main(PRules). + +discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :- + PragmaRule = pragma(Rule,_,_,Name,RuleNb), + Rule = rule(H1,H2,Guard,_), + ( H1 = [C1], + H2 = [C2] -> + true + ; H1 = [C1,C2], + H2 == [] -> + true + ), + check_unique_constraints(C1,C2,Guard,RuleNb,List), + term_variables(C1,Vs), + \+ ( + member(V1,Vs), + lookup_eq(List,V1,V2), + memberchk_eq(V2,Vs) + ), + select_pragma_unique_variables(Vs,List,Key1), + copy_term_nat(C1-Key1,Pattern-Key), + functor(C1,F,A). + +select_pragma_unique_variables([],_,[]). +select_pragma_unique_variables([V|Vs],List,L) :- + ( lookup_eq(List,V,_) -> + L = T + ; + L = [V|T] + ), + select_pragma_unique_variables(Vs,List,T). + + % depends on functional dependency analysis + % and shape of rule: C1 \ C2 <=> true. +set_semantics_rules(Rules) :- + ( fail, chr_pp_flag(set_semantics_rule,on) -> + set_semantics_rules_main(Rules) + ; + true + ). + +set_semantics_rules_main([]). +set_semantics_rules_main([R|Rs]) :- + set_semantics_rule_main(R), + set_semantics_rules_main(Rs). + +set_semantics_rule_main(PragmaRule) :- + PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb), + ( Rule = rule([C1],[C2],true,_), + IDs = ids([ID1],[ID2]), + \+ is_passive(RuleNb,ID1), + functor(C1,F,A), + get_functional_dependency(F/A,RuleNb,Pattern,Key), + copy_term_nat(Pattern-Key,C1-Key1), + copy_term_nat(Pattern-Key,C2-Key2), + Key1 == Key2 -> + passive(RuleNb,ID2) + ; + true + ). + +check_unique_constraints(C1,C2,G,RuleNb,List) :- + \+ any_passive_head(RuleNb), + variable_replacement(C1-C2,C2-C1,List), + copy_with_variable_replacement(G,OtherG,List), + negate_b(G,NotG), + once(entails_b(NotG,OtherG)). + + % checks for rules of the shape ...,C1,C2... (<|=)=> ... + % where C1 and C2 are symmteric constraints +symmetry_analysis(Rules) :- + ( chr_pp_flag(check_unnecessary_active,off) -> + true + ; + symmetry_analysis_main(Rules) + ). + +symmetry_analysis_main([]). +symmetry_analysis_main([R|Rs]) :- + R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb), + Rule = rule(H1,H2,_,_), + ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] -> + symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb), + symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb) + ; + true + ), + symmetry_analysis_main(Rs). + +symmetry_analysis_heads_simplification([],[],_,_,_,_). +symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :- + ( \+ is_passive(RuleNb,ID), + member2(PreHs,PreIDs,PreH-PreID), + \+ is_passive(RuleNb,PreID), + variable_replacement(PreH,H,List), + copy_with_variable_replacement(Rule,Rule2,List), + identical_guarded_rules(Rule,Rule2) -> + passive(RuleNb,ID) + ; + true + ), + symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb). + +symmetry_analysis_heads_propagation([],[],_,_,_,_). +symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :- + ( \+ is_passive(RuleNb,ID), + member2(PreHs,PreIDs,PreH-PreID), + \+ is_passive(RuleNb,PreID), + variable_replacement(PreH,H,List), + copy_with_variable_replacement(Rule,Rule2,List), + identical_rules(Rule,Rule2) -> + passive(RuleNb,ID) + ; + true + ), + symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ __ _ _ _ +%% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __ +%% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \ +%% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | | +%% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_| +%% |_| +%% {{{ + +simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,Symbol,O,Id,L,T) :- + PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb), + head_info1(Head,Symbol,_Vars,Susp,HeadVars,HeadPairs), + build_head(Symbol,Id,HeadVars,ClauseHead), + get_constraint_mode(Symbol,Mode), + head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars), + + + guard_splitting(Rule,GuardList0), + ( is_stored_in_guard(Symbol, RuleNb) -> + GuardList = [Hole1|GuardList0] + ; + GuardList = GuardList0 + ), + guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest), + + rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_), + + guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy), + + ( is_stored_in_guard(Symbol, RuleNb) -> + gen_occ_allocation_in_guard(Symbol,O,Vars,Susp,Allocation), + gen_uncond_attach_goal(Symbol,Susp,Vars,Attachment,_), + GuardCopyList = [Hole1Copy|_], + Hole1Copy = (Allocation, Attachment) + ; + true + ), + + + partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments), + active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment), + + ( chr_pp_flag(debugable,on) -> + Rule = rule(_,_,Guard,Body), + my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), + sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps), + DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)), + instrument_goal(ActualCut,DebugTry,DebugApply,Cut) + ; + Cut = ActualCut + ), + actual_cut(Symbol,O,ActualCut), + Clause = ( ClauseHead :- + FirstMatching, + RescheduledTest, + Cut, + SuspsDetachments, + SuspDetachment, + BodyCopy + ), + add_location(Clause,RuleNb,LocatedClause), + L = [LocatedClause | T]. + +actual_cut(Symbol,Occurrence,ActualCut) :- + ( unconditional_occurrence(Symbol,Occurrence), + chr_pp_flag(late_allocation,on) -> + ActualCut = true + ; + ActualCut = (!) + ). +% }}} + +add_location(Clause,RuleNb,NClause) :- + ( chr_pp_flag(line_numbers,on) -> + get_chr_source_file(File), + get_line_number(RuleNb,LineNb), + NClause = '$source_location'(File,LineNb):Clause + ; + NClause = Clause + ). + +add_dummy_location(Clause,NClause) :- + ( chr_pp_flag(line_numbers,on) -> + get_chr_source_file(File), + NClause = '$source_location'(File,1):Clause + ; + NClause = Clause + ). +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det. +% +% Return goal matching newly introduced variables with variables in +% previously looked-up heads. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :- + head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :- + head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars), + list2conj(GoalList,Goal). + +head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars). +head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !, + ( Mode == (+) -> + term_variables(Arg,GroundVars0,GroundVars), + head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars) + ; + head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars) + ). +head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- + ( var(Arg) -> + ( lookup_eq(VarDict,Arg,OtherVar) -> + ( Mode = (+) -> + ( memberchk_eq(Arg,GroundVars) -> + GoalList = [Var = OtherVar | RestGoalList], + GroundVars1 = GroundVars + ; + GoalList = [Var == OtherVar | RestGoalList], + GroundVars1 = [Arg|GroundVars] + ) + ; + GoalList = [Var == OtherVar | RestGoalList], + GroundVars1 = GroundVars + ), + VarDict1 = VarDict + ; + VarDict1 = [Arg-Var | VarDict], + GoalList = RestGoalList, + ( Mode = (+) -> + GroundVars1 = [Arg|GroundVars] + ; + GroundVars1 = GroundVars + ) + ), + Pairs = Rest, + RestModes = Modes + ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> + identifier_label_atom(IndexType,Var,ActualArg,Goal), + GoalList = [Goal|RestGoalList], + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; atomic(Arg) -> + ( Mode = (+) -> + GoalList = [ Var = Arg | RestGoalList] + ; + GoalList = [ Var == Arg | RestGoalList] + ), + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Mode == (+), is_ground(GroundVars,Arg) -> + copy_with_variable_replacement(Arg,ArgCopy,VarDict), + GoalList = [ Var = ArgCopy | RestGoalList], + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Mode == (?), is_ground(GroundVars,Arg) -> + copy_with_variable_replacement(Arg,ArgCopy,VarDict), + GoalList = [ Var == ArgCopy | RestGoalList], + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Arg =.. [_|Args], + functor(Arg,Fct,N), + functor(Term,Fct,N), + Term =.. [_|Vars], + ( Mode = (+) -> + GoalList = [ Var = Term | RestGoalList ] + ; + GoalList = [ nonvar(Var), Var = Term | RestGoalList ] + ), + pairup(Args,Vars,NewPairs), + append(NewPairs,Rest,Pairs), + replicate(N,Mode,NewModes), + append(NewModes,Modes,RestModes), + VarDict1 = VarDict, + GroundVars1 = GroundVars + ), + head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +add_heads_types([],VarTypes,VarTypes). +add_heads_types([Head|Heads],VarTypes,NVarTypes) :- + add_head_types(Head,VarTypes,VarTypes1), + add_heads_types(Heads,VarTypes1,NVarTypes). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% add_head_types(+Head,+VarTypes,-NVarTypes) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +add_head_types(Head,VarTypes,NVarTypes) :- + functor(Head,F,A), + get_constraint_type_det(F/A,ArgTypes), + Head =.. [_|Args], + add_args_types(Args,ArgTypes,VarTypes,NVarTypes). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +add_args_types([],[],VarTypes,VarTypes). +add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :- + add_arg_types(Arg,Type,VarTypes,VarTypes1), + add_args_types(Args,Types,VarTypes1,NVarTypes). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +% OPTIMIZATION: don't add if `any' +add_arg_types(Term,Type,VarTypes,NVarTypes) :- + ( Type == any -> + NVarTypes = VarTypes + ; var(Term) -> + ( lookup_eq(VarTypes,Term,_) -> + NVarTypes = VarTypes + ; + NVarTypes = [Term-Type|VarTypes] + ) + ; % nonvar + NVarTypes = VarTypes % approximate with any + ). + + + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det. +% +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +add_heads_ground_variables([],GroundVars,GroundVars). +add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :- + add_head_ground_variables(Head,GroundVars,GroundVars1), + add_heads_ground_variables(Heads,GroundVars1,NGroundVars). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det. +% +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +add_head_ground_variables(Head,GroundVars,NGroundVars) :- + functor(Head,F,A), + get_constraint_mode(F/A,ArgModes), + Head =.. [_|Args], + add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars). + + +add_arg_ground_variables([],[],GroundVars,GroundVars). +add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :- + ( Mode == (+) -> + term_variables(Arg,Vars), + add_var_ground_variables(Vars,GroundVars,GroundVars1) + ; + GroundVars = GroundVars1 + ), + add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars). + +add_var_ground_variables([],GroundVars,GroundVars). +add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :- + ( memberchk_eq(Var,GroundVars) -> + GroundVars1 = GroundVars + ; + GroundVars1 = [Var|GroundVars] + ), + add_var_ground_variables(Vars,GroundVars1,NGroundVars). +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% is_ground(+GroundVars,+Term) is semidet. +% +% Determine whether =Term= is always ground. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +is_ground(GroundVars,Term) :- + ( ground(Term) -> + true + ; compound(Term) -> + Term =.. [_|Args], + maplist(is_ground(GroundVars),Args) + ; + memberchk_eq(Term,GroundVars) + ). + +%% check_ground(+GroundVars,+Term,-Goal) is det. +% +% Return runtime check to see whether =Term= is ground. +check_ground(GroundVars,Term,Goal) :- + term_variables(Term,Variables), + check_ground_variables(Variables,GroundVars,Goal). + +check_ground_variables([],_,true). +check_ground_variables([Var|Vars],GroundVars,Goal) :- + ( memberchk_eq(Var,GroundVars) -> + check_ground_variables(Vars,GroundVars,Goal) + ; + Goal = (ground(Var), RGoal), + check_ground_variables(Vars,GroundVars,RGoal) + ). + +rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :- + rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_). + +rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :- + ( Heads = [_|_] -> + rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars) + ; + GoalList = [], + Susps = [], + VarDict = NVarDict, + GroundVars = NGroundVars + ). + +rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars). +rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead, + [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :- + functor(H,F,A), + head_info(H,A,Vars,_,_,Pairs), + get_store_type(F/A,StoreType), + ( StoreType == default -> + passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,Suspension), + get_static_suspension_term_field(arguments,F/A,Suspension,Vars), + get_static_suspension_field(F/A,Suspension,state,active,GetState) + ) + ), + % create_get_mutable_ref(active,State,GetMutable), + get_constraint_mode(F/A,Mode), + head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1), + NPairs = Pairs, + sbag_member_call(Susp,VarSusps,Sbag), + ExistentialLookup = ( + ViaGoal, + Sbag, + Susp = Suspension, % not inlined + GetState + ), + inline_matching_goal(MatchingGoal,MatchingGoal2) + ; + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,Suspension), + get_static_suspension_term_field(arguments,F/A,Suspension,Vars) + ) + ), + existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs), + get_constraint_mode(F/A,Mode), + NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode), + head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1), + filter_append(NPairs,VarDict1,DA_), % order important here + translate(GroundVars1,DA_,GroundVarsA), + translate(GroundVars1,VarDict1,GroundVarsB), + inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB) + ), + different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals), + Goal = + ( + ExistentialLookup, + DiffSuspGoals, + MatchingGoal2 + ), + rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars). + +inline_matching_goal(G1,G2) :- + inline_matching_goal(G1,G2,[],[]). + +inline_matching_goal(A==B,true,GVA,GVB) :- + memberchk_eq(A,GVA), + memberchk_eq(B,GVB), + A=B, !. +% inline_matching_goal(A=B,true,_,_) :- A=B, !. +inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !, + inline_matching_goal(A,A2,GVA,GVB), + inline_matching_goal(B,B2,GVA,GVB). +inline_matching_goal(X,X,_,_). + + +filter_mode([],_,_,[]). +filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :- + ( Var == V -> + Modes = [M|MT], + filter_mode(Rest,R,Ms,MT) + ; + filter_mode([Arg-Var|Rest],R,Ms,Modes) + ). + +filter_append([],VarDict,VarDict). +filter_append([X|Xs],VarDict,NVarDict) :- + ( X = silent(_) -> + filter_append(Xs,VarDict,NVarDict) + ; + NVarDict = [X|NVarDict0], + filter_append(Xs,VarDict,NVarDict0) + ). + +check_unique_keys([],_). +check_unique_keys([V|Vs],Dict) :- + lookup_eq(Dict,V,_), + check_unique_keys(Vs,Dict). + +% Generates tests to ensure the found constraint differs from previously found constraints +% TODO: detect more cases where constraints need be different +different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :- + different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList), + list2conj(DiffSuspGoalList,DiffSuspGoals). + +different_from_other_susps_(_,[],_,_,[]) :- !. +different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :- + ( functor(Head,F,A), functor(PreHead,F,A), + copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy), + \+ \+ PreHeadCopy = HeadCopy -> + + List = [Susp \== PreSusp | Tail] + ; + List = Tail + ), + different_from_other_susps_(Heads,Susps,Head,Susp,Tail). + +% passive_head_via(in,in,in,in,out,out,out) :- +passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :- + functor(Head,F,A), + get_constraint_index(F/A,Pos), + /* which static variables may contain runtime variables */ + common_variables(Head,PrevHeads,CommonVars0), + ground_vars([Head],GroundVars), + list_difference_eq(CommonVars0,GroundVars,CommonVars), + /********************************************************/ + global_list_store_name(F/A,Name), + GlobalGoal = nb_getval(Name,AllSusps), + get_constraint_mode(F/A,ArgModes), + ( Vars == [] -> + Goal = GlobalGoal + ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar -> + translate([CommonVar],VarDict,[Var]), + gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps), + Goal = AttrGoal + ; + translate(CommonVars,VarDict,Vars), + add_heads_types(PrevHeads,[],TypeDict), + my_term_copy(TypeDict,VarDict,TypeDictCopy), + gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps), + Goal = + ( ViaGoal -> + AttrGoal + ; + GlobalGoal + ) + ). + +common_variables(T,Ts,Vs) :- + term_variables(T,V1), + term_variables(Ts,V2), + intersect_eq(V1,V2,Vs). + +gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :- + via_goal(Vars,TypeDict,ViaGoal,Var), + get_target_module(Mod), + AttrGoal = + ( get_attr(Var,Mod,TSusps), + TSuspsEqSusps % TSusps = Susps + ), + get_max_constraint_index(N), + ( N == 1 -> + TSuspsEqSusps = true, % TSusps = Susps + AllSusps = TSusps + ; + get_constraint_index(FA,Pos), + get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps) + ). +via_goal(Vars,TypeDict,ViaGoal,Var) :- + ( Vars = [] -> + ViaGoal = fail + ; Vars = [A] -> + lookup_type(TypeDict,A,Type), + ( atomic_type(Type) -> + ViaGoal = var(A), + A = Var + ; + ViaGoal = 'chr newvia_1'(A,Var) + ) + ; Vars = [A,B] -> + ViaGoal = 'chr newvia_2'(A,B,Var) + ; + ViaGoal = 'chr newvia'(Vars,Var) + ). +lookup_type(TypeDict,Var,Type) :- + ( lookup_eq(TypeDict,Var,Type) -> + true + ; + Type = any % default type + ). +gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :- + get_target_module(Mod), + AttrGoal = + ( get_attr(Var,Mod,TSusps), + TSuspsEqSusps % TSusps = Susps + ), + get_max_constraint_index(N), + ( N == 1 -> + TSuspsEqSusps = true, % TSusps = Susps + AllSusps = TSusps + ; + get_constraint_index(FA,Pos), + get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps) + ). + +guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :- + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + list2conj(GuardCopyList,GuardCopy). + +guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :- + Rule = rule(_,H,Guard,Body), + conj2list(Guard,GuardList), + split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList), + my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore), + + append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList), + term_variables(RestGuardList,GuardVars), + term_variables(RestGuardListCopyCore,GuardCopyVars), + % variables that are declared to be ground don't need to be locked + ground_vars(H,GroundVars), + list_difference_eq(GuardVars,GroundVars,LockedGuardVars), + ( chr_pp_flag(guard_locks,off) -> + Locks = [], + Unlocks = [] + ; + bagof(Lock - Unlock, + X ^ Y ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard + pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable + memberchk_eq(Y,GuardCopyVars), % redundant check? or multiple entries for X possible? + chr_lock(Y,Lock), + chr_unlock(Y,Unlock) + ), + LocksUnlocks) -> + once(pairup(Locks,Unlocks,LocksUnlocks)) + ; + Locks = [], + Unlocks = [] + ), + list2conj(Locks,LockPhase), + list2conj(Unlocks,UnlockPhase), + list2conj(RestGuardListCopyCore,RestGuardCopyCore), + RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)), + my_term_copy(Body,VarDict2,BodyCopy). + + +split_off_simple_guard([],_,[],[]). +split_off_simple_guard([G|Gs],VarDict,S,C) :- + ( simple_guard(G,VarDict) -> + S = [G|Ss], + split_off_simple_guard(Gs,VarDict,Ss,C) + ; + S = [], + C = [G|Gs] + ). + +% simple guard: cheap and benign (does not bind variables) +simple_guard(G,VarDict) :- + binds_b(G,Vars), + \+ (( member(V,Vars), + lookup_eq(VarDict,V,_) + )). + +active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :- + functor(Head,F,A), + C = F/A, + ( is_stored(C) -> + ( + ( + Id == [0], chr_pp_flag(store_in_guards, off) + ; + ( get_allocation_occurrence(C,AO), + get_max_occurrence(C,MO), + MO < AO ) + ), + only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) -> + SuspDetachment = true + ; + gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment), + ( chr_pp_flag(late_allocation,on) -> + SuspDetachment = + ( var(Susp) -> + true + ; + UnCondSuspDetachment + ) + ; + SuspDetachment = UnCondSuspDetachment + ) + ) + ; + SuspDetachment = true + ). + +partner_constraint_detachments([],[],_,true). +partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :- + gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment), + partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments). + +gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :- + functor(Head,F,A), + C = F/A, + ( is_stored(C) -> + SuspDetachment = ( DebugEvent, RemoveInternalGoal), + ( chr_pp_flag(debugable,on) -> + DebugEvent = 'chr debug_event'(remove(Susp)) + ; + DebugEvent = true + ), + remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal), + delete_constraint_goal(Head,Susp,VarDict,DeleteCall), + ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) -> + detach_constraint_atom(C,Vars,Susp,Detach) + ; + Detach = true + ) + ; + SuspDetachment = true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ _ +%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / | +%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | | +%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | | +%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_| +%% |_| |___/ +%% {{{ + +simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :- + PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb), + Rule = rule(_Heads,Heads2,Guard,Body), + + head_info(Head,A,Vars,Susp,HeadVars,HeadPairs), + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars), + + build_head(F,A,Id,HeadVars,ClauseHead), + + append(RestHeads,Heads2,Heads), + append(OtherIDs,Heads2IDs,IDs), + reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs), + + guard_splitting(Rule,GuardList0), + ( is_stored_in_guard(F/A, RuleNb) -> + GuardList = [Hole1|GuardList0] + ; + GuardList = GuardList0 + ), + guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest), + + rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_), + split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs), + + guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy), + + ( is_stored_in_guard(F/A, RuleNb) -> + gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_), + GuardCopyList = [Hole1Copy|_], + Hole1Copy = Attachment + ; + true + ), + + sort_by_key(Susps1,Susps1IDs,SortedSusps1), + partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments), + active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment), + + ( chr_pp_flag(debugable,on) -> + my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), + sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps), + sort_by_key(Susps2,Susps2IDs,KeptSusps), + DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)), + instrument_goal((!),DebugTry,DebugApply,Cut) + ; + Cut = (!) + ), + + Clause = ( ClauseHead :- + FirstMatching, + RescheduledTest, + Cut, + SuspsDetachments, + SuspDetachment, + BodyCopy + ), + add_location(Clause,RuleNb,LocatedClause), + L = [LocatedClause | T]. + +% }}} + +split_by_ids([],[],_,[],[]). +split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :- + ( memberchk_eq(I,I1s) -> + S1s = [S | R1s], + S2s = R2s + ; + S1s = R1s, + S2s = [S | R2s] + ), + split_by_ids(Is,Ss,I1s,R1s,R2s). + +split_by_ids([],[],_,[],[],[],[]). +split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :- + ( memberchk_eq(I,I1s) -> + S1s = [S | R1s], + SI1s = [I|RSI1s], + S2s = R2s, + SI2s = RSI2s + ; + S1s = R1s, + SI1s = RSI1s, + S2s = [S | R2s], + SI2s = [I|RSI2s] + ), + split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ ____ +%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \ +%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) | +%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/ +%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____| +%% |_| |___/ + +%% Genereate prelude + worker predicate +%% prelude calls worker +%% worker iterates over one type of removed constraints +simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :- + PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb), + Rule = rule(Heads1,_,Guard,Body), + append(Heads1,RestHeads2,Heads), + append(IDs1,RestIDs,IDs), + reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]), + simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1), + extend_id(Id,Id1), + ( memberchk_eq(NID,IDs2) -> + simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2) + ; + L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs + ), + universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3), + simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T). + +simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L). +simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :- + Heads = [Head|RHeads], + inc_id(Id,Id1), + universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0), + universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1), + ( memberchk_eq(ID,IDs2) -> + simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T) + ; + NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id1,VarsSusp,ClauseHead), + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars), + + lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps), + + gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal), + + extend_id(Id1,DelegateId), + extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars), + append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars), + build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate), + + PreludeClause = + ( ClauseHead :- + FirstMatching, + ModConstraintsGoal, + !, + ConstraintAllocationGoal, + Delegate + ), + add_dummy_location(PreludeClause,LocatedPreludeClause), + L = [LocatedPreludeClause|T]. + +extra_active_delegate_variables(Term,Terms,VarDict,Vars) :- + Term =.. [_|Args], + delegate_variables(Term,Terms,VarDict,Args,Vars). + +passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :- + term_variables(PrevTerms,PrevVars), + delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars). + +delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :- + term_variables(Term,V1), + term_variables(Terms,V2), + intersect_eq(V1,V2,V3), + list_difference_eq(V3,PrevVars,V4), + translate(V4,VarDict,Vars). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :- + PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb), + Rule = rule(_,_,Guard,Body), + get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps), + + gen_var(OtherSusp), + gen_var(OtherSusps), + + functor(CurrentHead,OtherF,OtherA), + gen_vars(OtherA,OtherVars), + head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), + get_constraint_mode(OtherF/OtherA,Mode), + head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars), + + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(OtherF/OtherA,OtherSuspension), + get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState), + get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars) + ) + ), + % create_get_mutable_ref(active,State,GetMutable), + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), + CurrentSuspTest = ( + OtherSusp = OtherSuspension, + GetState, + DiffSuspGoals, + FirstMatching + ), + + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,[O|Id],ClauseVars,ClauseHead), + + guard_splitting(Rule,GuardList0), + ( is_stored_in_guard(F/A, RuleNb) -> + GuardList = [Hole1|GuardList0] + ; + GuardList = GuardList0 + ), + guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest), + + rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]), + split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2), + split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_), + + partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments), + + RecursiveVars = [OtherSusps|PreVarsAndSusps], + build_head(F,A,[O|Id],RecursiveVars,RecursiveCall), + RecursiveVars2 = [[]|PreVarsAndSusps], + build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2), + + guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy), + ( is_stored_in_guard(F/A, RuleNb) -> + GuardCopyList = [GuardAttachment|_] % once( ) ?? + ; + true + ), + + ( is_observed(F/A,O) -> + gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation), + gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall), + gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2) + ; + Attachment = true, + ConditionalRecursiveCall = RecursiveCall, + ConditionalRecursiveCall2 = RecursiveCall2 + ), + + ( chr_pp_flag(debugable,on) -> + my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + ( is_stored_in_guard(F/A, RuleNb) -> + GuardAttachment = Attachment, + BodyAttachment = true + ; + GuardAttachment = true, + BodyAttachment = Attachment % will be true if not observed at all + ), + + ( member(unique(ID1,UniqueKeys), Pragmas), + check_unique_keys(UniqueKeys,VarDict) -> + Clause = + ( ClauseHead :- + ( CurrentSuspTest -> + ( RescheduledTest, + DebugTry -> + DebugApply, + Susps1Detachments, + BodyAttachment, + BodyCopy, + ConditionalRecursiveCall2 + ; + RecursiveCall2 + ) + ; + RecursiveCall + ) + ) + ; + Clause = + ( ClauseHead :- + ( CurrentSuspTest, + RescheduledTest, + DebugTry -> + DebugApply, + Susps1Detachments, + BodyAttachment, + BodyCopy, + ConditionalRecursiveCall + ; + RecursiveCall + ) + ) + ), + add_location(Clause,RuleNb,LocatedClause), + L = [LocatedClause | T]. + +gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :- + ( may_trigger(FA) -> + does_use_field(FA,generation), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(FA,Suspension), + get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState), + get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration), + get_static_suspension_term_field(arguments,FA,Suspension,Args) + ) + ) + ; + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(FA,Suspension), + get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState), + get_static_suspension_term_field(arguments,FA,Suspension,Args) + ) + ), + GetGeneration = true + ), + ConditionalCall = + ( Susp = Suspension, + GetState, + GetGeneration -> + UpdateState, + Call + ; + true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ +%% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ +%% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ +%% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | | +%% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| +%% |_| |___/ + +propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- + ( RestHeads == [] -> + propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T) + ; + propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Single headed propagation +%% everything in a single clause +propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id,VarsSusp,ClauseHead), + + inc_id(Id,NextId), + build_head(F,A,NextId,VarsSusp,NextHead), + + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars), + guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), + + % - recursive call - + RecursiveCall = NextHead, + + actual_cut(F/A,O,ActualCut), + + Rule = rule(_,_,Guard,Body), + ( chr_pp_flag(debugable,on) -> + my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)), + instrument_goal(ActualCut,DebugTry,DebugApply,Cut) + ; + Cut = ActualCut + ), + ( may_trigger(F/A), \+ has_no_history(RuleNb)-> + use_auxiliary_predicate(novel_production), + use_auxiliary_predicate(extend_history), + does_use_history(F/A,O), + gen_occ_allocation(F/A,O,Vars,Susp,Allocation), + + ( named_history(RuleNb,HistoryName,HistoryIDs) -> + ( HistoryIDs == [] -> + empty_named_history_novel_production(HistoryName,NovelProduction), + empty_named_history_extend_history(HistoryName,ExtendHistory) + ; + Tuple = HistoryName + ) + ; + Tuple = RuleNb + ), + + ( var(NovelProduction) -> + NovelProduction = '$novel_production'(Susp,Tuple), + ExtendHistory = '$extend_history'(Susp,Tuple) + ; + true + ), + + ( is_observed(F/A,O) -> + gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation), + gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) + ; + Attachment = true, + ConditionalRecursiveCall = RecursiveCall + ) + ; + Allocation = true, + NovelProduction = true, + ExtendHistory = true, + + ( is_observed(F/A,O) -> + get_allocation_occurrence(F/A,AllocO), + ( O == AllocO -> + gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp), + Generation = 0 + ; % more room for improvement? + Attachment = (Attachment1, Attachment2), + gen_occ_allocation(F/A,O,Vars,Susp,Attachment1), + gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation) + ), + gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) + ; + gen_occ_allocation(F/A,O,Vars,Susp,Attachment), + ConditionalRecursiveCall = RecursiveCall + ) + ), + + ( is_stored_in_guard(F/A, RuleNb) -> + GuardAttachment = Attachment, + BodyAttachment = true + ; + GuardAttachment = true, + BodyAttachment = Attachment % will be true if not observed at all + ), + + Clause = ( + ClauseHead :- + HeadMatching, + Allocation, + NovelProduction, + GuardAttachment, + GuardCopy, + Cut, + ExtendHistory, + BodyAttachment, + BodyCopy, + ConditionalRecursiveCall + ), + add_location(Clause,RuleNb,LocatedClause), + ProgramList = [LocatedClause | ProgramTail]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% multi headed propagation +%% prelude + predicates to accumulate the necessary combinations of suspended +%% constraints + predicate to execute the body +propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- + RestHeads = [First|Rest], + propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1), + extend_id(Id,ExtendedId), + propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id,VarsSusp,PreludeHead), + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars), + Rule = rule(_,_,Guard,Body), + extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars), + + lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps), + + gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation), + + extend_id(Id,NestedId), + append([Susps|VarsSusp],ExtraVars,NestedVars), + build_head(F,A,[O|NestedId],NestedVars,NestedHead), + NestedCall = NestedHead, + + Prelude = ( + PreludeHead :- + FirstMatching, + FirstSuspGoal, + !, + CondAllocation, + NestedCall + ), + add_dummy_location(Prelude,LocatedPrelude), + L = [LocatedPrelude|T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- + universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1), + propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T). + +propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- + universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1), + universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2), + inc_id(Id,IncId), + propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T). + +%check_fd_lookup_condition(_,_,_,_) :- fail. +check_fd_lookup_condition(F,A,_,_) :- + get_store_type(F/A,global_singleton), !. +check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :- + \+ may_trigger(F/A), + get_functional_dependency(F/A,1,P,K), + copy_term(P-K,CurrentHead-Key), + term_variables(PreHeads,PreVars), + intersect_eq(Key,PreVars,Key),!. + +propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :- + Rule = rule(_,H2,Guard,Body), + gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators), + flatten(PreVarsAndSuspsList,PreVarsAndSusps), + init(AllSusps,RestSusps), + last(AllSusps,Susp), + gen_var(OtherSusp), + gen_var(OtherSusps), + functor(CurrentHead,OtherF,OtherA), + gen_vars(OtherA,OtherVars), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(OtherF/OtherA,Suspension), + get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState), + get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars) + ) + ), + % create_get_mutable_ref(active,State,GetMutable), + CurrentSuspTest = ( + OtherSusp = Suspension, + GetState + ), + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,[O|Id],ClauseVars,ClauseHead), + ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime + universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0), + RecursiveVars = PreVarsAndSusps1 + ; + RecursiveVars = [OtherSusps|PreVarsAndSusps], + PrevId0 = Id + ), + ( PrevId0 = [_] -> + PrevId = PrevId0 + ; + PrevId = [O|PrevId0] + ), + build_head(F,A,PrevId,RecursiveVars,RecursiveHead), + RecursiveCall = RecursiveHead, + CurrentHead =.. [_|OtherArgs], + pairup(OtherArgs,OtherVars,OtherPairs), + get_constraint_mode(OtherF/OtherA,Mode), + head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict), + + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals), + guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), + get_occurrence(F/A,O,_,ID), + + ( is_observed(F/A,O) -> + init(FirstVarsSusp,FirstVars), + gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation), + gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) + ; + Attachment = true, + ConditionalRecursiveCall = RecursiveCall + ), + ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) -> + NovelProduction = true, + ExtendHistory = true + ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) -> + NovelProduction = true, + ExtendHistory = true + ; + get_occurrence(F/A,O,_,ID), + use_auxiliary_predicate(novel_production), + use_auxiliary_predicate(extend_history), + does_use_history(F/A,O), + ( named_history(RuleNb,HistoryName,HistoryIDs) -> + ( HistoryIDs == [] -> + empty_named_history_novel_production(HistoryName,NovelProduction), + empty_named_history_extend_history(HistoryName,ExtendHistory) + ; + reverse([OtherSusp|RestSusps],NamedSusps), + named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps), + HistorySusps = [HistorySusp|_], + + ( length(HistoryIDs, 1) -> + ExtendHistory = '$extend_history'(HistorySusp,HistoryName), + NovelProduction = '$novel_production'(HistorySusp,HistoryName) + ; + findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols), + Tuple =.. [t,HistoryName|HistorySusps] + ) + ) + ; + HistorySusp = Susp, + maplist(extract_symbol,H2,ConstraintSymbols), + sort([ID|RestIDs],HistoryIDs), + history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps), + Tuple =.. [t,RuleNb|HistorySusps] + ), + + ( var(NovelProduction) -> + novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions), + ExtendHistory = '$extend_history'(HistorySusp,TupleVar), + NovelProduction = ( TupleVar = Tuple, NovelProductions ) + ; + true + ) + ), + + + ( chr_pp_flag(debugable,on) -> + Rule = rule(_,_,Guard,Body), + my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), + get_occurrence(F/A,O,_,ID), + sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps), + DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + ( is_stored_in_guard(F/A, RuleNb) -> + GuardAttachment = Attachment, + BodyAttachment = true + ; + GuardAttachment = true, + BodyAttachment = Attachment % will be true if not observed at all + ), + + Clause = ( + ClauseHead :- + ( CurrentSuspTest, + DiffSuspGoals, + Matching, + NovelProduction, + GuardAttachment, + GuardCopy, + DebugTry -> + DebugApply, + ExtendHistory, + BodyAttachment, + BodyCopy, + ConditionalRecursiveCall + ; RecursiveCall + ) + ), + add_location(Clause,RuleNb,LocatedClause), + L = [LocatedClause|T]. + +extract_symbol(Head,F/A) :- + functor(Head,F,A). + +novel_production_calls([],[],[],_,_,true). +novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :- + get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID), + delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)), + novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals). + +history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :- + reverse(ReversedRestSusps,RestSusps), + sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps). + +named_history_susps([],_,_,[]). +named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :- + select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !, + named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps). + + + +gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :- + !, + functor(Head,F,A), + head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :- + gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_), + functor(Head,F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps|Rest],VarsSusps). + + % returns + % VarDict for the copies of variables in the original heads + % VarsSuspsList list of lists of arguments for the successive heads + % FirstVarsSusp top level arguments + % SuspList list of all suspensions + % Iterators list of all iterators +gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :- + !, + functor(Head,F,A), + head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions + get_constraint_mode(F/A,Mode), + head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary + extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed + append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables +gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :- + gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators), + functor(Head,F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), + get_constraint_mode(F/A,Mode), + head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps],Vars). + +get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :- + !, + functor(Head,F,A), + head_info(Head,A,Vars,Susp,VarsSusp,Pairs), + get_constraint_mode(F/A,Mode), + head_arg_matches(Pairs,Mode,[],_,VarDict), + extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :- + get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps), + functor(Head,F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs), + get_constraint_mode(F/A,Mode), + head_arg_matches(Pairs,Mode,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ _ +%% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| | +%% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` | +%% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| | +%% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_| +%% +%% ____ _ _ _ +%% | _ \ ___| |_ _ __(_) _____ ____ _| | +%% | |_) / _ \ __| '__| |/ _ \ \ / / _` | | +%% | _ < __/ |_| | | | __/\ V / (_| | | +%% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_| +%% +%% ____ _ _ +%% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _ +%% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` | +%% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| | +%% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, | +%% |___/ + +reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- + ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 -> + reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) + ; + NRestHeads = RestHeads, + NRestIDs = RestIDs + ). + +reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- + term_variables(Head,Vars), + InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb), + copy_term_nat(InitialData,InitialDataCopy), + a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData), + InitialDataCopy = InitialData, + FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_), + reverse(RNRestHeads,NRestHeads), + reverse(RNRestIDs,NRestIDs). + +final_data(Entry) :- + Entry = entry(_,_,_,_,[],_). + +expand_data(Entry,NEntry,Cost) :- + Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb), + select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1), + term_variables([Head1|Vars],Vars1), + NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb), + order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost). + +% Assigns score to head based on known variables and heads to lookup +% order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{ +order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :- + functor(Head,F,A), + get_store_type(F/A,StoreType), + order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score). +% }}} + +%% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{ +order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :- + term_variables(Head,HeadVars0), + term_variables(RestHeads,RestVars), + ground_vars([Head],GroundVars), + list_difference_eq(HeadVars0,GroundVars,HeadVars), + order_score_vars(HeadVars,KnownVars,RestVars,Score), + NScore is min(CScore,Score). +order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- + ( CScore =< 100 -> + Score = CScore + ; + order_score_indexes(Indexes,Head,KnownVars,Score) + ). +order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- + ( CScore =< 100 -> + Score = CScore + ; + order_score_indexes(Indexes,Head,KnownVars,Score) + ). +order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :- + term_variables(Head,HeadVars), + term_variables(RestHeads,RestVars), + order_score_vars(HeadVars,KnownVars,RestVars,Score_), + Score is Score_ * 200, + NScore is min(CScore,Score). +order_score(var_assoc_store(_,_),_,_,_,_,_,_,1). +order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :- + Score = 1. % guaranteed O(1) +order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- + multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score). +multi_order_score([],_,_,_,_,_,Score,Score). +multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :- + ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true + ; Score1 = Score0 + ), + multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score). + +order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- + arg(Index,Head,Arg), + memberchk_eq(Arg,KnownVars), + Score is min(CScore,10). +order_score(type_indexed_identifier_store(Index,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- + arg(Index,Head,Arg), + memberchk_eq(Arg,KnownVars), + Score is min(CScore,10). +% }}} + + +%% order_score_indexes(+indexes,+head,+vars,-score). {{{ +order_score_indexes(Indexes,Head,Vars,Score) :- + copy_term_nat(Head+Vars,HeadCopy+VarsCopy), + numbervars(VarsCopy,0,_), + order_score_indexes(Indexes,HeadCopy,Score). + +order_score_indexes([I|Is],Head,Score) :- + args(I,Head,Args), + ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ -> + Score = 100 + ; + order_score_indexes(Is,Head,Score) + ). +% }}} + +memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List). + +order_score_vars(Vars,KnownVars,RestVars,Score) :- + order_score_count_vars(Vars,KnownVars,RestVars,K-R-O), + ( K-R-O == 0-0-0 -> + Score = 0 + ; K > 0 -> + Score is max(10 - K,0) + ; R > 0 -> + Score is max(10 - R,1) * 100 + ; + Score is max(10-O,1) * 1000 + ). +order_score_count_vars([],_,_,0-0-0). +order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :- + order_score_count_vars(Vs,KnownVars,RestVars,K-R-O), + ( memberchk_eq(V,KnownVars) -> + NK is K + 1, + NR = R, NO = O + ; memberchk_eq(V,RestVars) -> + NR is R + 1, + NK = K, NO = O + ; + NO is O + 1, + NK = K, NR = R + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ___ _ _ _ +%% |_ _|_ __ | (_)_ __ (_)_ __ __ _ +%% | || '_ \| | | '_ \| | '_ \ / _` | +%% | || | | | | | | | | | | | | (_| | +%% |___|_| |_|_|_|_| |_|_|_| |_|\__, | +%% |___/ + +%% SWI begin +create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)). +create_get_mutable(V,M,GM) :- M = mutable(V), GM = true. +%% SWI end + +%% SICStus begin +%% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M). +%% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M). +%% SICStus end + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% _ _ _ _ _ _ _ +%% | | | | |_(_) (_) |_ _ _ +%% | | | | __| | | | __| | | | +%% | |_| | |_| | | | |_| |_| | +%% \___/ \__|_|_|_|\__|\__, | +%% |___/ + +% Create a fresh variable. +gen_var(_). + +% Create =N= fresh variables. +gen_vars(N,Xs) :- + length(Xs,N). + +ast_head_info1(AstHead,Vars,Susp,VarsSusp,HeadPairs) :- + AstHead = chr_constraint(_/A,Args,_), + vars_susp(A,Vars,Susp,VarsSusp), + pairup(Args,Vars,HeadPairs). + +head_info1(Head,_/A,Vars,Susp,VarsSusp,HeadPairs) :- + vars_susp(A,Vars,Susp,VarsSusp), + Head =.. [_|Args], + pairup(Args,Vars,HeadPairs). + +head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :- + vars_susp(A,Vars,Susp,VarsSusp), + Head =.. [_|Args], + pairup(Args,Vars,HeadPairs). + +inc_id([N|Ns],[O|Ns]) :- + O is N + 1. +dec_id([N|Ns],[M|Ns]) :- + M is N - 1. + +extend_id(Id,[0|Id]). + +next_id([_,N|Ns],[O|Ns]) :- + O is N + 1. + + % return clause Head + % for F/A constraint symbol, predicate identifier Id and arguments Head +build_head(F/A,Id,Args,Head) :- + build_head(F,A,Id,Args,Head). +build_head(F,A,Id,Args,Head) :- + buildName(F,A,Id,Name), + ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)), + ( may_trigger(F/A) ; + get_allocation_occurrence(F/A,AO), + get_max_occurrence(F/A,MO), + MO >= AO ) ) -> + Head =.. [Name|Args] + ; + init(Args,ArgsWOSusp), % XXX not entirely correct! + Head =.. [Name|ArgsWOSusp] + ). + + % return predicate name Result + % for Fct/Aty constraint symbol and predicate identifier List +buildName(Fct,Aty,List,Result) :- + ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)), + ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO), + MO >= AO ) ; List \= [0])) ) ) -> + atom_concat(Fct, '___' ,FctSlash), + atomic_concat(FctSlash,Aty,FctSlashAty), + buildName_(List,FctSlashAty,Result) + ; + Result = Fct + ). + +buildName_([],Name,Name). +buildName_([N|Ns],Name,Result) :- + buildName_(Ns,Name,Name1), + atom_concat(Name1,'__',NameDash), % '_' is a char :-( + atomic_concat(NameDash,N,Result). + +vars_susp(A,Vars,Susp,VarsSusp) :- + length(Vars,A), + append(Vars,[Susp],VarsSusp). + +or_pattern(Pos,Pat) :- + Pow is Pos - 1, + Pat is 1 << Pow. % was 2 ** X + +and_pattern(Pos,Pat) :- + X is Pos - 1, + Y is 1 << X, % was 2 ** X + Pat is (-1)*(Y + 1). + +make_name(Prefix,F/A,Name) :- + atom_concat_list([Prefix,F,'___',A],Name). + +%=============================================================================== +% Attribute for attributed variables + +make_attr(N,Mask,SuspsList,Attr) :- + length(SuspsList,N), + Attr =.. [v,Mask|SuspsList]. + +get_all_suspensions2(N,Attr,SuspensionsList) :- + chr_pp_flag(dynattr,off), !, + make_attr(N,_,SuspensionsList,Attr). + +% NEW +get_all_suspensions2(N,Attr,Goal,SuspensionsList) :- + % writeln(get_all_suspensions2), + length(SuspensionsList,N), + Goal = 'chr all_suspensions'(SuspensionsList,1,Attr). + + +% NEW +normalize_attr(Attr,NormalGoal,NormalAttr) :- + % writeln(normalize_attr), + NormalGoal = 'chr normalize_attr'(Attr,NormalAttr). + +get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :- + chr_pp_flag(dynattr,off), + !, % chr_pp_flag(experiment,off), !, + make_attr(N,_,SuspsList,Attr), + nth1(Position,SuspsList,Suspensions). + +% get_suspensions(N,Position,TAttr,Goal,Suspensions) :- +% chr_pp_flag(dynattr,off), +% chr_pp_flag(experiment,on), !, +% Position1 is Position + 1, +% Goal = arg(Position1,TAttr,Suspensions). + +% NEW +get_suspensions(N,Position,TAttr,Goal,Suspensions) :- + % writeln(get_suspensions), + Goal = + ( memberchk(Position-Suspensions,TAttr) -> + true + ; + Suspensions = [] + ). + +%------------------------------------------------------------------------------- +% +N: number of constraint symbols +% +Suspension: source-level variable, for suspension +% +Position: constraint symbol number +% -Attr: source-level term, for new attribute +singleton_attr(N,Suspension,Position,Attr) :- + chr_pp_flag(dynattr,off), !, + or_pattern(Position,Pattern), + make_attr(N,Pattern,SuspsList,Attr), + nth1(Position,SuspsList,[Suspension],RestSuspsList), + set_elems(RestSuspsList,[]). + +% NEW +singleton_attr(N,Suspension,Position,Attr) :- + % writeln(singleton_attr), + Attr = [Position-[Suspension]]. + +%------------------------------------------------------------------------------- +% +N: number of constraint symbols +% +Suspension: source-level variable, for suspension +% +Position: constraint symbol number +% +TAttr: source-level variable, for old attribute +% -Goal: goal for creating new attribute +% -NTAttr: source-level variable, for new attribute +add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :- + chr_pp_flag(dynattr,off), !, + make_attr(N,Mask,SuspsList,Attr), + or_pattern(Position,Pattern), + nth1(Position,SuspsList,Susps), + substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1), + make_attr(N,Mask,SuspsList1,NewAttr1), + substitute_eq(Susps,SuspsList,[Suspension],SuspsList2), + make_attr(N,NewMask,SuspsList2,NewAttr2), + Goal = ( + TAttr = Attr, + ( Mask /\ Pattern =:= Pattern -> + NTAttr = NewAttr1 + ; + NewMask is Mask \/ Pattern, + NTAttr = NewAttr2 + ) + ), !. + +% NEW +add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :- + % writeln(add_attr), + Goal = + ( 'chr select'(TAttr,Position-Suspensions,RAttr) -> + NTAttr = [Position-[Suspension|Suspensions]|RAttr] + ; + NTAttr = [Position-[Suspension]|TAttr] + ). + +rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- + chr_pp_flag(dynattr,off), + chr_pp_flag(experiment,off), !, + or_pattern(Position,Pattern), + and_pattern(Position,DelPattern), + make_attr(N,Mask,SuspsList,Attr), + nth1(Position,SuspsList,Susps), + substitute_eq(Susps,SuspsList,[],SuspsList1), + make_attr(N,NewMask,SuspsList1,Attr1), + substitute_eq(Susps,SuspsList,NewSusps,SuspsList2), + make_attr(N,Mask,SuspsList2,Attr2), + get_target_module(Mod), + Goal = ( + TAttr = Attr, + ( Mask /\ Pattern =:= Pattern -> + 'chr sbag_del_element'(Susps,Suspension,NewSusps), + ( NewSusps == [] -> + NewMask is Mask /\ DelPattern, + ( NewMask == 0 -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,Attr1) + ) + ; + put_attr(Var,Mod,Attr2) + ) + ; + true + ) + ), !. +rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- + chr_pp_flag(dynattr,off), + chr_pp_flag(experiment,on), !, + or_pattern(Position,Pattern), + and_pattern(Position,DelPattern), + Position1 is Position + 1, + get_target_module(Mod), + Goal = ( + arg(1,TAttr,Mask), + ( Mask /\ Pattern =:= Pattern -> + arg(Position1,TAttr,Susps), + 'chr sbag_del_element'(Susps,Suspension,NewSusps), + ( NewSusps == [] -> + NewMask is Mask /\ DelPattern, + ( NewMask == 0 -> + del_attr(Var,Mod) + ; + setarg(1,TAttr,NewMask), + setarg(Position1,TAttr,NewSusps) + ) + ; + setarg(Position1,TAttr,NewSusps) + ) + ; + true + ) + ), !. + +% NEW +rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- + % writeln(rem_attr), + get_target_module(Mod), + Goal = + ( 'chr select'(TAttr,Position-Suspensions,RAttr) -> + 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions), + ( NSuspensions == [] -> + ( RAttr == [] -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,RAttr) + ) + ; + put_attr(Var,Mod,[Position-NSuspensions|RAttr]) + ) + ; + true + ). + +%------------------------------------------------------------------------------- +% +N: number of constraint symbols +% +TAttr1: source-level variable, for attribute +% +TAttr2: source-level variable, for other attribute +% -Goal: goal for merging the two attributes +% -Attr: source-level term, for merged attribute +merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :- + chr_pp_flag(dynattr,off), !, + make_attr(N,Mask1,SuspsList1,Attr1), + merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr), + Goal = ( + TAttr1 = Attr1, + Goal2 + ). + +% NEW +merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :- + % writeln(merge_attributes), + Goal = ( + sort(TAttr1,Sorted1), + sort(TAttr2,Sorted2), + 'chr new_merge_attributes'(Sorted1,Sorted2,Attr) + ). + + +%------------------------------------------------------------------------------- +% +N: number of constraint symbols +% +Mask1: ... +% +SuspsList1: static term, for suspensions list +% +TAttr2: source-level variable, for other attribute +% -Goal: goal for merging the two attributes +% -Attr: source-level term, for merged attribute +merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :- + make_attr(N,Mask2,SuspsList2,Attr2), + bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs), + list2conj(Gs,SortGoals), + bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList), + make_attr(N,Mask,SuspsList,Attr), + Goal = ( + TAttr2 = Attr2, + SortGoals, + Mask is Mask1 \/ Mask2 + ). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Storetype dependent lookup + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict, +%% -Goal,-SuspensionList) is det. +% +% Create a universal lookup goal for given head. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :- + functor(Head,F,A), + get_store_type(F/A,StoreType), + lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars, +%% -Goal,-SuspensionList) is det. +% +% Create a universal lookup goal for given head. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- + functor(Head,F,A), + get_store_type(F/A,StoreType), + lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict, +%% +GroundVars,-Goal,-SuspensionList) is det. +% +% Create a universal lookup goal for given head. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :- + functor(Head,F,A), + passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps), + update_store_type(F/A,default). +lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :- + hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_). +lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :- + hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_). +lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :- + functor(Head,F,A), + global_ground_store_name(F/A,StoreName), + make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps), + update_store_type(F/A,global_ground). +lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :- + arg(VarIndex,Head,OVar), + arg(KeyIndex,Head,OKey), + translate([OVar,OKey],VarDict,[Var,Key]), + get_target_module(Module), + Goal = ( + get_attr(Var,Module,AssocStore), + lookup_assoc_store(AssocStore,Key,AllSusps) + ). +lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :- + functor(Head,F,A), + global_singleton_store_name(F/A,StoreName), + make_get_store_goal(StoreName,Susp,GetStoreGoal), + Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]), + update_store_type(F/A,global_singleton). +lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- + once(( + member(ST,StoreTypes), + lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) + )). +lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- + functor(Head,F,A), + arg(Index,Head,Var), + translate([Var],VarDict,[KeyVar]), + delay_phase_end(validate_store_type_assumptions, + identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal) + ), + update_store_type(F/A,identifier_store(Index)), + get_identifier_index(F/A,Index,_). +lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- + functor(Head,F,A), + arg(Index,Head,Var), + ( var(Var) -> + translate([Var],VarDict,[KeyVar]), + Goal = StructGoal + ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) -> + lookup_only_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal), + Goal = (LookupGoal,StructGoal) + ), + delay_phase_end(validate_store_type_assumptions, + type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal) + ), + update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)), + get_type_indexed_identifier_index(IndexType,F/A,Index,_). + +identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :- + get_identifier_size(ISize), + functor(Struct,struct,ISize), + get_identifier_index(C,Index,IIndex), + arg(IIndex,Struct,AllSusps), + Goal = (KeyVar = Struct). + +type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :- + type_indexed_identifier_structure(IndexType,Struct), + get_type_indexed_identifier_index(IndexType,C,Index,IIndex), + arg(IIndex,Struct,AllSusps), + Goal = (KeyVar = Struct). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict, +%% +GroundVars,-Goal,-SuspensionList,-Index) is det. +% +% Create a universal hash lookup goal for given head. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :- + pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies), + ( KeyArgCopies = [KeyCopy] -> + true + ; + KeyCopy =.. [k|KeyArgCopies] + ), + functor(Head,F,A), + multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal), + + check_ground(GroundVars,KeyArgs,OriginalGroundCheck), + my_term_copy(OriginalGroundCheck,VarDict,GroundCheck), + + Goal = (GroundCheck,LookupGoal), + + ( HashType == inthash -> + update_store_type(F/A,multi_inthash([Index])) + ; + update_store_type(F/A,multi_hash([Index])) + ). + +pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :- + member(Index,Indexes), + args(Index,Head,KeyArgs), + key_in_scope(KeyArgs,VarDict,KeyArgCopies), + !. + +% check whether we can copy the given terms +% with the given dictionary, and, if so, do so +key_in_scope([],VarDict,[]). +key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :- + term_variables(Arg,Vars), + translate(Vars,VarDict,VarCopies), + copy_term(Arg/Vars,ArgCopy/VarCopies), + key_in_scope(Args,VarDict,ArgCopies). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict, +%% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar, +%% +VarArgDict,-NewVarArgDict) is det. +% +% Create existential lookup goal for given head. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !, + lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps), + sbag_member_call(Susp,AllSusps,Sbag), + functor(Head,F,A), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,SuspTerm), + get_static_suspension_field(F/A,SuspTerm,state,active,GetState) + ) + ), + Goal = ( + UniversalGoal, + Sbag, + Susp = SuspTerm, + GetState + ). +existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !, + functor(Head,F,A), + global_singleton_store_name(F/A,StoreName), + make_get_store_goal(StoreName,Susp,GetStoreGoal), + Goal = ( + GetStoreGoal, % nb_getval(StoreName,Susp), + Susp \== [], + Susp = SuspTerm + ), + update_store_type(F/A,global_singleton). +existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, + once(( + member(ST,StoreTypes), + existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) + )). +existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, + existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs). +existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, + existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs). +existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, + lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps), + hash_index_filter(Pairs,[Index],NPairs), + + functor(Head,F,A), + ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> + Sbag = (AllSusps = [Susp]) + ; + sbag_member_call(Susp,AllSusps,Sbag) + ), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,SuspTerm), + get_static_suspension_field(F/A,SuspTerm,state,active,GetState) + ) + ), + Goal = ( + LookupGoal, + Sbag, + Susp = SuspTerm, % not inlined + GetState + ). +existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, + lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps), + hash_index_filter(Pairs,[Index],NPairs), + + functor(Head,F,A), + ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> + Sbag = (AllSusps = [Susp]) + ; + sbag_member_call(Susp,AllSusps,Sbag) + ), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,SuspTerm), + get_static_suspension_field(F/A,SuspTerm,state,active,GetState) + ) + ), + Goal = ( + LookupGoal, + Sbag, + Susp = SuspTerm, % not inlined + GetState + ). +existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- + lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps), + sbag_member_call(Susp,Susps,Sbag), + functor(Head,F,A), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,SuspTerm), + get_static_suspension_field(F/A,SuspTerm,state,active,GetState) + ) + ), + Goal = ( + UGoal, + Sbag, + Susp = SuspTerm, % not inlined + GetState + ). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict, +%% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar, +%% +VarArgDict,-NewVarArgDict) is det. +% +% Create existential hash lookup goal for given head. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- + hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index), + + hash_index_filter(Pairs,Index,NPairs), + + functor(Head,F,A), + ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> + Sbag = (AllSusps = [Susp]) + ; + sbag_member_call(Susp,AllSusps,Sbag) + ), + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(F/A,SuspTerm), + get_static_suspension_field(F/A,SuspTerm,state,active,GetState) + ) + ), + Goal = ( + LookupGoal, + Sbag, + Susp = SuspTerm, % not inlined + GetState + ). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +%% hash_index_filter(+Pairs,+Index,-NPairs) is det. +% +% Filter out pairs already covered by given hash index. +% makes them 'silent' +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% +hash_index_filter(Pairs,Index,NPairs) :- + hash_index_filter(Pairs,Index,1,NPairs). + +hash_index_filter([],_,_,[]). +hash_index_filter([P|Ps],Index,N,NPairs) :- + ( Index = [I|Is] -> + NN is N + 1, + ( I > N -> + NPairs = [P|NPs], + hash_index_filter(Ps,[I|Is],NN,NPs) + ; I == N -> + NPairs = [silent(P)|NPs], + hash_index_filter(Ps,Is,NN,NPs) + ) + ; + NPairs = [P|Ps] + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%------------------------------------------------------------------------------% +%% assume_constraint_stores(+ConstraintSymbols) is det. +% +% Compute all constraint store types that are possible for the given +% =ConstraintSymbols=. +%------------------------------------------------------------------------------% +assume_constraint_stores([]). +assume_constraint_stores([C|Cs]) :- + ( chr_pp_flag(debugable,off), + ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ), + is_stored(C), + get_store_type(C,default) -> + get_indexed_arguments(C,AllIndexedArgs), + get_constraint_mode(C,Modes), + aggregate_all(bag(Index)-count, + (member(Index,AllIndexedArgs),nth1(Index,Modes,+)), + IndexedArgs-NbIndexedArgs), + % Construct Index Combinations + ( NbIndexedArgs > 10 -> + findall([Index],member(Index,IndexedArgs),Indexes) + ; + findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes), + predsort(longer_list,UnsortedIndexes,Indexes) + ), + % EXPERIMENTAL HEURISTIC + % findall(Index, ( + % member(Arg1,IndexedArgs), + % member(Arg2,IndexedArgs), + % Arg1 =< Arg2, + % sort([Arg1,Arg2], Index) + % ), UnsortedIndexes), + % predsort(longer_list,UnsortedIndexes,Indexes), + % Choose Index Type + ( get_functional_dependency(C,1,Pattern,Key), + all_distinct_var_args(Pattern), Key == [] -> + assumed_store_type(C,global_singleton) + ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) -> + get_constraint_type_det(C,ArgTypes), + partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes), + + ( IntHashIndexes = [] -> + Stores = Stores1 + ; + Stores = [multi_inthash(IntHashIndexes)|Stores1] + ), + ( HashIndexes = [] -> + Stores1 = Stores2 + ; + Stores1 = [multi_hash(HashIndexes)|Stores2] + ), + ( IdentifierIndexes = [] -> + Stores2 = Stores3 + ; + maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes), + append(WrappedIdentifierIndexes,Stores3,Stores2) + ), + append(CompoundIdentifierIndexes,Stores4,Stores3), + ( only_ground_indexed_arguments(C) + -> Stores4 = [global_ground] + ; Stores4 = [default] + ), + assumed_store_type(C,multi_store(Stores)) + ; true + ) + ; + true + ), + assume_constraint_stores(Cs). + +%------------------------------------------------------------------------------% +%% partition_indexes(+Indexes,+Types, +%% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det. +%------------------------------------------------------------------------------% +partition_indexes([],_,[],[],[],[]). +partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :- + ( Index = [I], + nth1(I,Types,Type), + unalias_type(Type,UnAliasedType), + UnAliasedType == chr_identifier -> + IdentifierIndexes = [I|RIdentifierIndexes], + IntHashIndexes = RIntHashIndexes, + HashIndexes = RHashIndexes, + CompoundIdentifierIndexes = RCompoundIdentifierIndexes + ; Index = [I], + nth1(I,Types,Type), + unalias_type(Type,UnAliasedType), + nonvar(UnAliasedType), + UnAliasedType = chr_identifier(IndexType) -> + CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes], + IdentifierIndexes = RIdentifierIndexes, + IntHashIndexes = RIntHashIndexes, + HashIndexes = RHashIndexes + ; Index = [I], + nth1(I,Types,Type), + unalias_type(Type,UnAliasedType), + UnAliasedType == dense_int -> + IntHashIndexes = [Index|RIntHashIndexes], + HashIndexes = RHashIndexes, + IdentifierIndexes = RIdentifierIndexes, + CompoundIdentifierIndexes = RCompoundIdentifierIndexes + ; member(I,Index), + nth1(I,Types,Type), + unalias_type(Type,UnAliasedType), + nonvar(UnAliasedType), + UnAliasedType = chr_identifier(_) -> + % don't use chr_identifiers in hash indexes + IntHashIndexes = RIntHashIndexes, + HashIndexes = RHashIndexes, + IdentifierIndexes = RIdentifierIndexes, + CompoundIdentifierIndexes = RCompoundIdentifierIndexes + ; + IntHashIndexes = RIntHashIndexes, + HashIndexes = [Index|RHashIndexes], + IdentifierIndexes = RIdentifierIndexes, + CompoundIdentifierIndexes = RCompoundIdentifierIndexes + ), + partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes). + +longer_list(R,L1,L2) :- + length(L1,N1), + length(L2,N2), + compare(Rt,N2,N1), + ( Rt == (=) -> + compare(R,L1,L2) + ; + R = Rt + ). + +all_distinct_var_args(Term) :- + copy_term_nat(Term,TermCopy), + functor(Term,F,A), + functor(Pattern,F,A), + Pattern =@= TermCopy. + +get_indexed_arguments(C,IndexedArgs) :- + C = F/A, + get_indexed_arguments(1,A,C,IndexedArgs). + +get_indexed_arguments(I,N,C,L) :- + ( I > N -> + L = [] + ; ( is_indexed_argument(C,I) -> + L = [I|T] + ; + L = T + ), + J is I + 1, + get_indexed_arguments(J,N,C,T) + ). + +validate_store_type_assumptions([]). +validate_store_type_assumptions([C|Cs]) :- + validate_store_type_assumption(C), + validate_store_type_assumptions(Cs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% new code generation +universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :- + Rule = rule(H1,_,Guard,Body), + gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators), + universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0), + flatten(VarsAndSuspsList,VarsAndSusps), + Vars = [ [] | VarsAndSusps], + build_head(F,A,[O|Id],Vars,Head), + ( PrevId0 = [_] -> + get_success_continuation_code_id(F/A,O,PredictedPrevId), + % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]), + PrevId = [PredictedPrevId] % PrevId = PrevId0 + ; + PrevId = [O|PrevId0] + ), + build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall), + Clause = ( Head :- PredecessorCall), + add_dummy_location(Clause,LocatedClause), + L = [LocatedClause | T]. +% ( H1 == [], +% functor(CurrentHead,CF,CA), +% check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) -> +% L = T +% ; +% gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators), +% universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId), +% flatten(VarsAndSuspsList,VarsAndSusps), +% Vars = [ [] | VarsAndSusps], +% build_head(F,A,Id,Vars,Head), +% build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall), +% Clause = ( Head :- PredecessorCall), +% L = [Clause | T] +% ). + + % skips back intelligently over global_singleton lookups +universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :- + ( Id = [0|_] -> + % TOM: add partial success continuation optimization here! + next_id(Id,PrevId), + PrevVarsAndSusps = BaseCallArgs + ; + VarsAndSuspsList = [_|AllButFirstList], + dec_id(Id,PrevId1), + ( PrevHeads = [PrevHead|PrevHeads1], + functor(PrevHead,F,A), + check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) -> + PrevIterators = [_|PrevIterators1], + universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId) + ; + PrevId = PrevId1, + flatten(AllButFirstList,AllButFirst), + PrevIterators = [PrevIterator|_], + PrevVarsAndSusps = [PrevIterator|AllButFirst] + ) + ). + +universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators), + init(AllSusps,PreSusps), + flatten(PreVarsAndSuspsList,PreVarsAndSusps), + gen_var(OtherSusps), + functor(CurrentHead,OtherF,OtherA), + gen_vars(OtherA,OtherVars), + head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), + get_constraint_mode(OtherF/OtherA,Mode), + head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1), + + delay_phase_end(validate_store_type_assumptions, + ( static_suspension_term(OtherF/OtherA,OtherSuspension), + get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState), + get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars) + ) + ), + + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), + % create_get_mutable_ref(active,State,GetMutable), + CurrentSuspTest = ( + OtherSusp = OtherSuspension, + GetState, + DiffSuspGoals, + FirstMatching + ), + add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars), + lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps), + inc_id(Id,NestedId), + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,[O|Id],ClauseVars,ClauseHead), + passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars), + append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars), + build_head(F,A,[O|NestedId],NestedVars,NestedHead), + + ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime + universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0), + RecursiveVars = PreVarsAndSusps1 + ; + RecursiveVars = [OtherSusps|PreVarsAndSusps], + PrevId0 = Id + ), + ( PrevId0 = [_] -> + PrevId = PrevId0 + ; + PrevId = [O|PrevId0] + ), + build_head(F,A,PrevId,RecursiveVars,RecursiveHead), + + Clause = ( + ClauseHead :- + ( CurrentSuspTest, + NextSuspGoal + -> + NestedHead + ; RecursiveHead + ) + ), + add_dummy_location(Clause,LocatedClause), + L = [LocatedClause|T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Observation Analysis +% +% CLASSIFICATION +% Enabled +% +% Analysis based on Abstract Interpretation paper. +% +% TODO: +% stronger analysis domain [research] + +:- chr_constraint + initial_call_pattern/1, + call_pattern/1, + call_pattern_worker/1, + final_answer_pattern/2, + abstract_constraints/1, + depends_on/2, + depends_on_ap/4, + depends_on_goal/2, + ai_observed_internal/2, + % ai_observed/2, + ai_not_observed_internal/2, + ai_not_observed/2, + ai_is_observed/2, + depends_on_as/3, + ai_observation_gather_results/0. + +:- chr_type abstract_domain ---> odom(program_point,list(constraint)). +:- chr_type program_point == any. + +:- chr_option(mode,initial_call_pattern(+)). +:- chr_option(type_declaration,call_pattern(abstract_domain)). + +:- chr_option(mode,call_pattern(+)). +:- chr_option(type_declaration,call_pattern(abstract_domain)). + +:- chr_option(mode,call_pattern_worker(+)). +:- chr_option(type_declaration,call_pattern_worker(abstract_domain)). + +:- chr_option(mode,final_answer_pattern(+,+)). +:- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)). + +:- chr_option(mode,abstract_constraints(+)). +:- chr_option(type_declaration,abstract_constraints(list)). + +:- chr_option(mode,depends_on(+,+)). +:- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)). + +:- chr_option(mode,depends_on_as(+,+,+)). +:- chr_option(mode,depends_on_ap(+,+,+,+)). +:- chr_option(mode,depends_on_goal(+,+)). +:- chr_option(mode,ai_is_observed(+,+)). +:- chr_option(mode,ai_not_observed(+,+)). +% :- chr_option(mode,ai_observed(+,+)). +:- chr_option(mode,ai_not_observed_internal(+,+)). +:- chr_option(mode,ai_observed_internal(+,+)). + + +abstract_constraints_fd @ + abstract_constraints(_) \ abstract_constraints(_) <=> true. + +ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true. +ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true. +ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true. + +ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail. +ai_is_observed(_,_) <=> true. + +ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O). +ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O). +ai_observation_gather_results <=> true. + +%------------------------------------------------------------------------------% +% Main Analysis Entry +%------------------------------------------------------------------------------% +ai_observation_analysis(ACs) :- + ( chr_pp_flag(ai_observation_analysis,on), + get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment -> + list_to_ord_set(ACs,ACSet), + abstract_constraints(ACSet), + ai_observation_schedule_initial_calls(ACSet,ACSet), + ai_observation_gather_results + ; + true + ). + +ai_observation_schedule_initial_calls([],_). +ai_observation_schedule_initial_calls([AC|RACs],ACs) :- + ai_observation_schedule_initial_call(AC,ACs), + ai_observation_schedule_initial_calls(RACs,ACs). + +ai_observation_schedule_initial_call(AC,ACs) :- + ai_observation_top(AC,CallPattern), + % ai_observation_bot(AC,ACs,CallPattern), + initial_call_pattern(CallPattern). + +ai_observation_schedule_new_calls([],AP). +ai_observation_schedule_new_calls([AC|ACs],AP) :- + AP = odom(_,Set), + initial_call_pattern(odom(AC,Set)), + ai_observation_schedule_new_calls(ACs,AP). + +final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2) + <=> + ai_observation_leq(AP2,AP1) + | + true. + +initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true. + +initial_call_pattern(CP) ==> call_pattern(CP). + +initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3 + ==> + ai_observation_schedule_new_calls(ACs,AP) + pragma + passive(ID3). + +call_pattern(CP) \ call_pattern(CP) <=> true. + +depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==> + final_answer_pattern(CP1,AP). + + %call_pattern(CP) ==> writeln(call_pattern(CP)). + +call_pattern(CP) ==> call_pattern_worker(CP). + +%------------------------------------------------------------------------------% +% Abstract Goal +%------------------------------------------------------------------------------% + + % AbstractGoala +%call_pattern(odom([],Set)) ==> +% final_answer_pattern(odom([],Set),odom([],Set)). + +call_pattern_worker(odom([],Set)) <=> + % writeln(' - AbstractGoal'(odom([],Set))), + final_answer_pattern(odom([],Set),odom([],Set)). + + % AbstractGoalb +call_pattern_worker(odom([G|Gs],Set)) <=> + % writeln(' - AbstractGoal'(odom([G|Gs],Set))), + CP1 = odom(G,Set), + depends_on_goal(odom([G|Gs],Set),CP1), + call_pattern(CP1). + +depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID + <=> true pragma passive(ID). +depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) + ==> + CP1 = odom([_|Gs],_), + AP2 = odom([],Set), + CCP = odom(Gs,Set), + call_pattern(CCP), + depends_on(CP1,CCP). + +%------------------------------------------------------------------------------% +% Abstract Disjunction +%------------------------------------------------------------------------------% + +call_pattern_worker(odom((AG1;AG2),Set)) <=> + CP = odom((AG1;AG2),Set), + InitialAnswerApproximation = odom([],Set), + final_answer_pattern(CP,InitialAnswerApproximation), + CP1 = odom(AG1,Set), + CP2 = odom(AG2,Set), + call_pattern(CP1), + call_pattern(CP2), + depends_on_as(CP,CP1,CP2). + +%------------------------------------------------------------------------------% +% Abstract Solve +%------------------------------------------------------------------------------% +call_pattern_worker(odom(builtin,Set)) <=> + % writeln(' - AbstractSolve'(odom(builtin,Set))), + ord_empty(EmptySet), + final_answer_pattern(odom(builtin,Set),odom([],EmptySet)). + +%------------------------------------------------------------------------------% +% Abstract Drop +%------------------------------------------------------------------------------% +max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) + <=> + O > MO + | + % writeln(' - AbstractDrop'(odom(occ(C,O),Set))), + final_answer_pattern(odom(occ(C,O),Set),odom([],Set)) + pragma + passive(ID2). + +%------------------------------------------------------------------------------% +% Abstract Activate +%------------------------------------------------------------------------------% +call_pattern_worker(odom(AC,Set)) + <=> + AC = _ / _ + | + % writeln(' - AbstractActivate'(odom(AC,Set))), + CP = odom(occ(AC,1),Set), + call_pattern(CP), + depends_on(odom(AC,Set),CP). + +%------------------------------------------------------------------------------% +% Abstract Passive +%------------------------------------------------------------------------------% +occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) + <=> + is_passive(RuleNb,ID) + | + % writeln(' - AbstractPassive'(odom(occ(C,O),Set))), + % DEFAULT + NO is O + 1, + DCP = odom(occ(C,NO),Set), + call_pattern(DCP), + final_answer_pattern(odom(occ(C,O),Set),odom([],Set)), + depends_on(odom(occ(C,O),Set),DCP) + pragma + passive(ID2). +%------------------------------------------------------------------------------% +% Abstract Simplify +%------------------------------------------------------------------------------% + + % AbstractSimplify +occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) + <=> + \+ is_passive(RuleNb,ID) + | + % writeln(' - AbstractPassive'(odom(occ(C,O),Set))), + ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads), + ai_observation_observe_set(Set,AbstractRestHeads,Set2), + ai_observation_memo_abstract_goal(RuleNb,AG), + call_pattern(odom(AG,Set2)), + % DEFAULT + NO is O + 1, + DCP = odom(occ(C,NO),Set), + call_pattern(DCP), + depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP), + % DEADLOCK AVOIDANCE + final_answer_pattern(odom(occ(C,O),Set),odom([],Set)) + pragma + passive(ID2). + +depends_on_as(CP,CPS,CPD), + final_answer_pattern(CPS,APS), + final_answer_pattern(CPD,APD) ==> + ai_observation_lub(APS,APD,AP), + final_answer_pattern(CP,AP). + + +:- chr_constraint + ai_observation_memo_simplification_rest_heads/3, + ai_observation_memoed_simplification_rest_heads/3. + +:- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)). +:- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)). + +ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH) + <=> + QRH = RH. +abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH) + <=> + Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_), + once(select2(ID,_,IDs1,H1,_,RestH1)), + ai_observation_abstract_constraints(RestH1,ACs,ARestHeads), + ai_observation_abstract_constraints(H2,ACs,AH2), + append(ARestHeads,AH2,AbstractHeads), + sort(AbstractHeads,QRH), + ai_observation_memoed_simplification_rest_heads(C,O,QRH) + pragma + passive(ID1), + passive(ID2), + passive(ID3). + +ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail. + +%------------------------------------------------------------------------------% +% Abstract Propagate +%------------------------------------------------------------------------------% + + + % AbstractPropagate +occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) + <=> + \+ is_passive(RuleNb,ID) + | + % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))), + % observe partners + ai_observation_memo_propagation_rest_heads(C,O,AHs), + ai_observation_observe_set(Set,AHs,Set2), + ord_add_element(Set2,C,Set3), + ai_observation_memo_abstract_goal(RuleNb,AG), + call_pattern(odom(AG,Set3)), + ( ord_memberchk(C,Set2) -> + Delete = no + ; + Delete = yes + ), + % DEFAULT + NO is O + 1, + DCP = odom(occ(C,NO),Set), + call_pattern(DCP), + depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete) + pragma + passive(ID2). + +:- chr_constraint + ai_observation_memo_propagation_rest_heads/3, + ai_observation_memoed_propagation_rest_heads/3. + +:- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)). +:- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)). + +ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH) + <=> + QRH = RH. +abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH) + <=> + Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_), + once(select2(ID,_,IDs2,H2,_,RestH2)), + ai_observation_abstract_constraints(RestH2,ACs,ARestHeads), + ai_observation_abstract_constraints(H1,ACs,AH1), + append(ARestHeads,AH1,AbstractHeads), + sort(AbstractHeads,QRH), + ai_observation_memoed_propagation_rest_heads(C,O,QRH) + pragma + passive(ID1), + passive(ID2), + passive(ID3). + +ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail. + +depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==> + final_answer_pattern(CP,APD). +depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP), + final_answer_pattern(CPD,APD) ==> + true | + CP = odom(occ(C,O),_), + ( ai_observation_is_observed(APP,C) -> + ai_observed_internal(C,O) + ; + ai_not_observed_internal(C,O) + ), + ( Delete == yes -> + APP = odom([],Set0), + ord_del_element(Set0,C,Set), + NAPP = odom([],Set) + ; + NAPP = APP + ), + ai_observation_lub(NAPP,APD,AP), + final_answer_pattern(CP,AP). + +%------------------------------------------------------------------------------% +% Catch All +%------------------------------------------------------------------------------% + +call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]). + +%------------------------------------------------------------------------------% +% Auxiliary Predicates +%------------------------------------------------------------------------------% + +ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :- + ord_intersection(S1,S2,S3). + +ai_observation_bot(AG,AS,odom(AG,AS)). + +ai_observation_top(AG,odom(AG,EmptyS)) :- + ord_empty(EmptyS). + +ai_observation_leq(odom(AG,S1),odom(AG,S2)) :- + ord_subset(S2,S1). + +ai_observation_observe_set(S,ACSet,NS) :- + ord_subtract(S,ACSet,NS). + +ai_observation_abstract_constraint(C,ACs,AC) :- + functor(C,F,A), + AC = F/A, + memberchk(AC,ACs). + +ai_observation_abstract_constraints(Cs,ACs,NACs) :- + findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs). + +%------------------------------------------------------------------------------% +% Abstraction of Rule Bodies +%------------------------------------------------------------------------------% + +:- chr_constraint + ai_observation_memoed_abstract_goal/2, + ai_observation_memo_abstract_goal/2. + +:- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)). +:- chr_option(mode,ai_observation_memo_abstract_goal(+,?)). + +ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG) + <=> + QAG = AG + pragma + passive(ID1). + +rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG) + <=> + Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_), + ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG), + QAG = AG, + ai_observation_memoed_abstract_goal(RuleNb,AG) + pragma + passive(ID1), + passive(ID2). + +ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :- + % also guard: e.g. b, c(X) ==> Y=X | p(Y). + term_variables((H1,H2,Guard),HVars), + append(H1,H2,Heads), + % variables that are declared to be ground are safe, + ground_vars(Heads,GroundVars), + % so we remove them from the list of 'dangerous' head variables + list_difference_eq(HVars,GroundVars,HV), + ai_observation_abstract_goal(G,ACs,AG,[],HV),!. + % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)). + % HV are 'dangerous' variables, all others are fresh and safe + +ground_vars([],[]). +ground_vars([H|Hs],GroundVars) :- + functor(H,F,A), + get_constraint_mode(F/A,Mode), + % TOM: fix this code! + head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs), + head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1), + ground_vars(Hs,GroundVars2), + append(GroundVars1,GroundVars2,GroundVars). + +ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction + ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV), + ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV). +ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction + ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV), + ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV). +ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then + ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV), + ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV). +ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :- + ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint +ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !. +ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !. +% non-CHR constraint is safe if it only binds fresh variables +ai_observation_abstract_goal(G,_,Tail,Tail,HV) :- + builtin_binds_b(G,Vars), + intersect_eq(Vars,HV,[]), + !. +ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :- + AG = builtin. % default case if goal is not recognized/safe + +ai_observation_is_observed(odom(_,ACSet),AC) :- + \+ ord_memberchk(AC,ACSet). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +unconditional_occurrence(C,O) :- + get_occurrence(C,O,RuleNb,ID), + get_rule(RuleNb,PRule), + PRule = pragma(ORule,_,_,_,_), + copy_term_nat(ORule,Rule), + Rule = rule(H1,H2,Guard,_), + guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard), + once(( + H1 = [Head], H2 == [] + ; + H2 = [Head], H1 == [], \+ may_trigger(C) + )), + all_distinct_var_args(Head). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Partial wake analysis +% +% In a Var = Var unification do not wake up constraints of both variables, +% but rather only those of one variable. +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +:- chr_constraint partial_wake_analysis/0. +:- chr_constraint no_partial_wake/1. +:- chr_option(mode,no_partial_wake(+)). +:- chr_constraint wakes_partially/1. +:- chr_option(mode,wakes_partially(+)). + +partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes) + ==> + Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_), + ( is_passive(RuleNb,ID) -> + true + ; Type == simplification -> + select(H,H1,RestH1), + H =.. [_|Args], + term_variables(Guard,Vars), + partial_wake_args(Args,ArgModes,Vars,FA) + ; % Type == propagation -> + select(H,H2,RestH2), + H =.. [_|Args], + term_variables(Guard,Vars), + partial_wake_args(Args,ArgModes,Vars,FA) + ). + +partial_wake_args([],_,_,_). +partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :- + ( Mode \== (+) -> + ( nonvar(Arg) -> + no_partial_wake(C) + ; memberchk_eq(Arg,Vars) -> + no_partial_wake(C) + ; + true + ) + ; + true + ), + partial_wake_args(Args,Modes,Vars,C). + +no_partial_wake(C) \ no_partial_wake(C) <=> true. + +no_partial_wake(C) \ wakes_partially(C) <=> fail. + +wakes_partially(C) <=> true. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Generate rules that implement chr_show_store/1 functionality. +% +% CLASSIFICATION +% Experimental +% Unused +% +% Generates additional rules: +% +% $show, C1 # ID ==> writeln(C1) pragma passive(ID). +% ... +% $show, Cn # ID ==> writeln(Cn) pragma passive(ID). +% $show <=> true. + +generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :- + ( chr_pp_flag(show,on) -> + Constraints = ['$show'/0|Constraints0], + generate_show_rules(Constraints0,Rules,[Rule|Rules0]), + inc_rule_count(RuleNb), + Rule = pragma( + rule(['$show'],[],true,true), + ids([0],[]), + [], + no, + RuleNb + ) + ; + Constraints = Constraints0, + Rules = Rules0 + ). + +generate_show_rules([],Rules,Rules). +generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :- + functor(C,F,A), + inc_rule_count(RuleNb), + Rule = pragma( + rule([],['$show',C],true,writeln(C)), + ids([],[0,1]), + [passive(1)], + no, + RuleNb + ), + generate_show_rules(Rest,Tail,Rules). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Custom supension term layout + +static_suspension_term(F/A,Suspension) :- + suspension_term_base(F/A,Base), + Arity is Base + A, + functor(Suspension,suspension,Arity). + +has_suspension_field(FA,Field) :- + suspension_term_base_fields(FA,Fields), + memberchk(Field,Fields). + +suspension_term_base(FA,Base) :- + suspension_term_base_fields(FA,Fields), + length(Fields,Base). + +suspension_term_base_fields(FA,Fields) :- + ( chr_pp_flag(debugable,on) -> + % 1. ID + % 2. State + % 3. Propagation History + % 4. Generation Number + % 5. Continuation Goal + % 6. Functor + Fields = [id,state,history,generation,continuation,functor] + ; + ( uses_history(FA) -> + Fields = [id,state,history|Fields2] + ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) -> + Fields = [state|Fields2] + ; + Fields = [id,state|Fields2] + ), + ( only_ground_indexed_arguments(FA) -> + get_store_type(FA,StoreType), + basic_store_types(StoreType,BasicStoreTypes), + ( memberchk(global_ground,BasicStoreTypes) -> + % 1. ID + % 2. State + % 3. Propagation History + % 4. Global List Prev + Fields2 = [global_list_prev|Fields3] + ; + % 1. ID + % 2. State + % 3. Propagation History + Fields2 = Fields3 + ), + ( chr_pp_flag(ht_removal,on) + -> ht_prev_fields(BasicStoreTypes,Fields3) + ; Fields3 = [] + ) + ; may_trigger(FA) -> + % 1. ID + % 2. State + % 3. Propagation History + ( uses_field(FA,generation) -> + % 4. Generation Number + % 5. Global List Prev + Fields2 = [generation,global_list_prev|Fields3] + ; + Fields2 = [global_list_prev|Fields3] + ), + ( chr_pp_flag(mixed_stores,on), + chr_pp_flag(ht_removal,on) + -> get_store_type(FA,StoreType), + basic_store_types(StoreType,BasicStoreTypes), + ht_prev_fields(BasicStoreTypes,Fields3) + ; Fields3 = [] + ) + ; + % 1. ID + % 2. State + % 3. Propagation History + % 4. Global List Prev + Fields2 = [global_list_prev|Fields3], + ( chr_pp_flag(mixed_stores,on), + chr_pp_flag(ht_removal,on) + -> get_store_type(FA,StoreType), + basic_store_types(StoreType,BasicStoreTypes), + ht_prev_fields(BasicStoreTypes,Fields3) + ; Fields3 = [] + ) + ) + ). + +ht_prev_fields(Stores,Prevs) :- + ht_prev_fields_int(Stores,PrevsList), + append(PrevsList,Prevs). +ht_prev_fields_int([],[]). +ht_prev_fields_int([H|T],Fields) :- + ( H = multi_hash(Indexes) + -> maplist(ht_prev_field,Indexes,FH), + Fields = [FH|FT] + ; Fields = FT + ), + ht_prev_fields_int(T,FT). + +ht_prev_field(Index,Field) :- + concat_atom(['multi_hash_prev-'|Index],Field). + +get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :- + suspension_term_base_fields(FA,Fields), + nth1(Index,Fields,FieldName), !, + arg(Index,StaticSuspension,Field). +get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !, + suspension_term_base(FA,Base), + StaticSuspension =.. [_|Args], + drop(Base,Args,Field). +get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :- + chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]). + + +get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- + suspension_term_base_fields(FA,Fields), + nth1(Index,Fields,FieldName), !, + Goal = arg(Index,DynamicSuspension,Field). +get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !, + static_suspension_term(FA,StaticSuspension), + get_static_suspension_term_field(arguments,FA,StaticSuspension,Field), + Goal = (DynamicSuspension = StaticSuspension). +get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !, + suspension_term_base(FA,Base), + Index is I + Base, + Goal = arg(Index,DynamicSuspension,Field). +get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- + chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]). + + +set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- + suspension_term_base_fields(FA,Fields), + nth1(Index,Fields,FieldName), !, + Goal = setarg(Index,DynamicSuspension,Field). +set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- + chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]). + +basic_store_types(multi_store(Types),Types) :- !. +basic_store_types(Type,[Type]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% + +:- chr_constraint + phase_end/1, + delay_phase_end/2. + +:- chr_option(mode,phase_end(+)). +:- chr_option(mode,delay_phase_end(+,?)). + +phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal). +% phase_end(Phase) <=> true. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- chr_constraint + does_use_history/2, + uses_history/1, + novel_production_call/4. + +:- chr_option(mode,uses_history(+)). +:- chr_option(mode,does_use_history(+,+)). +:- chr_option(mode,novel_production_call(+,+,?,?)). + +does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true. +does_use_history(FA,_) \ uses_history(FA) <=> true. +uses_history(_FA) <=> fail. + +does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal. +novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true. + +:- chr_constraint + does_use_field/2, + uses_field/2. + +:- chr_option(mode,uses_field(+,+)). +:- chr_option(mode,does_use_field(+,+)). + +does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true. +does_use_field(FA,Field) \ uses_field(FA,Field) <=> true. +uses_field(_FA,_Field) <=> fail. + +:- chr_constraint + uses_state/2, + if_used_state/5, + used_states_known/0. + +:- chr_option(mode,uses_state(+,+)). +:- chr_option(mode,if_used_state(+,+,?,?,?)). + + +% states ::= not_stored_yet | passive | active | triggered | removed +% +% allocate CREATES not_stored_yet +% remove CHECKS not_stored_yet +% activate CHECKS not_stored_yet +% +% ==> no allocate THEN no not_stored_yet + +% recurs CREATES inactive +% lookup CHECKS inactive + +% insert CREATES active +% activate CREATES active +% lookup CHECKS active +% recurs CHECKS active + +% runsusp CREATES triggered +% lookup CHECKS triggered +% +% ==> no runsusp THEN no triggered + +% remove CREATES removed +% runsusp CHECKS removed +% lookup CHECKS removed +% recurs CHECKS removed +% +% ==> no remove THEN no removed + +% ==> no allocate, no remove, no active/inactive distinction THEN no state at all... + +uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true. + +used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) + <=> ResultGoal = Used. +used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) + <=> ResultGoal = NotUsed. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES +% (Feature for SSS) +% +% 1. Checking +% ~~~~~~~~~~~ +% +% When the programmer enables the `declare_stored_constraints' option, i.e. writes +% +% :- chr_option(declare_stored_constraints,on). +% +% the compiler will check for the storedness of constraints. +% +% By default, the compiler assumes that the programmer wants his constraints to +% be never-stored. Hence, a warning will be issues when a constraint is actually +% stored. +% +% Such warnings are suppressed, if the programmer adds the `# stored' modifier +% to a constraint declaration, i.e. writes +% +% :- chr_constraint c(...) # stored. +% +% In that case a warning is issued when the constraint is never-stored. +% +% NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all +% constraints are stored anyway. +% +% +% 2. Rule Generation +% ~~~~~~~~~~~~~~~~~~ +% +% When the programmer enables the `declare_stored_constraints' option, i.e. writes +% +% :- chr_option(declare_stored_constraints,on). +% +% the compiler will generate default simplification rules for constraints. +% +% By default, no default rule is generated for a constraint. However, if the +% programmer writes a default/1 annotation in the constraint declaration, i.e. writes +% +% :- chr_constraint c(...) # default(Goal). +% +% where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'), +% the compiler generates a rule: +% +% c(_,...,_) <=> Goal. +% +% at the end of the program. If multiple default rules are generated, for several constraints, +% then the order of the default rules is not specified. + + +:- chr_constraint stored_assertion/1. +:- chr_option(mode,stored_assertion(+)). +:- chr_option(type_declaration,stored_assertion(constraint)). + +:- chr_constraint never_stored_default/2. +:- chr_option(mode,never_stored_default(+,?)). +:- chr_option(type_declaration,never_stored_default(constraint,any)). + +% Rule Generation +% ~~~~~~~~~~~~~~~ + +generate_never_stored_rules(Constraints,Rules) :- + ( chr_pp_flag(declare_stored_constraints,on) -> + never_stored_rules(Constraints,Rules) + ; + Rules = [] + ). + +:- chr_constraint never_stored_rules/2. +:- chr_option(mode,never_stored_rules(+,?)). +:- chr_option(type_declaration,never_stored_rules(list(constraint),any)). + +never_stored_rules([],Rules) <=> Rules = []. +never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=> + Constraint = F/A, + functor(Head,F,A), + inc_rule_count(RuleNb), + Rule = pragma( + rule([Head],[],true,Goal), + ids([0],[]), + [], + no, + RuleNb + ), + Rules = [Rule|Tail], + never_stored_rules(Constraints,Tail). +never_stored_rules([_|Constraints],Rules) <=> + never_stored_rules(Constraints,Rules). + +% Checking +% ~~~~~~~~ + +check_storedness_assertions(Constraints) :- + ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) -> + forall(Constraint,Constraints,check_storedness_assertion(Constraint)) + ; + true + ). + + +:- chr_constraint check_storedness_assertion/1. +:- chr_option(mode,check_storedness_assertion(+)). +:- chr_option(type_declaration,check_storedness_assertion(constraint)). + +check_storedness_assertion(Constraint), stored_assertion(Constraint) + <=> ( is_stored(Constraint) -> + true + ; + chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint]) + ). +never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint) + <=> ( is_finally_stored(Constraint) -> + chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint]) + ; is_stored(Constraint) -> + chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint]) + ; + true + ). + % never-stored, no default goal +check_storedness_assertion(Constraint) + <=> ( is_finally_stored(Constraint) -> + chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint]) + ; is_stored(Constraint) -> + chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint]) + ; + true + ). + +%^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +% success continuation analysis + +% TODO +% also use for forward jumping improvement! +% use Prolog indexing for generated code +% +% EXPORTED +% +% should_skip_to_next_id(C,O) +% +% get_occurrence_code_id(C,O,Id) +% +%vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + +continuation_analysis(ConstraintSymbols) :- + maplist(analyse_continuations,ConstraintSymbols). + +analyse_continuations(C) :- + % 1. compute success continuations of the + % occurrences of constraint C + continuation_analysis(C,1), + % 2. determine for which occurrences + % to skip to next code id + get_max_occurrence(C,MO), + LO is MO + 1, + bulk_propagation(C,1,LO), + % 3. determine code id for each occurrence + set_occurrence_code_id(C,1,0). + +% 1. Compute the success continuations of constrait C +%------------------------------------------------------------------------------- + +continuation_analysis(C,O) :- + get_max_occurrence(C,MO), + ( O > MO -> + true + ; O == MO -> + NextO is O + 1, + continuation_occurrence(C,O,NextO) + ; + constraint_continuation(C,O,MO,NextO), + continuation_occurrence(C,O,NextO), + NO is O + 1, + continuation_analysis(C,NO) + ). + +constraint_continuation(C,O,MO,NextO) :- + ( get_occurrence_head(C,O,Head) -> + NO is O + 1, + ( between(NO,MO,NextO), + get_occurrence_head(C,NextO,NextHead), + unifiable(Head,NextHead,_) -> + true + ; + NextO is MO + 1 + ) + ; % current occurrence is passive + NextO = MO + ). + +get_occurrence_head(C,O,Head) :- + get_occurrence(C,O,RuleNb,Id), + \+ is_passive(RuleNb,Id), + get_rule(RuleNb,Rule), + Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_), + ( select2(Id,Head,Ids1,H1,_,_) -> true + ; select2(Id,Head,Ids2,H2,_,_) + ). + +:- chr_constraint continuation_occurrence/3. +:- chr_option(mode,continuation_occurrence(+,+,+)). + +:- chr_constraint get_success_continuation_occurrence/3. +:- chr_option(mode,get_success_continuation_occurrence(+,+,-)). + +continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X) + <=> + X = NO. + +get_success_continuation_occurrence(C,O,X) + <=> + chr_error(internal,'Success continuation not found for ~w.\n',[C:O]). + +% 2. figure out when to skip to next code id +%------------------------------------------------------------------------------- + % don't go beyond the last occurrence + % we have to go to next id for storage here + +:- chr_constraint skip_to_next_id/2. +:- chr_option(mode,skip_to_next_id(+,+)). + +:- chr_constraint should_skip_to_next_id/2. +:- chr_option(mode,should_skip_to_next_id(+,+)). + +skip_to_next_id(C,O) \ should_skip_to_next_id(C,O) + <=> + true. + +should_skip_to_next_id(_,_) + <=> + fail. + +:- chr_constraint bulk_propagation/3. +:- chr_option(mode,bulk_propagation(+,+,+)). + +max_occurrence(C,MO) \ bulk_propagation(C,O,_) + <=> + O >= MO + | + skip_to_next_id(C,O). + % we have to go to the next id here because + % a predecessor needs it +bulk_propagation(C,O,LO) + <=> + LO =:= O + 1 + | + skip_to_next_id(C,O), + get_max_occurrence(C,MO), + NLO is MO + 1, + bulk_propagation(C,LO,NLO). + % we have to go to the next id here because + % we're running into a simplification rule + % IMPROVE: propagate back to propagation predecessor (IF ANY) +occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO) + <=> + NO =:= O + 1 + | + skip_to_next_id(C,O), + get_max_occurrence(C,MO), + NLO is MO + 1, + bulk_propagation(C,NO,NLO). + % we skip the next id here + % and go to the next occurrence +continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO) + <=> + NextO > O + 1 + | + NLO is min(LO,NextO), + NO is O + 1, + bulk_propagation(C,NO,NLO). + % default case + % err on the safe side +bulk_propagation(C,O,LO) + <=> + skip_to_next_id(C,O), + get_max_occurrence(C,MO), + NLO is MO + 1, + NO is O + 1, + bulk_propagation(C,NO,NLO). + +skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true. + + % if this occurrence is passive, but has to skip, + % then the previous one must skip instead... + % IMPROVE reasoning is conservative +occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O) + ==> + O > 1 + | + PO is O - 1, + skip_to_next_id(C,PO). + +% 3. determine code id of each occurrence +%------------------------------------------------------------------------------- + +:- chr_constraint set_occurrence_code_id/3. +:- chr_option(mode,set_occurrence_code_id(+,+,+)). + +:- chr_constraint occurrence_code_id/3. +:- chr_option(mode,occurrence_code_id(+,+,+)). + + % stop at the end +set_occurrence_code_id(C,O,IdNb) + <=> + get_max_occurrence(C,MO), + O > MO + | + occurrence_code_id(C,O,IdNb). + + % passive occurrences don't change the code id +occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb) + <=> + occurrence_code_id(C,O,IdNb), + NO is O + 1, + set_occurrence_code_id(C,NO,IdNb). + +occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb) + <=> + occurrence_code_id(C,O,IdNb), + NO is O + 1, + set_occurrence_code_id(C,NO,IdNb). + +occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb) + <=> + occurrence_code_id(C,O,IdNb), + NO is O + 1, + NIdNb is IdNb + 1, + set_occurrence_code_id(C,NO,NIdNb). + +occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb) + <=> + occurrence_code_id(C,O,IdNb), + NO is O + 1, + set_occurrence_code_id(C,NO,IdNb). + +% occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)). + +:- chr_constraint get_occurrence_code_id/3. +:- chr_option(mode,get_occurrence_code_id(+,+,-)). + +occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X) + <=> + X = IdNb. + +get_occurrence_code_id(C,O,X) + <=> + ( O == 0 -> + true % X = 0 + ; + format('no occurrence code for ~w!\n',[C:O]) + ). + +get_success_continuation_code_id(C,O,NextId) :- + get_success_continuation_occurrence(C,O,NextO), + get_occurrence_code_id(C,NextO,NextId). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% COLLECT CONSTANTS FOR INLINING +% +% for SSS + +%%% TODO: APPLY NEW DICT FORMAT DOWNWARDS + +% collect_constants(+rules,+ast_rules,+constraint_symbols,+clauses) {{{ +collect_constants(Rules,AstRules,Constraints,Clauses0) :- + ( not_restarted, chr_pp_flag(experiment,on) -> + ( chr_pp_flag(sss,on) -> + Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no], + copy_term_nat(Clauses0,Clauses), + flatten_clauses(Clauses,Dictionary,FlatClauses), + install_new_declarations_and_restart(FlatClauses) + ; + maplist(collect_rule_constants(Constraints),AstRules), + ( chr_pp_flag(verbose,on) -> + print_chr_constants + ; + true + ), + ( chr_pp_flag(experiment,on) -> + flattening_dictionary(Constraints,Dictionary), + copy_term_nat(Clauses0,Clauses), + flatten_clauses(Clauses,Dictionary,FlatClauses), + install_new_declarations_and_restart(FlatClauses) + ; + true + ) + ) + ; + true + ). + +:- chr_constraint chr_constants/1. +:- chr_option(mode,chr_constants(+)). + +:- chr_constraint get_chr_constants/1. + +chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants. + +get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = []. + +% collect_rule_constants(+constraint_symbols,+ast_rule) {{{ +collect_rule_constants(Constraints,AstRule) :- + AstRule = ast_rule(AstHead,_,_,AstBody,_), + collect_head_constants(AstHead), + collect_body_constants(AstBody,Constraints). + +collect_head_constants(simplification(H1)) :- + maplist(collect_constraint_constants,H1). +collect_head_constants(propagation(H2)) :- + maplist(collect_constraint_constants,H2). +collect_head_constants(simpagation(H1,H2)) :- + maplist(collect_constraint_constants,H1), + maplist(collect_constraint_constants,H2). + +collect_body_constants(AstBody,Constraints) :- + maplist(collect_goal_constants(Constraints),AstBody). + +collect_goal_constants(Constraints,Goal) :- + ( ast_nonvar(Goal) -> + ast_symbol(Goal,Symbol), + ( memberchk(Symbol,Constraints) -> + ast_term_to_term(Goal,Term), + ast_args(Goal,Arguments), + collect_constraint_constants(chr_constraint(Symbol,Arguments,Term)) + ; Symbol == (:)/2, + ast_args(Goal,[Arg1,Goal2]), + Arg1 = atomic(Mod), + get_target_module(Module), + Mod == Module, + ast_nonvar(Goal2), + ast_symbol(Goal2,Symbol2), + memberchk(Symbol2,Constraints) -> + ast_term_to_term(Goal2,Term2), + ast_args(Goal2,Arguments2), + collect_constraint_constants(chr_constraint(Symbol2,Arguments2,Term2)) + ; + true + ) + ; + true + ). + +collect_constraint_constants(Head) :- + Head = chr_constraint(Symbol,Arguments,_), + get_constraint_type_det(Symbol,Types), + collect_all_arg_constants(Arguments,Types,[]). + +collect_all_arg_constants([],[],Constants) :- + ( Constants \== [] -> + add_chr_constants(Constants) + ; + true + ). +collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :- + unalias_type(Type,NormalizedType), + ( is_chr_constants_type(NormalizedType,Key,_) -> + ( ast_ground(Arg) -> + ast_term_to_term(Arg,Term), + collect_all_arg_constants(Args,Types,[Key-Term|Constants0]) + ; % no useful information here + true + ) + ; + collect_all_arg_constants(Args,Types,Constants0) + ). + +add_chr_constants(Pairs) :- + keysort(Pairs,SortedPairs), + add_chr_constants_(SortedPairs). + +:- chr_constraint add_chr_constants_/1. +:- chr_option(mode,add_chr_constants_(+)). + +add_chr_constants_(Constants), chr_constants(MoreConstants) <=> + sort([Constants|MoreConstants],NConstants), + chr_constants(NConstants). + +add_chr_constants_(Constants) <=> + chr_constants([Constants]). + +% }}} + +:- chr_constraint print_chr_constants/0. % {{{ + +print_chr_constants, chr_constants(Constants) # Id ==> + format('\t* chr_constants : ~w.\n',[Constants]) + pragma passive(Id). + +print_chr_constants <=> + true. + +% }}} + +% flattening_dictionary(+constraint_symbols,-dictionary) {{{ +flattening_dictionary([],[]). +flattening_dictionary([CS|CSs],Dictionary) :- + ( flattening_dictionary_entry(CS,Entry) -> + Dictionary = [Entry|Rest] + ; + Dictionary = Rest + ), + flattening_dictionary(CSs,Rest). + +flattening_dictionary_entry(CS,Entry) :- + get_constraint_type_det(CS,Types), + constant_positions(Types,1,Positions,Keys,Handler,MaybeEnum), + ( Positions \== [] -> % there are chr_constant arguments + pairup(Keys,Constants,Pairs0), + keysort(Pairs0,Pairs), + Entry = CS-Positions-Specs-Handler, + get_chr_constants(ConstantsList), + findall(Spec, + ( member(Pairs,ConstantsList) + , flat_spec(CS,Positions,Constants,Spec) + ), + Specs) + ; MaybeEnum == yes -> + enum_positions(Types,1,EnumPositions,ConstantsLists,EnumHandler), + Entry = CS-EnumPositions-Specs-EnumHandler, + findall(Spec, + ( cartesian_product(Terms,ConstantsLists) + , flat_spec(CS,EnumPositions,Terms,Spec) + ), + Specs) + ). + +constant_positions([],_,[],[],no,no). +constant_positions([Type|Types],I,Positions,Keys,Handler,MaybeEnum) :- + unalias_type(Type,NormalizedType), + ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) -> + compose_error_handlers(ErrorHandler,NHandler,Handler), + Positions = [I|NPositions], + Keys = [Key|NKeys], + MaybeEnum = NMaybeEnum + ; + ( is_chr_enum_type(NormalizedType,_,_) -> + MaybeEnum = yes + ; + MaybeEnum = NMaybeEnum + ), + NPositions = Positions, + NKeys = Keys, + NHandler = Handler + ), + J is I + 1, + constant_positions(Types,J,NPositions,NKeys,NHandler,NMaybeEnum). + +compose_error_handlers(no,Handler,Handler). +compose_error_handlers(yes(Handler),_,yes(Handler)). + +enum_positions([],_,[],[],no). +enum_positions([Type|Types],I,Positions,ConstantsLists,Handler) :- + unalias_type(Type,NormalizedType), + ( is_chr_enum_type(NormalizedType,Constants,ErrorHandler) -> + compose_error_handlers(ErrorHandler,NHandler,Handler), + Positions = [I|NPositions], + ConstantsLists = [Constants|NConstantsLists] + ; Positions = NPositions, + ConstantsLists = NConstantsLists, + Handler = NHandler + ), + J is I + 1, + enum_positions(Types,J,NPositions,NConstantsLists,NHandler). + +cartesian_product([],[]). +cartesian_product([E|Es],[L|Ls]) :- + member(E,L), + cartesian_product(Es,Ls). + +flat_spec(C/N,Positions,Terms,Spec) :- + Spec = Terms - Functor, + term_to_atom(Terms,TermsAtom), + term_to_atom(Positions,PositionsAtom), + atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor). + +% }}} + +% }}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% RESTART AFTER FLATTENING {{{ + +restart_after_flattening(Declarations,Declarations) :- + nb_setval('$chr_restart_after_flattening',started). +restart_after_flattening(_,Declarations) :- + nb_getval('$chr_restart_after_flattening',restart(Declarations)), + nb_setval('$chr_restart_after_flattening',restarted). + +not_restarted :- + nb_getval('$chr_restart_after_flattening',started). + +install_new_declarations_and_restart(Declarations) :- + nb_setval('$chr_restart_after_flattening',restart(Declarations)), + fail. /* fails to choicepoint of restart_after_flattening */ +% }}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% FLATTENING {{{ + +% DONE +% -) generate dictionary from collected chr_constants +% enable with :- chr_option(experiment,on). +% -) issue constraint declarations for constraints not present in +% dictionary +% -) integrate with CHR compiler +% -) pass Mike's test code (full syntactic support for current CHR code) +% -) rewrite the body using the inliner +% +% TODO: +% -) refined semantics correctness issue +% -) incorporate chr_enum into dictionary generation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +flatten_clauses(Clauses,Dict,NClauses) :- + flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses), + flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses). + +flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :- + auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0), + dispatching_rules(Dict,NClauses1), + declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2), + flatten_rules(Clauses,Dict,NClauses3), + append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses). + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% Declarations for non-flattened constraints + +% declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{ +declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :- + findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols), + maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList), + flatten(DeclarationsList,Declarations). + +declaration(ModeDecls,TypeDecls,ConstraintSymbol, + [(:- chr_constraint ConstraintSymbol), + (:- chr_option(mode,ModeDeclPattern)), + (:- chr_option(type_declaration,TypeDeclPattern)) + ]) :- + ConstraintSymbol = Functor / Arity, + % print optional mode declaration + functor(ModeDeclPattern,Functor,Arity), + ( memberchk(ModeDeclPattern,ModeDecls) -> + true + ; + replicate(Arity,(?),Modes), + ModeDeclPattern =.. [_|Modes] + ), + % print optional type declaration + functor(TypeDeclPattern,Functor,Arity), + ( memberchk(TypeDeclPattern,TypeDecls) -> + true + ; + replicate(Arity,any,Types), + TypeDeclPattern =.. [_|Types] + ). +% }}} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% read clauses from file +% CHR are returned +% declared constaints are returned +% type definitions are returned and printed +% mode declarations are returned +% other clauses are returned + +% flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{ +flatten_readcontent([],[],[],[],[],[],[]). +flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :- + % read(Clause), + ( Clause == end_of_file -> + Rules = [], + ConstraintSymbols = [], + ModeDecls = [], + TypeDecls = [], + TypeDefs = [], + RestClauses = [] + ; crude_is_rule(Clause) -> + Rules = [Clause|RestRules], + flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) + ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) -> + append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols), + append(SomeModeDecls,RestModeDecls,ModeDecls), + append(SomeTypeDecls,RestTypeDecls,TypeDecls), + flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses) + ; is_mode_declaration(Clause,ModeDecl) -> + ModeDecls = [ModeDecl|RestModeDecls], + flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses) + ; is_type_declaration(Clause,TypeDecl) -> + TypeDecls = [TypeDecl|RestTypeDecls], + flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses) + ; is_type_definition(Clause,TypeDef) -> + RestClauses = [Clause|NRestClauses], + TypeDefs = [TypeDef|RestTypeDefs], + flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses) + ; ( Clause = (:- op(A,B,C)) -> + % assert operators in order to read and print them out properly + op(A,B,C) + ; + true + ), + RestClauses = [Clause|NRestClauses], + flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses) + ). + +crude_is_rule((_ @ _)). +crude_is_rule((_ pragma _)). +crude_is_rule((_ ==> _)). +crude_is_rule((_ <=> _)). + +pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration + D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint), + conj2list(Cs,Constraints0), + pure_extract_type_mode(Constraints0,Constraints,Modes,Types). + +pure_extract_type_mode([],[],[],[]). +pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !, + pure_extract_type_mode(R,R2,Modes,Types). +pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :- + functor(C,F,A), + ConstraintSymbol = F/A, + C =.. [_|Args], + extract_types_and_modes(Args,ArgTypes,ArgModes), + Mode =.. [F|ArgModes], + ( forall(member(ArgType,ArgTypes),ArgType == any) -> + Types = RTypes + ; + Types = [Type|RTypes], + Type =.. [F|ArgTypes] + ), + pure_extract_type_mode(R,R2,Modes,RTypes). + +is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl). + +is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl). +% }}} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% DECLARATIONS FOR FLATTENED CONSTRAINTS +% including mode and type declarations + +% auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{ +auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :- + findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0), + flatten(ConstraintSpecs0,ConstraintSpecs). + +auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls, + [(:- chr_constraint ConstraintSpec), + (:- chr_option(mode,NewModeDecl)), + (:- chr_option(type_declaration,NewTypeDecl))]) :- + member(C/N-I-SFs-_,Dict), + arg_modes(C,N,ModeDecls,Modes), + specialize_modes(Modes,I,SpecializedModes), + arg_types(C,N,TypeDecls,Types), + specialize_types(Types,I,SpecializedTypes), + length(I,IndexSize), + AN is N - IndexSize, + member(_Term-F,SFs), + ConstraintSpec = F/AN, + NewModeDecl =.. [F|SpecializedModes], + NewTypeDecl =.. [F|SpecializedTypes]. + +arg_modes(C,N,ModeDecls,ArgModes) :- + functor(ConstraintPattern,C,N), + ( memberchk(ConstraintPattern,ModeDecls) -> + ConstraintPattern =.. [_|ArgModes] + ; + replicate(N,?,ArgModes) + ). + +specialize_modes(Modes,I,SpecializedModes) :- + split_args(I,Modes,_,SpecializedModes). + +arg_types(C,N,TypeDecls,ArgTypes) :- + functor(ConstraintPattern,C,N), + ( memberchk(ConstraintPattern,TypeDecls) -> + ConstraintPattern =.. [_|ArgTypes] + ; + replicate(N,any,ArgTypes) + ). + +specialize_types(Types,I,SpecializedTypes) :- + split_args(I,Types,_,SpecializedTypes). +% }}} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% DISPATCHING RULES +% +% dispatching_rules(+dict,-newrules) + + +% {{{ + +% This code generates a decision tree for calling the appropriate specialized +% constraint based on the particular value of the argument the constraint +% is being specialized on. +% +% In case an error handler is provided, the handler is called with the +% unexpected constraint. + +dispatching_rules([],[]). +dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :- + constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules), + dispatching_rules(Dict,RestDispatchingRules). + +constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :- + ( increasing_numbers(I,1) -> + /* index on first arguments */ + Rules0 = Rules, + NCN = C/N + ; + /* reorder arguments for 1st argument indexing */ + functor(Head,C,N), + Head =.. [_|Args], + split_args(I,Args,GroundArgs,OtherArgs), + append(GroundArgs,OtherArgs,ShuffledArgs), + atom_concat(C,'_$shuffled',NC), + Body =.. [NC|ShuffledArgs], + [(Head :- Body)|Rules0] = Rules, + NCN = NC / N + ), + Context = swap(C,I), + dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules). + +increasing_numbers([],_). +increasing_numbers([X|Ys],X) :- + Y is X + 1, + increasing_numbers(Ys,Y). + +dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :- + length(I,IndexLength), + once(pairup(TermLists,Functors,SFs)), + maplist(head_tail,TermLists,Heads,Tails), + Payload is N - IndexLength, + maplist(wrap_in_functor(dispatching_action),Functors,Actions), + dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules). + +dispatching_action(Functor,PayloadArgs,Goal) :- + Goal =.. [Functor|PayloadArgs]. + +dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :- + dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail). + +dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !. + % length MorePatterns == length Patterns == length Results +dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :- + MorePatterns = [List|_], + length(List,N), + aggregate_all(set(F/A), + ( member(Pattern,Patterns), + functor(Pattern,F,A) + ), + FAs), + N1 is N + 1, + dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T). + +dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :- + ( MaybeErrorHandler = yes(ErrorHandler) -> + Clauses0 = [ErrorClause|Clauses], + ErrorClause = (Head :- Body), + Arity is N + Payload, + functor(Head,Symbol,Arity), + reconstruct_original_term(Context,Head,Term), + Body =.. [ErrorHandler,Term] + ; + Clauses0 = Clauses + ). +dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :- + dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1), + dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail). + +dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :- + Clause = (Head :- Cut, Body), + ( MaybeErrorHandler = yes(_) -> + Cut = (!) + ; + Cut = true + ), + /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */ + N1 is N + Payload, + functor(Head,Symbol,N1), + arg(1,Head,IndexPattern), + Head =.. [_,_|RestArgs], + length(PayloadArgs,Payload), + once(append(Vs,PayloadArgs,RestArgs)), + /* IndexPattern = F(...) */ + functor(IndexPattern,F,A), + Context1 = index_functor(F,A,Context0), + IndexPattern =.. [_|Args], + append(Args,RestArgs,RecArgs), + ( RecArgs == PayloadArgs -> + /* nothing more to match on */ + List = Tail, + rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions), + MoreActions = [Action], + call(Action,PayloadArgs,Body) + ; /* more things to match on */ + rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions), + ( MoreActions = [OneMoreAction] -> + /* only one more thing to match on */ + MoreCases = [OneMoreCase], + append([Cases,OneMoreCase,PayloadArgs],RecArgs), + List = Tail, + call(OneMoreAction,PayloadArgs,Body) + ; + /* more than one thing to match on */ + /* [ x1,..., xn] + [xs1,...,xsn] + */ + pairup(Cases,MoreCases,CasePairs), + common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences), + append(Args,Vs,[First|Rest]), + First-Rest = CommonPatternPair, + Context2 = gct([First|Rest],Context1), + fresh_symbol(Prefix,RSymbol), + append(DiffVars,PayloadArgs,RecCallVars), + Body =.. [RSymbol|RecCallVars], + findall(CH-CT,member([CH|CT],Differences),CPairs), + once(pairup(CHs,CTs,CPairs)), + dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail) + ) + ). + + +% split(list,int,before,at,after). + +split([X|Xs],I,Before,At,After) :- + ( I == 1 -> + Before = [], + At = X, + After = Xs + ; + J is I - 1, + Before = [X|RBefore], + split(Xs,J,RBefore,At,After) + ). + +% reconstruct_original_term(Context,CurrentTerm,OriginalTerm) +% +% context ::= swap(functor,positions) +% | index_functor(functor,arity,context) +% | gct(Pattern,Context) + +reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :- + functor(Term,_,Arity), + functor(OriginalTerm,Functor,Arity), + OriginalTerm =.. [_|OriginalArgs], + split_args(Positions,OriginalArgs,IndexArgs,OtherArgs), + Term =.. [_|Args], + append(IndexArgs,OtherArgs,Args). +reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :- + Term0 =.. [Predicate|Args], + split_at(Arity,Args,IndexArgs,RestArgs), + Index =.. [Functor|IndexArgs], + Term1 =.. [Predicate,Index|RestArgs], + reconstruct_original_term(Context,Term1,OriginalTerm). +reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :- + copy_term_nat(PatternList,IndexTerms), + term_variables(IndexTerms,Variables), + Term0 =.. [Predicate|Args0], + append(Variables,RestArgs,Args0), + append(IndexTerms,RestArgs,Args1), + Term1 =.. [Predicate|Args1], + reconstruct_original_term(Context,Term1,OriginalTerm). +% }}} + +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +% SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS +% +% flatten_rules(+rule_clauses,+dict,-rule_clauses). +% +% dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler)) + +% {{{ +flatten_rules(Rules,Dict,FlatRules) :- + flatten_rules1(Rules,Dict,FlatRulesList), + flatten(FlatRulesList,FlatRules). + +flatten_rules1([],_,[]). +flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :- + findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules), + flatten_rules1(Rules,Dict,FlatRulesList). + +flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !, + flatten_rule(Rule,Dict,NRule). +flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !, + flatten_rule(Rule,Dict,NRule). +flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !, + flatten_heads(H,Dict,NH), + flatten_body(B,Dict,NB). +flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !, + flatten_heads((H1,H2),Dict,(NH1,NH2)), + flatten_body(B,Dict,NB). +flatten_rule((H <=> B),Dict,(NH <=> NB)) :- + flatten_heads(H,Dict,NH), + flatten_body(B,Dict,NB). + +flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !, + flatten_heads(H1,Dict,NH1), + flatten_heads(H2,Dict,NH2). +flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !, + flatten_heads(H,Dict,NH). +flatten_heads(H,Dict,NH) :- + ( functor(H,C,N), + memberchk(C/N-ArgPositions-SFs-_,Dict) -> + H =.. [_|AllArgs], + split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs), + member(GroundArgs-Name,SFs), + NH =.. [Name|OtherArgs] + ; + NH = H + ). + +flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !, + conj2list(Guard,Guards), + maplist(flatten_goal(Dict),Guards,NGuards), + list2conj(NGuards,NGuard), + conj2list(Body,Goals), + maplist(flatten_goal(Dict),Goals,NGoals), + list2conj(NGoals,NBody). +flatten_body(Body,Dict,NBody) :- + conj2list(Body,Goals), + maplist(flatten_goal(Dict),Goals,NGoals), + list2conj(NGoals,NBody). + +flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal. +flatten_goal(Dict,Goal,NGoal) :- + ( is_specializable_goal(Goal,Dict,ArgPositions) + -> + specialize_goal(Goal,ArgPositions,NGoal) + ; Goal = Mod : TheGoal, + get_target_module(Module), + Mod == Module, + nonvar(TheGoal), + is_specializable_goal(TheGoal,Dict,ArgPositions) + -> + specialize_goal(TheGoal,ArgPositions,NTheGoal), + NGoal = Mod : NTheGoal + ; partial_eval(Goal,NGoal) + -> + true + ; + NGoal = Goal + ). + +%-------------------------------------------------------------------------------% +% Specialize body/guard goal +%-------------------------------------------------------------------------------% +is_specializable_goal(Goal,Dict,ArgPositions) :- + functor(Goal,C,N), + memberchk(C/N-ArgPositions-_-_,Dict), + args(ArgPositions,Goal,Args), + ground(Args). + +specialize_goal(Goal,ArgPositions,NGoal) :- + functor(Goal,C,N), + Goal =.. [_|Args], + split_args(ArgPositions,Args,GroundTerms,Others), + flat_spec(C/N,ArgPositions,GroundTerms,_-Functor), + NGoal =.. [Functor|Others]. + +%-------------------------------------------------------------------------------% +% Partially evaluate predicates +%-------------------------------------------------------------------------------% + +% append([],Y,Z) >--> Y = Z +% append(X,[],Z) >--> X = Z +partial_eval(append(L1,L2,L3),NGoal) :- + ( L1 == [] -> + NGoal = (L3 = L2) + ; L2 == [] -> + NGoal = (L3 = L1) + + ). +% flatten_path(L1,L2) >--> flatten_path(L1',L2) +% where flatten(L1,L1') +partial_eval(flatten_path(L1,L2),NGoal) :- + nonvar(L1), + flatten(L1,FlatterL1), + FlatterL1 \== L1 -> + NGoal = flatten_path(FlatterL1,L2). + + +% }}} + +% }}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +dump_code(Clauses) :- + ( chr_pp_flag(dump,on) -> + maplist(portray_clause,Clauses) + ; + true + ). + +chr_banner :- + chr_info(banner,'\tThe K.U.Leuven CHR System\n\t\tMain Developer:\tTom Schrijvers\n\t\tContributors:\tJon Sneyers, Bart Demoen, Jan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% LOCKING {{{ + +chr_none_locked(Vars,Goal) :- + chr_pp_flag(guard_locks,Flag), + ( Flag == off -> + Goal = true + ; Flag == on -> + Goal = 'chr none_locked'( Vars) + ; Flag == error -> + Goal = 'chr none_error_locked'( Vars) + ). + +chr_not_locked(Var,Goal) :- + chr_pp_flag(guard_locks,Flag), + ( Flag == off -> + Goal = true + ; Flag == on -> + Goal = 'chr not_locked'( Var) + ; Flag == error -> + Goal = 'chr not_error_locked'( Var) + ). + +chr_lock(Var,Goal) :- + chr_pp_flag(guard_locks,Flag), + ( Flag == off -> + Goal = true + ; Flag == on -> + Goal = 'chr lock'( Var) + ; Flag == error -> + Goal = 'chr error_lock'( Var) + ). + +chr_unlock(Var,Goal) :- + chr_pp_flag(guard_locks,Flag), + ( Flag == off -> + Goal = true + ; Flag == on -> + Goal = 'chr unlock'( Var) + ; Flag == error -> + Goal = 'chr unerror_lock'( Var) + ). +% }}} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% AST representation +% each AST representation caches the original term +% +% ast_term ::= atomic(Term) +% | compound(Functor,Arity,list(ast_term),Term) +% | var(int,Term) +% -- unique integer identifier + +% Conversion Predicate {{{ +:- chr_type var_id == natural. + +term_to_ast_term(Term,AstTerm,VarEnv,NVarEnv) :- + ( atomic(Term) -> + AstTerm = atomic(Term), + NVarEnv = VarEnv + ; compound(Term) -> + functor(Term,Functor,Arity), + AstTerm = compound(Functor,Arity,AstTerms,Term), + Term =.. [_|Args], + maplist_dcg(chr_translate:term_to_ast_term,Args,AstTerms,VarEnv,NVarEnv) + ; var(Term) -> + var_to_ast_term(Term,VarEnv,AstTerm,NVarEnv) + ). + +var_to_ast_term(Var,Env,AstTerm,NVarEnv) :- + Env = VarDict - VarId, + ( lookup_eq(VarDict,Var,AstTerm) -> + NVarEnv = Env + ; + AstTerm = var(VarId,Var), + NVarId is VarId + 1, + NVarDict = [Var - AstTerm|VarDict], + NVarEnv = NVarDict - NVarId + ). + +% ast_constraint ::= chr_constraint(Symbol,Arguments,Constraint) +chr_constraint_to_ast_constraint(CHRConstraint,AstConstraint,VarEnv,NVarEnv) :- + AstConstraint = chr_constraint(Functor/Arity,AstTerms,CHRConstraint), + functor(CHRConstraint,Functor,Arity), + CHRConstraint =.. [_|Arguments], + maplist_dcg(chr_translate:term_to_ast_term,Arguments,AstTerms,VarEnv,NVarEnv). + +% ast_head ::= simplification(list(chr_constraint)) +% | propagation(list(chr_constraint)) +% | simpagation(list(chr_constraint),list(chr_constraint)) + +% head_id ::= int + +% ast_guard ::= list(ast_term) +% ast_body ::= list(ast_term) + +% ast_rule ::= ast_rule(ast_head,ast_guard,guard,ast_body,body) + +rule_to_ast_rule(Rule,AstRule) :- + AstRule = ast_rule(Head,AstGuard,Guard,AstBody,Body), + Rule = rule(H1,H2,Guard,Body), + EmptyVarEnv = []-1, + ( H1 == [] -> + Head = propagation(AstConstraints), + maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,AstConstraints,EmptyVarEnv,VarEnv1) + ; H2 == [] -> + Head = simplification(AstConstraints), + maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,AstConstraints,EmptyVarEnv,VarEnv1) + ; + Head = simpagation(RemovedAstConstraints,KeptAstConstraints), + maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,RemovedAstConstraints,EmptyVarEnv,VarEnv0), + maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,KeptAstConstraints,VarEnv0,VarEnv1) + ), + conj2list(Guard,GuardList), + maplist_dcg(chr_translate:term_to_ast_term,GuardList,AstGuard,VarEnv1,VarEnv2), + conj2list(Body,BodyList), + maplist_dcg(chr_translate:term_to_ast_term,BodyList,AstBody,VarEnv2,_). + +pragma_rule_to_ast_rule(pragma(Rule,_,_,_,_),AstRule) :- + rule_to_ast_rule(Rule,AstRule). + +check_rule_to_ast_rule(Rule) :- + ( rule_to_ast_rule(Rule,AstRule) -> + writeln(AstRule) + ; + writeln(failed(rule_to_ast_rule(Rule,AstRule))) + ). + +% }}} + +% AST Utility Predicates {{{ +ast_term_to_term(var(_,Var),Var). +ast_term_to_term(atomic(Atom),Atom). +ast_term_to_term(compound(_,_,_,Compound),Compound). + +ast_nonvar(atomic(_)). +ast_nonvar(compound(_,_,_,_)). + +ast_ground(atomic(_)). +ast_ground(compound(_,_,Arguments,_)) :- + maplist(ast_ground,Arguments). + +%------------------------------------------------------------------------------% +% Check whether a term is ground, given a set of variables that are ground. +%------------------------------------------------------------------------------% +ast_is_ground(VarSet,AstTerm) :- + ast_is_ground_(AstTerm,VarSet). + +ast_is_ground_(var(VarId,_),VarSet) :- + tree_set_memberchk(VarId,VarSet). +ast_is_ground_(atomic(_),_). +ast_is_ground_(compound(_,_,Arguments,_),VarSet) :- + maplist(ast_is_ground(VarSet),Arguments). +%------------------------------------------------------------------------------% + +ast_functor(atomic(Atom),Atom,0). +ast_functor(compound(Functor,Arity,_,_),Functor,Arity). + +ast_symbol(atomic(Atom),Atom/0). +ast_symbol(compound(Functor,Arity,_,_),Functor/Arity). + +ast_args(atomic(_),[]). +ast_args(compound(_,_,Arguments,_),Arguments). + +%------------------------------------------------------------------------------% +% Add variables in a term to a given set. +%------------------------------------------------------------------------------% +ast_term_variables(atomic(_),Set,Set). +ast_term_variables(compound(_,_,Args,_),Set,NSet) :- + ast_term_list_variables(Args,Set,NSet). +ast_term_variables(var(VarId,_),Set,NSet) :- + tree_set_add(Set,VarId,NSet). + +ast_term_list_variables(Terms,Set,NSet) :- + fold(Terms,chr_translate:ast_term_variables,Set,NSet). +%------------------------------------------------------------------------------% + +ast_constraint_variables(chr_constraint(_,Args,_),Set,NSet) :- + ast_term_list_variables(Args,Set,NSet). + +ast_constraint_list_variables(Constraints,Set,NSet) :- + fold(Constraints,chr_translate:ast_constraint_variables,Set,NSet). + +ast_head_variables(simplification(H1),Set,NSet) :- + ast_constraint_list_variables(H1,Set,NSet). +ast_head_variables(propagation(H2),Set,NSet) :- + ast_constraint_list_variables(H2,Set,NSet). +ast_head_variables(simpagation(H1,H2),Set,NSet) :- + ast_constraint_list_variables(H1,Set,Set1), + ast_constraint_list_variables(H2,Set1,NSet). + +ast_var_memberchk(var(VarId,_),Set) :- + tree_set_memberchk(VarId,Set). + +%------------------------------------------------------------------------------% +% Return term based on AST-term with variables mapped. +%------------------------------------------------------------------------------% +ast_instantiate(Map,AstTerm,Term) :- + ast_instantiate_(AstTerm,Map,Term). + +ast_instantiate_(var(VarId,_),Map,Term) :- + get_assoc(VarId,Map,Term). +ast_instantiate_(atomic(Atom),_,Atom). +ast_instantiate_(compound(Functor,Arity,Arguments,_),Map,Term) :- + functor(Term,Functor,Arity), + Term =.. [_|Terms], + maplist(ast_instantiate(Map),Arguments,Terms). +%------------------------------------------------------------------------------% +% }}} + +%------------------------------------------------------------------------------% +% ast_head_arg_matches_(list(silent_pair(ast_term,var) +% ,modes +% ,map(var_id,...) +% ,set(variables) +% ,list(goal) +% ,vardict +% ,set(variables) +% ) +%------------------------------------------------------------------------------% + +ast_head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars). +ast_head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !, + ( Mode == (+) -> + ast_term_variables(Arg,GroundVars0,GroundVars), + ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars) + ; + ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars) + ). +ast_head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- + ( Arg = var(VarId,_) -> + ( get_assoc(VarId,VarDict,OtherVar) -> + ( Mode = (+) -> + ( tree_set_memberchk(VarId,GroundVars) -> + GoalList = [Var = OtherVar | RestGoalList], + GroundVars1 = GroundVars + ; + GoalList = [Var == OtherVar | RestGoalList], + tree_set_add(GroundVars,VarId,GroundVars1) + ) + ; + GoalList = [Var == OtherVar | RestGoalList], + GroundVars1 = GroundVars + ), + VarDict1 = VarDict + ; + put_assoc(VarId,VarDict,Var,VarDict1), + GoalList = RestGoalList, + ( Mode = (+) -> + + tree_set_add(GroundVars,VarId,GroundVars1) + ; + GroundVars1 = GroundVars + ) + ), + Pairs = Rest, + RestModes = Modes + ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> % TODO + identifier_label_atom(IndexType,Var,ActualArg,Goal), + GoalList = [Goal|RestGoalList], + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Arg = atomic(Atom) -> + ( Mode = (+) -> + GoalList = [ Var = Atom | RestGoalList] + ; + GoalList = [ Var == Atom | RestGoalList] + ), + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Mode == (+), ast_is_ground(GroundVars,Arg) -> + ast_instantiate(VarDict,Arg,ArgInst), + GoalList = [ Var = ArgInst | RestGoalList], + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Mode == (?), ast_is_ground(GroundVars,Arg) -> + ast_instantiate(VarDict,Arg,ArgInst), + GoalList = [ Var == ArgInst | RestGoalList], + VarDict = VarDict1, + GroundVars1 = GroundVars, + Pairs = Rest, + RestModes = Modes + ; Arg = compound(Functor,Arity,Arguments,_), + functor(Term,Functor,Arity), + Term =.. [_|Vars], + ( Mode = (+) -> + GoalList = [ Var = Term | RestGoalList ] + ; + GoalList = [ nonvar(Var), Var = Term | RestGoalList ] + ), + pairup(Arguments,Vars,NewPairs), + append(NewPairs,Rest,Pairs), + replicate(N,Mode,NewModes), + append(NewModes,Modes,RestModes), + VarDict1 = VarDict, + GroundVars1 = GroundVars + ), + ast_head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars). diff --git a/packages/chr/chr_translate_bootstrap.pl b/packages/chr/chr_translate_bootstrap.pl new file mode 100644 index 000000000..04432bbd8 --- /dev/null +++ b/packages/chr/chr_translate_bootstrap.pl @@ -0,0 +1,2495 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% ____ _ _ ____ ____ _ _ +%% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __ +%% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__| +%% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ | +%% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_| +%% |_| +%% +%% hProlog CHR compiler: +%% +%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be +%% +%% * based on the SICStus CHR compilation by Christian Holzbaur +%% +%% First working version: 6 June 2003 +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% To Do +%% +%% * SICStus compatibility +%% - rules/1 declaration +%% - options +%% - pragmas +%% - tell guard +%% +%% +%% * do not suspend on variables that don't matter +%% * make difference between cheap guards for reordering +%% and non-binding guards for lock removal +%% +%% * unqiue -> once/[] transformation for propagation +%% +%% * cheap guards interleaved with head retrieval + faster +%% via-retrieval + non-empty checking for propagation rules +%% redo for simpagation_head2 prelude +%% +%% * intelligent backtracking for simplification/simpagation rule +%% generator_1(X),'_$savecp'(CP_1), +%% ... +%% if( ( +%% generator_n(Y), +%% test(X,Y) +%% ), +%% true, +%% ('_$cutto'(CP_1), fail) +%% ), +%% ... +%% +%% or recently developped cascading-supported approach +%% +%% * intelligent backtracking for propagation rule +%% use additional boolean argument for each possible smart backtracking +%% when boolean at end of list true -> no smart backtracking +%% false -> smart backtracking +%% only works for rules with at least 3 constraints in the head +%% +%% * mutually exclusive rules +%% +%% * constraints that can never be attached / always simplified away +%% -> need not be considered in diverse operations +%% +%% * (set semantics + functional dependency) declaration + resolution +%% +%% * type and instantiation declarations + optimisations +%% + better indexes +%% +%% * disable global store option +%% +%% Done +%% +%% * clean up generated code +%% * input verification: pragmas +%% * SICStus compatibility: handler/1, constraints/1 +%% * optimise variable passing for propagation rule +%% * reordering of head constraints for passive head search +%% * unique inference for simpagation rules +%% * unique optimisation for simpagation and simplification rules +%% * cheap guards interleaved with head retrieval + faster +%% via-retrieval + non-empty checking for simplification / simpagation rules +%% * transform +%% C \ C <=> true +%% into +%% C # ID \ C <=> true pragma passive. +%% * valid to disregard body in uniqueness inference? +%% * unique inference for simplification rules +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- module(chr_translate, + [ chr_translate/2 % +Decls, -TranslatedDecls + ]). +%% SWI begin +:- use_module(library(lists),[member/2,append/3,permutation/2,reverse/2]). +:- use_module(library(ordsets)). +%% SWI end +:- use_module(library(dialect/hprolog)). +:- use_module(pairlist). +:- start_low_level_trace. +:- include(chr_op). +:- stop_low_level_trace. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Translation + +chr_translate(Declarations,NewDeclarations) :- + init_chr_pp_flags, + partition_clauses(Declarations,Decls,Rules,OtherClauses,Mod), + default(Mod,user), + ( Decls == [] -> + NewDeclarations = OtherClauses + ; + check_rules(Rules,Decls), + unique_analyse_optimise(Rules,1,[],NRules), + generate_attach_a_constraint_all(Decls,Mod,AttachAConstraintClauses), + generate_detach_a_constraint_all(Decls,Mod,DettachAConstraintClauses), + generate_attach_increment(Decls,Mod,AttachIncrementClauses), + generate_attr_unify_hook(Decls,Mod,AttrUnifyHookClauses), + constraints_code(Decls,NRules,Mod,ConstraintClauses), + append([ OtherClauses, + AttachAConstraintClauses, + DettachAConstraintClauses, + AttachIncrementClauses, + AttrUnifyHookClauses, + ConstraintClauses + ], + NewDeclarations) + ). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Partitioning of clauses into constraint declarations, chr rules and other +%% clauses + +partition_clauses([],[],[],[],_). +partition_clauses([C|Cs],Ds,Rs,OCs,Mod) :- + ( rule(C,R) -> + Ds = RDs, + Rs = [R | RRs], + OCs = ROCs + ; is_declaration(C,D) -> + append(D,RDs,Ds), + Rs = RRs, + OCs = ROCs + ; is_module_declaration(C,Mod) -> + Ds = RDs, + Rs = RRs, + OCs = [C|ROCs] + ; C = (handler _) -> + format('CHR compiler WARNING: ~w.\n',[C]), + format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]), + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; C = (rules _) -> + format('CHR compiler WARNING: ~w.\n',[C]), + format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]), + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; C = (:- chr_option(OptionName,OptionValue)) -> + handle_option(OptionName,OptionValue), + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; Ds = RDs, + Rs = RRs, + OCs = [C|ROCs] + ), + partition_clauses(Cs,RDs,RRs,ROCs,Mod). + +is_declaration(D, Constraints) :- %% constraint declaration + D = (:- Decl), + ( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]), + conj2list(Cs,Constraints). + +%% Data Declaration +%% +%% pragma_rule +%% -> pragma( +%% rule, +%% ids, +%% list(pragma), +%% yesno(string) +%% ) +%% +%% ids -> ids( +%% list(int), +%% list(int) +%% ) +%% +%% rule -> rule( +%% list(constraint), :: constraints to be removed +%% list(constraint), :: surviving constraints +%% goal, :: guard +%% goal :: body +%% ) + +rule(RI,R) :- %% name @ rule + RI = (Name @ RI2), !, + rule(RI2,yes(Name),R). +rule(RI,R) :- + rule(RI,no,R). + +rule(RI,Name,R) :- + RI = (RI2 pragma P), !, %% pragmas + is_rule(RI2,R1,IDs), + conj2list(P,Ps), + R = pragma(R1,IDs,Ps,Name). +rule(RI,Name,R) :- + is_rule(RI,R1,IDs), + R = pragma(R1,IDs,[],Name). + +is_rule(RI,R,IDs) :- %% propagation rule + RI = (H ==> B), !, + conj2list(H,Head2i), + get_ids(Head2i,IDs2,Head2), + IDs = ids([],IDs2), + ( B = (G | RB) -> + R = rule([],Head2,G,RB) + ; + R = rule([],Head2,true,B) + ). +is_rule(RI,R,IDs) :- %% simplification/simpagation rule + RI = (H <=> B), !, + ( B = (G | RB) -> + Guard = G, + Body = RB + ; Guard = true, + Body = B + ), + ( H = (H1 \ H2) -> + conj2list(H1,Head2i), + conj2list(H2,Head1i), + get_ids(Head2i,IDs2,Head2,0,N), + get_ids(Head1i,IDs1,Head1,N,_), + IDs = ids(IDs1,IDs2) + ; conj2list(H,Head1i), + Head2 = [], + get_ids(Head1i,IDs1,Head1), + IDs = ids(IDs1,[]) + ), + R = rule(Head1,Head2,Guard,Body). + +get_ids(Cs,IDs,NCs) :- + get_ids(Cs,IDs,NCs,0,_). + +get_ids([],[],[],N,N). +get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :- + ( C = (NC # N) -> + true + ; + NC = C + ), + M is N + 1, + get_ids(Cs,IDs,NCs, M,NN). + +is_module_declaration((:- module(Mod)),Mod). +is_module_declaration((:- module(Mod,_)),Mod). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Some input verification: +%% - all constraints in heads are declared constraints + +check_rules(Rules,Decls) :- + check_rules(Rules,Decls,1). + +check_rules([],_,_). +check_rules([PragmaRule|Rest],Decls,N) :- + check_rule(PragmaRule,Decls,N), + N1 is N + 1, + check_rules(Rest,Decls,N1). + +check_rule(PragmaRule,Decls,N) :- + PragmaRule = pragma(Rule,_IDs,Pragmas,_Name), + Rule = rule(H1,H2,_,_), + append(H1,H2,HeadConstraints), + check_head_constraints(HeadConstraints,Decls,PragmaRule,N), + check_pragmas(Pragmas,PragmaRule,N). + +check_head_constraints([],_,_,_). +check_head_constraints([Constr|Rest],Decls,PragmaRule,N) :- + functor(Constr,F,A), + ( member(F/A,Decls) -> + check_head_constraints(Rest,Decls,PragmaRule,N) + ; + format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n', + [F/A,format_rule(PragmaRule,N)]), + format(' `--> Constraint should be on of ~w.\n',[Decls]), + fail + ). + +check_pragmas([],_,_). +check_pragmas([Pragma|Pragmas],PragmaRule,N) :- + check_pragma(Pragma,PragmaRule,N), + check_pragmas(Pragmas,PragmaRule,N). + +check_pragma(Pragma,PragmaRule,N) :- + var(Pragma), !, + format('CHR compiler ERROR: invalid pragma ~w in ~@.\n', + [Pragma,format_rule(PragmaRule,N)]), + format(' `--> Pragma should not be a variable!\n',[]), + fail. + +check_pragma(passive(ID), PragmaRule, N) :- + !, + PragmaRule = pragma(_,ids(IDs1,IDs2),_,_), + ( memberchk_eq(ID,IDs1) -> + true + ; memberchk_eq(ID,IDs2) -> + true + ; + format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n', + [ID,format_rule(PragmaRule,N)]), + fail + ). + +check_pragma(Pragma, PragmaRule, N) :- + Pragma = unique(_,_), + !, + format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]), + format(' `--> Only use this pragma if you know what you are doing.\n',[]). + +check_pragma(Pragma, PragmaRule, N) :- + Pragma = already_in_heads, + !, + format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]), + format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]). + +check_pragma(Pragma, PragmaRule, N) :- + Pragma = already_in_head(_), + !, + format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]), + format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]). + +check_pragma(Pragma,PragmaRule,N) :- + format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]), + format(' `--> Pragma should be one of passive/1!\n',[]), + fail. + +format_rule(PragmaRule,N) :- + PragmaRule = pragma(_,_,_,MaybeName), + ( MaybeName = yes(Name) -> + write('rule '), write(Name) + ; + write('rule number '), write(N) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Global Options +% + +handle_option(Var,Value) :- + var(Var), !, + format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]), + format(' `--> First argument should be an atom, not a variable.\n',[]), + fail. + +handle_option(Name,Value) :- + var(Value), !, + format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]), + format(' `--> Second argument should be a nonvariable.\n',[]), + fail. + +handle_option(Name,Value) :- + option_definition(Name,Value,Flags), + !, + set_chr_pp_flags(Flags). + +handle_option(Name,Value) :- + \+ option_definition(Name,_,_), !, + setof(N, V^F^option_definition(N,V,F), Ns), + format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]), + format(' `--> Invalid option name ~w: should be one of ~w.\n',[Name,Ns]), + fail. + +handle_option(Name,Value) :- + findall(V,option_definition(Name,V,_),Vs), + format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]), + format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]), + fail. + +option_definition(optimize,full,Flags) :- + Flags = [ unique_analyse_optimise - on, + check_unnecessary_active - full, + reorder_heads - on, + set_semantics_rule - on, + guard_via_reschedule - on + ]. + +option_definition(optimize,sicstus,Flags) :- + Flags = [ unique_analyse_optimise - off, + check_unnecessary_active - simplification, + reorder_heads - off, + set_semantics_rule - off, + guard_via_reschedule - off + ]. + +option_definition(optimize,off,Flags) :- + Flags = [ unique_analyse_optimise - off, + check_unnecessary_active - off, + reorder_heads - off, + set_semantics_rule - off, + guard_via_reschedule - off + ]. + +option_definition(check_guard_bindings,on,Flags) :- + Flags = [ guard_locks - on ]. + +option_definition(check_guard_bindings,off,Flags) :- + Flags = [ guard_locks - off ]. + +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(unique_analyse_optimise,[on,off]). +chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]). +chr_pp_flag_definition(reorder_heads,[on,off]). +chr_pp_flag_definition(set_semantics_rule,[on,off]). +chr_pp_flag_definition(guard_via_reschedule,[on,off]). +chr_pp_flag_definition(guard_locks,[on,off]). + +chr_pp_flag(Name,Value) :- + atom_concat('$chr_pp_',Name,GlobalVar), + nb_getval(GlobalVar,V), + ( V == [] -> + chr_pp_flag_definition(Name,[Value|_]) + ; + V = Value + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Generated predicates +%% attach_$CONSTRAINT +%% attach_increment +%% detach_$CONSTRAINT +%% attr_unify_hook + +%% attach_$CONSTRAINT +generate_attach_a_constraint_all(Constraints,Mod,Clauses) :- + length(Constraints,Total), + generate_attach_a_constraint_all(Constraints,1,Total,Mod,Clauses). + +generate_attach_a_constraint_all([],_,_,_,[]). +generate_attach_a_constraint_all([Constraint|Constraints],Position,Total,Mod,Clauses) :- + generate_attach_a_constraint(Total,Position,Constraint,Mod,Clauses1), + NextPosition is Position + 1, + generate_attach_a_constraint_all(Constraints,NextPosition,Total,Mod,Clauses2), + append(Clauses1,Clauses2,Clauses). + +generate_attach_a_constraint(Total,Position,Constraint,Mod,[Clause1,Clause2]) :- + generate_attach_a_constraint_empty_list(Constraint,Clause1), + ( Total == 1 -> + generate_attach_a_constraint_1_1(Constraint,Mod,Clause2) + ; + generate_attach_a_constraint_t_p(Total,Position,Constraint,Mod,Clause2) + ). + +generate_attach_a_constraint_empty_list(CFct / CAty,Clause) :- + atom_concat_list(['attach_',CFct, (/) ,CAty],Fct), + Args = [[],_], + Head =.. [Fct | Args], + Clause = ( Head :- true). + +generate_attach_a_constraint_1_1(CFct / CAty,Mod,Clause) :- + atom_concat_list(['attach_',CFct, (/) ,CAty],Fct), + Args = [[Var|Vars],Susp], + Head =.. [Fct | Args], + RecursiveCall =.. [Fct,Vars,Susp], + Body = + ( + ( get_attr(Var, Mod, Susps) -> + NewSusps=[Susp|Susps], + put_attr(Var, Mod, NewSusps) + ; + put_attr(Var, Mod, [Susp]) + ), + RecursiveCall + ), + Clause = (Head :- Body). + +generate_attach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :- + atom_concat_list(['attach_',CFct, (/) ,CAty],Fct), + Args = [[Var|Vars],Susp], + Head =.. [Fct | Args], + RecursiveCall =.. [Fct,Vars,Susp], + or_pattern(Position,Pattern), + make_attr(Total,Mask,SuspsList,Attr), + nth1(Position,SuspsList,Susps), + substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1), + make_attr(Total,Mask,SuspsList1,NewAttr1), + substitute_eq(Susps,SuspsList,[Susp],SuspsList2), + make_attr(Total,NewMask,SuspsList2,NewAttr2), + copy_term_nat(SuspsList,SuspsList3), + nth1(Position,SuspsList3,[Susp]), + chr_delete(SuspsList3,[Susp],RestSuspsList), + set_elems(RestSuspsList,[]), + make_attr(Total,Pattern,SuspsList3,NewAttr3), + Body = + ( + ( get_attr(Var,Mod,TAttr) -> + TAttr = Attr, + ( Mask /\ Pattern =:= Pattern -> + put_attr(Var, Mod, NewAttr1) + ; + NewMask is Mask \/ Pattern, + put_attr(Var, Mod, NewAttr2) + ) + ; + put_attr(Var,Mod,NewAttr3) + ), + RecursiveCall + ), + Clause = (Head :- Body). + +%% detach_$CONSTRAINT +generate_detach_a_constraint_all(Constraints,Mod,Clauses) :- + length(Constraints,Total), + generate_detach_a_constraint_all(Constraints,1,Total,Mod,Clauses). + +generate_detach_a_constraint_all([],_,_,_,[]). +generate_detach_a_constraint_all([Constraint|Constraints],Position,Total,Mod,Clauses) :- + generate_detach_a_constraint(Total,Position,Constraint,Mod,Clauses1), + NextPosition is Position + 1, + generate_detach_a_constraint_all(Constraints,NextPosition,Total,Mod,Clauses2), + append(Clauses1,Clauses2,Clauses). + +generate_detach_a_constraint(Total,Position,Constraint,Mod,[Clause1,Clause2]) :- + generate_detach_a_constraint_empty_list(Constraint,Clause1), + ( Total == 1 -> + generate_detach_a_constraint_1_1(Constraint,Mod,Clause2) + ; + generate_detach_a_constraint_t_p(Total,Position,Constraint,Mod,Clause2) + ). + +generate_detach_a_constraint_empty_list(CFct / CAty,Clause) :- + atom_concat_list(['detach_',CFct, (/) ,CAty],Fct), + Args = [[],_], + Head =.. [Fct | Args], + Clause = ( Head :- true). + +generate_detach_a_constraint_1_1(CFct / CAty,Mod,Clause) :- + atom_concat_list(['detach_',CFct, (/) ,CAty],Fct), + Args = [[Var|Vars],Susp], + Head =.. [Fct | Args], + RecursiveCall =.. [Fct,Vars,Susp], + Body = + ( + ( get_attr(Var,Mod,Susps) -> + 'chr sbag_del_element'(Susps,Susp,NewSusps), + ( NewSusps == [] -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,NewSusps) + ) + ; + true + ), + RecursiveCall + ), + Clause = (Head :- Body). + +generate_detach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :- + atom_concat_list(['detach_',CFct, (/) ,CAty],Fct), + Args = [[Var|Vars],Susp], + Head =.. [Fct | Args], + RecursiveCall =.. [Fct,Vars,Susp], + or_pattern(Position,Pattern), + and_pattern(Position,DelPattern), + make_attr(Total,Mask,SuspsList,Attr), + nth1(Position,SuspsList,Susps), + substitute_eq(Susps,SuspsList,[],SuspsList1), + make_attr(Total,NewMask,SuspsList1,Attr1), + substitute_eq(Susps,SuspsList,NewSusps,SuspsList2), + make_attr(Total,Mask,SuspsList2,Attr2), + Body = + ( + ( get_attr(Var,Mod,TAttr) -> + TAttr = Attr, + ( Mask /\ Pattern =:= Pattern -> + 'chr sbag_del_element'(Susps,Susp,NewSusps), + ( NewSusps == [] -> + NewMask is Mask /\ DelPattern, + ( NewMask == 0 -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,Attr1) + ) + ; + put_attr(Var,Mod,Attr2) + ) + ; + true + ) + ; + true + ), + RecursiveCall + ), + Clause = (Head :- Body). + +%% detach_$CONSTRAINT +generate_attach_increment(Constraints,Mod,[Clause1,Clause2]) :- + generate_attach_increment_empty(Clause1), + length(Constraints,N), + ( N == 1 -> + generate_attach_increment_one(Mod,Clause2) + ; + generate_attach_increment_many(N,Mod,Clause2) + ). + +generate_attach_increment_empty((attach_increment([],_) :- true)). + +generate_attach_increment_one(Mod,Clause) :- + Head = attach_increment([Var|Vars],Susps), + Body = + ( + 'chr not_locked'(Var), + ( get_attr(Var,Mod,VarSusps) -> + sort(VarSusps,SortedVarSusps), + merge(Susps,SortedVarSusps,MergedSusps), + put_attr(Var,Mod,MergedSusps) + ; + put_attr(Var,Mod,Susps) + ), + attach_increment(Vars,Susps) + ), + Clause = (Head :- Body). + +generate_attach_increment_many(N,Mod,Clause) :- + make_attr(N,Mask,SuspsList,Attr), + make_attr(N,OtherMask,OtherSuspsList,OtherAttr), + Head = attach_increment([Var|Vars],Attr), + bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs), + list2conj(Gs,SortGoals), + bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList), + make_attr(N,MergedMask,MergedSuspsList,NewAttr), + Body = + ( + 'chr not_locked'(Var), + ( get_attr(Var,Mod,TOtherAttr) -> + TOtherAttr = OtherAttr, + SortGoals, + MergedMask is Mask \/ OtherMask, + put_attr(Var,Mod,NewAttr) + ; + put_attr(Var,Mod,Attr) + ), + attach_increment(Vars,Attr) + ), + Clause = (Head :- Body). + +%% attr_unify_hook +generate_attr_unify_hook(Constraints,Mod,[Clause]) :- + length(Constraints,N), + ( N == 1 -> + generate_attr_unify_hook_one(Mod,Clause) + ; + generate_attr_unify_hook_many(N,Mod,Clause) + ). + +generate_attr_unify_hook_one(Mod,Clause) :- + Head = attr_unify_hook(Susps,Other), + Body = + ( + sort(Susps, SortedSusps), + ( var(Other) -> + ( get_attr(Other,Mod,OtherSusps) -> + true + ; + OtherSusps = [] + ), + sort(OtherSusps,SortedOtherSusps), + 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps), + put_attr(Other,Mod,NewSusps), + 'chr run_suspensions'(NewSusps) + ; + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars, SortedSusps) + ; + true + ), + 'chr run_suspensions'(Susps) + ) + ), + Clause = (Head :- Body). + +generate_attr_unify_hook_many(N,Mod,Clause) :- + make_attr(N,Mask,SuspsList,Attr), + make_attr(N,OtherMask,OtherSuspsList,OtherAttr), + bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList), + list2conj(SortGoalList,SortGoals), + bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList), + bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E), + C = (sort(E,F), + 'chr merge_attributes'(D,F,G)) ), + SortMergeGoalList), + bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList), + list2conj(SortMergeGoalList,SortMergeGoals), + make_attr(N,MergedMask,MergedSuspsList,MergedAttr), + make_attr(N,Mask,SortedSuspsList,SortedAttr), + Head = attr_unify_hook(Attr,Other), + Body = + ( + SortGoals, + ( var(Other) -> + ( get_attr(Other,Mod,TOtherAttr) -> + TOtherAttr = OtherAttr, + SortMergeGoals, + MergedMask is Mask \/ OtherMask, + put_attr(Other,Mod,MergedAttr), + 'chr run_suspensions_loop'(MergedSuspsList) + ; + put_attr(Other,Mod,SortedAttr), + 'chr run_suspensions_loop'(SortedSuspsList) + ) + ; + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars,SortedAttr) + ; + true + ), + 'chr run_suspensions_loop'(SortedSuspsList) + ) + ), + Clause = (Head :- Body). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ _ _ +%% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __ +%% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \ +%% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | | +%% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_| +%% |_| + +constraints_code(Constraints,Rules,Mod,Clauses) :- + constraints_code(Constraints,Rules,Mod,L,[]), + clean_clauses(L,Clauses). + +%% Generate code for all the CHR constraints +constraints_code(Constraints,Rules,Mod,L,T) :- + length(Constraints,N), + constraints_code(Constraints,1,N,Constraints,Rules,Mod,L,T). + +constraints_code([],_,_,_,_,_,L,L). +constraints_code([Constr|Constrs],I,N,Constraints,Rules,Mod,L,T) :- + constraint_code(Constr,I,N,Constraints,Rules,Mod,L,T1), + J is I + 1, + constraints_code(Constrs,J,N,Constraints,Rules,Mod,T1,T). + +%% Generate code for a single CHR constraint +constraint_code(Constraint, I, N, Constraints, Rules, Mod, L, T) :- + constraint_prelude(Constraint,Mod,Clause), + L = [Clause | L1], + Id1 = [0], + rules_code(Rules,1,Constraint,I,N,Constraints,Mod,Id1,Id2,L1,L2), + gen_cond_attach_clause(Mod,Constraint,I,N,Constraints,Id2,L2,T). + +%% Generate prelude predicate for a constraint. +%% f(...) :- f/a_0(...,Susp). +constraint_prelude(F/A, _Mod, Clause) :- + vars_susp(A,Vars,_Susp,VarsSusp), + Head =.. [ F | Vars], + build_head(F,A,[0],VarsSusp,Delegate), + Clause = ( Head :- Delegate ). + +gen_cond_attach_clause(Mod,F/A,_I,_N,_Constraints,Id,L,T) :- + ( Id == [0] -> + gen_cond_attach_goal(Mod,F/A,Body,AllArgs) + ; vars_susp(A,_Args,Susp,AllArgs), + gen_uncond_attach_goal(F/A,Susp,Mod,Body,_) + ), + build_head(F,A,Id,AllArgs,Head), + Clause = ( Head :- Body ), + L = [Clause | T]. + +gen_cond_attach_goal(Mod,F/A,Goal,AllArgs) :- + vars_susp(A,Args,Susp,AllArgs), + build_head(F,A,[0],AllArgs,Closure), + atom_concat_list(['attach_',F, (/) ,A],AttachF), + Attach =.. [AttachF,Vars,Susp], + Goal = + ( + ( var(Susp) -> + 'chr insert_constraint_internal'(Vars,Susp,Mod:Closure,F,Args) + ; + 'chr activate_constraint'(Vars,Susp,_) + ), + Attach + ). + +gen_uncond_attach_goal(F/A,Susp,_Mod,AttachGoal,Generation) :- + atom_concat_list(['attach_',F, (/) ,A],AttachF), + Attach =.. [AttachF,Vars,Susp], + AttachGoal = + ( + 'chr activate_constraint'(Vars, Susp, Generation), + Attach + ). + +%% Generate all the code for a constraint based on all CHR rules +rules_code([],_,_,_,_,_,_,Id,Id,L,L). +rules_code([R |Rs],RuleNb,FA,I,N,Constraints,Mod,Id1,Id3,L,T) :- + rule_code(R,RuleNb,FA,I,N,Constraints,Mod,Id1,Id2,L,T1), + NextRuleNb is RuleNb + 1, + rules_code(Rs,NextRuleNb,FA,I,N,Constraints,Mod,Id2,Id3,T1,T). + +%% Generate code for a constraint based on a single CHR rule +rule_code(PragmaRule,RuleNb,FA,I,N,Constraints,Mod,Id1,Id2,L,T) :- + PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name), + HeadIDs = ids(Head1IDs,Head2IDs), + Rule = rule(Head1,Head2,_,_), + heads1_code(Head1,[],Head1IDs,[],PragmaRule,FA,I,N,Constraints,Mod,Id1,L,L1), + heads2_code(Head2,[],Head2IDs,[],PragmaRule,RuleNb,FA,I,N,Constraints,Mod,Id1,Id2,L1,T). + +%% Generate code based on all the removed heads of a CHR rule +heads1_code([],_,_,_,_,_,_,_,_,_,_,L,L). +heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,F/A,I,N,Constraints,Mod,Id,L,T) :- + PragmaRule = pragma(Rule,_,Pragmas,_Name), + ( functor(Head,F,A), + \+ check_unnecessary_active(Head,RestHeads,Rule), + \+ memberchk_eq(passive(HeadID),Pragmas) -> + append(Heads,RestHeads,OtherHeads), + append(HeadIDs,RestIDs,OtherIDs), + head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,N,Constraints,Mod,Id,L,L1) + ; + L = L1 + ), + heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,F/A,I,N,Constraints,Mod,Id,L1,T). + +%% Generate code based on one removed head of a CHR rule +head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_Name), + Rule = rule(_,Head2,_,_), + ( Head2 == [] -> + reorder_heads(Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), + simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) + ; + simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) + ). + +%% Generate code based on all the persistent heads of a CHR rule +heads2_code([],_,_,_,_,_,_,_,_,_,_,Id,Id,L,L). +heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,RuleNb,F/A,I,N,Constraints,Mod,Id1,Id3,L,T) :- + PragmaRule = pragma(Rule,_,Pragmas,_Name), + ( functor(Head,F,A), + \+ check_unnecessary_active(Head,RestHeads,Rule), + \+ memberchk_eq(passive(HeadID),Pragmas), + \+ set_semantics_rule(PragmaRule) -> + append(Heads,RestHeads,OtherHeads), + append(HeadIDs,RestIDs,OtherIDs), + length(Heads,RestHeadNb), + head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,F/A,I,N,Constraints,Mod,Id1,L,L0), + inc_id(Id1,Id2), + gen_alloc_inc_clause(F/A,Mod,Id1,L0,L1) + ; + L = L1, + Id2 = Id1 + ), + heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,RuleNb,F/A,I,N,Constraints,Mod,Id2,Id3,L1,T). + +%% Generate code based on one persistent head of a CHR rule +head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,FA,I,N,Constraints,Mod,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_Name), + Rule = rule(Head1,_,_,_), + ( Head1 == [] -> + reorder_heads(Head,OtherHeads,NOtherHeads), + propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) + ; + simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) + ). + +gen_alloc_inc_clause(F/A,Mod,Id,L,T) :- + vars_susp(A,Vars,Susp,VarsSusp), + build_head(F,A,Id,VarsSusp,Head), + inc_id(Id,IncId), + build_head(F,A,IncId,VarsSusp,CallHead), + ( Id == [0] -> + gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,ConditionalAlloc) + ; + ConditionalAlloc = true + ), + Clause = + ( + Head :- + ConditionalAlloc, + CallHead + ), + L = [Clause|T]. + +gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,ConstraintAllocationGoal) :- + build_head(F,A,[0],VarsSusp,Term), + ConstraintAllocationGoal = + ( var(Susp) -> + 'chr allocate_constraint'(Mod : Term, Susp, F, Vars) + ; + true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :- + ( chr_pp_flag(guard_via_reschedule,on) -> + guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) + ; + append(Retrievals,GuardList,GoalList), + list2conj(GoalList,Goal) + ). + +guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :- + initialize_unit_dictionary(Prelude,Dict), + build_units(Retrievals,GuardList,Dict,Units), + dependency_reorder(Units,NUnits), + units2goal(NUnits,Goal). + +units2goal([],true). +units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :- + units2goal(Units,Goals). + +dependency_reorder(Units,NUnits) :- + dependency_reorder(Units,[],NUnits). + +dependency_reorder([],Acc,Result) :- + reverse(Acc,Result). + +dependency_reorder([Unit|Units],Acc,Result) :- + Unit = unit(_GID,_Goal,Type,GIDs), + ( Type == fixed -> + NAcc = [Unit|Acc] + ; + dependency_insert(Acc,Unit,GIDs,NAcc) + ), + dependency_reorder(Units,NAcc,Result). + +dependency_insert([],Unit,_,[Unit]). +dependency_insert([X|Xs],Unit,GIDs,L) :- + X = unit(GID,_,_,_), + ( memberchk(GID,GIDs) -> + L = [Unit,X|Xs] + ; + L = [X | T], + dependency_insert(Xs,Unit,GIDs,T) + ). + +build_units(Retrievals,Guard,InitialDict,Units) :- + build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail), + build_guard_units(Guard,N,Dict,Tail). + +build_retrieval_units([],N,N,Dict,Dict,L,L). +build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :- + term_variables(U,Vs), + update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs), + L = [unit(N,U,movable,GIDs)|L1], + N1 is N + 1, + build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T). + +build_retrieval_units2([],N,N,Dict,Dict,L,L). +build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :- + term_variables(U,Vs), + update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs), + L = [unit(N,U,fixed,GIDs)|L1], + N1 is N + 1, + build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T). + +initialize_unit_dictionary(Term,Dict) :- + term_variables(Term,Vars), + pair_all_with(Vars,0,Dict). + +update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs). +update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :- + ( lookup_eq(Dict,V,GID) -> + ( (GID == This ; memberchk(GID,GIDs) ) -> + GIDs1 = GIDs + ; + GIDs1 = [GID|GIDs] + ), + Dict1 = Dict + ; + Dict1 = [V - This|Dict], + GIDs1 = GIDs + ), + update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs). + +build_guard_units(Guard,N,Dict,Units) :- + ( Guard = [Goal] -> + Units = [unit(N,Goal,fixed,[])] + ; Guard = [Goal|Goals] -> + term_variables(Goal,Vs), + update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs), + Units = [unit(N,Goal,movable,GIDs)|RUnits], + N1 is N + 1, + build_guard_units(Goals,N1,NDict,RUnits) + ). + +update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs). +update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :- + ( lookup_eq(Dict,V,GID) -> + ( (GID == This ; memberchk(GID,GIDs) ) -> + GIDs1 = GIDs + ; + GIDs1 = [GID|GIDs] + ), + Dict1 = [V - This|Dict] + ; + Dict1 = [V - This|Dict], + GIDs1 = GIDs + ), + update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ +%% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _ +%% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_) +%% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_ +%% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_) +%% +%% _ _ _ ___ __ +%% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___ +%% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \ +%% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/ +%% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___| +%% |_| +unique_analyse_optimise(Rules,N,PatternList,NRules) :- + ( chr_pp_flag(unique_analyse_optimise,on) -> + unique_analyse_optimise_main(Rules,N,PatternList,NRules) + ; + NRules = Rules + ). + +unique_analyse_optimise_main([],_,_,[]). +unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :- + ( discover_unique_pattern(PRule,N,Pattern) -> + NPatternList = [Pattern|PatternList] + ; + NPatternList = PatternList + ), + PRule = pragma(Rule,Ids,Pragmas,Name), + Rule = rule(H1,H2,_,_), + Ids = ids(Ids1,Ids2), + apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1), + apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2), + append([MorePragmas1,MorePragmas2,Pragmas],NPragmas), + NPRule = pragma(Rule,Ids,NPragmas,Name), + N1 is N + 1, + unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules). + +apply_unique_patterns_to_constraints([],_,_,[]). +apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :- + ( member(Pattern,Patterns), + apply_unique_pattern(C,Id,Pattern,Pragma) -> + Pragmas = [Pragma | RPragmas] + ; + Pragmas = RPragmas + ), + apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas). + +apply_unique_pattern(Constraint,Id,Pattern,Pragma) :- + Pattern = unique(PatternConstraint,PatternKey), + subsumes(Constraint,PatternConstraint,Unifier), + ( setof( V, + T^Term^Vs^( + member(T,PatternKey), + lookup_eq(Unifier,T,Term), + term_variables(Term,Vs), + member(V,Vs) + ), + Vars) -> + true + ; + Vars = [] + ), + Pragma = unique(Id,Vars). + +% subsumes(+Term1, +Term2, -Unifier) +% +% If Term1 is a more general term than Term2 (e.g. has a larger +% part instantiated), unify Unifier with a list Var-Value of +% variables from Term2 and their corresponding values in Term1. + +subsumes(Term1,Term2,Unifier) :- + empty_ds(S0), + subsumes_aux(Term1,Term2,S0,S), + ds_to_list(S,L), + build_unifier(L,Unifier). + +subsumes_aux(Term1, Term2, S0, S) :- + ( compound(Term2), + functor(Term2, F, N) + -> compound(Term1), functor(Term1, F, N), + subsumes_aux(N, Term1, Term2, S0, S) + ; Term1 == Term2 + -> S = S0 + ; var(Term2), + get_ds(Term1,S0,V) + -> V == Term2, S = S0 + ; var(Term2), + put_ds(Term1, S0, Term2, S) + ). + +subsumes_aux(0, _, _, S, S) :- ! . +subsumes_aux(N, T1, T2, S0, S) :- + arg(N, T1, T1x), + arg(N, T2, T2x), + subsumes_aux(T1x, T2x, S0, S1), + M is N-1, + subsumes_aux(M, T1, T2, S1, S). + +build_unifier([],[]). +build_unifier([X-V|R],[V - X | T]) :- + build_unifier(R,T). + +discover_unique_pattern(PragmaRule,RuleNb,Pattern) :- + PragmaRule = pragma(Rule,_,Pragmas,Name), + ( Rule = rule([C1],[C2],Guard,Body) -> + true + ; + Rule = rule([C1,C2],[],Guard,Body) + ), + check_unique_constraints(C1,C2,Guard,Body,Pragmas,List), + term_variables(C1,Vs), + select_pragma_unique_variables(List,Vs,Key), + Pattern0 = unique(C1,Key), + copy_term_nat(Pattern0,Pattern), + ( verbosity_on -> + format('Found unique pattern ~w in rule ~d~@\n', + [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)]) + ; + true + ). + +select_pragma_unique_variables([],_,[]). +select_pragma_unique_variables([X-Y|R],Vs,L) :- + ( X == Y -> + L = [X|T] + ; + once(( + \+ memberchk_eq(X,Vs) + ; + \+ memberchk_eq(Y,Vs) + )), + L = T + ), + select_pragma_unique_variables(R,Vs,T). + +check_unique_constraints(C1,C2,G,_Body,Pragmas,List) :- + \+ member(passive(_),Pragmas), + variable_replacement(C1-C2,C2-C1,List), + copy_with_variable_replacement(G,OtherG,List), + negate(G,NotG), + once(entails(NotG,OtherG)). + +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(var(X),nonvar(X)). +negate(nonvar(X),var(X)). + +entails(X,X1) :- X1 == X. +entails(fail,_). +entails(X > Y, X1 >= Y1) :- X1 == X, Y1 == Y. +entails(X < Y, X1 =< Y1) :- X1 == X, Y1 == Y. +entails(ground(X),var(X1)) :- X1 == X. + +check_unnecessary_active(Constraint,Previous,Rule) :- + ( chr_pp_flag(check_unnecessary_active,full) -> + check_unnecessary_active_main(Constraint,Previous,Rule) + ; chr_pp_flag(check_unnecessary_active,simplification), + Rule = rule(_,[],_,_) -> + check_unnecessary_active_main(Constraint,Previous,Rule) + ; + fail + ). + +check_unnecessary_active_main(Constraint,Previous,Rule) :- + member(Other,Previous), + variable_replacement(Other,Constraint,List), + copy_with_variable_replacement(Rule,Rule2,List), + identical_rules(Rule,Rule2), ! . + +set_semantics_rule(PragmaRule) :- + ( chr_pp_flag(set_semantics_rule,on) -> + set_semantics_rule_main(PragmaRule) + ; + fail + ). + +set_semantics_rule_main(PragmaRule) :- + PragmaRule = pragma(Rule,IDs,Pragmas,_), + Rule = rule([C1],[C2],true,true), + C1 == C2, + IDs = ids([ID1],_), + \+ memberchk_eq(passive(ID1),Pragmas). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _____ _ _ +%% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___ +%% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \ +%% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/ +%% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___| +%% |_| +% have to check for no duplicates in value list + +% check wether two rules are identical + +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 + ; L2 = [X-Y|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). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ __ _ _ _ +%% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __ +%% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \ +%% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | | +%% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_| +%% |_| + +simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,_I,N,Constraints,Mod,Id,L,T) :- + PragmaRule = pragma(Rule,_,Pragmas,_), + head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs), + build_head(F,A,Id,HeadVars,ClauseHead), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict1), + + ( RestHeads == [] -> + Susps = [], + VarDict = VarDict1, + GetRestHeads = [] + ; + rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,Mod,N,Constraints,GetRestHeads,Susps,VarDict1,VarDict) + ), + + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest), + + gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments), + gen_cond_susp_detachment(Susp,F/A,SuspDetachment), + + Clause = ( ClauseHead :- + FirstMatching, + RescheduledTest, + !, + SuspsDetachments, + SuspDetachment, + BodyCopy + ), + L = [Clause | T]. + +head_arg_matches(Pairs,VarDict,Goal,NVarDict) :- + head_arg_matches_(Pairs,VarDict,GoalList,NVarDict), + list2conj(GoalList,Goal). + +head_arg_matches_([],VarDict,[],VarDict). +head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :- + ( var(Arg) -> + ( lookup_eq(VarDict,Arg,OtherVar) -> + GoalList = [Var == OtherVar | RestGoalList], + VarDict1 = VarDict + ; VarDict1 = [Arg-Var | VarDict], + GoalList = RestGoalList + ), + Pairs = Rest + ; atomic(Arg) -> + GoalList = [ Var == Arg | RestGoalList], + VarDict = VarDict1, + Pairs = Rest + ; Arg =.. [_|Args], + functor(Arg,Fct,N), + functor(Term,Fct,N), + Term =.. [_|Vars], + GoalList =[ nonvar(Var), Var = Term | RestGoalList ], + pairup(Args,Vars,NewPairs), + append(NewPairs,Rest,Pairs), + VarDict1 = VarDict + ), + head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict). + +rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict):- + rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict,[],[],[]). + +rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :- + ( Heads = [_|_] -> + rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict,AttrDict) + ; + GoalList = [], + Susps = [], + VarDict = NVarDict + ). + +rest_heads_retrieval_and_matching_n([],_,_,_,_,_,_,N,_,[],[],VarDict,VarDict,AttrDict) :- + instantiate_pattern_goals(AttrDict,N). +rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,Mod,N,Constraints,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :- + passive_head_via(H,[ActiveHead|PrevHs],AttrDict,Constraints,Mod,VarDict,ViaGoal,Attr,NewAttrDict), + functor(H,Fct,Aty), + head_info(H,Aty,Vars,_,_,Pairs), + head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1), + Suspension =.. [suspension,_,State,_,_,_,_|Vars], + ( N == 1 -> + VarSusps = Attr + ; + nth1(Pos,Constraints,Fct/Aty), !, + make_attr(N,_Mask,SuspsList,Attr), + nth1(Pos,SuspsList,VarSusps) + ), + different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals), + create_get_mutable_ref(active,State,GetMutable), + Goal1 = + ( + 'chr sbag_member'(Susp,VarSusps), + Susp = Suspension, + GetMutable, + DiffSuspGoals, + MatchingGoal + ), + ( member(unique(ID,UniqueKeus),Pragmas), + check_unique_keys(UniqueKeus,VarDict) -> + Goal = (Goal1 -> true) % once(Goal1) + ; + Goal = Goal1 + ), + rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Mod,N,Constraints,Goals,Susps,VarDict1,NVarDict,NewAttrDict). + +instantiate_pattern_goals([],_). +instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest],N) :- + ( N == 1 -> + Goal = true + ; + make_attr(N,Mask,_,Attr), + or_list(Bits,Pattern), !, + Goal = (Mask /\ Pattern =:= Pattern) + ), + instantiate_pattern_goals(Rest,N). + + +check_unique_keys([],_). +check_unique_keys([V|Vs],Dict) :- + lookup_eq(Dict,V,_), + check_unique_keys(Vs,Dict). + +% Generates tests to ensure the found constraint differs from previously found constraints +different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :- + ( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) -> + list2conj(DiffSuspGoalList,DiffSuspGoals) + ; + DiffSuspGoals = true + ). + +passive_head_via(Head,PrevHeads,AttrDict,Constraints,Mod,VarDict,Goal,Attr,NewAttrDict) :- + functor(Head,F,A), + nth1(Pos,Constraints,F/A),!, + common_variables(Head,PrevHeads,CommonVars), + translate(CommonVars,VarDict,Vars), + or_pattern(Pos,Bit), + ( permutation(Vars,PermutedVars), + lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) -> + member(Bit,Positions), !, + NewAttrDict = AttrDict, + Goal = true + ; + Goal = (Goal1, PatternGoal), + gen_get_mod_constraints(Mod,Vars,Goal1,Attr), + NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict] + ). + +common_variables(T,Ts,Vs) :- + term_variables(T,V1), + term_variables(Ts,V2), + intersect_eq(V1,V2,Vs). + +gen_get_mod_constraints(Mod,L,Goal,Susps) :- + ( L == [] -> + Goal = + ( 'chr default_store'(Global), + get_attr(Global,Mod,TSusps), + TSusps = Susps + ) + ; + ( L = [A] -> + VIA = 'chr via_1'(A,V) + ; ( L = [A,B] -> + VIA = 'chr via_2'(A,B,V) + ; VIA = 'chr via'(L,V) + ) + ), + Goal = + ( VIA, + get_attr(V,Mod,TSusps), + TSusps = Susps + ) + ). + +guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :- + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + list2conj(GuardCopyList,GuardCopy). + +guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :- + Rule = rule(_,_,Guard,Body), + conj2list(Guard,GuardList), + split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList), + my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore), + + append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList), + term_variables(RestGuardList,GuardVars), + term_variables(RestGuardListCopyCore,GuardCopyVars), + ( chr_pp_flag(guard_locks,on), + bagof(('chr lock'(Y)) - ('chr unlock'(Y)), + X ^ (member(X,GuardVars), % X is a variable appearing in the original guard + lookup_eq(VarDict,X,Y), % translate X into new variable + memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible? + ), + LocksUnlocks) -> + once(pairup(Locks,Unlocks,LocksUnlocks)) + ; + Locks = [], + Unlocks = [] + ), + list2conj(Locks,LockPhase), + list2conj(Unlocks,UnlockPhase), + list2conj(RestGuardListCopyCore,RestGuardCopyCore), + RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)), + my_term_copy(Body,VarDict2,BodyCopy). + + +split_off_simple_guard([],_,[],[]). +split_off_simple_guard([G|Gs],VarDict,S,C) :- + ( simple_guard(G,VarDict) -> + S = [G|Ss], + split_off_simple_guard(Gs,VarDict,Ss,C) + ; + S = [], + C = [G|Gs] + ). + +% simple guard: cheap and benign (does not bind variables) + +simple_guard(var(_), _). +simple_guard(nonvar(_), _). +simple_guard(ground(_), _). +simple_guard(number(_), _). +simple_guard(atom(_), _). +simple_guard(integer(_), _). +simple_guard(float(_), _). + +simple_guard(_ > _ , _). +simple_guard(_ < _ , _). +simple_guard(_ =< _, _). +simple_guard(_ >= _, _). +simple_guard(_ =:= _, _). +simple_guard(_ == _, _). + +simple_guard(X is _, VarDict) :- + \+ lookup_eq(VarDict,X,_). + +simple_guard((G1,G2),VarDict) :- + simple_guard(G1,VarDict), + simple_guard(G2,VarDict). + +simple_guard(\+ G, VarDict) :- + simple_guard(G, VarDict). + +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). + +gen_cond_susp_detachment(Susp,FA,SuspDetachment) :- + gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment), + SuspDetachment = + ( var(Susp) -> + true + ; UnCondSuspDetachment + ). + +gen_uncond_susp_detachment(Susp,CFct/CAty,SuspDetachment) :- + atom_concat_list(['detach_',CFct, (/) ,CAty],Fct), + Detach =.. [Fct,Vars,Susp], + SuspDetachment = + ( + 'chr remove_constraint_internal'(Susp, Vars), + Detach + ). + +gen_uncond_susps_detachments([],[],true). +gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :- + functor(Term,F,A), + gen_uncond_susp_detachment(Susp,F/A,SuspDetachment), + gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ _ +%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / | +%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | | +%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | | +%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_| +%% |_| |___/ + +simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,_I,N,Constraints,Mod,Id,L,T) :- + PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name), + Rule = rule(_Heads,Heads2,_Guard,_Body), + + head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict1), + + build_head(F,A,Id,HeadVars,ClauseHead), + + append(RestHeads,Heads2,Heads), + append(OtherIDs,Heads2IDs,IDs), + reorder_heads(Head,Heads,IDs,NHeads,NIDs), + rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,Mod,N,Constraints,GetRestHeads,Susps,VarDict1,VarDict), + length(RestHeads,RN), + take(RN,Susps,Susps1), + + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest), + + gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments), + gen_cond_susp_detachment(Susp,F/A,SuspDetachment), + + Clause = ( ClauseHead :- + FirstMatching, + RescheduledTest, + !, + SuspsDetachments, + SuspDetachment, + BodyCopy + ), + L = [Clause | T]. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ ____ +%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \ +%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) | +%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/ +%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____| +%% |_| |___/ + +%% Genereate prelude + worker predicate +%% prelude calls worker +%% worker iterates over one type of removed constraints +simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) :- + PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name), + Rule = rule(Heads1,_,Guard,Body), + reorder_heads(Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1], + % IDs1 = [ID1|RestIDs1], + simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,I,N,Constraints,Mod,Id,L,L1), + extend_id(Id,Id2), + simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,Rule,Pragmas,FA,I,N,Constraints,Mod,Id2,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_prelude(Head,Head1,Rest,F/A,_I,N,Constraints,Mod,Id1,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id1,VarsSusp,ClauseHead), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict), + + passive_head_via(Head1,[Head],[],Constraints,Mod,VarDict,ModConstraintsGoal,Attr,AttrDict), + instantiate_pattern_goals(AttrDict,N), + ( N == 1 -> + AllSusps = Attr + ; + functor(Head1,F1,A1), + nth1(Pos,Constraints,F1/A1), !, + make_attr(N,_,SuspsList,Attr), + nth1(Pos,SuspsList,AllSusps) + ), + + ( Id1 == [0] -> % create suspension + gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,ConstraintAllocationGoal) + ; ConstraintAllocationGoal = true + ), + + extend_id(Id1,DelegateId), + extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars), + append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars), + build_head(F,A,DelegateId,DelegateCallVars,Delegate), + + PreludeClause = + ( ClauseHead :- + FirstMatching, + ModConstraintsGoal, + !, + ConstraintAllocationGoal, + Delegate + ), + L = [PreludeClause|T]. + +extra_active_delegate_variables(Term,Terms,VarDict,Vars) :- + Term =.. [_|Args], + delegate_variables(Term,Terms,VarDict,Args,Vars). + +passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :- + term_variables(PrevTerms,PrevVars), + delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars). + +delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :- + term_variables(Term,V1), + term_variables(Terms,V2), + intersect_eq(V1,V2,V3), + list_difference_eq(V3,PrevVars,V4), + translate(V4,VarDict,Vars). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,I,N,Constraints,Mod,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1), + simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,I,N,Constraints,Mod,Id,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,F/A,_I,N,Constraints,Mod,Id,L,T) :- + gen_var(OtherSusp), + gen_var(OtherSusps), + + head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs), + head_arg_matches(Head2Pairs,[],_,VarDict1), + + Rule = rule(_,_,Guard,Body), + extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars), + append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars), + build_head(F,A,Id,HeadVars,ClauseHead), + + functor(Head1,_OtherF,OtherA), + head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs), + head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2), + + OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars], + create_get_mutable_ref(active,OtherState,GetMutable), + IteratorSuspTest = + ( OtherSusp = OtherSuspension, + GetMutable + ), + + ( (RestHeads1 \== [] ; RestHeads2 \== []) -> + append(RestHeads1,RestHeads2,RestHeads), + append(IDs1,IDs2,IDs), + reorder_heads(Head1-Head2,RestHeads,IDs,NRestHeads,NIDs), + rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],Mod,N,Constraints,RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]), + length(RestHeads1,RH1N), + take(RH1N,Susps,Susps1) + ; RestSuspsRetrieval = [], + Susps1 = [], + VarDict = VarDict2 + ), + + gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments), + + append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars), + build_head(F,A,Id,RecursiveVars,RecursiveCall), + append([[]|VarsSusp],ExtraVars,RecursiveVars2), + build_head(F,A,Id,RecursiveVars2,RecursiveCall2), + + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest), + ( BodyCopy \== true -> + gen_uncond_attach_goal(F/A,Susp,Mod,Attachment,Generation), + gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall), + gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2) + ; Attachment = true, + ConditionalRecursiveCall = RecursiveCall, + ConditionalRecursiveCall2 = RecursiveCall2 + ), + + ( member(unique(ID1,UniqueKeys), Pragmas), + check_unique_keys(UniqueKeys,VarDict1) -> + Clause = + ( ClauseHead :- + ( IteratorSuspTest, + FirstMatching -> + ( RescheduledTest -> + Susps1Detachments, + Attachment, + BodyCopy, + ConditionalRecursiveCall2 + ; + RecursiveCall2 + ) + ; + RecursiveCall + ) + ) + ; + Clause = + ( ClauseHead :- + ( IteratorSuspTest, + FirstMatching, + RescheduledTest -> + Susps1Detachments, + Attachment, + BodyCopy, + ConditionalRecursiveCall + ; + RecursiveCall + ) + ) + ), + L = [Clause | T]. + +gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :- + length(Args,N), + Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args], + create_get_mutable_ref(active,State,GetState), + create_get_mutable_ref(Generation,NewGeneration,GetGeneration), + ConditionalCall = + ( Susp = Suspension, + GetState, + GetGeneration -> + 'chr update_mutable'(inactive,State), + Call + ; true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :- + head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs), + head_arg_matches(Pairs,[],_,VarDict), + extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars), + append([[]|VarsSusp],ExtraVars,HeadVars), + build_head(F,A,Id,HeadVars,ClauseHead), + next_id(Id,ContinuationId), + build_head(F,A,ContinuationId,VarsSusp,ContinuationHead), + Clause = ( ClauseHead :- ContinuationHead ), + L = [Clause | T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ +%% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ +%% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ +%% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | | +%% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| +%% |_| |___/ + +propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) :- + ( RestHeads == [] -> + propagation_single_headed(Head,Rule,RuleNb,FA,Mod,Id,L,T) + ; + propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Single headed propagation +%% everything in a single clause +propagation_single_headed(Head,Rule,RuleNb,F/A,Mod,Id,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id,VarsSusp,ClauseHead), + + inc_id(Id,NextId), + build_head(F,A,NextId,VarsSusp,NextHead), + + NextCall = NextHead, + + head_arg_matches(HeadPairs,[],HeadMatching,VarDict), + guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), + ( Id == [0] -> + gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,Allocation), + Allocation1 = Allocation + ; + Allocation1 = true + ), + gen_uncond_attach_goal(F/A,Susp,Mod,Attachment,Generation), + + gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall), + + Clause = ( + ClauseHead :- + HeadMatching, + Allocation1, + 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp) + GuardCopy, + !, + 'chr extend_history'(Susp,RuleNb), + Attachment, + BodyCopy, + ConditionalNextCall + ), + L = [Clause | T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% multi headed propagation +%% prelude + predicates to accumulate the necessary combinations of suspended +%% constraints + predicate to execute the body +propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) :- + RestHeads = [First|Rest], + propagation_prelude(Head,RestHeads,Rule,FA,N,Constraints,Mod,Id,L,L1), + extend_id(Id,ExtendedId), + propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,ExtendedId,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +propagation_prelude(Head,[First|Rest],Rule,F/A,N,Constraints,Mod,Id,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id,VarsSusp,PreludeHead), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict), + Rule = rule(_,_,Guard,Body), + extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars), + + passive_head_via(First,[Head],[],Constraints,Mod,VarDict,FirstSuspGoal,Attr,AttrDict), + instantiate_pattern_goals(AttrDict,N), + ( N == 1 -> + Susps = Attr + ; + functor(First,FirstFct,FirstAty), + make_attr(N,_Mask,SuspsList,Attr), + nth1(Pos,Constraints,FirstFct/FirstAty), !, + nth1(Pos,SuspsList,Susps) + ), + + ( Id == [0] -> + gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,CondAllocation) + ; CondAllocation = true + ), + + extend_id(Id,NestedId), + append([Susps|VarsSusp],ExtraVars,NestedVars), + build_head(F,A,NestedId,NestedVars,NestedHead), + NestedCall = NestedHead, + + Prelude = ( + PreludeHead :- + FirstMatching, + FirstSuspGoal, + !, + CondAllocation, + NestedCall + ), + L = [Prelude|T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,_,_Constraints,Mod,Id,L,T) :- + propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1), + propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Mod,Id,L1,T). + +propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) :- + propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1), + propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,N,Constraints,Mod,Id,L1,L2), + inc_id(Id,IncId), + propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,IncId,L2,T). + +propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Mod,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps), + gen_var(OtherSusp), + gen_var(OtherSusps), + functor(CurrentHead,_OtherF,OtherA), + gen_vars(OtherA,OtherVars), + Suspension =.. [suspension,_,State,_,_,_,_|OtherVars], + create_get_mutable_ref(active,State,GetMutable), + CurrentSuspTest = ( + OtherSusp = Suspension, + GetMutable + ), + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,Id,ClauseVars,ClauseHead), + RecursiveVars = [OtherSusps|PreVarsAndSusps], + build_head(F,A,Id,RecursiveVars,RecursiveHead), + RecursiveCall = RecursiveHead, + CurrentHead =.. [_|OtherArgs], + pairup(OtherArgs,OtherVars,OtherPairs), + head_arg_matches(OtherPairs,VarDict1,Matching,VarDict), + + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals), + + guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), + gen_uncond_attach_goal(F/A,Susp,Mod,Attach,Generation), + gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall), + + history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps), + bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList), + list2conj(NovelProductionsList,NovelProductions), + Tuple =.. [t,RuleNb|HistorySusps], + + Clause = ( + ClauseHead :- + ( CurrentSuspTest, + DiffSuspGoals, + Matching, + TupleVar = Tuple, + NovelProductions, + GuardCopy -> + 'chr extend_history'(Susp,TupleVar), + Attach, + BodyCopy, + ConditionalRecursiveCall + ; RecursiveCall + ) + ), + L = [Clause|T]. + + +history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :- + ( Count == 0 -> + reverse(OtherSusps,ReversedSusps), + append(ReversedSusps,[Susp|Acc],HistorySusps) + ; + OtherSusps = [OtherSusp|RestOtherSusps], + NCount is Count - 1, + history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps) + ). + + +get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :- + !, + functor(Head,_F,A), + head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), + head_arg_matches(Pairs,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :- + get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps), + functor(Head,_F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs), + head_arg_matches(Pairs,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps). + +propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp), + + Vars = [ [] | VarsAndSusps], + + build_head(F,A,Id,Vars,Head), + + ( Id = [0|_] -> + next_id(Id,PrevId), + PrevVarsAndSusps = AllButFirst + ; + dec_id(Id,PrevId), + PrevVarsAndSusps = [FirstSusp|AllButFirst] + ), + + build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead), + PredecessorCall = PrevHead, + + Clause = ( + Head :- + PredecessorCall + ), + L = [Clause | T]. + +gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :- + !, + functor(Head,_F,A), + head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :- + gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_), + functor(Head,_F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps|Rest],VarsSusps). + +propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,N,Constraints,Mod,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps), + gen_var(OtherSusps), + functor(CurrentHead,_OtherF,OtherA), + gen_vars(OtherA,OtherVars), + head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1), + + OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars], + + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), + create_get_mutable_ref(active,State,GetMutable), + CurrentSuspTest = ( + OtherSusp = OtherSuspension, + GetMutable, + DiffSuspGoals, + FirstMatching + ), + functor(NextHead,NextF,NextA), + passive_head_via(NextHead,[CurrentHead|PreHeads],[],Constraints,Mod,VarDict1,NextSuspGoal,Attr,AttrDict), + instantiate_pattern_goals(AttrDict,N), + ( N == 1 -> + NextSusps = Attr + ; + nth1(Position,Constraints,NextF/NextA), !, + make_attr(N,_Mask,SuspsList,Attr), + nth1(Position,SuspsList,NextSusps) + ), + inc_id(Id,NestedId), + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,Id,ClauseVars,ClauseHead), + passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars), + append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars), + build_head(F,A,NestedId,NestedVars,NestedHead), + + RecursiveVars = [OtherSusps|PreVarsAndSusps], + build_head(F,A,Id,RecursiveVars,RecursiveHead), + Clause = ( + ClauseHead :- + ( CurrentSuspTest, + NextSuspGoal + -> + NestedHead + ; RecursiveHead + ) + ), + L = [Clause|T]. + +pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :- + !, + functor(Head,_F,A), + head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :- + pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps), + functor(Head,_F,A), + gen_var(NextSusps), + head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,NextSusps|VSs],NVSs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ _ +%% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| | +%% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` | +%% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| | +%% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_| +%% +%% ____ _ _ _ +%% | _ \ ___| |_ _ __(_) _____ ____ _| | +%% | |_) / _ \ __| '__| |/ _ \ \ / / _` | | +%% | _ < __/ |_| | | | __/\ V / (_| | | +%% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_| +%% +%% ____ _ _ +%% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _ +%% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` | +%% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| | +%% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, | +%% |___/ + +reorder_heads(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- + ( chr_pp_flag(reorder_heads,on) -> + reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) + ; + NRestHeads = RestHeads, + NRestIDs = RestIDs + ). + +reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- + term_variables(Head,KnownVars), + reorder_heads1(RestHeads,RestIDs,KnownVars,NRestHeads,NRestIDs). + +reorder_heads1(Heads,IDs,KnownVars,NHeads,NIDs) :- + ( Heads == [] -> + NHeads = [], + NIDs = [] + ; + NHeads = [BestHead|BestTail], + NIDs = [BestID | BestIDs], + select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars), + reorder_heads1(RestHeads,RestIDs,NKnownVars,BestTail,BestIDs) + ). + +select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars) :- + ( bagof(tuple(Score,Head,ID,Rest,RIDs), ( + select2(Head,ID, Heads,IDs,Rest,RIDs) , + order_score(Head,KnownVars,Rest,Score) + ), + Scores) -> true ; Scores = []), + max_go_list(Scores,tuple(_,BestHead,BestID,RestHeads,RestIDs)), + term_variables(BestHead,BestHeadVars), + ( setof(V, ( + member(V,BestHeadVars), + \+ memberchk_eq(V,KnownVars) + ), + NewVars) -> true ; NewVars = []), + append(NewVars,KnownVars,NKnownVars). + +reorder_heads(Head,RestHeads,NRestHeads) :- + term_variables(Head,KnownVars), + reorder_heads1(RestHeads,KnownVars,NRestHeads). + +reorder_heads1(Heads,KnownVars,NHeads) :- + ( Heads == [] -> + NHeads = [] + ; + NHeads = [BestHead|BestTail], + select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars), + reorder_heads1(RestHeads,NKnownVars,BestTail) + ). + +select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars) :- + ( bagof(tuple(Score,Head,Rest), ( + select(Head,Heads,Rest) , + order_score(Head,KnownVars,Rest,Score) + ), + Scores) -> true ; Scores = []), + max_go_list(Scores,tuple(_,BestHead,RestHeads)), + term_variables(BestHead,BestHeadVars), + ( setof(V, ( + member(V,BestHeadVars), + \+ memberchk_eq(V,KnownVars) + ), + NewVars) -> true ; NewVars = []), + append(NewVars,KnownVars,NKnownVars). + +order_score(Head,KnownVars,Rest,Score) :- + term_variables(Head,HeadVars), + term_variables(Rest,RestVars), + order_score_vars(HeadVars,KnownVars,RestVars,0,Score). + +order_score_vars([],_,_,Score,NScore) :- + ( Score == 0 -> + NScore = 99999 + ; + NScore = Score + ). +order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :- + ( memberchk_eq(V,KnownVars) -> + TScore is Score + 1 + ; memberchk_eq(V,RestVars) -> + TScore is Score + 1 + ; + TScore = Score + ), + order_score_vars(Vs,KnownVars,RestVars,TScore,NScore). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ___ _ _ _ +%% |_ _|_ __ | (_)_ __ (_)_ __ __ _ +%% | || '_ \| | | '_ \| | '_ \ / _` | +%% | || | | | | | | | | | | | | (_| | +%% |___|_| |_|_|_|_| |_|_|_| |_|\__, | +%% |___/ + +%% SWI begin +create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)). +%% SWI end + +%% SICStus begin +%% create_get_mutable_ref(V,M,GM) :- GM = (get_mutable(V,M)). +%% SICStus end + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ +%% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _ +%% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` | +%% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| | +%% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, | +%% |___/ +%% +%% removes redundant 'true's and other trivial but potentially non-free constructs + +clean_clauses([],[]). +clean_clauses([C|Cs],[NC|NCs]) :- + clean_clause(C,NC), + clean_clauses(Cs,NCs). + +clean_clause(Clause,NClause) :- + ( Clause = (Head :- Body) -> + clean_goal(Body,NBody), + ( NBody == true -> + NClause = Head + ; + NClause = (Head :- NBody) + ) + ; + 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). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% _ _ _ _ _ _ _ +%% | | | | |_(_) (_) |_ _ _ +%% | | | | __| | | | __| | | | +%% | |_| | |_| | | | |_| |_| | +%% \___/ \__|_|_|_|\__|\__, | +%% |___/ + +gen_var(_). +gen_vars(N,Xs) :- + length(Xs,N). + +head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :- + vars_susp(A,Vars,Susp,VarsSusp), + Head =.. [_|Args], + pairup(Args,Vars,HeadPairs). + +inc_id([N|Ns],[O|Ns]) :- + O is N + 1. +dec_id([N|Ns],[M|Ns]) :- + M is N - 1. + +extend_id(Id,[0|Id]). + +next_id([_,N|Ns],[O|Ns]) :- + O is N + 1. + +build_head(F,A,Id,Args,Head) :- + buildName(F,A,Id,Name), + Head =.. [Name|Args]. + +buildName(Fct,Aty,List,Result) :- + atom_concat(Fct, (/) ,FctSlash), + atomic_concat(FctSlash,Aty,FctSlashAty), + buildName_(List,FctSlashAty,Result). + +buildName_([],Name,Name). +buildName_([N|Ns],Name,Result) :- + buildName_(Ns,Name,Name1), + atom_concat(Name1,'__',NameDash), % '_' is a char :-( + atomic_concat(NameDash,N,Result). + +vars_susp(A,Vars,Susp,VarsSusp) :- + length(Vars,A), + append(Vars,[Susp],VarsSusp). + +make_attr(N,Mask,SuspsList,Attr) :- + length(SuspsList,N), + Attr =.. [v,Mask|SuspsList]. + +or_pattern(Pos,Pat) :- + Pow is Pos - 1, + Pat is 1 << Pow. % was 2 ** X + +and_pattern(Pos,Pat) :- + X is Pos - 1, + Y is 1 << X, % was 2 ** X + Pat is -(Y + 1). + +conj2list(Conj,L) :- %% transform conjunctions to list + conj2list(Conj,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) + ). + +atom_concat_list([X],X) :- ! . +atom_concat_list([X|Xs],A) :- + atom_concat_list(Xs,B), + atomic_concat(X,B,A). + +set_elems([],_). +set_elems([X|Xs],X) :- + set_elems(Xs,X). + +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). + +pair_all_with([],_,[]). +pair_all_with([X|Xs],Y,[X-Y|Rest]) :- + pair_all_with(Xs,Y,Rest). + +default(X,Def) :- + ( var(X) -> X = Def ; true). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% SWI begin +verbosity_on :- prolog_flag(verbose,V), V == yes. +%% SWI end + +%% SICStus begin +%% verbosity_on. % at the moment +%% SICStus end diff --git a/packages/chr/chr_translate_bootstrap1.chr b/packages/chr/chr_translate_bootstrap1.chr new file mode 100644 index 000000000..cdee4cbe0 --- /dev/null +++ b/packages/chr/chr_translate_bootstrap1.chr @@ -0,0 +1,2315 @@ +/* Generated by CHR bootstrap compiler + From: chr_translate_bootstrap1.pl + Date: Fri Jan 12 13:49:11 2007 + + DO NOT EDIT. EDIT THE CHR FILE INSTEAD +*/ + +:- module(chr_translate_bootstrap1, + [ chr_translate/2 + ]). +:- use_module(chr_runtime). +:- style_check(- (discontiguous)). +:- use_module(chr_runtime). +:- style_check(- (discontiguous)). +:- use_module(library(lists), + [ append/3, + member/2, + permutation/2, + reverse/2 + ]). +:- use_module(library(ordsets)). +:- use_module(library(dialect/hprolog)). +:- use_module(pairlist). +:- include(chr_op2). +chr_translate(A, C) :- + init_chr_pp_flags, + partition_clauses(A, B, E, D), + ( B==[] + -> C=D + ; check_rules(E, B), + unique_analyse_optimise(E, F), + check_attachments(F), + set_constraint_indices(B, 1), + store_management_preds(B, G), + constraints_code(B, F, H), + append([D, G, H], C) + ), + chr_clear. +store_management_preds(A, E) :- + generate_attach_detach_a_constraint_all(A, B), + generate_attach_increment(C), + generate_attr_unify_hook(D), + append([B, C, D], E). +partition_clauses([], [], [], []). +partition_clauses([A|M], B, C, E) :- + ( rule(A, D) + -> B=G, + C=[D|H], + E=I + ; is_declaration(A, F) + -> append(F, G, B), + C=H, + E=I + ; is_module_declaration(A, J) + -> target_module(J), + B=G, + C=H, + E=[A|I] + ; A=handler(_) + -> format('CHR compiler WARNING: ~w.\n', [A]), + format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n', []), + B=G, + C=H, + E=I + ; A=rules(_) + -> format('CHR compiler WARNING: ~w.\n', [A]), + format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n', []), + B=G, + C=H, + E=I + ; A= (:-chr_option(K, L)) + -> handle_option(K, L), + B=G, + C=H, + E=I + ; B=G, + C=H, + E=[A|I] + ), + partition_clauses(M, G, H, I). +is_declaration(A, D) :- + A= (:-B), + ( B=..[chr_constraint, C] + ; B=..[chr_constraint, C] + ), + conj2list(C, D). +rule(A, D) :- + A= @(C, B), !, + rule(B, yes(C), D). +rule(A, B) :- + rule(A, no, B). +rule(A, H, D) :- + A=pragma(B, C), !, + is_rule(B, E, F), + conj2list(C, G), + D=pragma(E, F, G, H). +rule(A, E, B) :- + is_rule(A, C, D), + B=pragma(C, D, [], E). +is_rule(A, G, D) :- + A= ==>(B, F), !, + conj2list(B, C), + get_ids(C, E, H), + D=ids([], E), + ( F= '|'(I,J) + -> G=rule([], H, I, J) + ; G=rule([], H, true, F) + ). +is_rule(A, R, M) :- + A= <=>(G, B), !, + ( B= '|'(C,D) + -> E=C, + F=D + ; E=true, + F=B + ), + ( G= \(H, I) + -> conj2list(H, J), + conj2list(I, K), + get_ids(J, O, P, 0, L), + get_ids(K, N, Q, L, _), + M=ids(N, O) + ; conj2list(G, K), + P=[], + get_ids(K, N, Q), + M=ids(N, []) + ), + R=rule(Q, P, E, F). +get_ids(A, B, C) :- + get_ids(A, B, C, 0, _). +get_ids([], [], [], A, A). +get_ids([B|D], [A|E], [C|F], A, H) :- + ( B= #(C, A) + -> true + ; C=B + ), + G is A+1, + get_ids(D, E, F, G, H). +is_module_declaration((:-module(A)), A). +is_module_declaration((:-module(A, _)), A). +check_rules(A, B) :- + check_rules(A, B, 1). +check_rules([], _, _). +check_rules([A|D], B, C) :- + check_rule(A, B, C), + E is C+1, + check_rules(D, B, E). +check_rule(A, F, G) :- + A=pragma(B, _, H, _), + B=rule(C, D, _, _), + append(C, D, E), + check_head_constraints(E, F, A, G), + check_pragmas(H, A, G). +check_head_constraints([], _, _, _). +check_head_constraints([A|E], D, F, G) :- + functor(A, B, C), + ( member(B/C, D) + -> check_head_constraints(E, D, F, G) + ; format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n', [B/C, format_rule(F, G)]), + format(' `--> Constraint should be on of ~w.\n', [D]), + fail + ). +check_pragmas([], _, _). +check_pragmas([A|D], B, C) :- + check_pragma(A, B, C), + check_pragmas(D, B, C). +check_pragma(A, B, C) :- + var(A), !, + format('CHR compiler ERROR: invalid pragma ~w in ~@.\n', [A, format_rule(B, C)]), + format(' `--> Pragma should not be a variable!\n', []), + fail. +check_pragma(passive(B), A, E) :- !, + A=pragma(_, ids(C, D), _, _), + ( memberchk_eq(B, C) + -> true + ; memberchk_eq(B, D) + -> true + ; format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n', [B, format_rule(A, E)]), + fail + ). +check_pragma(A, B, C) :- + A=unique(_, _), !, + format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n', [A, format_rule(B, C)]), + format(' `--> Only use this pragma if you know what you are doing.\n', []). +check_pragma(A, B, C) :- + A=already_in_heads, !, + format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n', [A, format_rule(B, C)]), + format(' `--> Pragma is ignored. Termination and correctness may be affected \n', []). +check_pragma(A, B, C) :- + A=already_in_head(_), !, + format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n', [A, format_rule(B, C)]), + format(' `--> Pragma is ignored. Termination and correctness may be affected \n', []). +check_pragma(A, B, C) :- + format('CHR compiler ERROR: invalid pragma ~w in ~@.\n', [A, format_rule(B, C)]), + format(' `--> Pragma should be one of passive/1!\n', []), + fail. +format_rule(A, D) :- + A=pragma(_, _, _, B), + ( B=yes(C) + -> write('rule '), + write(C) + ; write('rule number '), + write(D) + ). +handle_option(A, B) :- + var(A), !, + format('CHR compiler ERROR: ~w.\n', [option(A, B)]), + format(' `--> First argument should be an atom, not a variable.\n', []), + fail. +handle_option(B, A) :- + var(A), !, + format('CHR compiler ERROR: ~w.\n', [option(B, A)]), + format(' `--> Second argument should be a nonvariable.\n', []), + fail. +handle_option(A, B) :- + option_definition(A, B, C), !, + set_chr_pp_flags(C). +handle_option(A, _) :- + \+option_definition(A, _, _), !. +handle_option(A, C) :- + findall(B, option_definition(A, B, _), D), + format('CHR compiler ERROR: ~w.\n', [option(A, C)]), + format(' `--> Invalid value ~w: should be one of ~w.\n', [C, D]), + fail. +option_definition(optimize, experimental, A) :- + A=[unique_analyse_optimise-on, check_unnecessary_active-full, reorder_heads-on, set_semantics_rule-on, check_attachments-on, guard_via_reschedule-on]. +option_definition(optimize, full, A) :- + A=[unique_analyse_optimise-on, check_unnecessary_active-full, reorder_heads-on, set_semantics_rule-on, check_attachments-on, guard_via_reschedule-on]. +option_definition(optimize, sicstus, A) :- + A=[unique_analyse_optimise-off, check_unnecessary_active-simplification, reorder_heads-off, set_semantics_rule-off, check_attachments-off, guard_via_reschedule-off]. +option_definition(optimize, off, A) :- + A=[unique_analyse_optimise-off, check_unnecessary_active-off, reorder_heads-off, set_semantics_rule-off, check_attachments-off, guard_via_reschedule-off]. +option_definition(debug, off, A) :- + A=[debugable-off]. +option_definition(debug, on, A) :- + A=[debugable-on]. +option_definition(check_guard_bindings, on, A) :- + A=[guard_locks-on]. +option_definition(check_guard_bindings, off, A) :- + A=[guard_locks-off]. +init_chr_pp_flags :- + chr_pp_flag_definition(A, [B|_]), + set_chr_pp_flag(A, B), + fail. +init_chr_pp_flags. +set_chr_pp_flags([]). +set_chr_pp_flags([A-B|C]) :- + set_chr_pp_flag(A, B), + set_chr_pp_flags(C). +set_chr_pp_flag(A, C) :- + atomic_concat('$chr_pp_', A, B), + nb_setval(B, C). +chr_pp_flag_definition(unique_analyse_optimise, [on, off]). +chr_pp_flag_definition(check_unnecessary_active, [full, simplification, off]). +chr_pp_flag_definition(reorder_heads, [on, off]). +chr_pp_flag_definition(set_semantics_rule, [on, off]). +chr_pp_flag_definition(guard_via_reschedule, [on, off]). +chr_pp_flag_definition(guard_locks, [on, off]). +chr_pp_flag_definition(check_attachments, [on, off]). +chr_pp_flag_definition(debugable, [off, on]). +chr_pp_flag(A, D) :- + atomic_concat('$chr_pp_', A, B), + nb_getval(B, C), + ( C==[] + -> chr_pp_flag_definition(A, [D|_]) + ; C=D + ). +generate_attach_detach_a_constraint_all([], []). +generate_attach_detach_a_constraint_all([A|D], F) :- + ( is_attached(A) + -> generate_attach_a_constraint(A, B), + generate_detach_a_constraint(A, C) + ; B=[], + C=[] + ), + generate_attach_detach_a_constraint_all(D, E), + append([B, C, E], F). +generate_attach_a_constraint(A, [B, D]) :- + generate_attach_a_constraint_empty_list(A, B), + get_max_constraint_index(C), + ( C==1 + -> generate_attach_a_constraint_1_1(A, D) + ; generate_attach_a_constraint_t_p(A, D) + ). +generate_attach_a_constraint_empty_list(A/B, E) :- + atom_concat_list([attach_, A, /, B], C), + D=[[], _], + F=..[C|D], + E= (F:-true). +generate_attach_a_constraint_1_1(A/B, L) :- + atom_concat_list([attach_, A, /, B], C), + D=[[G|E], F], + M=..[C|D], + K=..[C, E, F], + get_target_module(H), + N= ((get_attr(G, H, I)->J=[F|I], put_attr(G, H, J);put_attr(G, H, [F])), K), + L= (M:-N). +generate_attach_a_constraint_t_p(A/B, Z) :- + atom_concat_list([attach_, A, /, B], C), + D=[[Q|E], F], + A1=..[C|D], + Y=..[C, E, F], + get_constraint_index(A/B, G), + or_pattern(G, P), + get_max_constraint_index(H), + make_attr(H, K, I, T), + nth1(G, I, J), + substitute_eq(J, I, [F|J], L), + make_attr(H, K, L, U), + substitute_eq(J, I, [F], M), + make_attr(H, V, M, W), + copy_term_nat(I, N), + nth1(G, N, [F]), + chr_delete(N, [F], O), + set_elems(O, []), + make_attr(H, P, N, X), + get_target_module(R), + B1= ((get_attr(Q, R, S)->S=T, (K/\P=:=P->put_attr(Q, R, U);V is K\/P, put_attr(Q, R, W));put_attr(Q, R, X)), Y), + Z= (A1:-B1). +generate_detach_a_constraint(A, [B, D]) :- + generate_detach_a_constraint_empty_list(A, B), + get_max_constraint_index(C), + ( C==1 + -> generate_detach_a_constraint_1_1(A, D) + ; generate_detach_a_constraint_t_p(A, D) + ). +generate_detach_a_constraint_empty_list(A/B, E) :- + atom_concat_list([detach_, A, /, B], C), + D=[[], _], + F=..[C|D], + E= (F:-true). +generate_detach_a_constraint_1_1(A/B, L) :- + atom_concat_list([detach_, A, /, B], C), + D=[[G|E], F], + M=..[C|D], + K=..[C, E, F], + get_target_module(H), + N= ((get_attr(G, H, I)->'chr sbag_del_element'(I, F, J), (J==[]->del_attr(G, H);put_attr(G, H, J));true), K), + L= (M:-N). +generate_detach_a_constraint_t_p(A/B, Y) :- + atom_concat_list([detach_, A, /, B], C), + D=[[N|E], F], + Z=..[C|D], + X=..[C, E, F], + get_constraint_index(A/B, G), + or_pattern(G, R), + and_pattern(G, U), + get_max_constraint_index(H), + make_attr(H, L, I, Q), + nth1(G, I, J), + substitute_eq(J, I, [], K), + make_attr(H, T, K, V), + substitute_eq(J, I, S, M), + make_attr(H, L, M, W), + get_target_module(O), + A1= ((get_attr(N, O, P)->P=Q, (L/\R=:=R->'chr sbag_del_element'(J, F, S), (S==[]->T is L/\U, (T==0->del_attr(N, O);put_attr(N, O, V));put_attr(N, O, W));true);true), X), + Y= (Z:-A1). +generate_attach_increment([A, C]) :- + generate_attach_increment_empty(A), + get_max_constraint_index(B), + ( B==1 + -> generate_attach_increment_one(C) + ; generate_attach_increment_many(B, C) + ). +generate_attach_increment_empty((attach_increment([], _):-true)). +generate_attach_increment_one(H) :- + I=attach_increment([A|G], D), + get_target_module(B), + J= ('chr not_locked'(A), (get_attr(A, B, C)->sort(C, E), merge(D, E, F), put_attr(A, B, F);put_attr(A, B, D)), attach_increment(G, D)), + H= (I:-J). +generate_attach_increment_many(A, Z) :- + make_attr(A, V, C, B), + make_attr(A, W, D, S), + A1=attach_increment([P|Y], B), + bagof(G, E^F^H^I^ (member2(C, D, E-F), G= (sort(F, H), 'chr merge_attributes'(E, H, I))), J), + list2conj(J, T), + bagof(N, K^L^M^member((K, 'chr merge_attributes'(L, M, N)), J), O), + make_attr(A, U, O, X), + get_target_module(Q), + B1= ('chr not_locked'(P), (get_attr(P, Q, R)->R=S, T, U is V\/W, put_attr(P, Q, X);put_attr(P, Q, B)), attach_increment(Y, B)), + Z= (A1:-B1). +generate_attr_unify_hook([B]) :- + get_max_constraint_index(A), + ( A==1 + -> generate_attr_unify_hook_one(B) + ; generate_attr_unify_hook_many(A, B) + ). +generate_attr_unify_hook_one(K) :- + L=A:attr_unify_hook(B, C), + get_target_module(A), + make_run_suspensions(G, H), + make_run_suspensions(B, J), + M= (sort(B, E), (var(C)-> (get_attr(C, A, D)->true;D=[]), sort(D, F), 'chr merge_attributes'(E, F, G), put_attr(C, A, G), H; (compound(C)->term_variables(C, I), attach_increment(I, E);true), J)), + K= (L:-M). +generate_attr_unify_hook_many(A, F1) :- + make_attr(A, Q, C, R), + make_attr(A, Z, H, W), + bagof(D, B^E^ (member(B, C), D=sort(B, E)), F), + list2conj(F, T), + bagof(E, B^member(sort(B, E), F), G), + bagof(K, I^J^L^M^ (member2(G, H, I-J), K= (sort(J, L), 'chr merge_attributes'(I, L, M))), O), + bagof(M, I^L^N^member((N, 'chr merge_attributes'(I, L, M)), O), P), + list2conj(O, X), + make_attr(A, Y, P, A1), + make_attr(A, Q, G, C1), + G1=S:attr_unify_hook(R, U), + get_target_module(S), + make_run_suspensions_loop(P, B1), + make_run_suspensions_loop(G, D1), + H1= (T, (var(U)-> (get_attr(U, S, V)->V=W, X, Y is Q\/Z, put_attr(U, S, A1), B1;put_attr(U, S, C1), D1); (compound(U)->term_variables(U, E1), attach_increment(E1, C1);true), D1)), + F1= (G1:-H1). +make_run_suspensions(B, A) :- + ( chr_pp_flag(debugable, on) + -> A='chr run_suspensions_d'(B) + ; A='chr run_suspensions'(B) + ). +make_run_suspensions_loop(B, A) :- + ( chr_pp_flag(debugable, on) + -> A='chr run_suspensions_loop_d'(B) + ; A='chr run_suspensions_loop'(B) + ). +check_attachments(A) :- + ( chr_pp_flag(check_attachments, on) + -> check_attachments_(A) + ; true + ). +check_attachments_([]). +check_attachments_([A|B]) :- + check_attachment(A), + check_attachments_(B). +check_attachment(A) :- + A=pragma(B, _, _, _), + B=rule(C, D, E, F), + check_attachment_heads1(C, C, D, E), + check_attachment_heads2(D, C, F). +check_attachment_heads1([], _, _, _). +check_attachment_heads1([A|H], B, C, D) :- + functor(A, F, G), + ( B==[A], + C==[], + D==true, + A=..[_|E], + no_matching(E, []) + -> attached(F/G, no) + ; attached(F/G, maybe) + ), + check_attachment_heads1(H, B, C, D). +no_matching([], _). +no_matching([A|C], B) :- + var(A), + \+memberchk_eq(A, B), + no_matching(C, [A|B]). +check_attachment_heads2([], _, _). +check_attachment_heads2([A|F], B, C) :- + functor(A, D, E), + ( B\==[], + C==true + -> attached(D/E, maybe) + ; attached(D/E, yes) + ), + check_attachment_heads2(F, B, C). +all_attached([]). +all_attached([A|D]) :- + functor(A, B, C), + is_attached(B/C), + all_attached(D). +set_constraint_indices([], A) :- + B is A-1, + max_constraint_index(B). +set_constraint_indices([A|C], B) :- + ( is_attached(A) + -> constraint_index(A, B), + D is B+1, + set_constraint_indices(C, D) + ; set_constraint_indices(C, B) + ). +constraints_code(A, B, D) :- + post_constraints(A, 1), + constraints_code1(1, B, C, []), + clean_clauses(C, D). +post_constraints([], A) :- + B is A-1, + constraint_count(B). +post_constraints([A/B|D], C) :- + constraint(A/B, C), + E is C+1, + post_constraints(D, E). +constraints_code1(A, E, D, C) :- + constraint_count(B), + ( A>B + -> C=D + ; constraint_code(A, E, D, G), + F is A+1, + constraints_code1(F, E, G, C) + ). +constraint_code(A, E, C, J) :- + constraint(B, A), + constraint_prelude(B, D), + C=[D|G], + F=[0], + rules_code(E, 1, A, F, H, G, I), + gen_cond_attach_clause(B, H, I, J). +constraint_prelude(B/A, E) :- + vars_susp(A, C, I, D), + F=..[B|C], + build_head(B, A, [0], D, H), + get_target_module(G), + ( chr_pp_flag(debugable, on) + -> E= (F:-'chr allocate_constraint'(G:H, I, B, C), ('chr debug_event'(call(I)), H;'chr debug_event'(fail(I)), !, fail), ('chr debug_event'(exit(I));'chr debug_event'(redo(I)), fail)) + ; E= (F:-H) + ). +gen_cond_attach_clause(A/B, C, K, M) :- + ( is_attached(A/B) + -> ( C==[0] + -> gen_cond_attach_goal(A/B, G, F, D, E) + ; vars_susp(B, D, E, F), + gen_uncond_attach_goal(A/B, E, G, _) + ), + ( chr_pp_flag(debugable, on) + -> H=..[A|D], + I='chr debug_event'(insert(#(H, E))) + ; I=true + ), + build_head(A, B, C, F, J), + L= (J:-I, G), + K=[L|M] + ; K=M + ). +gen_cond_attach_goal(E/A, G, D, B, C) :- + vars_susp(A, B, C, D), + build_head(E, A, [0], D, J), + atom_concat_list([attach_, E, /, A], F), + K=..[F, H, C], + get_target_module(I), + G= ((var(C)->'chr insert_constraint_internal'(H, C, I:J, E, B);'chr activate_constraint'(H, C, _)), K). +gen_uncond_attach_goal(A/B, D, E, G) :- + atom_concat_list([attach_, A, /, B], C), + H=..[C, F, D], + E= ('chr activate_constraint'(F, D, G), H). +rules_code([], _, _, A, A, B, B). +rules_code([A|F], B, C, D, I, E, K) :- + rule_code(A, B, C, D, H, E, J), + G is B+1, + rules_code(F, G, C, H, I, J, K). +rule_code(A, K, F, G, L, H, N) :- + A=pragma(C, B, _, _), + B=ids(E, J), + C=rule(D, I, _, _), + heads1_code(D, [], E, [], A, F, G, H, M), + heads2_code(I, [], J, [], A, K, F, G, L, M, N). +heads1_code([], _, _, _, _, _, _, A, A). +heads1_code([C|J], F, [H|L], M, A, B, P, Q, S) :- + A=pragma(G, _, I, _), + constraint(D/E, B), + ( functor(C, D, E), + \+check_unnecessary_active(C, F, G), + \+memberchk_eq(passive(H), I), + all_attached(J), + all_attached(F), + G=rule(_, K, _, _), + all_attached(K) + -> append(J, F, N), + append(L, M, O), + head1_code(C, N, O, A, D/E, B, P, Q, R) + ; Q=R + ), + heads1_code(J, [C|F], L, [H|M], A, B, P, R, S). +head1_code(D, E, F, A, I, _, J, K, L) :- + A=pragma(B, _, _, _), + B=rule(_, C, _, _), + ( C==[] + -> reorder_heads(D, E, F, G, H), + simplification_code(D, G, H, A, I, J, K, L) + ; simpagation_head1_code(D, E, F, A, I, J, K, L) + ). +heads2_code([], _, _, _, _, _, _, A, A, B, B). +heads2_code([C|J], F, [H|L], M, A, P, B, R, W, S, X) :- + A=pragma(G, _, I, _), + constraint(D/E, B), + ( functor(C, D, E), + \+check_unnecessary_active(C, F, G), + \+memberchk_eq(passive(H), I), + \+set_semantics_rule(A), + all_attached(J), + all_attached(F), + G=rule(K, _, _, _), + all_attached(K) + -> append(J, F, N), + append(L, M, O), + length(J, Q), + head2_code(C, N, O, A, P, Q, D/E, R, S, T), + inc_id(R, V), + gen_alloc_inc_clause(D/E, R, T, U) + ; S=U, + V=R + ), + heads2_code(J, [C|F], L, [H|M], A, P, B, V, W, U, X). +head2_code(D, E, M, A, G, H, I, J, K, L) :- + A=pragma(B, _, _, _), + B=rule(C, _, _, _), + ( C==[] + -> reorder_heads(D, E, F), + propagation_code(D, F, B, G, H, I, J, K, L) + ; simpagation_head2_code(D, E, M, A, I, J, K, L) + ). +gen_alloc_inc_clause(B/A, C, K, M) :- + vars_susp(A, F, G, D), + build_head(B, A, C, D, I), + inc_id(C, E), + build_head(B, A, E, D, J), + ( C==[0] + -> gen_cond_allocation(F, G, B/A, D, H) + ; H=true + ), + L= (I:-H, J), + K=[L|M]. +gen_cond_allocation(H, E, A/B, C, D) :- + build_head(A, B, [0], C, G), + get_target_module(F), + D= (var(E)->'chr allocate_constraint'(F:G, E, A, H);true). +guard_via_reschedule(A, B, C, D) :- + ( chr_pp_flag(guard_via_reschedule, on) + -> guard_via_reschedule_main(A, B, C, D) + ; append(A, B, E), + list2conj(E, D) + ). +guard_via_reschedule_main(B, C, A, G) :- + initialize_unit_dictionary(A, D), + build_units(B, C, D, E), + dependency_reorder(E, F), + units2goal(F, G). +units2goal([], true). +units2goal([unit(_, A, _, _)|B], (A, C)) :- + units2goal(B, C). +dependency_reorder(A, B) :- + dependency_reorder(A, [], B). +dependency_reorder([], A, B) :- + reverse(A, B). +dependency_reorder([A|F], C, G) :- + A=unit(_, _, B, D), + ( B==fixed + -> E=[A|C] + ; dependency_insert(C, A, D, E) + ), + dependency_reorder(F, E, G). +dependency_insert([], A, _, [A]). +dependency_insert([A|F], E, C, D) :- + A=unit(B, _, _, _), + ( memberchk(B, C) + -> D=[E, A|F] + ; D=[A|G], + dependency_insert(F, E, C, G) + ). +build_units(A, D, B, C) :- + build_retrieval_units(A, 1, E, B, F, C, G), + build_guard_units(D, E, F, G). +build_retrieval_units([], A, A, B, B, C, C). +build_retrieval_units([A|G], C, I, D, K, E, M) :- + term_variables(A, B), + update_unit_dictionary(B, C, D, J, [], F), + E=[unit(C, A, movable, F)|L], + H is C+1, + build_retrieval_units2(G, H, I, J, K, L, M). +build_retrieval_units2([], A, A, B, B, C, C). +build_retrieval_units2([A|G], C, I, D, K, E, M) :- + term_variables(A, B), + update_unit_dictionary(B, C, D, J, [], F), + E=[unit(C, A, fixed, F)|L], + H is C+1, + build_retrieval_units(G, H, I, J, K, L, M). +initialize_unit_dictionary(A, C) :- + term_variables(A, B), + pair_all_with(B, 0, C). +update_unit_dictionary([], _, A, A, B, B). +update_unit_dictionary([B|H], D, A, I, E, J) :- + ( lookup_eq(A, B, C) + -> ( ( C==D + ; memberchk(C, E) + ) + -> F=E + ; F=[C|E] + ), + G=A + ; G=[B-D|A], + F=E + ), + update_unit_dictionary(H, D, G, I, F, J). +build_guard_units(A, C, F, B) :- + ( A=[D] + -> B=[unit(C, D, fixed, [])] + ; A=[D|H] + -> term_variables(D, E), + update_unit_dictionary2(E, C, F, J, [], G), + B=[unit(C, D, movable, G)|K], + I is C+1, + build_guard_units(H, I, J, K) + ). +update_unit_dictionary2([], _, A, A, B, B). +update_unit_dictionary2([B|H], D, A, I, E, J) :- + ( lookup_eq(A, B, C) + -> ( ( C==D + ; memberchk(C, E) + ) + -> F=E + ; F=[C|E] + ), + G=[B-D|A] + ; G=[B-D|A], + F=E + ), + update_unit_dictionary2(H, D, G, I, F, J). +unique_analyse_optimise(A, B) :- + ( chr_pp_flag(unique_analyse_optimise, on) + -> unique_analyse_optimise_main(A, 1, [], B) + ; B=A + ). +unique_analyse_optimise_main([], _, _, []). +unique_analyse_optimise_main([A|R], B, D, [O|T]) :- + ( discover_unique_pattern(A, B, C) + -> E=[C|D] + ; E=D + ), + A=pragma(F, G, N, Q), + F=rule(H, J, _, _), + G=ids(I, K), + apply_unique_patterns_to_constraints(H, I, E, L), + apply_unique_patterns_to_constraints(J, K, E, M), + append([L, M, N], P), + O=pragma(F, G, P, Q), + S is B+1, + unique_analyse_optimise_main(R, S, E, T). +apply_unique_patterns_to_constraints([], _, _, []). +apply_unique_patterns_to_constraints([B|H], [C|I], A, E) :- + ( member(D, A), + apply_unique_pattern(B, C, D, F) + -> E=[F|G] + ; E=G + ), + apply_unique_patterns_to_constraints(H, I, A, G). +apply_unique_pattern(B, L, A, K) :- + A=unique(C, E), + subsumes(B, C, F), + ( setof(I, D^G^H^ (member(D, E), lookup_eq(F, D, G), term_variables(G, H), member(I, H)), J) + -> true + ; J=[] + ), + K=unique(L, J). +subsumes(A, B, F) :- + empty_ds(C), + subsumes_aux(A, B, C, D), + ds_to_list(D, E), + build_unifier(E, F). +subsumes_aux(B, A, E, F) :- + ( compound(A), + functor(A, C, D) + -> compound(B), + functor(B, C, D), + subsumes_aux(D, B, A, E, F) + ; B==A + -> F=E + ; var(A), + get_ds(B, E, G) + -> G==A, + F=E + ; var(A), + put_ds(B, E, A, F) + ). +subsumes_aux(0, _, _, A, A) :- !. +subsumes_aux(A, B, C, F, I) :- + arg(A, B, D), + arg(A, C, E), + subsumes_aux(D, E, F, H), + G is A-1, + subsumes_aux(G, B, C, H, I). +build_unifier([], []). +build_unifier([B-A|C], [A-B|D]) :- + build_unifier(C, D). +discover_unique_pattern(A, M, L) :- + A=pragma(B, _, G, N), + ( B=rule([C], [D], E, F) + -> true + ; B=rule([C, D], [], E, F) + ), + check_unique_constraints(C, D, E, F, G, H), + term_variables(C, I), + select_pragma_unique_variables(H, I, J), + K=unique(C, J), + copy_term_nat(K, L), + ( verbosity_on + -> format('Found unique pattern ~w in rule ~d~@\n', [L, M, (N=yes(O)->write([58, 32]), write(O);true)]) + ; true + ). +select_pragma_unique_variables([], _, []). +select_pragma_unique_variables([A-B|F], D, C) :- + ( A==B + -> C=[A|E] + ; once(( + ( \+memberchk_eq(A, D) + ; \+memberchk_eq(B, D) + ) + )), + C=E + ), + select_pragma_unique_variables(F, D, E). +check_unique_constraints(B, C, E, _, A, D) :- + \+member(passive(_), A), + variable_replacement(B-C, C-B, D), + copy_with_variable_replacement(E, G, D), + negate(E, F), + once(entails(F, G)). +negate(true, fail). +negate(fail, true). +negate(B=A, A>=B). +negate(B>=A, A>B). +negate(BD, A>=C) :- + A==B, + C==D. +entails(B check_unnecessary_active_main(A, B, C) + ; chr_pp_flag(check_unnecessary_active, simplification), + C=rule(_, [], _, _) + -> check_unnecessary_active_main(A, B, C) + ; fail + ). +check_unnecessary_active_main(C, A, D) :- + member(B, A), + variable_replacement(B, C, E), + copy_with_variable_replacement(D, F, E), + identical_rules(D, F), !. +set_semantics_rule(A) :- + ( chr_pp_flag(set_semantics_rule, on) + -> set_semantics_rule_main(A) + ; fail + ). +set_semantics_rule_main(A) :- + A=pragma(B, C, E, _), + B=rule([_], [_], true, _), + C=ids([D], [F]), + once(member(unique(D, G), E)), + once(member(unique(F, H), E)), + G==H, + \+memberchk_eq(passive(D), E). +identical_rules(rule(E, H, A, C), rule(G, J, B, D)) :- + A==B, + identical_bodies(C, D), + permutation(E, F), + F==G, + permutation(H, I), + I==J. +identical_bodies(A, B) :- + ( A= (C=E), + B= (D=F) + -> ( C==D, + E==F + ; C==F, + D==E + ), ! + ; A==B + ). +copy_with_variable_replacement(A, C, B) :- + ( var(A) + -> ( lookup_eq(B, A, C) + -> true + ; A=C + ) + ; functor(A, D, E), + functor(C, D, E), + A=..[_|F], + C=..[_|G], + copy_with_variable_replacement_l(F, G, B) + ). +copy_with_variable_replacement_l([], [], _). +copy_with_variable_replacement_l([A|D], [B|E], C) :- + copy_with_variable_replacement(A, B, C), + copy_with_variable_replacement_l(D, E, C). +variable_replacement(A, B, C) :- + variable_replacement(A, B, [], C). +variable_replacement(A, B, C, E) :- + ( var(A) + -> var(B), + ( lookup_eq(C, A, D) + -> D==B, + E=C + ; E=[A-B|C] + ) + ; A=..[F|G], + nonvar(B), + B=..[F|H], + variable_replacement_l(G, H, C, E) + ). +variable_replacement_l([], [], A, A). +variable_replacement_l([A|D], [B|E], C, G) :- + variable_replacement(A, B, C, F), + variable_replacement_l(D, E, F, G). +simplification_code(B, H, J, A, D/C, E, E1, G1) :- + A=pragma(O, _, K, _), + head_info(B, C, _, S, F, G), + build_head(D, C, E, F, Q), + head_arg_matches(G, [], R, I), + ( H==[] + -> M=[], + N=I, + L=[] + ; rest_heads_retrieval_and_matching(H, J, K, B, L, M, I, N) + ), + guard_body_copies2(O, N, P, D1), + guard_via_reschedule(L, P, Q-R, A1), + gen_uncond_susps_detachments(M, H, B1), + gen_cond_susp_detachment(S, D/C, C1), + ( chr_pp_flag(debugable, on) + -> O=rule(_, _, T, U), + my_term_copy(T-U, N, _, V-W), + Y='chr debug_event'(try([S|X], [], V, W)), + Z='chr debug_event'(apply([S|X], [], V, W)) + ; Y=true, + Z=true + ), + F1= (Q:-R, A1, Y, !, Z, B1, C1, D1), + E1=[F1|G1]. +head_arg_matches(A, B, E, C) :- + head_arg_matches_(A, B, D, C), + list2conj(D, E). +head_arg_matches_([], A, [], A). +head_arg_matches_([A-D|H], B, C, P) :- + ( var(A) + -> ( lookup_eq(B, A, E) + -> C=[D==E|G], + F=B + ; F=[A-D|B], + C=G + ), + I=H + ; atomic(A) + -> C=[D==A|G], + B=F, + I=H + ; A=..[_|M], + functor(A, J, K), + functor(L, J, K), + L=..[_|N], + C=[nonvar(D), D=L|G], + pairup(M, N, O), + append(O, H, I), + F=B + ), + head_arg_matches_(I, F, G, P). +rest_heads_retrieval_and_matching(A, B, C, D, E, F, G, H) :- + rest_heads_retrieval_and_matching(A, B, C, D, E, F, G, H, [], [], []). +rest_heads_retrieval_and_matching(A, B, C, F, G, H, I, J, D, E, K) :- + ( A=[_|_] + -> rest_heads_retrieval_and_matching_n(A, B, C, D, E, F, G, H, I, J, K) + ; G=[], + H=[], + I=J + ). +rest_heads_retrieval_and_matching_n([], _, _, _, _, _, [], [], A, A, B) :- + instantiate_pattern_goals(B). +rest_heads_retrieval_and_matching_n([A|B1], [W|C1], X, C, Q, B, [F, Z|D1], [P|E1], E, G1, D) :- + passive_head_via(A, [B|C], D, E, F, K, H1), + functor(A, L, G), + head_info(A, G, I, _, _, H), + head_arg_matches(H, E, V, F1), + S=..[suspension, _, R, _, _, _, _|I], + get_max_constraint_index(J), + ( J==1 + -> O=K + ; get_constraint_index(L/G, M), + make_attr(J, _, N, K), + nth1(M, N, O) + ), + different_from_other_susps(A, P, C, Q, U), + create_get_mutable_ref(active, R, T), + A1= ('chr sbag_member'(P, O), P=S, T, U, V), + ( member(unique(W, Y), X), + check_unique_keys(Y, E) + -> Z= (A1->true) + ; Z=A1 + ), + rest_heads_retrieval_and_matching_n(B1, C1, X, [A|C], [P|Q], B, D1, E1, F1, G1, H1). +instantiate_pattern_goals([]). +instantiate_pattern_goals([_-attr(C, D, B)|G]) :- + get_max_constraint_index(A), + ( A==1 + -> B=true + ; make_attr(A, E, _, C), + or_list(D, F), !, + B= (E/\F=:=F) + ), + instantiate_pattern_goals(G). +check_unique_keys([], _). +check_unique_keys([B|C], A) :- + lookup_eq(A, B, _), + check_unique_keys(C, A). +different_from_other_susps(C, G, B, E, J) :- + ( bagof(F, A^ (nth1(A, B, D), \+C\=D, nth1(A, E, H), F= (G\==H)), I) + -> list2conj(I, J) + ; J=true + ). +passive_head_via(A, D, I, F, O, K, N) :- + functor(A, B, C), + get_constraint_index(B/C, G), + common_variables(A, D, E), + translate(E, F, H), + or_pattern(G, L), + ( permutation(H, J), + lookup_eq(I, J, attr(K, M, _)) + -> member(L, M), !, + N=I, + O=true + ; O= (P, Q), + gen_get_mod_constraints(H, P, K), + N=[H-attr(K, [L|_], Q)|I] + ). +common_variables(A, B, E) :- + term_variables(A, C), + term_variables(B, D), + intersect_eq(C, D, E). +gen_get_mod_constraints(A, B, F) :- + get_target_module(D), + ( A==[] + -> B= ('chr default_store'(C), get_attr(C, D, E), E=F) + ; ( A=[G] + -> H='chr via_1'(G, J) + ; A=[G, I] + -> H='chr via_2'(G, I, J) + ; H='chr via'(A, J) + ), + B= (H, get_attr(J, D, E), E=F) + ). +guard_body_copies(A, B, E, C) :- + guard_body_copies2(A, B, D, C), + list2conj(D, E). +guard_body_copies2(A, D, H, W) :- + A=rule(_, _, B, U), + conj2list(B, C), + split_off_simple_guard(C, D, E, F), + my_term_copy(E-F, D, V, G-I), + append(G, [Q], H), + term_variables(F, L), + term_variables(I, M), + ( chr_pp_flag(guard_locks, on), + bagof('chr lock'(J)-'chr unlock'(J), K^ (member(K, L), lookup_eq(D, K, J), memberchk_eq(J, M)), N) + -> once(pairup(O, P, N)) + ; O=[], + P=[] + ), + list2conj(O, R), + list2conj(P, T), + list2conj(I, S), + Q= (R, S, T), + my_term_copy(U, V, W). +split_off_simple_guard([], _, [], []). +split_off_simple_guard([A|D], B, C, F) :- + ( simple_guard(A, B) + -> C=[A|E], + split_off_simple_guard(D, B, E, F) + ; C=[], + F=[A|D] + ). +simple_guard(var(_), _). +simple_guard(nonvar(_), _). +simple_guard(ground(_), _). +simple_guard(number(_), _). +simple_guard(atom(_), _). +simple_guard(integer(_), _). +simple_guard(float(_), _). +simple_guard(_>_, _). +simple_guard(_<_, _). +simple_guard(_=<_, _). +simple_guard(_>=_, _). +simple_guard(_=:=_, _). +simple_guard(_==_, _). +simple_guard(B is _, A) :- + \+lookup_eq(A, B, _). +simple_guard((A, C), B) :- + simple_guard(A, B), + simple_guard(C, B). +simple_guard(\+A, B) :- + simple_guard(A, B). +my_term_copy(A, B, C) :- + my_term_copy(A, B, _, C). +my_term_copy(A, B, D, C) :- + ( var(A) + -> ( lookup_eq(B, A, C) + -> D=B + ; D=[A-C|B] + ) + ; functor(A, E, F), + functor(C, E, F), + A=..[_|G], + C=..[_|H], + my_term_copy_list(G, B, D, H) + ). +my_term_copy_list([], A, A, []). +my_term_copy_list([A|D], B, F, [C|G]) :- + my_term_copy(A, B, E, C), + my_term_copy_list(D, E, F, G). +gen_cond_susp_detachment(B, A, C) :- + ( is_attached(A) + -> gen_uncond_susp_detachment(B, A, D), + C= (var(B)->true;D) + ; C=true + ). +gen_uncond_susp_detachment(D, A/B, F) :- + ( is_attached(A/B) + -> atom_concat_list([detach_, A, /, B], C), + H=..[C, G, D], + ( chr_pp_flag(debugable, on) + -> E='chr debug_event'(remove(D)) + ; E=true + ), + F= (E, 'chr remove_constraint_internal'(D, G), H) + ; F=true + ). +gen_uncond_susps_detachments([], [], true). +gen_uncond_susps_detachments([B|F], [A|G], (E, H)) :- + functor(A, C, D), + gen_uncond_susp_detachment(B, C/D, E), + gen_uncond_susps_detachments(F, G, H). +simpagation_head1_code(C, I, K, A, F/D, G, L1, N1) :- + A=pragma(B, ids(_, L), Q, _), + B=rule(_, J, A1, B1), + head_info(C, D, _, Z, H, E), + head_arg_matches(E, [], X, R), + build_head(F, D, G, H, W), + append(I, J, M), + append(K, L, N), + reorder_heads(C, M, N, O, P), + rest_heads_retrieval_and_matching(O, P, Q, C, U, S, R, T), + split_by_ids(P, S, K, Y, C1), + guard_body_copies2(B, T, V, K1), + guard_via_reschedule(U, V, W-X, H1), + gen_uncond_susps_detachments(Y, I, I1), + gen_cond_susp_detachment(Z, F/D, J1), + ( chr_pp_flag(debugable, on) + -> my_term_copy(A1-B1, T, _, D1-E1), + F1='chr debug_event'(try([Z|Y], C1, D1, E1)), + G1='chr debug_event'(apply([Z|Y], C1, D1, E1)) + ; F1=true, + G1=true + ), + M1= (W:-X, H1, F1, !, G1, I1, J1, K1), + L1=[M1|N1]. +split_by_ids([], [], _, [], []). +split_by_ids([A|H], [D|I], B, C, E) :- + ( memberchk_eq(A, B) + -> C=[D|F], + E=G + ; C=F, + E=[D|G] + ), + split_by_ids(H, I, B, F, G). +simpagation_head2_code(C, G, P, A, J, K, L, T) :- + A=pragma(B, ids(E, _), Q, _), + B=rule(D, _, H, I), + reorder_heads(C, D, E, [F|N], [M|O]), + simpagation_head2_prelude(C, F, [G, D, H, I], J, K, L, S), + extend_id(K, R), + simpagation_head2_worker(C, F, M, N, O, G, P, B, Q, J, R, S, T). +simpagation_head2_prelude(A, G, T, C/B, D, B1, D1) :- + head_info(A, B, Q, R, E, F), + build_head(C, B, D, E, X), + head_arg_matches(F, [], Y, H), + passive_head_via(G, [A], [], H, Z, K, I), + instantiate_pattern_goals(I), + get_max_constraint_index(J), + ( J==1 + -> P=K + ; functor(G, L, M), + get_constraint_index(L/M, N), + make_attr(J, _, O, K), + nth1(N, O, P) + ), + ( D==[0] + -> gen_cond_allocation(Q, R, C/B, E, S) + ; S=true + ), + extend_id(D, V), + extra_active_delegate_variables(A, T, H, U), + append([P|E], U, W), + build_head(C, B, V, W, A1), + C1= (X:-Y, Z, !, S, A1), + B1=[C1|D1]. +extra_active_delegate_variables(A, B, C, E) :- + A=..[_|D], + delegate_variables(A, B, C, D, E). +passive_delegate_variables(B, A, C, D, F) :- + term_variables(A, E), + delegate_variables(B, C, D, E, F). +delegate_variables(A, B, H, F, I) :- + term_variables(A, C), + term_variables(B, D), + intersect_eq(C, D, E), + list_difference_eq(E, F, G), + translate(G, H, I). +simpagation_head2_worker(B, C, K, D, L, E, M, A, N, H, I, J, P) :- + A=rule(_, _, F, G), + simpagation_head2_worker_end(B, [C, D, E, F, G], H, I, J, O), + simpagation_head2_worker_body(B, C, K, D, L, E, M, A, N, H, I, O, P). +simpagation_head2_worker_body(A, E, C2, F, X, G, Y, D, D1, O/B, P, H2, I2) :- + gen_var(K), + gen_var(L), + head_info(A, B, _, R1, M, C), + head_arg_matches(C, [], _, J), + D=rule(_, _, H, I), + extra_active_delegate_variables(A, [E, F, G, H, I], J, N), + append([[K|L]|M], N, Q), + build_head(O, B, P, Q, N1), + functor(E, _, R), + head_info(E, R, T, _, _, S), + head_arg_matches(S, J, P1, E1), + V=..[suspension, _, U, _, _, _, _|T], + create_get_mutable_ref(active, U, W), + O1= (K=V, W), + ( ( F\==[] + ; G\==[] + ) + -> append(F, G, Z), + append(X, Y, A1), + reorder_heads(E-A, Z, A1, B1, C1), + rest_heads_retrieval_and_matching(B1, C1, D1, [E, A], G1, F1, E1, J1, [E], [K], []), + split_by_ids(C1, F1, X, H1, I1) + ; G1=[], + H1=[], + I1=[], + J1=E1 + ), + gen_uncond_susps_detachments([K|H1], [E|F], F2), + append([L|M], N, K1), + build_head(O, B, P, K1, S1), + append([[]|M], N, L1), + build_head(O, B, P, L1, U1), + guard_body_copies2(D, J1, M1, Q1), + guard_via_reschedule(G1, M1, v(N1, O1, P1), E2), + ( Q1\==true + -> gen_uncond_attach_goal(O/B, R1, V1, T1), + gen_state_cond_call(R1, B, S1, T1, W1), + gen_state_cond_call(R1, B, U1, T1, X1) + ; V1=true, + W1=S1, + X1=U1 + ), + ( chr_pp_flag(debugable, on) + -> my_term_copy(H-I, J1, _, Y1-Z1), + A2='chr debug_event'(try([K|H1], [R1|I1], Y1, Z1)), + B2='chr debug_event'(apply([K|H1], [R1|I1], Y1, Z1)) + ; A2=true, + B2=true + ), + ( member(unique(C2, D2), D1), + check_unique_keys(D2, J) + -> G2= (N1:-O1, P1-> (E2, A2->B2, F2, V1, Q1, X1;U1);S1) + ; G2= (N1:-O1, P1, E2, A2->B2, F2, V1, Q1, W1;S1) + ), + H2=[G2|I2]. +gen_state_cond_call(G, A, K, D, F) :- + length(B, A), + H=..[suspension, _, C, _, E, _, _|B], + create_get_mutable_ref(active, C, I), + create_get_mutable_ref(D, E, J), + F= (G=H, I, J->'chr update_mutable'(inactive, C), K;true). +simpagation_head2_worker_end(A, D, H/B, I, N, P) :- + head_info(A, B, _, _, F, C), + head_arg_matches(C, [], _, E), + extra_active_delegate_variables(A, D, E, G), + append([[]|F], G, J), + build_head(H, B, I, J, L), + next_id(I, K), + build_head(H, B, K, F, M), + O= (L:-M), + N=[O|P]. +propagation_code(B, A, C, D, I, E, F, G, H) :- + ( A==[] + -> propagation_single_headed(B, C, D, E, F, G, H) + ; propagation_multi_headed(B, A, C, D, I, E, F, G, H) + ). +propagation_single_headed(A, I, Y, C/B, D, D1, F1) :- + head_info(A, B, K, L, E, H), + build_head(C, B, D, E, W), + inc_id(D, F), + build_head(C, B, F, E, G), + O=G, + head_arg_matches(H, [], X, J), + guard_body_copies(I, J, Z, B1), + ( D==[0] + -> gen_cond_allocation(K, L, C/B, E, M), + N=M + ; N=true + ), + gen_uncond_attach_goal(C/B, L, A1, P), + gen_state_cond_call(L, B, O, P, C1), + ( chr_pp_flag(debugable, on) + -> I=rule(_, _, Q, R), + my_term_copy(Q-R, J, _, S-T), + U='chr debug_event'(try([], [L], S, T)), + V='chr debug_event'(apply([], [L], S, T)) + ; U=true, + V=true + ), + E1= (W:-X, N, 'chr novel_production'(L, Y), Z, U, !, V, 'chr extend_history'(L, Y), A1, B1, C1), + D1=[E1|F1]. +propagation_multi_headed(B, A, C, I, J, D, E, F, M) :- + A=[H|G], + propagation_prelude(B, A, C, D, E, F, L), + extend_id(E, K), + propagation_nested_code(G, [H, B], C, I, J, D, K, L, M). +propagation_prelude(A, [H|I], G, C/B, D, F1, H1) :- + head_info(A, B, U, V, E, F), + build_head(C, B, D, E, B1), + head_arg_matches(F, [], C1, L), + G=rule(_, _, J, K), + extra_active_delegate_variables(A, [H, I, J, K], L, X), + passive_head_via(H, [A], [], L, D1, O, M), + instantiate_pattern_goals(M), + get_max_constraint_index(N), + ( N==1 + -> T=O + ; functor(H, P, Q), + make_attr(N, _, S, O), + get_constraint_index(P/Q, R), + nth1(R, S, T) + ), + ( D==[0] + -> gen_cond_allocation(U, V, C/B, E, W) + ; W=true + ), + extend_id(D, Y), + append([T|E], X, Z), + build_head(C, B, Y, Z, A1), + E1=A1, + G1= (B1:-C1, D1, !, W, E1), + F1=[G1|H1]. +propagation_nested_code([], [A|B], C, G, H, D, E, F, J) :- + propagation_end([A|B], [], C, D, E, F, I), + propagation_body(A, B, C, G, H, D, E, I, J). +propagation_nested_code([B|C], A, D, I, J, E, F, G, M) :- + propagation_end(A, [B|C], D, E, F, G, H), + propagation_accumulator([B|C], A, D, E, F, H, L), + inc_id(F, K), + propagation_nested_code(C, [B|A], D, I, J, E, K, L, M). +propagation_body(C, B, A, G1, B1, N/O, P, W1, Y1) :- + A=rule(_, _, D, E), + get_prop_inner_loop_vars(B, [C, D, E], M, V, Y, W), + gen_var(I), + gen_var(L), + functor(C, _, F), + gen_vars(F, G), + J=..[suspension, _, H, _, _, _, _|G], + create_get_mutable_ref(active, H, K), + M1= (I=J, K), + Q=[[I|L]|M], + build_head(N, O, P, Q, L1), + R=[L|M], + build_head(N, O, P, R, S), + Z=S, + C=..[_|T], + pairup(T, G, U), + head_arg_matches(U, V, O1, X), + different_from_other_susps(C, I, B, W, N1), + guard_body_copies(A, X, S1, U1), + gen_uncond_attach_goal(N/O, Y, T1, A1), + gen_state_cond_call(Y, O, Z, A1, V1), + history_susps(B1, [I|W], Y, [], D1), + bagof('chr novel_production'(C1, E1), (member(C1, D1), E1=P1), F1), + list2conj(F1, R1), + Q1=..[t, G1|D1], + ( chr_pp_flag(debugable, on) + -> A=rule(_, _, D, E), + my_term_copy(D-E, X, _, H1-I1), + J1='chr debug_event'(try([], [Y, I|W], H1, I1)), + K1='chr debug_event'(apply([], [Y, I|W], H1, I1)) + ; J1=true, + K1=true + ), + X1= (L1:-M1, N1, O1, P1=Q1, R1, S1, J1->K1, 'chr extend_history'(Y, P1), T1, U1, V1;Z), + W1=[X1|Y1]. +history_susps(A, B, D, E, F) :- + ( A==0 + -> reverse(B, C), + append(C, [D|E], F) + ; B=[I|H], + G is A-1, + history_susps(G, H, D, [I|E], F) + ). +get_prop_inner_loop_vars([A], F, I, E, C, []) :- !, + functor(A, _, B), + head_info(A, B, _, C, G, D), + head_arg_matches(D, [], _, E), + extra_active_delegate_variables(A, F, E, H), + append(G, H, I). +get_prop_inner_loop_vars([B|A], C, N, J, D, [G|E]) :- + get_prop_inner_loop_vars(A, [B|C], M, I, D, E), + functor(B, _, F), + gen_var(L), + head_info(B, F, _, G, _, H), + head_arg_matches(H, I, _, J), + passive_delegate_variables(B, A, C, J, K), + append(K, [G, L|M], N). +propagation_end([C|B], D, A, H/I, J, S, U) :- + A=rule(_, _, E, F), + gen_var_susp_list_for(B, [C, D, E, F], _, G, L, O), + K=[[]|G], + build_head(H, I, J, K, Q), + ( J=[0|_] + -> next_id(J, M), + N=L + ; dec_id(J, M), + N=[O|L] + ), + build_head(H, I, M, N, P), + R=P, + T= (Q:-R), + S=[T|U]. +gen_var_susp_list_for([A], G, F, I, D, C) :- !, + functor(A, _, B), + head_info(A, B, _, C, D, E), + head_arg_matches(E, [], _, F), + extra_active_delegate_variables(A, G, F, H), + append(D, H, I). +gen_var_susp_list_for([B|A], C, I, L, D, E) :- + gen_var_susp_list_for(A, [B|C], H, D, _, _), + functor(B, _, F), + gen_var(E), + head_info(B, F, _, K, _, G), + head_arg_matches(G, H, _, I), + passive_delegate_variables(B, A, C, I, J), + append(J, [K, E|D], L). +propagation_accumulator([D|E], [C|B], A, E1/F1, B1, Q1, S1) :- + A=rule(_, _, F, G), + pre_vars_and_susps(B, [C, D, E, F, G], D1, K, M), + gen_var(C1), + functor(C, _, H), + gen_vars(H, I), + head_info(C, H, I, L, _, J), + head_arg_matches(J, K, R, S), + O=..[suspension, _, N, _, _, _, _|I], + different_from_other_susps(C, L, B, M, Q), + create_get_mutable_ref(active, N, P), + M1= (L=O, P, Q, R), + functor(D, W, X), + passive_head_via(D, [C|B], [], S, N1, V, T), + instantiate_pattern_goals(T), + get_max_constraint_index(U), + ( U==1 + -> A1=V + ; get_constraint_index(W/X, Y), + make_attr(U, _, Z, V), + nth1(Y, Z, A1) + ), + inc_id(B1, I1), + G1=[[L|C1]|D1], + build_head(E1, F1, B1, G1, L1), + passive_delegate_variables(C, B, [D, E, F, G], S, H1), + append([A1|H1], [L, C1|D1], J1), + build_head(E1, F1, I1, J1, O1), + K1=[C1|D1], + build_head(E1, F1, B1, K1, P1), + R1= (L1:-M1, N1->O1;P1), + Q1=[R1|S1]. +pre_vars_and_susps([A], E, H, D, []) :- !, + functor(A, _, B), + head_info(A, B, _, _, F, C), + head_arg_matches(C, [], _, D), + extra_active_delegate_variables(A, E, D, G), + append(F, G, H). +pre_vars_and_susps([B|A], C, M, I, [F|D]) :- + pre_vars_and_susps(A, [B|C], L, H, D), + functor(B, _, E), + gen_var(K), + head_info(B, E, _, F, _, G), + head_arg_matches(G, H, _, I), + passive_delegate_variables(B, A, C, I, J), + append(J, [F, K|L], M). +reorder_heads(A, B, C, D, E) :- + ( chr_pp_flag(reorder_heads, on) + -> reorder_heads_main(A, B, C, D, E) + ; D=B, + E=C + ). +reorder_heads_main(A, B, C, E, F) :- + term_variables(A, D), + reorder_heads1(B, C, D, E, F). +reorder_heads1(A, D, E, B, C) :- + ( A==[] + -> B=[], + C=[] + ; B=[F|K], + C=[G|L], + select_best_head(A, D, E, F, G, H, I, J), + reorder_heads1(H, I, J, K, L) + ). +select_best_head(C, D, G, J, K, L, M, Q) :- + ( bagof(tuple(H, A, B, E, F), (select2(A, B, C, D, E, F), order_score(A, G, E, H)), I) + -> true + ; I=[] + ), + max_go_list(I, tuple(_, J, K, L, M)), + term_variables(J, O), + ( setof(N, (member(N, O), \+memberchk_eq(N, G)), P) + -> true + ; P=[] + ), + append(P, G, Q). +reorder_heads(A, B, D) :- + term_variables(A, C), + reorder_heads1(B, C, D). +reorder_heads1(A, C, B) :- + ( A==[] + -> B=[] + ; B=[D|G], + select_best_head(A, C, D, E, F), + reorder_heads1(E, F, G) + ). +select_best_head(B, D, G, H, L) :- + ( bagof(tuple(E, A, C), (select(A, B, C), order_score(A, D, C, E)), F) + -> true + ; F=[] + ), + max_go_list(F, tuple(_, G, H)), + term_variables(G, J), + ( setof(I, (member(I, J), \+memberchk_eq(I, D)), K) + -> true + ; K=[] + ), + append(K, D, L). +order_score(A, D, B, F) :- + term_variables(A, C), + term_variables(B, E), + order_score_vars(C, D, E, 0, F). +order_score_vars([], _, _, A, B) :- + ( A==0 + -> B=99999 + ; B=A + ). +order_score_vars([A|F], B, D, C, G) :- + ( memberchk_eq(A, B) + -> E is C+1 + ; memberchk_eq(A, D) + -> E is C+1 + ; E=C + ), + order_score_vars(F, B, D, E, G). +create_get_mutable_ref(C, B, A) :- + A= (B=mutable(C)). +clean_clauses([], []). +clean_clauses([A|C], [B|D]) :- + clean_clause(A, B), + clean_clauses(C, D). +clean_clause(A, D) :- + ( A= (E:-B) + -> clean_goal(B, C), + ( C==true + -> D=E + ; D= (E:-C) + ) + ; D=A + ). +clean_goal(A, B) :- + var(A), !, + B=A. +clean_goal((A, B), D) :- !, + clean_goal(A, C), + clean_goal(B, E), + ( C==true + -> D=E + ; E==true + -> D=C + ; D= (C, E) + ). +clean_goal((A->C;F), D) :- !, + clean_goal(A, B), + ( B==true + -> clean_goal(C, E), + D=E + ; B==fail + -> clean_goal(F, G), + D=G + ; clean_goal(C, E), + clean_goal(F, G), + D= (B->E;G) + ). +clean_goal((A;B), D) :- !, + clean_goal(A, C), + clean_goal(B, E), + ( C==fail + -> D=E + ; E==fail + -> D=C + ; D= (C;E) + ). +clean_goal(once(A), C) :- !, + clean_goal(A, B), + ( B==true + -> C=true + ; B==fail + -> C=fail + ; C=once(B) + ). +clean_goal((A->C), D) :- !, + clean_goal(A, B), + ( B==true + -> clean_goal(C, D) + ; B==fail + -> D=fail + ; clean_goal(C, E), + D= (B->E) + ). +clean_goal(A, A). +gen_var(_). +gen_vars(B, A) :- + length(A, B). +head_info(E, A, B, C, D, G) :- + vars_susp(A, B, C, D), + E=..[_|F], + pairup(F, B, G). +inc_id([C|A], [B|A]) :- + B is C+1. +dec_id([C|A], [B|A]) :- + B is C-1. +extend_id(A, [0|A]). +next_id([_, C|A], [B|A]) :- + B is C+1. +build_head(A, B, C, F, D) :- + buildName(A, B, C, E), + D=..[E|F]. +buildName(A, C, D, F) :- + atom_concat(A, /, B), + atomic_concat(B, C, E), + buildName_(D, E, F). +buildName_([], A, A). +buildName_([E|A], B, F) :- + buildName_(A, B, C), + atom_concat(C, '__', D), + atomic_concat(D, E, F). +vars_susp(B, A, C, D) :- + length(A, B), + append(A, [C], D). +make_attr(B, D, A, C) :- + length(A, B), + C=..[v, D|A]. +or_pattern(A, B) :- + C is A-1, + B is 1< list2conj(B, C) + ; C= (A, D), + list2conj(B, D) + ). +atom_concat_list([A], A) :- !. +atom_concat_list([B|A], D) :- + atom_concat_list(A, C), + atomic_concat(B, C, D). +make_atom(A, B) :- + ( atom(A) + -> B=A + ; number(A) + -> number_codes(A, C), + atom_codes(B, C) + ). +set_elems([], _). +set_elems([A|B], A) :- + set_elems(B, A). +member2([A|_], [B|_], A-B). +member2([_|A], [_|B], C) :- + member2(A, B, C). +select2(A, B, [A|C], [B|D], C, D). +select2(C, D, [A|E], [B|F], [A|G], [B|H]) :- + select2(C, D, E, F, G, H). +pair_all_with([], _, []). +pair_all_with([A|C], B, [A-B|D]) :- + pair_all_with(C, B, D). +verbosity_on :- + prolog_flag(verbose, A), + A==yes. +'attach_constraint/2'([], _). +'attach_constraint/2'([A|L], D) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, E, F, G, H, I, J), + ( C/\1=:=1 + -> put_attr(A, chr_translate_bootstrap1, v(C, [D|E], F, G, H, I, J)) + ; K is C\/1, + put_attr(A, chr_translate_bootstrap1, v(K, [D], F, G, H, I, J)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(1, [D], [], [], [], [], [])) + ), + 'attach_constraint/2'(L, D). +'detach_constraint/2'([], _). +'detach_constraint/2'([A|M], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, D, H, I, J, K, L), + ( C/\1=:=1 + -> 'chr sbag_del_element'(D, E, F), + ( F==[] + -> G is C/\ -2, + ( G==0 + -> del_attr(A, chr_translate_bootstrap1) + ; put_attr(A, chr_translate_bootstrap1, v(G, [], H, I, J, K, L)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(C, F, H, I, J, K, L)) + ) + ; true + ) + ; true + ), + 'detach_constraint/2'(M, E). +'attach_constraint_count/1'([], _). +'attach_constraint_count/1'([A|L], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, D, F, G, H, I, J), + ( C/\2=:=2 + -> put_attr(A, chr_translate_bootstrap1, v(C, D, [E|F], G, H, I, J)) + ; K is C\/2, + put_attr(A, chr_translate_bootstrap1, v(K, D, [E], G, H, I, J)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(2, [], [E], [], [], [], [])) + ), + 'attach_constraint_count/1'(L, E). +'detach_constraint_count/1'([], _). +'detach_constraint_count/1'([A|M], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, H, D, I, J, K, L), + ( C/\2=:=2 + -> 'chr sbag_del_element'(D, E, F), + ( F==[] + -> G is C/\ -3, + ( G==0 + -> del_attr(A, chr_translate_bootstrap1) + ; put_attr(A, chr_translate_bootstrap1, v(G, H, [], I, J, K, L)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(C, H, F, I, J, K, L)) + ) + ; true + ) + ; true + ), + 'detach_constraint_count/1'(M, E). +'attach_constraint_index/2'([], _). +'attach_constraint_index/2'([A|L], F) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, D, E, G, H, I, J), + ( C/\4=:=4 + -> put_attr(A, chr_translate_bootstrap1, v(C, D, E, [F|G], H, I, J)) + ; K is C\/4, + put_attr(A, chr_translate_bootstrap1, v(K, D, E, [F], H, I, J)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(4, [], [], [F], [], [], [])) + ), + 'attach_constraint_index/2'(L, F). +'detach_constraint_index/2'([], _). +'detach_constraint_index/2'([A|M], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, H, I, D, J, K, L), + ( C/\4=:=4 + -> 'chr sbag_del_element'(D, E, F), + ( F==[] + -> G is C/\ -5, + ( G==0 + -> del_attr(A, chr_translate_bootstrap1) + ; put_attr(A, chr_translate_bootstrap1, v(G, H, I, [], J, K, L)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(C, H, I, F, J, K, L)) + ) + ; true + ) + ; true + ), + 'detach_constraint_index/2'(M, E). +'attach_max_constraint_index/1'([], _). +'attach_max_constraint_index/1'([A|L], G) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, D, E, F, H, I, J), + ( C/\8=:=8 + -> put_attr(A, chr_translate_bootstrap1, v(C, D, E, F, [G|H], I, J)) + ; K is C\/8, + put_attr(A, chr_translate_bootstrap1, v(K, D, E, F, [G], I, J)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(8, [], [], [], [G], [], [])) + ), + 'attach_max_constraint_index/1'(L, G). +'detach_max_constraint_index/1'([], _). +'detach_max_constraint_index/1'([A|M], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, H, I, J, D, K, L), + ( C/\8=:=8 + -> 'chr sbag_del_element'(D, E, F), + ( F==[] + -> G is C/\ -9, + ( G==0 + -> del_attr(A, chr_translate_bootstrap1) + ; put_attr(A, chr_translate_bootstrap1, v(G, H, I, J, [], K, L)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(C, H, I, J, F, K, L)) + ) + ; true + ) + ; true + ), + 'detach_max_constraint_index/1'(M, E). +'attach_target_module/1'([], _). +'attach_target_module/1'([A|L], H) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, D, E, F, G, I, J), + ( C/\16=:=16 + -> put_attr(A, chr_translate_bootstrap1, v(C, D, E, F, G, [H|I], J)) + ; K is C\/16, + put_attr(A, chr_translate_bootstrap1, v(K, D, E, F, G, [H], J)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(16, [], [], [], [], [H], [])) + ), + 'attach_target_module/1'(L, H). +'detach_target_module/1'([], _). +'detach_target_module/1'([A|M], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, H, I, J, K, D, L), + ( C/\16=:=16 + -> 'chr sbag_del_element'(D, E, F), + ( F==[] + -> G is C/\ -17, + ( G==0 + -> del_attr(A, chr_translate_bootstrap1) + ; put_attr(A, chr_translate_bootstrap1, v(G, H, I, J, K, [], L)) + ) + ; put_attr(A, chr_translate_bootstrap1, v(C, H, I, J, K, F, L)) + ) + ; true + ) + ; true + ), + 'detach_target_module/1'(M, E). +'attach_attached/2'([], _). +'attach_attached/2'([A|L], I) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, D, E, F, G, H, J), + ( C/\32=:=32 + -> put_attr(A, chr_translate_bootstrap1, v(C, D, E, F, G, H, [I|J])) + ; K is C\/32, + put_attr(A, chr_translate_bootstrap1, v(K, D, E, F, G, H, [I])) + ) + ; put_attr(A, chr_translate_bootstrap1, v(32, [], [], [], [], [], [I])) + ), + 'attach_attached/2'(L, I). +'detach_attached/2'([], _). +'detach_attached/2'([A|M], E) :- + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(C, H, I, J, K, L, D), + ( C/\32=:=32 + -> 'chr sbag_del_element'(D, E, F), + ( F==[] + -> G is C/\ -33, + ( G==0 + -> del_attr(A, chr_translate_bootstrap1) + ; put_attr(A, chr_translate_bootstrap1, v(G, H, I, J, K, L, [])) + ) + ; put_attr(A, chr_translate_bootstrap1, v(C, H, I, J, K, L, F)) + ) + ; true + ) + ; true + ), + 'detach_attached/2'(M, E). +attach_increment([], _). +attach_increment([A|D1], v(U, D, G, J, M, P, S)) :- + 'chr not_locked'(A), + ( get_attr(A, chr_translate_bootstrap1, B) + -> B=v(V, C, F, I, L, O, R), + sort(C, E), + 'chr merge_attributes'(D, E, X), + sort(F, H), + 'chr merge_attributes'(G, H, Y), + sort(I, K), + 'chr merge_attributes'(J, K, Z), + sort(L, N), + 'chr merge_attributes'(M, N, A1), + sort(O, Q), + 'chr merge_attributes'(P, Q, B1), + sort(R, T), + 'chr merge_attributes'(S, T, C1), + W is U\/V, + put_attr(A, chr_translate_bootstrap1, v(W, X, Y, Z, A1, B1, C1)) + ; put_attr(A, chr_translate_bootstrap1, v(U, D, G, J, M, P, S)) + ), + attach_increment(D1, v(U, D, G, J, M, P, S)). +chr_translate_bootstrap1:attr_unify_hook(v(A1, A, B, C, D, E, F), G) :- + sort(A, J), + sort(B, M), + sort(C, P), + sort(D, S), + sort(E, V), + sort(F, Y), + ( var(G) + -> ( get_attr(G, chr_translate_bootstrap1, H) + -> H=v(B1, I, L, O, R, U, X), + sort(I, K), + 'chr merge_attributes'(J, K, D1), + sort(L, N), + 'chr merge_attributes'(M, N, E1), + sort(O, Q), + 'chr merge_attributes'(P, Q, F1), + sort(R, T), + 'chr merge_attributes'(S, T, G1), + sort(U, W), + 'chr merge_attributes'(V, W, H1), + sort(X, Z), + 'chr merge_attributes'(Y, Z, I1), + C1 is A1\/B1, + put_attr(G, chr_translate_bootstrap1, v(C1, D1, E1, F1, G1, H1, I1)), + 'chr run_suspensions_loop'([D1, E1, F1, G1, H1, I1]) + ; put_attr(G, chr_translate_bootstrap1, v(A1, J, M, P, S, V, Y)), + 'chr run_suspensions_loop'([J, M, P, S, V, Y]) + ) + ; ( compound(G) + -> term_variables(G, J1), + attach_increment(J1, v(A1, J, M, P, S, V, Y)) + ; true + ), + 'chr run_suspensions_loop'([J, M, P, S, V, Y]) + ). +constraint(A, B) :- + 'constraint/2__0'(A, B, _). +'constraint/2__0'(A, K, I) :- + 'chr via_1'(A, B), + get_attr(B, chr_translate_bootstrap1, C), + C=v(D, E, _, _, _, _, _), + D/\1=:=1, + ( 'chr sbag_member'(F, E), + F=suspension(_, G, _, _, _, _, H, L), + G=mutable(active), + H==A + -> true + ), !, + ( var(I) + -> true + ; 'chr remove_constraint_internal'(I, J), + 'detach_constraint/2'(J, I) + ), + K=L. +'constraint/2__0'(K, A, I) :- + 'chr via_1'(A, B), + get_attr(B, chr_translate_bootstrap1, C), + C=v(D, E, _, _, _, _, _), + D/\1=:=1, + 'chr sbag_member'(F, E), + F=suspension(_, G, _, _, _, _, L, H), + G=mutable(active), + H==A, !, + ( var(I) + -> true + ; 'chr remove_constraint_internal'(I, J), + 'detach_constraint/2'(J, I) + ), + K=L. +'constraint/2__0'(B, C, A) :- + ( var(A) + -> 'chr insert_constraint_internal'(D, A, chr_translate_bootstrap1:'constraint/2__0'(B, C, A), constraint, [B, C]) + ; 'chr activate_constraint'(D, A, _) + ), + 'attach_constraint/2'(D, A). +constraint_count(A) :- + 'constraint_count/1__0'(A, _). +'constraint_count/1__0'(I, G) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, D, _, _, _, _), + C/\2=:=2, + 'chr sbag_member'(E, D), + E=suspension(_, F, _, _, _, _, J), + F=mutable(active), !, + ( var(G) + -> true + ; 'chr remove_constraint_internal'(G, H), + 'detach_constraint_count/1'(H, G) + ), + I=J. +'constraint_count/1__0'(B, A) :- + ( var(A) + -> 'chr insert_constraint_internal'(C, A, chr_translate_bootstrap1:'constraint_count/1__0'(B, A), constraint_count, [B]) + ; 'chr activate_constraint'(C, A, _) + ), + 'attach_constraint_count/1'(C, A). +constraint_index(A, B) :- + 'constraint_index/2__0'(A, B, _). +'constraint_index/2__0'(B, C, A) :- + ( var(A) + -> 'chr insert_constraint_internal'(D, A, chr_translate_bootstrap1:'constraint_index/2__0'(B, C, A), constraint_index, [B, C]) + ; 'chr activate_constraint'(D, A, _) + ), + 'attach_constraint_index/2'(D, A). +get_constraint_index(A, B) :- + 'get_constraint_index/2__0'(A, B, _). +'get_constraint_index/2__0'(A, I, _) :- + 'chr via_1'(A, B), + get_attr(B, chr_translate_bootstrap1, C), + C=v(D, _, _, E, _, _, _), + D/\4=:=4, + 'chr sbag_member'(F, E), + F=suspension(_, G, _, _, _, _, H, J), + G=mutable(active), + H==A, !, + I=J. +'get_constraint_index/2__0'(_, _, _) :- !, + fail. +max_constraint_index(A) :- + 'max_constraint_index/1__0'(A, _). +'max_constraint_index/1__0'(B, A) :- + ( var(A) + -> 'chr insert_constraint_internal'(C, A, chr_translate_bootstrap1:'max_constraint_index/1__0'(B, A), max_constraint_index, [B]) + ; 'chr activate_constraint'(C, A, _) + ), + 'attach_max_constraint_index/1'(C, A). +get_max_constraint_index(A) :- + 'get_max_constraint_index/1__0'(A, _). +'get_max_constraint_index/1__0'(G, _) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, _, _, D, _, _), + C/\8=:=8, + 'chr sbag_member'(E, D), + E=suspension(_, F, _, _, _, _, H), + F=mutable(active), !, + G=H. +'get_max_constraint_index/1__0'(_, _) :- !, + fail. +target_module(A) :- + 'target_module/1__0'(A, _). +'target_module/1__0'(B, A) :- + ( var(A) + -> 'chr insert_constraint_internal'(C, A, chr_translate_bootstrap1:'target_module/1__0'(B, A), target_module, [B]) + ; 'chr activate_constraint'(C, A, _) + ), + 'attach_target_module/1'(C, A). +get_target_module(A) :- + 'get_target_module/1__0'(A, _). +'get_target_module/1__0'(G, _) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, _, _, _, D, _), + C/\16=:=16, + 'chr sbag_member'(E, D), + E=suspension(_, F, _, _, _, _, H), + F=mutable(active), !, + G=H. +'get_target_module/1__0'(A, _) :- !, + A=user. +attached(A, B) :- + 'attached/2__0'(A, B, _). +'attached/2__0'(A, _, J) :- + 'chr via_1'(A, B), + get_attr(B, chr_translate_bootstrap1, C), + C=v(D, _, _, _, _, _, E), + D/\32=:=32, + 'chr sbag_member'(F, E), + F=suspension(_, G, _, _, _, _, H, I), + G=mutable(active), + H==A, + I==yes, !, + ( var(J) + -> true + ; 'chr remove_constraint_internal'(J, K), + 'detach_attached/2'(K, J) + ). +'attached/2__0'(B, A, F) :- + A==yes, + 'chr via_1'(B, C), + get_attr(C, chr_translate_bootstrap1, D), + D=v(E, _, _, _, _, _, G), + E/\32=:=32, !, + ( var(F) + -> 'chr allocate_constraint'(chr_translate_bootstrap1:'attached/2__0'(B, A, F), F, attached, [B, A]) + ; true + ), + 'attached/2__0__0'(G, B, A, F). +'attached/2__0__0'([], A, B, C) :- + 'attached/2__1'(A, B, C). +'attached/2__0__0'([A|F], D, G, H) :- + ( A=suspension(_, B, _, _, _, _, C, _), + B=mutable(active), + C==D + -> 'chr remove_constraint_internal'(A, E), + 'detach_attached/2'(E, A), + 'attached/2__0__0'(F, D, G, H) + ; 'attached/2__0__0'(F, D, G, H) + ). +'attached/2__0'(B, C, A) :- + ( var(A) + -> 'chr allocate_constraint'(chr_translate_bootstrap1:'attached/2__0'(B, C, A), A, attached, [B, C]) + ; true + ), + 'attached/2__1'(B, C, A). +'attached/2__1'(A, _, J) :- + 'chr via_1'(A, B), + get_attr(B, chr_translate_bootstrap1, C), + C=v(D, _, _, _, _, _, E), + D/\32=:=32, + 'chr sbag_member'(F, E), + F=suspension(_, G, _, _, _, _, H, I), + G=mutable(active), + H==A, + I==no, !, + ( var(J) + -> true + ; 'chr remove_constraint_internal'(J, K), + 'detach_attached/2'(K, J) + ). +'attached/2__1'(B, A, G) :- + A==no, + 'chr via_1'(B, C), + get_attr(C, chr_translate_bootstrap1, D), + D=v(E, _, _, _, _, _, F), + E/\32=:=32, !, + 'attached/2__1__0'(F, B, A, G). +'attached/2__1__0'([], A, B, C) :- + 'attached/2__2'(A, B, C). +'attached/2__1__0'([A|F], D, G, H) :- + ( A=suspension(_, B, _, _, _, _, C, _), + B=mutable(active), + C==D + -> 'chr remove_constraint_internal'(A, E), + 'detach_attached/2'(E, A), + 'attached/2__1__0'(F, D, G, H) + ; 'attached/2__1__0'(F, D, G, H) + ). +'attached/2__1'(A, B, C) :- + 'attached/2__2'(A, B, C). +'attached/2__2'(B, A, K) :- + A==maybe, + 'chr via_1'(B, C), + get_attr(C, chr_translate_bootstrap1, D), + D=v(E, _, _, _, _, _, F), + E/\32=:=32, + ( 'chr sbag_member'(G, F), + G=suspension(_, H, _, _, _, _, I, J), + H=mutable(active), + I==B, + J==maybe + -> true + ), !, + ( var(K) + -> true + ; 'chr remove_constraint_internal'(K, L), + 'detach_attached/2'(L, K) + ). +'attached/2__2'(_, _, A) :- + 'chr activate_constraint'(B, A, _), + 'attach_attached/2'(B, A). +is_attached(A) :- + 'is_attached/1__0'(A, _). +'is_attached/1__0'(A, _) :- + 'chr via_1'(A, B), + get_attr(B, chr_translate_bootstrap1, C), + C=v(D, _, _, _, _, _, E), + D/\32=:=32, + 'chr sbag_member'(F, E), + F=suspension(_, G, _, _, _, _, H, I), + G=mutable(active), + H==A, !, + ( I==no + -> fail + ; true + ). +'is_attached/1__0'(_, _) :- !. +chr_clear :- + 'chr_clear/0__0'(_). +'chr_clear/0__0'(D) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, E, _, _, _, _, _), + C/\1=:=1, !, + ( var(D) + -> 'chr allocate_constraint'(chr_translate_bootstrap1:'chr_clear/0__0'(D), D, chr_clear, []) + ; true + ), + 'chr_clear/0__0__0'(E, D). +'chr_clear/0__0__0'([], A) :- + 'chr_clear/0__1'(A). +'chr_clear/0__0__0'([A|D], E) :- + ( A=suspension(_, B, _, _, _, _, _, _), + B=mutable(active) + -> 'chr remove_constraint_internal'(A, C), + 'detach_constraint/2'(C, A), + 'chr_clear/0__0__0'(D, E) + ; 'chr_clear/0__0__0'(D, E) + ). +'chr_clear/0__0'(A) :- + ( var(A) + -> 'chr allocate_constraint'(chr_translate_bootstrap1:'chr_clear/0__0'(A), A, chr_clear, []) + ; true + ), + 'chr_clear/0__1'(A). +'chr_clear/0__1'(E) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, D, _, _, _, _), + C/\2=:=2, !, + 'chr_clear/0__1__0'(D, E). +'chr_clear/0__1__0'([], A) :- + 'chr_clear/0__2'(A). +'chr_clear/0__1__0'([A|D], E) :- + ( A=suspension(_, B, _, _, _, _, _), + B=mutable(active) + -> 'chr remove_constraint_internal'(A, C), + 'detach_constraint_count/1'(C, A), + 'chr_clear/0__1__0'(D, E) + ; 'chr_clear/0__1__0'(D, E) + ). +'chr_clear/0__1'(A) :- + 'chr_clear/0__2'(A). +'chr_clear/0__2'(E) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, _, D, _, _, _), + C/\4=:=4, !, + 'chr_clear/0__2__0'(D, E). +'chr_clear/0__2__0'([], A) :- + 'chr_clear/0__3'(A). +'chr_clear/0__2__0'([A|D], E) :- + ( A=suspension(_, B, _, _, _, _, _, _), + B=mutable(active) + -> 'chr remove_constraint_internal'(A, C), + 'detach_constraint_index/2'(C, A), + 'chr_clear/0__2__0'(D, E) + ; 'chr_clear/0__2__0'(D, E) + ). +'chr_clear/0__2'(A) :- + 'chr_clear/0__3'(A). +'chr_clear/0__3'(E) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, _, _, D, _, _), + C/\8=:=8, !, + 'chr_clear/0__3__0'(D, E). +'chr_clear/0__3__0'([], A) :- + 'chr_clear/0__4'(A). +'chr_clear/0__3__0'([A|D], E) :- + ( A=suspension(_, B, _, _, _, _, _), + B=mutable(active) + -> 'chr remove_constraint_internal'(A, C), + 'detach_max_constraint_index/1'(C, A), + 'chr_clear/0__3__0'(D, E) + ; 'chr_clear/0__3__0'(D, E) + ). +'chr_clear/0__3'(A) :- + 'chr_clear/0__4'(A). +'chr_clear/0__4'(E) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, _, _, _, D, _), + C/\16=:=16, !, + 'chr_clear/0__4__0'(D, E). +'chr_clear/0__4__0'([], A) :- + 'chr_clear/0__5'(A). +'chr_clear/0__4__0'([A|D], E) :- + ( A=suspension(_, B, _, _, _, _, _), + B=mutable(active) + -> 'chr remove_constraint_internal'(A, C), + 'detach_target_module/1'(C, A), + 'chr_clear/0__4__0'(D, E) + ; 'chr_clear/0__4__0'(D, E) + ). +'chr_clear/0__4'(A) :- + 'chr_clear/0__5'(A). +'chr_clear/0__5'(E) :- + 'chr default_store'(A), + get_attr(A, chr_translate_bootstrap1, B), + B=v(C, _, _, _, _, _, D), + C/\32=:=32, !, + 'chr_clear/0__5__0'(D, E). +'chr_clear/0__5__0'([], A) :- + 'chr_clear/0__6'(A). +'chr_clear/0__5__0'([A|D], E) :- + ( A=suspension(_, B, _, _, _, _, _, _), + B=mutable(active) + -> 'chr remove_constraint_internal'(A, C), + 'detach_attached/2'(C, A), + 'chr_clear/0__5__0'(D, E) + ; 'chr_clear/0__5__0'(D, E) + ). +'chr_clear/0__5'(A) :- + 'chr_clear/0__6'(A). +'chr_clear/0__6'(_) :- !. diff --git a/packages/chr/chr_translate_bootstrap2.chr b/packages/chr/chr_translate_bootstrap2.chr new file mode 100644 index 000000000..f32ea2ae2 --- /dev/null +++ b/packages/chr/chr_translate_bootstrap2.chr @@ -0,0 +1,3670 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% ____ _ _ ____ ____ _ _ +%% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __ +%% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__| +%% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ | +%% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_| +%% |_| +%% +%% hProlog CHR compiler: +%% +%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be +%% +%% * based on the SICStus CHR compilation by Christian Holzbaur +%% +%% First working version: 6 June 2003 +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% URGENTLY TODO +%% +%% * fine-tune automatic selection of constraint stores +%% +%% To Do +%% +%% * further specialize runtime predicates for special cases where +%% - none of the constraints contain any indexing variables, ... +%% - just one constraint requires some runtime predicate +%% * analysis for attachment delaying (see primes for case) +%% * internal constraints declaration + analyses? +%% * Do not store in global variable store if not necessary +%% NOTE: affects show_store/1 +%% * multi-level store: variable - ground +%% * Do not maintain/check unnecessary propagation history +%% for rules that cannot be applied more than once +%% e.g. due to groundness +%% * Strengthen attachment analysis: +%% reason about bodies of rules only containing constraints +%% +%% * SICStus compatibility +%% - rules/1 declaration +%% - options +%% - pragmas +%% - tell guard +%% * instantiation declarations +%% POTENTIAL GAIN: +%% GROUND +%% - cheaper matching code? +%% VARIABLE (never bound) +%% +%% * make difference between cheap guards for reordering +%% and non-binding guards for lock removal +%% * unqiue -> once/[] transformation for propagation +%% * cheap guards interleaved with head retrieval + faster +%% via-retrieval + non-empty checking for propagation rules +%% redo for simpagation_head2 prelude +%% * intelligent backtracking for simplification/simpagation rule +%% generator_1(X),'_$savecp'(CP_1), +%% ... +%% if( ( +%% generator_n(Y), +%% test(X,Y) +%% ), +%% true, +%% ('_$cutto'(CP_1), fail) +%% ), +%% ... +%% +%% or recently developped cascading-supported approach +%% +%% * intelligent backtracking for propagation rule +%% use additional boolean argument for each possible smart backtracking +%% when boolean at end of list true -> no smart backtracking +%% false -> smart backtracking +%% only works for rules with at least 3 constraints in the head +%% +%% * mutually exclusive rules +%% * (set semantics + functional dependency) declaration + resolution +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- module(chr_translate, + [ chr_translate/2 % +Decls, -TranslatedDecls + ]). +%% SWI begin +:- use_module(library(lists),[append/3,member/2,delete/3,reverse/2,permutation/2]). +:- use_module(library(ordsets)). +%% SWI end + +:- use_module(library(dialect/hprolog)). +:- use_module(pairlist). +:- use_module(a_star). +:- use_module(clean_code). +:- use_module(builtins). +:- use_module(find). +:- include(chr_op2). + +:- chr_option(debug,off). +:- chr_option(optimize,full). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- chr_constraint + + constraint/2, % constraint(F/A,ConstraintIndex) + get_constraint/2, + + constraint_count/1, % constraint_count(MaxConstraintIndex) + get_constraint_count/1, + + constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex) + get_constraint_index/2, + + max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex) + get_max_constraint_index/1, + + target_module/1, % target_module(Module) + get_target_module/1, + + attached/2, % attached(F/A,yes/no/maybe) + is_attached/1, + + indexed_argument/2, % argument instantiation may enable applicability of rule + is_indexed_argument/2, + + constraint_mode/2, + get_constraint_mode/2, + + may_trigger/1, + + has_nonground_indexed_argument/3, + + store_type/2, + get_store_type/2, + update_store_type/2, + actual_store_types/2, + assumed_store_type/2, + validate_store_type_assumption/1, + + rule_count/1, + inc_rule_count/1, + get_rule_count/1, + + passive/2, + is_passive/2, + any_passive_head/1, + + pragma_unique/3, + get_pragma_unique/3, + + occurrence/4, + get_occurrence/4, + + max_occurrence/2, + get_max_occurrence/2, + + allocation_occurrence/2, + get_allocation_occurrence/2, + rule/2, + get_rule/2 + . + +:- chr_option(mode,constraint(+,+)). +:- chr_option(mode,constraint_count(+)). +:- chr_option(mode,constraint_index(+,+)). +:- chr_option(mode,max_constraint_index(+)). +:- chr_option(mode,target_module(+)). +:- chr_option(mode,attached(+,+)). +:- chr_option(mode,indexed_argument(+,+)). +:- chr_option(mode,constraint_mode(+,+)). +:- chr_option(mode,may_trigger(+)). +:- chr_option(mode,store_type(+,+)). +:- chr_option(mode,actual_store_types(+,+)). +:- chr_option(mode,assumed_store_type(+,+)). +:- chr_option(mode,rule_count(+)). +:- chr_option(mode,passive(+,+)). +:- chr_option(mode,pragma_unique(+,+,?)). +:- chr_option(mode,occurrence(+,+,+,+)). +:- chr_option(mode,max_occurrence(+,+)). +:- chr_option(mode,allocation_occurrence(+,+)). +:- chr_option(mode,rule(+,+)). + +constraint(FA,Index) \ get_constraint(Query,Index) + <=> Query = FA. +get_constraint(_,_) + <=> fail. + +constraint_count(Index) \ get_constraint_count(Query) + <=> Query = Index. +get_constraint_count(Query) + <=> Query = 0. + +target_module(Mod) \ get_target_module(Query) + <=> Query = Mod . +get_target_module(Query) + <=> Query = user. + +constraint_index(C,Index) \ get_constraint_index(C,Query) + <=> Query = Index. +get_constraint_index(_,_) + <=> fail. + +max_constraint_index(Index) \ get_max_constraint_index(Query) + <=> Query = Index. +get_max_constraint_index(Query) + <=> Query = 0. + +attached(Constr,yes) \ attached(Constr,_) <=> true. +attached(Constr,no) \ attached(Constr,_) <=> true. +attached(Constr,maybe) \ attached(Constr,maybe) <=> true. + +attached(Constr,Type) \ is_attached(Constr) + <=> Type \== no. +is_attached(_) <=> true. + +indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true. +indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true. +is_indexed_argument(_,_) <=> fail. + +constraint_mode(FA,Mode) \ get_constraint_mode(FA,Query) + <=> Query = Mode. +get_constraint_mode(FA,Query) + <=> FA = _/A, length(Query,A), set_elems(Query,?). + +may_trigger(FA) <=> + is_attached(FA), + get_constraint_mode(FA,Mode), + has_nonground_indexed_argument(FA,1,Mode). + +has_nonground_indexed_argument(FA,I,[Mode|Modes]) + <=> + true + | + ( is_indexed_argument(FA,I), + Mode \== (+) -> + true + ; + J is I + 1, + has_nonground_indexed_argument(FA,J,Modes) + ). +has_nonground_indexed_argument(_,_,_) + <=> fail. + +store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])). +store_type(FA,Store) \ get_store_type(FA,Query) + <=> Query = Store. +assumed_store_type(FA,Store) \ get_store_type(FA,Query) + <=> Query = Store. +get_store_type(_,Query) + <=> Query = default. + +actual_store_types(C,STs) \ update_store_type(C,ST) + <=> member(ST,STs) | true. +update_store_type(C,ST), actual_store_types(C,STs) + <=> + actual_store_types(C,[ST|STs]). +update_store_type(C,ST) + <=> + actual_store_types(C,[ST]). + +% refine store type assumption +validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption + <=> + store_type(C,multi_store(STs)). +validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption + <=> + store_type(C,multi_store(STs)). +validate_store_type_assumption(_) + <=> true. + +rule_count(C), inc_rule_count(NC) + <=> NC is C + 1, rule_count(NC). +inc_rule_count(NC) + <=> NC = 1, rule_count(NC). + +rule_count(C) \ get_rule_count(Q) + <=> Q = C. +get_rule_count(Q) + <=> Q = 0. + +passive(RuleNb,ID) \ is_passive(RuleNb,ID) + <=> true. +is_passive(_,_) + <=> fail. +passive(RuleNb,_) \ any_passive_head(RuleNb) + <=> true. +any_passive_head(_) + <=> fail. + +pragma_unique(RuleNb,ID,Vars) \ get_pragma_unique(RuleNb,ID,Query) + <=> Query = Vars. +get_pragma_unique(_,_,_) + <=> true. + +occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID) + <=> Rule = QRule, ID = QID. +get_occurrence(_,_,_,_) + <=> fail. + +occurrence(C,ON,_,_) ==> max_occurrence(C,ON). +max_occurrence(C,N) \ max_occurrence(C,M) + <=> N >= M | true. +max_occurrence(C,MON) \ get_max_occurrence(C,Q) + <=> Q = MON. +get_max_occurrence(_,Q) + <=> Q = 0. + + % need not store constraint that is removed +rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O) + <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs) + | NO is O + 1, allocation_occurrence(C,NO). + % need not store constraint when body is true +rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O) + <=> Rule = pragma(rule(_,_,_,true),_,_,_,_) + | NO is O + 1, allocation_occurrence(C,NO). + % cannot store constraint at passive occurrence +occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O) + <=> NO is O + 1, allocation_occurrence(C,NO). +allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q) + <=> Q = O. +get_allocation_occurrence(_,_) + <=> fail. + +rule(RuleNb,Rule) \ get_rule(RuleNb,Q) + <=> Q = Rule. +get_rule(_,_) + <=> fail. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Translation + +chr_translate(Declarations,NewDeclarations) :- + init_chr_pp_flags, + partition_clauses(Declarations,Constraints,Rules,OtherClauses), + ( Constraints == [] -> + insert_declarations(OtherClauses, NewDeclarations) + ; + % start analysis + add_rules(Rules), + check_rules(Rules,Constraints), + add_occurrences(Rules), + late_allocation(Constraints), + unique_analyse_optimise(Rules,NRules), + check_attachments(Constraints), + assume_constraint_stores(Constraints), + set_constraint_indices(Constraints,1), + % end analysis + constraints_code(Constraints,NRules,ConstraintClauses), + validate_store_type_assumptions(Constraints), + store_management_preds(Constraints,StoreClauses), % depends on actual code used + insert_declarations(OtherClauses, Clauses0), + chr_module_declaration(CHRModuleDeclaration), + append([Clauses0, + StoreClauses, + ConstraintClauses, + CHRModuleDeclaration + ], + NewDeclarations) + ). + +store_management_preds(Constraints,Clauses) :- + generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses), + generate_indexed_variables_clauses(Constraints,IndexedClauses), + generate_attach_increment(AttachIncrementClauses), + generate_attr_unify_hook(AttrUnifyHookClauses), + generate_extra_clauses(Constraints,ExtraClauses), + generate_insert_delete_constraints(Constraints,DeleteClauses), + generate_store_code(Constraints,StoreClauses), + append([AttachAConstraintClauses + ,IndexedClauses + ,AttachIncrementClauses + ,AttrUnifyHookClauses + ,ExtraClauses + ,DeleteClauses + ,StoreClauses] + ,Clauses). + + +%% SWI begin +specific_declarations([(:- use_module('chr_runtime')) + ,(:- use_module('chr_hashtable_store')) + ,(:- style_check(-discontiguous)) + |Tail],Tail). +%% SWI end + +%% SICStus begin +%% specific_declarations([(:- use_module('chr_runtime')), +%% (:- use_module('chr_hashtable_store')), +%% (:- 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 + ). + + +chr_module_declaration(CHRModuleDeclaration) :- + get_target_module(Mod), + ( Mod \== chr_translate -> + CHRModuleDeclaration = [ + (:- multifile chr:'$chr_module'/1), + chr:'$chr_module'(Mod) + ] + ; + CHRModuleDeclaration = [] + ). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Partitioning of clauses into constraint declarations, chr rules and other +%% clauses + +partition_clauses([],[],[],[]). +partition_clauses([C|Cs],Ds,Rs,OCs) :- + ( parse_rule(C,R) -> + Ds = RDs, + Rs = [R | RRs], + OCs = ROCs + ; is_declaration(C,D) -> + append(D,RDs,Ds), + Rs = RRs, + OCs = ROCs + ; is_module_declaration(C,Mod) -> + target_module(Mod), + Ds = RDs, + Rs = RRs, + OCs = [C|ROCs] + ; C = (handler _) -> + format('CHR compiler WARNING: ~w.\n',[C]), + format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]), + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; C = (rules _) -> + format('CHR compiler WARNING: ~w.\n',[C]), + format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]), + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; C = (:- chr_option(OptionName,OptionValue)) -> + handle_option(OptionName,OptionValue), + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; C = (:- chr_type _) -> + Ds = RDs, + Rs = RRs, + OCs = ROCs + ; Ds = RDs, + Rs = RRs, + OCs = [C|ROCs] + ), + partition_clauses(Cs,RDs,RRs,ROCs). + +is_declaration(D, Constraints) :- %% constraint declaration + D = (:- Decl), + ( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]), + conj2list(Cs,Constraints). + +%% Data Declaration +%% +%% pragma_rule +%% -> pragma( +%% rule, +%% ids, +%% list(pragma), +%% yesno(string), :: maybe rule nane +%% int :: rule number +%% ) +%% +%% ids -> ids( +%% list(int), +%% list(int) +%% ) +%% +%% rule -> rule( +%% list(constraint), :: constraints to be removed +%% list(constraint), :: surviving constraints +%% goal, :: guard +%% goal :: body +%% ) + +parse_rule(RI,R) :- %% name @ rule + RI = (Name @ RI2), !, + rule(RI2,yes(Name),R). +parse_rule(RI,R) :- + rule(RI,no,R). + +rule(RI,Name,R) :- + RI = (RI2 pragma P), !, %% pragmas + is_rule(RI2,R1,IDs), + conj2list(P,Ps), + inc_rule_count(RuleCount), + R = pragma(R1,IDs,Ps,Name,RuleCount). +rule(RI,Name,R) :- + is_rule(RI,R1,IDs), + inc_rule_count(RuleCount), + R = pragma(R1,IDs,[],Name,RuleCount). + +is_rule(RI,R,IDs) :- %% propagation rule + RI = (H ==> B), !, + conj2list(H,Head2i), + get_ids(Head2i,IDs2,Head2), + IDs = ids([],IDs2), + ( B = (G | RB) -> + R = rule([],Head2,G,RB) + ; + R = rule([],Head2,true,B) + ). +is_rule(RI,R,IDs) :- %% simplification/simpagation rule + RI = (H <=> B), !, + ( B = (G | RB) -> + Guard = G, + Body = RB + ; Guard = true, + Body = B + ), + ( H = (H1 \ H2) -> + conj2list(H1,Head2i), + conj2list(H2,Head1i), + get_ids(Head2i,IDs2,Head2,0,N), + get_ids(Head1i,IDs1,Head1,N,_), + IDs = ids(IDs1,IDs2) + ; conj2list(H,Head1i), + Head2 = [], + get_ids(Head1i,IDs1,Head1), + IDs = ids(IDs1,[]) + ), + R = rule(Head1,Head2,Guard,Body). + +get_ids(Cs,IDs,NCs) :- + get_ids(Cs,IDs,NCs,0,_). + +get_ids([],[],[],N,N). +get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :- + ( C = (NC # N) -> + true + ; + NC = C + ), + M is N + 1, + get_ids(Cs,IDs,NCs, M,NN). + +is_module_declaration((:- module(Mod)),Mod). +is_module_declaration((:- module(Mod,_)),Mod). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Add rules +add_rules([]). +add_rules([Rule|Rules]) :- + Rule = pragma(_,_,_,_,RuleNb), + rule(RuleNb,Rule), + add_rules(Rules). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Some input verification: +%% - all constraints in heads are declared constraints +%% - all passive pragmas refer to actual head constraints + +check_rules([],_). +check_rules([PragmaRule|Rest],Decls) :- + check_rule(PragmaRule,Decls), + check_rules(Rest,Decls). + +check_rule(PragmaRule,Decls) :- + check_rule_indexing(PragmaRule), + PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N), + Rule = rule(H1,H2,_,_), + append(H1,H2,HeadConstraints), + check_head_constraints(HeadConstraints,Decls,PragmaRule), + check_pragmas(Pragmas,PragmaRule). + +check_head_constraints([],_,_). +check_head_constraints([Constr|Rest],Decls,PragmaRule) :- + functor(Constr,F,A), + ( member(F/A,Decls) -> + check_head_constraints(Rest,Decls,PragmaRule) + ; + format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n', + [F/A,format_rule(PragmaRule)]), + format(' `--> Constraint should be one of ~w.\n',[Decls]), + fail + ). + +check_pragmas([],_). +check_pragmas([Pragma|Pragmas],PragmaRule) :- + check_pragma(Pragma,PragmaRule), + check_pragmas(Pragmas,PragmaRule). + +check_pragma(Pragma,PragmaRule) :- + var(Pragma), !, + format('CHR compiler ERROR: invalid pragma ~w in ~@.\n', + [Pragma,format_rule(PragmaRule)]), + format(' `--> Pragma should not be a variable!\n',[]), + fail. +check_pragma(passive(ID), PragmaRule) :- + !, + PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), + ( memberchk_eq(ID,IDs1) -> + true + ; memberchk_eq(ID,IDs2) -> + true + ; + format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n', + [ID,format_rule(PragmaRule)]), + fail + ), + passive(RuleNb,ID). + +check_pragma(Pragma, PragmaRule) :- + Pragma = unique(ID,Vars), + !, + PragmaRule = pragma(_,_,_,_,RuleNb), + pragma_unique(RuleNb,ID,Vars), + format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]), + format(' `--> Only use this pragma if you know what you are doing.\n',[]). + +check_pragma(Pragma, PragmaRule) :- + Pragma = already_in_heads, + !, + format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]), + format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]). + +check_pragma(Pragma, PragmaRule) :- + Pragma = already_in_head(_), + !, + format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]), + format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]). + +check_pragma(Pragma,PragmaRule) :- + format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]), + format(' `--> Pragma should be one of passive/1!\n',[]), + fail. + +format_rule(PragmaRule) :- + PragmaRule = pragma(_,_,_,MaybeName,N), + ( MaybeName = yes(Name) -> + write('rule '), write(Name) + ; + write('rule number '), write(N) + ). + +check_rule_indexing(PragmaRule) :- + PragmaRule = pragma(Rule,_,_,_,_), + Rule = rule(H1,H2,G,_), + term_variables(H1-H2,HeadVars), + remove_anti_monotonic_guards(G,HeadVars,NG), + check_indexing(H1,NG-H2), + check_indexing(H2,NG-H1). + +remove_anti_monotonic_guards(G,Vars,NG) :- + conj2list(G,GL), + remove_anti_monotonic_guard_list(GL,Vars,NGL), + list2conj(NGL,NG). + +remove_anti_monotonic_guard_list([],_,[]). +remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :- + ( G = var(X), + memberchk_eq(X,Vars) -> + NGs = RGs + ; + NGs = [G|RGs] + ), + remove_anti_monotonic_guard_list(Gs,Vars,RGs). + +check_indexing([],_). +check_indexing([Head|Heads],Other) :- + functor(Head,F,A), + Head =.. [_|Args], + term_variables(Heads-Other,OtherVars), + check_indexing(Args,1,F/A,OtherVars), + check_indexing(Heads,[Head|Other]). + +check_indexing([],_,_,_). +check_indexing([Arg|Args],I,FA,OtherVars) :- + ( is_indexed_argument(FA,I) -> + true + ; nonvar(Arg) -> + indexed_argument(FA,I) + ; % var(Arg) -> + term_variables(Args,ArgsVars), + append(ArgsVars,OtherVars,RestVars), + ( memberchk_eq(Arg,RestVars) -> + indexed_argument(FA,I) + ; + true + ) + ), + J is I + 1, + term_variables(Arg,NVars), + append(NVars,OtherVars,NOtherVars), + check_indexing(Args,J,FA,NOtherVars). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Occurrences + +add_occurrences([]). +add_occurrences([Rule|Rules]) :- + Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb), + add_occurrences(H1,IDs1,Nb), + add_occurrences(H2,IDs2,Nb), + add_occurrences(Rules). + +add_occurrences([],[],_). +add_occurrences([H|Hs],[ID|IDs],RuleNb) :- + functor(H,F,A), + FA = F/A, + get_max_occurrence(FA,MO), + O is MO + 1, + occurrence(FA,O,RuleNb,ID), + add_occurrences(Hs,IDs,RuleNb). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Late allocation + +late_allocation([]). +late_allocation([C|Cs]) :- + allocation_occurrence(C,1), + late_allocation(Cs). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Global Options +% + +handle_option(Var,Value) :- + var(Var), !, + format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]), + format(' `--> First argument should be an atom, not a variable.\n',[]), + fail. + +handle_option(Name,Value) :- + var(Value), !, + format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]), + format(' `--> Second argument should be a nonvariable.\n',[]), + fail. + +handle_option(Name,Value) :- + option_definition(Name,Value,Flags), + !, + set_chr_pp_flags(Flags). + +handle_option(Name,Value) :- + \+ option_definition(Name,_,_), !, +% setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns), + format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]), + format(' `--> Invalid option name \n',[]). %~w: should be one of ~w.\n',[Name,Ns]). + +handle_option(Name,Value) :- + findall(V,option_definition(Name,V,_),Vs), + format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]), + format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]), + fail. + +option_definition(optimize,experimental,Flags) :- + Flags = [ unique_analyse_optimise - on, + check_unnecessary_active - full, + reorder_heads - on, + set_semantics_rule - on, + check_attachments - on, + guard_via_reschedule - on + ]. +option_definition(optimize,full,Flags) :- + Flags = [ unique_analyse_optimise - off, + check_unnecessary_active - full, + reorder_heads - on, + set_semantics_rule - on, + check_attachments - on, + guard_via_reschedule - on + ]. + +option_definition(optimize,sicstus,Flags) :- + Flags = [ unique_analyse_optimise - off, + check_unnecessary_active - simplification, + reorder_heads - off, + set_semantics_rule - off, + check_attachments - off, + guard_via_reschedule - off + ]. + +option_definition(optimize,off,Flags) :- + Flags = [ unique_analyse_optimise - off, + check_unnecessary_active - off, + reorder_heads - off, + set_semantics_rule - off, + check_attachments - off, + guard_via_reschedule - 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(mode,ModeDecl,[]) :- + (nonvar(ModeDecl) -> + functor(ModeDecl,F,A), + ModeDecl =.. [_|ArgModes], + constraint_mode(F/A,ArgModes) + ; + true + ). +option_definition(store,FA-Store,[]) :- + store_type(FA,Store). + +option_definition(debug,on,Flags) :- + Flags = [ debugable - on ]. +option_definition(debug,off,Flags) :- + Flags = [ debugable - off ]. +option_definition(type_definition, _, []). % JW: ignored by bootstrap compiler +option_definition(type_declaration, _, []). % JW: ignored by bootstrap compiler +option_definition(verbosity,_,[]). + +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(unique_analyse_optimise,[on,off]). +chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]). +chr_pp_flag_definition(reorder_heads,[on,off]). +chr_pp_flag_definition(set_semantics_rule,[on,off]). +chr_pp_flag_definition(guard_via_reschedule,[on,off]). +chr_pp_flag_definition(guard_locks,[on,off]). +chr_pp_flag_definition(check_attachments,[on,off]). +chr_pp_flag_definition(debugable,[off,on]). +chr_pp_flag_definition(reduced_indexing,[on,off]). + +chr_pp_flag(Name,Value) :- + atom_concat('$chr_pp_',Name,GlobalVar), + nb_getval(GlobalVar,V), + ( V == [] -> + chr_pp_flag_definition(Name,[Value|_]) + ; + V = Value + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Generated predicates +%% attach_$CONSTRAINT +%% attach_increment +%% detach_$CONSTRAINT +%% attr_unify_hook + +%% attach_$CONSTRAINT +generate_attach_detach_a_constraint_all([],[]). +generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :- + ( may_trigger(Constraint) -> + generate_attach_a_constraint(Constraint,Clauses1), + generate_detach_a_constraint(Constraint,Clauses2) + ; + Clauses1 = [], + Clauses2 = [] + ), + generate_attach_detach_a_constraint_all(Constraints,Clauses3), + append([Clauses1,Clauses2,Clauses3],Clauses). + +generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :- + generate_attach_a_constraint_empty_list(Constraint,Clause1), + get_max_constraint_index(N), + ( N == 1 -> + generate_attach_a_constraint_1_1(Constraint,Clause2) + ; + generate_attach_a_constraint_t_p(Constraint,Clause2) + ). + +generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :- + make_name('attach_',FA,Fct), + Head =.. [Fct | Args], + Clause = ( Head :- Body). + +generate_attach_a_constraint_empty_list(FA,Clause) :- + generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause). + +generate_attach_a_constraint_1_1(FA,Clause) :- + Args = [[Var|Vars],Susp], + generate_attach_a_constraint_skeleton(FA,Args,Body,Clause), + generate_attach_body_1(FA,Var,Susp,AttachBody), + make_name('attach_',FA,Fct), + RecursiveCall =.. [Fct,Vars,Susp], + Body = + ( + AttachBody, + RecursiveCall + ). + +generate_attach_body_1(FA,Var,Susp,Body) :- + get_target_module(Mod), + Body = + ( get_attr(Var, Mod, Susps) -> + NewSusps=[Susp|Susps], + put_attr(Var, Mod, NewSusps) + ; + put_attr(Var, Mod, [Susp]) + ). + +generate_attach_a_constraint_t_p(FA,Clause) :- + Args = [[Var|Vars],Susp], + generate_attach_a_constraint_skeleton(FA,Args,Body,Clause), + make_name('attach_',FA,Fct), + RecursiveCall =.. [Fct,Vars,Susp], + generate_attach_body_n(FA,Var,Susp,AttachBody), + Body = + ( + AttachBody, + RecursiveCall + ). + +generate_attach_body_n(F/A,Var,Susp,Body) :- + get_constraint_index(F/A,Position), + or_pattern(Position,Pattern), + get_max_constraint_index(Total), + make_attr(Total,Mask,SuspsList,Attr), + nth1(Position,SuspsList,Susps), + substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1), + make_attr(Total,Mask,SuspsList1,NewAttr1), + substitute_eq(Susps,SuspsList,[Susp],SuspsList2), + make_attr(Total,NewMask,SuspsList2,NewAttr2), + copy_term_nat(SuspsList,SuspsList3), + nth1(Position,SuspsList3,[Susp],RestSuspsList), + set_elems(RestSuspsList,[]), + make_attr(Total,Pattern,SuspsList3,NewAttr3), + get_target_module(Mod), + Body = + ( get_attr(Var,Mod,TAttr) -> + TAttr = Attr, + ( Mask /\ Pattern =:= Pattern -> + put_attr(Var, Mod, NewAttr1) + ; + NewMask is Mask \/ Pattern, + put_attr(Var, Mod, NewAttr2) + ) + ; + put_attr(Var,Mod,NewAttr3) + ). + +%% detach_$CONSTRAINT +generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :- + generate_detach_a_constraint_empty_list(Constraint,Clause1), + get_max_constraint_index(N), + ( N == 1 -> + generate_detach_a_constraint_1_1(Constraint,Clause2) + ; + generate_detach_a_constraint_t_p(Constraint,Clause2) + ). + +generate_detach_a_constraint_empty_list(FA,Clause) :- + make_name('detach_',FA,Fct), + Args = [[],_], + Head =.. [Fct | Args], + Clause = ( Head :- true). + +generate_detach_a_constraint_1_1(FA,Clause) :- + make_name('detach_',FA,Fct), + Args = [[Var|Vars],Susp], + Head =.. [Fct | Args], + RecursiveCall =.. [Fct,Vars,Susp], + generate_detach_body_1(FA,Var,Susp,DetachBody), + Body = + ( + DetachBody, + RecursiveCall + ), + Clause = (Head :- Body). + +generate_detach_body_1(FA,Var,Susp,Body) :- + get_target_module(Mod), + Body = + ( get_attr(Var,Mod,Susps) -> + 'chr sbag_del_element'(Susps,Susp,NewSusps), + ( NewSusps == [] -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,NewSusps) + ) + ; + true + ). + +generate_detach_a_constraint_t_p(FA,Clause) :- + make_name('detach_',FA,Fct), + Args = [[Var|Vars],Susp], + Head =.. [Fct | Args], + RecursiveCall =.. [Fct,Vars,Susp], + generate_detach_body_n(FA,Var,Susp,DetachBody), + Body = + ( + DetachBody, + RecursiveCall + ), + Clause = (Head :- Body). + +generate_detach_body_n(F/A,Var,Susp,Body) :- + get_constraint_index(F/A,Position), + or_pattern(Position,Pattern), + and_pattern(Position,DelPattern), + get_max_constraint_index(Total), + make_attr(Total,Mask,SuspsList,Attr), + nth1(Position,SuspsList,Susps), + substitute_eq(Susps,SuspsList,[],SuspsList1), + make_attr(Total,NewMask,SuspsList1,Attr1), + substitute_eq(Susps,SuspsList,NewSusps,SuspsList2), + make_attr(Total,Mask,SuspsList2,Attr2), + get_target_module(Mod), + Body = + ( get_attr(Var,Mod,TAttr) -> + TAttr = Attr, + ( Mask /\ Pattern =:= Pattern -> + 'chr sbag_del_element'(Susps,Susp,NewSusps), + ( NewSusps == [] -> + NewMask is Mask /\ DelPattern, + ( NewMask == 0 -> + del_attr(Var,Mod) + ; + put_attr(Var,Mod,Attr1) + ) + ; + put_attr(Var,Mod,Attr2) + ) + ; + true + ) + ; + true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +generate_indexed_variables_clauses(Constraints,Clauses) :- + ( forsome(C,Constraints,chr_translate:may_trigger(C)) -> + generate_indexed_variables_clauses_(Constraints,Clauses) + ; + Clauses = [] + ). + +generate_indexed_variables_clauses_([],[]). +generate_indexed_variables_clauses_([C|Cs],Clauses) :- + ( ( is_attached(C) ; chr_pp_flag(debugable,on)) -> + Clauses = [Clause|RestClauses], + generate_indexed_variables_clause(C,Clause) + ; + Clauses = RestClauses + ), + generate_indexed_variables_clauses_(Cs,RestClauses). + +generate_indexed_variables_clause(F/A,Clause) :- + functor(Term,F,A), + get_constraint_mode(F/A,ArgModes), + Term =.. [_|Args], + create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N), + ( MaybeBody == empty -> + + Body = (Vars = []) + ; N == 0 -> + Body = term_variables(Susp,Vars) + ; + MaybeBody = Body + ), + Clause = + ( '$indexed_variables'(Susp,Vars) :- + Susp = Term, + Body + ). + +create_indexed_variables_body([],[],_,_,_,empty,0). +create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :- + J is I + 1, + create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M), + ( Mode \== (+), + is_indexed_argument(FA,I) -> + ( RBody == empty -> + Body = term_variables(V,Vars) + ; + Body = (term_variables(V,Vars,Tail),RBody) + ), + N = M + ; + Vars = Tail, + Body = RBody, + N is M + 1 + ). + +generate_extra_clauses(Constraints,[A,B,C,D,E]) :- + ( chr_pp_flag(reduced_indexing,on) -> + global_indexed_variables_clause(Constraints,D) + ; + D = + ( chr_indexed_variables(Susp,Vars) :- + 'chr chr_indexed_variables'(Susp,Vars) + ) + ), + generate_remove_clause(A), + generate_activate_clause(B), + generate_allocate_clause(C), + generate_insert_constraint_internal(E). + +generate_remove_clause(RemoveClause) :- + RemoveClause = + ( + remove_constraint_internal(Susp, Agenda, Delete) :- + arg( 2, Susp, Mref), + 'chr get_mutable'( State, Mref), + 'chr update_mutable'( removed, Mref), % mark in any case + ( compound(State) -> % passive/1 + Agenda = [], + Delete = no + ; State==removed -> + Agenda = [], + Delete = no + %; State==triggered -> + % Agenda = [] + ; + Delete = yes, + chr_indexed_variables(Susp,Agenda) + ) + ). + +generate_activate_clause(ActivateClause) :- + ActivateClause = + ( + activate_constraint(Store, Vars, Susp, Generation) :- + arg( 2, Susp, Mref), + 'chr get_mutable'( State, Mref), + 'chr update_mutable'( active, Mref), + ( nonvar(Generation) -> % aih + true + ; + arg( 4, Susp, Gref), + 'chr get_mutable'( Gen, Gref), + Generation is Gen+1, + 'chr update_mutable'( Generation, Gref) + ), + ( compound(State) -> % passive/1 + term_variables( State, Vars), + 'chr none_locked'( Vars), + Store = yes + ; State == removed -> % the price for eager removal ... + chr_indexed_variables(Susp,Vars), + Store = yes + ; + Vars = [], + Store = no + ) + ). + +generate_allocate_clause(AllocateClause) :- + AllocateClause = + ( + allocate_constraint( Closure, Self, F, Args) :- + Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], + 'chr create_mutable'(0,Gref), % Gref = mutable(0), + 'chr empty_history'(History), + 'chr create_mutable'(History,Href), % Href = mutable(History), + chr_indexed_variables(Self,Vars), + 'chr create_mutable'(passive(Vars),Mref), % Mref = mutable(passive(Vars)), + 'chr gen_id'( Id) + ). + +generate_insert_constraint_internal(Clause) :- + Clause = + ( + insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :- + Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], + chr_indexed_variables(Self,Vars), + 'chr none_locked'(Vars), + 'chr create_mutable'(active,Mref), % Mref = mutable(active), + 'chr create_mutable'(0,Gref), % Gref = mutable(0), + 'chr empty_history'(History), + 'chr create_mutable'(History,Href), % Href = mutable(History), + 'chr gen_id'(Id) + ). + +global_indexed_variables_clause(Constraints,Clause) :- + ( forsome(C,Constraints,chr_translate:may_trigger(C)) -> + Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars)) + ; + Body = true, + Vars = [] + ), + Clause = ( chr_indexed_variables(Susp,Vars) :- Body ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +generate_attach_increment(Clauses) :- + get_max_constraint_index(N), + ( N > 0 -> + Clauses = [Clause1,Clause2], + generate_attach_increment_empty(Clause1), + ( N == 1 -> + generate_attach_increment_one(Clause2) + ; + generate_attach_increment_many(N,Clause2) + ) + ; + Clauses = [] + ). + +generate_attach_increment_empty((attach_increment([],_) :- true)). + +generate_attach_increment_one(Clause) :- + Head = attach_increment([Var|Vars],Susps), + get_target_module(Mod), + Body = + ( + 'chr not_locked'(Var), + ( get_attr(Var,Mod,VarSusps) -> + sort(VarSusps,SortedVarSusps), + merge(Susps,SortedVarSusps,MergedSusps), + put_attr(Var,Mod,MergedSusps) + ; + put_attr(Var,Mod,Susps) + ), + attach_increment(Vars,Susps) + ), + Clause = (Head :- Body). + +generate_attach_increment_many(N,Clause) :- + make_attr(N,Mask,SuspsList,Attr), + make_attr(N,OtherMask,OtherSuspsList,OtherAttr), + Head = attach_increment([Var|Vars],Attr), + bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs), + list2conj(Gs,SortGoals), + bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList), + make_attr(N,MergedMask,MergedSuspsList,NewAttr), + get_target_module(Mod), + Body = + ( + 'chr not_locked'(Var), + ( get_attr(Var,Mod,TOtherAttr) -> + TOtherAttr = OtherAttr, + SortGoals, + MergedMask is Mask \/ OtherMask, + put_attr(Var,Mod,NewAttr) + ; + put_attr(Var,Mod,Attr) + ), + attach_increment(Vars,Attr) + ), + Clause = (Head :- Body). + +%% attr_unify_hook +generate_attr_unify_hook([Clause]) :- + get_max_constraint_index(N), + ( N == 0 -> + get_target_module(Mod), + Clause = + ( attr_unify_hook(Attr,Var) :- + write('ERROR: Unexpected triggering of attr_unify_hook/2 in module '), + writeln(Mod) + ) + ; N == 1 -> + generate_attr_unify_hook_one(Clause) + ; + generate_attr_unify_hook_many(N,Clause) + ). + +generate_attr_unify_hook_one(Clause) :- + Head = attr_unify_hook(Susps,Other), + get_target_module(Mod), + make_run_suspensions(NewSusps,WakeNewSusps), + make_run_suspensions(Susps,WakeSusps), + Body = + ( + sort(Susps, SortedSusps), + ( var(Other) -> + ( get_attr(Other,Mod,OtherSusps) -> + true + ; + OtherSusps = [] + ), + sort(OtherSusps,SortedOtherSusps), + 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps), + put_attr(Other,Mod,NewSusps), + WakeNewSusps + ; + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars, SortedSusps) + ; + true + ), + WakeSusps + ) + ), + Clause = (Head :- Body). + +generate_attr_unify_hook_many(N,Clause) :- + make_attr(N,Mask,SuspsList,Attr), + make_attr(N,OtherMask,OtherSuspsList,OtherAttr), + bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList), + list2conj(SortGoalList,SortGoals), + bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList), + bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E), + C = (sort(E,F), + 'chr merge_attributes'(D,F,G)) ), + SortMergeGoalList), + bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList), + list2conj(SortMergeGoalList,SortMergeGoals), + make_attr(N,MergedMask,MergedSuspsList,MergedAttr), + make_attr(N,Mask,SortedSuspsList,SortedAttr), + Head = attr_unify_hook(Attr,Other), + get_target_module(Mod), + make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps), + make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps), + Body = + ( + SortGoals, + ( var(Other) -> + ( get_attr(Other,Mod,TOtherAttr) -> + TOtherAttr = OtherAttr, + SortMergeGoals, + MergedMask is Mask \/ OtherMask, + put_attr(Other,Mod,MergedAttr), + WakeMergedSusps + ; + put_attr(Other,Mod,SortedAttr), + WakeSortedSusps + ) + ; + ( compound(Other) -> + term_variables(Other,OtherVars), + attach_increment(OtherVars,SortedAttr) + ; + true + ), + WakeSortedSusps + ) + ), + Clause = (Head :- Body). + +make_run_suspensions(Susps,Goal) :- + ( chr_pp_flag(debugable,on) -> + Goal = 'chr run_suspensions_d'(Susps) + ; + Goal = 'chr run_suspensions'(Susps) + ). + +make_run_suspensions_loop(SuspsList,Goal) :- + ( chr_pp_flag(debugable,on) -> + Goal = 'chr run_suspensions_loop_d'(SuspsList) + ; + Goal = 'chr run_suspensions_loop'(SuspsList) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% $insert_in_store_F/A +% $delete_from_store_F/A + +generate_insert_delete_constraints([],[]). +generate_insert_delete_constraints([FA|Rest],Clauses) :- + ( is_attached(FA) -> + Clauses = [IClause,DClause|RestClauses], + generate_insert_delete_constraint(FA,IClause,DClause) + ; + Clauses = RestClauses + ), + generate_insert_delete_constraints(Rest,RestClauses). + +generate_insert_delete_constraint(FA,IClause,DClause) :- + get_store_type(FA,StoreType), + generate_insert_constraint(StoreType,FA,IClause), + generate_delete_constraint(StoreType,FA,DClause). + +generate_insert_constraint(StoreType,C,Clause) :- + make_name('$insert_in_store_',C,ClauseName), + Head =.. [ClauseName,Susp], + generate_insert_constraint_body(StoreType,C,Susp,Body), + Clause = (Head :- Body). + +generate_insert_constraint_body(default,C,Susp,Body) :- + get_target_module(Mod), + get_max_constraint_index(Total), + ( Total == 1 -> + generate_attach_body_1(C,Store,Susp,AttachBody) + ; + generate_attach_body_n(C,Store,Susp,AttachBody) + ), + Body = + ( + 'chr default_store'(Store), + AttachBody + ). +generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :- + generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body). +generate_insert_constraint_body(global_ground,C,Susp,Body) :- + global_ground_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,Store), + UpdateStoreGoal % b_setval(StoreName,[Susp|Store]) + ). +generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :- + find_with_var_identity( + B, + [Susp], + ( + member(ST,StoreTypes), + chr_translate:generate_insert_constraint_body(ST,C,Susp,B) + ), + Bodies + ), + list2conj(Bodies,Body). + +generate_multi_hash_insert_constraint_bodies([],_,_,true). +generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- + multi_hash_store_name(FA,Index,StoreName), + multi_hash_key(FA,Index,Susp,KeyBody,Key), + make_get_store_goal(StoreName,Store,GetStoreGoal), + Body = + ( + KeyBody, + GetStoreGoal, % nb_getval(StoreName,Store), + insert_ht(Store,Key,Susp) + ), + generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies). + +generate_delete_constraint(StoreType,FA,Clause) :- + make_name('$delete_from_store_',FA,ClauseName), + Head =.. [ClauseName,Susp], + generate_delete_constraint_body(StoreType,FA,Susp,Body), + Clause = (Head :- Body). + +generate_delete_constraint_body(default,C,Susp,Body) :- + get_target_module(Mod), + get_max_constraint_index(Total), + ( Total == 1 -> + generate_detach_body_1(C,Store,Susp,DetachBody), + Body = + ( + 'chr default_store'(Store), + DetachBody + ) + ; + generate_detach_body_n(C,Store,Susp,DetachBody), + Body = + ( + 'chr default_store'(Store), + DetachBody + ) + ). +generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :- + generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body). +generate_delete_constraint_body(global_ground,C,Susp,Body) :- + global_ground_store_name(C,StoreName), + make_get_store_goal(StoreName,Store,GetStoreGoal), + make_update_store_goal(StoreName,NStore,UpdateStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,Store), + 'chr sbag_del_element'(Store,Susp,NStore), + UpdateStoreGoal % b_setval(StoreName,NStore) + ). +generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :- + find_with_var_identity( + B, + [Susp], + ( + member(ST,StoreTypes), + chr_translate:generate_delete_constraint_body(ST,C,Susp,B) + ), + Bodies + ), + list2conj(Bodies,Body). + +generate_multi_hash_delete_constraint_bodies([],_,_,true). +generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- + multi_hash_store_name(FA,Index,StoreName), + multi_hash_key(FA,Index,Susp,KeyBody,Key), + make_get_store_goal(StoreName,Store,GetStoreGoal), + Body = + ( + KeyBody, + GetStoreGoal, % nb_getval(StoreName,Store), + delete_ht(Store,Key,Susp) + ), + generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies). + +generate_delete_constraint_call(FA,Susp,Call) :- + make_name('$delete_from_store_',FA,Functor), + Call =.. [Functor,Susp]. + +generate_insert_constraint_call(FA,Susp,Call) :- + make_name('$insert_in_store_',FA,Functor), + Call =.. [Functor,Susp]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +generate_store_code(Constraints,[Enumerate|L]) :- + enumerate_stores_code(Constraints,Enumerate), + generate_store_code(Constraints,L,[]). + +generate_store_code([],L,L). +generate_store_code([C|Cs],L,T) :- + get_store_type(C,StoreType), + generate_store_code(StoreType,C,L,L1), + generate_store_code(Cs,L1,T). + +generate_store_code(default,_,L,L). +generate_store_code(multi_hash(Indexes),C,L,T) :- + multi_hash_store_initialisations(Indexes,C,L,L1), + multi_hash_via_lookups(Indexes,C,L1,T). +generate_store_code(global_ground,C,L,T) :- + global_ground_store_initialisation(C,L,T). +generate_store_code(multi_store(StoreTypes),C,L,T) :- + multi_store_generate_store_code(StoreTypes,C,L,T). + +multi_store_generate_store_code([],_,L,L). +multi_store_generate_store_code([ST|STs],C,L,T) :- + generate_store_code(ST,C,L,L1), + multi_store_generate_store_code(STs,C,L1,T). + +multi_hash_store_initialisations([],_,L,L). +multi_hash_store_initialisations([Index|Indexes],FA,L,T) :- + multi_hash_store_name(FA,Index,StoreName), + make_init_store_goal(StoreName,HT,InitStoreGoal), + L = [(:- (new_ht(HT),InitStoreGoal)) | L1], + multi_hash_store_initialisations(Indexes,FA,L1,T). + +global_ground_store_initialisation(C,L,T) :- + global_ground_store_name(C,StoreName), + make_init_store_goal(StoreName,[],InitStoreGoal), + L = [(:- InitStoreGoal)|T]. + +multi_hash_via_lookups([],_,L,L). +multi_hash_via_lookups([Index|Indexes],C,L,T) :- + multi_hash_via_lookup_name(C,Index,PredName), + Head =.. [PredName,Key,SuspsList], + multi_hash_store_name(C,Index,StoreName), + make_get_store_goal(StoreName,HT,GetStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,HT), + lookup_ht(HT,Key,SuspsList) + ), + L = [(Head :- Body)|L1], + multi_hash_via_lookups(Indexes,C,L1,T). + +multi_hash_via_lookup_name(F/A,Index,Name) :- + ( integer(Index) -> + IndexName = Index + ; is_list(Index) -> + atom_concat_list(Index,IndexName) + ), + atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name). + +multi_hash_store_name(F/A,Index,Name) :- + get_target_module(Mod), + ( integer(Index) -> + IndexName = Index + ; is_list(Index) -> + atom_concat_list(Index,IndexName) + ), + atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name). + +multi_hash_key(F/A,Index,Susp,KeyBody,Key) :- + ( ( integer(Index) -> + I = Index + ; + Index = [I] + ) -> + SuspIndex is I + 6, + KeyBody = arg(SuspIndex,Susp,Key) + ; is_list(Index) -> + sort(Index,Indexes), + find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs), + pairup(Bodies,Keys,ArgKeyPairs), + Key =.. [k|Keys], + list2conj(Bodies,KeyBody) + ). + +multi_hash_key_args(Index,Head,KeyArgs) :- + ( integer(Index) -> + arg(Index,Head,Arg), + KeyArgs = [Arg] + ; is_list(Index) -> + sort(Index,Indexes), + term_variables(Head,Vars), + find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs) + ). + +global_ground_store_name(F/A,Name) :- + get_target_module(Mod), + atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +enumerate_stores_code(Constraints,Clause) :- + Head = '$enumerate_suspensions'(Susp), + enumerate_store_bodies(Constraints,Susp,Bodies), + list2disj(Bodies,Body), + Clause = (Head :- Body). + +enumerate_store_bodies([],_,[]). +enumerate_store_bodies([C|Cs],Susp,L) :- + ( is_attached(C) -> + get_store_type(C,StoreType), + enumerate_store_body(StoreType,C,Susp,B), + L = [B|T] + ; + L = T + ), + enumerate_store_bodies(Cs,Susp,T). + +enumerate_store_body(default,C,Susp,Body) :- + get_constraint_index(C,Index), + get_target_module(Mod), + get_max_constraint_index(MaxIndex), + Body1 = + ( + 'chr default_store'(GlobalStore), + get_attr(GlobalStore,Mod,Attr) + ), + ( MaxIndex > 1 -> + NIndex is Index + 1, + Body2 = + ( + arg(NIndex,Attr,List), + 'chr sbag_member'(Susp,List) + ) + ; + Body2 = 'chr sbag_member'(Susp,Attr) + ), + Body = (Body1,Body2). +enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :- + multi_hash_enumerate_store_body(Index,C,Susp,Body). +enumerate_store_body(global_ground,C,Susp,Body) :- + global_ground_store_name(C,StoreName), + make_get_store_goal(StoreName,List,GetStoreGoal), + Body = + ( + GetStoreGoal, % nb_getval(StoreName,List), + 'chr sbag_member'(Susp,List) + ). +enumerate_store_body(multi_store(STs),C,Susp,Body) :- + once(( + member(ST,STs), + enumerate_store_body(ST,C,Susp,Body) + )). + +multi_hash_enumerate_store_body(I,C,Susp,B) :- + multi_hash_store_name(C,I,StoreName), + make_get_store_goal(StoreName,HT,GetStoreGoal), + B = + ( + GetStoreGoal, % nb_getval(StoreName,HT), + value_ht(HT,Susp) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +check_attachments(Constraints) :- + ( chr_pp_flag(check_attachments,on) -> + check_constraint_attachments(Constraints) + ; + true + ). + +check_constraint_attachments([]). +check_constraint_attachments([C|Cs]) :- + check_constraint_attachment(C), + check_constraint_attachments(Cs). + +check_constraint_attachment(C) :- + get_max_occurrence(C,MO), + check_occurrences_attachment(C,1,MO). + +check_occurrences_attachment(C,O,MO) :- + ( O > MO -> + true + ; + check_occurrence_attachment(C,O), + NO is O + 1, + check_occurrences_attachment(C,NO,MO) + ). + +check_occurrence_attachment(C,O) :- + get_occurrence(C,O,RuleNb,ID), + get_rule(RuleNb,PragmaRule), + PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_), + ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> + check_attachment_head1(Head1,ID,RuleNb,Heads1,Heads2,Guard) + ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> + check_attachment_head2(Head2,ID,RuleNb,Heads1,Body) + ). + +check_attachment_head1(C,ID,RuleNb,H1,H2,G) :- + functor(C,F,A), + ( H1 == [C], + H2 == [], + G == true, + C =.. [_|L], + no_matching(L,[]), + \+ is_passive(RuleNb,ID) -> + attached(F/A,no) + ; + attached(F/A,maybe) + ). + +no_matching([],_). +no_matching([X|Xs],Prev) :- + var(X), + \+ memberchk_eq(X,Prev), + no_matching(Xs,[X|Prev]). + +check_attachment_head2(C,ID,RuleNb,H1,B) :- + functor(C,F,A), + ( is_passive(RuleNb,ID) -> + attached(F/A,maybe) + ; H1 \== [], + B == true -> + attached(F/A,maybe) + ; + attached(F/A,yes) + ). + +all_attached([]). +all_attached([C|Cs]) :- + functor(C,F,A), + is_attached(F/A), + all_attached(Cs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +set_constraint_indices([],M) :- + N is M - 1, + max_constraint_index(N). +set_constraint_indices([C|Cs],N) :- + ( ( may_trigger(C) ; is_attached(C), get_store_type(C,default)) -> + constraint_index(C,N), + M is N + 1, + set_constraint_indices(Cs,M) + ; + set_constraint_indices(Cs,N) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ _ _ +%% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __ +%% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \ +%% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | | +%% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_| +%% |_| + +constraints_code(Constraints,Rules,Clauses) :- + post_constraints(Constraints,1), + constraints_code1(1,Rules,L,[]), + clean_clauses(L,Clauses). + +%% Add global data +post_constraints([],MaxIndex1) :- + MaxIndex is MaxIndex1 - 1, + constraint_count(MaxIndex). +post_constraints([F/A|Cs],N) :- + constraint(F/A,N), + M is N + 1, + post_constraints(Cs,M). +constraints_code1(I,Rules,L,T) :- + get_constraint_count(N), + ( I > N -> + T = L + ; + constraint_code(I,Rules,L,T1), + J is I + 1, + constraints_code1(J,Rules,T1,T) + ). + +%% Generate code for a single CHR constraint +constraint_code(I, Rules, L, T) :- + get_constraint(Constraint,I), + constraint_prelude(Constraint,Clause), + L = [Clause | L1], + Id1 = [0], + rules_code(Rules,I,Id1,Id2,L1,L2), + gen_cond_attach_clause(Constraint,Id2,L2,T). + +%% Generate prelude predicate for a constraint. +%% f(...) :- f/a_0(...,Susp). +constraint_prelude(F/A, Clause) :- + vars_susp(A,Vars,Susp,VarsSusp), + Head =.. [ F | Vars], + build_head(F,A,[0],VarsSusp,Delegate), + get_target_module(Mod), + FTerm =.. [F|Vars], + ( chr_pp_flag(debugable,on) -> + Clause = + ( Head :- + allocate_constraint(Mod : Delegate, Susp, FTerm, Vars), + ( + 'chr debug_event'(call(Susp)), + Delegate + ; + 'chr debug_event'(fail(Susp)), !, + fail + ), + ( + 'chr debug_event'(exit(Susp)) + ; + 'chr debug_event'(redo(Susp)), + fail + ) + ) + ; + Clause = ( Head :- Delegate ) + ). + +gen_cond_attach_clause(F/A,Id,L,T) :- + ( is_attached(F/A) -> + ( Id == [0] -> + ( may_trigger(F/A) -> + gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp) + ; + gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp) + ) + ; vars_susp(A,Args,Susp,AllArgs), + gen_uncond_attach_goal(F/A,Susp,Body,_) + ), + ( chr_pp_flag(debugable,on) -> + Constraint =.. [F|Args], + DebugEvent = 'chr debug_event'(insert(Constraint#Susp)) + ; + DebugEvent = true + ), + build_head(F,A,Id,AllArgs,Head), + Clause = ( Head :- DebugEvent,Body ), + L = [Clause | T] + ; + L = T + ). + +gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :- + vars_susp(A,Args,Susp,AllArgs), + build_head(F,A,[0],AllArgs,Closure), + ( may_trigger(F/A) -> + make_name('attach_',F/A,AttachF), + Attach =.. [AttachF,Vars,Susp] + ; + Attach = true + ), + get_target_module(Mod), + FTerm =.. [F|Args], + generate_insert_constraint_call(F/A,Susp,InsertCall), + Goal = + ( + ( var(Susp) -> + insert_constraint_internal(Stored,Vars,Susp,Mod:Closure,FTerm,Args) + ; + activate_constraint(Stored,Vars,Susp,_) + ), + ( Stored == yes -> + InsertCall, + Attach + ; + true + ) + ). + +gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :- + vars_susp(A,Args,Susp,AllArgs), + build_head(F,A,[0],AllArgs,Closure), + ( may_trigger(F/A) -> + make_name('attach_',F/A,AttachF), + Attach =.. [AttachF,Vars,Susp] + ; + Attach = true + ), + get_target_module(Mod), + FTerm =.. [F|Args], + generate_insert_constraint_call(F/A,Susp,InsertCall), + Goal = + ( + insert_constraint_internal(_,Vars,Susp,Mod:Closure,FTerm,Args), + InsertCall, + Attach + ). + +gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :- + ( may_trigger(FA) -> + make_name('attach_',FA,AttachF), + Attach =.. [AttachF,Vars,Susp] + ; + Attach = true + ), + generate_insert_constraint_call(FA,Susp,InsertCall), + AttachGoal = + ( + activate_constraint(Stored,Vars, Susp, Generation), + ( Stored == yes -> + InsertCall, + Attach + ; + true + ) + ). + +%% Generate all the code for a constraint based on all CHR rules +rules_code([],_,Id,Id,L,L). +rules_code([R |Rs],I,Id1,Id3,L,T) :- + rule_code(R,I,Id1,Id2,L,T1), + rules_code(Rs,I,Id2,Id3,T1,T). + +%% Generate code for a constraint based on a single CHR rule +rule_code(PragmaRule,I,Id1,Id2,L,T) :- + PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name,_RuleNb), + HeadIDs = ids(Head1IDs,Head2IDs), + Rule = rule(Head1,Head2,_,_), + heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1), + heads2_code(Head2,[],Head2IDs,[],PragmaRule,I,Id1,Id2,L1,T). + +%% Generate code based on all the removed heads of a CHR rule +heads1_code([],_,_,_,_,_,_,L,L). +heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :- + PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb), + get_constraint(F/A,I), + ( functor(Head,F,A), + \+ is_passive(RuleNb,HeadID), + \+ check_unnecessary_active(Head,RestHeads,Rule), + all_attached(Heads), + all_attached(RestHeads), + Rule = rule(_,Heads2,_,_), + all_attached(Heads2) -> + append(Heads,RestHeads,OtherHeads), + append(HeadIDs,RestIDs,OtherIDs), + head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1) + ; + L = L1 + ), + heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T). + +%% Generate code based on one removed head of a CHR rule +head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_Name,RuleNb), + Rule = rule(_,Head2,_,_), + ( Head2 == [] -> + reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), + simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T) + ; + simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T) + ). + +%% Generate code based on all the persistent heads of a CHR rule +heads2_code([],_,_,_,_,_,Id,Id,L,L). +heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id1,Id3,L,T) :- + PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb), + get_constraint(F/A,I), + ( functor(Head,F,A), + \+ is_passive(RuleNb,HeadID), + \+ check_unnecessary_active(Head,RestHeads,Rule), + \+ set_semantics_rule(PragmaRule), + all_attached(Heads), + all_attached(RestHeads), + Rule = rule(Heads1,_,_,_), + all_attached(Heads1) -> + append(Heads,RestHeads,OtherHeads), + append(HeadIDs,RestIDs,OtherIDs), + length(Heads,RestHeadNb), + head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,F/A,Id1,L,L0), + inc_id(Id1,Id2), + gen_alloc_inc_clause(F/A,Id1,L0,L1) + ; + L = L1, + Id2 = Id1 + ), + heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id2,Id3,L1,T). + +%% Generate code based on one persistent head of a CHR rule +head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,FA,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_Name,RuleNb), + Rule = rule(Head1,_,_,_), + ( Head1 == [] -> + reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,_), + propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) + ; + simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T) + ). + +gen_alloc_inc_clause(F/A,Id,L,T) :- + vars_susp(A,Vars,Susp,VarsSusp), + build_head(F,A,Id,VarsSusp,Head), + inc_id(Id,IncId), + build_head(F,A,IncId,VarsSusp,CallHead), + gen_allocation(Id,Vars,Susp,F/A,VarsSusp,ConditionalAlloc), + Clause = + ( + Head :- + ConditionalAlloc, + CallHead + ), + L = [Clause|T]. + +gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :- + gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal), + ConstraintAllocationGoal = + ( var(Susp) -> + UncondConstraintAllocationGoal + ; + true + ). +gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :- + build_head(F,A,[0],VarsSusp,Term), + get_target_module(Mod), + FTerm =.. [F|Vars], + ConstraintAllocationGoal = allocate_constraint(Mod : Term, Susp, FTerm, Vars). + +gen_allocation(Id,Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :- + ( Id == [0] -> + ( is_attached(FA) -> + ( may_trigger(FA) -> + gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) + ; + gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) + ) + ; + ConstraintAllocationGoal = true + ) + ; + ConstraintAllocationGoal = true + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :- + ( chr_pp_flag(guard_via_reschedule,on) -> + guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) + ; + append(Retrievals,GuardList,GoalList), + list2conj(GoalList,Goal) + ). + +guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :- + initialize_unit_dictionary(Prelude,Dict), + build_units(Retrievals,GuardList,Dict,Units), + dependency_reorder(Units,NUnits), + units2goal(NUnits,Goal). + +units2goal([],true). +units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :- + units2goal(Units,Goals). + +dependency_reorder(Units,NUnits) :- + dependency_reorder(Units,[],NUnits). + +dependency_reorder([],Acc,Result) :- + reverse(Acc,Result). + +dependency_reorder([Unit|Units],Acc,Result) :- + Unit = unit(_GID,_Goal,Type,GIDs), + ( Type == fixed -> + NAcc = [Unit|Acc] + ; + dependency_insert(Acc,Unit,GIDs,NAcc) + ), + dependency_reorder(Units,NAcc,Result). + +dependency_insert([],Unit,_,[Unit]). +dependency_insert([X|Xs],Unit,GIDs,L) :- + X = unit(GID,_,_,_), + ( memberchk(GID,GIDs) -> + L = [Unit,X|Xs] + ; + L = [X | T], + dependency_insert(Xs,Unit,GIDs,T) + ). + +build_units(Retrievals,Guard,InitialDict,Units) :- + build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail), + build_guard_units(Guard,N,Dict,Tail). + +build_retrieval_units([],N,N,Dict,Dict,L,L). +build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :- + term_variables(U,Vs), + update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs), + L = [unit(N,U,movable,GIDs)|L1], + N1 is N + 1, + build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T). + +build_retrieval_units2([],N,N,Dict,Dict,L,L). +build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :- + term_variables(U,Vs), + update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs), + L = [unit(N,U,fixed,GIDs)|L1], + N1 is N + 1, + build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T). + +initialize_unit_dictionary(Term,Dict) :- + term_variables(Term,Vars), + pair_all_with(Vars,0,Dict). + +update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs). +update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :- + ( lookup_eq(Dict,V,GID) -> + ( (GID == This ; memberchk(GID,GIDs) ) -> + GIDs1 = GIDs + ; + GIDs1 = [GID|GIDs] + ), + Dict1 = Dict + ; + Dict1 = [V - This|Dict], + GIDs1 = GIDs + ), + update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs). + +build_guard_units(Guard,N,Dict,Units) :- + ( Guard = [Goal] -> + Units = [unit(N,Goal,fixed,[])] + ; Guard = [Goal|Goals] -> + term_variables(Goal,Vs), + update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs), + Units = [unit(N,Goal,movable,GIDs)|RUnits], + N1 is N + 1, + build_guard_units(Goals,N1,NDict,RUnits) + ). + +update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs). +update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :- + ( lookup_eq(Dict,V,GID) -> + ( (GID == This ; memberchk(GID,GIDs) ) -> + GIDs1 = GIDs + ; + GIDs1 = [GID|GIDs] + ), + Dict1 = [V - This|Dict] + ; + Dict1 = [V - This|Dict], + GIDs1 = GIDs + ), + update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ ____ _ _ +%% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _ +%% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_) +%% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_ +%% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_) +%% +%% _ _ _ ___ __ +%% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___ +%% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \ +%% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/ +%% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___| +%% |_| +unique_analyse_optimise(Rules,NRules) :- + ( chr_pp_flag(unique_analyse_optimise,on) -> + unique_analyse_optimise_main(Rules,1,[],NRules) + ; + NRules = Rules + ). + +unique_analyse_optimise_main([],_,_,[]). +unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :- + ( discover_unique_pattern(PRule,N,Pattern) -> + NPatternList = [Pattern|PatternList] + ; + NPatternList = PatternList + ), + PRule = pragma(Rule,Ids,Pragmas,Name,RuleNb), + Rule = rule(H1,H2,_,_), + Ids = ids(Ids1,Ids2), + apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1), + apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2), + globalize_unique_pragmas(MorePragmas1,RuleNb), + globalize_unique_pragmas(MorePragmas2,RuleNb), + append([MorePragmas1,MorePragmas2,Pragmas],NPragmas), + NPRule = pragma(Rule,Ids,NPragmas,Name,RuleNb), + N1 is N + 1, + unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules). + +globalize_unique_pragmas([],_). +globalize_unique_pragmas([unique(ID,Vars)|R],RuleNb) :- + pragma_unique(RuleNb,ID,Vars), + globalize_unique_pragmas(R,RuleNb). + +apply_unique_patterns_to_constraints([],_,_,[]). +apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :- + ( member(Pattern,Patterns), + apply_unique_pattern(C,Id,Pattern,Pragma) -> + Pragmas = [Pragma | RPragmas] + ; + Pragmas = RPragmas + ), + apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas). + +apply_unique_pattern(Constraint,Id,Pattern,Pragma) :- + Pattern = unique(PatternConstraint,PatternKey), + subsumes(Constraint,PatternConstraint,Unifier), + find_with_var_identity( V, + Unifier + , + ( + member(T,PatternKey), + lookup_eq(Unifier,T,Term), + term_variables(Term,Vs), + member(V,Vs) + ), + Vars2), + sort(Vars2,Vars3), + Vars = Vars3, + Pragma = unique(Id,Vars). + +% subsumes(+Term1, +Term2, -Unifier) +% +% If Term1 is a more general term than Term2 (e.g. has a larger +% part instantiated), unify Unifier with a list Var-Value of +% variables from Term2 and their corresponding values in Term1. + +subsumes(Term1,Term2,Unifier) :- + empty_ds(S0), + subsumes_aux(Term1,Term2,S0,S), + ds_to_list(S,L), + build_unifier(L,Unifier). + +subsumes_aux(Term1, Term2, S0, S) :- + ( compound(Term2), + functor(Term2, F, N) + -> compound(Term1), functor(Term1, F, N), + subsumes_aux(N, Term1, Term2, S0, S) + ; Term1 == Term2 + -> S = S0 + ; var(Term2), + get_ds(Term1,S0,V) + -> V == Term2, S = S0 + ; var(Term2), + put_ds(Term1, S0, Term2, S) + ). + +subsumes_aux(0, _, _, S, S) :- ! . +subsumes_aux(N, T1, T2, S0, S) :- + arg(N, T1, T1x), + arg(N, T2, T2x), + subsumes_aux(T1x, T2x, S0, S1), + M is N-1, + subsumes_aux(M, T1, T2, S1, S). + +build_unifier([],[]). +build_unifier([X-V|R],[V - X | T]) :- + build_unifier(R,T). + +discover_unique_pattern(PragmaRule,RuleNb,Pattern) :- + PragmaRule = pragma(Rule,_,_Pragmas,Name,RuleNb), + Rule = rule(H1,H2,Guard,_), + ( H1 = [C1], + H2 = [C2] -> + true + ; H1 = [C1,C2], + H2 == [] -> + true + ), + check_unique_constraints(C1,C2,Guard,RuleNb,List), + term_variables(C1,Vs), + select_pragma_unique_variables(List,Vs,Key), + Pattern0 = unique(C1,Key), + copy_term_nat(Pattern0,Pattern), + ( verbosity_on -> + format('Found unique pattern ~w in rule ~d~@\n', + [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)]) + ; + true + ). + +select_pragma_unique_variables([],_,[]). +select_pragma_unique_variables([X-Y|R],Vs,L) :- + ( X == Y -> + L = [X|T] + ; + once(( + \+ memberchk_eq(X,Vs) + ; + \+ memberchk_eq(Y,Vs) + )), + L = T + ), + select_pragma_unique_variables(R,Vs,T). + +check_unique_constraints(C1,C2,G,RuleNb,List) :- + \+ any_passive_head(RuleNb), + variable_replacement(C1-C2,C2-C1,List), + copy_with_variable_replacement(G,OtherG,List), + negate_b(G,NotG), + once(entails_b(NotG,OtherG)). + +check_unnecessary_active(Constraint,Previous,Rule) :- + ( chr_pp_flag(check_unnecessary_active,full) -> + check_unnecessary_active_main(Constraint,Previous,Rule) + ; chr_pp_flag(check_unnecessary_active,simplification), + Rule = rule(_,[],_,_) -> + check_unnecessary_active_main(Constraint,Previous,Rule) + ; + fail + ). + +check_unnecessary_active_main(Constraint,Previous,Rule) :- + member(Other,Previous), + variable_replacement(Other,Constraint,List), + copy_with_variable_replacement(Rule,Rule2,List), + identical_rules(Rule,Rule2), ! . + +set_semantics_rule(PragmaRule) :- + ( chr_pp_flag(set_semantics_rule,on) -> + set_semantics_rule_main(PragmaRule) + ; + fail + ). + +set_semantics_rule_main(PragmaRule) :- + PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb), + Rule = rule([C1],[C2],true,_), + IDs = ids([ID1],[ID2]), + once(member(unique(ID1,L1),Pragmas)), + once(member(unique(ID2,L2),Pragmas)), + L1 == L2, + \+ is_passive(RuleNb,ID1). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _____ _ _ +%% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___ +%% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \ +%% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/ +%% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___| +%% |_| +% have to check for no duplicates in value list + +% check wether two rules are identical + +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 + ; L2 = [X-Y|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). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ __ _ _ _ +%% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __ +%% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \ +%% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | | +%% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_| +%% |_| + +simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :- + PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb), + head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs), + build_head(F,A,Id,HeadVars,ClauseHead), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict1), + + ( RestHeads == [] -> + Susps = [], + VarDict = VarDict1, + GetRestHeads = [] + ; + rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict) + ), + + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest), + + gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments), + gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment), + + ( chr_pp_flag(debugable,on) -> + Rule = rule(_,_,Guard,Body), + my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + Clause = ( ClauseHead :- + FirstMatching, + RescheduledTest, + DebugTry, + !, + DebugApply, + SuspsDetachments, + SuspDetachment, + BodyCopy + ), + L = [Clause | T]. + +head_arg_matches(Pairs,VarDict,Goal,NVarDict) :- + head_arg_matches_(Pairs,VarDict,GoalList,NVarDict), + list2conj(GoalList,Goal). + +head_arg_matches_([],VarDict,[],VarDict). +head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :- + ( var(Arg) -> + ( lookup_eq(VarDict,Arg,OtherVar) -> + GoalList = [Var == OtherVar | RestGoalList], + VarDict1 = VarDict + ; VarDict1 = [Arg-Var | VarDict], + GoalList = RestGoalList + ), + Pairs = Rest + ; atomic(Arg) -> + GoalList = [ Var == Arg | RestGoalList], + VarDict = VarDict1, + Pairs = Rest + ; Arg =.. [_|Args], + functor(Arg,Fct,N), + functor(Term,Fct,N), + Term =.. [_|Vars], + GoalList =[ nonvar(Var), Var = Term | RestGoalList ], + pairup(Args,Vars,NewPairs), + append(NewPairs,Rest,Pairs), + VarDict1 = VarDict + ), + head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict). + +rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):- + rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]). + +rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :- + ( Heads = [_|_] -> + rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict) + ; + GoalList = [], + Susps = [], + VarDict = NVarDict + ). + +rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :- + instantiate_pattern_goals(AttrDict). +rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :- + functor(H,F,A), + get_store_type(F/A,StoreType), + ( StoreType == default -> + passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict), + get_max_constraint_index(N), + ( N == 1 -> + VarSusps = Attr + ; + get_constraint_index(F/A,Pos), + make_attr(N,_Mask,SuspsList,Attr), + nth1(Pos,SuspsList,VarSusps) + ) + ; + lookup_passive_head(StoreType,H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps), + NewAttrDict = AttrDict + ), + head_info(H,A,Vars,_,_,Pairs), + head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1), + Suspension =.. [suspension,_,State,_,_,_,_|Vars], + different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals), + create_get_mutable_ref(active,State,GetMutable), + Goal1 = + ( + 'chr sbag_member'(Susp,VarSusps), + Susp = Suspension, + GetMutable, + DiffSuspGoals, + MatchingGoal + ), + ( member(unique(ID,UniqueKeus),Pragmas), + check_unique_keys(UniqueKeus,VarDict) -> + Goal = (Goal1 -> true) + ; + Goal = Goal1 + ), + rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict). + +instantiate_pattern_goals([]). +instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :- + get_max_constraint_index(N), + ( N == 1 -> + Goal = true + ; + make_attr(N,Mask,_,Attr), + or_list(Bits,Pattern), !, + Goal = (Mask /\ Pattern =:= Pattern) + ), + instantiate_pattern_goals(Rest). + + +check_unique_keys([],_). +check_unique_keys([V|Vs],Dict) :- + lookup_eq(Dict,V,_), + check_unique_keys(Vs,Dict). + +% Generates tests to ensure the found constraint differs from previously found constraints +% TODO: detect more cases where constraints need be different +different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :- + ( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) -> + list2conj(DiffSuspGoalList,DiffSuspGoals) + ; + DiffSuspGoals = true + ). + +passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :- + functor(Head,F,A), + get_constraint_index(F/A,Pos), + common_variables(Head,PrevHeads,CommonVars), + translate(CommonVars,VarDict,Vars), + or_pattern(Pos,Bit), + ( permutation(Vars,PermutedVars), + lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) -> + member(Bit,Positions), !, + NewAttrDict = AttrDict, + Goal = true + ; + Goal = (Goal1, PatternGoal), + gen_get_mod_constraints(Vars,Goal1,Attr), + NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict] + ). + +common_variables(T,Ts,Vs) :- + term_variables(T,V1), + term_variables(Ts,V2), + intersect_eq(V1,V2,Vs). + +gen_get_mod_constraints(L,Goal,Susps) :- + get_target_module(Mod), + ( L == [] -> + Goal = + ( 'chr default_store'(Global), + get_attr(Global,Mod,TSusps), + TSusps = Susps + ) + ; + ( L = [A] -> + VIA = 'chr via_1'(A,V) + ; ( L = [A,B] -> + VIA = 'chr via_2'(A,B,V) + ; VIA = 'chr via'(L,V) + ) + ), + Goal = + ( VIA, + get_attr(V,Mod,TSusps), + TSusps = Susps + ) + ). + +guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :- + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + list2conj(GuardCopyList,GuardCopy). + +guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :- + Rule = rule(_,_,Guard,Body), + conj2list(Guard,GuardList), + split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList), + my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore), + + append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList), + term_variables(RestGuardList,GuardVars), + term_variables(RestGuardListCopyCore,GuardCopyVars), + ( chr_pp_flag(guard_locks,on), + find_with_var_identity(('chr lock'(Y)) - ('chr unlock'(Y)), + VarDict, + (member(X,GuardVars), % X is a variable appearing in the original guard + lookup_eq(VarDict,X,Y), % translate X into new variable + memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible? + ), + LocksUnlocks) + + -> + once(pairup(Locks,Unlocks,LocksUnlocks)) + ; + Locks = [], + Unlocks = [] + ), + list2conj(Locks,LockPhase), + list2conj(Unlocks,UnlockPhase), + list2conj(RestGuardListCopyCore,RestGuardCopyCore), + RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)), + my_term_copy(Body,VarDict2,BodyCopy). + + +split_off_simple_guard([],_,[],[]). +split_off_simple_guard([G|Gs],VarDict,S,C) :- + ( simple_guard(G,VarDict) -> + S = [G|Ss], + split_off_simple_guard(Gs,VarDict,Ss,C) + ; + S = [], + C = [G|Gs] + ). + +% simple guard: cheap and benign (does not bind variables) +simple_guard(G,VarDict) :- + binds_b(G,Vars), + not(( member(V,Vars), + lookup_eq(VarDict,V,_) + )). + +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). + +gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :- + ( is_attached(FA) -> + ( Id == [0], \+ may_trigger(FA) -> + SuspDetachment = true + ; + gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment), + SuspDetachment = + ( var(Susp) -> + true + ; UnCondSuspDetachment + ) + ) + ; + SuspDetachment = true + ). + +gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :- + ( is_attached(FA) -> + ( may_trigger(FA) -> + make_name('detach_',FA,Fct), + Detach =.. [Fct,Vars,Susp] + ; + Detach = true + ), + ( chr_pp_flag(debugable,on) -> + DebugEvent = 'chr debug_event'(remove(Susp)) + ; + DebugEvent = true + ), + generate_delete_constraint_call(FA,Susp,DeleteCall), + SuspDetachment = + ( + DebugEvent, + remove_constraint_internal(Susp, Vars, Delete), + ( Delete == yes -> + DeleteCall, + Detach + ; + true + ) + ) + ; + SuspDetachment = true + ). + +gen_uncond_susps_detachments([],[],true). +gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :- + functor(Term,F,A), + gen_uncond_susp_detachment(Susp,F/A,SuspDetachment), + gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ _ +%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / | +%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | | +%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | | +%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_| +%% |_| |___/ + +simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :- + PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb), + Rule = rule(_Heads,Heads2,Guard,Body), + + head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict1), + + build_head(F,A,Id,HeadVars,ClauseHead), + + append(RestHeads,Heads2,Heads), + append(OtherIDs,Heads2IDs,IDs), + reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs), + rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict), + split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2), + + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest), + + gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments), + gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment), + + ( chr_pp_flag(debugable,on) -> + my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + Clause = ( ClauseHead :- + FirstMatching, + RescheduledTest, + DebugTry, + !, + DebugApply, + SuspsDetachments, + SuspDetachment, + BodyCopy + ), + L = [Clause | T]. + +split_by_ids([],[],_,[],[]). +split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :- + ( memberchk_eq(I,I1s) -> + S1s = [S | R1s], + S2s = R2s + ; + S1s = R1s, + S2s = [S | R2s] + ), + split_by_ids(Is,Ss,I1s,R1s,R2s). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ ____ +%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \ +%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) | +%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/ +%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____| +%% |_| |___/ + +%% Genereate prelude + worker predicate +%% prelude calls worker +%% worker iterates over one type of removed constraints +simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :- + PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name,RuleNb), + Rule = rule(Heads1,_,Guard,Body), + reorder_heads(RuleNb,Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1], + % IDs1 = [ID1|RestIDs1], + simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1), + extend_id(Id,Id2), + simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,PragmaRule,FA,Id2,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id1,VarsSusp,ClauseHead), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict), + + lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps), + + gen_allocation(Id1,Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal), + + extend_id(Id1,DelegateId), + extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars), + append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars), + build_head(F,A,DelegateId,DelegateCallVars,Delegate), + + PreludeClause = + ( ClauseHead :- + FirstMatching, + ModConstraintsGoal, + !, + ConstraintAllocationGoal, + Delegate + ), + L = [PreludeClause|T]. + +extra_active_delegate_variables(Term,Terms,VarDict,Vars) :- + Term =.. [_|Args], + delegate_variables(Term,Terms,VarDict,Args,Vars). + +passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :- + term_variables(PrevTerms,PrevVars), + delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars). + +delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :- + term_variables(Term,V1), + term_variables(Terms,V2), + intersect_eq(V1,V2,V3), + list_difference_eq(V3,PrevVars,V4), + translate(V4,VarDict,Vars). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L,T) :- + PragmaRule = pragma(Rule,_,_,_,_), + Rule = rule(_,_,Guard,Body), + simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1), + simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,F/A,Id,L,T) :- + gen_var(OtherSusp), + gen_var(OtherSusps), + + head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs), + head_arg_matches(Head2Pairs,[],_,VarDict1), + + PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb), + Rule = rule(_,_,Guard,Body), + extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars), + append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars), + build_head(F,A,Id,HeadVars,ClauseHead), + + functor(Head1,_OtherF,OtherA), + head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs), + head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2), + + OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars], + create_get_mutable_ref(active,OtherState,GetMutable), + IteratorSuspTest = + ( OtherSusp = OtherSuspension, + GetMutable + ), + + ( (RestHeads1 \== [] ; RestHeads2 \== []) -> + append(RestHeads1,RestHeads2,RestHeads), + append(IDs1,IDs2,IDs), + reorder_heads(RuleNb,Head1-Head2,RestHeads,IDs,NRestHeads,NIDs), + rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]), + split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2) + ; RestSuspsRetrieval = [], + Susps1 = [], + Susps2 = [], + VarDict = VarDict2 + ), + + gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments), + + append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars), + build_head(F,A,Id,RecursiveVars,RecursiveCall), + append([[]|VarsSusp],ExtraVars,RecursiveVars2), + build_head(F,A,Id,RecursiveVars2,RecursiveCall2), + + guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy), + guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest), + ( BodyCopy \== true -> + gen_uncond_attach_goal(F/A,Susp,Attachment,Generation), + gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall), + gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2) + ; Attachment = true, + ConditionalRecursiveCall = RecursiveCall, + ConditionalRecursiveCall2 = RecursiveCall2 + ), + + ( chr_pp_flag(debugable,on) -> + my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + ( member(unique(ID1,UniqueKeys), Pragmas), + check_unique_keys(UniqueKeys,VarDict1) -> + Clause = + ( ClauseHead :- + ( IteratorSuspTest, + FirstMatching -> + ( RescheduledTest, + DebugTry -> + DebugApply, + Susps1Detachments, + Attachment, + BodyCopy, + ConditionalRecursiveCall2 + ; + RecursiveCall2 + ) + ; + RecursiveCall + ) + ) + ; + Clause = + ( ClauseHead :- + ( IteratorSuspTest, + FirstMatching, + RescheduledTest, + DebugTry -> + DebugApply, + Susps1Detachments, + Attachment, + BodyCopy, + ConditionalRecursiveCall + ; + RecursiveCall + ) + ) + ), + L = [Clause | T]. + +gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :- + length(Args,N), + Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args], + create_get_mutable_ref(active,State,GetState), + create_get_mutable_ref(Generation,NewGeneration,GetGeneration), + ConditionalCall = + ( Susp = Suspension, + GetState, + GetGeneration -> + 'chr update_mutable'(inactive,State), + Call + ; true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :- + head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs), + head_arg_matches(Pairs,[],_,VarDict), + extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars), + append([[]|VarsSusp],ExtraVars,HeadVars), + build_head(F,A,Id,HeadVars,ClauseHead), + next_id(Id,ContinuationId), + build_head(F,A,ContinuationId,VarsSusp,ContinuationHead), + Clause = ( ClauseHead :- ContinuationHead ), + L = [Clause | T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ +%% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ +%% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ +%% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | | +%% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| +%% |_| |___/ + +propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :- + ( RestHeads == [] -> + propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T) + ; + propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) + ). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Single headed propagation +%% everything in a single clause +propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id,VarsSusp,ClauseHead), + + inc_id(Id,NextId), + build_head(F,A,NextId,VarsSusp,NextHead), + + NextCall = NextHead, + + head_arg_matches(HeadPairs,[],HeadMatching,VarDict), + guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), + gen_allocation(Id,Vars,Susp,F/A,VarsSusp,Allocation), + gen_uncond_attach_goal(F/A,Susp,Attachment,Generation), + + gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall), + + ( chr_pp_flag(debugable,on) -> + Rule = rule(_,_,Guard,Body), + my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + Clause = ( + ClauseHead :- + HeadMatching, + Allocation, + 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp) + GuardCopy, + DebugTry, + !, + DebugApply, + 'chr extend_history'(Susp,RuleNb), + Attachment, + BodyCopy, + ConditionalNextCall + ), + L = [Clause | T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% multi headed propagation +%% prelude + predicates to accumulate the necessary combinations of suspended +%% constraints + predicate to execute the body +propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :- + RestHeads = [First|Rest], + propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1), + extend_id(Id,ExtendedId), + propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :- + head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), + build_head(F,A,Id,VarsSusp,PreludeHead), + head_arg_matches(HeadPairs,[],FirstMatching,VarDict), + Rule = rule(_,_,Guard,Body), + extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars), + + lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps), + + gen_allocation(Id,Vars,Susp,F/A,VarsSusp,CondAllocation), + + extend_id(Id,NestedId), + append([Susps|VarsSusp],ExtraVars,NestedVars), + build_head(F,A,NestedId,NestedVars,NestedHead), + NestedCall = NestedHead, + + Prelude = ( + PreludeHead :- + FirstMatching, + FirstSuspGoal, + !, + CondAllocation, + NestedCall + ), + L = [Prelude|T]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :- + propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1), + propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T). + +propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :- + propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1), + propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2), + inc_id(Id,IncId), + propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T). + +propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps), + gen_var(OtherSusp), + gen_var(OtherSusps), + functor(CurrentHead,_OtherF,OtherA), + gen_vars(OtherA,OtherVars), + Suspension =.. [suspension,_,State,_,_,_,_|OtherVars], + create_get_mutable_ref(active,State,GetMutable), + CurrentSuspTest = ( + OtherSusp = Suspension, + GetMutable + ), + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,Id,ClauseVars,ClauseHead), + RecursiveVars = [OtherSusps|PreVarsAndSusps], + build_head(F,A,Id,RecursiveVars,RecursiveHead), + RecursiveCall = RecursiveHead, + CurrentHead =.. [_|OtherArgs], + pairup(OtherArgs,OtherVars,OtherPairs), + head_arg_matches(OtherPairs,VarDict1,Matching,VarDict), + + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals), + + guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), + gen_uncond_attach_goal(F/A,Susp,Attach,Generation), + gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall), + + history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps), + bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList), + list2conj(NovelProductionsList,NovelProductions), + Tuple =.. [t,RuleNb|HistorySusps], + + ( chr_pp_flag(debugable,on) -> + Rule = rule(_,_,Guard,Body), + my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody), + DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)), + DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)) + ; + DebugTry = true, + DebugApply = true + ), + + Clause = ( + ClauseHead :- + ( CurrentSuspTest, + DiffSuspGoals, + Matching, + TupleVar = Tuple, + NovelProductions, + GuardCopy, + DebugTry -> + DebugApply, + 'chr extend_history'(Susp,TupleVar), + Attach, + BodyCopy, + ConditionalRecursiveCall + ; RecursiveCall + ) + ), + L = [Clause|T]. + +history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :- + ( Count == 0 -> + reverse(OtherSusps,ReversedSusps), + append(ReversedSusps,[Susp|Acc],HistorySusps) + ; + OtherSusps = [OtherSusp|RestOtherSusps], + NCount is Count - 1, + history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps) + ). + +get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :- + !, + functor(Head,_F,A), + head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), + head_arg_matches(Pairs,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :- + get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps), + functor(Head,_F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs), + head_arg_matches(Pairs,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps). + +propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp), + + Vars = [ [] | VarsAndSusps], + + build_head(F,A,Id,Vars,Head), + + ( Id = [0|_] -> + next_id(Id,PrevId), + PrevVarsAndSusps = AllButFirst + ; + dec_id(Id,PrevId), + PrevVarsAndSusps = [FirstSusp|AllButFirst] + ), + + build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead), + PredecessorCall = PrevHead, + + Clause = ( + Head :- + PredecessorCall + ), + L = [Clause | T]. + +gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :- + !, + functor(Head,_F,A), + head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :- + gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_), + functor(Head,_F,A), + gen_var(Susps), + head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,Susps|Rest],VarsSusps). + +propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :- + Rule = rule(_,_,Guard,Body), + pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps), + gen_var(OtherSusps), + functor(CurrentHead,_OtherF,OtherA), + gen_vars(OtherA,OtherVars), + head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1), + + OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars], + + different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), + create_get_mutable_ref(active,State,GetMutable), + CurrentSuspTest = ( + OtherSusp = OtherSuspension, + GetMutable, + DiffSuspGoals, + FirstMatching + ), + lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps), + inc_id(Id,NestedId), + ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], + build_head(F,A,Id,ClauseVars,ClauseHead), + passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars), + append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars), + build_head(F,A,NestedId,NestedVars,NestedHead), + + RecursiveVars = [OtherSusps|PreVarsAndSusps], + build_head(F,A,Id,RecursiveVars,RecursiveHead), + Clause = ( + ClauseHead :- + ( CurrentSuspTest, + NextSuspGoal + -> + NestedHead + ; RecursiveHead + ) + ), + L = [Clause|T]. + +pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :- + !, + functor(Head,_F,A), + head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,[],_,VarDict), + extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars), + append(VarsSusp,ExtraVars,HeadVars). +pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :- + pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps), + functor(Head,_F,A), + gen_var(NextSusps), + head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), + head_arg_matches(HeadPairs,VarDict,_,NVarDict), + passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), + append(HeadVars,[Susp,NextSusps|VSs],NVSs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ____ _ _ _ _ +%% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| | +%% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` | +%% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| | +%% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_| +%% +%% ____ _ _ _ +%% | _ \ ___| |_ _ __(_) _____ ____ _| | +%% | |_) / _ \ __| '__| |/ _ \ \ / / _` | | +%% | _ < __/ |_| | | | __/\ V / (_| | | +%% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_| +%% +%% ____ _ _ +%% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _ +%% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` | +%% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| | +%% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, | +%% |___/ + +reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- + ( chr_pp_flag(reorder_heads,on) -> + reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) + ; + NRestHeads = RestHeads, + NRestIDs = RestIDs + ). + +reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- + term_variables(Head,Vars), + InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb), + a_star(InitialData,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData), + FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_), + reverse(RNRestHeads,NRestHeads), + reverse(RNRestIDs,NRestIDs). + +final_data(Entry) :- + Entry = entry(_,_,_,_,[],_). + +expand_data(Entry,NEntry,Cost) :- + Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb), + term_variables(Entry,EVars), + NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb), + select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1), + order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost), + term_variables([Head1|Vars],Vars1). + +order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :- + functor(Head,F,A), + get_store_type(F/A,StoreType), + order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score). + +order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :- + term_variables(Head,HeadVars), + term_variables(RestHeads,RestVars), + order_score_vars(HeadVars,KnownVars,RestHeads,0,Score). +order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :- + order_score_indexes(Indexes,Head,KnownVars,0,Score). +order_score(global_ground,Head,ID,_KnownVars,_RestHeads,RuleNb,Score) :- + functor(Head,F,A), + ( get_pragma_unique(RuleNb,ID,Vars), + Vars == [] -> + Score = 1 % guaranteed O(1) + ; A == 0 -> % flag constraint + Score = 10 % O(1)? [CHECK: no deleted/triggered/... constraints in store?] + ; A > 0 -> + Score = 100 + ). + +order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :- + find_with_var_identity( + S, + t(Head,KnownVars,RestHeads), + ( member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ), + Scores + ), + min_list(Scores,Score). + + +order_score_indexes([],_,_,Score,Score) :- + Score > 0. +order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :- + multi_hash_key_args(I,Head,Args), + ( forall(Arg,Args,hprolog:memberchk_eq(Arg,KnownVars)) -> + Score1 is Score + 10 + ; + Score1 = Score + ), + order_score_indexes(Is,Head,KnownVars,Score1,NScore). + +order_score_vars([],_,_,Score,NScore) :- + ( Score == 0 -> + NScore = 0 + ; + NScore = Score + ). +order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :- + ( memberchk_eq(V,KnownVars) -> + TScore is Score + 10 + ; memberchk_eq(V,RestVars) -> + TScore is Score + 100 + ; + TScore = Score + ), + order_score_vars(Vs,KnownVars,RestVars,TScore,NScore). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% ___ _ _ _ +%% |_ _|_ __ | (_)_ __ (_)_ __ __ _ +%% | || '_ \| | | '_ \| | '_ \ / _` | +%% | || | | | | | | | | | | | | (_| | +%% |___|_| |_|_|_|_| |_|_|_| |_|\__, | +%% |___/ + +%% SWI begin +create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)). +%% SWI end + +%% SICStus begin +%% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M). +%% SICStus end + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% _ _ _ _ _ _ _ +%% | | | | |_(_) (_) |_ _ _ +%% | | | | __| | | | __| | | | +%% | |_| | |_| | | | |_| |_| | +%% \___/ \__|_|_|_|\__|\__, | +%% |___/ + +gen_var(_). +gen_vars(N,Xs) :- + length(Xs,N). + +head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :- + vars_susp(A,Vars,Susp,VarsSusp), + Head =.. [_|Args], + pairup(Args,Vars,HeadPairs). + +inc_id([N|Ns],[O|Ns]) :- + O is N + 1. +dec_id([N|Ns],[M|Ns]) :- + M is N - 1. + +extend_id(Id,[0|Id]). + +next_id([_,N|Ns],[O|Ns]) :- + O is N + 1. + +build_head(F,A,Id,Args,Head) :- + buildName(F,A,Id,Name), + Head =.. [Name|Args]. + +buildName(Fct,Aty,List,Result) :- + atom_concat(Fct, (/) ,FctSlash), + atomic_concat(FctSlash,Aty,FctSlashAty), + buildName_(List,FctSlashAty,Result). + +buildName_([],Name,Name). +buildName_([N|Ns],Name,Result) :- + buildName_(Ns,Name,Name1), + atom_concat(Name1,'__',NameDash), % '_' is a char :-( + atomic_concat(NameDash,N,Result). + +vars_susp(A,Vars,Susp,VarsSusp) :- + length(Vars,A), + append(Vars,[Susp],VarsSusp). + +make_attr(N,Mask,SuspsList,Attr) :- + length(SuspsList,N), + Attr =.. [v,Mask|SuspsList]. + +or_pattern(Pos,Pat) :- + Pow is Pos - 1, + Pat is 1 << Pow. % was 2 ** X + +and_pattern(Pos,Pat) :- + X is Pos - 1, + Y is 1 << X, % was 2 ** X + Pat is (-1)*(Y + 1). % because fx (-) is redefined + +conj2list(Conj,L) :- %% transform conjunctions to list + conj2list(Conj,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) + ). + +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) + ). + +atom_concat_list([X],X) :- ! . +atom_concat_list([X|Xs],A) :- + atom_concat_list(Xs,B), + atomic_concat(X,B,A). + +make_name(Prefix,F/A,Name) :- + atom_concat_list([Prefix,F,(/),A],Name). + +set_elems([],_). +set_elems([X|Xs],X) :- + set_elems(Xs,X). + +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). + +pair_all_with([],_,[]). +pair_all_with([X|Xs],Y,[X-Y|Rest]) :- + pair_all_with(Xs,Y,Rest). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :- + functor(Head,F,A), + get_store_type(F/A,StoreType), + lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps). + +lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :- + passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict), + instantiate_pattern_goals(AttrDict), + get_max_constraint_index(N), + ( N == 1 -> + AllSusps = Attr + ; + functor(Head,F,A), + get_constraint_index(F/A,Pos), + make_attr(N,_,SuspsList,Attr), + nth1(Pos,SuspsList,AllSusps) + ). +lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :- + once(( + member(Index,Indexes), + multi_hash_key_args(Index,Head,KeyArgs), + translate(KeyArgs,VarDict,KeyArgCopies) + )), + ( KeyArgCopies = [KeyCopy] -> + true + ; + KeyCopy =.. [k|KeyArgCopies] + ), + functor(Head,F,A), + multi_hash_via_lookup_name(F/A,Index,ViaName), + Goal =.. [ViaName,KeyCopy,AllSusps], + update_store_type(F/A,multi_hash([Index])). +lookup_passive_head(global_ground,Head,PreJoin,_VarDict,Goal,AllSusps) :- + functor(Head,F,A), + global_ground_store_name(F/A,StoreName), + make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps), + update_store_type(F/A,global_ground). +lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :- + once(( + member(ST,StoreTypes), + lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps) + )). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +assume_constraint_stores([]). +assume_constraint_stores([C|Cs]) :- + ( \+ may_trigger(C), + is_attached(C), + get_store_type(C,default) -> + get_indexed_arguments(C,IndexedArgs), + findall(Index,(sublist(Index,IndexedArgs), Index \== []),Indexes), + assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground])) + ; + true + ), + assume_constraint_stores(Cs). + +get_indexed_arguments(C,IndexedArgs) :- + C = F/A, + get_indexed_arguments(1,A,C,IndexedArgs). + +get_indexed_arguments(I,N,C,L) :- + ( I > N -> + L = [] + ; ( is_indexed_argument(C,I) -> + L = [I|T] + ; + L = T + ), + J is I + 1, + get_indexed_arguments(J,N,C,T) + ). + +validate_store_type_assumptions([]). +validate_store_type_assumptions([C|Cs]) :- + validate_store_type_assumption(C), + validate_store_type_assumptions(Cs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% SWI begin +verbosity_on :- prolog_flag(verbose,V), V == yes. +%% SWI end + +%% SICStus begin +%% verbosity_on. % at the moment +%% SICStus end diff --git a/packages/chr/clean_code.pl b/packages/chr/clean_code.pl new file mode 100644 index 000000000..d354e588a --- /dev/null +++ b/packages/chr/clean_code.pl @@ -0,0 +1,249 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +% ____ _ ____ _ _ +% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _ +% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` | +% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| | +% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, | +% |___/ +% +% To be done: +% inline clauses + +:- module(clean_code, + [ + clean_clauses/2 + ]). + +:- use_module(library(dialect/hprolog)). + +clean_clauses(Clauses,NClauses) :- + clean_clauses1(Clauses,Clauses1), + merge_clauses(Clauses1,NClauses). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% CLEAN CLAUSES +% +% - move neck unification into the head of the clause +% - drop true body +% - specialize control flow goal wrt true and fail +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +clean_clauses1([],[]). +clean_clauses1([C|Cs],[NC|NCs]) :- + clean_clause(C,NC), + clean_clauses1(Cs,NCs). + +clean_clause(Clause,NClause) :- + ( Clause = (Head :- Body) -> + clean_goal(Body,Body1), + move_unification_into_head(Head,Body1,NHead,NBody), + ( NBody == true -> + NClause = NHead + ; + NClause = (NHead :- NBody) + ) + ; Clause = '$source_location'(File,Line) : ActualClause -> + NClause = '$source_location'(File,Line) : NActualClause, + clean_clause(ActualClause,NActualClause) + ; + NClause = Clause + ). + +clean_goal(Goal,NGoal) :- + var(Goal), !, + NGoal = Goal. +clean_goal((G1,G2),NGoal) :- + !, + clean_goal(G1,NG1), + clean_goal(G2,NG2), + ( NG1 == true -> + NGoal = NG2 + ; NG2 == true -> + NGoal = NG1 + ; + NGoal = (NG1,NG2) + ). +clean_goal((If -> Then ; Else),NGoal) :- + !, + clean_goal(If,NIf), + ( NIf == true -> + clean_goal(Then,NThen), + NGoal = NThen + ; NIf == fail -> + clean_goal(Else,NElse), + NGoal = NElse + ; + clean_goal(Then,NThen), + clean_goal(Else,NElse), + NGoal = (NIf -> NThen; NElse) + ). +clean_goal((G1 ; G2),NGoal) :- + !, + clean_goal(G1,NG1), + clean_goal(G2,NG2), + ( NG1 == fail -> + NGoal = NG2 + ; NG2 == fail -> + NGoal = NG1 + ; + NGoal = (NG1 ; NG2) + ). +clean_goal(once(G),NGoal) :- + !, + clean_goal(G,NG), + ( NG == true -> + NGoal = true + ; NG == fail -> + NGoal = fail + ; + NGoal = once(NG) + ). +clean_goal((G1 -> G2),NGoal) :- + !, + clean_goal(G1,NG1), + ( NG1 == true -> + clean_goal(G2,NGoal) + ; NG1 == fail -> + NGoal = fail + ; + clean_goal(G2,NG2), + NGoal = (NG1 -> NG2) + ). +clean_goal(Goal,Goal). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +move_unification_into_head(Head,Body,NHead,NBody) :- + conj2list(Body,BodyList), + move_unification_into_head_(BodyList,Head,NHead,NBody). + +move_unification_into_head_([],Head,Head,true). +move_unification_into_head_([G|Gs],Head,NHead,NBody) :- + ( nonvar(G), G = (X = Y) -> + term_variables(Gs,GsVars), + ( var(X), ( \+ memberchk_eq(X,GsVars) ; atomic(Y)) -> + X = Y, + move_unification_into_head_(Gs,Head,NHead,NBody) + ; var(Y), (\+ memberchk_eq(Y,GsVars) ; atomic(X)) -> + X = Y, + move_unification_into_head_(Gs,Head,NHead,NBody) + ; + Head = NHead, + list2conj([G|Gs],NBody) + ) + ; + Head = NHead, + list2conj([G|Gs],NBody) + ). + + +conj2list(Conj,L) :- %% transform conjunctions to list + conj2list(Conj,L,[]). + +conj2list(G,L,T) :- + var(G), !, + L = [G|T]. +conj2list(true,L,L) :- !. +conj2list(Conj,L,T) :- + Conj = (G1,G2), !, + conj2list(G1,L,T1), + conj2list(G2,T1,T). +conj2list(G,[G | T],T). + +list2conj([],true). +list2conj([G],X) :- !, X = G. +list2conj([G|Gs],C) :- + ( G == true -> %% remove some redundant trues + list2conj(Gs,C) + ; + C = (G,R), + list2conj(Gs,R) + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% MERGE CLAUSES +% +% Find common prefixes of successive clauses and share them. +% +% Note: we assume that the prefix does not generate a side effect. +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +merge_clauses([],[]). +merge_clauses([C],[C]). +merge_clauses([X,Y|Clauses],NClauses) :- + ( merge_two_clauses(X,Y,Clause) -> + merge_clauses([Clause|Clauses],NClauses) + ; + NClauses = [X|RClauses], + merge_clauses([Y|Clauses],RClauses) + ). + +merge_two_clauses('$source_location'(F1,L1) : C1, + '$source_location'(_F2,_L2) : C2, + Result) :- !, + merge_two_clauses(C1,C2,C), + Result = '$source_location'(F1,L1) : C. +merge_two_clauses((H1 :- B1), (H2 :- B2), (H :- B)) :- + H1 =@= H2, + H1 = H, + conj2list(B1,List1), + conj2list(B2,List2), + merge_lists(List1,List2,H1,H2,Unifier,List,NList1,NList2), + List \= [], + H1 = H2, + call(Unifier), + list2conj(List,Prefix), + list2conj(NList1,NB1), + ( NList2 == (!) -> + B = Prefix + ; + list2conj(NList2,NB2), + B = (Prefix,(NB1 ; NB2)) + ). + +merge_lists([],[],_,_,true,[],[],[]). +merge_lists([],L2,_,_,true,[],[],L2). +merge_lists([!|Xs],_,_,_,true,[!|Xs],[],!) :- !. +merge_lists([X|Xs],[],_,_,true,[],[X|Xs],[]). +merge_lists([X|Xs],[Y|Ys],H1,H2,Unifier,Common,N1,N2) :- + ( H1-X =@= H2-Y -> + Unifier = (X = Y, RUnifier), + Common = [X|NCommon], + merge_lists(Xs,Ys,H1/X,H2/Y,RUnifier,NCommon,N1,N2) + ; + Unifier = true, + Common = [], + N1 = [X|Xs], + N2 = [Y|Ys] + ). diff --git a/packages/chr/configure.in b/packages/chr/configure.in new file mode 100644 index 000000000..2386d10fc --- /dev/null +++ b/packages/chr/configure.in @@ -0,0 +1,15 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_INIT(install-sh) +AC_PREREQ([2.50]) + +AC_ARG_ENABLE(chr, + [ --enable-chr install chr library ], + use_chr="$enableval", use_chr=yes) + + +AC_CONFIG_HEADER(config.h) + +m4_include([../ac_swi_noc.m4]) + +AC_OUTPUT(Makefile) diff --git a/packages/chr/find.pl b/packages/chr/find.pl new file mode 100644 index 000000000..c48555924 --- /dev/null +++ b/packages/chr/find.pl @@ -0,0 +1,79 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Bart Demoen, Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +%% @addtogroup CHR_in_YAP_Programs +% +% CHR controlling the compiler +% +:- module(chr_find, + [ + find_with_var_identity/4, + forall/3, + forsome/3 + ]). + +:- use_module(library(lists)). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- meta_predicate + find_with_var_identity(?, +, :, -), + forall(-, +, :), + forsome(-, +, :). + +find_with_var_identity(Template, IdVars, Goal, Answers) :- + Key = foo(IdVars), + copy_term_nat(Template-Key-Goal,TemplateC-KeyC-GoalC), + findall(KeyC - TemplateC, GoalC, As), + smash(As,Key,Answers). + +smash([],_,[]). +smash([Key-T|R],Key,[T|NR]) :- smash(R,Key,NR). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +forall(X,L,G) :- + \+ (member(X,L), \+ call(G)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +forsome(X,L,G) :- + member(X,L), + call(G), !. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +:- dynamic + user:goal_expansion/2. +:- multifile + user:goal_expansion/2. + +user:goal_expansion(forall(Element,List,Test), GoalOut) :- + nonvar(Test), + Test =.. [Functor,Arg], + Arg == Element, + GoalOut = once(maplist(Functor,List)). diff --git a/packages/chr/guard_entailment.chr b/packages/chr/guard_entailment.chr new file mode 100644 index 000000000..6338cd64d --- /dev/null +++ b/packages/chr/guard_entailment.chr @@ -0,0 +1,511 @@ +:- module(guard_entailment, + [ entails_guard/2, + simplify_guards/5 + ]). +:- include(chr_op). +:- use_module(library(dialect/hprolog)). +:- use_module(builtins). +:- use_module(chr_compiler_errors). +:- chr_option(debug, off). +:- chr_option(optimize, full). +:- chr_option(verbosity,off). +%:- chr_option(dynattr,on). +:- chr_constraint known/1, test/1, cleanup/0, variables/1. +entails_guard(A, B) :- + copy_term_nat((A, B), (C, F)), + term_variables(C, D), + variables(D), + sort(C, E), + entails_guard2(E), !, + test(F), !, + cleanup. +entails_guard2([]). +entails_guard2([A|B]) :- + known(A), + entails_guard2(B). +simplify_guards(A, H, B, G, I) :- + copy_term_nat((A, B), (C, E)), + term_variables(C, D), + variables(D), + sort(C,Z), + entails_guard2(Z), !, + simplify(E, F), + simplified(B, F, G, H, I), !, + cleanup. +simplified([], [], [], A, A). +simplified([A|B], [keep|C], [A|D], E, F) :- + simplified(B, C, D, E, F). +simplified([_|_], [fail|_], fail, A, A). +simplified([A|B], [true|L], [I|M], F, J) :- + builtins:binds_b(A, C), + term_variables(B, D), + intersect_eq(C, D, E), !, + ( E=[] + -> term_variables(F, G), + intersect_eq(C, G, H), !, + ( H=[] + -> I=true, + J=K + ; I=true, + J= (A, K) + ) + ; I=A, + J=K + ), + simplified(B, L, M, F, K). +simplify([], []). +simplify([A|D], [B|E]) :- + ( \+try(true, A) + -> B=true + ; builtins:negate_b(A, C), + ( \+try(true, C) + -> B=fail + ; B=keep + ) + ), + known(A), + simplify(D, E). +try(A, B) :- + ( known(A) + -> true + ; chr_error(internal, 'Entailment Checker: try/2.\n', []) + ), + ( test(B) + -> fail + ; true + ). +add_args_unif([], [], true). +add_args_unif([A|C], [B|D], (A=B, E)) :- + add_args_unif(C, D, E). +add_args_nunif([], [], fail). +add_args_nunif([A|C], [B|D], (A\=B;E)) :- + add_args_nunif(C, D, E). +add_args_nmatch([], [], fail). +add_args_nmatch([A|C], [B|D], (A\==B;E)) :- + add_args_nmatch(C, D, E). +all_unique_vars(A, B) :- + all_unique_vars(A, B, []). +all_unique_vars([], _, _). +all_unique_vars([A|D], B, C) :- + var(A), + \+memberchk_eq(A, B), + \+memberchk_eq(A, C), + all_unique_vars(D, [A|C]). +:- chr_constraint'test/1_1_$default'/1, 'test/1_1_$special_,/2'/2, 'test/1_1_$special_\\+/1'/1, 'test/1_1_$special_integer/1'/1, 'test/1_1_$special_float/1'/1, 'test/1_1_$special_number/1'/1, 'test/1_1_$special_ground/1'/1, 'test/1_1_$special_=:=/2'/2, 'test/1_1_$special_==/2'/2, 'test/1_1_$special_true/0'/0, 'test/1_1_$special_functor/3'/3, 'test/1_1_$special_=/2'/2, 'test/1_1_$special_;/2'/2, 'test/1_1_$special_is/2'/2, 'test/1_1_$special_=/2'/2, 'test/1_1_$special_>/2'/2, 'test/1_1_$special_=\\=/2'/2, 'test/1_1_$special_==/2'/2, 'known/1_1_$special_>/2'/2, 'known/1_1_$special_='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'test/1_1_$special_=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_$special_='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'known/1_1_$special_=B)<=>'known/1_1_$special_>=/2'(A, B). +known(A>B)<=>'known/1_1_$special_>/2'(A, B). +known(A='known/1_1_$special_='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_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_=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_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_=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_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_=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_=true. +'known/1_1_$special_=:=/2'(A, C)\'test/1_1_$special_=number(B), number(C), C=number(B), number(C), B=number(B), number(C), C=number(B), number(C), C=number(B), number(C), B>C|true. +'known/1_1_$special_=number(B), number(C), C/2'(B, A)<=>'known/1_1_$special_=/2'(B, A)<=>'known/1_1_$special_='known/1_1_$special_='known/1_1_$special_=:=/2'(A, B). +'test/1_1_$special_>/2'(B, A)<=>'test/1_1_$special_=/2'(B, A)<=>'test/1_1_$special_='test/1_1_$special_,/2'(A='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_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_=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_=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_=number(A), number(B), A>B|'known/1_1_$special_fail/0'. +'known/1_1_$special_=number(B), number(C), B=number(B), number(C), B='known/1_1_$special_=:=/2'(B, A). +'known/1_1_$special_='known/1_1_$special_='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_'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_='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_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_=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_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_=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_=A==B|true. +'test/1_1_$special_=ground(A), ground(B), A=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_true|\+try(A, B=/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_=true|\+try(A, B=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_fail. +'test/1_1_$special_>=/2'(_, _)<=>fail. +'test/1_1_$special_>/2'(_, _)<=>fail. +'test/1_1_$special_=\\=/2'(_, _)<=>fail. +'test/1_1_$special_=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_true. +cleanup\'known/1_1_$special_>=/2'(_, _)<=>true. +cleanup\'known/1_1_$special_>/2'(_, _)<=>true. +cleanup\'known/1_1_$special_=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. diff --git a/packages/chr/install-sh b/packages/chr/install-sh new file mode 100755 index 000000000..ab74c882e --- /dev/null +++ b/packages/chr/install-sh @@ -0,0 +1,238 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +tranformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/packages/chr/listmap.pl b/packages/chr/listmap.pl new file mode 100644 index 000000000..eed74855e --- /dev/null +++ b/packages/chr/listmap.pl @@ -0,0 +1,105 @@ +/* $Id$ + + Part of CHR (Constraint Handling Rules) + + Author: Tom Schrijvers + E-mail: Tom.Schrijvers@cs.kuleuven.be + WWW: http://www.swi-prolog.org + Copyright (C): 2003-2004, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(listmap, + [ + listmap_empty/1, + listmap_lookup/3, + listmap_insert/4, + listmap_remove/3, + listmap_merge/5 + ]). + +listmap_empty([]). + +listmap_lookup([K-V|R],Key,Q) :- + ( Key == K -> + Q = V + ; + Key @> K, + listmap_lookup(R,Key,Q) + ). + +listmap_insert([],Key,Value,[Key-Value]). +listmap_insert([P|R],Key,Value,ML) :- + P = K-_, + compare(C,Key,K), + ( C == (=) -> + ML = [K-Value|R] + ; C == (<) -> + ML = [Key-Value,P|R] + ; + ML = [P|Tail], + listmap_insert(R,Key,Value,Tail) + ). + +listmap_merge(ML1,ML2,F,G,ML) :- + ( ML1 == [] -> + ML = ML2 + ; ML2 == [] -> + ML = ML1 + ; + ML1 = [P1|R1], P1 = K1-V1, + ML2 = [P2|R2], P2 = K2-V2, + compare(C,K1,K2), + ( C == (=) -> + Call =.. [F,V1,V2,NV], + call(Call), + ML = [K1-NV|Tail], + listmap_merge(R1,R2,F,G,Tail) + ; C == (<) -> + Call =.. [G,V1,NV], + call(Call), + ML = [K1-NV|Tail], + listmap_merge(R1,ML2,F,G,Tail) + ; + Call =.. [G,V2,NV], + call(Call), + ML = [K2-NV|Tail], + listmap_merge(ML1,R2,F,G,Tail) + ) + ). + + +listmap_remove([],_,[]). +listmap_remove([P|R],Key,NLM) :- + P = K-_, + compare(C,Key,K), + ( C == (=) -> + NLM = R + ; C == (<) -> + NLM = [P|R] + ; + NLM = [P|Tail], + listmap_remove(R,Key,Tail) + ). + + diff --git a/packages/chr/pairlist.pl b/packages/chr/pairlist.pl new file mode 100644 index 000000000..c0971aa9b --- /dev/null +++ b/packages/chr/pairlist.pl @@ -0,0 +1,78 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% _ _ _ _ +%% _ __ __ _(_)_ __| (_)___| |_ +%% | '_ \ / _` | | '__| | / __| __| +%% | |_) | (_| | | | | | \__ \ |_ +%% | .__/ \__,_|_|_| |_|_|___/\__| +%% |_| +%% +%% * author: Tom Schrijvers + +:- module(pairlist,[ + fst_of_pairs/2, + lookup/3, + lookup_any/3, + lookup_eq/3, + lookup_any_eq/3, + pairup/3, + snd_of_pairs/2, + translate/3, + pairlist_delete_eq/3 + ]). + +fst_of_pairs([],[]). +fst_of_pairs([X-_|XYs],[X|Xs]) :- + fst_of_pairs(XYs,Xs). + +snd_of_pairs([],[]). +snd_of_pairs([_-Y|XYs],[Y|Ys]) :- + snd_of_pairs(XYs,Ys). + +pairup([],[],[]). +pairup([X|Xs],[Y|Ys],[X-Y|XYs]) :- + pairup(Xs,Ys,XYs). + +lookup([K - V | KVs],Key,Value) :- + ( K = Key -> + V = Value + ; + lookup(KVs,Key,Value) + ). + +lookup_any([K - V | KVs],Key,Value) :- + ( + K = Key, + V = Value + ; + lookup_any(KVs,Key,Value) + ). + +lookup_eq([K - V | KVs],Key,Value) :- + ( K == Key -> + V = Value + ; + lookup_eq(KVs,Key,Value) + ). + +lookup_any_eq([K - V | KVs],Key,Value) :- + ( + K == Key, + V = Value + ; + lookup_any_eq(KVs,Key,Value) + ). + +translate([],_,[]). +translate([X|Xs],Dict,[Y|Ys]) :- + lookup_eq(Dict,X,Y), + translate(Xs,Dict,Ys). + +pairlist_delete_eq([], _, []). +pairlist_delete_eq([K - V| KVs], Key, PL) :- + ( Key == K -> + PL = KVs + ; + PL = [ K - V | T ], + pairlist_delete_eq(KVs, Key, T) + ). + diff --git a/packages/clib b/packages/clib deleted file mode 160000 index a66738b77..000000000 --- a/packages/clib +++ /dev/null @@ -1 +0,0 @@ -Subproject commit a66738b770cc3c3270e19de981a596e74a871220 diff --git a/packages/clpqr b/packages/clpqr deleted file mode 160000 index 39a11c2d8..000000000 --- a/packages/clpqr +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 39a11c2d87fbd072ece4af19e5265997e06c56e1 diff --git a/packages/clpqr/ChangeLog b/packages/clpqr/ChangeLog new file mode 100644 index 000000000..76fcaf04a --- /dev/null +++ b/packages/clpqr/ChangeLog @@ -0,0 +1,63 @@ +[Sep 16 2009] + + * ENHANCED: CLP(Q/R): Correct residual goals for suspendend non-linear + constraints. + +[Aug 9 2009] + + * ENHANCED: CLP(Q/R): Working residual goals with copy_term/3. Please review. + +[Mar 30 2009] + + * FIXED: alarm handling on Win64 (Kerri Haris) + +[Nov 21 2008] + + * FIXED: wakeup issue in S_LIST and H_LIST_FF instructions. Matt Lilley. + +[Mar 30 2009] + + * FIXED: alarm handling on Win64 (Kerri Haris) + +[Nov 21 2008] + + * FIXED: wakeup issue in S_LIST and H_LIST_FF instructions. Matt Lilley. + +[Nov 21 2008] + + * FIXED: wakeup issue in S_LIST and H_LIST_FF instructions. Matt Lilley. + +Sep 10, 2006 + + * JW: Removed dependency on C/3. + +Mar 31, 2006 + + * JW: Removed SICStus ugraphs.pl and replaced by new SWI-Prolog library + +Oct 17, 2005 + + * LDK: Changed floor and ceiling operators to cope with + inaccurate floats. + +Feb 25, 2005 + + * TS: Fix for Bugzilla Bug 19 by Leslie De Koninck. + +Feb 21, 2005 + + * JW: Fixed various module imports and expanded SWI-Prolog + library(ordsets) to support all of the clp(R) library. + +Dec 16, 2004 + + * JW: Make loading parts silent + * TS: Fixed bug toplevel printing. Now only pass different + variables to dump/3. + +Dec 15, 2004 + + * JW: Added version to CVS, updated copyright notices, etc. + * TS: Added automatic printing of constraints on variables + in toplevel query. + diff --git a/packages/clpqr/Makefile.in b/packages/clpqr/Makefile.in new file mode 100755 index 000000000..d526fc33c --- /dev/null +++ b/packages/clpqr/Makefile.in @@ -0,0 +1,78 @@ +################################################################ +# SWI-Prolog CLPQR package +# Author: Jan Wielemaker. jan@swi.psy.uva.nl +# Copyright: LGPL (see COPYING or www.gnu.org +################################################################ + +PACKAGE=clpqr + +include ../Makefile.defs + +CLPDIR=$(PLLIBDIR) +CLPRDIR=$(CLPDIR)/clpr +CLPQDIR=$(CLPDIR)/clpq +CLPQRDIR=$(CLPDIR)/clpqr + +CLPRPRIV= bb_r.pl bv_r.pl \ + fourmotz_r.pl ineq_r.pl \ + itf_r.pl nf_r.pl \ + store_r.pl +CLPQPRIV= bb_q.pl bv_q.pl \ + fourmotz_q.pl ineq_q.pl \ + itf_q.pl nf_q.pl \ + store_q.pl +CLPQRPRIV= class.pl dump.pl \ + geler.pl itf.pl \ + ordering.pl \ + project.pl redund.pl +LIBPL= $(srcdir)/clpr.pl $(srcdir)/clpq.pl +EXAMPLES= + +all:: + @echo "Nothing to be done for this package" + +install: $(LIBPL) install-examples + mkdir -p $(DESTDIR)$(CLPDIR) + mkdir -p $(DESTDIR)$(CLPRDIR) + mkdir -p $(DESTDIR)$(CLPQDIR) + mkdir -p $(DESTDIR)$(CLPQRDIR) + $(INSTALL_DATA) $(LIBPL) $(DESTDIR)$(CLPDIR) + for f in $(CLPRPRIV); do $(INSTALL_DATA) $(srcdir)/clpr/$$f $(DESTDIR)$(CLPRDIR); done + for f in $(CLPQPRIV); do $(INSTALL_DATA) $(srcdir)/clpq/$$f $(DESTDIR)$(CLPQDIR); done + for f in $(CLPQRPRIV); do $(INSTALL_DATA) $(srcdir)/clpqr/$$f $(DESTDIR)$(CLPQRDIR); done + $(INSTALL_DATA) $(srcdir)/README $(DESTDIR)$(CLPQRDIR) + +ln-install:: + @$(MAKE) INSTALL_DATA=$(LN_INSTALL_DATA) INSTALL_PROGRAM=$(LN_INSTALL_PROGRAM) install + +rpm-install: install + +pdf-install: install-examples + +html-install: install-examples + +install-examples:: +# mkdir -p $(DESTDIR)$(EXDIR) +# (cd Examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR)) + +uninstall: + (cd $(CLPDIR) && rm -f $(LIBPL)) + rm -rf $(CLPRDIR) + rm -rf $(CLPQDIR) + rm -rf $(CLPQRDIR) + +check:: +# $(PL) -q -f $(srcdir)/clpr_test.pl -g test,halt -t 'halt(1)' + + +################################################################ +# Clean +################################################################ + +clean: + rm -f *~ *% config.log + +distclean: clean + rm -f config.h config.cache config.status Makefile + rm -rf autom4te.cache + diff --git a/packages/clpqr/Makefile.mak b/packages/clpqr/Makefile.mak new file mode 100644 index 000000000..550cd1e7b --- /dev/null +++ b/packages/clpqr/Makefile.mak @@ -0,0 +1,77 @@ +################################################################ +# Install CLP(R) stuff for the MS-Windows build +# Author: Jan Wielemaker +# +# Use: +# nmake /f Makefile.mak +# nmake /f Makefile.mak install +################################################################ + +PLHOME=..\.. +!include $(PLHOME)\src\rules.mk +LIBDIR=$(PLBASE)\library +EXDIR=$(PKGDOC)\examples\clpr +CLPDIR=$(LIBDIR)\clp +CLPRDIR=$(CLPDIR)\clpr +CLPQDIR=$(CLPDIR)\clpq +CLPQRDIR=$(CLPDIR)\clpqr +PL="$(PLHOME)\bin\swipl.exe" + +CLPRPRIV= bb_r.pl bv_r.pl fourmotz_r.pl ineq_r.pl \ + itf_r.pl nf_r.pl store_r.pl +CLPQPRIV= bb_q.pl bv_q.pl fourmotz_q.pl ineq_q.pl \ + itf_q.pl nf_q.pl store_q.pl +CLPQRPRIV= class.pl dump.pl geler.pl itf.pl ordering.pl \ + project.pl redund.pl +LIBPL= clpr.pl clpq.pl +EXAMPLES= + +all:: + @echo "Nothing to be done for this package" + +check:: +# $(PL) -q -f chr_test.pl -g test,halt -t 'halt(1)' + + +!IF "$(CFG)" == "rt" +install:: +!ELSE +install:: + @if not exist "$(CLPRDIR)\$(NULL)" $(MKDIR) "$(CLPRDIR)" + @if not exist "$(CLPQDIR)\$(NULL)" $(MKDIR) "$(CLPQDIR)" + @if not exist "$(CLPQRDIR)\$(NULL)" $(MKDIR) "$(CLPQRDIR)" + @for %f in ($(LIBPL)) do \ + copy "%f" "$(CLPDIR)" + @for %f in ($(CLPRPRIV)) do \ + copy "clpr\%f" "$(CLPRDIR)" + @for %f in ($(CLPQPRIV)) do \ + copy "clpq\%f" "$(CLPQDIR)" + @for %f in ($(CLPQRPRIV)) do \ + copy "clpqr\%f" "$(CLPQRDIR)" + copy README "$(CLPQRDIR)\README.TXT" +!ENDIF + +html-install: install-examples +pdf-install: install-examples + +install-examples:: +# if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)" +# cd examples & @for %f in ($(EXAMPLES)) do @copy %f "$(EXDIR)" + +xpce-install:: + +uninstall:: + @for %f in ($(LIBPL)) do \ + del "$(CLPDIR)\%f" + @for %f in ($(CLPRPRIV)) do \ + del "$(CLPRDIR)\%f" + @for %f in ($(CLPQPRIV)) do \ + del "$(CLPQDIR)\%f" + @for %f in ($(CLPQRPRIV)) do \ + del "$(CLPQRDIR)\%f" + del "$(CLPQRDIR)\README.TXT" + +clean:: + if exist *~ del *~ + +distclean: clean diff --git a/packages/clpqr/README b/packages/clpqr/README new file mode 100644 index 000000000..6acf85f3c --- /dev/null +++ b/packages/clpqr/README @@ -0,0 +1,19 @@ + SWI-Prolog CLP(Q,R) + ------------------- + +Author: Leslie De Koninck, K.U.Leuven + +This software is based on the CLP(Q,R) implementation by Christian +Holzbauer and released with permission from all above mentioned authors +and Christian Holzbauer under the standard SWI-Prolog license schema: +GPL-2 + statement to allow linking with proprietary software. + +The sources of this package are maintained in packages/clpr in the +SWI-Prolog source distribution. The documentation source is in +man/lib/clpr.doc as part of the overall SWI-Prolog documentation. + +Full documentation on CLP(Q,R) can be found at + + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + + diff --git a/packages/clpqr/clpq.pl b/packages/clpqr/clpq.pl new file mode 100644 index 000000000..4b4103dec --- /dev/null +++ b/packages/clpqr/clpq.pl @@ -0,0 +1,135 @@ +/* + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(clpq, + [ + {}/1, + maximize/1, + minimize/1, + inf/2, inf/4, sup/2, sup/4, + bb_inf/3, + bb_inf/4, + ordering/1, + entailed/1, + clp_type/2, + dump/3%, projecting_assert/1 + ]). + +:- expects_dialect(swi). + +% +% Don't report export of private predicates from clpq +% +:- multifile + user:portray_message/2. + +:- dynamic + user:portray_message/2. +% +user:portray_message(warning,import(_,_,clpq,private)). + +:- load_files( + [ + 'clpq/bb_q', + 'clpq/bv_q', + 'clpq/fourmotz_q', + 'clpq/ineq_q', + 'clpq/itf_q', + 'clpq/nf_q', + 'clpq/store_q', + 'clpqr/class', + 'clpqr/dump', + 'clpqr/geler', + 'clpqr/itf', + 'clpqr/ordering', + 'clpqr/project', + 'clpqr/redund', + library(ugraphs) + ], + [ + if(not_loaded), + silent(true) + ]). + + /******************************* + * TOPLEVEL PRINTING * + *******************************/ + +:- multifile + prolog:message/3. + +% prolog:message(query(YesNo)) --> !, +% ['~@'-[chr:print_all_stores]], +% '$messages':prolog_message(query(YesNo)). + +prolog:message(query(YesNo,Bindings)) --> !, + {dump_toplevel_bindings(Bindings,Constraints)}, + {dump_format(Constraints,Format)}, + Format, + '$messages':prolog_message(query(YesNo,Bindings)). + +dump_toplevel_bindings(Bindings,Constraints) :- + dump_vars_names(Bindings,[],Vars,Names), + dump(Vars,Names,Constraints). + +dump_vars_names([],_,[],[]). +dump_vars_names([Name=Term|Rest],Seen,Vars,Names) :- + ( var(Term), + ( get_attr(Term,itf,_) + ; get_attr(Term,geler,_) + ), + \+ memberchk_eq(Term,Seen) + -> Vars = [Term|RVars], + Names = [Name|RNames], + NSeen = [Term|Seen] + ; Vars = RVars, + Names = RNames, + Seen = NSeen + ), + dump_vars_names(Rest,NSeen,RVars,RNames). + +dump_format([],[]). +dump_format([X|Xs],['{~w}'-[X],nl|Rest]) :- + dump_format(Xs,Rest). + +memberchk_eq(X,[Y|Ys]) :- + ( X == Y + -> true + ; memberchk_eq(X,Ys) + ). diff --git a/packages/clpqr/clpq/bb_q.pl b/packages/clpqr/clpq/bb_q.pl new file mode 100644 index 000000000..75dfdbbe7 --- /dev/null +++ b/packages/clpqr/clpq/bb_q.pl @@ -0,0 +1,240 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(bb_q, + [ + bb_inf/3, + bb_inf/4, + vertex_value/2 + ]). +:- use_module(bv_q, + [ + deref/2, + deref_var/2, + determine_active_dec/1, + inf/2, + iterate_dec/2, + sup/2, + var_with_def_assign/2 + ]). +:- use_module(nf_q, + [ + {}/1, + entailed/1, + nf/2, + nf_constant/2, + repair/2, + wait_linear/3 + ]). + +% bb_inf(Ints,Term,Inf) +% +% Finds the infimum of Term where the variables Ints are to be integers. +% The infimum is stored in Inf. + +bb_inf(Is,Term,Inf) :- + bb_inf(Is,Term,Inf,_). + +bb_inf(Is,Term,Inf,Vertex) :- + wait_linear(Term,Nf,bb_inf_internal(Is,Nf,Inf,Vertex)). + +% --------------------------------------------------------------------- + +% bb_inf_internal(Is,Lin,Inf,Vertex) +% +% Finds an infimum for linear expression in normal form , where +% all variables in are to be integers. + +bb_inf_internal(Is,Lin,_,_) :- + bb_intern(Is,IsNf), + nb_delete(prov_opt), + repair(Lin,LinR), % bb_narrow ... + deref(LinR,Lind), + var_with_def_assign(Dep,Lind), + determine_active_dec(Lind), + bb_loop(Dep,IsNf), + fail. +bb_inf_internal(_,_,Inf,Vertex) :- + catch(nb_getval(prov_opt,InfVal-Vertex),_,fail), + {Inf =:= InfVal}, + nb_delete(prov_opt). + +% bb_loop(Opt,Is) +% +% Minimizes the value of Opt where variables Is have to be integer values. + +bb_loop(Opt,Is) :- + bb_reoptimize(Opt,Inf), + bb_better_bound(Inf), + vertex_value(Is,Ivs), + ( bb_first_nonint(Is,Ivs,Viol,Floor,Ceiling) + -> bb_branch(Viol,Floor,Ceiling), + bb_loop(Opt,Is) + ; nb_setval(prov_opt,Inf-Ivs) % new provisional optimum + ). + +% bb_reoptimize(Obj,Inf) +% +% Minimizes the value of Obj and puts the result in Inf. +% This new minimization is necessary as making a bound integer may yield a +% different optimum. The added inequalities may also have led to binding. + +bb_reoptimize(Obj,Inf) :- + var(Obj), + iterate_dec(Obj,Inf). +bb_reoptimize(Obj,Inf) :- + nonvar(Obj), + Inf = Obj. + +% bb_better_bound(Inf) +% +% Checks if the new infimum Inf is better than the previous one (if such exists). + +bb_better_bound(Inf) :- + catch((nb_getval(prov_opt,Inc-_),Inf < Inc),_,true). + +% bb_branch(V,U,L) +% +% Stores that V =< U or V >= L, can be used for different strategies within +% bb_loop/3. + +bb_branch(V,U,_) :- {V =< U}. +bb_branch(V,_,L) :- {V >= L}. + +% vertex_value(Vars,Values) +% +% Returns in the current values of the variables in . + +vertex_value([],[]). +vertex_value([X|Xs],[V|Vs]) :- + rhs_value(X,V), + vertex_value(Xs,Vs). + +% rhs_value(X,Value) +% +% Returns in the current value of variable . + +rhs_value(Xn,Value) :- + ( nonvar(Xn) + -> Value = Xn + ; var(Xn) + -> deref_var(Xn,Xd), + Xd = [I,R|_], + Value is R+I + ). + +% bb_first_nonint(Ints,Rhss,Eps,Viol,Floor,Ceiling) +% +% Finds the first variable in Ints which doesn't have an active integer bound. +% Rhss contain the Rhs (R + I) values corresponding to the variables. +% The first variable that hasn't got an active integer bound, is returned in +% Viol. The floor and ceiling of its actual bound is returned in Floor and Ceiling. + +bb_first_nonint([I|Is],[Rhs|Rhss],Viol,F,C) :- + ( integer(Rhs) + -> bb_first_nonint(Is,Rhss,Viol,F,C) + ; Viol = I, + F is floor(Rhs), + C is ceiling(Rhs) + ). + +% bb_intern([X|Xs],[Xi|Xis]) +% +% Turns the elements of the first list into integers into the second +% list via bb_intern/3. + +bb_intern([],[]). +bb_intern([X|Xs],[Xi|Xis]) :- + nf(X,Xnf), + bb_intern(Xnf,Xi,X), + bb_intern(Xs,Xis). + + +% bb_intern(Nf,X,Term) +% +% Makes sure that Term which is normalized into Nf, is integer. +% X contains the possibly changed Term. If Term is a variable, +% then its bounds are hightened or lowered to the next integer. +% Otherwise, it is checked it Term is integer. + +bb_intern([],X,_) :- + !, + X = 0. +bb_intern([v(I,[])],X,_) :- + !, + integer(I), + X = I. +bb_intern([v(1,[V^1])],X,_) :- + !, + V = X, + bb_narrow_lower(X), + bb_narrow_upper(X). +bb_intern(_,_,Term) :- + throw(instantiation_error(bb_inf(Term,_),1)). + +% bb_narrow_lower(X) +% +% Narrows the lower bound so that it is an integer bound. +% We do this by finding the infimum of X and asserting that X +% is larger than the first integer larger or equal to the infimum +% (second integer if X is to be strict larger than the first integer). + +bb_narrow_lower(X) :- + ( inf(X,Inf) + -> Bound is ceiling(Inf), + ( entailed(X > Bound) + -> {X >= Bound+1} + ; {X >= Bound} + ) + ; true + ). + +% bb_narrow_upper(X) +% +% See bb_narrow_lower/1. This predicate handles the upper bound. + +bb_narrow_upper(X) :- + ( sup(X,Sup) + -> Bound is floor(Sup), + ( entailed(X < Bound) + -> {X =< Bound-1} + ; {X =< Bound} + ) + ; true + ). \ No newline at end of file diff --git a/packages/clpqr/clpq/bv_q.pl b/packages/clpqr/clpq/bv_q.pl new file mode 100644 index 000000000..8a81c362c --- /dev/null +++ b/packages/clpqr/clpq/bv_q.pl @@ -0,0 +1,1760 @@ +/* + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(bv_q, + [ + allvars/2, + backsubst/3, + backsubst_delta/4, + basis_add/2, + dec_step/2, + deref/2, + deref_var/2, + detach_bounds/1, + detach_bounds_vlv/5, + determine_active_dec/1, + determine_active_inc/1, + dump_var/6, + dump_nz/5, + export_binding/1, + get_or_add_class/2, + inc_step/2, + intro_at/3, + iterate_dec/2, + lb/3, + pivot_a/4, + pivot/5, + rcbl_status/6, + reconsider/1, + same_class/2, + solve/1, + solve_ord_x/3, + ub/3, + unconstrained/4, + var_intern/2, + var_intern/3, + var_with_def_assign/2, + var_with_def_intern/4, + maximize/1, + minimize/1, + sup/2, + sup/4, + inf/2, + inf/4, + 'solve_<'/1, + 'solve_=<'/1, + 'solve_=\\='/1, + log_deref/4 + ]). +:- use_module(store_q, + [ + add_linear_11/3, + add_linear_f1/4, + add_linear_ff/5, + delete_factor/4, + indep/2, + isolate/3, + nf2sum/3, + nf_rhs_x/4, + nf_substitute/4, + normalize_scalar/2, + mult_hom/3, + mult_linear_factor/3 + ]). +:- use_module('../clpqr/class', + [ + class_allvars/2, + class_basis/2, + class_basis_add/3, + class_basis_drop/2, + class_basis_pivot/3, + class_new/5 + ]). +:- use_module(ineq_q, + [ + ineq/4 + ]). +:- use_module(nf_q, + [ + {}/1, + split/3, + wait_linear/3 + ]). +:- use_module(bb_q, + [ + vertex_value/2 + ]). +:- use_module(library(ordsets), + [ + ord_add_element/3 + ]). + +% For the rhs maint. the following events are important: +% +% -) introduction of an indep var at active bound B +% -) narrowing of active bound +% -) swap active bound +% -) pivot +% + +% a variables bound (L/U) can have the states: +% +% -) t_none no bounds +% -) t_l inactive lower bound +% -) t_u inactive upper bound +% -) t_L active lower bound +% -) t_U active upper bound +% -) t_lu inactive lower and upper bound +% -) t_Lu active lower bound and inactive upper bound +% -) t_lU inactive lower bound and active upper bound + +% ----------------------------------- deref ----------------------------------- +% + +% deref(Lin,Lind) +% +% Makes a linear equation of the form [v(I,[])|H] into a solvable linear +% equation. +% If the variables are new, they are initialized with the linear equation X=X. + +deref(Lin,Lind) :- + split(Lin,H,I), + normalize_scalar(I,Nonvar), + length(H,Len), + log_deref(Len,H,[],Restd), + add_linear_11(Nonvar,Restd,Lind). + +% log_deref(Len,[Vs|VsTail],VsTail,Res) +% +% Logarithmically converts a linear equation in normal form ([v(_,_)|_]) into a +% linear equation in solver form ([I,R,K*X|_]). Res contains the result, Len is +% the length of the part to convert and [Vs|VsTail] is a difference list +% containing the equation in normal form. + +log_deref(0,Vs,Vs,Lin) :- + !, + Lin = [0,0]. +log_deref(1,[v(K,[X^1])|Vs],Vs,Lin) :- + !, + deref_var(X,Lx), + mult_linear_factor(Lx,K,Lin). +log_deref(2,[v(Kx,[X^1]),v(Ky,[Y^1])|Vs],Vs,Lin) :- + !, + deref_var(X,Lx), + deref_var(Y,Ly), + add_linear_ff(Lx,Kx,Ly,Ky,Lin). +log_deref(N,V0,V2,Lin) :- + P is N >> 1, + Q is N - P, + log_deref(P,V0,V1,Lp), + log_deref(Q,V1,V2,Lq), + add_linear_11(Lp,Lq,Lin). + +% deref_var(X,Lin) +% +% Returns the equation of variable X. If X is a new variable, a new equation +% X = X is made. + +deref_var(X,Lin) :- + ( get_attr(X,itf,Att) + -> ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; arg(4,Att,lin(Lin)) + -> true + ; setarg(2,Att,type(t_none)), + setarg(3,Att,strictness(0)), + Lin = [0,0,l(X*1,Ord)], + setarg(4,Att,lin(Lin)), + setarg(5,Att,order(Ord)) + ) + ; Lin = [0,0,l(X*1,Ord)], + put_attr(X,itf,t(clpq,type(t_none),strictness(0), + lin(Lin),order(Ord),n,n,n,n,n,n)) + ). + +% TODO +% +% + +var_with_def_assign(Var,Lin) :- + Lin = [I,_|Hom], + ( Hom = [] + -> % X=k + Var = I + ; Hom = [l(V*K,_)|Cs] + -> ( Cs = [], + K =:= 1, + I =:= 0 + -> % X=Y + Var = V + ; % general case + var_with_def_intern(t_none,Var,Lin,0) + ) + ). + +% var_with_def_intern(Type,Var,Lin,Strictness) +% +% Makes Lin the linear equation of new variable Var, makes all variables of +% Lin, and Var of the same class and bounds Var by type(Type) and +% strictness(Strictness) + +var_with_def_intern(Type,Var,Lin,Strict) :- + put_attr(Var,itf,t(clpq,type(Type),strictness(Strict),lin(Lin), + order(_),n,n,n,n,n,n)), % check uses + Lin = [_,_|Hom], + get_or_add_class(Var,Class), + same_class(Hom,Class). + +% TODO +% +% + +var_intern(Type,Var,Strict) :- + put_attr(Var,itf,t(clpq,type(Type),strictness(Strict), + lin([0,0,l(Var*1,Ord)]),order(Ord),n,n,n,n,n,n)), + get_or_add_class(Var,_Class). + +% TODO +% +% + +var_intern(Var,Class) :- % for ordered/1 but otherwise free vars + get_attr(Var,itf,Att), + arg(2,Att,type(_)), + arg(4,Att,lin(_)), + !, + get_or_add_class(Var,Class). +var_intern(Var,Class) :- + put_attr(Var,itf,t(clpq,type(t_none),strictness(0), + lin([0,0,l(Var*1,Ord)]),order(Ord),n,n,n,n,n,n)), + get_or_add_class(Var,Class). + +% ----------------------------------------------------------------------------- + +% export_binding(Lst) +% +% Binds variables X to Y where Lst contains elements of the form [X-Y]. + +export_binding([]). +export_binding([X-Y|Gs]) :- + Y = X, + export_binding(Gs). + +% 'solve_='(Nf) +% +% Solves linear equation Nf = 0 where Nf is in normal form. + +'solve_='(Nf) :- + deref(Nf,Nfd), % dereferences and turns Nf into solvable form Nfd + solve(Nfd). + +% 'solve_=\\='(Nf) +% +% Solves linear inequality Nf =\= 0 where Nf is in normal form. + +'solve_=\\='(Nf) :- + deref(Nf,Lind), % dereferences and turns Nf into solvable form Lind + Lind = [Inhom,_|Hom], + ( Hom = [] + -> Inhom =\= 0 + ; % make new variable Nz = Lind + var_with_def_intern(t_none,Nz,Lind,0), + % make Nz nonzero + get_attr(Nz,itf,Att), + setarg(8,Att,nonzero) + ). + +% 'solve_<'(Nf) +% +% Solves linear inequality Nf < 0 where Nf is in normal form. + +'solve_<'(Nf) :- + split(Nf,H,I), + ineq(H,I,Nf,strict). + +% 'solve_=<'(Nf) +% +% Solves linear inequality Nf =< 0 where Nf is in normal form. + +'solve_=<'(Nf) :- + split(Nf,H,I), + ineq(H,I,Nf,nonstrict). + +maximize(Term) :- + minimize(-Term). + +% +% This is NOT coded as minimize(Expr) :- inf(Expr,Expr). +% +% because the new version of inf/2 only visits +% the vertex where the infimum is assumed and returns +% to the 'current' vertex via backtracking. +% The rationale behind this construction is to eliminate +% all garbage in the solver data structures produced by +% the pivots on the way to the extremal point caused by +% {inf,sup}/{2,4}. +% +% If we are after the infimum/supremum for minimizing/maximizing, +% this strategy may have adverse effects on performance because +% the simplex algorithm is forced to re-discover the +% extremal vertex through the equation {Inf =:= Expr}. +% +% Thus the extra code for {minimize,maximize}/1. +% +% In case someone comes up with an example where +% +% inf(Expr,Expr) +% +% outperforms the provided formulation for minimize - so be it. +% Both forms are available to the user. +% +minimize(Term) :- + wait_linear(Term,Nf,minimize_lin(Nf)). + +% minimize_lin(Lin) +% +% Minimizes the linear expression Lin. It does so by making a new +% variable Dep and minimizes its value. + +minimize_lin(Lin) :- + deref(Lin,Lind), + var_with_def_intern(t_none,Dep,Lind,0), + determine_active_dec(Lind), + iterate_dec(Dep,Inf), + { Dep =:= Inf }. + +sup(Expression,Sup) :- + sup(Expression,Sup,[],[]). + +sup(Expression,Sup,Vector,Vertex) :- + inf(-Expression,-Sup,Vector,Vertex). + +inf(Expression,Inf) :- + inf(Expression,Inf,[],[]). + +inf(Expression,Inf,Vector,Vertex) :- + % wait until Expression becomes linear, Nf contains linear Expression + % in normal form + wait_linear(Expression,Nf,inf_lin(Nf,Inf,Vector,Vertex)). + +inf_lin(Lin,_,Vector,_) :- + deref(Lin,Lind), + var_with_def_intern(t_none,Dep,Lind,0), % make new variable Dep = Lind + determine_active_dec(Lind), % minimizes Lind + iterate_dec(Dep,Inf), + vertex_value(Vector,Values), + nb_setval(inf,[Inf|Values]), + fail. +inf_lin(_,Infimum,_,Vertex) :- + catch(nb_getval(inf,L),_,fail), + nb_delete(inf), + assign([Infimum|Vertex],L). + +% assign(L1,L2) +% +% The elements of L1 are pairwise assigned to the elements of L2 +% by means of asserting {X =:= Y} where X is an element of L1 and Y +% is the corresponding element of L2. + +assign([],[]). +assign([X|Xs],[Y|Ys]) :- + {X =:= Y}, % more defensive/expressive than X=Y + assign(Xs,Ys). + +% --------------------------------- optimization ------------------------------ +% +% The _sn(S) =< 0 row might be temporarily infeasible. +% We use reconsider/1 to fix this. +% +% s(S) e [_,0] = d +xi ... -xj, Rhs > 0 so we want to decrease s(S) +% +% positive xi would have to be moved towards their lower bound, +% negative xj would have to be moved towards their upper bound, +% +% the row s(S) does not limit the lower bound of xi +% the row s(S) does not limit the upper bound of xj +% +% a) if some other row R is limiting xk, we pivot(R,xk), +% s(S) will decrease and get more feasible until (b) +% b) if there is no limiting row for some xi: we pivot(s(S),xi) +% xj: we pivot(s(S),xj) +% which cures the infeasibility in one step +% + + +% iterate_dec(OptVar,Opt) +% +% Decreases the bound on the variables of the linear equation of OptVar as much +% as possible and returns the resulting optimal bound in Opt. Fails if for some +% variable, a status of unlimited is found. + +iterate_dec(OptVar,Opt) :- + get_attr(OptVar,itf,Att), + arg(4,Att,lin([I,R|H])), + dec_step(H,Status), + ( Status = applied + -> iterate_dec(OptVar,Opt) + ; Status = optimum, + Opt is R + I + ). + +% iterate_inc(OptVar,Opt) +% +% Increases the bound on the variables of the linear equation of OptVar as much +% as possible and returns the resulting optimal bound in Opt. Fails if for some +% variable, a status of unlimited is found. + +iterate_inc(OptVar,Opt) :- + get_attr(OptVar,itf,Att), + arg(4,Att,lin([I,R|H])), + inc_step(H,Status), + ( Status = applied + -> iterate_inc(OptVar,Opt) + ; Status = optimum, + Opt is R + I + ). + +% +% Status = {optimum,unlimited(Indep,DepT),applied} +% If Status = optimum, the tables have not been changed at all. +% Searches left to right, does not try to find the 'best' pivot +% Therefore we might discover unboundedness only after a few pivots +% + + +dec_step_cont([],optimum,Cont,Cont). +dec_step_cont([l(V*K,OrdV)|Vs],Status,ContIn,ContOut) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( dec_step_2_cont(W,l(V*K,OrdV),Class,Status,ContIn,ContOut) + -> true + ; dec_step_cont(Vs,Status,ContIn,ContOut) + ). + +inc_step_cont([],optimum,Cont,Cont). +inc_step_cont([l(V*K,OrdV)|Vs],Status,ContIn,ContOut) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( inc_step_2_cont(W,l(V*K,OrdV),Class,Status,ContIn,ContOut) + -> true + ; inc_step_cont(Vs,Status,ContIn,ContOut) + ). + +dec_step_2_cont(t_U(U),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K > 0, + ( lb(Class,OrdV,Vub-Vb-_) + -> % found a lower bound + Status = applied, + pivot_a(Vub,V,Vb,t_u(U)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_u(U)), + ContIn = ContOut + ). +dec_step_2_cont(t_lU(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K > 0, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +dec_step_2_cont(t_L(L),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K < 0, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_l(L)), + ContIn = ContOut + ). +dec_step_2_cont(t_Lu(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K < 0, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +dec_step_2_cont(t_none,l(V*_,_),_,unlimited(V,t_none),Cont,Cont). + + + +inc_step_2_cont(t_U(U),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K < 0, + ( lb(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_u(U)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_u(U)), + ContIn = ContOut + ). +inc_step_2_cont(t_lU(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K < 0, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +inc_step_2_cont(t_L(L),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K > 0, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_l(L)), + ContIn = ContOut + ). +inc_step_2_cont(t_Lu(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K > 0, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +inc_step_2_cont(t_none,l(V*_,_),_,unlimited(V,t_none),Cont,Cont). + +replace_in_cont([],_,_,[]). +replace_in_cont([H1|T1],X,Y,[H2|T2]) :- + ( H1 == X + -> H2 = Y, + T1 = T2 + ; H2 = H1, + replace_in_cont(T1,X,Y,T2) + ). + +dec_step([],optimum). +dec_step([l(V*K,OrdV)|Vs],Status) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( dec_step_2(W,l(V*K,OrdV),Class,Status) + -> true + ; dec_step(Vs,Status) + ). + +dec_step_2(t_U(U),l(V*K,OrdV),Class,Status) :- + K > 0, + ( lb(Class,OrdV,Vub-Vb-_) + -> % found a lower bound + Status = applied, + pivot_a(Vub,V,Vb,t_u(U)) + ; Status = unlimited(V,t_u(U)) + ). +dec_step_2(t_lU(L,U),l(V*K,OrdV),Class,applied) :- + K > 0, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +dec_step_2(t_L(L),l(V*K,OrdV),Class,Status) :- + K < 0, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)) + ; Status = unlimited(V,t_l(L)) + ). +dec_step_2(t_Lu(L,U),l(V*K,OrdV),Class,applied) :- + K < 0, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +dec_step_2(t_none,l(V*_,_),_,unlimited(V,t_none)). + +inc_step([],optimum). % if status has not been set yet: no changes +inc_step([l(V*K,OrdV)|Vs],Status) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( inc_step_2(W,l(V*K,OrdV),Class,Status) + -> true + ; inc_step(Vs,Status) + ). + +inc_step_2(t_U(U),l(V*K,OrdV),Class,Status) :- + K < 0, + ( lb(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_u(U)) + ; Status = unlimited(V,t_u(U)) + ). +inc_step_2(t_lU(L,U),l(V*K,OrdV),Class,applied) :- + K < 0, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +inc_step_2(t_L(L),l(V*K,OrdV),Class,Status) :- + K > 0, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)) + ; Status = unlimited(V,t_l(L)) + ). +inc_step_2(t_Lu(L,U),l(V*K,OrdV),Class,applied) :- + K > 0, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +inc_step_2(t_none,l(V*_,_),_,unlimited(V,t_none)). + +% ------------------------- find the most constraining row -------------------- +% +% The code for the lower and the upper bound are dual versions of each other. +% The only difference is in the orientation of the comparisons. +% Indeps are ruled out by their types. +% If there is no bound, this fails. +% +% *** The actual lb and ub on an indep variable X are [lu]b + b(X), where b(X) +% is the value of the active bound. +% +% Nota bene: We must NOT consider infeasible rows as candidates to +% leave the basis! +% +% ub(Class,OrdX,Ub) +% +% See lb/3: this is similar + +ub(Class,OrdX,Ub) :- + class_basis(Class,Deps), + ub_first(Deps,OrdX,Ub). + +% ub_first(Deps,X,Dep-W-Ub) +% +% Finds the tightest upperbound for variable X from the linear equations of +% basis variables Deps, and puts the resulting bound in Ub. Dep is the basis +% variable that generates the bound, and W is bound of that variable that has +% to be activated to achieve this. + +ub_first([Dep|Deps],OrdX,Tightest) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + ub_inner(Type,OrdX,Lin,W,Ub), + Ub >= 0 + -> ub(Deps,OrdX,Dep-W-Ub,Tightest) + ; ub_first(Deps,OrdX,Tightest) + ). + +% ub(Deps,OrdX,TightestIn,TightestOut) +% +% See lb/4: this is similar + +ub([],_,T0,T0). +ub([Dep|Deps],OrdX,T0,T1) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + ub_inner(Type,OrdX,Lin,W,Ub), + T0 = _-Ubb, + Ub < Ubb, + Ub >= 0 + -> ub(Deps,OrdX,Dep-W-Ub,T1) % tighter bound, use new bound + ; ub(Deps,OrdX,T0,T1) % no tighter bound, keep current one + ). + +% ub_inner(Type,OrdX,Lin,W,Ub) +% +% See lb_inner/5: this is similar + +ub_inner(t_l(L),OrdX,Lin,t_L(L),Ub) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + K < 0, + Ub is (L - Rhs) rdiv K. +ub_inner(t_u(U),OrdX,Lin,t_U(U),Ub) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + K > 0, + Ub is (U - Rhs) rdiv K. +ub_inner(t_lu(L,U),OrdX,Lin,W,Ub) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + ( K < 0 % use lowerbound + -> W = t_Lu(L,U), + Ub = (L - Rhs) rdiv K + ; K > 0 % use upperbound + -> W = t_lU(L,U), + Ub = (U - Rhs) rdiv K + ). + +% lb(Class,OrdX,Lb) +% +% Returns in Lb how much we can lower the upperbound of X without violating +% a bound of the basisvariables. +% Lb has the form Dep-W-Lb with Dep the variable whose bound is violated when +% lowering the bound for X more, W the actual bound that has to be activated +% and Lb the amount that the upperbound can be lowered. +% X has ordering OrdX and class Class. + +lb(Class,OrdX,Lb) :- + class_basis(Class,Deps), + lb_first(Deps,OrdX,Lb). + +% lb_first(Deps,OrdX,Tightest) +% +% Returns in Tightest how much we can lower the upperbound of X without +% violating a bound of Deps. +% Tightest has the form Dep-W-Lb with Dep the variable whose bound is violated +% when lowering the bound for X more, W the actual bound that has to be +% activated and Lb the amount that the upperbound can be lowered. X has +% ordering attribute OrdX. + +lb_first([Dep|Deps],OrdX,Tightest) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + lb_inner(Type,OrdX,Lin,W,Lb), + Lb =< 0 % Lb > 0 means a violated bound + -> lb(Deps,OrdX,Dep-W-Lb,Tightest) + ; lb_first(Deps,OrdX,Tightest) + ). + +% lb(Deps,OrdX,TightestIn,TightestOut) +% +% See lb_first/3: this one does the same thing, but is used for the steps after +% the first one and remembers the tightest bound so far. + +lb([],_,T0,T0). +lb([Dep|Deps],OrdX,T0,T1) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + lb_inner(Type,OrdX,Lin,W,Lb), + T0 = _-Lbb, + Lb > Lbb, % choose the least lowering, others might violate + % bounds + Lb =< 0 % violation of a bound (without lowering) + -> lb(Deps,OrdX,Dep-W-Lb,T1) + ; lb(Deps,OrdX,T0,T1) + ). + +% lb_inner(Type,X,Lin,W,Lb) +% +% Returns in Lb how much lower we can make X without violating a bound +% by using the linear equation Lin of basis variable B which has type +% Type and which has to activate a bound (type W) to do so. +% +% E.g. when B has a lowerbound L, then L should always be smaller than I + R. +% So a lowerbound of X (which has scalar K in Lin), could be at most +% (L-(I+R))/K lower than its upperbound (if K is positive). +% Also note that Lb should always be smaller than 0, otherwise the row is +% not feasible. +% X has ordering attribute OrdX. + +lb_inner(t_l(L),OrdX,Lin,t_L(L),Lb) :- + nf_rhs_x(Lin,OrdX,Rhs,K), % if linear equation Lin contains the term + % X*K, Rhs is the right hand side of that + % equation + K > 0, + Lb is (L - Rhs) rdiv K. +lb_inner(t_u(U),OrdX,Lin,t_U(U),Lb) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + K < 0, % K < 0 + Lb is (U - Rhs) rdiv K. +lb_inner(t_lu(L,U),OrdX,Lin,W,Lb) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + ( K < 0 + -> W = t_lU(L,U), + Lb is (U - Rhs) rdiv K + ; K > 0 + -> W = t_Lu(L,U), + Lb is (L - Rhs) rdiv K + ). + +% ---------------------------------- equations -------------------------------- +% +% backsubstitution will not make the system infeasible, if the bounds on the +% indep vars are obeyed, but some implied values might pop up in rows where X +% occurs +% -) special case X=Y during bs -> get rid of dependend var(s), alias +% + +solve(Lin) :- + Lin = [I,_|H], + solve(H,Lin,I,Bindings,[]), + export_binding(Bindings). + +% solve(Hom,Lin,I,Bind,BindT) +% +% Solves a linear equation Lin = [I,_|H] = 0 and exports the generated bindings + +solve([],_,I,Bind0,Bind0) :- + !, + I =:= 0. +solve(H,Lin,_,Bind0,BindT) :- + sd(H,[],ClassesUniq,9-9-0,Category-Selected-_,NV,NVT), + get_attr(Selected,itf,Att), + arg(5,Att,order(Ord)), + isolate(Ord,Lin,Lin1), % Lin = 0 => Selected = Lin1 + ( Category = 1 % classless variable, no bounds + -> setarg(4,Att,lin(Lin1)), + Lin1 = [Inhom,_|Hom], + bs_collect_binding(Hom,Selected,Inhom,Bind0,BindT), + eq_classes(NV,NVT,ClassesUniq) + ; Category = 2 % class variable, no bounds + -> arg(6,Att,class(NewC)), + class_allvars(NewC,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,Ord,Lin1,Bind0,BindT) + ; Bind0 = BindT, + bs(Deps,Ord,Lin1) + ), + eq_classes(NV,NVT,ClassesUniq) + ; Category = 3 % classless variable, all variables in Lin and + % Selected are bounded + -> arg(2,Att,type(Type)), + setarg(4,Att,lin(Lin1)), + deactivate_bound(Type,Selected), + eq_classes(NV,NVT,ClassesUniq), + basis_add(Selected,Basis), + undet_active(Lin1), % we can't tell which bound will likely be a + % problem at this point + Lin1 = [Inhom,_|Hom], + bs_collect_binding(Hom,Selected,Inhom,Bind0,Bind1), % only if + % Hom = [] + rcbl(Basis,Bind1,BindT) % reconsider entire basis + ; Category = 4 % class variable, all variables in Lin and Selected + % are bounded + -> arg(2,Att,type(Type)), + arg(6,Att,class(NewC)), + class_allvars(NewC,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,Ord,Lin1,Bind0,Bind1) + ; Bind0 = Bind1, + bs(Deps,Ord,Lin1) + ), + deactivate_bound(Type,Selected), + basis_add(Selected,Basis), + % eq_classes( NV, NVT, ClassesUniq), + % 4 -> var(NV) + equate(ClassesUniq,_), + undet_active(Lin1), + rcbl(Basis,Bind1,BindT) + ). + +% +% Much like solve, but we solve for a particular variable of type t_none +% + +% solve_x(H,Lin,I,X,[Bind|BindT],BindT) +% +% + +solve_x(Lin,X) :- + Lin = [I,_|H], + solve_x(H,Lin,I,X,Bindings,[]), + export_binding(Bindings). + +solve_x([],_,I,_,Bind0,Bind0) :- + !, + I =:= 0. +solve_x(H,Lin,_,X,Bind0,BindT) :- + sd(H,[],ClassesUniq,9-9-0,_,NV,NVT), + get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + isolate(OrdX,Lin,Lin1), + ( arg(6,Att,class(NewC)) + -> class_allvars(NewC,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,OrdX,Lin1,Bind0,BindT) + ; Bind0 = BindT, + bs(Deps,OrdX,Lin1) + ), + eq_classes(NV,NVT,ClassesUniq) + ; setarg(4,Att,lin(Lin1)), + Lin1 = [Inhom,_|Hom], + bs_collect_binding(Hom,X,Inhom,Bind0,BindT), + eq_classes(NV,NVT,ClassesUniq) + ). + +% solve_ord_x(Lin,OrdX,ClassX) +% +% Does the same thing as solve_x/2, but has the ordering of X and its class as +% input. This also means that X has a class which is not sure in solve_x/2. + +solve_ord_x(Lin,OrdX,ClassX) :- + Lin = [I,_|H], + solve_ord_x(H,Lin,I,OrdX,ClassX,Bindings,[]), + export_binding(Bindings). + +solve_ord_x([],_,I,_,_,Bind0,Bind0) :- + I =:= 0. +solve_ord_x([_|_],Lin,_,OrdX,ClassX,Bind0,BindT) :- + isolate(OrdX,Lin,Lin1), + Lin1 = [_,_|H1], + sd(H1,[],ClassesUniq1,9-9-0,_,NV,NVT), % do sd on Lin without X, then + % add class of X + ord_add_element(ClassesUniq1,ClassX,ClassesUniq), + class_allvars(ClassX,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,OrdX,Lin1,Bind0,BindT) + ; Bind0 = BindT, + bs(Deps,OrdX,Lin1) + ), + eq_classes(NV,NVT,ClassesUniq). + +% sd(H,[],ClassesUniq,9-9-0,Category-Selected-_,NV,NVT) + +% sd(Hom,ClassesIn,ClassesOut,PreferenceIn,PreferenceOut,[NV|NVTail],NVTail) +% +% ClassesOut is a sorted list of the different classes that are either in +% ClassesIn or that are the classes of the variables in Hom. Variables that do +% not belong to a class yet, are put in the difference list NV. + +sd([],Class0,Class0,Preference0,Preference0,NV0,NV0). +sd([l(X*K,_)|Xs],Class0,ClassN,Preference0,PreferenceN,NV0,NVt) :- + get_attr(X,itf,Att), + ( arg(6,Att,class(Xc)) % old: has class + -> NV0 = NV1, + ord_add_element(Class0,Xc,Class1), + ( arg(2,Att,type(t_none)) + -> preference(Preference0,2-X-K,Preference1) + % has class, no bounds => category 2 + ; preference(Preference0,4-X-K,Preference1) + % has class, is bounded => category 4 + ) + ; % new: has no class + Class1 = Class0, + NV0 = [X|NV1], % X has no class yet, add to list of new variables + ( arg(2,Att,type(t_none)) + -> preference(Preference0,1-X-K,Preference1) + % no class, no bounds => category 1 + ; preference(Preference0,3-X-K,Preference1) + % no class, is bounded => category 3 + ) + ), + sd(Xs,Class1,ClassN,Preference1,PreferenceN,NV1,NVt). + +% +% A is best sofar, B is current +% smallest prefered +preference(A,B,Pref) :- + A = Px-_-_, + B = Py-_-_, + ( Px < Py + -> Pref = A + ; Pref = B + ). + +% eq_classes(NV,NVTail,Cs) +% +% Attaches all classless variables NV to a new class and equates all other +% classes with this class. The equate operation only happens after attach_class +% because the unification of classes can bind the tail of the AllVars attribute +% to a nonvar and then the attach_class operation wouldn't work. + +eq_classes(NV,_,Cs) :- + var(NV), + !, + equate(Cs,_). +eq_classes(NV,NVT,Cs) :- + class_new(Su,clpq,NV,NVT,[]), % make a new class Su with NV as the variables + attach_class(NV,Su), % attach the variables NV to Su + equate(Cs,Su). + +equate([],_). +equate([X|Xs],X) :- equate(Xs,X). + +% +% assert: none of the Vars has a class attribute yet +% +attach_class(Xs,_) :- + var(Xs), % Tail + !. +attach_class([X|Xs],Class) :- + get_attr(X,itf,Att), + setarg(6,Att,class(Class)), + attach_class(Xs,Class). + +% unconstrained(Lin,Uc,Kuc,Rest) +% +% Finds an unconstrained variable Uc (type(t_none)) in Lin with scalar Kuc and +% removes it from Lin to return Rest. + +unconstrained(Lin,Uc,Kuc,Rest) :- + Lin = [_,_|H], + sd(H,[],_,9-9-0,Category-Uc-_,_,_), + Category =< 2, + get_attr(Uc,itf,Att), + arg(5,Att,order(OrdUc)), + delete_factor(OrdUc,Lin,Rest,Kuc). + +% +% point the vars in Lin into the same equivalence class +% maybe join some global data +% +same_class([],_). +same_class([l(X*_,_)|Xs],Class) :- + get_or_add_class(X,Class), + same_class(Xs,Class). + +% get_or_add_class(X,Class) +% +% Returns in Class the class of X if X has one, or a new class where X now +% belongs to if X didn't have one. + +get_or_add_class(X,Class) :- + get_attr(X,itf,Att), + arg(1,Att,CLP), + ( arg(6,Att,class(ClassX)) + -> ClassX = Class + ; setarg(6,Att,class(Class)), + class_new(Class,CLP,[X|Tail],Tail,[]) + ). + +% allvars(X,Allvars) +% +% Allvars is a list of all variables in the class to which X belongs. + +allvars(X,Allvars) :- + get_attr(X,itf,Att), + arg(6,Att,class(C)), + class_allvars(C,Allvars). + +% deactivate_bound(Type,Variable) +% +% The Type of the variable is changed to reflect the deactivation of its +% bounds. +% t_L(_) becomes t_l(_), t_lU(_,_) becomes t_lu(_,_) and so on. + +deactivate_bound(t_l(_),_). +deactivate_bound(t_u(_),_). +deactivate_bound(t_lu(_,_),_). +deactivate_bound(t_L(L),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(L))). +deactivate_bound(t_Lu(L,U),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). +deactivate_bound(t_U(U),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(U))). +deactivate_bound(t_lU(L,U),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). + +% intro_at(X,Value,Type) +% +% Variable X gets new type Type which reflects the activation of a bound with +% value Value. In the linear equations of all the variables belonging to the +% same class as X, X is substituted by [0,Value,X] to reflect the new active +% bound. + +intro_at(X,Value,Type) :- + get_attr(X,itf,Att), + arg(5,Att,order(Ord)), + arg(6,Att,class(Class)), + setarg(2,Att,type(Type)), + ( Value =:= 0 + -> true + ; backsubst_delta(Class,Ord,X,Value) + ). + +% undet_active(Lin) +% +% For each variable in the homogene part of Lin, a bound is activated +% if an inactive bound exists. (t_l(L) becomes t_L(L) and so on) + +undet_active([_,_|H]) :- + undet_active_h(H). + +% undet_active_h(Hom) +% +% For each variable in homogene part Hom, a bound is activated if an +% inactive bound exists (t_l(L) becomes t_L(L) and so on) + +undet_active_h([]). +undet_active_h([l(X*_,_)|Xs]) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + undet_active(Type,X), + undet_active_h(Xs). + +% undet_active(Type,Var) +% +% An inactive bound of Var is activated if such exists +% t_lu(L,U) is arbitrarily chosen to become t_Lu(L,U) + +undet_active(t_none,_). % type_activity +undet_active(t_L(_),_). +undet_active(t_Lu(_,_),_). +undet_active(t_U(_),_). +undet_active(t_lU(_,_),_). +undet_active(t_l(L),X) :- intro_at(X,L,t_L(L)). +undet_active(t_u(U),X) :- intro_at(X,U,t_U(U)). +undet_active(t_lu(L,U),X) :- intro_at(X,L,t_Lu(L,U)). + +% determine_active_dec(Lin) +% +% Activates inactive bounds on the variables of Lin if such bounds exist. +% If the type of a variable is t_none, this fails. This version is aimed +% to make the R component of Lin as small as possible in order not to violate +% an upperbound (see reconsider/1) + +determine_active_dec([_,_|H]) :- + determine_active(H,-1). + +% determine_active_inc(Lin) +% +% Activates inactive bounds on the variables of Lin if such bounds exist. +% If the type of a variable is t_none, this fails. This version is aimed +% to make the R component of Lin as large as possible in order not to violate +% a lowerbound (see reconsider/1) + +determine_active_inc([_,_|H]) :- + determine_active(H,1). + +% determine_active(Hom,S) +% +% For each variable in Hom, activates its bound if it is not yet activated. +% For the case of t_lu(_,_) the lower or upper bound is activated depending on +% K and S: +% If sign of K*S is negative, then lowerbound, otherwise upperbound. + +determine_active([],_). +determine_active([l(X*K,_)|Xs],S) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + determine_active(Type,X,K,S), + determine_active(Xs,S). + +determine_active(t_L(_),_,_,_). +determine_active(t_Lu(_,_),_,_,_). +determine_active(t_U(_),_,_,_). +determine_active(t_lU(_,_),_,_,_). +determine_active(t_l(L),X,_,_) :- intro_at(X,L,t_L(L)). +determine_active(t_u(U),X,_,_) :- intro_at(X,U,t_U(U)). +determine_active(t_lu(L,U),X,K,S) :- + KS is K*S, + ( KS < 0 + -> intro_at(X,L,t_Lu(L,U)) + ; KS > 0 + -> intro_at(X,U,t_lU(L,U)) + ). + +% +% Careful when an indep turns into t_none !!! +% + +detach_bounds(V) :- + get_attr(V,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + arg(5,Att,order(OrdV)), + arg(6,Att,class(Class)), + setarg(2,Att,type(t_none)), + setarg(3,Att,strictness(0)), + ( indep(Lin,OrdV) + -> ( ub(Class,OrdV,Vub-Vb-_) + -> % exchange against thightest + class_basis_drop(Class,Vub), + pivot(Vub,Class,OrdV,Vb,Type) + ; lb(Class,OrdV,Vlb-Vb-_) + -> class_basis_drop(Class,Vlb), + pivot(Vlb,Class,OrdV,Vb,Type) + ; true + ) + ; class_basis_drop(Class,V) + ). + +detach_bounds_vlv(OrdV,Lin,Class,Var,NewLin) :- + ( indep(Lin,OrdV) + -> Lin = [_,R|_], + ( ub(Class,OrdV,Vub-Vb-_) + -> % in verify_lin, class might contain two occurrences of Var, + % but it doesn't matter which one we delete + class_basis_drop(Class,Var), + pivot_vlv(Vub,Class,OrdV,Vb,R,NewLin) + ; lb(Class,OrdV,Vlb-Vb-_) + -> class_basis_drop(Class,Var), + pivot_vlv(Vlb,Class,OrdV,Vb,R,NewLin) + ; NewLin = Lin + ) + ; NewLin = Lin, + class_basis_drop(Class,Var) + ). + +% ----------------------------- manipulate the basis -------------------------- + +% basis_drop(X) +% +% Removes X from the basis of the class to which X belongs. + +basis_drop(X) :- + get_attr(X,itf,Att), + arg(6,Att,class(Cv)), + class_basis_drop(Cv,X). + +% basis(X,Basis) +% +% Basis is the basis of the class to which X belongs. + +basis(X,Basis) :- + get_attr(X,itf,Att), + arg(6,Att,class(Cv)), + class_basis(Cv,Basis). + +% basis_add(X,NewBasis) +% +% NewBasis is the result of adding X to the basis of the class to which X +% belongs. + +basis_add(X,NewBasis) :- + get_attr(X,itf,Att), + arg(6,Att,class(Cv)), + class_basis_add(Cv,X,NewBasis). + +% basis_pivot(Leave,Enter) +% +% Removes Leave from the basis of the class to which it belongs, and adds +% Enter to that basis. + +basis_pivot(Leave,Enter) :- + get_attr(Leave,itf,Att), + arg(6,Att,class(Cv)), + class_basis_pivot(Cv,Enter,Leave). + +% ----------------------------------- pivot ----------------------------------- + +% pivot(Dep,Indep) +% +% The linear equation of variable Dep, is transformed into one of variable +% Indep, containing Dep. Then, all occurrences of Indep in linear equations are +% substituted by this new definition + +% +% Pivot ignoring rhs and active states +% + +pivot(Dep,Indep) :- + get_attr(Dep,itf,AttD), + arg(4,AttD,lin(H)), + arg(5,AttD,order(OrdDep)), + get_attr(Indep,itf,AttI), + arg(5,AttI,order(Ord)), + arg(5,AttI,class(Class)), + delete_factor(Ord,H,H0,Coeff), + K is -1 rdiv Coeff, + add_linear_ff(H0,K,[0,0,l(Dep* -1,OrdDep)],K,Lin), + backsubst(Class,Ord,Lin). + +% pivot_a(Dep,Indep,IndepT,DepT) +% +% Removes Dep from the basis, puts Indep in, and pivots the equation of +% Dep to become one of Indep. The type of Dep becomes DepT (which means +% it gets deactivated), the type of Indep becomes IndepT (which means it +% gets activated) + + +pivot_a(Dep,Indep,Vb,Wd) :- + basis_pivot(Dep,Indep), + get_attr(Indep,itf,Att), + arg(2,Att,type(Type)), + arg(5,Att,order(Ord)), + arg(6,Att,class(Class)), + pivot(Dep,Class,Ord,Vb,Type), + get_attr(Indep,itf,Att2), %changed? + setarg(2,Att2,type(Wd)). + +pivot_b(Vub,V,Vb,Wd) :- + ( Vub == V + -> get_attr(V,itf,Att), + arg(5,Att,order(Ord)), + arg(6,Att,class(Class)), + setarg(2,Att,type(Vb)), + pivot_b_delta(Vb,Delta), % nonzero(Delta) + backsubst_delta(Class,Ord,V,Delta) + ; pivot_a(Vub,V,Vb,Wd) + ). + +pivot_b_delta(t_Lu(L,U),Delta) :- Delta is L-U. +pivot_b_delta(t_lU(L,U),Delta) :- Delta is U-L. + +% select_active_bound(Type,Bound) +% +% Returns the bound that is active in Type (if such exists, 0 otherwise) + +select_active_bound(t_L(L),L). +select_active_bound(t_Lu(L,_),L). +select_active_bound(t_U(U),U). +select_active_bound(t_lU(_,U),U). +select_active_bound(t_none,0). +% +% for project.pl +% +select_active_bound(t_l(_),0). +select_active_bound(t_u(_),0). +select_active_bound(t_lu(_,_),0). + + +% pivot(Dep,Class,IndepOrd,DepAct,IndAct) +% +% See pivot/2. +% In addition, variable Indep with ordering IndepOrd has an active bound IndAct + +% +% +% Pivot taking care of rhs and active states +% +pivot(Dep,Class,IndepOrd,DepAct,IndAct) :- + get_attr(Dep,itf,Att), + arg(4,Att,lin(H)), + arg(5,Att,order(DepOrd)), + setarg(2,Att,type(DepAct)), + select_active_bound(DepAct,AbvD), % New current value for Dep + select_active_bound(IndAct,AbvI), % Old current value of Indep + delete_factor(IndepOrd,H,H0,Coeff), % Dep = ... + Coeff*Indep + ... + AbvDm is -AbvD, + AbvIm is -AbvI, + add_linear_f1([0,AbvIm],Coeff,H0,H1), + K is -1 rdiv Coeff, + add_linear_ff(H1,K,[0,AbvDm,l(Dep* -1,DepOrd)],K,H2), + % Indep = -1/Coeff*... + 1/Coeff*Dep + add_linear_11(H2,[0,AbvIm],Lin), + backsubst(Class,IndepOrd,Lin). + +% Rewrite Dep = ... + Coeff*Indep + ... +% into Indep = ... + -1/Coeff*Dep + ... +% +% For backsubstitution, old current value of Indep must be removed from RHS +% New current value of Dep must be added to RHS +% For solving: old current value of Indep should be out of RHS + +pivot_vlv(Dep,Class,IndepOrd,DepAct,AbvI,Lin) :- + get_attr(Dep,itf,Att), + arg(4,Att,lin(H)), + arg(5,Att,order(DepOrd)), + setarg(2,Att,type(DepAct)), + select_active_bound(DepAct,AbvD), % New current value for Dep + delete_factor(IndepOrd,H,H0,Coeff), % Dep = ... + Coeff*Indep + ... + AbvDm is -AbvD, + AbvIm is -AbvI, + add_linear_f1([0,AbvIm],Coeff,H0,H1), + K is -1 rdiv Coeff, + add_linear_ff(H1,K,[0,AbvDm,l(Dep* -1,DepOrd)],K,Lin), + % Indep = -1/Coeff*... + 1/Coeff*Dep + add_linear_11(Lin,[0,AbvIm],SubstLin), + backsubst(Class,IndepOrd,SubstLin). + +% backsubst_delta(Class,OrdX,X,Delta) +% +% X with ordering attribute OrdX, is substituted in all linear equations of +% variables in the class Class, by linear equation [0,Delta,l(X*1,OrdX)]. This +% reflects the activation of a bound. + +backsubst_delta(Class,OrdX,X,Delta) :- + backsubst(Class,OrdX,[0,Delta,l(X*1,OrdX)]). + +% backsubst(Class,OrdX,Lin) +% +% X with ordering OrdX is substituted in all linear equations of variables in +% the class Class, by linear equation Lin + +backsubst(Class,OrdX,Lin) :- + class_allvars(Class,Allvars), + bs(Allvars,OrdX,Lin). + +% bs(Vars,OrdV,Lin) +% +% In all linear equations of the variables Vars, variable V with ordering +% attribute OrdV is substituted by linear equation Lin. +% +% valid if nothing will go ground +% + +bs(Xs,_,_) :- + var(Xs), + !. +bs([X|Xs],OrdV,Lin) :- + ( get_attr(X,itf,Att), + arg(4,Att,lin(LinX)), + nf_substitute(OrdV,Lin,LinX,LinX1) % does not change attributes + -> setarg(4,Att,lin(LinX1)), + bs(Xs,OrdV,Lin) + ; bs(Xs,OrdV,Lin) + ). + +% +% rank increasing backsubstitution +% + +% bs_collect_bindings(Deps,SelectedOrd,Lin,Bind,BindT) +% +% Collects bindings (of the form [X-I] where X = I is the binding) by +% substituting Selected in all linear equations of the variables Deps (which +% are of the same class), by Lin. Selected has ordering attribute SelectedOrd. +% +% E.g. when V = 2X + 3Y + 4, X = 3V + 2Z and Y = 4X + 3 +% we can substitute V in the linear equation of X: X = 6X + 9Y + 2Z + 12 +% we can't substitute V in the linear equation of Y of course. + +bs_collect_bindings(Xs,_,_,Bind0,BindT) :- + var(Xs), + !, + Bind0 = BindT. +bs_collect_bindings([X|Xs],OrdV,Lin,Bind0,BindT) :- + ( get_attr(X,itf,Att), + arg(4,Att,lin(LinX)), + nf_substitute(OrdV,Lin,LinX,LinX1) % does not change attributes + -> setarg(4,Att,lin(LinX1)), + LinX1 = [Inhom,_|Hom], + bs_collect_binding(Hom,X,Inhom,Bind0,Bind1), + bs_collect_bindings(Xs,OrdV,Lin,Bind1,BindT) + ; bs_collect_bindings(Xs,OrdV,Lin,Bind0,BindT) + ). + +% bs_collect_binding(Hom,Selected,Inhom,Bind,BindT) +% +% Collects binding following from Selected = Hom + Inhom. +% If Hom = [], returns the binding Selected-Inhom (=0) +% +bs_collect_binding([],X,Inhom) --> [X-Inhom]. +bs_collect_binding([_|_],_,_) --> []. + +% +% reconsider the basis +% + +% rcbl(Basis,Bind,BindT) +% +% + +rcbl([],Bind0,Bind0). +rcbl([X|Continuation],Bind0,BindT) :- + ( rcb_cont(X,Status,Violated,Continuation,NewContinuation) % have a culprit + -> rcbl_status(Status,X,NewContinuation,Bind0,BindT,Violated) + ; rcbl(Continuation,Bind0,BindT) + ). + +rcb_cont(X,Status,Violated,ContIn,ContOut) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin([I,R|H])), + ( Type = t_l(L) % case 1: lowerbound: R + I should always be larger + % than the lowerbound + -> R + I =< L, + Violated = l(L), + inc_step_cont(H,Status,ContIn,ContOut) + ; Type = t_u(U) % case 2: upperbound: R + I should always be smaller + % than the upperbound + -> R + I >= U, + Violated = u(U), + dec_step_cont(H,Status,ContIn,ContOut) + ; Type = t_lu(L,U) % case 3: check both + -> At is R + I, + ( At =< L + -> Violated = l(L), + inc_step_cont(H,Status,ContIn,ContOut) + ; At >= U + -> Violated = u(U), + dec_step_cont(H,Status,ContIn,ContOut) + ) + ). % other types imply nonbasic variable or unbounded variable + + + +% +% reconsider one element of the basis +% later: lift the binds +% +reconsider(X) :- + rcb(X,Status,Violated), + !, + rcbl_status(Status,X,[],Binds,[],Violated), + export_binding(Binds). +reconsider(_). + +% +% Find a basis variable out of its bound or at its bound +% Try to move it into whithin its bound +% a) impossible -> fail +% b) optimum at the bound -> implied value +% c) else look at the remaining basis variables +% +% +% Idea: consider a variable V with linear equation Lin. +% When a bound on a variable X of Lin gets activated, its value, multiplied +% with the scalar of X, is added to the R component of Lin. +% When we consider the lowerbound of V, it must be smaller than R + I, since R +% contains at best the lowerbounds of the variables in Lin (but could contain +% upperbounds, which are of course larger). So checking this can show the +% violation of a bound of V. A similar case works for the upperbound. + +rcb(X,Status,Violated) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin([I,R|H])), + ( Type = t_l(L) % case 1: lowerbound: R + I should always be larger + % than the lowerbound + -> R + I =< L, + Violated = l(L), + inc_step(H,Status) + ; Type = t_u(U) % case 2: upperbound: R + I should always be smaller + % than the upperbound + -> R + I >= U, + Violated = u(U), + dec_step(H,Status) + ; Type = t_lu(L,U) % case 3: check both + -> At is R + I, + ( At =< L + -> Violated = l(L), + inc_step(H,Status) + ; At >= U + -> Violated = u(U), + dec_step(H,Status) + ) + ). % other types imply nonbasic variable or unbounded variable + +% rcbl_status(Status,X,Continuation,[Bind|BindT],BindT,Violated) +% +% + +rcbl_status(optimum,X,Cont,B0,Bt,Violated) :- rcbl_opt(Violated,X,Cont,B0,Bt). +rcbl_status(applied,X,Cont,B0,Bt,Violated) :- rcbl_app(Violated,X,Cont,B0,Bt). +rcbl_status(unlimited(Indep,DepT),X,Cont,B0,Bt,Violated) :- + rcbl_unl(Violated,X,Cont,B0,Bt,Indep,DepT). + +% +% Might reach optimum immediately without changing the basis, +% but in general we must assume that there were pivots. +% If the optimum meets the bound, we backsubstitute the implied +% value, solve will call us again to check for further implied +% values or unsatisfiability in the rank increased system. +% +rcbl_opt(l(L),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Strict)), + arg(4,Att,lin(Lin)), + Lin = [I,R|_], + Opt is R + I, + ( L < Opt + -> narrow_u(Type,X,Opt), % { X =< Opt } + rcbl(Continuation,B0,B1) + ; L =:= Opt, + Strict /\ 2 =:= 0, % meets lower + Mop is -Opt, + normalize_scalar(Mop,MopN), + add_linear_11(MopN,Lin,Lin1), + Lin1 = [Inhom,_|Hom], + ( Hom = [] + -> rcbl(Continuation,B0,B1) % would not callback + ; solve(Hom,Lin1,Inhom,B0,B1) + ) + ). +rcbl_opt(u(U),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Strict)), + arg(4,Att,lin(Lin)), + Lin = [I,R|_], + Opt is R + I, + ( U > Opt + -> narrow_l(Type,X,Opt), % { X >= Opt } + rcbl(Continuation,B0,B1) + ; U =:= Opt, + Strict /\ 1 =:= 0, % meets upper + Mop is -Opt, + normalize_scalar(Mop,MopN), + add_linear_11(MopN,Lin,Lin1), + Lin1 = [Inhom,_|Hom], + ( Hom = [] + -> rcbl(Continuation,B0,B1) % would not callback + ; solve(Hom,Lin1,Inhom,B0,B1) + ) + ). + +% +% Basis has already changed when this is called +% +rcbl_app(l(L),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(4,Att,lin([I,R|H])), + ( R + I > L % within bound now + -> rcbl(Continuation,B0,B1) + ; inc_step(H,Status), + rcbl_status(Status,X,Continuation,B0,B1,l(L)) + ). +rcbl_app(u(U),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(4,Att,lin([I,R|H])), + ( R + I < U % within bound now + -> rcbl(Continuation,B0,B1) + ; dec_step(H,Status), + rcbl_status(Status,X,Continuation,B0,B1,u(U)) + ). +% +% This is never called for a t_lu culprit +% +rcbl_unl(l(L),X,Continuation,B0,B1,Indep,DepT) :- + pivot_a(X,Indep,t_L(L),DepT), % changes the basis + rcbl(Continuation,B0,B1). +rcbl_unl(u(U),X,Continuation,B0,B1,Indep,DepT) :- + pivot_a(X,Indep,t_U(U),DepT), % changes the basis + rcbl(Continuation,B0,B1). + +% narrow_u(Type,X,U) +% +% Narrows down the upperbound of X (type Type) to U. +% Fails if Type is not t_u(_) or t_lu(_) + +narrow_u(t_u(_),X,U) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(U))). +narrow_u(t_lu(L,_),X,U) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). + +% narrow_l(Type,X,L) +% +% Narrows down the lowerbound of X (type Type) to L. +% Fails if Type is not t_l(_) or t_lu(_) + +narrow_l( t_l(_), X, L) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(L))). + +narrow_l( t_lu(_,U), X, L) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). + +% ----------------------------------- dump ------------------------------------ + +% dump_var(Type,Var,I,H,Dump,DumpTail) +% +% Returns in Dump a representation of the linear constraint on variable +% Var which has linear equation H + I and has type Type. + +dump_var(t_none,V,I,H) --> + !, + ( { + H = [l(W*K,_)], + V == W, + I =:= 0, + K =:= 1 + } + -> % indep var + [] + ; {nf2sum(H,I,Sum)}, + [V = Sum] + ). +dump_var(t_L(L),V,I,H) --> + !, + dump_var(t_l(L),V,I,H). +% case lowerbound: V >= L or V > L +% say V >= L, and V = K*V1 + ... + I, then K*V1 + ... + I >= L +% and K*V1 + ... >= L-I and V1 + .../K = (L-I)/K +dump_var(t_l(L),V,I,H) --> + !, + { + H = [l(_*K,_)|_], % avoid 1 >= 0 + get_attr(V,itf,Att), + arg(3,Att,strictness(Strict)), + Sm is Strict /\ 2, + Kr is 1 rdiv K, + Li is Kr*(L - I), + mult_hom(H,Kr,H1), + nf2sum(H1,0,Sum), + ( K > 0 % K > 0 + -> dump_strict(Sm,Sum >= Li,Sum > Li,Result) + ; dump_strict(Sm,Sum =< Li,Sum < Li,Result) + ) + }, + [Result]. +dump_var(t_U(U),V,I,H) --> + !, + dump_var(t_u(U),V,I,H). +dump_var(t_u(U),V,I,H) --> + !, + { + H = [l(_*K,_)|_], % avoid 0 =< 1 + get_attr(V,itf,Att), + arg(3,Att,strictness(Strict)), + Sm is Strict /\ 1, + Kr is 1 rdiv K, + Ui is Kr*(U-I), + mult_hom(H,Kr,H1), + nf2sum(H1,0.0,Sum), + ( K > 0 + -> dump_strict(Sm,Sum =< Ui,Sum < Ui,Result) + ; dump_strict(Sm,Sum >= Ui,Sum > Ui,Result) + ) + }, + [Result]. +dump_var(t_Lu(L,U),V,I,H) --> + !, + dump_var(t_l(L),V,I,H), + dump_var(t_u(U),V,I,H). +dump_var(t_lU(L,U),V,I,H) --> + !, + dump_var(t_l(L),V,I,H), + dump_var(t_u(U),V,I,H). +dump_var(t_lu(L,U),V,I,H) --> + !, + dump_var(t_l(L),V,I,H), + dump_var(t_U(U),V,I,H). +dump_var(T,V,I,H) --> % should not happen + [V:T:I+H]. + +% dump_strict(FilteredStrictness,Nonstrict,Strict,Res) +% +% Unifies Res with either Nonstrict or Strict depending on FilteredStrictness. +% FilteredStrictness is the component of strictness related to the bound: 0 +% means nonstrict, 1 means strict upperbound, 2 means strict lowerbound, +% 3 is filtered out to either 1 or 2. + +dump_strict(0,Result,_,Result). +dump_strict(1,_,Result,Result). +dump_strict(2,_,Result,Result). + +% dump_nz(V,H,I,Dump,DumpTail) +% +% Returns in Dump a representation of the nonzero constraint of variable V +% which has linear +% equation H + I. + +dump_nz(_,H,I) --> + { + H = [l(_*K,_)|_], + Kr is 1 rdiv K, + I1 is -Kr*I, + mult_hom(H,Kr,H1), + nf2sum(H1,0,Sum) + }, + [Sum =\= I1]. diff --git a/packages/clpqr/clpq/fourmotz_q.pl b/packages/clpqr/clpq/fourmotz_q.pl new file mode 100644 index 000000000..bfa2be144 --- /dev/null +++ b/packages/clpqr/clpq/fourmotz_q.pl @@ -0,0 +1,503 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(fourmotz_q, + [ + fm_elim/3 + ]). +:- use_module(bv_q, + [ + allvars/2, + basis_add/2, + detach_bounds/1, + pivot/5, + var_with_def_intern/4 + ]). +:- use_module('../clpqr/class', + [ + class_allvars/2 + ]). +:- use_module('../clpqr/project', + [ + drop_dep/1, + drop_dep_one/1, + make_target_indep/2 + ]). +:- use_module('../clpqr/redund', + [ + redundancy_vars/1 + ]). +:- use_module(store_q, + [ + add_linear_11/3, + add_linear_f1/4, + indep/2, + nf_coeff_of/3, + normalize_scalar/2 + ]). + + + +fm_elim(Vs,Target,Pivots) :- + prefilter(Vs,Vsf), + fm_elim_int(Vsf,Target,Pivots). + +% prefilter(Vars,Res) +% +% filters out target variables and variables that do not occur in bounded linear equations. +% Stores that the variables in Res are to be kept independent. + +prefilter([],[]). +prefilter([V|Vs],Res) :- + ( get_attr(V,itf,Att), + arg(9,Att,n), + occurs(V) + -> % V is a nontarget variable that occurs in a bounded linear equation + Res = [V|Tail], + setarg(10,Att,keep_indep), + prefilter(Vs,Tail) + ; prefilter(Vs,Res) + ). + +% +% the target variables are marked with an attribute, and we get a list +% of them as an argument too +% +fm_elim_int([],_,Pivots) :- % done + unkeep(Pivots). +fm_elim_int(Vs,Target,Pivots) :- + Vs = [_|_], + ( best(Vs,Best,Rest) + -> occurences(Best,Occ), + elim_min(Best,Occ,Target,Pivots,NewPivots) + ; % give up + NewPivots = Pivots, + Rest = [] + ), + fm_elim_int(Rest,Target,NewPivots). + +% best(Vs,Best,Rest) +% +% Finds the variable with the best result (lowest Delta) in fm_cp_filter +% and returns the other variables in Rest. + +best(Vs,Best,Rest) :- + findall(Delta-N,fm_cp_filter(Vs,Delta,N),Deltas), + keysort(Deltas,[_-N|_]), + select_nth(Vs,N,Best,Rest). + +% fm_cp_filter(Vs,Delta,N) +% +% For an indepenent variable V in Vs, which is the N'th element in Vs, +% find how many inequalities are generated when this variable is eliminated. +% Note that target variables and variables that only occur in unbounded equations +% should have been removed from Vs via prefilter/2 + +fm_cp_filter(Vs,Delta,N) :- + length(Vs,Len), % Len = number of variables in Vs + mem(Vs,X,Vst), % Selects a variable X in Vs, Vst is the list of elements after X in Vs + get_attr(X,itf,Att), + arg(4,Att,lin(Lin)), + arg(5,Att,order(OrdX)), + arg(9,Att,n), % no target variable + indep(Lin,OrdX), % X is an independent variable + occurences(X,Occ), + Occ = [_|_], + cp_card(Occ,0,Lnew), + length(Occ,Locc), + Delta is Lnew-Locc, + length(Vst,Vstl), + N is Len-Vstl. % X is the Nth element in Vs + +% mem(Xs,X,XsT) +% +% If X is a member of Xs, XsT is the list of elements after X in Xs. + +mem([X|Xs],X,Xs). +mem([_|Ys],X,Xs) :- mem(Ys,X,Xs). + +% select_nth(List,N,Nth,Others) +% +% Selects the N th element of List, stores it in Nth and returns the rest of the list in Others. + +select_nth(List,N,Nth,Others) :- + select_nth(List,1,N,Nth,Others). + +select_nth([X|Xs],N,N,X,Xs) :- !. +select_nth([Y|Ys],M,N,X,[Y|Xs]) :- + M1 is M+1, + select_nth(Ys,M1,N,X,Xs). + +% +% fm_detach + reverse_pivot introduce indep t_none, which +% invalidates the invariants +% +elim_min(V,Occ,Target,Pivots,NewPivots) :- + crossproduct(Occ,New,[]), + activate_crossproduct(New), + reverse_pivot(Pivots), + fm_detach(Occ), + allvars(V,All), + redundancy_vars(All), % only for New \== [] + make_target_indep(Target,NewPivots), + drop_dep(All). + +% +% restore NF by reverse pivoting +% +reverse_pivot([]). +reverse_pivot([I:D|Ps]) :- + get_attr(D,itf,AttD), + arg(2,AttD,type(Dt)), + setarg(11,AttD,n), % no longer + get_attr(I,itf,AttI), + arg(2,AttI,type(It)), + arg(5,AttI,order(OrdI)), + arg(6,AttI,class(ClI)), + pivot(D,ClI,OrdI,Dt,It), + reverse_pivot(Ps). + +% unkeep(Pivots) +% +% + +unkeep([]). +unkeep([_:D|Ps]) :- + get_attr(D,itf,Att), + setarg(11,Att,n), + drop_dep_one(D), + unkeep(Ps). + + +% +% All we drop are bounds +% +fm_detach( []). +fm_detach([V:_|Vs]) :- + detach_bounds(V), + fm_detach(Vs). + +% activate_crossproduct(Lst) +% +% For each inequality Lin =< 0 (or Lin < 0) in Lst, a new variable is created: +% Var = Lin and Var =< 0 (or Var < 0). Var is added to the basis. + +activate_crossproduct([]). +activate_crossproduct([lez(Strict,Lin)|News]) :- + var_with_def_intern(t_u(0),Var,Lin,Strict), + % Var belongs to same class as elements in Lin + basis_add(Var,_), + activate_crossproduct(News). + +% ------------------------------------------------------------------------------ + +% crossproduct(Lst,Res,ResTail) +% +% See crossproduct/4 +% This predicate each time puts the next element of Lst as First in crossproduct/4 +% and lets the rest be Next. + +crossproduct([]) --> []. +crossproduct([A|As]) --> + crossproduct(As,A), + crossproduct(As). + +% crossproduct(Next,First,Res,ResTail) +% +% Eliminates a variable in linear equations First + Next and stores the generated +% inequalities in Res. +% Let's say A:K1 = First and B:K2 = first equation in Next. +% A = ... + K1*V + ... +% B = ... + K2*V + ... +% Let K = -K2/K1 +% then K*A + B = ... + 0*V + ... +% from the bounds of A and B, via cross_lower/7 and cross_upper/7, new inequalities +% are generated. Then the same is done for B:K2 = next element in Next. + +crossproduct([],_) --> []. +crossproduct([B:Kb|Bs],A:Ka) --> + { + get_attr(A,itf,AttA), + arg(2,AttA,type(Ta)), + arg(3,AttA,strictness(Sa)), + arg(4,AttA,lin(LinA)), + get_attr(B,itf,AttB), + arg(2,AttB,type(Tb)), + arg(3,AttB,strictness(Sb)), + arg(4,AttB,lin(LinB)), + K is -Kb rdiv Ka, + add_linear_f1(LinA,K,LinB,Lin) % Lin doesn't contain the target variable anymore + }, + ( { K > 0 } % K > 0: signs were opposite + -> { Strict is Sa \/ Sb }, + cross_lower(Ta,Tb,K,Lin,Strict), + cross_upper(Ta,Tb,K,Lin,Strict) + ; % La =< A =< Ua -> -Ua =< -A =< -La + { + flip(Ta,Taf), + flip_strict(Sa,Saf), + Strict is Saf \/ Sb + }, + cross_lower(Taf,Tb,K,Lin,Strict), + cross_upper(Taf,Tb,K,Lin,Strict) + ), + crossproduct(Bs,A:Ka). + +% cross_lower(Ta,Tb,K,Lin,Strict,Res,ResTail) +% +% Generates a constraint following from the bounds of A and B. +% When A = LinA and B = LinB then Lin = K*LinA + LinB. Ta is the type +% of A and Tb is the type of B. Strict is the union of the strictness +% of A and B. If K is negative, then Ta should have been flipped (flip/2). +% The idea is that if La =< A =< Ua and Lb =< B =< Ub (=< can also be <) +% then if K is positive, K*La + Lb =< K*A + B =< K*Ua + Ub. +% if K is negative, K*Ua + Lb =< K*A + B =< K*La + Ub. +% This predicate handles the first inequality and adds it to Res in the form +% lez(Sl,Lhs) meaning K*La + Lb - (K*A + B) =< 0 or K*Ua + Lb - (K*A + B) =< 0 +% with Sl being the strictness and Lhs the lefthandside of the equation. +% See also cross_upper/7 + +cross_lower(Ta,Tb,K,Lin,Strict) --> + { + lower(Ta,La), + lower(Tb,Lb), + !, + L is K*La+Lb, + normalize_scalar(L,Ln), + add_linear_f1(Lin,-1,Ln,Lhs), + Sl is Strict >> 1 % normalize to upper bound + }, + [ lez(Sl,Lhs) ]. +cross_lower(_,_,_,_,_) --> []. + +% cross_upper(Ta,Tb,K,Lin,Strict,Res,ResTail) +% +% See cross_lower/7 +% This predicate handles the second inequality: +% -(K*Ua + Ub) + K*A + B =< 0 or -(K*La + Ub) + K*A + B =< 0 + +cross_upper(Ta,Tb,K,Lin,Strict) --> + { + upper(Ta,Ua), + upper(Tb,Ub), + !, + U is -(K*Ua+Ub), + normalize_scalar(U,Un), + add_linear_11(Un,Lin,Lhs), + Su is Strict /\ 1 % normalize to upper bound + }, + [ lez(Su,Lhs) ]. +cross_upper(_,_,_,_,_) --> []. + +% lower(Type,Lowerbound) +% +% Returns the lowerbound of type Type if it has one. +% E.g. if type = t_l(L) then Lowerbound is L, +% if type = t_lU(L,U) then Lowerbound is L, +% if type = t_u(U) then fails + +lower(t_l(L),L). +lower(t_lu(L,_),L). +lower(t_L(L),L). +lower(t_Lu(L,_),L). +lower(t_lU(L,_),L). + +% upper(Type,Upperbound) +% +% Returns the upperbound of type Type if it has one. +% See lower/2 + +upper(t_u(U),U). +upper(t_lu(_,U),U). +upper(t_U(U),U). +upper(t_Lu(_,U),U). +upper(t_lU(_,U),U). + +% flip(Type,FlippedType) +% +% Flips the lower and upperbound, so the old lowerbound becomes the new upperbound and +% vice versa. + +flip(t_l(X),t_u(X)). +flip(t_u(X),t_l(X)). +flip(t_lu(X,Y),t_lu(Y,X)). +flip(t_L(X),t_u(X)). +flip(t_U(X),t_l(X)). +flip(t_lU(X,Y),t_lu(Y,X)). +flip(t_Lu(X,Y),t_lu(Y,X)). + +% flip_strict(Strict,FlippedStrict) +% +% Does what flip/2 does, but for the strictness. + +flip_strict(0,0). +flip_strict(1,2). +flip_strict(2,1). +flip_strict(3,3). + +% cp_card(Lst,CountIn,CountOut) +% +% Counts the number of bounds that may generate an inequality in +% crossproduct/3 + +cp_card([],Ci,Ci). +cp_card([A|As],Ci,Co) :- + cp_card(As,A,Ci,Cii), + cp_card(As,Cii,Co). + +% cp_card(Next,First,CountIn,CountOut) +% +% Counts the number of bounds that may generate an inequality in +% crossproduct/4. + +cp_card([],_,Ci,Ci). +cp_card([B:Kb|Bs],A:Ka,Ci,Co) :- + get_attr(A,itf,AttA), + arg(2,AttA,type(Ta)), + get_attr(B,itf,AttB), + arg(2,AttB,type(Tb)), + ( sign(Ka) =\= sign(Kb) + -> cp_card_lower(Ta,Tb,Ci,Cii), + cp_card_upper(Ta,Tb,Cii,Ciii) + ; flip(Ta,Taf), + cp_card_lower(Taf,Tb,Ci,Cii), + cp_card_upper(Taf,Tb,Cii,Ciii) + ), + cp_card(Bs,A:Ka,Ciii,Co). + +% cp_card_lower(TypeA,TypeB,SIn,SOut) +% +% SOut = SIn + 1 if both TypeA and TypeB have a lowerbound. + +cp_card_lower(Ta,Tb,Si,So) :- + lower(Ta,_), + lower(Tb,_), + !, + So is Si+1. +cp_card_lower(_,_,Si,Si). + +% cp_card_upper(TypeA,TypeB,SIn,SOut) +% +% SOut = SIn + 1 if both TypeA and TypeB have an upperbound. + +cp_card_upper(Ta,Tb,Si,So) :- + upper(Ta,_), + upper(Tb,_), + !, + So is Si+1. +cp_card_upper(_,_,Si,Si). + +% ------------------------------------------------------------------------------ + +% occurences(V,Occ) +% +% Returns in Occ the occurrences of variable V in the linear equations of dependent variables +% with bound =\= t_none in the form of D:K where D is a dependent variable and K is the scalar +% of V in the linear equation of D. + +occurences(V,Occ) :- + get_attr(V,itf,Att), + arg(5,Att,order(OrdV)), + arg(6,Att,class(C)), + class_allvars(C,All), + occurences(All,OrdV,Occ). + +% occurences(De,OrdV,Occ) +% +% Returns in Occ the occurrences of variable V with order OrdV in the linear equations of +% dependent variables De with bound =\= t_none in the form of D:K where D is a dependent +% variable and K is the scalar of V in the linear equation of D. + +occurences(De,_,[]) :- + var(De), + !. +occurences([D|De],OrdV,Occ) :- + ( get_attr(D,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + occ_type_filter(Type), + nf_coeff_of(Lin,OrdV,K) + -> Occ = [D:K|Occt], + occurences(De,OrdV,Occt) + ; occurences(De,OrdV,Occ) + ). + +% occ_type_filter(Type) +% +% Succeeds when Type is any other type than t_none. Is used in occurences/3 and occurs/2 + +occ_type_filter(t_l(_)). +occ_type_filter(t_u(_)). +occ_type_filter(t_lu(_,_)). +occ_type_filter(t_L(_)). +occ_type_filter(t_U(_)). +occ_type_filter(t_lU(_,_)). +occ_type_filter(t_Lu(_,_)). + +% occurs(V) +% +% Checks whether variable V occurs in a linear equation of a dependent variable with a bound +% =\= t_none. + +occurs(V) :- + get_attr(V,itf,Att), + arg(5,Att,order(OrdV)), + arg(6,Att,class(C)), + class_allvars(C,All), + occurs(All,OrdV). + +% occurs(De,OrdV) +% +% Checks whether variable V with order OrdV occurs in a linear equation of any dependent variable +% in De with a bound =\= t_none. + +occurs(De,_) :- + var(De), + !, + fail. +occurs([D|De],OrdV) :- + ( get_attr(D,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + occ_type_filter(Type), + nf_coeff_of(Lin,OrdV,_) + -> true + ; occurs(De,OrdV) + ). \ No newline at end of file diff --git a/packages/clpqr/clpq/ineq_q.pl b/packages/clpqr/clpq/ineq_q.pl new file mode 100644 index 000000000..965c62981 --- /dev/null +++ b/packages/clpqr/clpq/ineq_q.pl @@ -0,0 +1,1281 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(ineq_q, + [ + ineq/4, + ineq_one/4, + ineq_one_n_n_0/1, + ineq_one_n_p_0/1, + ineq_one_s_n_0/1, + ineq_one_s_p_0/1 + ]). +:- use_module(bv_q, + [ + backsubst/3, + backsubst_delta/4, + basis_add/2, + dec_step/2, + deref/2, + determine_active_dec/1, + determine_active_inc/1, + export_binding/1, + get_or_add_class/2, + inc_step/2, + lb/3, + pivot_a/4, + rcbl_status/6, + reconsider/1, + same_class/2, + solve/1, + ub/3, + unconstrained/4, + var_intern/3, + var_with_def_intern/4 + ]). +:- use_module(store_q, + [ + add_linear_11/3, + add_linear_ff/5, + normalize_scalar/2 + ]). + +% ineq(H,I,Nf,Strictness) +% +% Solves the inequality Nf < 0 or Nf =< 0 where Nf is in normal form +% and H and I are the homogene and inhomogene parts of Nf. + +ineq([],I,_,Strictness) :- ineq_ground(Strictness,I). +ineq([v(K,[X^1])|Tail],I,Lin,Strictness) :- + ineq_cases(Tail,I,Lin,Strictness,X,K). + +ineq_cases([],I,_,Strictness,X,K) :- % K*X + I < 0 or K*X + I =< 0 + ineq_one(Strictness,X,K,I). +ineq_cases([_|_],_,Lin,Strictness,_,_) :- + deref(Lin,Lind), % Id+Hd =< 0 + Lind = [Inhom,_|Hom], + ineq_more(Hom,Inhom,Lind,Strictness). + +% ineq_ground(Strictness,I) +% +% Checks whether a grounded inequality I < 0 or I =< 0 is satisfied. + +ineq_ground(strict,I) :- I < 0. +ineq_ground(nonstrict,I) :- I =< 0. + +% ineq_one(Strictness,X,K,I) +% +% Solves the inequality K*X + I < 0 or K*X + I =< 0 + +ineq_one(strict,X,K,I) :- + ( K > 0 + -> ( I =:= 0 + -> ineq_one_s_p_0(X) % K*X < 0, K > 0 => X < 0 + ; Inhom is I rdiv K, + ineq_one_s_p_i(X,Inhom) % K*X + I < 0, K > 0 => X + I/K < 0 + ) + ; ( I =:= 0 + -> ineq_one_s_n_0(X) % K*X < 0, K < 0 => -X < 0 + ; Inhom is -I rdiv K, + ineq_one_s_n_i(X,Inhom) % K*X + I < 0, K < 0 => -X - I/K < 0 + ) + ). +ineq_one(nonstrict,X,K,I) :- + ( K > 0 + -> ( I =:= 0 + -> ineq_one_n_p_0(X) % K*X =< 0, K > 0 => X =< 0 + ; Inhom is I rdiv K, + ineq_one_n_p_i(X,Inhom) % K*X + I =< 0, K > 0 => X + I/K =< 0 + ) + ; ( I =:= 0 + -> ineq_one_n_n_0(X) % K*X =< 0, K < 0 => -X =< 0 + ; Inhom is -I rdiv K, + ineq_one_n_n_i(X,Inhom) % K*X + I =< 0, K < 0 => -X - I/K =< 0 + ) + ). + +% --------------------------- strict ---------------------------- + +% ineq_one_s_p_0(X) +% +% Solves the inequality X < 0 + +ineq_one_s_p_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, % old variable, this is deref + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_p_0(OrdX,X,Ix) + ). +ineq_one_s_p_0(X) :- % new variable, nothing depends on it + var_intern(t_u(0),X,1). % put a strict inactive upperbound on the variable + +% ineq_one_s_n_0(X) +% +% Solves the inequality X > 0 + +ineq_one_s_n_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_n_0(OrdX,X,Ix) + ). +ineq_one_s_n_0(X) :- + var_intern(t_l(0),X,2). % puts a strict inactive lowerbound on the variable + +% ineq_one_s_p_i(X,I) +% +% Solves the inequality X < -I + +ineq_one_s_p_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_p_i(OrdX,I,X,Ix) + ). +ineq_one_s_p_i(X,I) :- + Bound is -I, + var_intern(t_u(Bound),X,1). % puts a strict inactive upperbound on the variable + +% ineq_one_s_n_i(X,I) +% +% Solves the inequality X > I + +ineq_one_s_n_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_n_i(OrdX,I,X,Ix) + ). +ineq_one_s_n_i(X,I) :- var_intern(t_l(I),X,2). % puts a strict inactive lowerbound on the variable + +% ineq_one_old_s_p_0(Hom,X,Inhom) +% +% Solves the inequality X < 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_p_0([],_,Ix) :- Ix < 0. % X = I: Ix < 0 +ineq_one_old_s_p_0([l(Y*Ky,_)|Tail],X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -Ix rdiv Ky, + update_indep(strict,Y,Ky,Bound) % X < 0, X = K*Y + I => Y < -I/K or Y > -I/K (depending on K) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udus(Type,X,Lin,0,Old) % update strict upperbound + ). + +% ineq_one_old_s_p_0(Hom,X,Inhom) +% +% Solves the inequality X > 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_n_0([],_,Ix) :- Ix > 0. % X = I: Ix > 0 +ineq_one_old_s_n_0([l(Y*Ky,_)|Tail], X, Ix) :- + ( Tail = [] % X = K*Y + I + -> Coeff is -Ky, + Bound is Ix rdiv Coeff, + update_indep(strict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udls(Type,X,Lin,0,Old) % update strict lowerbound + ). + +% ineq_one_old_s_p_i(Hom,C,X,Inhom) +% +% Solves the inequality X + C < 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_p_i([],I,_,Ix) :- I + Ix < 0. % X = I +ineq_one_old_s_p_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -(Ix + I) rdiv Ky, + update_indep(strict,Y,Ky,Bound) + ; Tail = [_|_] + -> Bound is -I, + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udus(Type,X,Lin,Bound,Old) % update strict upperbound + ). + +% ineq_one_old_s_n_i(Hom,C,X,Inhom) +% +% Solves the inequality X - C > 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_n_i([],I,_,Ix) :- I - Ix < 0. % X = I +ineq_one_old_s_n_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Coeff is -Ky, + Bound is (Ix - I) rdiv Coeff, + update_indep(strict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udls(Type,X,Lin,I,Old) % update strict lowerbound + ). + +% -------------------------- nonstrict -------------------------- + +% ineq_one_n_p_0(X) +% +% Solves the inequality X =< 0 + +ineq_one_n_p_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, % old variable, this is deref + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_p_0(OrdX,X,Ix) + ). +ineq_one_n_p_0(X) :- % new variable, nothing depends on it + var_intern(t_u(0),X,0). % nonstrict upperbound + +% ineq_one_n_n_0(X) +% +% Solves the inequality X >= 0 + +ineq_one_n_n_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_n_0(OrdX,X,Ix) + ). +ineq_one_n_n_0(X) :- + var_intern(t_l(0),X,0). % nonstrict lowerbound + +% ineq_one_n_p_i(X,I) +% +% Solves the inequality X =< -I + +ineq_one_n_p_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_p_i(OrdX,I,X,Ix) + ). +ineq_one_n_p_i(X,I) :- + Bound is -I, + var_intern(t_u(Bound),X,0). % nonstrict upperbound + +% ineq_one_n_n_i(X,I) +% +% Solves the inequality X >= I + +ineq_one_n_n_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpq) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_n_i(OrdX,I,X,Ix) + ). +ineq_one_n_n_i(X,I) :- + var_intern(t_l(I),X,0). % nonstrict lowerbound + +% ineq_one_old_n_p_0(Hom,X,Inhom) +% +% Solves the inequality X =< 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_p_0([],_,Ix) :- Ix =< 0. % X =I +ineq_one_old_n_p_0([l(Y*Ky,_)|Tail],X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -Ix rdiv Ky, + update_indep(nonstrict,Y,Ky,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udu(Type,X,Lin,0,Old) % update nonstrict upperbound + ). + +% ineq_one_old_n_n_0(Hom,X,Inhom) +% +% Solves the inequality X >= 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_n_0([],_,Ix) :- Ix >= 0. % X = I +ineq_one_old_n_n_0([l(Y*Ky,_)|Tail], X, Ix) :- + ( Tail = [] % X = K*Y + I + -> Coeff is -Ky, + Bound is Ix rdiv Coeff, + update_indep(nonstrict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udl(Type,X,Lin,0,Old) % update nonstrict lowerbound + ). + +% ineq_one_old_n_p_i(Hom,C,X,Inhom) +% +% Solves the inequality X + C =< 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_p_i([],I,_,Ix) :- I + Ix =< 0. % X = I +ineq_one_old_n_p_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -(Ix + I) rdiv Ky, + update_indep(nonstrict,Y,Ky,Bound) + ; Tail = [_|_] + -> Bound is -I, + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udu(Type,X,Lin,Bound,Old) % update nonstrict upperbound + ). + +% ineq_one_old_n_n_i(Hom,C,X,Inhom) +% +% Solves the inequality X - C >= 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_n_i([],I,_,Ix) :- I - Ix =< 0. % X = I +ineq_one_old_n_n_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] + -> Coeff is -Ky, + Bound is (Ix - I) rdiv Coeff, + update_indep(nonstrict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udl(Type,X,Lin,I,Old) + ). + +% --------------------------------------------------------------- + +% ineq_more(Hom,Inhom,Lin,Strictness) +% +% Solves the inequality Lin < 0 or Lin =< 0 with Lin = Hom + Inhom + +ineq_more([],I,_,Strictness) :- ineq_ground(Strictness,I). % I < 0 or I =< 0 +ineq_more([l(X*K,_)|Tail],Id,Lind,Strictness) :- + ( Tail = [] + -> % X*K < Id or X*K =< Id + % one var: update bound instead of slack introduction + get_or_add_class(X,_), % makes sure X belongs to a class + Bound is -Id rdiv K, + update_indep(Strictness,X,K,Bound) % new bound + ; Tail = [_|_] + -> ineq_more(Strictness,Lind) + ). + +% ineq_more(Strictness,Lin) +% +% Solves the inequality Lin < 0 or Lin =< 0 + +ineq_more(strict,Lind) :- + ( unconstrained(Lind,U,K,Rest) + -> % never fails, no implied value + % Lind < 0 => Rest < -K*U where U has no bounds + var_intern(t_l(0),S,2), % create slack variable S + get_attr(S,itf,AttS), + arg(5,AttS,order(OrdS)), + Ki is -1 rdiv K, + add_linear_ff(Rest,Ki,[0,0,l(S*1,OrdS)],Ki,LinU), % U = (-1/K)*Rest + (-1/K)*S + LinU = [_,_|Hu], + get_or_add_class(U,Class), + same_class(Hu,Class), % put all variables of new lin. eq. of U in the same class + get_attr(U,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(ClassU)), + backsubst(ClassU,OrdU,LinU) % substitute U by new lin. eq. everywhere in the class + ; var_with_def_intern(t_u(0),S,Lind,1), % Lind < 0 => Lind = S with S < 0 + basis_add(S,_), % adds S to the basis + determine_active_dec(Lind), % activate bounds + reconsider(S) % reconsider basis + ). +ineq_more(nonstrict,Lind) :- + ( unconstrained(Lind,U,K,Rest) + -> % never fails, no implied value + % Lind =< 0 => Rest =< -K*U where U has no bounds + var_intern(t_l(0),S,0), % create slack variable S + Ki is -1 rdiv K, + get_attr(S,itf,AttS), + arg(5,AttS,order(OrdS)), + add_linear_ff(Rest,Ki,[0,0,l(S*1,OrdS)],Ki,LinU), % U = (-1K)*Rest + (-1/K)*S + LinU = [_,_|Hu], + get_or_add_class(U,Class), + same_class(Hu,Class), % put all variables of new lin. eq of U in the same class + get_attr(U,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(ClassU)), + backsubst(ClassU,OrdU,LinU) % substitute U by new lin. eq. everywhere in the class + ; % all variables are constrained + var_with_def_intern(t_u(0),S,Lind,0), % Lind =< 0 => Lind = S with S =< 0 + basis_add(S,_), % adds S to the basis + determine_active_dec(Lind), + reconsider(S) + ). + + +% update_indep(Strictness,X,K,Bound) +% +% Updates the bound of independent variable X where X < Bound or X =< Bound +% or X > Bound or X >= Bound, depending on Strictness and K. + +update_indep(strict,X,K,Bound) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + ( K < 0 + -> uils(Type,X,Lin,Bound,Old) % update independent lowerbound strict + ; uius(Type,X,Lin,Bound,Old) % update independent upperbound strict + ). +update_indep(nonstrict,X,K,Bound) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + ( K < 0 + -> uil(Type,X,Lin,Bound,Old) % update independent lowerbound nonstrict + ; uiu(Type,X,Lin,Bound,Old) % update independent upperbound nonstrict + ). + + +% --------------------------------------------------------------------------------------- + +% +% Update a bound on a var xi +% +% a) independent variable +% +% a1) update inactive bound: done +% +% a2) update active bound: +% Determine [lu]b including most constraining row R +% If we are within: done +% else pivot(R,xi) and introduce bound via (b) +% +% a3) introduce a bound on an unconstrained var: +% All vars that depend on xi are unconstrained (invariant) -> +% the bound cannot invalidate any Lhs +% +% b) dependent variable +% +% repair upper or lower (maybe just swap with an unconstrained var from Rhs) +% + +% +% Sign = 1,0,-1 means inside,at,outside +% + +% Read following predicates as update (dependent/independent) (lowerbound/upperbound) (strict) + +% udl(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. + +udl(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_l(Bound))), + setarg(3,AttX,strictness(0)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> Ki is -1 rdiv Kuc, + add_linear_ff(Rest,Ki,[0,0,l(X* -1,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; basis_add(X,_), + determine_active_inc(Lin), + reconsider(X) + ). +udl(t_l(L),X,Lin,Bound,Sold) :- + ( Bound > L + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; true + ). + +udl(t_u(U),X,Lin,Bound,_Sold) :- + ( Bound < U + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + reconsider_lower(X,Lin,Bound) % makes sure that Lin still satisfies lowerbound Bound + ; Bound =:= U, + solve_bound(Lin,Bound) % new bound is equal to upperbound: solve + ). +udl(t_lu(L,U),X,Lin,Bound,Sold) :- + ( Bound > L + -> ( Bound < U + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; Bound =:= U, + Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). + +% udls(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. + +udls(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_l(Bound))), + setarg(3,AttX,strictness(2)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => U = -1/K*Rest + 1/K*X with U an unconstrained variable + Ki is -1 rdiv Kuc, + add_linear_ff(Rest,Ki,[0,0,l(X* -1,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables: add X to basis and reconsider basis + basis_add(X,_), + determine_active_inc(Lin), + reconsider(X) + ). +udls(t_l(L),X,Lin,Bound,Sold) :- + ( Bound < L + -> true + ; Bound > L + -> Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; % equal to lowerbound: check strictness + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +udls(t_u(U),X,Lin,Bound,Sold) :- + Bound < U, % smaller than upperbound: set new bound + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound). +udls(t_lu(L,U),X,Lin,Bound,Sold) :- + ( Bound < L + -> true % smaller than lowerbound: keep + ; Bound > L + -> % larger than lowerbound: check upperbound and possibly use new and reconsider basis + Bound < U, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; % equal to lowerbound: put new strictness + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% udu(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. + +udu(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_u(Bound))), + setarg(3,AttX,strictness(0)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => U = -1/K*Rest + 1/K*X with U an unconstrained variable + Ki is -1 rdiv Kuc, + add_linear_ff(Rest,Ki,[0,0,l(X* -1,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables: add X to basis and reconsider basis + basis_add(X,_), + determine_active_dec(Lin), % try to lower R + reconsider(X) + ). +udu(t_u(U),X,Lin,Bound,Sold) :- + ( Bound < U + -> Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; true + ). +udu(t_l(L),X,Lin,Bound,_Sold) :- + ( Bound > L + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + reconsider_upper(X,Lin,Bound) + ; Bound =:= L, + solve_bound(Lin,Bound) % equal to lowerbound: solve + ). +udu(t_lu(L,U),X,Lin,Bound,Sold) :- + ( Bound < U + -> ( Bound > L + -> Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; Bound =:= L, + Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). + +% udus(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. + +udus(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_u(Bound))), + setarg(3,AttX,strictness(1)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => U = -1/K*Rest + 1/K*X with U an unconstrained variable + Ki is -1 rdiv Kuc, + add_linear_ff(Rest,Ki,[0,0,l(X* -1,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables: add X to basis and reconsider basis + basis_add(X,_), + determine_active_dec(Lin), + reconsider(X) + ). +udus(t_u(U),X,Lin,Bound,Sold) :- + ( U < Bound + -> true % larger than upperbound: keep + ; Bound < U + -> % smaller than upperbound: update bound and reconsider basis + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; % equal to upperbound: set new strictness + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +udus(t_l(L),X,Lin,Bound,Sold) :- + L < Bound, % larger than lowerbound: update and reconsider basis + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound). +udus(t_lu(L,U),X,Lin,Bound,Sold) :- + ( U < Bound + -> true % larger than upperbound: keep + ; Bound < U + -> % smaller than upperbound: check lowerbound, possibly update and reconsider basis + L < Bound, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; % equal to upperbound: update strictness + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% uiu(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. + +uiu(t_none,X,_Lin,Bound,_) :- % X had no bounds + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(0)). +uiu(t_u(U),X,_Lin,Bound,Sold) :- + ( U < Bound + -> true % larger than upperbound: keep + ; Bound < U + -> % smaller than upperbound: update. + Strict is Sold /\ 2, % update strictness: strictness of lowerbound is kept, + % strictness of upperbound is set to non-strict + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)) + ; true % equal to upperbound and nonstrict: keep + ). +uiu(t_l(L),X,Lin,Bound,_Sold) :- + ( Bound > L + -> % Upperbound is larger than lowerbound: store new bound + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))) + ; Bound =:= L, + solve_bound(Lin,Bound) % Lowerbound was equal to new upperbound: solve + ). +uiu(t_L(L),X,Lin,Bound,_Sold) :- + ( Bound > L + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))) + ; Bound =:= L, + solve_bound(Lin,Bound) + ). +uiu(t_lu(L,U),X,Lin,Bound,Sold) :- + ( Bound < U + -> ( Bound > L + -> Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; Bound =:= L, + Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uiu(t_Lu(L,U),X,Lin,Bound,Sold) :- + ( Bound < U + -> ( L < Bound + -> Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; L =:= Bound, + Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uiu(t_U(U),X,_Lin,Bound,Sold) :- + ( Bound < U + -> Strict is Sold /\ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound =< Lb + U + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_U(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_u(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_U(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; true + ). +uiu(t_lU(L,U),X,Lin,Bound,Sold) :- + ( Bound < U + -> ( L < Bound + -> Strict is Sold /\ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound =< Lb + U + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_lU(L,Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_lu(L,Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_lU(L,Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; L =:= Bound, + Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). + +% uius(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. (see also uiu/5) + +uius(t_none,X,_Lin,Bound,_Sold) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(1)). +uius(t_u(U),X,_Lin,Bound,Sold) :- + ( U < Bound + -> true + ; Bound < U + -> Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_l(L),X,_Lin,Bound,Sold) :- + L < Bound, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)). +uius(t_L(L),X,_Lin,Bound,Sold) :- + L < Bound, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))), + setarg(3,Att,strictness(Strict)). +uius(t_lu(L,U),X,_Lin,Bound,Sold) :- + ( U < Bound + -> true + ; Bound < U + -> L < Bound, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_Lu(L,U),X,_Lin,Bound,Sold) :- + ( U < Bound + -> true + ; Bound < U + -> L < Bound, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_U(U),X,_Lin,Bound,Sold) :- + ( U < Bound + -> true + ; Bound < U + -> Strict is Sold \/ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound =< Lb + U + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_U(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_u(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_U(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_lU(L,U),X,_Lin,Bound,Sold) :- + ( U < Bound + -> true + ; Bound < U + -> L < Bound, + Strict is Sold \/ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound =< Lb + U + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_lU(L,Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_lu(L,Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_lU(L,Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% uil(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. (see also uiu/5) + + +uil(t_none,X,_Lin,Bound,_Sold) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(0)). +uil(t_l(L),X,_Lin,Bound,Sold) :- + ( Bound > L + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)) + ; true + ). +uil(t_u(U),X,Lin,Bound,_Sold) :- + ( Bound < U + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))) + ; Bound =:= U, + solve_bound(Lin,Bound) + ). +uil(t_U(U),X,Lin,Bound,_Sold) :- + ( Bound < U + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))) + ; Bound =:= U, + solve_bound(Lin,Bound) + ). +uil(t_lu(L,U),X,Lin,Bound,Sold) :- + ( Bound > L + -> ( Bound < U + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Bound =:= U, + Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uil(t_lU(L,U),X,Lin,Bound,Sold) :- + ( Bound > L + -> ( Bound < U + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Bound =:= U, + Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uil(t_L(L),X,_Lin,Bound,Sold) :- + ( Bound > L + -> Strict is Sold /\ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound >= Ub + L + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_L(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_l(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_L(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; true + ). +uil(t_Lu(L,U),X,Lin,Bound,Sold) :- + ( Bound > L + -> ( Bound < U + -> Strict is Sold /\ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound >= Ub + L + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,t_Lu(Bound,U)), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_lu(Bound,U)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_Lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Bound =:= U, + Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). + +% uils(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. (see also uiu/5) + +uils(t_none,X,_Lin,Bound,_Sold) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(2)). +uils(t_l(L),X,_Lin,Bound,Sold) :- + ( Bound < L + -> true + ; Bound > L + -> Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_u(U),X,_Lin,Bound,Sold) :- + Bound < U, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)). +uils(t_U(U),X,_Lin,Bound,Sold) :- + Bound < U, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))), + setarg(3,Att,strictness(Strict)). +uils(t_lu(L,U),X,_Lin,Bound,Sold) :- + ( Bound < L + -> true + ; Bound > L + -> Bound < U, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_lU(L,U),X,_Lin,Bound,Sold) :- + ( Bound < L + -> true + ; Bound > L + -> Bound < U, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_L(L),X,_Lin,Bound,Sold) :- + ( Bound < L + -> true + ; Bound > L + -> Strict is Sold \/ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound >= Ub + L + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_L(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_l(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_L(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_Lu(L,U),X,_Lin,Bound,Sold) :- + ( Bound < L + -> true + ; Bound > L + -> Bound < U, + Strict is Sold \/ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound >= Ub + L + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_Lu(Bound,U))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_lu(Bound,U)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_Lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% reconsider_upper(X,Lin,U) +% +% Checks if the upperbound of X which is U, satisfies the bounds +% of the variables in Lin: let R be the sum of all the bounds on +% the variables in Lin, and I be the inhomogene part of Lin, then +% upperbound U should be larger than R + I (R may contain +% lowerbounds). +% See also rcb/3 in bv.pl + +% The code could probably be further specialized to only +% decrement/increment in case a variable takes a value equal to a +% _strict_ upper/lower bound. Also note that this is only for the +% CLP(Q) version. The CLP(R) fuzzy arithmetic makes it useless to +% really distinguish between strict and non-strict inequalities. + +reconsider_upper(X,[I,R|H],U) :- + R + I >= U, % violation + !, + dec_step(H,Status), % we want to decrement R + rcbl_status(Status,X,[],Binds,[],u(U)), + export_binding(Binds). +reconsider_upper( _, _, _). + +% reconsider_lower(X,Lin,L) +% +% Checks if the lowerbound of X which is L, satisfies the bounds +% of the variables in Lin: let R be the sum of all the bounds on +% the variables in Lin, and I be the inhomogene part of Lin, then +% lowerbound L should be smaller than R + I (R may contain +% upperbounds). +% See also rcb/3 in bv.pl + +reconsider_lower(X,[I,R|H],L) :- + R + I =< L, % violation + !, + inc_step(H,Status), % we want to increment R + rcbl_status(Status,X,[],Binds,[],l(L)), + export_binding(Binds). +reconsider_lower(_,_,_). + +% +% lin is dereferenced +% + +% solve_bound(Lin,Bound) +% +% Solves the linear equation Lin - Bound = 0 +% Lin is the linear equation of X, a variable whose bounds have narrowed to value Bound + +solve_bound(Lin,Bound) :- + Bound =:= 0, + !, + solve(Lin). +solve_bound(Lin,Bound) :- + Nb is -Bound, + normalize_scalar(Nb,Nbs), + add_linear_11(Nbs,Lin,Eq), + solve(Eq). diff --git a/packages/clpqr/clpq/itf_q.pl b/packages/clpqr/clpq/itf_q.pl new file mode 100644 index 000000000..7add42fa7 --- /dev/null +++ b/packages/clpqr/clpq/itf_q.pl @@ -0,0 +1,222 @@ +/* + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(itf_q, + [ + do_checks/8 + ]). +:- use_module(bv_q, + [ + deref/2, + detach_bounds_vlv/5, + solve/1, + solve_ord_x/3 + ]). +:- use_module(nf_q, + [ + nf/2 + ]). +:- use_module(store_q, + [ + add_linear_11/3, + indep/2, + nf_coeff_of/3 + ]). +:- use_module('../clpqr/class', + [ + class_drop/2 + ]). + +do_checks(Y,Ty,St,Li,Or,Cl,No,Later) :- + numbers_only(Y), + verify_nonzero(No,Y), + verify_type(Ty,St,Y,Later,[]), + verify_lin(Or,Cl,Li,Y), + maplist(call,Later). + +numbers_only(Y) :- + ( var(Y) + ; rational(Y) + ; throw(type_error(_X = Y,2,'a rational number',Y)) + ), + !. + +% verify_nonzero(Nonzero,Y) +% +% if Nonzero = nonzero, then verify that Y is not zero +% (if possible, otherwise set Y to be nonzero) + +verify_nonzero(nonzero,Y) :- + ( var(Y) + -> ( get_attr(Y,itf,Att) + -> setarg(8,Att,nonzero) + ; put_attr(Y,itf,t(clpq,n,n,n,n,n,n,nonzero,n,n,n)) + ) + ; Y =\= 0 + ). +verify_nonzero(n,_). % X is not nonzero + +% verify_type(type(Type),strictness(Strict),Y,[OL|OLT],OLT) +% +% if possible verifies whether Y satisfies the type and strictness of X +% if not possible to verify, then returns the constraints that follow from +% the type and strictness + +verify_type(type(Type),strictness(Strict),Y) --> + verify_type2(Y,Type,Strict). +verify_type(n,n,_) --> []. + +verify_type2(Y,TypeX,StrictX) --> + {var(Y)}, + !, + verify_type_var(TypeX,Y,StrictX). +verify_type2(Y,TypeX,StrictX) --> + {verify_type_nonvar(TypeX,Y,StrictX)}. + +% verify_type_nonvar(Type,Nonvar,Strictness) +% +% verifies whether the type and strictness are satisfied with the Nonvar + +verify_type_nonvar(t_none,_,_). +verify_type_nonvar(t_l(L),Value,S) :- ilb(S,L,Value). +verify_type_nonvar(t_u(U),Value,S) :- iub(S,U,Value). +verify_type_nonvar(t_lu(L,U),Value,S) :- + ilb(S,L,Value), + iub(S,U,Value). +verify_type_nonvar(t_L(L),Value,S) :- ilb(S,L,Value). +verify_type_nonvar(t_U(U),Value,S) :- iub(S,U,Value). +verify_type_nonvar(t_Lu(L,U),Value,S) :- + ilb(S,L,Value), + iub(S,U,Value). +verify_type_nonvar(t_lU(L,U),Value,S) :- + ilb(S,L,Value), + iub(S,U,Value). + +% ilb(Strict,Lower,Value) & iub(Strict,Upper,Value) +% +% check whether Value is satisfiable with the given lower/upper bound and +% strictness. +% strictness is encoded as follows: +% 2 = strict lower bound +% 1 = strict upper bound +% 3 = strict lower and upper bound +% 0 = no strict bounds + +ilb(S,L,V) :- + S /\ 2 =:= 0, + !, + L =< V. % non-strict +ilb(_,L,V) :- L < V. % strict + +iub(S,U,V) :- + S /\ 1 =:= 0, + !, + V =< U. % non-strict +iub(_,U,V) :- V < U. % strict + +% +% Running some goals after X=Y simplifies the coding. It should be possible +% to run the goals here and taking care not to put_atts/2 on X ... +% + +% verify_type_var(Type,Var,Strictness,[OutList|OutListTail],OutListTail) +% +% returns the inequalities following from a type and strictness satisfaction +% test with Var + +verify_type_var(t_none,_,_) --> []. +verify_type_var(t_l(L),Y,S) --> llb(S,L,Y). +verify_type_var(t_u(U),Y,S) --> lub(S,U,Y). +verify_type_var(t_lu(L,U),Y,S) --> + llb(S,L,Y), + lub(S,U,Y). +verify_type_var(t_L(L),Y,S) --> llb(S,L,Y). +verify_type_var(t_U(U),Y,S) --> lub(S,U,Y). +verify_type_var(t_Lu(L,U),Y,S) --> + llb(S,L,Y), + lub(S,U,Y). +verify_type_var(t_lU(L,U),Y,S) --> + llb(S,L,Y), + lub(S,U,Y). + +% llb(Strict,Lower,Value,[OL|OLT],OLT) and lub(Strict,Upper,Value,[OL|OLT],OLT) +% +% returns the inequalities following from the lower and upper bounds and the +% strictness see also lb and ub +llb(S,L,V) --> + {S /\ 2 =:= 0}, + !, + [clpq:{L =< V}]. +llb(_,L,V) --> [clpq:{L < V}]. + +lub(S,U,V) --> + {S /\ 1 =:= 0}, + !, + [clpq:{V =< U}]. +lub(_,U,V) --> [clpq:{V < U}]. + +% +% We used to drop X from the class/basis to avoid trouble with subsequent +% put_atts/2 on X. Now we could let these dead but harmless updates happen. +% In R however, exported bindings might conflict, e.g. 0 \== 0.0 +% +% If X is indep and we do _not_ solve for it, we are in deep shit +% because the ordering is violated. +% +verify_lin(order(OrdX),class(Class),lin(LinX),Y) :- + !, + ( indep(LinX,OrdX) + -> detach_bounds_vlv(OrdX,LinX,Class,Y,NewLinX), + % if there were bounds, they are requeued already + class_drop(Class,Y), + nf(-Y,NfY), + deref(NfY,LinY), + add_linear_11(NewLinX,LinY,Lind), + ( nf_coeff_of(Lind,OrdX,_) + -> % X is element of Lind + solve_ord_x(Lind,OrdX,Class) + ; solve(Lind) % X is gone, can safely solve Lind + ) + ; class_drop(Class,Y), + nf(-Y,NfY), + deref(NfY,LinY), + add_linear_11(LinX,LinY,Lind), + solve(Lind) + ). +verify_lin(_,_,_,_). \ No newline at end of file diff --git a/packages/clpqr/clpq/nf_q.pl b/packages/clpqr/clpq/nf_q.pl new file mode 100644 index 000000000..17007ccf7 --- /dev/null +++ b/packages/clpqr/clpq/nf_q.pl @@ -0,0 +1,1119 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(nf_q, + [ + {}/1, + nf/2, + entailed/1, + split/3, + repair/2, + nf_constant/2, + wait_linear/3, + nf2term/2 + ]). +:- use_module('../clpqr/geler', + [ + geler/3 + ]). +:- use_module(bv_q, + [ + log_deref/4, + solve/1, + 'solve_<'/1, + 'solve_=<'/1, + 'solve_=\\='/1 + ]). +:- use_module(ineq_q, + [ + ineq_one/4, + ineq_one_s_p_0/1, + ineq_one_s_n_0/1, + ineq_one_n_p_0/1, + ineq_one_n_n_0/1 + ]). +:- use_module(store_q, + [ + add_linear_11/3, + normalize_scalar/2 + ]). + +goal_expansion(geler(X,Y),geler(clpq,X,Y)). + +% ------------------------------------------------------------------------- + +% {Constraint} +% +% Adds the constraint Constraint to the constraint store. +% +% First rule is to prevent binding with other rules when a variable is input +% Constraints are converted to normal form and if necessary, submitted to the linear +% equality/inequality solver (bv + ineq) or to the non-linear store (geler) + +{Rel} :- + var(Rel), + !, + throw(instantiation_error({Rel},1)). +{R,Rs} :- + !, + {R},{Rs}. +{R;Rs} :- + !, + ({R};{Rs}). % for entailment checking +{L < R} :- + !, + nf(L-R,Nf), + submit_lt(Nf). +{L > R} :- + !, + nf(R-L,Nf), + submit_lt(Nf). +{L =< R} :- + !, + nf(L-R,Nf), + submit_le( Nf). +{<=(L,R)} :- + !, + nf(L-R,Nf), + submit_le(Nf). +{L >= R} :- + !, + nf(R-L,Nf), + submit_le(Nf). +{L =\= R} :- + !, + nf(L-R,Nf), + submit_ne(Nf). +{L =:= R} :- + !, + nf(L-R,Nf), + submit_eq(Nf). +{L = R} :- + !, + nf(L-R,Nf), + submit_eq(Nf). +{Rel} :- throw(type_error({Rel},1,'a constraint',Rel)). + +% entailed(C) +% +% s -> c = ~s v c = ~(s /\ ~c) +% where s is the store and c is the constraint for which +% we want to know whether it is entailed. +% C is negated and added to the store. If this fails, then c is entailed by s + +entailed(C) :- + negate(C,Cn), + \+ {Cn}. + +% negate(C,Res). +% +% Res is the negation of constraint C +% first rule is to prevent binding with other rules when a variable is input + +negate(Rel,_) :- + var(Rel), + !, + throw(instantiation_error(entailed(Rel),1)). +negate((A,B),(Na;Nb)) :- + !, + negate(A,Na), + negate(B,Nb). +negate((A;B),(Na,Nb)) :- + !, + negate(A,Na), + negate(B,Nb). +negate(A=B) :- !. +negate(A>B,A=B) :- !. +negate(A>=B,A A = 0 +% b4) nonlinear -> geler +% c) Nf=[A,B|Rest] +% c1) A=k +% c11) (B=c*X^+1 or B=c*X^-1), Rest=[] -> B=-k/c or B=-c/k +% c12) invertible(A,B) +% c13) linear(B|Rest) +% c14) geler +% c2) linear(Nf) +% c3) nonlinear -> geler + +submit_eq([]). % trivial success: case a +submit_eq([T|Ts]) :- + submit_eq(Ts,T). +submit_eq([],A) :- submit_eq_b(A). % case b +submit_eq([B|Bs],A) :- submit_eq_c(A,B,Bs). % case c + +% submit_eq_b(A) +% +% Handles case b of submit_eq/1 + +% case b1: A is a constant (non-zero) +submit_eq_b(v(_,[])) :- + !, + fail. +% case b2/b3: A is n*X^P => X = 0 +submit_eq_b(v(_,[X^P])) :- + var(X), + P > 0, + !, + X = 0. +% case b2: non-linear is invertible: NL(X) = 0 => X - inv(NL)(0) = 0 +submit_eq_b(v(_,[NL^1])) :- + nonvar(NL), + nl_invertible(NL,X,0,Inv), + !, + nf(-Inv,S), + nf_add(X,S,New), + submit_eq(New). +% case b4: A is non-linear and not invertible => submit equality to geler +submit_eq_b(Term) :- + term_variables(Term,Vs), + geler(Vs,nf_q:resubmit_eq([Term])). + +% submit_eq_c(A,B,Rest) +% +% Handles case c of submit_eq/1 + +% case c1: A is a constant +submit_eq_c(v(I,[]),B,Rest) :- + !, + submit_eq_c1(Rest,B,I). +% case c2: A,B and Rest are linear +submit_eq_c(A,B,Rest) :- % c2 + A = v(_,[X^1]), + var(X), + B = v(_,[Y^1]), + var(Y), + linear(Rest), + !, + Hom = [A,B|Rest], + % 'solve_='(Hom). + nf_length(Hom,0,Len), + log_deref(Len,Hom,[],HomD), + solve(HomD). +% case c3: A, B or Rest is non-linear => geler +submit_eq_c(A,B,Rest) :- + Norm = [A,B|Rest], + term_variables(Norm,Vs), + geler(Vs,nf_q:resubmit_eq(Norm)). + +% submit_eq_c1(Rest,B,K) +% +% Handles case c1 of submit_eq/1 + +% case c11: k+cX^1=0 or k+cX^-1=0 +submit_eq_c1([],v(K,[X^P]),I) :- + var(X), + ( P = 1, + !, + X is -I rdiv K + ; P = -1, + !, + X is -K rdiv I + ). +% case c12: non-linear, invertible: cNL(X)^1+k=0 => inv(NL)(-k/c) = 0 ; +% cNL(X)^-1+k=0 => inv(NL)(-c/k) = 0 +submit_eq_c1([],v(K,[NL^P]),I) :- + nonvar(NL), + ( P = 1, + Y is -I rdiv K + ; P = -1, + Y is -K rdiv I + ), + nl_invertible(NL,X,Y,Inv), + !, + nf(-Inv,S), + nf_add(X,S,New), + submit_eq(New). +% case c13: linear: X + Y + Z + c = 0 => +submit_eq_c1(Rest,B,I) :- + B = v(_,[Y^1]), + var(Y), + linear(Rest), + !, + % 'solve_='( [v(I,[]),B|Rest]). + Hom = [B|Rest], + nf_length(Hom,0,Len), + normalize_scalar(I,Nonvar), + log_deref(Len,Hom,[],HomD), + add_linear_11(Nonvar,HomD,LinD), + solve(LinD). +% case c14: other cases => geler +submit_eq_c1(Rest,B,I) :- + Norm = [v(I,[]),B|Rest], + term_variables(Norm,Vs), + geler(Vs,nf_q:resubmit_eq(Norm)). + +% ----------------------------------------------------------------------- + +% submit_lt(Nf) +% +% Submits the inequality Nf<0 to the constraint store, where Nf is in normal form. + +% 0 < 0 => fail +submit_lt([]) :- fail. +% A + B < 0 +submit_lt([A|As]) :- submit_lt(As,A). + +% submit_lt(As,A) +% +% Does what submit_lt/1 does where Nf = [A|As] + +% v(K,P) < 0 +submit_lt([],v(K,P)) :- submit_lt_b(P,K). +% A + B + Bs < 0 +submit_lt([B|Bs],A) :- submit_lt_c(Bs,A,B). + +% submit_lt_b(P,K) +% +% Does what submit_lt/2 does where A = [v(K,P)] and As = [] + +% c < 0 +submit_lt_b([],I) :- + !, + I < 0. +% cX^1 < 0 : if c < 0 then X > 0, else X < 0 +submit_lt_b([X^1],K) :- + var(X), + !, + ( K > 0 + -> ineq_one_s_p_0(X) % X is strictly negative + ; ineq_one_s_n_0(X) % X is strictly positive + ). +% non-linear => geler +submit_lt_b(P,K) :- + term_variables(P,Vs), + geler(Vs,nf_q:resubmit_lt([v(K,P)])). + +% submit_lt_c(Bs,A,B) +% +% Does what submit_lt/2 does where As = [B|Bs]. + +% c + kX < 0 => kX < c +submit_lt_c([],A,B) :- + A = v(I,[]), + B = v(K,[Y^1]), + var(Y), + !, + ineq_one(strict,Y,K,I). +% linear < 0 => solve, non-linear < 0 => geler +submit_lt_c(Rest,A,B) :- + Norm = [A,B|Rest], + ( linear(Norm) + -> 'solve_<'(Norm) + ; term_variables(Norm,Vs), + geler(Vs,nf_q:resubmit_lt(Norm)) + ). + +% submit_le(Nf) +% +% Submits the inequality Nf =< 0 to the constraint store, where Nf is in normal form. +% See also submit_lt/1 + +% 0 =< 0 => success +submit_le([]). +% A + B =< 0 +submit_le([A|As]) :- submit_le(As,A). + +% submit_le(As,A) +% +% See submit_lt/2. This handles less or equal. + +% v(K,P) =< 0 +submit_le([],v(K,P)) :- submit_le_b(P,K). +% A + B + Bs =< 0 +submit_le([B|Bs],A) :- submit_le_c(Bs,A,B). + +% submit_le_b(P,K) +% +% See submit_lt_b/2. This handles less or equal. + +% c =< 0 +submit_le_b([],I) :- + !, + I =< 0. +% cX^1 =< 0: if c < 0 then X >= 0, else X =< 0 +submit_le_b([X^1],K) :- + var(X), + !, + ( K > 0 + -> ineq_one_n_p_0(X) % X is non-strictly negative + ; ineq_one_n_n_0(X) % X is non-strictly positive + ). +% cX^P =< 0 => geler +submit_le_b(P,K) :- + term_variables(P,Vs), + geler(Vs,nf_q:resubmit_le([v(K,P)])). + +% submit_le_c(Bs,A,B) +% +% See submit_lt_c/3. This handles less or equal. + +% c + kX^1 =< 0 => kX =< 0 +submit_le_c([],A,B) :- + A = v(I,[]), + B = v(K,[Y^1]), + var(Y), + !, + ineq_one(nonstrict,Y,K,I). +% A, B & Rest are linear => solve, otherwise => geler +submit_le_c(Rest,A,B) :- + Norm = [A,B|Rest], + ( linear(Norm) + -> 'solve_=<'(Norm) + ; term_variables(Norm,Vs), + geler(Vs,nf_q:resubmit_le(Norm)) + ). + +% submit_ne(Nf) +% +% Submits the inequality Nf =\= 0 to the constraint store, where Nf is in normal form. +% if Nf is a constant => check constant = 0, else if Nf is linear => solve else => geler + +submit_ne(Norm1) :- + ( nf_constant(Norm1,K) + -> K =\= 0 + ; linear(Norm1) + -> 'solve_=\\='(Norm1) + ; term_variables(Norm1,Vs), + geler(Vs,nf_q:resubmit_ne(Norm1)) + ). + +% linear(A) +% +% succeeds when A is linear: all elements are of the form v(_,[]) or v(_,[X^1]) + +linear([]). +linear(v(_,Ps)) :- linear_ps(Ps). +linear([A|As]) :- + linear(A), + linear(As). + +% linear_ps(A) +% +% Succeeds when A = V^1 with V a variable. +% This reflects the linearity of v(_,A). + +linear_ps([]). +linear_ps([V^1]) :- var(V). % excludes sin(_), ... + +% +% Goal delays until Term gets linear. +% At this time, Var will be bound to the normalform of Term. +% +:- meta_predicate wait_linear( ?, ?, :). +% +wait_linear(Term,Var,Goal) :- + nf(Term,Nf), + ( linear(Nf) + -> Var = Nf, + call(Goal) + ; term_variables(Nf,Vars), + geler(Vars,nf_q:wait_linear_retry(Nf,Var,Goal)) + ). +% +% geler clients +% +resubmit_eq(N) :- + repair(N,Norm), + submit_eq(Norm). +resubmit_lt(N) :- + repair(N,Norm), + submit_lt(Norm). +resubmit_le(N) :- + repair(N,Norm), + submit_le(Norm). +resubmit_ne(N) :- + repair(N,Norm), + submit_ne(Norm). +wait_linear_retry(Nf0,Var,Goal) :- + repair(Nf0,Nf), + ( linear(Nf) + -> Var = Nf, + call(Goal) + ; term_variables(Nf,Vars), + geler(Vars,nf_q:wait_linear_retry(Nf,Var,Goal)) + ). +% ----------------------------------------------------------------------- + +% nl_invertible(F,X,Y,Res) +% +% Res is the evaluation of the inverse of nonlinear function F in variable X +% where X is Y + +nl_invertible(sin(X),X,Y,Res) :- Res is asin(Y). +nl_invertible(cos(X),X,Y,Res) :- Res is acos(Y). +nl_invertible(tan(X),X,Y,Res) :- Res is atan(Y). +nl_invertible(exp(B,C),X,A,Res) :- + ( nf_constant(B,Kb) + -> A > 0, + Kb > 0, + Kb =\= 1, + X = C, % note delayed unification + Res is rational(log(A)) rdiv rational(log(Kb)) + ; nf_constant(C,Kc), + A =\= 0, + Kc > 0, + X = B, % note delayed unification + Res is rational(A**(1 rdiv Kc)) + ). + +% ----------------------------------------------------------------------- + +% nf(Exp,Nf) +% +% Returns in Nf, the normal form of expression Exp +% +% v(A,[B^C,D^E|...]) means A*B^C*D^E*... where A is a scalar (number) +% v(A,[]) means scalar A + +% variable X => 1*X^1 +nf(X,Norm) :- + var(X), + !, + Norm = [v(1,[X^1])]. +nf(X,Norm) :- + number(X), + !, + nf_number(X,Norm). +nf(X,Norm) :- + rational(X), + !, + nf_number(X,Norm). +% +nf(-A,Norm) :- + !, + nf(A,An), + nf_mul_factor(v(-1,[]),An,Norm). +nf(+A,Norm) :- + !, + nf(A,Norm). +% +nf(A+B,Norm) :- + !, + nf(A,An), + nf(B,Bn), + nf_add(An,Bn,Norm). +nf(A-B,Norm) :- + !, + nf(A,An), + nf(-B,Bn), + nf_add(An,Bn,Norm). +% +nf(A*B,Norm) :- + !, + nf(A,An), + nf(B,Bn), + nf_mul(An,Bn,Norm). +nf(A/B,Norm) :- + !, + nf(A,An), + nf(B,Bn), + nf_div(Bn,An,Norm). +% non-linear function, one argument: Term = f(Arg) equals f'(Sa1) = Skel +nf(Term,Norm) :- + nonlin_1(Term,Arg,Skel,Sa1), + !, + nf(Arg,An), + nf_nonlin_1(Skel,An,Sa1,Norm). +% non-linear function, two arguments: Term = f(A1,A2) equals f'(Sa1,Sa2) = Skel +nf(Term,Norm) :- + nonlin_2(Term,A1,A2,Skel,Sa1,Sa2), + !, + nf(A1,A1n), + nf(A2,A2n), + nf_nonlin_2(Skel,A1n,A2n,Sa1,Sa2,Norm). +% +nf(Term,_) :- + throw(type_error(nf(Term,_),1,'a numeric expression',Term)). + +% nf_number(N,Res) +% +% If N is a number, N is normalized + +nf_number(N,Res) :- + rational(N), + Rat is rationalize(N), + ( Rat =:= 0 + -> Res = [] + ; Res = [v(Rat,[])] + ). + +nonlin_1(abs(X),X,abs(Y),Y). +nonlin_1(sin(X),X,sin(Y),Y). +nonlin_1(cos(X),X,cos(Y),Y). +nonlin_1(tan(X),X,tan(Y),Y). +nonlin_2(min(A,B),A,B,min(X,Y),X,Y). +nonlin_2(max(A,B),A,B,max(X,Y),X,Y). +nonlin_2(exp(A,B),A,B,exp(X,Y),X,Y). +nonlin_2(pow(A,B),A,B,exp(X,Y),X,Y). % pow->exp +nonlin_2(A^B,A,B,exp(X,Y),X,Y). + +nf_nonlin_1(Skel,An,S1,Norm) :- + ( nf_constant(An,S1) + -> nl_eval(Skel,Res), + nf_number(Res,Norm) + ; S1 = An, + Norm = [v(1,[Skel^1])]). +nf_nonlin_2(Skel,A1n,A2n,S1,S2,Norm) :- + ( nf_constant(A1n,S1), + nf_constant(A2n,S2) + -> nl_eval(Skel,Res), + nf_number(Res,Norm) + ; Skel=exp(_,_), + nf_constant(A2n,Exp), + integer(Exp) + -> nf_power(Exp,A1n,Norm) + ; S1 = A1n, + S2 = A2n, + Norm = [v(1,[Skel^1])] + ). + +% evaluates non-linear functions in one variable where the variable is bound +nl_eval(abs(X),R) :- R is abs(X). +nl_eval(sin(X),R) :- R is sin(X). +nl_eval(cos(X),R) :- R is cos(X). +nl_eval(tan(X),R) :- R is tan(X). +% evaluates non-linear functions in two variables where both variables are +% bound +nl_eval(min(X,Y),R) :- R is min(X,Y). +nl_eval(max(X,Y),R) :- R is max(X,Y). +nl_eval(exp(X,Y),R) :- R is X**Y. + +% +% check if a Nf consists of just a constant +% + +nf_constant([],Z) :- Z = 0. +nf_constant([v(K,[])],K). + +% split(NF,SNF,C) +% +% splits a normalform expression NF into two parts: +% - a constant term C (which might be 0) +% - the homogene part of the expression +% +% this method depends on the polynf ordering, i.e. [] < [X^1] ... + +split([],[],0). +split([First|T],H,I) :- + ( First = v(I,[]) + -> H = T + ; I = 0, + H = [First|T] + ). + +% nf_add(A,B,C): merges two normalized additions into a new normalized addition +% +% a normalized addition is one where the terms are ordered, e.g. X^1 < Y^1, X^1 < X^2 etc. +% terms in the same variable with the same exponent are added, +% e.g. when A contains v(5,[X^1]) and B contains v(4,[X^1]) then C contains v(9,[X^1]). + +nf_add([],Bs,Bs). +nf_add([A|As],Bs,Cs) :- nf_add(Bs,A,As,Cs). + +nf_add([],A,As,Cs) :- Cs = [A|As]. +nf_add([B|Bs],A,As,Cs) :- + A = v(Ka,Pa), + B = v(Kb,Pb), + compare(Rel,Pa,Pb), + nf_add_case(Rel,A,As,Cs,B,Bs,Ka,Kb,Pa). + +% nf_add_case(Rel,A,As,Cs,B,Bs,Ka,Kb,Pa) +% +% merges sorted lists [A|As] and [B|Bs] into new sorted list Cs +% A = v(Ka,Pa) and B = v(Kb,_) +% Rel is the ordering relation (<, > or =) between A and B. +% when Rel is =, Ka and Kb are added to form a new scalar for Pa +nf_add_case(<,A,As,Cs,B,Bs,_,_,_) :- + Cs = [A|Rest], + nf_add(As,B,Bs,Rest). +nf_add_case(>,A,As,Cs,B,Bs,_,_,_) :- + Cs = [B|Rest], + nf_add(Bs,A,As,Rest). +nf_add_case(=,_,As,Cs,_,Bs,Ka,Kb,Pa) :- + Kc is Ka + Kb, + ( Kc =:= 0.0 + -> nf_add(As,Bs,Cs) + ; Cs = [v(Kc,Pa)|Rest], + nf_add(As,Bs,Rest) + ). + +nf_mul(A,B,Res) :- + nf_length(A,0,LenA), + nf_length(B,0,LenB), + nf_mul_log(LenA,A,[],LenB,B,Res). + +nf_mul_log(0,As,As,_,_,[]) :- !. +nf_mul_log(1,[A|As],As,Lb,B,R) :- + !, + nf_mul_factor_log(Lb,B,[],A,R). +nf_mul_log(2,[A1,A2|As],As,Lb,B,R) :- + !, + nf_mul_factor_log(Lb,B,[],A1,A1b), + nf_mul_factor_log(Lb,B,[],A2,A2b), + nf_add(A1b,A2b,R). +nf_mul_log(N,A0,A2,Lb,B,R) :- + P is N>>1, + Q is N-P, + nf_mul_log(P,A0,A1,Lb,B,Rp), + nf_mul_log(Q,A1,A2,Lb,B,Rq), + nf_add(Rp,Rq,R). + + +% nf_add_2: does the same thing as nf_add, but only has 2 elements to combine. +nf_add_2(Af,Bf,Res) :- % unfold: nf_add([Af],[Bf],Res). + Af = v(Ka,Pa), + Bf = v(Kb,Pb), + compare(Rel,Pa,Pb), + nf_add_2_case(Rel,Af,Bf,Res,Ka,Kb,Pa). + +nf_add_2_case(<,Af,Bf,[Af,Bf],_,_,_). +nf_add_2_case(>,Af,Bf,[Bf,Af],_,_,_). +nf_add_2_case(=,_, _,Res,Ka,Kb,Pa) :- + Kc is Ka + Kb, + ( Kc =:= 0 + -> Res = [] + ; Res = [v(Kc,Pa)] + ). + +% nf_mul_k(A,B,C) +% +% C is the result of the multiplication of each element of A (of the form v(_,_)) with scalar B (which shouldn't be 0) +nf_mul_k([],_,[]). +nf_mul_k([v(I,P)|Vs],K,[v(Ki,P)|Vks]) :- + Ki is K*I, + nf_mul_k(Vs,K,Vks). + +% nf_mul_factor(A,Sum,Res) +% +% multiplies each element of the list Sum with factor A which is of the form v(_,_) +% and puts the result in the sorted list Res. +nf_mul_factor(v(K,[]),Sum,Res) :- + !, + nf_mul_k(Sum,K,Res). +nf_mul_factor(F,Sum,Res) :- + nf_length(Sum,0,Len), + nf_mul_factor_log(Len,Sum,[],F,Res). + +% nf_mul_factor_log(Len,[Sum|SumTail],SumTail,F,Res) +% +% multiplies each element of Sum with F and puts the result in the sorted list Res +% Len is the length of Sum +% Sum is split logarithmically each step + +nf_mul_factor_log(0,As,As,_,[]) :- !. +nf_mul_factor_log(1,[A|As],As,F,[R]) :- + !, + mult(A,F,R). +nf_mul_factor_log(2,[A,B|As],As,F,Res) :- + !, + mult(A,F,Af), + mult(B,F,Bf), + nf_add_2(Af,Bf,Res). +nf_mul_factor_log(N,A0,A2,F,R) :- + P is N>>1, % P is rounded(N/2) + Q is N-P, + nf_mul_factor_log(P,A0,A1,F,Rp), + nf_mul_factor_log(Q,A1,A2,F,Rq), + nf_add(Rp,Rq,R). + +% mult(A,B,C) +% +% multiplies A and B into C each of the form v(_,_) + +mult(v(Ka,La),v(Kb,Lb),v(Kc,Lc)) :- + Kc is Ka*Kb, + pmerge(La,Lb,Lc). + +% pmerge(A,B,C) +% +% multiplies A and B into sorted C, where each is of the form of the second argument of v(_,_) + +pmerge([],Bs,Bs). +pmerge([A|As],Bs,Cs) :- pmerge(Bs,A,As,Cs). + +pmerge([],A,As,Res) :- Res = [A|As]. +pmerge([B|Bs],A,As,Res) :- + A = Xa^Ka, + B = Xb^Kb, + compare(R,Xa,Xb), + pmerge_case(R,A,As,Res,B,Bs,Ka,Kb,Xa). + +% pmerge_case(Rel,A,As,Res,B,Bs,Ka,Kb,Xa) +% +% multiplies and sorts [A|As] with [B|Bs] into Res where each is of the form of +% the second argument of v(_,_) +% +% A is Xa^Ka and B is Xb^Kb, Rel is ordening relation between Xa and Xb + +pmerge_case(<,A,As,Res,B,Bs,_,_,_) :- + Res = [A|Tail], + pmerge(As,B,Bs,Tail). +pmerge_case(>,A,As,Res,B,Bs,_,_,_) :- + Res = [B|Tail], + pmerge(Bs,A,As,Tail). +pmerge_case(=,_,As,Res,_,Bs,Ka,Kb,Xa) :- + Kc is Ka + Kb, + ( Kc =:= 0 + -> pmerge(As,Bs,Res) + ; Res = [Xa^Kc|Tail], + pmerge(As,Bs,Tail) + ). + +% nf_div(Factor,In,Out) +% +% Out is the result of the division of each element in In (which is of the form v(_,_)) by Factor. + +% division by zero +nf_div([],_,_) :- + !, + zero_division. +% division by v(K,P) => multiplication by v(1/K,P^-1) +nf_div([v(K,P)],Sum,Res) :- + !, + Ki is 1 rdiv K, + mult_exp(P,-1,Pi), + nf_mul_factor(v(Ki,Pi),Sum,Res). +nf_div(D,A,[v(1,[(A/D)^1])]). + +% zero_division +% +% called when a division by zero is performed +zero_division :- fail. % raise_exception(_) ? + +% mult_exp(In,Factor,Out) +% +% Out is the result of the multiplication of the exponents of the elements in In +% (which are of the form X^Exp by Factor. +mult_exp([],_,[]). +mult_exp([X^P|Xs],K,[X^I|Tail]) :- + I is K*P, + mult_exp(Xs,K,Tail). +% +% raise to integer powers +% +% | ?- time({(1+X+Y+Z)^15=0}). (sicstus, try with SWI) +% Timing 00:00:02.610 2.610 iterative +% Timing 00:00:00.660 0.660 binomial +nf_power(N,Sum,Norm) :- + integer(N), + compare(Rel,N,0), + ( Rel = (<) + -> Pn is -N, + % nf_power_pos(Pn,Sum,Inorm), + binom(Sum,Pn,Inorm), + nf_div(Inorm,[v(1,[])],Norm) + ; Rel = (>) + -> % nf_power_pos(N,Sum,Norm) + binom(Sum,N,Norm) + ; Rel = (=) + -> % 0^0 is indeterminate but we say 1 + Norm = [v(1,[])] + ). +% +% N>0 +% +% iterative method: X^N = X*(X^N-1) +nf_power_pos(1,Sum,Norm) :- + !, + Sum = Norm. +nf_power_pos(N,Sum,Norm) :- + N1 is N-1, + nf_power_pos(N1,Sum,Pn1), + nf_mul(Sum,Pn1,Norm). +% +% N>0 +% +% binomial method +binom(Sum,1,Power) :- + !, + Power = Sum. +binom([],_,[]). +binom([A|Bs],N,Power) :- + ( Bs = [] + -> nf_power_factor(A,N,Ap), + Power = [Ap] + ; Bs = [_|_] + -> factor_powers(N,A,v(1,[]),Pas), + sum_powers(N,Bs,[v(1,[])],Pbs,[]), + combine_powers(Pas,Pbs,0,N,1,[],Power) + ). + +combine_powers([],[],_,_,_,Pi,Pi). +combine_powers([A|As],[B|Bs],L,R,C,Pi,Po) :- + nf_mul(A,B,Ab), + nf_mul_k(Ab,C,Abc), + nf_add(Abc,Pi,Pii), + L1 is L+1, + R1 is R-1, + C1 is C*R//L1, + combine_powers(As,Bs,L1,R1,C1,Pii,Po). + +nf_power_factor(v(K,P),N,v(Kn,Pn)) :- + Kn is K**N, + mult_exp(P,N,Pn). + +factor_powers(0,_,Prev,[[Prev]]) :- !. +factor_powers(N,F,Prev,[[Prev]|Ps]) :- + N1 is N-1, + mult(Prev,F,Next), + factor_powers(N1,F,Next,Ps). +sum_powers(0,_,Prev,[Prev|Lt],Lt) :- !. +sum_powers(N,S,Prev,L0,Lt) :- + N1 is N-1, + nf_mul(S,Prev,Next), + sum_powers(N1,S,Next,L0,[Prev|Lt]). + +% ------------------------------------------------------------------------------ +repair(Sum,Norm) :- + nf_length(Sum,0,Len), + repair_log(Len,Sum,[],Norm). +repair_log(0,As,As,[]) :- !. +repair_log(1,[v(Ka,Pa)|As],As,R) :- + !, + repair_term(Ka,Pa,R). +repair_log(2,[v(Ka,Pa),v(Kb,Pb)|As],As,R) :- + !, + repair_term(Ka,Pa,Ar), + repair_term(Kb,Pb,Br), + nf_add(Ar,Br,R). +repair_log(N,A0,A2,R) :- + P is N>>1, + Q is N-P, + repair_log(P,A0,A1,Rp), + repair_log(Q,A1,A2,Rq), + nf_add(Rp,Rq,R). + +repair_term(K,P,Norm) :- + length(P,Len), + repair_p_log(Len,P,[],Pr,[v(1,[])],Sum), + nf_mul_factor(v(K,Pr),Sum,Norm). + +repair_p_log(0,Ps,Ps,[],L0,L0) :- !. +repair_p_log(1,[X^P|Ps],Ps,R,L0,L1) :- + !, + repair_p(X,P,R,L0,L1). +repair_p_log(2,[X^Px,Y^Py|Ps],Ps,R,L0,L2) :- + !, + repair_p(X,Px,Rx,L0,L1), + repair_p(Y,Py,Ry,L1,L2), + pmerge(Rx,Ry,R). +repair_p_log(N,P0,P2,R,L0,L2) :- + P is N>>1, + Q is N-P, + repair_p_log(P,P0,P1,Rp,L0,L1), + repair_p_log(Q,P1,P2,Rq,L1,L2), + pmerge(Rp,Rq,R). + +repair_p(Term,P,[Term^P],L0,L0) :- var(Term). +repair_p(Term,P,[],L0,L1) :- + nonvar(Term), + repair_p_one(Term,TermN), + nf_power(P,TermN,TermNP), + nf_mul(TermNP,L0,L1). +% +% An undigested term a/b is distinguished from an +% digested one by the fact that its arguments are +% digested -> cuts after repair of args! +% +repair_p_one(Term,TermN) :- + nf_number(Term,TermN), % freq. shortcut for nf/2 case below + !. +repair_p_one(A1/A2,TermN) :- + repair(A1,A1n), + repair(A2,A2n), + !, + nf_div(A2n,A1n,TermN). +repair_p_one(Term,TermN) :- + nonlin_1(Term,Arg,Skel,Sa), + repair(Arg,An), + !, + nf_nonlin_1(Skel,An,Sa,TermN). +repair_p_one(Term,TermN) :- + nonlin_2(Term,A1,A2,Skel,Sa1,Sa2), + repair(A1,A1n), + repair(A2,A2n), + !, + nf_nonlin_2(Skel,A1n,A2n,Sa1,Sa2,TermN). +repair_p_one(Term,TermN) :- + nf(Term,TermN). + +nf_length([],Li,Li). +nf_length([_|R],Li,Lo) :- + Lii is Li+1, + nf_length(R,Lii,Lo). +% ------------------------------------------------------------------------------ +% nf2term(NF,Term) +% +% transforms a normal form into a readable term + +% empty normal form = 0 +nf2term([],0). +% term is first element (+ next elements) +nf2term([F|Fs],T) :- + f02t(F,T0), % first element + yfx(Fs,T0,T). % next elements + +yfx([],T0,T0). +yfx([F|Fs],T0,TN) :- + fn2t(F,Ft,Op), + T1 =.. [Op,T0,Ft], + yfx(Fs,T1,TN). + +% f02t(v(K,P),T) +% +% transforms the first element of the normal form (something of the form v(K,P)) +% into a readable term +f02t(v(K,P),T) :- + ( % just a constant + P = [] + -> T = K + ; K =:= 1 + -> p2term(P,T) + ; K =:= -1 + -> T = -Pt, + p2term(P,Pt) + ; T = K*Pt, + p2term(P,Pt) + ). + +% f02t(v(K,P),T,Op) +% +% transforms a next element of the normal form (something of the form v(K,P)) +% into a readable term +fn2t(v(K,P),Term,Op) :- + ( K =:= 1 + -> Term = Pt, + Op = + + ; K =:= -1 + -> Term = Pt, + Op = - + ; K < 0 + -> Kf is -K, + Term = Kf*Pt, + Op = - + ; Term = K*Pt, + Op = + + ), + p2term(P,Pt). + +% transforms the P part in v(_,P) into a readable term +p2term([X^P|Xs],Term) :- + ( Xs = [] + -> pe2term(X,Xt), + exp2term(P,Xt,Term) + ; Xs = [_|_] + -> Term = Xst*Xtp, + pe2term(X,Xt), + exp2term(P,Xt,Xtp), + p2term(Xs,Xst) + ). + +% +exp2term(1,X,X) :- !. +exp2term(-1,X,1/X) :- !. +exp2term(P,X,Term) :- + % Term = exp(X,Pn) + Term = X^P. + +pe2term(X,Term) :- + var(X), + Term = X. +pe2term(X,Term) :- + nonvar(X), + X =.. [F|Args], + pe2term_args(Args,Argst), + Term =.. [F|Argst]. + +pe2term_args([],[]). +pe2term_args([A|As],[T|Ts]) :- + nf2term(A,T), + pe2term_args(As,Ts). + +% transg(Goal,[OutList|OutListTail],OutListTail) +% +% puts the equalities and inequalities that are implied by the elements in Goal +% in the difference list OutList +% +% called by geler.pl for project.pl + +transg(resubmit_eq(Nf)) --> + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpq:{Term=Z}]. +transg(resubmit_lt(Nf)) --> + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpq:{Term + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpq:{Term= + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpq:{Term=\=Z}]. +transg(wait_linear_retry(Nf,Res,Goal)) --> + { + nf2term(Nf,Term) + }, + [clpq:{Term=Res},Goal]. \ No newline at end of file diff --git a/packages/clpqr/clpq/store_q.pl b/packages/clpqr/clpq/store_q.pl new file mode 100644 index 000000000..85518a73a --- /dev/null +++ b/packages/clpqr/clpq/store_q.pl @@ -0,0 +1,398 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(store_q, + [ + add_linear_11/3, + add_linear_f1/4, + add_linear_ff/5, + normalize_scalar/2, + delete_factor/4, + mult_linear_factor/3, + nf_rhs_x/4, + indep/2, + isolate/3, + nf_substitute/4, + mult_hom/3, + nf2sum/3, + nf_coeff_of/3, + renormalize/2 + ]). + +% normalize_scalar(S,[N,Z]) +% +% Transforms a scalar S into a linear expression [S,0] + +normalize_scalar(S,[S,0]). + +% renormalize(List,Lin) +% +% Renormalizes the not normalized linear expression in List into +% a normalized one. It does so to take care of unifications. +% (e.g. when a variable X is bound to a constant, the constant is added to +% the constant part of the linear expression; when a variable X is bound to +% another variable Y, the scalars of both are added) + +renormalize([I,R|Hom],Lin) :- + length(Hom,Len), + renormalize_log(Len,Hom,[],Lin0), + add_linear_11([I,R],Lin0,Lin). + +% renormalize_log(Len,Hom,HomTail,Lin) +% +% Logarithmically renormalizes the homogene part of a not normalized +% linear expression. See also renormalize/2. + +renormalize_log(1,[Term|Xs],Xs,Lin) :- + !, + Term = l(X*_,_), + renormalize_log_one(X,Term,Lin). +renormalize_log(2,[A,B|Xs],Xs,Lin) :- + !, + A = l(X*_,_), + B = l(Y*_,_), + renormalize_log_one(X,A,LinA), + renormalize_log_one(Y,B,LinB), + add_linear_11(LinA,LinB,Lin). +renormalize_log(N,L0,L2,Lin) :- + P is N>>1, + Q is N-P, + renormalize_log(P,L0,L1,Lp), + renormalize_log(Q,L1,L2,Lq), + add_linear_11(Lp,Lq,Lin). + +% renormalize_log_one(X,Term,Res) +% +% Renormalizes a term in X: if X is a nonvar, the term becomes a scalar. + +renormalize_log_one(X,Term,Res) :- + var(X), + Term = l(X*K,_), + get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), % Order might have changed + Res = [0,0,l(X*K,OrdX)]. +renormalize_log_one(X,Term,Res) :- + nonvar(X), + Term = l(X*K,_), + Xk is X*K, + normalize_scalar(Xk,Res). + +% ----------------------------- sparse vector stuff ---------------------------- % + +% add_linear_ff(LinA,Ka,LinB,Kb,LinC) +% +% Linear expression LinC is the result of the addition of the 2 linear expressions +% LinA and LinB, each one multiplied by a scalar (Ka for LinA and Kb for LinB). + +add_linear_ff(LinA,Ka,LinB,Kb,LinC) :- + LinA = [Ia,Ra|Ha], + LinB = [Ib,Rb|Hb], + LinC = [Ic,Rc|Hc], + Ic is Ia*Ka+Ib*Kb, + Rc is Ra*Ka+Rb*Kb, + add_linear_ffh(Ha,Ka,Hb,Kb,Hc). + +% add_linear_ffh(Ha,Ka,Hb,Kb,Hc) +% +% Homogene part Hc is the result of the addition of the 2 homogene parts Ha and Hb, +% each one multiplied by a scalar (Ka for Ha and Kb for Hb) + +add_linear_ffh([],_,Ys,Kb,Zs) :- mult_hom(Ys,Kb,Zs). +add_linear_ffh([l(X*Kx,OrdX)|Xs],Ka,Ys,Kb,Zs) :- + add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb). + +% add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb) +% +% Homogene part Zs is the result of the addition of the 2 homogene parts Ys and +% [l(X*Kx,OrdX)|Xs], each one multiplied by a scalar (Ka for [l(X*Kx,OrdX)|Xs] and Kb for Ys) + +add_linear_ffh([],X,Kx,OrdX,Xs,Zs,Ka,_) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs). +add_linear_ffh([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka,Kb) :- + compare(Rel,OrdX,OrdY), + ( Rel = (=) + -> Kz is Kx*Ka+Ky*Kb, + ( Kz =:= 0 + -> add_linear_ffh(Xs,Ka,Ys,Kb,Zs) + ; Zs = [l(X*Kz,OrdX)|Ztail], + add_linear_ffh(Xs,Ka,Ys,Kb,Ztail) + ) + ; Rel = (<) + -> Zs = [l(X*Kz,OrdX)|Ztail], + Kz is Kx*Ka, + add_linear_ffh(Xs,Y,Ky,OrdY,Ys,Ztail,Kb,Ka) + ; Rel = (>) + -> Zs = [l(Y*Kz,OrdY)|Ztail], + Kz is Ky*Kb, + add_linear_ffh(Ys,X,Kx,OrdX,Xs,Ztail,Ka,Kb) + ). + +% add_linear_f1(LinA,Ka,LinB,LinC) +% +% special case of add_linear_ff with Kb = 1 + +add_linear_f1(LinA,Ka,LinB,LinC) :- + LinA = [Ia,Ra|Ha], + LinB = [Ib,Rb|Hb], + LinC = [Ic,Rc|Hc], + Ic is Ia*Ka+Ib, + Rc is Ra*Ka+Rb, + add_linear_f1h(Ha,Ka,Hb,Hc). + +% add_linear_f1h(Ha,Ka,Hb,Hc) +% +% special case of add_linear_ffh/5 with Kb = 1 + +add_linear_f1h([],_,Ys,Ys). +add_linear_f1h([l(X*Kx,OrdX)|Xs],Ka,Ys,Zs) :- + add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka). + +% add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka) +% +% special case of add_linear_ffh/8 with Kb = 1 + +add_linear_f1h([],X,Kx,OrdX,Xs,Zs,Ka) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs). +add_linear_f1h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka) :- + compare(Rel,OrdX,OrdY), + ( Rel = (=) + -> Kz is Kx*Ka+Ky, + ( Kz =:= 0 + -> add_linear_f1h(Xs,Ka,Ys,Zs) + ; Zs = [l(X*Kz,OrdX)|Ztail], + add_linear_f1h(Xs,Ka,Ys,Ztail) + ) + ; Rel = (<) + -> Zs = [l(X*Kz,OrdX)|Ztail], + Kz is Kx*Ka, + add_linear_f1h(Xs,Ka,[l(Y*Ky,OrdY)|Ys],Ztail) + ; Rel = (>) + -> Zs = [l(Y*Ky,OrdY)|Ztail], + add_linear_f1h(Ys,X,Kx,OrdX,Xs,Ztail,Ka) + ). + +% add_linear_11(LinA,LinB,LinC) +% +% special case of add_linear_ff with Ka = 1 and Kb = 1 + +add_linear_11(LinA,LinB,LinC) :- + LinA = [Ia,Ra|Ha], + LinB = [Ib,Rb|Hb], + LinC = [Ic,Rc|Hc], + Ic is Ia+Ib, + Rc is Ra+Rb, + add_linear_11h(Ha,Hb,Hc). + +% add_linear_11h(Ha,Hb,Hc) +% +% special case of add_linear_ffh/5 with Ka = 1 and Kb = 1 + +add_linear_11h([],Ys,Ys). +add_linear_11h([l(X*Kx,OrdX)|Xs],Ys,Zs) :- + add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs). + +% add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs) +% +% special case of add_linear_ffh/8 with Ka = 1 and Kb = 1 + +add_linear_11h([],X,Kx,OrdX,Xs,[l(X*Kx,OrdX)|Xs]). +add_linear_11h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs) :- + compare(Rel,OrdX,OrdY), + ( Rel = (=) + -> Kz is Kx+Ky, + ( Kz =:= 0 + -> add_linear_11h(Xs,Ys,Zs) + ; Zs = [l(X*Kz,OrdX)|Ztail], + add_linear_11h(Xs,Ys,Ztail) + ) + ; Rel = (<) + -> Zs = [l(X*Kx,OrdX)|Ztail], + add_linear_11h(Xs,Y,Ky,OrdY,Ys,Ztail) + ; Rel = (>) + -> Zs = [l(Y*Ky,OrdY)|Ztail], + add_linear_11h(Ys,X,Kx,OrdX,Xs,Ztail) + ). + +% mult_linear_factor(Lin,K,Res) +% +% Linear expression Res is the result of multiplication of linear +% expression Lin by scalar K + +mult_linear_factor(Lin,K,Mult) :- + K =:= 1, + !, + Mult = Lin. +mult_linear_factor(Lin,K,Res) :- + Lin = [I,R|Hom], + Res = [Ik,Rk|Mult], + Ik is I*K, + Rk is R*K, + mult_hom(Hom,K,Mult). + +% mult_hom(Hom,K,Res) +% +% Homogene part Res is the result of multiplication of homogene part +% Hom by scalar K + +mult_hom([],_,[]). +mult_hom([l(A*Fa,OrdA)|As],F,[l(A*Fan,OrdA)|Afs]) :- + Fan is F*Fa, + mult_hom(As,F,Afs). + +% nf_substitute(Ord,Def,Lin,Res) +% +% Linear expression Res is the result of substitution of Var in +% linear expression Lin, by its definition in the form of linear +% expression Def + +nf_substitute(OrdV,LinV,LinX,LinX1) :- + delete_factor(OrdV,LinX,LinW,K), + add_linear_f1(LinV,K,LinW,LinX1). + +% delete_factor(Ord,Lin,Res,Coeff) +% +% Linear expression Res is the result of the deletion of the term +% Var*Coeff where Var has ordering Ord from linear expression Lin + +delete_factor(OrdV,Lin,Res,Coeff) :- + Lin = [I,R|Hom], + Res = [I,R|Hdel], + delete_factor_hom(OrdV,Hom,Hdel,Coeff). + +% delete_factor_hom(Ord,Hom,Res,Coeff) +% +% Homogene part Res is the result of the deletion of the term +% Var*Coeff from homogene part Hom + +delete_factor_hom(VOrd,[Car|Cdr],RCdr,RKoeff) :- + Car = l(_*Koeff,Ord), + compare(Rel,VOrd,Ord), + ( Rel= (=) + -> RCdr = Cdr, + RKoeff=Koeff + ; Rel= (>) + -> RCdr = [Car|RCdr1], + delete_factor_hom(VOrd,Cdr,RCdr1,RKoeff) + ). + + +% nf_coeff_of(Lin,OrdX,Coeff) +% +% Linear expression Lin contains the term l(X*Coeff,OrdX) + +nf_coeff_of([_,_|Hom],VOrd,Coeff) :- + nf_coeff_hom(Hom,VOrd,Coeff). + +% nf_coeff_hom(Lin,OrdX,Coeff) +% +% Linear expression Lin contains the term l(X*Coeff,OrdX) where the +% order attribute of X = OrdX + +nf_coeff_hom([l(_*K,OVar)|Vs],OVid,Coeff) :- + compare(Rel,OVid,OVar), + ( Rel = (=) + -> Coeff = K + ; Rel = (>) + -> nf_coeff_hom(Vs,OVid,Coeff) + ). + +% nf_rhs_x(Lin,OrdX,Rhs,K) +% +% Rhs = R + I where Lin = [I,R|Hom] and l(X*K,OrdX) is a term of Hom + +nf_rhs_x(Lin,OrdX,Rhs,K) :- + Lin = [I,R|Tail], + nf_coeff_hom(Tail,OrdX,K), + Rhs is R+I. % late because X may not occur in H + +% isolate(OrdN,Lin,Lin1) +% +% Linear expression Lin1 is the result of the transformation of linear expression +% Lin = 0 which contains the term l(New*K,OrdN) into an equivalent expression Lin1 = New. + +isolate(OrdN,Lin,Lin1) :- + delete_factor(OrdN,Lin,Lin0,Coeff), + K is -1 rdiv Coeff, + mult_linear_factor(Lin0,K,Lin1). + +% indep(Lin,OrdX) +% +% succeeds if Lin = [0,_|[l(X*1,OrdX)]] + +indep(Lin,OrdX) :- + Lin = [I,_|[l(_*K,OrdY)]], + OrdX == OrdY, + K =:= 1, + I =:= 0. + +% nf2sum(Lin,Sofar,Term) +% +% Transforms a linear expression into a sum +% (e.g. the expression [5,_,[l(X*2,OrdX),l(Y*-1,OrdY)]] gets transformed into 5 + 2*X - Y) + +nf2sum([],I,I). +nf2sum([X|Xs],I,Sum) :- + ( I =:= 0 + -> X = l(Var*K,_), + ( K =:= 1 + -> hom2sum(Xs,Var,Sum) + ; K =:= -1 + -> hom2sum(Xs,-Var,Sum) + ; hom2sum(Xs,K*Var,Sum) + ) + ; hom2sum([X|Xs],I,Sum) + ). + +% hom2sum(Hom,Sofar,Term) +% +% Transforms a linear expression into a sum +% this predicate handles all but the first term +% (the first term does not need a concatenation symbol + or -) +% see also nf2sum/3 + +hom2sum([],Term,Term). +hom2sum([l(Var*K,_)|Cs],Sofar,Term) :- + ( K =:= 1 + -> Next = Sofar + Var + ; K =:= -1 + -> Next = Sofar - Var + ; K < 0 + -> Ka is -K, + Next = Sofar - Ka*Var + ; Next = Sofar + K*Var + ), + hom2sum(Cs,Next,Term). \ No newline at end of file diff --git a/packages/clpqr/clpqr/class.pl b/packages/clpqr/clpqr/class.pl new file mode 100644 index 000000000..ab03ce026 --- /dev/null +++ b/packages/clpqr/clpqr/class.pl @@ -0,0 +1,155 @@ +/* $Id$ + + Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(class, + [ + class_allvars/2, + class_new/5, + class_drop/2, + class_basis/2, + class_basis_add/3, + class_basis_drop/2, + class_basis_pivot/3, + class_get_clp/2, + class_get_prio/2, + class_put_prio/2, + ordering/1, + arrangement/2 + ]). + +:- use_module(ordering, + [ + combine/3, + ordering/1, + arrangement/2 + ]). +:- use_module(library(lists), + [ append/3 + ]). + +% called when two classes are unified: the allvars lists are appended to eachother, as well as the basis +% lists. +% +% note: La=[A,B,...,C|Lat], Lb=[D,E,...,F|Lbt], so new La = [A,B,...,C,D,E,...,F|Lbt] + +attr_unify_hook(class(CLP,La,Lat,ABasis,PrioA),Y) :- + !, + var(Y), + get_attr(Y,class,class(CLP,Lb,Lbt,BBasis,PrioB)), + Lat = Lb, + append(ABasis,BBasis,CBasis), + combine(PrioA,PrioB,PrioC), + put_attr(Y,class,class(CLP,La,Lbt,CBasis,PrioC)). +attr_unify_hook(_,_). + +class_new(Class,CLP,All,AllT,Basis) :- + put_attr(Su,class,class(CLP,All,AllT,Basis,[])), + Su = Class. + +class_get_prio(Class,Priority) :- + get_attr(Class,class,class(_,_,_,_,Priority)). + +class_get_clp(Class,CLP) :- + get_attr(Class,class,class(CLP,_,_,_,_)). + +class_put_prio(Class,Priority) :- + get_attr(Class,class,class(CLP,All,AllT,Basis,_)), + put_attr(Class,class,class(CLP,All,AllT,Basis,Priority)). + +class_drop(Class,X) :- + get_attr(Class,class,class(CLP,Allvars,Tail,Basis,Priority)), + delete_first(Allvars,X,NewAllvars), + delete_first(Basis,X,NewBasis), + put_attr(Class,class,class(CLP,NewAllvars,Tail,NewBasis,Priority)). + +class_allvars(Class,All) :- get_attr(Class,class,class(_,All,_,_,_)). + +% class_basis(Class,Basis) +% +% Returns the basis of class Class. + +class_basis(Class,Basis) :- get_attr(Class,class,class(_,_,_,Basis,_)). + +% class_basis_add(Class,X,NewBasis) +% +% adds X in front of the basis and returns the new basis + +class_basis_add(Class,X,NewBasis) :- + NewBasis = [X|Basis], + get_attr(Class,class,class(CLP,All,AllT,Basis,Priority)), + put_attr(Class,class,class(CLP,All,AllT,NewBasis,Priority)). + +% class_basis_drop(Class,X) +% +% removes the first occurence of X from the basis (if exists) + +class_basis_drop(Class,X) :- + get_attr(Class,class,class(CLP,All,AllT,Basis0,Priority)), + delete_first(Basis0,X,Basis), + Basis0 \== Basis, % anything deleted ? + !, + put_attr(Class,class,class(CLP,All,AllT,Basis,Priority)). +class_basis_drop(_,_). + +% class_basis_pivot(Class,Enter,Leave) +% +% removes first occurence of Leave from the basis and adds Enter in front of the basis + +class_basis_pivot(Class,Enter,Leave) :- + get_attr(Class,class,class(CLP,All,AllT,Basis0,Priority)), + delete_first(Basis0,Leave,Basis1), + put_attr(Class,class,class(CLP,All,AllT,[Enter|Basis1],Priority)). + +% delete_first(Old,Element,New) +% +% removes the first occurence of Element from Old and returns the result in New +% +% note: test via syntactic equality, not unifiability + +delete_first(L,_,Res) :- + var(L), + !, + Res = L. +delete_first([],_,[]). +delete_first([Y|Ys],X,Res) :- + ( X==Y + -> Res = Ys + ; Res = [Y|Tail], + delete_first(Ys,X,Tail) + ). diff --git a/packages/clpqr/clpqr/dump.pl b/packages/clpqr/clpqr/dump.pl new file mode 100644 index 000000000..99078b1b9 --- /dev/null +++ b/packages/clpqr/clpqr/dump.pl @@ -0,0 +1,334 @@ +/* $Id$ + + Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(dump, + [ + dump/3, + projecting_assert/1 + ]). +:- use_module(class, + [ + class_allvars/2 + ]). +:- use_module(geler, + [ + collect_nonlin/3 + ]). +:- use_module(library(assoc), + [ + empty_assoc/1, + get_assoc/3, + put_assoc/4, + assoc_to_list/2 + ]). +:- use_module(itf, + [ + dump_linear/3, + dump_nonzero/3 + ]). +:- use_module(project, + [ + project_attributes/2 + ]). +:- use_module(ordering, + [ + ordering/1 + ]). + +%% dump(+Target,-NewVars,-Constraints) is det. +% +% Returns in , the constraints that currently hold on Target where +% all variables in are copied to new variables in and the +% constraints are given on these new variables. In short, you can safely +% manipulate and without changing the constraints on +% . + +dump([],[],[]) :- !. +dump(Target,NewVars,Constraints) :- + ( ( proper_varlist(Target) + -> true + ; % Target is not a list of variables + throw(instantiation_error(dump(Target,NewVars,Constraints),1)) + ), + ordering(Target), + related_linear_vars(Target,All), % All contains all variables of the classes of Target variables. + nonlin_crux(All,Nonlin), + project_attributes(Target,All), + related_linear_vars(Target,Again), % project drops/adds vars + all_attribute_goals(Again,Gs,Nonlin), + empty_assoc(D0), + mapping(Target,NewVars,D0,D1), % late (AVL suffers from put_atts) + copy(Gs,Copy,D1,_), % strip constraints + nb_setval(clpqr_dump,NewVars/Copy), + fail % undo projection + ; catch(nb_getval(clpqr_dump,NewVars/Constraints),_,fail), + nb_delete(clpqr_dump) + ). + +:- meta_predicate projecting_assert(:). + +projecting_assert(QClause) :- + strip_module(QClause, Module, Clause), % JW: SWI-Prolog not always qualifies the term! + copy_term_clpq(Clause,Copy,Constraints), + l2c(Constraints,Conj), % fails for [] + ( Sm = clpq + ; Sm = clpr + ), % proper module for {}/1 + !, + ( Copy = (H:-B) + -> % former rule + Module:assert((H:-Sm:{Conj},B)) + ; % former fact + Module:assert((Copy:-Sm:{Conj})) + ). +projecting_assert(Clause) :- % not our business + assert(Clause). + +copy_term_clpq(Term,Copy,Constraints) :- + ( term_variables(Term,Target), % get all variables in Term + related_linear_vars(Target,All), % get all variables of the classes of the variables in Term + nonlin_crux(All,Nonlin), % get a list of all the nonlinear goals of these variables + project_attributes(Target,All), + related_linear_vars(Target,Again), % project drops/adds vars + all_attribute_goals(Again,Gs,Nonlin), + empty_assoc(D0), + copy(Term/Gs,TmpCopy,D0,_), % strip constraints + nb_setval(clpqr_dump,TmpCopy), + fail + ; catch(nb_getval(clpqr_dump,Copy/Constraints),_,fail), + nb_delete(clpqr_copy_term) + ). + +% l2c(Lst,Conj) +% +% converts a list to a round list: [a,b,c] -> (a,b,c) and [a] becomes a + +l2c([X|Xs],Conj) :- + ( Xs = [] + -> Conj = X + ; Conj = (X,Xc), + l2c(Xs,Xc) + ). + +% proper_varlist(List) +% +% Returns whether Lst is a list of variables. +% First clause is to avoid unification of a variable with a list. + +proper_varlist(X) :- + var(X), + !, + fail. +proper_varlist([]). +proper_varlist([X|Xs]) :- + var(X), + proper_varlist(Xs). + +% related_linear_vars(Vs,All) +% +% Generates a list of all variables that are in the classes of the variables in +% Vs. + +related_linear_vars(Vs,All) :- + empty_assoc(S0), + related_linear_sys(Vs,S0,Sys), + related_linear_vars(Sys,All,[]). + +% related_linear_sys(Vars,Assoc,List) +% +% Generates in List, a list of all to classes to which variables in Vars +% belong. +% Assoc should be an empty association list and is used internally. +% List contains elements of the form C-C where C is a class and both C's are +% equal. + +related_linear_sys([],S0,L0) :- assoc_to_list(S0,L0). +related_linear_sys([V|Vs],S0,S2) :- + ( get_attr(V,itf,Att), + arg(6,Att,class(C)) + -> put_assoc(C,S0,C,S1) + ; S1 = S0 + ), + related_linear_sys(Vs,S1,S2). + +% related_linear_vars(Classes,[Vars|VarsTail],VarsTail) +% +% Generates a difference list of all variables in the classes in Classes. +% Classes contains elements of the form C-C where C is a class and both C's are +% equal. + +related_linear_vars([]) --> []. +related_linear_vars([S-_|Ss]) --> + { + class_allvars(S,Otl) + }, + cpvars(Otl), + related_linear_vars(Ss). + +% cpvars(Vars,Out,OutTail) +% +% Makes a new difference list of the difference list Vars. +% All nonvars are removed. + +cpvars(Xs) --> {var(Xs)}, !. +cpvars([X|Xs]) --> + ( { var(X) } + -> [X] + ; [] + ), + cpvars(Xs). + +% nonlin_crux(All,Gss) +% +% Collects all pending non-linear constraints of variables in All. +% This marks all nonlinear goals of the variables as run and cannot +% be reversed manually. + +nonlin_crux(All,Gss) :- + collect_nonlin(All,Gs,[]), % collect the nonlinear goals of variables All + % this marks the goals as run and cannot be reversed manually + nonlin_strip(Gs,Gss). + +% nonlin_strip(Gs,Solver,Res) +% +% Removes the goals from Gs that are not from solver Solver. + +nonlin_strip([],[]). +nonlin_strip([_:What|Gs],Res) :- + ( What = {G} + -> Res = [G|Gss] + ; Res = [What|Gss] + ), + nonlin_strip(Gs,Gss). + +all_attribute_goals([]) --> []. +all_attribute_goals([V|Vs]) --> + dump_linear(V), + dump_nonzero(V), + all_attribute_goals(Vs). + +% mapping(L1,L2,AssocIn,AssocOut) +% +% Makes an association mapping of lists L1 and L2: +% L1 = [L1H|L1T] and L2 = [L2H|L2T] then the association L1H-L2H is formed +% and the tails are mapped similarly. + +mapping([],[],D0,D0). +mapping([T|Ts],[N|Ns],D0,D2) :- + put_assoc(T,D0,N,D1), + mapping(Ts,Ns,D1,D2). + +% copy(Term,Copy,AssocIn,AssocOut) +% +% Makes a copy of Term by changing all variables in it to new ones and +% building an association between original variables and the new ones. +% E.g. when Term = test(A,B,C), Copy = test(D,E,F) and an association between +% A and D, B and E and C and F is formed in AssocOut. AssocIn is input +% association. + +copy(Term,Copy,D0,D1) :- + var(Term), + ( get_assoc(Term,D0,New) + -> Copy = New, + D1 = D0 + ; put_assoc(Term,D0,Copy,D1) + ). +copy(Term,Copy,D0,D1) :- + nonvar(Term), % Term is a functor + functor(Term,N,A), + functor(Copy,N,A), % Copy is new functor with the same name and arity as Term + copy(A,Term,Copy,D0,D1). + +% copy(Nb,Term,Copy,AssocIn,AssocOut) +% +% Makes a copy of the Nb arguments of Term by changing all variables in it to +% new ones and building an association between original variables and the new +% ones. +% See also copy/4 + +copy(0,_,_,D0,D0) :- !. +copy(1,T,C,D0,D1) :- !, + arg(1,T,At1), + arg(1,C,Ac1), + copy(At1,Ac1,D0,D1). +copy(2,T,C,D0,D2) :- !, + arg(1,T,At1), + arg(1,C,Ac1), + copy(At1,Ac1,D0,D1), + arg(2,T,At2), + arg(2,C,Ac2), + copy(At2,Ac2,D1,D2). +copy(N,T,C,D0,D2) :- + arg(N,T,At), + arg(N,C,Ac), + copy(At,Ac,D0,D1), + N1 is N-1, + copy(N1,T,C,D1,D2). + +%% attribute_goals(@V)// is det. +% +% Translate attributes back into goals. This is used by +% copy_term/3, which also determines the toplevel printing of +% residual constraints. + +itf:attribute_goals(V) --> + ( { term_attvars(V, Vs), + dump(Vs, NVs, List), + NVs = Vs, + del_itf(Vs), + list_to_conj(List, Conj) } + -> [ {}(Conj) ] + ; [] + ). + +class:attribute_goals(_) --> []. + +geler:attribute_goals(V) --> itf:attribute_goals(V). + +del_itf([]). +del_itf([H|T]) :- + del_attr(H, itf), + del_itf(T). + + +list_to_conj([], true) :- !. +list_to_conj([X], X) :- !. +list_to_conj([H|T0], (H,T)) :- + list_to_conj(T0, T). diff --git a/packages/clpqr/clpqr/geler.pl b/packages/clpqr/clpqr/geler.pl new file mode 100644 index 000000000..b3fd410bf --- /dev/null +++ b/packages/clpqr/clpqr/geler.pl @@ -0,0 +1,192 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(geler, + [ + geler/3, + project_nonlin/3, + collect_nonlin/3 + ]). + +% l2conj(List,Conj) +% +% turns a List into a conjunction of the form (El,Conj) where Conj +% is of the same form recursively and El is an element of the list + +l2conj([X|Xs],Conj) :- + ( X = [], + Conj = X + ; Xs = [_|_], + Conj = (X,Xc), + l2conj(Xs,Xc) + ). + +% nonexhausted(Goals,OutList,OutListTail) +% +% removes the goals that have already run from Goals +% and puts the result in the difference list OutList + +nonexhausted(run(Mutex,G)) --> + ( { var(Mutex) } + -> [G] + ; [] + ). +nonexhausted((A,B)) --> + nonexhausted(A), + nonexhausted(B). + +attr_unify_hook(g(CLP,goals(Gx),_),Y) :- + !, + ( var(Y), + ( get_attr(Y,geler,g(A,B,C)) + -> ignore((CLP \== A,throw(error(permission_error( + 'apply CLP(Q) constraints on','CLP(R) variable',Y), + context(_))))), + ( % possibly mutual goals. these need to be run. + % other goals are run as well to remove redundant goals. + B = goals(Gy) + -> Later = [Gx,Gy], + ( C = n + -> del_attr(Y,geler) + ; put_attr(Y,geler,g(CLP,n,C)) + ) + ; % no goals in Y, so no mutual goals of X and Y, store + % goals of X in Y + % no need to run any goal. + Later = [], + put_attr(Y,geler,g(CLP,goals(Gx),C)) + ) + ; Later = [], + put_attr(Y,geler,g(CLP,goals(Gx),n)) + ) + ; nonvar(Y), + Later = [Gx] + ), + maplist(call,Later). +attr_unify_hook(_,_). % no goals in X + +% +% called from project.pl +% +project_nonlin(_,Cvas,Reachable) :- + collect_nonlin(Cvas,L,[]), + sort(L,Ls), + term_variables(Ls,Reachable). + %put_attr(_,all_nonlin(Ls)). + + +collect_nonlin([]) --> []. +collect_nonlin([X|Xs]) --> + ( { get_attr(X,geler,g(_,goals(Gx),_)) } + -> trans(Gx), + collect_nonlin(Xs) + ; collect_nonlin(Xs) + ). + +% trans(Goals,OutList,OutListTail) +% +% transforms the goals (of the form run(Mutex,Goal) +% that are in Goals (in the conjunction form, see also l2conj) +% that have not been run (Mutex = variable) into a readable output format +% and notes that they're done (Mutex = 'done'). Because of the Mutex +% variable, each goal is only added once (so not for each variable). + +trans((A,B)) --> + trans(A), + trans(B). +trans(run(Mutex,Gs)) --> + ( { var(Mutex) } + -> { Mutex = done }, + transg(Gs) + ; [] + ). + +transg((A,B)) --> + !, + transg(A), + transg(B). +transg(M:G) --> + !, + M:transg(G). +transg(G) --> [G]. + +% run(Mutex,G) +% +% Calls goal G if it has not yet run (Mutex is still variable) +% and stores that it has run (Mutex = done). This is done so +% that when X = Y and X and Y are in the same goal, that goal +% is called only once. + +run(Mutex,_) :- nonvar(Mutex). +run(Mutex,G) :- + var(Mutex), + Mutex = done, + call(G). + +% geler(Vars,Goal) +% +% called by nf.pl when an unsolvable non-linear expression is found +% Vars contain the variables of the expression, Goal contains the predicate of +% nf.pl to be called when the variables are bound. + +geler(CLP,Vars,Goal) :- + attach(Vars,CLP,run(_Mutex,Goal)). + % one goal gets the same mutex on every var, so it is run only once + +% attach(Vars,Goal) +% +% attaches a new goal to be awoken when the variables get bounded. +% when the old value of the attribute goals = OldGoal, then the new value = +% (Goal,OldGoal) + +attach([],_,_). +attach([V|Vs],CLP,Goal) :- + var(V), + ( get_attr(V,geler,g(A,B,C)) + -> ( CLP \== A + -> throw(error(permission_error('apply CLP(Q) constraints on', + 'CLP(R) variable',V),context(_))) + ; ( B = goals(Goals) + -> put_attr(V,geler,g(A,goals((Goal,Goals)),C)) + ; put_attr(V,geler,g(A,goals(Goal),C)) + ) + ) + ; put_attr(V,geler,g(CLP,goals(Goal),n)) + ), + attach(Vs,CLP,Goal). \ No newline at end of file diff --git a/packages/clpqr/clpqr/itf.pl b/packages/clpqr/clpqr/itf.pl new file mode 100644 index 000000000..427d13ea0 --- /dev/null +++ b/packages/clpqr/clpqr/itf.pl @@ -0,0 +1,124 @@ +/* + + Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +% attribute = t(CLP,type(_),strictness(_),lin(_),order(_),class(_),forward(_), +% nonzero,target,keep_indep,keep) + +:- module(itf, + [ + dump_linear/3, + dump_nonzero/3, + clp_type/2 + ]). + + +clp_type(Var,Type) :- + ( get_attr(Var,itf,Att) + -> arg(1,Att,Type) + ; get_attr(Var,geler,Att) + -> arg(1,Att,Type) + ). + +dump_linear(V) --> + { + get_attr(V,itf,Att), + arg(1,Att,CLP), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + !, + Lin = [I,_|H] + }, + ( { + Type=t_none + ; arg(9,Att,n) + } + -> [] + ; dump_v(CLP,t_none,V,I,H) + ), + ( { + Type=t_none, + arg(9,Att,n) % attribute should not have changed by dump_v... + } + -> % nonzero produces such + [] + ; dump_v(CLP,Type,V,I,H) + ). +dump_linear(_) --> []. + +dump_v(clpq,Type,V,I,H) --> bv_q:dump_var(Type,V,I,H). +dump_v(clpr,Type,V,I,H) --> bv_r:dump_var(Type,V,I,H). + +dump_nonzero(V) --> + { + get_attr(V,itf,Att), + arg(1,Att,CLP), + arg(4,Att,lin(Lin)), + arg(8,Att,nonzero), + !, + Lin = [I,_|H] + }, + dump_nz(CLP,V,H,I). +dump_nonzero(_) --> []. + +dump_nz(clpq,V,H,I) --> bv_q:dump_nz(V,H,I). +dump_nz(clpr,V,H,I) --> bv_r:dump_nz(V,H,I). + +attr_unify_hook(t(CLP,n,n,n,n,n,n,n,_,_,_),Y) :- + !, + ( get_attr(Y,itf,AttY), + \+ arg(1,AttY,CLP) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',Y),context(_))) + ; true + ). +attr_unify_hook(t(CLP,Ty,St,Li,Or,Cl,_,No,_,_,_),Y) :- + ( get_attr(Y,itf,AttY), + \+ arg(1,AttY,CLP) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',Y),context(_))) + ; true + ), + do_checks(CLP,Y,Ty,St,Li,Or,Cl,No,Later), + maplist(call,Later). + +do_checks(clpq,Y,Ty,St,Li,Or,Cl,No,Later) :- + itf_q:do_checks(Y,Ty,St,Li,Or,Cl,No,Later). +do_checks(clpr,Y,Ty,St,Li,Or,Cl,No,Later) :- + itf_r:do_checks(Y,Ty,St,Li,Or,Cl,No,Later). diff --git a/packages/clpqr/clpqr/ordering.pl b/packages/clpqr/clpqr/ordering.pl new file mode 100644 index 000000000..29fa7b49d --- /dev/null +++ b/packages/clpqr/clpqr/ordering.pl @@ -0,0 +1,198 @@ +/* $Id$ + + Part of CLP(Q) (Constraint Logic Programming over Rationals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(ordering, + [ + combine/3, + ordering/1, + arrangement/2 + ]). +:- use_module(class, + [ + class_get_clp/2, + class_get_prio/2, + class_put_prio/2 + ]). +:- use_module(itf, + [ + clp_type/2 + ]). +:- use_module(library(ugraphs), + [ + add_edges/3, + add_vertices/3, + top_sort/2, + ugraph_union/3 + ]). +:- use_module(library(lists), + [ + append/3 + ]). + +ordering(X) :- + var(X), + !, + fail. +ordering(A>B) :- + !, + ordering(B clp_type(X,CLP), + ( CLP = clpr + -> bv_r:var_intern(X,Class) + ; bv_q:var_intern(X,Class) + ) + ; true + ), + join_class(Xs,Class). + +% combine(Ga,Gb,Gc) +% +% Combines the vertices of Ga and Gb into Gc. + +combine(Ga,Gb,Gc) :- + normalize(Ga,Gan), + normalize(Gb,Gbn), + ugraph_union(Gan,Gbn,Gc). + +% +% both Ga and Gb might have their internal ordering invalidated +% because of bindings and aliasings +% + +normalize([],[]) :- !. +normalize(G,Gsgn) :- + G = [_|_], + keysort(G,Gs), % sort vertices on key + group(Gs,Gsg), % concatenate vertices with the same key + normalize_vertices(Gsg,Gsgn). % normalize + +normalize_vertices([],[]). +normalize_vertices([X-Xnb|Xs],Res) :- + ( normalize_vertex(X,Xnb,Xnorm) + -> Res = [Xnorm|Xsn], + normalize_vertices(Xs,Xsn) + ; normalize_vertices(Xs,Res) + ). + +% normalize_vertex(X,Nbs,X-Nbss) +% +% Normalizes a vertex X-Nbs into X-Nbss by sorting Nbs, removing duplicates (also of X) +% and removing non-vars. + +normalize_vertex(X,Nbs,X-Nbsss) :- + var(X), + sort(Nbs,Nbss), + strip_nonvar(Nbss,X,Nbsss). + +% strip_nonvar(Nbs,X,Res) +% +% Turns vertext X-Nbs into X-Res by removing occurrences of X from Nbs and removing +% non-vars. This to normalize after bindings have occurred. See also normalize_vertex/3. + +strip_nonvar([],_,[]). +strip_nonvar([X|Xs],Y,Res) :- + ( X==Y % duplicate of Y + -> strip_nonvar(Xs,Y,Res) + ; var(X) % var: keep + -> Res = [X|Stripped], + strip_nonvar(Xs,Y,Stripped) + ; % nonvar: remove + nonvar(X), + Res = [] % because Vars []. +gen_edges([X|Xs]) --> + gen_edges(Xs,X), + gen_edges(Xs). + +gen_edges([],_) --> []. +gen_edges([Y|Ys],X) --> + [X-Y], + gen_edges(Ys,X). + +% group(Vert,Res) +% +% Concatenates vertices with the same key. + +group([],[]). +group([K-Kl|Ks],Res) :- + group(Ks,K,Kl,Res). + +group([],K,Kl,[K-Kl]). +group([L-Ll|Ls],K,Kl,Res) :- + ( K==L + -> append(Kl,Ll,KLl), + group(Ls,K,KLl,Res) + ; Res = [K-Kl|Tail], + group(Ls,L,Ll,Tail) + ). diff --git a/packages/clpqr/clpqr/project.pl b/packages/clpqr/clpqr/project.pl new file mode 100644 index 000000000..a86f3037e --- /dev/null +++ b/packages/clpqr/clpqr/project.pl @@ -0,0 +1,305 @@ +/* + + Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +% +% Answer constraint projection +% + +%:- public project_attributes/2. % xref.pl + +:- module(project, + [ + drop_dep/1, + drop_dep_one/1, + make_target_indep/2, + project_attributes/2 + ]). +:- use_module(class, + [ + class_allvars/2 + ]). +:- use_module(geler, + [ + project_nonlin/3 + ]). +:- use_module(redund, + [ + redundancy_vars/1, + systems/3 + ]). +:- use_module(ordering, + [ + arrangement/2 + ]). + +% +% interface predicate +% +% May be destructive (either acts on a copy or in a failure loop) +% +project_attributes(TargetVars,Cvas) :- + sort(TargetVars,Tvs), % duplicates ? + sort(Cvas,Avs), % duplicates ? + get_clp(TargetVars,CLP), + ( nonvar(CLP) + -> mark_target(Tvs), + project_nonlin(Tvs,Avs,NlReachable), + ( Tvs == [] + -> drop_lin_atts(Avs) + ; redundancy_vars(Avs), % removes redundant bounds (redund.pl) + make_target_indep(Tvs,Pivots), % pivot partners are marked to be kept during elim. + mark_target(NlReachable), % after make_indep to express priority + drop_dep(Avs), + fm_elim(CLP,Avs,Tvs,Pivots), + impose_ordering(Avs) + ) + ; true + ). + +fm_elim(clpq,Avs,Tvs,Pivots) :- fourmotz_q:fm_elim(Avs,Tvs,Pivots). +fm_elim(clpr,Avs,Tvs,Pivots) :- fourmotz_r:fm_elim(Avs,Tvs,Pivots). + +get_clp([],_). +get_clp([H|T],CLP) :- + ( get_attr(H,itf,Att) + -> arg(1,Att,CLP) + ; true + ), + get_clp(T,CLP). + +% mark_target(Vars) +% +% Marks the variables in Vars as target variables. + +mark_target([]). +mark_target([V|Vs]) :- + ( get_attr(V,itf,Att) + -> setarg(9,Att,target) + ; true + ), + mark_target(Vs). + + +% mark_keep(Vars) +% +% Mark the variables in Vars to be kept during elimination. + +mark_keep([]). +mark_keep([V|Vs]) :- + get_attr(V,itf,Att), + setarg(11,Att,keep), + mark_keep(Vs). + +% +% Collect the pivots in reverse order +% We have to protect the target variables pivot partners +% from redundancy eliminations triggered by fm_elim, +% in order to allow for reverse pivoting. +% +make_target_indep(Ts,Ps) :- make_target_indep(Ts,[],Ps). + +% make_target_indep(Targets,Pivots,PivotsTail) +% +% Tries to make as many targetvariables independent by pivoting them with a non-target +% variable. The pivots are stored as T:NT where T is a target variable and NT a non-target +% variable. The non-target variables are marked to be kept during redundancy eliminations. + +make_target_indep([],Ps,Ps). +make_target_indep([T|Ts],Ps0,Pst) :- + ( get_attr(T,itf,AttT), + arg(1,AttT,CLP), + arg(2,AttT,type(Type)), + arg(4,AttT,lin([_,_|H])), + nontarget(H,Nt) + -> Ps1 = [T:Nt|Ps0], + get_attr(Nt,itf,AttN), + arg(2,AttN,type(IndAct)), + arg(5,AttN,order(Ord)), + arg(6,AttN,class(Class)), + setarg(11,AttN,keep), + pivot(CLP,T,Class,Ord,Type,IndAct) + ; Ps1 = Ps0 + ), + make_target_indep(Ts,Ps1,Pst). + +% nontarget(Hom,Nt) +% +% Finds a nontarget variable in homogene part Hom. +% Hom contains elements of the form l(V*K,OrdV). +% A nontarget variable has no target attribute and no keep_indep attribute. + +nontarget([l(V*_,_)|Vs],Nt) :- + ( get_attr(V,itf,Att), + arg(9,Att,n), + arg(10,Att,n) + -> Nt = V + ; nontarget(Vs,Nt) + ). + +% drop_dep(Vars) +% +% Does drop_dep_one/1 on each variable in Vars. + +drop_dep(Vs) :- + var(Vs), + !. +drop_dep([]). +drop_dep([V|Vs]) :- + drop_dep_one(V), + drop_dep(Vs). + +% drop_dep_one(V) +% +% If V is an unbounded dependent variable that isn't a target variable, shouldn't be kept +% and is not nonzero, drops all linear attributes of V. +% The linear attributes are: type, strictness, linear equation (lin), class and order. + +drop_dep_one(V) :- + get_attr(V,itf,Att), + Att = t(CLP,type(t_none),_,lin(Lin),order(OrdV),_,_,n,n,_,n), + \+ indep(CLP,Lin,OrdV), + !, + setarg(2,Att,n), + setarg(3,Att,n), + setarg(4,Att,n), + setarg(5,Att,n), + setarg(6,Att,n). +drop_dep_one(_). + +indep(clpq,Lin,OrdV) :- store_q:indep(Lin,OrdV). +indep(clpr,Lin,OrdV) :- store_r:indep(Lin,OrdV). + +pivot(clpq,T,Class,Ord,Type,IndAct) :- bv_q:pivot(T,Class,Ord,Type,IndAct). +pivot(clpr,T,Class,Ord,Type,IndAct) :- bv_r:pivot(T,Class,Ord,Type,IndAct). + +renormalize(clpq,Lin,New) :- store_q:renormalize(Lin,New). +renormalize(clpr,Lin,New) :- store_r:renormalize(Lin,New). + +% drop_lin_atts(Vs) +% +% Removes the linear attributes of the variables in Vs. +% The linear attributes are type, strictness, linear equation (lin), order and class. + +drop_lin_atts([]). +drop_lin_atts([V|Vs]) :- + get_attr(V,itf,Att), + setarg(2,Att,n), + setarg(3,Att,n), + setarg(4,Att,n), + setarg(5,Att,n), + setarg(6,Att,n), + drop_lin_atts(Vs). + +impose_ordering(Cvas) :- + systems(Cvas,[],Sys), + impose_ordering_sys(Sys). + +impose_ordering_sys([]). +impose_ordering_sys([S|Ss]) :- + arrangement(S,Arr), % ordering.pl + arrange(Arr,S), + impose_ordering_sys(Ss). + +arrange([],_). +arrange(Arr,S) :- + Arr = [_|_], + class_allvars(S,All), + order(Arr,1,N), + order(All,N,_), + renorm_all(All), + arrange_pivot(All). + +order(Xs,N,M) :- + var(Xs), + !, + N = M. +order([],N,N). +order([X|Xs],N,M) :- + ( get_attr(X,itf,Att), + arg(5,Att,order(O)), + var(O) + -> O = N, + N1 is N+1, + order(Xs,N1,M) + ; order(Xs,N,M) + ). + +% renorm_all(Vars) +% +% Renormalizes all linear equations of the variables in difference list Vars to reflect +% their new ordering. + +renorm_all(Xs) :- + var(Xs), + !. +renorm_all([X|Xs]) :- + ( get_attr(X,itf,Att), + arg(1,Att,CLP), + arg(4,Att,lin(Lin)) + -> renormalize(CLP,Lin,New), + setarg(4,Att,lin(New)), + renorm_all(Xs) + ; renorm_all(Xs) + ). + +% arrange_pivot(Vars) +% +% If variable X of Vars has type t_none and has a higher order than the first element of +% its linear equation, then it is pivoted with that element. + +arrange_pivot(Xs) :- + var(Xs), + !. +arrange_pivot([X|Xs]) :- + ( get_attr(X,itf,AttX), + %arg(8,AttX,n), % not for nonzero + arg(1,AttX,CLP), + arg(2,AttX,type(t_none)), + arg(4,AttX,lin(Lin)), + arg(5,AttX,order(OrdX)), + Lin = [_,_,l(Y*_,_)|_], + get_attr(Y,itf,AttY), + arg(2,AttY,type(IndAct)), + arg(5,AttY,order(OrdY)), + arg(6,AttY,class(Class)), + compare(>,OrdY,OrdX) + -> pivot(CLP,X,Class,OrdY,t_none,IndAct), + arrange_pivot(Xs) + ; arrange_pivot(Xs) + ). \ No newline at end of file diff --git a/packages/clpqr/clpqr/redund.pl b/packages/clpqr/clpqr/redund.pl new file mode 100644 index 000000000..f20bdc629 --- /dev/null +++ b/packages/clpqr/clpqr/redund.pl @@ -0,0 +1,297 @@ +/* + + Part of CLP(Q,R) (Constraint Logic Programming over Rationals and Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(redund, + [ + redundancy_vars/1, + systems/3 + ]). +:- use_module(class, + [ + class_allvars/2 + ]). + +% +% redundancy removal (semantic definition) +% +% done: +% +) deal with active bounds +% +) indep t_[lu] -> t_none invalidates invariants (fixed) +% + +% systems(Vars,SystemsIn,SystemsOut) +% +% Returns in SystemsOut the different classes to which variables in Vars +% belong. Every class only appears once in SystemsOut. + +systems([],Si,Si). +systems([V|Vs],Si,So) :- + ( var(V), + get_attr(V,itf,Att), + arg(6,Att,class(C)), + not_memq(Si,C) + -> systems(Vs,[C|Si],So) + ; systems(Vs,Si,So) + ). + +% not_memq(Lst,El) +% +% Succeeds if El is not a member of Lst (does not use unification). + +not_memq([],_). +not_memq([Y|Ys],X) :- + X \== Y, + not_memq(Ys,X). + +% redundancy_systems(Classes) +% +% Does redundancy removal via redundancy_vs/1 on all variables in the classes Classes. + +redundancy_systems([]). +redundancy_systems([S|Sys]) :- + class_allvars(S,All), + redundancy_vs(All), + redundancy_systems(Sys). + +% redundancy_vars(Vs) +% +% Does the same thing as redundancy_vs/1 but has some extra timing facilities that +% may be used. + +redundancy_vars(Vs) :- + !, + redundancy_vs(Vs). +redundancy_vars(Vs) :- + statistics(runtime,[Start|_]), + redundancy_vs(Vs), + statistics(runtime,[End|_]), + Duration is End-Start, + format(user_error,"% Redundancy elimination took ~d msec~n",Duration). + + +% redundancy_vs(Vs) +% +% Removes redundant bounds from the variables in Vs via redundant/3 + +redundancy_vs(Vs) :- + var(Vs), + !. +redundancy_vs([]). +redundancy_vs([V|Vs]) :- + ( get_attr(V,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Strict)), + redundant(Type,V,Strict) + -> redundancy_vs(Vs) + ; redundancy_vs(Vs) + ). + +% redundant(Type,Var,Strict) +% +% Removes redundant bounds from variable Var with type Type and strictness Strict. +% A redundant bound is one that is satisfied anyway (so adding the inverse of the bound +% makes the system infeasible. This predicate can either fail or succeed but a success +% doesn't necessarily mean a redundant bound. + +redundant(t_l(L),X,Strict) :- + get_attr(X,itf,Att), + arg(1,Att,CLP), + detach_bounds(CLP,X), % drop temporarily + % if not redundant, backtracking will restore bound + negate_l(Strict,CLP,L,X), + red_t_l. % negate_l didn't fail, redundant bound +redundant(t_u(U),X,Strict) :- + get_attr(X,itf,Att), + arg(1,Att,CLP), + detach_bounds(CLP,X), + negate_u(Strict,CLP,U,X), + red_t_u. +redundant(t_lu(L,U),X,Strict) :- + strictness_parts(Strict,Sl,Su), + ( get_attr(X,itf,Att), + arg(1,Att,CLP), + setarg(2,Att,type(t_u(U))), + setarg(3,Att,strictness(Su)), + negate_l(Strict,CLP,L,X) + -> red_t_l, + ( redundant(t_u(U),X,Strict) + -> true + ; true + ) + ; get_attr(X,itf,Att), + arg(1,Att,CLP), + setarg(2,Att,type(t_l(L))), + setarg(3,Att,strictness(Sl)), + negate_u(Strict,CLP,U,X) + -> red_t_u + ; true + ). +redundant(t_L(L),X,Strict) :- + get_attr(X,itf,Att), + arg(1,Att,CLP), + Bound is -L, + intro_at(CLP,X,Bound,t_none), % drop temporarily + detach_bounds(CLP,X), + negate_l(Strict,CLP,L,X), + red_t_L. +redundant(t_U(U),X,Strict) :- + get_attr(X,itf,Att), + arg(1,Att,CLP), + Bound is -U, + intro_at(CLP,X,Bound,t_none), % drop temporarily + detach_bounds(CLP,X), + negate_u(Strict,CLP,U,X), + red_t_U. +redundant(t_Lu(L,U),X,Strict) :- + strictness_parts(Strict,Sl,Su), + ( Bound is -L, + get_attr(X,itf,Att), + arg(1,Att,CLP), + intro_at(CLP,X,Bound,t_u(U)), + get_attr(X,itf,Att2), % changed? + setarg(3,Att2,strictness(Su)), + negate_l(Strict,CLP,L,X) + -> red_t_l, + ( redundant(t_u(U),X,Strict) + -> true + ; true + ) + ; get_attr(X,itf,Att), + arg(1,Att,CLP), + setarg(2,Att,type(t_L(L))), + setarg(3,Att,strictness(Sl)), + negate_u(Strict,CLP,U,X) + -> red_t_u + ; true + ). +redundant(t_lU(L,U),X,Strict) :- + strictness_parts(Strict,Sl,Su), + ( get_attr(X,itf,Att), + arg(1,Att,CLP), + setarg(2,Att,type(t_U(U))), + setarg(3,Att,strictness(Su)), + negate_l(Strict,CLP,L,X) + -> red_t_l, + ( redundant(t_U(U),X,Strict) + -> true + ; true + ) + ; get_attr(X,itf,Att), + arg(1,Att,CLP), + Bound is -U, + intro_at(CLP,X,Bound,t_l(L)), + get_attr(X,itf,Att2), % changed? + setarg(3,Att2,strictness(Sl)), + negate_u(Strict,CLP,U,X) + -> red_t_u + ; true + ). + +% strictness_parts(Strict,Lower,Upper) +% +% Splits strictness Strict into two parts: one related to the lowerbound and +% one related to the upperbound. + +strictness_parts(Strict,Lower,Upper) :- + Lower is Strict /\ 2, + Upper is Strict /\ 1. + +% negate_l(Strict,Lowerbound,X) +% +% Fails if X does not necessarily satisfy the lowerbound and strictness +% In other words: if adding the inverse of the lowerbound (X < L or X =< L) +% does not result in a failure, this predicate fails. + +negate_l(0,CLP,L,X) :- + CLP:{L > X}, + !, + fail. +negate_l(1,CLP,L,X) :- + CLP:{L > X}, + !, + fail. +negate_l(2,CLP,L,X) :- + CLP:{L >= X}, + !, + fail. +negate_l(3,CLP,L,X) :- + CLP:{L >= X}, + !, + fail. +negate_l(_,_,_,_). + +% negate_u(Strict,Upperbound,X) +% +% Fails if X does not necessarily satisfy the upperbound and strictness +% In other words: if adding the inverse of the upperbound (X > U or X >= U) +% does not result in a failure, this predicate fails. + +negate_u(0,CLP,U,X) :- + CLP:{U < X}, + !, + fail. +negate_u(1,CLP,U,X) :- + CLP:{U =< X}, + !, + fail. +negate_u(2,CLP,U,X) :- + CLP:{U < X}, + !, + fail. +negate_u(3,CLP,U,X) :- + CLP:{U =< X}, + !, + fail. +negate_u(_,_,_,_). + +% CLP(Q,R) + +detach_bounds(clpq,X) :- bv_q:detach_bounds(X). +detach_bounds(clpr,X) :- bv_r:detach_bounds(X). + +intro_at(clpq,A,B,C) :- bv_q:intro_at(A,B,C). +intro_at(clpr,A,B,C) :- bv_r:intro_at(A,B,C). + +% Profiling: these predicates are called during redundant and can be used +% to count the number of redundant bounds. + +red_t_l. +red_t_u. +red_t_L. +red_t_U. \ No newline at end of file diff --git a/packages/clpqr/clpr.pl b/packages/clpqr/clpr.pl new file mode 100644 index 000000000..1e9fb9b00 --- /dev/null +++ b/packages/clpqr/clpr.pl @@ -0,0 +1,204 @@ +/* $Id$ + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + + +/** @pred bb_inf(+ _Ints_,+ _Expression_,- _Inf_) +The same as bb_inf/5 but without returning the values of the integers +and with an eps of 0.001. + + +*/ +/** @pred bb_inf(+ _Ints_,+ _Expression_,- _Inf_,- _Vertext_,+ _Eps_) +Computes the infimum of _Expression_ within the current constraint +store, with the additional constraint that in that infimum, all +variables in _Ints_ have integral values. _Vertex_ will contain +the values of _Ints_ in the infimum. _Eps_ denotes how much a +value may differ from an integer to be considered an integer. E.g. when + _Eps_ = 0.001, then X = 4.999 will be considered as an integer (5 in +this case). _Eps_ should be between 0 and 0.5. + + +*/ +/** @pred dump(+ _Target_,+ _Newvars_,- _CodedAnswer_) +Returns the constraints on _Target_ in the list _CodedAnswer_ +where all variables of _Target_ have veen replaced by _NewVars_. +This operation does not change the constraint store. E.g. in + +~~~~~ +dump([X,Y,Z],[x,y,z],Cons) +~~~~~ + + _Cons_ will contain the constraints on _X_, _Y_ and + _Z_ where these variables have been replaced by atoms `x`, `y` and `z`. + + + + + */ +/** @pred entailed(+ _Constraint_) +Succeeds if _Constraint_ is necessarily true within the current +constraint store. This means that adding the negation of the constraint +to the store results in failure. + + +*/ +/** @pred inf(+ _Expression_,- _Inf_) +Computes the infimum of _Expression_ within the current state of the +constraint store and returns that infimum in _Inf_. This predicate +does not change the constraint store. + + +*/ +/** @pred inf(+ _Expression_,- _Sup_) +Computes the supremum of _Expression_ within the current state of +the constraint store and returns that supremum in _Sup_. This +predicate does not change the constraint store. + + +*/ +/** @pred maximize( _V_) +maximise variable _V_ + + +*/ +/** @pred minimize(V) +minimise variable _V_ + + + + + */ +:- module(clpr, + [ + {}/1, + maximize/1, + minimize/1, + inf/2, inf/4, sup/2, sup/4, + bb_inf/3, + bb_inf/5, + ordering/1, + entailed/1, + clp_type/2, + dump/3%, projecting_assert/1 + ]). + +:- expects_dialect(swi). + +% +% Don't report export of private predicates from clpr +% +:- multifile + user:portray_message/2. + +:- dynamic + user:portray_message/2. +% +user:portray_message(warning,import(_,_,clpr,private)). + +:- load_files( + [ + 'clpr/bb_r', + 'clpr/bv_r', + 'clpr/fourmotz_r', + 'clpr/ineq_r', + 'clpr/itf_r', + 'clpr/nf_r', + 'clpr/store_r', + 'clpqr/class', + 'clpqr/dump', + 'clpqr/geler', + 'clpqr/itf', + 'clpqr/ordering', + 'clpqr/project', + 'clpqr/redund', + library(ugraphs) + ], + [ + if(not_loaded), + silent(true) + ]). + + /******************************* + * TOPLEVEL PRINTING * + *******************************/ + +:- multifile + prolog:message/3. + +% prolog:message(query(YesNo)) --> !, +% ['~@'-[chr:print_all_stores]], +% '$messages':prolog_message(query(YesNo)). + +prolog:message(query(YesNo,Bindings)) --> !, + {dump_toplevel_bindings(Bindings,Constraints)}, + {dump_format(Constraints,Format)}, + Format, + '$messages':prolog_message(query(YesNo,Bindings)). + +dump_toplevel_bindings(Bindings,Constraints) :- + dump_vars_names(Bindings,[],Vars,Names), + dump(Vars,Names,Constraints). + +dump_vars_names([],_,[],[]). +dump_vars_names([Name=Term|Rest],Seen,Vars,Names) :- + ( var(Term), + ( get_attr(Term,itf,_) + ; get_attr(Term,geler,_) + ), + \+ memberchk_eq(Term,Seen) + -> Vars = [Term|RVars], + Names = [Name|RNames], + NSeen = [Term|Seen] + ; Vars = RVars, + Names = RNames, + Seen = NSeen + ), + dump_vars_names(Rest,NSeen,RVars,RNames). + +dump_format([],[]). +dump_format([X|Xs],['{~w}'-[X],nl|Rest]) :- + dump_format(Xs,Rest). + +memberchk_eq(X,[Y|Ys]) :- + ( X == Y + -> true + ; memberchk_eq(X,Ys) + ). diff --git a/packages/clpqr/clpr/bb_r.pl b/packages/clpqr/clpr/bb_r.pl new file mode 100644 index 000000000..331c2b489 --- /dev/null +++ b/packages/clpqr/clpr/bb_r.pl @@ -0,0 +1,260 @@ +/* $Id$ + + Part of CPL(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(bb_r, + [ + bb_inf/3, + bb_inf/5, + vertex_value/2 + ]). +:- use_module(bv_r, + [ + deref/2, + deref_var/2, + determine_active_dec/1, + inf/2, + iterate_dec/2, + sup/2, + var_with_def_assign/2 + ]). +:- use_module(nf_r, + [ + {}/1, + entailed/1, + nf/2, + nf_constant/2, + repair/2, + wait_linear/3 + ]). + +% bb_inf(Ints,Term,Inf) +% +% Finds the infimum of Term where the variables Ints are to be integers. +% The infimum is stored in Inf. + +bb_inf(Is,Term,Inf) :- + bb_inf(Is,Term,Inf,_,0.001). + +bb_inf(Is,Term,Inf,Vertex,Eps) :- + nf(Eps,ENf), + nf_constant(ENf,EpsN), + wait_linear(Term,Nf,bb_inf_internal(Is,Nf,EpsN,Inf,Vertex)). + +% --------------------------------------------------------------------- + +% bb_inf_internal(Is,Lin,Eps,Inf,Vertex) +% +% Finds an infimum Inf for linear expression in normal form Lin, where +% all variables in Is are to be integers. Eps denotes the margin in which +% we accept a number as an integer (to deal with rounding errors etc.). + +bb_inf_internal(Is,Lin,Eps,_,_) :- + bb_intern(Is,IsNf,Eps), + nb_delete(prov_opt), + repair(Lin,LinR), % bb_narrow ... + deref(LinR,Lind), + var_with_def_assign(Dep,Lind), + determine_active_dec(Lind), + bb_loop(Dep,IsNf,Eps), + fail. +bb_inf_internal(_,_,_,Inf,Vertex) :- + catch(nb_getval(prov_opt,InfVal-Vertex),_,fail), + {Inf =:= InfVal}, + nb_delete(prov_opt). + +% bb_loop(Opt,Is,Eps) +% +% Minimizes the value of Opt where variables Is have to be integer values. +% Eps denotes the rounding error that is acceptable. This predicate can be +% backtracked to try different strategies. + +bb_loop(Opt,Is,Eps) :- + bb_reoptimize(Opt,Inf), + bb_better_bound(Inf), + vertex_value(Is,Ivs), + ( bb_first_nonint(Is,Ivs,Eps,Viol,Floor,Ceiling) + -> bb_branch(Viol,Floor,Ceiling), + bb_loop(Opt,Is,Eps) + ; round_values(Ivs,RoundVertex), + nb_setval(prov_opt,Inf-RoundVertex) % new provisional optimum + ). + +% bb_reoptimize(Obj,Inf) +% +% Minimizes the value of Obj and puts the result in Inf. +% This new minimization is necessary as making a bound integer may yield a +% different optimum. The added inequalities may also have led to binding. + +bb_reoptimize(Obj,Inf) :- + var(Obj), + iterate_dec(Obj,Inf). +bb_reoptimize(Obj,Inf) :- + nonvar(Obj), + Inf = Obj. + +% bb_better_bound(Inf) +% +% Checks if the new infimum Inf is better than the previous one (if such exists). + +bb_better_bound(Inf) :- + catch((nb_getval(prov_opt,Inc-_),Inf - Inc < -1.0e-10),_,true). + +% bb_branch(V,U,L) +% +% Stores that V =< U or V >= L, can be used for different strategies within bb_loop/3. + +bb_branch(V,U,_) :- {V =< U}. +bb_branch(V,_,L) :- {V >= L}. + +% vertex_value(Vars,Values) +% +% Returns in the current values of the variables in . + +vertex_value([],[]). +vertex_value([X|Xs],[V|Vs]) :- + rhs_value(X,V), + vertex_value(Xs,Vs). + +% rhs_value(X,Value) +% +% Returns in the current value of variable . + +rhs_value(Xn,Value) :- + ( nonvar(Xn) + -> Value = Xn + ; var(Xn) + -> deref_var(Xn,Xd), + Xd = [I,R|_], + Value is R+I + ). + +% bb_first_nonint(Ints,Rhss,Eps,Viol,Floor,Ceiling) +% +% Finds the first variable in Ints which doesn't have an active integer bound. +% Rhss contain the Rhs (R + I) values corresponding to the variables. +% The first variable that hasn't got an active integer bound, is returned in +% Viol. The floor and ceiling of its actual bound is returned in Floor and Ceiling. + +bb_first_nonint([I|Is],[Rhs|Rhss],Eps,Viol,F,C) :- + ( Floor is floor(Rhs+1.0e-10), + Ceiling is ceiling(Rhs-1.0e-10), + Eps - min(Rhs-Floor,Ceiling-Rhs) < -1.0e-10 + -> Viol = I, + F = Floor, + C = Ceiling + ; bb_first_nonint(Is,Rhss,Eps,Viol,F,C) + ). + +% round_values([X|Xs],[Xr|Xrs]) +% +% Rounds of the values of the first list into the second list. + +round_values([],[]). +round_values([X|Xs],[Y|Ys]) :- + Y is round(X), + round_values(Xs,Ys). + +% bb_intern([X|Xs],[Xi|Xis],Eps) +% +% Turns the elements of the first list into integers into the second +% list via bb_intern/4. + +bb_intern([],[],_). +bb_intern([X|Xs],[Xi|Xis],Eps) :- + nf(X,Xnf), + bb_intern(Xnf,Xi,X,Eps), + bb_intern(Xs,Xis,Eps). + + +% bb_intern(Nf,X,Term,Eps) +% +% Makes sure that Term which is normalized into Nf, is integer. +% X contains the possibly changed Term. If Term is a variable, +% then its bounds are hightened or lowered to the next integer. +% Otherwise, it is checked it Term is integer. + +bb_intern([],X,_,_) :- + !, + X = 0.0. +bb_intern([v(I,[])],X,_,Eps) :- + !, + X = I, + min(I-floor(I+1e-010),ceiling(I-1e-010)-I) - Eps < 1e-010. +bb_intern([v(One,[V^1])],X,_,_) :- + Test is One - 1.0, + Test =< 1e-010, + Test >= -1e-010, + !, + V = X, + bb_narrow_lower(X), + bb_narrow_upper(X). +bb_intern(_,_,Term,_) :- + throw(instantiation_error(bb_inf(Term,_,_),1)). + +% bb_narrow_lower(X) +% +% Narrows the lower bound so that it is an integer bound. +% We do this by finding the infimum of X and asserting that X +% is larger than the first integer larger or equal to the infimum +% (second integer if X is to be strict larger than the first integer). + +bb_narrow_lower(X) :- + ( inf(X,Inf) + -> Bound is ceiling(Inf-1.0e-10), + ( entailed(X > Bound) + -> {X >= Bound+1} + ; {X >= Bound} + ) + ; true + ). + +% bb_narrow_upper(X) +% +% See bb_narrow_lower/1. This predicate handles the upper bound. + +bb_narrow_upper(X) :- + ( sup(X,Sup) + -> Bound is floor(Sup+1.0e-10), + ( entailed(X < Bound) + -> {X =< Bound-1} + ; {X =< Bound} + ) + ; true + ). diff --git a/packages/clpqr/clpr/bv_r.pl b/packages/clpqr/clpr/bv_r.pl new file mode 100644 index 000000000..b481858fd --- /dev/null +++ b/packages/clpqr/clpr/bv_r.pl @@ -0,0 +1,1786 @@ +/* $Id$ + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2006, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is based on CLP(Q,R) by Christian Holzbaur for SICStus + Prolog and distributed under the license details below with permission from + all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(bv_r, + [ + allvars/2, + backsubst/3, + backsubst_delta/4, + basis_add/2, + dec_step/2, + deref/2, + deref_var/2, + detach_bounds/1, + detach_bounds_vlv/5, + determine_active_dec/1, + determine_active_inc/1, + dump_var/6, + dump_nz/5, + export_binding/1, + export_binding/2, + get_or_add_class/2, + inc_step/2, + intro_at/3, + iterate_dec/2, + lb/3, + pivot_a/4, + pivot/5, + rcbl_status/6, + reconsider/1, + same_class/2, + solve/1, + solve_ord_x/3, + ub/3, + unconstrained/4, + var_intern/2, + var_intern/3, + var_with_def_assign/2, + var_with_def_intern/4, + maximize/1, + minimize/1, + sup/2, + sup/4, + inf/2, + inf/4, + 'solve_<'/1, + 'solve_=<'/1, + 'solve_=\\='/1, + log_deref/4 + ]). +:- use_module(store_r, + [ + add_linear_11/3, + add_linear_f1/4, + add_linear_ff/5, + delete_factor/4, + indep/2, + isolate/3, + nf2sum/3, + nf_rhs_x/4, + nf_substitute/4, + normalize_scalar/2, + mult_hom/3, + mult_linear_factor/3 + ]). +:- use_module('../clpqr/class', + [ + class_allvars/2, + class_basis/2, + class_basis_add/3, + class_basis_drop/2, + class_basis_pivot/3, + class_new/5 + ]). +:- use_module(ineq_r, + [ + ineq/4 + ]). +:- use_module(nf_r, + [ + {}/1, + split/3, + wait_linear/3 + ]). +:- use_module(bb_r, + [ + vertex_value/2 + ]). +:- use_module(library(ordsets), + [ + ord_add_element/3 + ]). + +% For the rhs maint. the following events are important: +% +% -) introduction of an indep var at active bound B +% -) narrowing of active bound +% -) swap active bound +% -) pivot +% + +% a variables bound (L/U) can have the states: +% +% -) t_none no bounds +% -) t_l inactive lower bound +% -) t_u inactive upper bound +% -) t_L active lower bound +% -) t_U active upper bound +% -) t_lu inactive lower and upper bound +% -) t_Lu active lower bound and inactive upper bound +% -) t_lU inactive lower bound and active upper bound + +% ----------------------------------- deref ----------------------------------- +% + +% deref(Lin,Lind) +% +% Makes a linear equation of the form [v(I,[])|H] into a solvable linear +% equation. +% If the variables are new, they are initialized with the linear equation X=X. + +deref(Lin,Lind) :- + split(Lin,H,I), + normalize_scalar(I,Nonvar), + length(H,Len), + log_deref(Len,H,[],Restd), + add_linear_11(Nonvar,Restd,Lind). + +% log_deref(Len,[Vs|VsTail],VsTail,Res) +% +% Logarithmically converts a linear equation in normal form ([v(_,_)|_]) into a +% linear equation in solver form ([I,R,K*X|_]). Res contains the result, Len is +% the length of the part to convert and [Vs|VsTail] is a difference list +% containing the equation in normal form. + +log_deref(0,Vs,Vs,Lin) :- + !, + Lin = [0.0,0.0]. +log_deref(1,[v(K,[X^1])|Vs],Vs,Lin) :- + !, + deref_var(X,Lx), + mult_linear_factor(Lx,K,Lin). +log_deref(2,[v(Kx,[X^1]),v(Ky,[Y^1])|Vs],Vs,Lin) :- + !, + deref_var(X,Lx), + deref_var(Y,Ly), + add_linear_ff(Lx,Kx,Ly,Ky,Lin). +log_deref(N,V0,V2,Lin) :- + P is N >> 1, + Q is N - P, + log_deref(P,V0,V1,Lp), + log_deref(Q,V1,V2,Lq), + add_linear_11(Lp,Lq,Lin). + +% deref_var(X,Lin) +% +% Returns the equation of variable X. If X is a new variable, a new equation +% X = X is made. + +deref_var(X,Lin) :- + ( get_attr(X,itf,Att) + -> ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; arg(4,Att,lin(Lin)) + -> true + ; setarg(2,Att,type(t_none)), + setarg(3,Att,strictness(0)), + Lin = [0.0,0.0,l(X*1.0,Ord)], + setarg(4,Att,lin(Lin)), + setarg(5,Att,order(Ord)) + ) + ; Lin = [0.0,0.0,l(X*1.0,Ord)], + put_attr(X,itf,t(clpr,type(t_none),strictness(0), + lin(Lin),order(Ord),n,n,n,n,n,n)) + ). + +% TODO +% +% + +var_with_def_assign(Var,Lin) :- + Lin = [I,_|Hom], + ( Hom = [] + -> % X=k + Var = I + ; Hom = [l(V*K,_)|Cs] + -> ( Cs = [], + TestK is K - 1.0, % K =:= 1 + TestK =< 1.0e-10, + TestK >= -1.0e-10, + I >= -1.0e-010, % I =:= 0 + I =< 1.0e-010 + -> % X=Y + Var = V + ; % general case + var_with_def_intern(t_none,Var,Lin,0) + ) + ). + +% var_with_def_intern(Type,Var,Lin,Strictness) +% +% Makes Lin the linear equation of new variable Var, makes all variables of +% Lin, and Var of the same class and bounds Var by type(Type) and +% strictness(Strictness) + +var_with_def_intern(Type,Var,Lin,Strict) :- + put_attr(Var,itf,t(clpr,type(Type),strictness(Strict),lin(Lin), + order(_),n,n,n,n,n,n)), % check uses + Lin = [_,_|Hom], + get_or_add_class(Var,Class), + same_class(Hom,Class). + +% TODO +% +% + +var_intern(Type,Var,Strict) :- + put_attr(Var,itf,t(clpr,type(Type),strictness(Strict), + lin([0.0,0.0,l(Var*1.0,Ord)]),order(Ord),n,n,n,n,n,n)), + get_or_add_class(Var,_Class). + +% TODO +% +% + +var_intern(Var,Class) :- % for ordered/1 but otherwise free vars + get_attr(Var,itf,Att), + arg(2,Att,type(_)), + arg(4,Att,lin(_)), + !, + get_or_add_class(Var,Class). +var_intern(Var,Class) :- + put_attr(Var,itf,t(clpr,type(t_none),strictness(0), + lin([0.0,0.0,l(Var*1.0,Ord)]),order(Ord),n,n,n,n,n,n)), + get_or_add_class(Var,Class). + +% ----------------------------------------------------------------------------- + +% export_binding(Lst) +% +% Binds variables X to Y where Lst contains elements of the form [X-Y]. + +export_binding([]). +export_binding([X-Y|Gs]) :- + export_binding(Y,X), + export_binding(Gs). + +% export_binding(Y,X) +% +% Binds variable X to Y. If Y is a nonvar and equals 0, then X is set to 0 +% (numerically more stable) + +export_binding(Y,X) :- + var(Y), + Y = X. +export_binding(Y,X) :- + nonvar(Y), + ( Y >= -1.0e-10, % Y =:= 0 + Y =< 1.0e-10 + -> X = 0.0 + ; Y = X + ). + +% 'solve_='(Nf) +% +% Solves linear equation Nf = 0 where Nf is in normal form. + +'solve_='(Nf) :- + deref(Nf,Nfd), % dereferences and turns Nf into solvable form Nfd + solve(Nfd). + +% 'solve_=\\='(Nf) +% +% Solves linear inequality Nf =\= 0 where Nf is in normal form. + +'solve_=\\='(Nf) :- + deref(Nf,Lind), % dereferences and turns Nf into solvable form Lind + Lind = [Inhom,_|Hom], + ( Hom = [] + -> % Lind = Inhom => check Inhom =\= 0 + \+ (Inhom >= -1.0e-10, Inhom =< 1.0e-10) % Inhom =\= 0 + ; % make new variable Nz = Lind + var_with_def_intern(t_none,Nz,Lind,0), + % make Nz nonzero + get_attr(Nz,itf,Att), + setarg(8,Att,nonzero) + ). + +% 'solve_<'(Nf) +% +% Solves linear inequality Nf < 0 where Nf is in normal form. + +'solve_<'(Nf) :- + split(Nf,H,I), + ineq(H,I,Nf,strict). + +% 'solve_=<'(Nf) +% +% Solves linear inequality Nf =< 0 where Nf is in normal form. + +'solve_=<'(Nf) :- + split(Nf,H,I), + ineq(H,I,Nf,nonstrict). + +maximize(Term) :- + minimize(-Term). + +% +% This is NOT coded as minimize(Expr) :- inf(Expr,Expr). +% +% because the new version of inf/2 only visits +% the vertex where the infimum is assumed and returns +% to the 'current' vertex via backtracking. +% The rationale behind this construction is to eliminate +% all garbage in the solver data structures produced by +% the pivots on the way to the extremal point caused by +% {inf,sup}/{2,4}. +% +% If we are after the infimum/supremum for minimizing/maximizing, +% this strategy may have adverse effects on performance because +% the simplex algorithm is forced to re-discover the +% extremal vertex through the equation {Inf =:= Expr}. +% +% Thus the extra code for {minimize,maximize}/1. +% +% In case someone comes up with an example where +% +% inf(Expr,Expr) +% +% outperforms the provided formulation for minimize - so be it. +% Both forms are available to the user. +% +minimize(Term) :- + wait_linear(Term,Nf,minimize_lin(Nf)). + +% minimize_lin(Lin) +% +% Minimizes the linear expression Lin. It does so by making a new +% variable Dep and minimizes its value. + +minimize_lin(Lin) :- + deref(Lin,Lind), + var_with_def_intern(t_none,Dep,Lind,0), + determine_active_dec(Lind), + iterate_dec(Dep,Inf), + { Dep =:= Inf }. + +sup(Expression,Sup) :- + sup(Expression,Sup,[],[]). + +sup(Expression,Sup,Vector,Vertex) :- + inf(-Expression,-Sup,Vector,Vertex). + +inf(Expression,Inf) :- + inf(Expression,Inf,[],[]). + +inf(Expression,Inf,Vector,Vertex) :- + % wait until Expression becomes linear, Nf contains linear Expression + % in normal form + wait_linear(Expression,Nf,inf_lin(Nf,Inf,Vector,Vertex)). + +inf_lin(Lin,_,Vector,_) :- + deref(Lin,Lind), + var_with_def_intern(t_none,Dep,Lind,0), % make new variable Dep = Lind + determine_active_dec(Lind), % minimizes Lind + iterate_dec(Dep,Inf), + vertex_value(Vector,Values), + nb_setval(inf,[Inf|Values]), + fail. +inf_lin(_,Infimum,_,Vertex) :- + catch(nb_getval(inf,L),_,fail), + nb_delete(inf), + assign([Infimum|Vertex],L). + +% assign(L1,L2) +% +% The elements of L1 are pairwise assigned to the elements of L2 +% by means of asserting {X =:= Y} where X is an element of L1 and Y +% is the corresponding element of L2. + +assign([],[]). +assign([X|Xs],[Y|Ys]) :- + {X =:= Y}, % more defensive/expressive than X=Y + assign(Xs,Ys). + +% --------------------------------- optimization ------------------------------ +% +% The _sn(S) =< 0 row might be temporarily infeasible. +% We use reconsider/1 to fix this. +% +% s(S) e [_,0] = d +xi ... -xj, Rhs > 0 so we want to decrease s(S) +% +% positive xi would have to be moved towards their lower bound, +% negative xj would have to be moved towards their upper bound, +% +% the row s(S) does not limit the lower bound of xi +% the row s(S) does not limit the upper bound of xj +% +% a) if some other row R is limiting xk, we pivot(R,xk), +% s(S) will decrease and get more feasible until (b) +% b) if there is no limiting row for some xi: we pivot(s(S),xi) +% xj: we pivot(s(S),xj) +% which cures the infeasibility in one step +% + + +% iterate_dec(OptVar,Opt) +% +% Decreases the bound on the variables of the linear equation of OptVar as much +% as possible and returns the resulting optimal bound in Opt. Fails if for some +% variable, a status of unlimited is found. + +iterate_dec(OptVar,Opt) :- + get_attr(OptVar,itf,Att), + arg(4,Att,lin([I,R|H])), + dec_step(H,Status), + ( Status = applied + -> iterate_dec(OptVar,Opt) + ; Status = optimum, + Opt is R + I + ). + +% iterate_inc(OptVar,Opt) +% +% Increases the bound on the variables of the linear equation of OptVar as much +% as possible and returns the resulting optimal bound in Opt. Fails if for some +% variable, a status of unlimited is found. + +iterate_inc(OptVar,Opt) :- + get_attr(OptVar,itf,Att), + arg(4,Att,lin([I,R|H])), + inc_step(H,Status), + ( Status = applied + -> iterate_inc(OptVar,Opt) + ; Status = optimum, + Opt is R + I + ). + +% +% Status = {optimum,unlimited(Indep,DepT),applied} +% If Status = optimum, the tables have not been changed at all. +% Searches left to right, does not try to find the 'best' pivot +% Therefore we might discover unboundedness only after a few pivots +% + +dec_step_cont([],optimum,Cont,Cont). +dec_step_cont([l(V*K,OrdV)|Vs],Status,ContIn,ContOut) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( dec_step_2_cont(W,l(V*K,OrdV),Class,Status,ContIn,ContOut) + -> true + ; dec_step_cont(Vs,Status,ContIn,ContOut) + ). + +inc_step_cont([],optimum,Cont,Cont). +inc_step_cont([l(V*K,OrdV)|Vs],Status,ContIn,ContOut) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( inc_step_2_cont(W,l(V*K,OrdV),Class,Status,ContIn,ContOut) + -> true + ; inc_step_cont(Vs,Status,ContIn,ContOut) + ). + +dec_step_2_cont(t_U(U),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K > 1.0e-10, + ( lb(Class,OrdV,Vub-Vb-_) + -> % found a lower bound + Status = applied, + pivot_a(Vub,V,Vb,t_u(U)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_u(U)), + ContIn = ContOut + ). +dec_step_2_cont(t_lU(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K > 1.0e-10, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +dec_step_2_cont(t_L(L),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K < -1.0e-10, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_l(L)), + ContIn = ContOut + ). +dec_step_2_cont(t_Lu(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K < -1.0e-10, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +dec_step_2_cont(t_none,l(V*_,_),_,unlimited(V,t_none),Cont,Cont). + + + +inc_step_2_cont(t_U(U),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K < -1.0e-10, + ( lb(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_u(U)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_u(U)), + ContIn = ContOut + ). +inc_step_2_cont(t_lU(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K < -1.0e-10, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +inc_step_2_cont(t_L(L),l(V*K,OrdV),Class,Status,ContIn,ContOut) :- + K > 1.0e-10, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)), + replace_in_cont(ContIn,Vub,V,ContOut) + ; Status = unlimited(V,t_l(L)), + ContIn = ContOut + ). +inc_step_2_cont(t_Lu(L,U),l(V*K,OrdV),Class,applied,ContIn,ContOut) :- + K > 1.0e-10, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)), + replace_in_cont(ContIn,Vub,V,ContOut). +inc_step_2_cont(t_none,l(V*_,_),_,unlimited(V,t_none),Cont,Cont). + +replace_in_cont([],_,_,[]). +replace_in_cont([H1|T1],X,Y,[H2|T2]) :- + ( H1 == X + -> H2 = Y, + T1 = T2 + ; H2 = H1, + replace_in_cont(T1,X,Y,T2) + ). + +dec_step([],optimum). +dec_step([l(V*K,OrdV)|Vs],Status) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( dec_step_2(W,l(V*K,OrdV),Class,Status) + -> true + ; dec_step(Vs,Status) + ). + +dec_step_2(t_U(U),l(V*K,OrdV),Class,Status) :- + K > 1.0e-10, + ( lb(Class,OrdV,Vub-Vb-_) + -> % found a lower bound + Status = applied, + pivot_a(Vub,V,Vb,t_u(U)) + ; Status = unlimited(V,t_u(U)) + ). +dec_step_2(t_lU(L,U),l(V*K,OrdV),Class,applied) :- + K > 1.0e-10, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +dec_step_2(t_L(L),l(V*K,OrdV),Class,Status) :- + K < -1.0e-10, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)) + ; Status = unlimited(V,t_l(L)) + ). +dec_step_2(t_Lu(L,U),l(V*K,OrdV),Class,applied) :- + K < -1.0e-10, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +dec_step_2(t_none,l(V*_,_),_,unlimited(V,t_none)). + +inc_step([],optimum). % if status has not been set yet: no changes +inc_step([l(V*K,OrdV)|Vs],Status) :- + get_attr(V,itf,Att), + arg(2,Att,type(W)), + arg(6,Att,class(Class)), + ( inc_step_2(W,l(V*K,OrdV),Class,Status) + -> true + ; inc_step(Vs,Status) + ). + +inc_step_2(t_U(U),l(V*K,OrdV),Class,Status) :- + K < -1.0e-10, + ( lb(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_u(U)) + ; Status = unlimited(V,t_u(U)) + ). +inc_step_2(t_lU(L,U),l(V*K,OrdV),Class,applied) :- + K < -1.0e-10, + Init is L - U, + class_basis(Class,Deps), + lb(Deps,OrdV,V-t_Lu(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +inc_step_2(t_L(L),l(V*K,OrdV),Class,Status) :- + K > 1.0e-10, + ( ub(Class,OrdV,Vub-Vb-_) + -> Status = applied, + pivot_a(Vub,V,Vb,t_l(L)) + ; Status = unlimited(V,t_l(L)) + ). +inc_step_2(t_Lu(L,U),l(V*K,OrdV),Class,applied) :- + K > 1.0e-10, + Init is U - L, + class_basis(Class,Deps), + ub(Deps,OrdV,V-t_lU(L,U)-Init,Vub-Vb-_), + pivot_b(Vub,V,Vb,t_lu(L,U)). +inc_step_2(t_none,l(V*_,_),_,unlimited(V,t_none)). + +% ------------------------- find the most constraining row -------------------- +% +% The code for the lower and the upper bound are dual versions of each other. +% The only difference is in the orientation of the comparisons. +% Indeps are ruled out by their types. +% If there is no bound, this fails. +% +% *** The actual lb and ub on an indep variable X are [lu]b + b(X), where b(X) +% is the value of the active bound. +% +% Nota bene: We must NOT consider infeasible rows as candidates to +% leave the basis! +% +% ub(Class,OrdX,Ub) +% +% See lb/3: this is similar + +ub(Class,OrdX,Ub) :- + class_basis(Class,Deps), + ub_first(Deps,OrdX,Ub). + +% ub_first(Deps,X,Dep-W-Ub) +% +% Finds the tightest upperbound for variable X from the linear equations of +% basis variables Deps, and puts the resulting bound in Ub. Dep is the basis +% variable that generates the bound, and W is bound of that variable that has +% to be activated to achieve this. + +ub_first([Dep|Deps],OrdX,Tightest) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + ub_inner(Type,OrdX,Lin,W,Ub), + Ub > -1.0e-10 % Ub >= 0 + -> ub(Deps,OrdX,Dep-W-Ub,Tightest) + ; ub_first(Deps,OrdX,Tightest) + ). + +% ub(Deps,OrdX,TightestIn,TightestOut) +% +% See lb/4: this is similar + +ub([],_,T0,T0). +ub([Dep|Deps],OrdX,T0,T1) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + ub_inner(Type,OrdX,Lin,W,Ub), + T0 = _-Ubb, + % Ub < Ubb: tighter upper bound is a smaller one + Ub - Ubb < -1.0e-10, + % Ub >= 0: upperbound should be larger than 0; rare failure + Ub > -1.0e-10 + -> ub(Deps,OrdX,Dep-W-Ub,T1) % tighter bound, use new bound + ; ub(Deps,OrdX,T0,T1) % no tighter bound, keep current one + ). + +% ub_inner(Type,OrdX,Lin,W,Ub) +% +% See lb_inner/5: this is similar + +ub_inner(t_l(L),OrdX,Lin,t_L(L),Ub) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + % Rhs is right hand side of lin. eq. Lin containing term X*K + K < -1.0e-10, % K < 0 + Ub is (L-Rhs)/K. +ub_inner(t_u(U),OrdX,Lin,t_U(U),Ub) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + K > 1.0e-10, % K > 0 + Ub is (U-Rhs)/K. +ub_inner(t_lu(L,U),OrdX,Lin,W,Ub) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + ( K < -1.0e-10 % K < 0, use lowerbound + -> W = t_Lu(L,U), + Ub = (L-Rhs)/K + ; K > 1.0e-10 % K > 0, use upperbound + -> W = t_lU(L,U), + Ub = (U-Rhs)/K + ). + +% lb(Class,OrdX,Lb) +% +% Returns in Lb how much we can lower the upperbound of X without violating +% a bound of the basisvariables. +% Lb has the form Dep-W-Lb with Dep the variable whose bound is violated when +% lowering the bound for X more, W the actual bound that has to be activated +% and Lb the amount that the upperbound can be lowered. +% X has ordering OrdX and class Class. + +lb(Class,OrdX,Lb) :- + class_basis(Class,Deps), + lb_first(Deps,OrdX,Lb). + +% lb_first(Deps,OrdX,Tightest) +% +% Returns in Tightest how much we can lower the upperbound of X without +% violating a bound of Deps. +% Tightest has the form Dep-W-Lb with Dep the variable whose bound is violated +% when lowering the bound for X more, W the actual bound that has to be +% activated and Lb the amount that the upperbound can be lowered. X has +% ordering attribute OrdX. + +lb_first([Dep|Deps],OrdX,Tightest) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + lb_inner(Type,OrdX,Lin,W,Lb), + Lb < 1.0e-10 % Lb =< 0: Lb > 0 means a violated bound + -> lb(Deps,OrdX,Dep-W-Lb,Tightest) + ; lb_first(Deps,OrdX,Tightest) + ). + +% lb(Deps,OrdX,TightestIn,TightestOut) +% +% See lb_first/3: this one does the same thing, but is used for the steps after +% the first one and remembers the tightest bound so far. + +lb([],_,T0,T0). +lb([Dep|Deps],OrdX,T0,T1) :- + ( get_attr(Dep,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + lb_inner(Type,OrdX,Lin,W,Lb), + T0 = _-Lbb, + Lb - Lbb > 1.0e-10, % Lb > Lbb: choose the least lowering, others + % might violate bounds + Lb < 1.0e-10 % Lb =< 0: violation of a bound (without lowering) + -> lb(Deps,OrdX,Dep-W-Lb,T1) + ; lb(Deps,OrdX,T0,T1) + ). + +% lb_inner(Type,X,Lin,W,Lb) +% +% Returns in Lb how much lower we can make X without violating a bound +% by using the linear equation Lin of basis variable B which has type +% Type and which has to activate a bound (type W) to do so. +% +% E.g. when B has a lowerbound L, then L should always be smaller than I + R. +% So a lowerbound of X (which has scalar K in Lin), could be at most +% (L-(I+R))/K lower than its upperbound (if K is positive). +% Also note that Lb should always be smaller than 0, otherwise the row is +% not feasible. +% X has ordering attribute OrdX. + +lb_inner(t_l(L),OrdX,Lin,t_L(L),Lb) :- + nf_rhs_x(Lin,OrdX,Rhs,K), % if linear equation Lin contains the term + % X*K, Rhs is the right hand side of that + % equation + K > 1.0e-10, % K > 0 + Lb is (L-Rhs)/K. +lb_inner(t_u(U),OrdX,Lin,t_U(U),Lb) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + K < -1.0e-10, % K < 0 + Lb is (U-Rhs)/K. +lb_inner(t_lu(L,U),OrdX,Lin,W,Lb) :- + nf_rhs_x(Lin,OrdX,Rhs,K), + ( K < -1.0e-10 + -> W = t_lU(L,U), + Lb is (U-Rhs)/K + ; K > 1.0e-10 + -> W = t_Lu(L,U), + Lb is (L-Rhs)/K + ). + +% ---------------------------------- equations -------------------------------- +% +% backsubstitution will not make the system infeasible, if the bounds on the +% indep vars are obeyed, but some implied values might pop up in rows where X +% occurs +% -) special case X=Y during bs -> get rid of dependend var(s), alias +% + +solve(Lin) :- + Lin = [I,_|H], + solve(H,Lin,I,Bindings,[]), + export_binding(Bindings). + +% solve(Hom,Lin,I,Bind,BindT) +% +% Solves a linear equation Lin = [I,_|H] = 0 and exports the generated bindings + +solve([],_,I,Bind0,Bind0) :- + !, + I >= -1.0e-10, % I =:= 0: redundant or trivially unsat + I =< 1.0e-10. +solve(H,Lin,_,Bind0,BindT) :- + sd(H,[],ClassesUniq,9-9-0,Category-Selected-_,NV,NVT), + get_attr(Selected,itf,Att), + arg(5,Att,order(Ord)), + isolate(Ord,Lin,Lin1), % Lin = 0 => Selected = Lin1 + ( Category = 1 % classless variable, no bounds + -> setarg(4,Att,lin(Lin1)), + Lin1 = [Inhom,_|Hom], + bs_collect_binding(Hom,Selected,Inhom,Bind0,BindT), + eq_classes(NV,NVT,ClassesUniq) + ; Category = 2 % class variable, no bounds + -> arg(6,Att,class(NewC)), + class_allvars(NewC,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,Ord,Lin1,Bind0,BindT) + ; Bind0 = BindT, + bs(Deps,Ord,Lin1) + ), + eq_classes(NV,NVT,ClassesUniq) + ; Category = 3 % classless variable, all variables in Lin and + % Selected are bounded + -> arg(2,Att,type(Type)), + setarg(4,Att,lin(Lin1)), + deactivate_bound(Type,Selected), + eq_classes(NV,NVT,ClassesUniq), + basis_add(Selected,Basis), + undet_active(Lin1), % we can't tell which bound will likely be a + % problem at this point + Lin1 = [Inhom,_|Hom], + bs_collect_binding(Hom,Selected,Inhom,Bind0,Bind1), % only if + % Hom = [] + rcbl(Basis,Bind1,BindT) % reconsider entire basis + ; Category = 4 % class variable, all variables in Lin and Selected + % are bounded + -> arg(2,Att,type(Type)), + arg(6,Att,class(NewC)), + class_allvars(NewC,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,Ord,Lin1,Bind0,Bind1) + ; Bind0 = Bind1, + bs(Deps,Ord,Lin1) + ), + deactivate_bound(Type,Selected), + basis_add(Selected,Basis), + % eq_classes( NV, NVT, ClassesUniq), + % 4 -> var(NV) + equate(ClassesUniq,_), + undet_active(Lin1), + rcbl(Basis,Bind1,BindT) + ). + +% +% Much like solve, but we solve for a particular variable of type t_none +% + +% solve_x(H,Lin,I,X,[Bind|BindT],BindT) +% +% + +solve_x(Lin,X) :- + Lin = [I,_|H], + solve_x(H,Lin,I,X,Bindings,[]), + export_binding(Bindings). + +solve_x([],_,I,_,Bind0,Bind0) :- + !, + I >= -1.0e-10, % I =:= 0: redundant or trivially unsat + I =< 1.0e-10. + +solve_x(H,Lin,_,X,Bind0,BindT) :- + sd(H,[],ClassesUniq,9-9-0,_,NV,NVT), + get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + isolate(OrdX,Lin,Lin1), + ( arg(6,Att,class(NewC)) + -> class_allvars(NewC,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,OrdX,Lin1,Bind0,BindT) + ; Bind0 = BindT, + bs(Deps,OrdX,Lin1) + ), + eq_classes(NV,NVT,ClassesUniq) + ; setarg(4,Att,lin(Lin1)), + Lin1 = [Inhom,_|Hom], + bs_collect_binding(Hom,X,Inhom,Bind0,BindT), + eq_classes(NV,NVT,ClassesUniq) + ). + +% solve_ord_x(Lin,OrdX,ClassX) +% +% Does the same thing as solve_x/2, but has the ordering of X and its class as +% input. This also means that X has a class which is not sure in solve_x/2. + +solve_ord_x(Lin,OrdX,ClassX) :- + Lin = [I,_|H], + solve_ord_x(H,Lin,I,OrdX,ClassX,Bindings,[]), + export_binding(Bindings). + +solve_ord_x([],_,I,_,_,Bind0,Bind0) :- + I >= -1.0e-10, % I =:= 0 + I =< 1.0e-10. +solve_ord_x([_|_],Lin,_,OrdX,ClassX,Bind0,BindT) :- + isolate(OrdX,Lin,Lin1), + Lin1 = [_,_|H1], + sd(H1,[],ClassesUniq1,9-9-0,_,NV,NVT), % do sd on Lin without X, then + % add class of X + ord_add_element(ClassesUniq1,ClassX,ClassesUniq), + class_allvars(ClassX,Deps), + ( ClassesUniq = [_] % rank increasing + -> bs_collect_bindings(Deps,OrdX,Lin1,Bind0,BindT) + ; Bind0 = BindT, + bs(Deps,OrdX,Lin1) + ), + eq_classes(NV,NVT,ClassesUniq). + +% sd(H,[],ClassesUniq,9-9-0,Category-Selected-_,NV,NVT) + +% sd(Hom,ClassesIn,ClassesOut,PreferenceIn,PreferenceOut,[NV|NVTail],NVTail) +% +% ClassesOut is a sorted list of the different classes that are either in +% ClassesIn or that are the classes of the variables in Hom. Variables that do +% not belong to a class yet, are put in the difference list NV. + +sd([],Class0,Class0,Preference0,Preference0,NV0,NV0). +sd([l(X*K,_)|Xs],Class0,ClassN,Preference0,PreferenceN,NV0,NVt) :- + get_attr(X,itf,Att), + ( arg(6,Att,class(Xc)) % old: has class + -> NV0 = NV1, + ord_add_element(Class0,Xc,Class1), + ( arg(2,Att,type(t_none)) + -> preference(Preference0,2-X-K,Preference1) + % has class, no bounds => category 2 + ; preference(Preference0,4-X-K,Preference1) + % has class, is bounded => category 4 + ) + ; % new: has no class + Class1 = Class0, + NV0 = [X|NV1], % X has no class yet, add to list of new variables + ( arg(2,Att,type(t_none)) + -> preference(Preference0,1-X-K,Preference1) + % no class, no bounds => category 1 + ; preference(Preference0,3-X-K,Preference1) + % no class, is bounded => category 3 + ) + ), + sd(Xs,Class1,ClassN,Preference1,PreferenceN,NV1,NVt). + +% +% A is best sofar, B is current +% smallest prefered +preference(A,B,Pref) :- + A = Px-_-_, + B = Py-_-_, + ( Px < Py + -> Pref = A + ; Pref = B + ). + +% eq_classes(NV,NVTail,Cs) +% +% Attaches all classless variables NV to a new class and equates all other +% classes with this class. The equate operation only happens after attach_class +% because the unification of classes can bind the tail of the AllVars attribute +% to a nonvar and then the attach_class operation wouldn't work. + +eq_classes(NV,_,Cs) :- + var(NV), + !, + equate(Cs,_). +eq_classes(NV,NVT,Cs) :- + class_new(Su,clpr,NV,NVT,[]), % make a new class Su with NV as the variables + attach_class(NV,Su), % attach the variables NV to Su + equate(Cs,Su). + +equate([],_). +equate([X|Xs],X) :- equate(Xs,X). + +% +% assert: none of the Vars has a class attribute yet +% +attach_class(Xs,_) :- + var(Xs), % Tail + !. +attach_class([X|Xs],Class) :- + get_attr(X,itf,Att), + setarg(6,Att,class(Class)), + attach_class(Xs,Class). + +% unconstrained(Lin,Uc,Kuc,Rest) +% +% Finds an unconstrained variable Uc (type(t_none)) in Lin with scalar Kuc and +% removes it from Lin to return Rest. + +unconstrained(Lin,Uc,Kuc,Rest) :- + Lin = [_,_|H], + sd(H,[],_,9-9-0,Category-Uc-_,_,_), + Category =< 2, + get_attr(Uc,itf,Att), + arg(5,Att,order(OrdUc)), + delete_factor(OrdUc,Lin,Rest,Kuc). + +% +% point the vars in Lin into the same equivalence class +% maybe join some global data +% +same_class([],_). +same_class([l(X*_,_)|Xs],Class) :- + get_or_add_class(X,Class), + same_class(Xs,Class). + +% get_or_add_class(X,Class) +% +% Returns in Class the class of X if X has one, or a new class where X now +% belongs to if X didn't have one. + +get_or_add_class(X,Class) :- + get_attr(X,itf,Att), + arg(1,Att,CLP), + ( arg(6,Att,class(ClassX)) + -> ClassX = Class + ; setarg(6,Att,class(Class)), + class_new(Class,CLP,[X|Tail],Tail,[]) + ). + +% allvars(X,Allvars) +% +% Allvars is a list of all variables in the class to which X belongs. + +allvars(X,Allvars) :- + get_attr(X,itf,Att), + arg(6,Att,class(C)), + class_allvars(C,Allvars). + +% deactivate_bound(Type,Variable) +% +% The Type of the variable is changed to reflect the deactivation of its +% bounds. +% t_L(_) becomes t_l(_), t_lU(_,_) becomes t_lu(_,_) and so on. + +deactivate_bound(t_l(_),_). +deactivate_bound(t_u(_),_). +deactivate_bound(t_lu(_,_),_). +deactivate_bound(t_L(L),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(L))). +deactivate_bound(t_Lu(L,U),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). +deactivate_bound(t_U(U),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(U))). +deactivate_bound(t_lU(L,U),X) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). + +% intro_at(X,Value,Type) +% +% Variable X gets new type Type which reflects the activation of a bound with +% value Value. In the linear equations of all the variables belonging to the +% same class as X, X is substituted by [0,Value,X] to reflect the new active +% bound. + +intro_at(X,Value,Type) :- + get_attr(X,itf,Att), + arg(5,Att,order(Ord)), + arg(6,Att,class(Class)), + setarg(2,Att,type(Type)), + ( Value >= -1.0e-10, % Value =:= 0 + Value =< 1.0e-010 + -> true + ; backsubst_delta(Class,Ord,X,Value) + ). + +% undet_active(Lin) +% +% For each variable in the homogene part of Lin, a bound is activated +% if an inactive bound exists. (t_l(L) becomes t_L(L) and so on) + +undet_active([_,_|H]) :- + undet_active_h(H). + +% undet_active_h(Hom) +% +% For each variable in homogene part Hom, a bound is activated if an +% inactive bound exists (t_l(L) becomes t_L(L) and so on) + +undet_active_h([]). +undet_active_h([l(X*_,_)|Xs]) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + undet_active(Type,X), + undet_active_h(Xs). + +% undet_active(Type,Var) +% +% An inactive bound of Var is activated if such exists +% t_lu(L,U) is arbitrarily chosen to become t_Lu(L,U) + +undet_active(t_none,_). % type_activity +undet_active(t_L(_),_). +undet_active(t_Lu(_,_),_). +undet_active(t_U(_),_). +undet_active(t_lU(_,_),_). +undet_active(t_l(L),X) :- intro_at(X,L,t_L(L)). +undet_active(t_u(U),X) :- intro_at(X,U,t_U(U)). +undet_active(t_lu(L,U),X) :- intro_at(X,L,t_Lu(L,U)). + +% determine_active_dec(Lin) +% +% Activates inactive bounds on the variables of Lin if such bounds exist. +% If the type of a variable is t_none, this fails. This version is aimed +% to make the R component of Lin as small as possible in order not to violate +% an upperbound (see reconsider/1) + +determine_active_dec([_,_|H]) :- + determine_active(H,-1). + +% determine_active_inc(Lin) +% +% Activates inactive bounds on the variables of Lin if such bounds exist. +% If the type of a variable is t_none, this fails. This version is aimed +% to make the R component of Lin as large as possible in order not to violate +% a lowerbound (see reconsider/1) + +determine_active_inc([_,_|H]) :- + determine_active(H,1). + +% determine_active(Hom,S) +% +% For each variable in Hom, activates its bound if it is not yet activated. +% For the case of t_lu(_,_) the lower or upper bound is activated depending on +% K and S: +% If sign of K*S is negative, then lowerbound, otherwise upperbound. + +determine_active([],_). +determine_active([l(X*K,_)|Xs],S) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + determine_active(Type,X,K,S), + determine_active(Xs,S). + +determine_active(t_L(_),_,_,_). +determine_active(t_Lu(_,_),_,_,_). +determine_active(t_U(_),_,_,_). +determine_active(t_lU(_,_),_,_,_). +determine_active(t_l(L),X,_,_) :- intro_at(X,L,t_L(L)). +determine_active(t_u(U),X,_,_) :- intro_at(X,U,t_U(U)). +determine_active(t_lu(L,U),X,K,S) :- + TestKs is K*S, + ( TestKs < -1.0e-10 % K*S < 0 + -> intro_at(X,L,t_Lu(L,U)) + ; TestKs > 1.0e-10 + -> intro_at(X,U,t_lU(L,U)) + ). + +% +% Careful when an indep turns into t_none !!! +% + +detach_bounds(V) :- + get_attr(V,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + arg(5,Att,order(OrdV)), + arg(6,Att,class(Class)), + setarg(2,Att,type(t_none)), + setarg(3,Att,strictness(0)), + ( indep(Lin,OrdV) + -> ( ub(Class,OrdV,Vub-Vb-_) + -> % exchange against thightest + class_basis_drop(Class,Vub), + pivot(Vub,Class,OrdV,Vb,Type) + ; lb(Class,OrdV,Vlb-Vb-_) + -> class_basis_drop(Class,Vlb), + pivot(Vlb,Class,OrdV,Vb,Type) + ; true + ) + ; class_basis_drop(Class,V) + ). + +detach_bounds_vlv(OrdV,Lin,Class,Var,NewLin) :- + ( indep(Lin,OrdV) + -> Lin = [_,R|_], + ( ub(Class,OrdV,Vub-Vb-_) + -> % in verify_lin, class might contain two occurrences of Var, + % but it doesn't matter which one we delete + class_basis_drop(Class,Var), + pivot_vlv(Vub,Class,OrdV,Vb,R,NewLin) + ; lb(Class,OrdV,Vlb-Vb-_) + -> class_basis_drop(Class,Var), + pivot_vlv(Vlb,Class,OrdV,Vb,R,NewLin) + ; NewLin = Lin + ) + ; NewLin = Lin, + class_basis_drop(Class,Var) + ). + +% ----------------------------- manipulate the basis -------------------------- + +% basis_drop(X) +% +% Removes X from the basis of the class to which X belongs. + +basis_drop(X) :- + get_attr(X,itf,Att), + arg(6,Att,class(Cv)), + class_basis_drop(Cv,X). + +% basis(X,Basis) +% +% Basis is the basis of the class to which X belongs. + +basis(X,Basis) :- + get_attr(X,itf,Att), + arg(6,Att,class(Cv)), + class_basis(Cv,Basis). + +% basis_add(X,NewBasis) +% +% NewBasis is the result of adding X to the basis of the class to which X +% belongs. + +basis_add(X,NewBasis) :- + get_attr(X,itf,Att), + arg(6,Att,class(Cv)), + class_basis_add(Cv,X,NewBasis). + +% basis_pivot(Leave,Enter) +% +% Removes Leave from the basis of the class to which it belongs, and adds +% Enter to that basis. + +basis_pivot(Leave,Enter) :- + get_attr(Leave,itf,Att), + arg(6,Att,class(Cv)), + class_basis_pivot(Cv,Enter,Leave). + +% ----------------------------------- pivot ----------------------------------- + +% pivot(Dep,Indep) +% +% The linear equation of variable Dep, is transformed into one of variable +% Indep, containing Dep. Then, all occurrences of Indep in linear equations are +% substituted by this new definition + +% +% Pivot ignoring rhs and active states +% + +pivot(Dep,Indep) :- + get_attr(Dep,itf,AttD), + arg(4,AttD,lin(H)), + arg(5,AttD,order(OrdDep)), + get_attr(Indep,itf,AttI), + arg(5,AttI,order(Ord)), + arg(5,AttI,class(Class)), + delete_factor(Ord,H,H0,Coeff), + K is -1.0/Coeff, + add_linear_ff(H0,K,[0.0,0.0,l(Dep* -1.0,OrdDep)],K,Lin), + backsubst(Class,Ord,Lin). + +% pivot_a(Dep,Indep,IndepT,DepT) +% +% Removes Dep from the basis, puts Indep in, and pivots the equation of +% Dep to become one of Indep. The type of Dep becomes DepT (which means +% it gets deactivated), the type of Indep becomes IndepT (which means it +% gets activated) + + +pivot_a(Dep,Indep,Vb,Wd) :- + basis_pivot(Dep,Indep), + get_attr(Indep,itf,Att), + arg(2,Att,type(Type)), + arg(5,Att,order(Ord)), + arg(6,Att,class(Class)), + pivot(Dep,Class,Ord,Vb,Type), + get_attr(Indep,itf,Att2), %changed? + setarg(2,Att2,type(Wd)). + +pivot_b(Vub,V,Vb,Wd) :- + ( Vub == V + -> get_attr(V,itf,Att), + arg(5,Att,order(Ord)), + arg(6,Att,class(Class)), + setarg(2,Att,type(Vb)), + pivot_b_delta(Vb,Delta), % nonzero(Delta) + backsubst_delta(Class,Ord,V,Delta) + ; pivot_a(Vub,V,Vb,Wd) + ). + +pivot_b_delta(t_Lu(L,U),Delta) :- Delta is L-U. +pivot_b_delta(t_lU(L,U),Delta) :- Delta is U-L. + +% select_active_bound(Type,Bound) +% +% Returns the bound that is active in Type (if such exists, 0 otherwise) + +select_active_bound(t_L(L),L). +select_active_bound(t_Lu(L,_),L). +select_active_bound(t_U(U),U). +select_active_bound(t_lU(_,U),U). +select_active_bound(t_none,0.0). +% +% for project.pl +% +select_active_bound(t_l(_),0.0). +select_active_bound(t_u(_),0.0). +select_active_bound(t_lu(_,_),0.0). + + +% pivot(Dep,Class,IndepOrd,DepAct,IndAct) +% +% See pivot/2. +% In addition, variable Indep with ordering IndepOrd has an active bound IndAct + +% +% +% Pivot taking care of rhs and active states +% +pivot(Dep,Class,IndepOrd,DepAct,IndAct) :- + get_attr(Dep,itf,Att), + arg(4,Att,lin(H)), + arg(5,Att,order(DepOrd)), + setarg(2,Att,type(DepAct)), + select_active_bound(DepAct,AbvD), % New current value for Dep + select_active_bound(IndAct,AbvI), % New current value of Indep + delete_factor(IndepOrd,H,H0,Coeff), % Dep = ... + Coeff*Indep + ... + AbvDm is -AbvD, + AbvIm is -AbvI, + add_linear_f1([0.0,AbvIm],Coeff,H0,H1), + K is -1.0/Coeff, + add_linear_ff(H1,K,[0.0,AbvDm,l(Dep* -1.0,DepOrd)],K,H2), + % Indep = -1/Coeff*... + 1/Coeff*Dep + add_linear_11(H2,[0.0,AbvIm],Lin), + backsubst(Class,IndepOrd,Lin). + +pivot_vlv(Dep,Class,IndepOrd,DepAct,AbvI,Lin) :- + get_attr(Dep,itf,Att), + arg(4,Att,lin(H)), + arg(5,Att,order(DepOrd)), + setarg(2,Att,type(DepAct)), + select_active_bound(DepAct,AbvD), % New current value for Dep + delete_factor(IndepOrd,H,H0,Coeff), % Dep = ... + Coeff*Indep + ... + AbvDm is -AbvD, + AbvIm is -AbvI, + add_linear_f1([0.0,AbvIm],Coeff,H0,H1), + K is -1.0/Coeff, + add_linear_ff(H1,K,[0.0,AbvDm,l(Dep* -1.0,DepOrd)],K,Lin), + % Indep = -1/Coeff*... + 1/Coeff*Dep + add_linear_11(Lin,[0.0,AbvIm],SubstLin), + backsubst(Class,IndepOrd,SubstLin). + +% backsubst_delta(Class,OrdX,X,Delta) +% +% X with ordering attribute OrdX, is substituted in all linear equations of +% variables in the class Class, by linear equation [0,Delta,l(X*1,OrdX)]. This +% reflects the activation of a bound. + +backsubst_delta(Class,OrdX,X,Delta) :- + backsubst(Class,OrdX,[0.0,Delta,l(X*1.0,OrdX)]). + +% backsubst(Class,OrdX,Lin) +% +% X with ordering OrdX is substituted in all linear equations of variables in +% the class Class, by linear equation Lin + +backsubst(Class,OrdX,Lin) :- + class_allvars(Class,Allvars), + bs(Allvars,OrdX,Lin). + +% bs(Vars,OrdV,Lin) +% +% In all linear equations of the variables Vars, variable V with ordering +% attribute OrdV is substituted by linear equation Lin. +% +% valid if nothing will go ground +% + +bs(Xs,_,_) :- + var(Xs), + !. +bs([X|Xs],OrdV,Lin) :- + ( get_attr(X,itf,Att), + arg(4,Att,lin(LinX)), + nf_substitute(OrdV,Lin,LinX,LinX1) % does not change attributes + -> setarg(4,Att,lin(LinX1)), + bs(Xs,OrdV,Lin) + ; bs(Xs,OrdV,Lin) + ). + +% +% rank increasing backsubstitution +% + +% bs_collect_bindings(Deps,SelectedOrd,Lin,Bind,BindT) +% +% Collects bindings (of the form [X-I] where X = I is the binding) by +% substituting Selected in all linear equations of the variables Deps (which +% are of the same class), by Lin. Selected has ordering attribute SelectedOrd. +% +% E.g. when V = 2X + 3Y + 4, X = 3V + 2Z and Y = 4X + 3 +% we can substitute V in the linear equation of X: X = 6X + 9Y + 2Z + 12 +% we can't substitute V in the linear equation of Y of course. + +bs_collect_bindings(Xs,_,_,Bind0,BindT) :- + var(Xs), + !, + Bind0 = BindT. +bs_collect_bindings([X|Xs],OrdV,Lin,Bind0,BindT) :- + ( get_attr(X,itf,Att), + arg(4,Att,lin(LinX)), + nf_substitute(OrdV,Lin,LinX,LinX1) % does not change attributes + -> setarg(4,Att,lin(LinX1)), + LinX1 = [Inhom,_|Hom], + bs_collect_binding(Hom,X,Inhom,Bind0,Bind1), + bs_collect_bindings(Xs,OrdV,Lin,Bind1,BindT) + ; bs_collect_bindings(Xs,OrdV,Lin,Bind0,BindT) + ). + +% bs_collect_binding(Hom,Selected,Inhom,Bind,BindT) +% +% Collects binding following from Selected = Hom + Inhom. +% If Hom = [], returns the binding Selected-Inhom (=0) +% +bs_collect_binding([],X,Inhom) --> [X-Inhom]. +bs_collect_binding([_|_],_,_) --> []. + +% +% reconsider the basis +% + +% rcbl(Basis,Bind,BindT) +% +% + +rcbl([],Bind0,Bind0). +rcbl([X|Continuation],Bind0,BindT) :- + ( rcb_cont(X,Status,Violated,Continuation,NewContinuation) % have a culprit + -> rcbl_status(Status,X,NewContinuation,Bind0,BindT,Violated) + ; rcbl(Continuation,Bind0,BindT) + ). + +rcb_cont(X,Status,Violated,ContIn,ContOut) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin([I,R|H])), + ( Type = t_l(L) % case 1: lowerbound: R + I should always be larger + % than the lowerbound + -> R + I - L < 1.0e-10, + Violated = l(L), + inc_step_cont(H,Status,ContIn,ContOut) + ; Type = t_u(U) % case 2: upperbound: R + I should always be smaller + % than the upperbound + -> R + I - U > -1.0e-10, + Violated = u(U), + dec_step_cont(H,Status,ContIn,ContOut) + ; Type = t_lu(L,U) % case 3: check both + -> At is R + I, + ( At - L < 1.0e-10 + -> Violated = l(L), + inc_step_cont(H,Status,ContIn,ContOut) + ; At - U > -1.0e-10 + -> Violated = u(U), + dec_step_cont(H,Status,ContIn,ContOut) + ) + ). % other types imply nonbasic variable or unbounded variable + + + +% +% reconsider one element of the basis +% later: lift the binds +% +reconsider(X) :- + rcb(X,Status,Violated), + !, + rcbl_status(Status,X,[],Binds,[],Violated), + export_binding(Binds). +reconsider(_). + +% +% Find a basis variable out of its bound or at its bound +% Try to move it into whithin its bound +% a) impossible -> fail +% b) optimum at the bound -> implied value +% c) else look at the remaining basis variables +% +% +% Idea: consider a variable V with linear equation Lin. +% When a bound on a variable X of Lin gets activated, its value, multiplied +% with the scalar of X, is added to the R component of Lin. +% When we consider the lowerbound of V, it must be smaller than R + I, since R +% contains at best the lowerbounds of the variables in Lin (but could contain +% upperbounds, which are of course larger). So checking this can show the +% violation of a bound of V. A similar case works for the upperbound. + +rcb(X,Status,Violated) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin([I,R|H])), + ( Type = t_l(L) % case 1: lowerbound: R + I should always be larger + % than the lowerbound + -> R + I - L < 1.0e-10, % R + I =< L + Violated = l(L), + inc_step(H,Status) + ; Type = t_u(U) % case 2: upperbound: R + I should always be smaller + % than the upperbound + -> R + I - U > -1.0e-10, % R + I >= U + Violated = u(U), + dec_step(H,Status) + ; Type = t_lu(L,U) % case 3: check both + -> At is R + I, + ( At - L < 1.0e-10 % At =< L + -> Violated = l(L), + inc_step(H,Status) + ; At - U > -1.0e-10 % At >= U + -> Violated = u(U), + dec_step(H,Status) + ) + ). % other types imply nonbasic variable or unbounded variable + +% rcbl_status(Status,X,Continuation,[Bind|BindT],BindT,Violated) +% +% + +rcbl_status(optimum,X,Cont,B0,Bt,Violated) :- rcbl_opt(Violated,X,Cont,B0,Bt). +rcbl_status(applied,X,Cont,B0,Bt,Violated) :- rcbl_app(Violated,X,Cont,B0,Bt). +rcbl_status(unlimited(Indep,DepT),X,Cont,B0,Bt,Violated) :- + rcbl_unl(Violated,X,Cont,B0,Bt,Indep,DepT). + +% +% Might reach optimum immediately without changing the basis, +% but in general we must assume that there were pivots. +% If the optimum meets the bound, we backsubstitute the implied +% value, solve will call us again to check for further implied +% values or unsatisfiability in the rank increased system. +% +rcbl_opt(l(L),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Strict)), + arg(4,Att,lin(Lin)), + Lin = [I,R|_], + Opt is R + I, + TestLO is L - Opt, + ( TestLO < -1.0e-10 % L < Opt + -> narrow_u(Type,X,Opt), % { X =< Opt } + rcbl(Continuation,B0,B1) + ; TestLO =< 1.0e-10, % L = Opt + Strict /\ 2 =:= 0, % meets lower + Mop is -Opt, + normalize_scalar(Mop,MopN), + add_linear_11(MopN,Lin,Lin1), + Lin1 = [Inhom,_|Hom], + ( Hom = [] + -> rcbl(Continuation,B0,B1) % would not callback + ; solve(Hom,Lin1,Inhom,B0,B1) + ) + ). +rcbl_opt(u(U),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Strict)), + arg(4,Att,lin(Lin)), + Lin = [I,R|_], + Opt is R + I, + TestUO is U - Opt, + ( TestUO > 1.0e-10 % U > Opt + -> narrow_l(Type,X,Opt), % { X >= Opt } + rcbl(Continuation,B0,B1) + ; TestUO >= -1.0e-10, % U = Opt + Strict /\ 1 =:= 0, % meets upper + Mop is -Opt, + normalize_scalar(Mop,MopN), + add_linear_11(MopN,Lin,Lin1), + Lin1 = [Inhom,_|Hom], + ( Hom = [] + -> rcbl(Continuation,B0,B1) % would not callback + ; solve(Hom,Lin1,Inhom,B0,B1) + ) + ). + +% +% Basis has already changed when this is called +% +rcbl_app(l(L),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(4,Att,lin([I,R|H])), + ( R + I - L > 1.0e-10 % R+I > L: within bound now + -> rcbl(Continuation,B0,B1) + ; inc_step(H,Status), + rcbl_status(Status,X,Continuation,B0,B1,l(L)) + ). +rcbl_app(u(U),X,Continuation,B0,B1) :- + get_attr(X,itf,Att), + arg(4,Att,lin([I,R|H])), + ( R + I - U < -1.0e-10 % R+I < U: within bound now + -> rcbl(Continuation,B0,B1) + ; dec_step(H,Status), + rcbl_status(Status,X,Continuation,B0,B1,u(U)) + ). +% +% This is never called for a t_lu culprit +% +rcbl_unl(l(L),X,Continuation,B0,B1,Indep,DepT) :- + pivot_a(X,Indep,t_L(L),DepT), % changes the basis + rcbl(Continuation,B0,B1). +rcbl_unl(u(U),X,Continuation,B0,B1,Indep,DepT) :- + pivot_a(X,Indep,t_U(U),DepT), % changes the basis + rcbl(Continuation,B0,B1). + +% narrow_u(Type,X,U) +% +% Narrows down the upperbound of X (type Type) to U. +% Fails if Type is not t_u(_) or t_lu(_) + +narrow_u(t_u(_),X,U) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(U))). +narrow_u(t_lu(L,_),X,U) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). + +% narrow_l(Type,X,L) +% +% Narrows down the lowerbound of X (type Type) to L. +% Fails if Type is not t_l(_) or t_lu(_) + +narrow_l( t_l(_), X, L) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(L))). + +narrow_l( t_lu(_,U), X, L) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,U))). + +% ----------------------------------- dump ------------------------------------ + +% dump_var(Type,Var,I,H,Dump,DumpTail) +% +% Returns in Dump a representation of the linear constraint on variable +% Var which has linear equation H + I and has type Type. + +dump_var(t_none,V,I,H) --> + !, + ( { + H = [l(W*K,_)], + V == W, + I >= -1.0e-10, % I=:=0 + I =< 1.0e-010, + TestK is K - 1.0, % K=:=1 + TestK >= -1.0e-10, + TestK =< 1.0e-10 + } + -> % indep var + [] + ; {nf2sum(H,I,Sum)}, + [V = Sum] + ). +dump_var(t_L(L),V,I,H) --> + !, + dump_var(t_l(L),V,I,H). +% case lowerbound: V >= L or V > L +% say V >= L, and V = K*V1 + ... + I, then K*V1 + ... + I >= L +% and K*V1 + ... >= L-I and V1 + .../K = (L-I)/K +dump_var(t_l(L),V,I,H) --> + !, + { + H = [l(_*K,_)|_], % avoid 1 >= 0 + get_attr(V,itf,Att), + arg(3,Att,strictness(Strict)), + Sm is Strict /\ 2, + Kr is 1.0/K, + Li is Kr*(L - I), + mult_hom(H,Kr,H1), + nf2sum(H1,0.0,Sum), + ( K > 1.0e-10 % K > 0 + -> dump_strict(Sm,Sum >= Li,Sum > Li,Result) + ; dump_strict(Sm,Sum =< Li,Sum < Li,Result) + ) + }, + [Result]. +dump_var(t_U(U),V,I,H) --> + !, + dump_var(t_u(U),V,I,H). +dump_var(t_u(U),V,I,H) --> + !, + { + H = [l(_*K,_)|_], % avoid 0 =< 1 + get_attr(V,itf,Att), + arg(3,Att,strictness(Strict)), + Sm is Strict /\ 1, + Kr is 1.0/K, + Ui is Kr*(U-I), + mult_hom(H,Kr,H1), + nf2sum(H1,0.0,Sum), + ( K > 1.0e-10 % K > 0 + -> dump_strict(Sm,Sum =< Ui,Sum < Ui,Result) + ; dump_strict(Sm,Sum >= Ui,Sum > Ui,Result) + ) + }, + [Result]. +dump_var(t_Lu(L,U),V,I,H) --> + !, + dump_var(t_l(L),V,I,H), + dump_var(t_u(U),V,I,H). +dump_var(t_lU(L,U),V,I,H) --> + !, + dump_var(t_l(L),V,I,H), + dump_var(t_u(U),V,I,H). +dump_var(t_lu(L,U),V,I,H) --> + !, + dump_var(t_l(L),V,I,H), + dump_var(t_U(U),V,I,H). +dump_var(T,V,I,H) --> % should not happen + [V:T:I+H]. + +% dump_strict(FilteredStrictness,Nonstrict,Strict,Res) +% +% Unifies Res with either Nonstrict or Strict depending on FilteredStrictness. +% FilteredStrictness is the component of strictness related to the bound: 0 +% means nonstrict, 1 means strict upperbound, 2 means strict lowerbound, +% 3 is filtered out to either 1 or 2. + +dump_strict(0,Result,_,Result). +dump_strict(1,_,Result,Result). +dump_strict(2,_,Result,Result). + +% dump_nz(V,H,I,Dump,DumpTail) +% +% Returns in Dump a representation of the nonzero constraint of variable V +% which has linear +% equation H + I. + +dump_nz(_,H,I) --> + { + H = [l(_*K,_)|_], + Kr is 1.0/K, + I1 is -Kr*I, + mult_hom(H,Kr,H1), + nf2sum(H1,0.0,Sum) + }, + [Sum =\= I1]. diff --git a/packages/clpqr/clpr/fourmotz_r.pl b/packages/clpqr/clpr/fourmotz_r.pl new file mode 100644 index 000000000..45894a91c --- /dev/null +++ b/packages/clpqr/clpr/fourmotz_r.pl @@ -0,0 +1,504 @@ +/* $Id$ + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(fourmotz_r, + [ + fm_elim/3 + ]). +:- use_module(bv_r, + [ + allvars/2, + basis_add/2, + detach_bounds/1, + pivot/5, + var_with_def_intern/4 + ]). +:- use_module('../clpqr/class', + [ + class_allvars/2 + ]). +:- use_module('../clpqr/project', + [ + drop_dep/1, + drop_dep_one/1, + make_target_indep/2 + ]). +:- use_module('../clpqr/redund', + [ + redundancy_vars/1 + ]). +:- use_module(store_r, + [ + add_linear_11/3, + add_linear_f1/4, + indep/2, + nf_coeff_of/3, + normalize_scalar/2 + ]). + + + +fm_elim(Vs,Target,Pivots) :- + prefilter(Vs,Vsf), + fm_elim_int(Vsf,Target,Pivots). + +% prefilter(Vars,Res) +% +% filters out target variables and variables that do not occur in bounded linear equations. +% Stores that the variables in Res are to be kept independent. + +prefilter([],[]). +prefilter([V|Vs],Res) :- + ( get_attr(V,itf,Att), + arg(9,Att,n), + occurs(V) % V is a nontarget variable that occurs in a bounded linear equation + -> Res = [V|Tail], + setarg(10,Att,keep_indep), + prefilter(Vs,Tail) + ; prefilter(Vs,Res) + ). + +% +% the target variables are marked with an attribute, and we get a list +% of them as an argument too +% +fm_elim_int([],_,Pivots) :- % done + unkeep(Pivots). +fm_elim_int(Vs,Target,Pivots) :- + Vs = [_|_], + ( best(Vs,Best,Rest) + -> occurences(Best,Occ), + elim_min(Best,Occ,Target,Pivots,NewPivots) + ; % give up + NewPivots = Pivots, + Rest = [] + ), + fm_elim_int(Rest,Target,NewPivots). + +% best(Vs,Best,Rest) +% +% Finds the variable with the best result (lowest Delta) in fm_cp_filter +% and returns the other variables in Rest. + +best(Vs,Best,Rest) :- + findall(Delta-N,fm_cp_filter(Vs,Delta,N),Deltas), + keysort(Deltas,[_-N|_]), + select_nth(Vs,N,Best,Rest). + +% fm_cp_filter(Vs,Delta,N) +% +% For an indepenent variable V in Vs, which is the N'th element in Vs, +% find how many inequalities are generated when this variable is eliminated. +% Note that target variables and variables that only occur in unbounded equations +% should have been removed from Vs via prefilter/2 + +fm_cp_filter(Vs,Delta,N) :- + length(Vs,Len), % Len = number of variables in Vs + mem(Vs,X,Vst), % Selects a variable X in Vs, Vst is the list of elements after X in Vs + get_attr(X,itf,Att), + arg(4,Att,lin(Lin)), + arg(5,Att,order(OrdX)), + arg(9,Att,n), % no target variable + indep(Lin,OrdX), % X is an independent variable + occurences(X,Occ), + Occ = [_|_], + cp_card(Occ,0,Lnew), + length(Occ,Locc), + Delta is Lnew-Locc, + length(Vst,Vstl), + N is Len-Vstl. % X is the Nth element in Vs + +% mem(Xs,X,XsT) +% +% If X is a member of Xs, XsT is the list of elements after X in Xs. + +mem([X|Xs],X,Xs). +mem([_|Ys],X,Xs) :- mem(Ys,X,Xs). + +% select_nth(List,N,Nth,Others) +% +% Selects the N th element of List, stores it in Nth and returns the rest of the list in Others. + +select_nth(List,N,Nth,Others) :- + select_nth(List,1,N,Nth,Others). + +select_nth([X|Xs],N,N,X,Xs) :- !. +select_nth([Y|Ys],M,N,X,[Y|Xs]) :- + M1 is M+1, + select_nth(Ys,M1,N,X,Xs). + +% +% fm_detach + reverse_pivot introduce indep t_none, which +% invalidates the invariants +% +elim_min(V,Occ,Target,Pivots,NewPivots) :- + crossproduct(Occ,New,[]), + activate_crossproduct(New), + reverse_pivot(Pivots), + fm_detach(Occ), + allvars(V,All), + redundancy_vars(All), % only for New \== [] + make_target_indep(Target,NewPivots), + drop_dep(All). + +% +% restore NF by reverse pivoting +% +reverse_pivot([]). +reverse_pivot([I:D|Ps]) :- + get_attr(D,itf,AttD), + arg(2,AttD,type(Dt)), + setarg(11,AttD,n), % no longer + get_attr(I,itf,AttI), + arg(2,AttI,type(It)), + arg(5,AttI,order(OrdI)), + arg(6,AttI,class(ClI)), + pivot(D,ClI,OrdI,Dt,It), + reverse_pivot(Ps). + +% unkeep(Pivots) +% +% + +unkeep([]). +unkeep([_:D|Ps]) :- + get_attr(D,itf,Att), + setarg(11,Att,n), + drop_dep_one(D), + unkeep(Ps). + + +% +% All we drop are bounds +% +fm_detach( []). +fm_detach([V:_|Vs]) :- + detach_bounds(V), + fm_detach(Vs). + +% activate_crossproduct(Lst) +% +% For each inequality Lin =< 0 (or Lin < 0) in Lst, a new variable is created: +% Var = Lin and Var =< 0 (or Var < 0). Var is added to the basis. + +activate_crossproduct([]). +activate_crossproduct([lez(Strict,Lin)|News]) :- + var_with_def_intern(t_u(0.0),Var,Lin,Strict), + % Var belongs to same class as elements in Lin + basis_add(Var,_), + activate_crossproduct(News). + +% ------------------------------------------------------------------------------ + +% crossproduct(Lst,Res,ResTail) +% +% See crossproduct/4 +% This predicate each time puts the next element of Lst as First in crossproduct/4 +% and lets the rest be Next. + +crossproduct([]) --> []. +crossproduct([A|As]) --> + crossproduct(As,A), + crossproduct(As). + +% crossproduct(Next,First,Res,ResTail) +% +% Eliminates a variable in linear equations First + Next and stores the generated +% inequalities in Res. +% Let's say A:K1 = First and B:K2 = first equation in Next. +% A = ... + K1*V + ... +% B = ... + K2*V + ... +% Let K = -K2/K1 +% then K*A + B = ... + 0*V + ... +% from the bounds of A and B, via cross_lower/7 and cross_upper/7, new inequalities +% are generated. Then the same is done for B:K2 = next element in Next. + +crossproduct([],_) --> []. +crossproduct([B:Kb|Bs],A:Ka) --> + { + get_attr(A,itf,AttA), + arg(2,AttA,type(Ta)), + arg(3,AttA,strictness(Sa)), + arg(4,AttA,lin(LinA)), + get_attr(B,itf,AttB), + arg(2,AttB,type(Tb)), + arg(3,AttB,strictness(Sb)), + arg(4,AttB,lin(LinB)), + K is -Kb/Ka, + add_linear_f1(LinA,K,LinB,Lin) % Lin doesn't contain the target variable anymore + }, + ( { K > 1.0e-10 } % K > 0: signs were opposite + -> { Strict is Sa \/ Sb }, + cross_lower(Ta,Tb,K,Lin,Strict), + cross_upper(Ta,Tb,K,Lin,Strict) + ; % La =< A =< Ua -> -Ua =< -A =< -La + { + flip(Ta,Taf), + flip_strict(Sa,Saf), + Strict is Saf \/ Sb + }, + cross_lower(Taf,Tb,K,Lin,Strict), + cross_upper(Taf,Tb,K,Lin,Strict) + ), + crossproduct(Bs,A:Ka). + +% cross_lower(Ta,Tb,K,Lin,Strict,Res,ResTail) +% +% Generates a constraint following from the bounds of A and B. +% When A = LinA and B = LinB then Lin = K*LinA + LinB. Ta is the type +% of A and Tb is the type of B. Strict is the union of the strictness +% of A and B. If K is negative, then Ta should have been flipped (flip/2). +% The idea is that if La =< A =< Ua and Lb =< B =< Ub (=< can also be <) +% then if K is positive, K*La + Lb =< K*A + B =< K*Ua + Ub. +% if K is negative, K*Ua + Lb =< K*A + B =< K*La + Ub. +% This predicate handles the first inequality and adds it to Res in the form +% lez(Sl,Lhs) meaning K*La + Lb - (K*A + B) =< 0 or K*Ua + Lb - (K*A + B) =< 0 +% with Sl being the strictness and Lhs the lefthandside of the equation. +% See also cross_upper/7 + +cross_lower(Ta,Tb,K,Lin,Strict) --> + { + lower(Ta,La), + lower(Tb,Lb), + !, + L is K*La+Lb, + normalize_scalar(L,Ln), + add_linear_f1(Lin,-1.0,Ln,Lhs), + Sl is Strict >> 1 % normalize to upper bound + }, + [ lez(Sl,Lhs) ]. +cross_lower(_,_,_,_,_) --> []. + +% cross_upper(Ta,Tb,K,Lin,Strict,Res,ResTail) +% +% See cross_lower/7 +% This predicate handles the second inequality: +% -(K*Ua + Ub) + K*A + B =< 0 or -(K*La + Ub) + K*A + B =< 0 + +cross_upper(Ta,Tb,K,Lin,Strict) --> + { + upper(Ta,Ua), + upper(Tb,Ub), + !, + U is -(K*Ua+Ub), + normalize_scalar(U,Un), + add_linear_11(Un,Lin,Lhs), + Su is Strict /\ 1 % normalize to upper bound + }, + [ lez(Su,Lhs) ]. +cross_upper(_,_,_,_,_) --> []. + +% lower(Type,Lowerbound) +% +% Returns the lowerbound of type Type if it has one. +% E.g. if type = t_l(L) then Lowerbound is L, +% if type = t_lU(L,U) then Lowerbound is L, +% if type = t_u(U) then fails + +lower(t_l(L),L). +lower(t_lu(L,_),L). +lower(t_L(L),L). +lower(t_Lu(L,_),L). +lower(t_lU(L,_),L). + +% upper(Type,Upperbound) +% +% Returns the upperbound of type Type if it has one. +% See lower/2 + +upper(t_u(U),U). +upper(t_lu(_,U),U). +upper(t_U(U),U). +upper(t_Lu(_,U),U). +upper(t_lU(_,U),U). + +% flip(Type,FlippedType) +% +% Flips the lower and upperbound, so the old lowerbound becomes the new upperbound and +% vice versa. + +flip(t_l(X),t_u(X)). +flip(t_u(X),t_l(X)). +flip(t_lu(X,Y),t_lu(Y,X)). +flip(t_L(X),t_u(X)). +flip(t_U(X),t_l(X)). +flip(t_lU(X,Y),t_lu(Y,X)). +flip(t_Lu(X,Y),t_lu(Y,X)). + +% flip_strict(Strict,FlippedStrict) +% +% Does what flip/2 does, but for the strictness. + +flip_strict(0,0). +flip_strict(1,2). +flip_strict(2,1). +flip_strict(3,3). + +% cp_card(Lst,CountIn,CountOut) +% +% Counts the number of bounds that may generate an inequality in +% crossproduct/3 + +cp_card([],Ci,Ci). +cp_card([A|As],Ci,Co) :- + cp_card(As,A,Ci,Cii), + cp_card(As,Cii,Co). + +% cp_card(Next,First,CountIn,CountOut) +% +% Counts the number of bounds that may generate an inequality in +% crossproduct/4. + +cp_card([],_,Ci,Ci). +cp_card([B:Kb|Bs],A:Ka,Ci,Co) :- + get_attr(A,itf,AttA), + arg(2,AttA,type(Ta)), + get_attr(B,itf,AttB), + arg(2,AttB,type(Tb)), + K is -Kb/Ka, + ( K > 1.0e-10 % K > 0: signs were opposite + -> cp_card_lower(Ta,Tb,Ci,Cii), + cp_card_upper(Ta,Tb,Cii,Ciii) + ; flip(Ta,Taf), + cp_card_lower(Taf,Tb,Ci,Cii), + cp_card_upper(Taf,Tb,Cii,Ciii) + ), + cp_card(Bs,A:Ka,Ciii,Co). + +% cp_card_lower(TypeA,TypeB,SIn,SOut) +% +% SOut = SIn + 1 if both TypeA and TypeB have a lowerbound. + +cp_card_lower(Ta,Tb,Si,So) :- + lower(Ta,_), + lower(Tb,_), + !, + So is Si+1. +cp_card_lower(_,_,Si,Si). + +% cp_card_upper(TypeA,TypeB,SIn,SOut) +% +% SOut = SIn + 1 if both TypeA and TypeB have an upperbound. + +cp_card_upper(Ta,Tb,Si,So) :- + upper(Ta,_), + upper(Tb,_), + !, + So is Si+1. +cp_card_upper(_,_,Si,Si). + +% ------------------------------------------------------------------------------ + +% occurences(V,Occ) +% +% Returns in Occ the occurrences of variable V in the linear equations of dependent variables +% with bound =\= t_none in the form of D:K where D is a dependent variable and K is the scalar +% of V in the linear equation of D. + +occurences(V,Occ) :- + get_attr(V,itf,Att), + arg(5,Att,order(OrdV)), + arg(6,Att,class(C)), + class_allvars(C,All), + occurences(All,OrdV,Occ). + +% occurences(De,OrdV,Occ) +% +% Returns in Occ the occurrences of variable V with order OrdV in the linear equations of +% dependent variables De with bound =\= t_none in the form of D:K where D is a dependent +% variable and K is the scalar of V in the linear equation of D. + +occurences(De,_,[]) :- + var(De), + !. +occurences([D|De],OrdV,Occ) :- + ( get_attr(D,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + occ_type_filter(Type), + nf_coeff_of(Lin,OrdV,K) + -> Occ = [D:K|Occt], + occurences(De,OrdV,Occt) + ; occurences(De,OrdV,Occ) + ). + +% occ_type_filter(Type) +% +% Succeeds when Type is any other type than t_none. Is used in occurences/3 and occurs/2 + +occ_type_filter(t_l(_)). +occ_type_filter(t_u(_)). +occ_type_filter(t_lu(_,_)). +occ_type_filter(t_L(_)). +occ_type_filter(t_U(_)). +occ_type_filter(t_lU(_,_)). +occ_type_filter(t_Lu(_,_)). + +% occurs(V) +% +% Checks whether variable V occurs in a linear equation of a dependent variable with a bound +% =\= t_none. + +occurs(V) :- + get_attr(V,itf,Att), + arg(5,Att,order(OrdV)), + arg(6,Att,class(C)), + class_allvars(C,All), + occurs(All,OrdV). + +% occurs(De,OrdV) +% +% Checks whether variable V with order OrdV occurs in a linear equation of any dependent variable +% in De with a bound =\= t_none. + +occurs(De,_) :- + var(De), + !, + fail. +occurs([D|De],OrdV) :- + ( get_attr(D,itf,Att), + arg(2,Att,type(Type)), + arg(4,Att,lin(Lin)), + occ_type_filter(Type), + nf_coeff_of(Lin,OrdV,_) + -> true + ; occurs(De,OrdV) + ). \ No newline at end of file diff --git a/packages/clpqr/clpr/ineq_r.pl b/packages/clpqr/clpr/ineq_r.pl new file mode 100644 index 000000000..9be003af1 --- /dev/null +++ b/packages/clpqr/clpr/ineq_r.pl @@ -0,0 +1,1384 @@ +/* + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +:- module(ineq_r, + [ + ineq/4, + ineq_one/4, + ineq_one_n_n_0/1, + ineq_one_n_p_0/1, + ineq_one_s_n_0/1, + ineq_one_s_p_0/1 + ]). +:- use_module(bv_r, + [ + backsubst/3, + backsubst_delta/4, + basis_add/2, + dec_step/2, + deref/2, + determine_active_dec/1, + determine_active_inc/1, + export_binding/1, + get_or_add_class/2, + inc_step/2, + lb/3, + pivot_a/4, + rcbl_status/6, + reconsider/1, + same_class/2, + solve/1, + ub/3, + unconstrained/4, + var_intern/3, + var_with_def_intern/4 + ]). +:- use_module(store_r, + [ + add_linear_11/3, + add_linear_ff/5, + normalize_scalar/2 + ]). + +% ineq(H,I,Nf,Strictness) +% +% Solves the inequality Nf < 0 or Nf =< 0 where Nf is in normal form +% and H and I are the homogene and inhomogene parts of Nf. + +ineq([],I,_,Strictness) :- ineq_ground(Strictness,I). +ineq([v(K,[X^1])|Tail],I,Lin,Strictness) :- + ineq_cases(Tail,I,Lin,Strictness,X,K). + +ineq_cases([],I,_,Strictness,X,K) :- % K*X + I < 0 or K*X + I =< 0 + ineq_one(Strictness,X,K,I). +ineq_cases([_|_],_,Lin,Strictness,_,_) :- + deref(Lin,Lind), % Id+Hd =< 0 + Lind = [Inhom,_|Hom], + ineq_more(Hom,Inhom,Lind,Strictness). + +% ineq_ground(Strictness,I) +% +% Checks whether a grounded inequality I < 0 or I =< 0 is satisfied. + +ineq_ground(strict,I) :- I < -1.0e-10. % I < 0 +ineq_ground(nonstrict,I) :- I < 1.0e-10. % I =< 0 + +% ineq_one(Strictness,X,K,I) +% +% Solves the inequality K*X + I < 0 or K*X + I =< 0 + +ineq_one(strict,X,K,I) :- + ( K > 1.0e-10 % K > 0.0 + -> ( I >= -1.0e-10, % I =:= 0.0 + I =< 1.0e-10 + -> ineq_one_s_p_0(X) % K*X < 0, K > 0 => X < 0 + ; Inhom is I/K, + ineq_one_s_p_i(X,Inhom) % K*X + I < 0, K > 0 => X + I/K < 0 + ) + ; ( I >= -1.0e-10, % I =:= 0.0 + I =< 1.0e-10 + -> ineq_one_s_n_0(X) % K*X < 0, K < 0 => -X < 0 + ; Inhom is -I/K, + ineq_one_s_n_i(X,Inhom) % K*X + I < 0, K < 0 => -X - I/K < 0 + ) + ). +ineq_one(nonstrict,X,K,I) :- + ( K > 1.0e-10 % K > 0.0 + -> ( I >= -1.0e-10, % I =:= 0 + I =< 1.0e-10 + -> ineq_one_n_p_0(X) % K*X =< 0, K > 0 => X =< 0 + ; Inhom is I/K, + ineq_one_n_p_i(X,Inhom) % K*X + I =< 0, K > 0 => X + I/K =< 0 + ) + ; ( I >= -1.0e-10, % I =:= 0 + I =< 1.0e-10 + -> ineq_one_n_n_0(X) % K*X =< 0, K < 0 => -X =< 0 + ; Inhom is -I/K, + ineq_one_n_n_i(X,Inhom) % K*X + I =< 0, K < 0 => -X - I/K =< 0 + ) + ). + +% --------------------------- strict ---------------------------- + +% ineq_one_s_p_0(X) +% +% Solves the inequality X < 0 + +ineq_one_s_p_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, % old variable, this is deref + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_p_0(OrdX,X,Ix) + ). +ineq_one_s_p_0(X) :- % new variable, nothing depends on it + var_intern(t_u(0.0),X,1). % put a strict inactive upperbound on the variable + +% ineq_one_s_n_0(X) +% +% Solves the inequality X > 0 + +ineq_one_s_n_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_n_0(OrdX,X,Ix) + ). +ineq_one_s_n_0(X) :- + var_intern(t_l(0.0),X,2). % puts a strict inactive lowerbound on the variable + +% ineq_one_s_p_i(X,I) +% +% Solves the inequality X < -I + +ineq_one_s_p_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_p_i(OrdX,I,X,Ix) + ). +ineq_one_s_p_i(X,I) :- + Bound is -I, + var_intern(t_u(Bound),X,1). % puts a strict inactive upperbound on the variable + +% ineq_one_s_n_i(X,I) +% +% Solves the inequality X > I + +ineq_one_s_n_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_s_n_i(OrdX,I,X,Ix) + ). +ineq_one_s_n_i(X,I) :- var_intern(t_l(I),X,2). % puts a strict inactive lowerbound on the variable + +% ineq_one_old_s_p_0(Hom,X,Inhom) +% +% Solves the inequality X < 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_p_0([],_,Ix) :- Ix < -1.0e-10. % X = I: Ix < 0 +ineq_one_old_s_p_0([l(Y*Ky,_)|Tail],X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -Ix/Ky, + update_indep(strict,Y,Ky,Bound) % X < 0, X = K*Y + I => Y < -I/K or Y > -I/K (depending on K) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udus(Type,X,Lin,0.0,Old) % update strict upperbound + ). + +% ineq_one_old_s_p_0(Hom,X,Inhom) +% +% Solves the inequality X > 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_n_0([],_,Ix) :- Ix > 1.0e-10. % X = I: Ix > 0 +ineq_one_old_s_n_0([l(Y*Ky,_)|Tail], X, Ix) :- + ( Tail = [] % X = K*Y + I + -> Coeff is -Ky, + Bound is Ix/Coeff, + update_indep(strict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udls(Type,X,Lin,0.0,Old) % update strict lowerbound + ). + +% ineq_one_old_s_p_i(Hom,C,X,Inhom) +% +% Solves the inequality X + C < 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_p_i([],I,_,Ix) :- Ix + I < -1.0e-10. % X = I +ineq_one_old_s_p_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -(Ix + I)/Ky, + update_indep(strict,Y,Ky,Bound) + ; Tail = [_|_] + -> Bound is -I, + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udus(Type,X,Lin,Bound,Old) % update strict upperbound + ). + +% ineq_one_old_s_n_i(Hom,C,X,Inhom) +% +% Solves the inequality X - C > 0 where X has linear equation Hom + Inhom + +ineq_one_old_s_n_i([],I,_,Ix) :- -Ix + I < -1.0e-10. % X = I +ineq_one_old_s_n_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Coeff is -Ky, + Bound is (Ix - I)/Coeff, + update_indep(strict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udls(Type,X,Lin,I,Old) % update strict lowerbound + ). + +% -------------------------- nonstrict -------------------------- + +% ineq_one_n_p_0(X) +% +% Solves the inequality X =< 0 + +ineq_one_n_p_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, % old variable, this is deref + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_p_0(OrdX,X,Ix) + ). +ineq_one_n_p_0(X) :- % new variable, nothing depends on it + var_intern(t_u(0.0),X,0). % nonstrict upperbound + +% ineq_one_n_n_0(X) +% +% Solves the inequality X >= 0 + +ineq_one_n_n_0(X) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_n_0(OrdX,X,Ix) + ). +ineq_one_n_n_0(X) :- + var_intern(t_l(0.0),X,0). % nonstrict lowerbound + +% ineq_one_n_p_i(X,I) +% +% Solves the inequality X =< -I + +ineq_one_n_p_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_p_i(OrdX,I,X,Ix) + ). +ineq_one_n_p_i(X,I) :- + Bound is -I, + var_intern(t_u(Bound),X,0). % nonstrict upperbound + +% ineq_one_n_n_i(X,I) +% +% Solves the inequality X >= I + +ineq_one_n_n_i(X,I) :- + get_attr(X,itf,Att), + arg(4,Att,lin([Ix,_|OrdX])), + !, + ( \+ arg(1,Att,clpr) + -> throw(error(permission_error('mix CLP(Q) variables with', + 'CLP(R) variables:',X),context(_))) + ; ineq_one_old_n_n_i(OrdX,I,X,Ix) + ). +ineq_one_n_n_i(X,I) :- + var_intern(t_l(I),X,0). % nonstrict lowerbound + +% ineq_one_old_n_p_0(Hom,X,Inhom) +% +% Solves the inequality X =< 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_p_0([],_,Ix) :- Ix < 1.0e-10. % X =I +ineq_one_old_n_p_0([l(Y*Ky,_)|Tail],X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -Ix/Ky, + update_indep(nonstrict,Y,Ky,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udu(Type,X,Lin,0.0,Old) % update nonstrict upperbound + ). + +% ineq_one_old_n_n_0(Hom,X,Inhom) +% +% Solves the inequality X >= 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_n_0([],_,Ix) :- Ix > -1.0e-10. % X = I +ineq_one_old_n_n_0([l(Y*Ky,_)|Tail], X, Ix) :- + ( Tail = [] % X = K*Y + I + -> Coeff is -Ky, + Bound is Ix/Coeff, + update_indep(nonstrict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udl(Type,X,Lin,0.0,Old) % update nonstrict lowerbound + ). + +% ineq_one_old_n_p_i(Hom,C,X,Inhom) +% +% Solves the inequality X + C =< 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_p_i([],I,_,Ix) :- Ix + I < 1.0e-10. % X = I +ineq_one_old_n_p_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] % X = K*Y + I + -> Bound is -(Ix + I)/Ky, + update_indep(nonstrict,Y,Ky,Bound) + ; Tail = [_|_] + -> Bound is -I, + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udu(Type,X,Lin,Bound,Old) % update nonstrict upperbound + ). + +% ineq_one_old_n_n_i(Hom,C,X,Inhom) +% +% Solves the inequality X - C >= 0 where X has linear equation Hom + Inhom + +ineq_one_old_n_n_i([],I,_,Ix) :- -Ix + I < 1.0e-10. % X = I +ineq_one_old_n_n_i([l(Y*Ky,_)|Tail],I,X,Ix) :- + ( Tail = [] + -> Coeff is -Ky, + Bound is (Ix - I)/Coeff, + update_indep(nonstrict,Y,Coeff,Bound) + ; Tail = [_|_] + -> get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + udl(Type,X,Lin,I,Old) + ). + +% --------------------------------------------------------------- + +% ineq_more(Hom,Inhom,Lin,Strictness) +% +% Solves the inequality Lin < 0 or Lin =< 0 with Lin = Hom + Inhom + +ineq_more([],I,_,Strictness) :- ineq_ground(Strictness,I). % I < 0 or I =< 0 +ineq_more([l(X*K,_)|Tail],Id,Lind,Strictness) :- + ( Tail = [] + -> % X*K < Id or X*K =< Id + % one var: update bound instead of slack introduction + get_or_add_class(X,_), % makes sure X belongs to a class + Bound is -Id/K, + update_indep(Strictness,X,K,Bound) % new bound + ; Tail = [_|_] + -> ineq_more(Strictness,Lind) + ). + +% ineq_more(Strictness,Lin) +% +% Solves the inequality Lin < 0 or Lin =< 0 + +ineq_more(strict,Lind) :- + ( unconstrained(Lind,U,K,Rest) + -> % never fails, no implied value + % Lind < 0 => Rest < -K*U where U has no bounds + var_intern(t_l(0.0),S,2), % create slack variable S + get_attr(S,itf,AttS), + arg(5,AttS,order(OrdS)), + Ki is -1.0/K, + add_linear_ff(Rest,Ki,[0.0,0.0,l(S*1.0,OrdS)],Ki,LinU), % U = (-1/K)*Rest + (-1/K)*S + LinU = [_,_|Hu], + get_or_add_class(U,Class), + same_class(Hu,Class), % put all variables of new lin. eq. of U in the same class + get_attr(U,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(ClassU)), + backsubst(ClassU,OrdU,LinU) % substitute U by new lin. eq. everywhere in the class + ; var_with_def_intern(t_u(0.0),S,Lind,1), % Lind < 0 => Lind = S with S < 0 + basis_add(S,_), % adds S to the basis + determine_active_dec(Lind), % activate bounds + reconsider(S) % reconsider basis + ). +ineq_more(nonstrict,Lind) :- + ( unconstrained(Lind,U,K,Rest) + -> % never fails, no implied value + % Lind =< 0 => Rest =< -K*U where U has no bounds + var_intern(t_l(0.0),S,0), % create slack variable S + Ki is -1.0/K, + get_attr(S,itf,AttS), + arg(5,AttS,order(OrdS)), + add_linear_ff(Rest,Ki,[0.0,0.0,l(S*1.0,OrdS)],Ki,LinU), % U = (-1K)*Rest + (-1/K)*S + LinU = [_,_|Hu], + get_or_add_class(U,Class), + same_class(Hu,Class), % put all variables of new lin. eq of U in the same class + get_attr(U,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(ClassU)), + backsubst(ClassU,OrdU,LinU) % substitute U by new lin. eq. everywhere in the class + ; % all variables are constrained + var_with_def_intern(t_u(0.0),S,Lind,0), % Lind =< 0 => Lind = S with S =< 0 + basis_add(S,_), % adds S to the basis + determine_active_dec(Lind), + reconsider(S) + ). + + +% update_indep(Strictness,X,K,Bound) +% +% Updates the bound of independent variable X where X < Bound or X =< Bound +% or X > Bound or X >= Bound, depending on Strictness and K. + +update_indep(strict,X,K,Bound) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + ( K < -1.0e-10 + -> uils(Type,X,Lin,Bound,Old) % update independent lowerbound strict + ; uius(Type,X,Lin,Bound,Old) % update independent upperbound strict + ). +update_indep(nonstrict,X,K,Bound) :- + get_attr(X,itf,Att), + arg(2,Att,type(Type)), + arg(3,Att,strictness(Old)), + arg(4,Att,lin(Lin)), + ( K < -1.0e-10 + -> uil(Type,X,Lin,Bound,Old) % update independent lowerbound nonstrict + ; uiu(Type,X,Lin,Bound,Old) % update independent upperbound nonstrict + ). + + +% --------------------------------------------------------------------------------------- + +% +% Update a bound on a var xi +% +% a) independent variable +% +% a1) update inactive bound: done +% +% a2) update active bound: +% Determine [lu]b including most constraining row R +% If we are within: done +% else pivot(R,xi) and introduce bound via (b) +% +% a3) introduce a bound on an unconstrained var: +% All vars that depend on xi are unconstrained (invariant) -> +% the bound cannot invalidate any Lhs +% +% b) dependent variable +% +% repair upper or lower (maybe just swap with an unconstrained var from Rhs) +% + +% +% Sign = 1,0,-1 means inside,at,outside +% + +% Read following predicates as update (dependent/independent) (lowerbound/upperbound) (strict) + +% udl(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. + +udl(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_l(Bound))), + setarg(3,AttX,strictness(0)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => -1/K*Rest + 1/K*X = U where U has no bounds + Ki is -1.0/Kuc, + add_linear_ff(Rest,Ki,[0.0,0.0,l(X* -1.0,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables in Lin: make X part of basis and reconsider + basis_add(X,_), + determine_active_inc(Lin), + reconsider(X) + ). +udl(t_l(L),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true % new bound is smaller than old one: keep old + ; TestBL > 1.0e-10 + -> % new bound is larger than old one: use new and reconsider basis + Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) % makes sure that Lin still satisfies lowerbound Bound + ; true % new bound is equal to old one, new one is nonstrict: keep old + ). + +udl(t_u(U),X,Lin,Bound,_Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail % new bound is larger than upperbound: fail + ; TestUB > 1.0e-10 + -> % new bound is smaller than upperbound: add new and reconsider basis + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + reconsider_lower(X,Lin,Bound) % makes sure that Lin still satisfies lowerbound Bound + ; solve_bound(Lin,Bound) % new bound is equal to upperbound: solve + ). +udl(t_lu(L,U),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true % smaller than lowerbound: keep + ; TestBL > 1.0e-10 + -> % larger than lowerbound: check upperbound + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail % larger than upperbound: fail + ; TestUB > 1.0e-10 + -> % smaller than upperbound: use new and reconsider basis + Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; % equal to upperbound: if strictness matches => solve + Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true % equal to lowerbound and nonstrict: keep + ). + +% udls(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. + +udls(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_l(Bound))), + setarg(3,AttX,strictness(2)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => U = -1/K*Rest + 1/K*X with U an unconstrained variable + Ki is -1.0/Kuc, + add_linear_ff(Rest,Ki,[0.0,0.0,l(X* -1.0,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables: add X to basis and reconsider basis + basis_add(X,_), + determine_active_inc(Lin), + reconsider(X) + ). +udls(t_l(L),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true % smaller than lowerbound: keep + ; TestBL > 1.0e-10 + -> % larger than lowerbound: use new and reconsider basis + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; % equal to lowerbound: check strictness + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +udls(t_u(U),X,Lin,Bound,Sold) :- + U - Bound > 1.0e-10, % smaller than upperbound: set new bound + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound). +udls(t_lu(L,U),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true % smaller than lowerbound: keep + ; TestBL > 1.0e-10 + -> % larger than lowerbound: check upperbound and possibly use new and reconsider basis + U - Bound > 1.0e-10, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + reconsider_lower(X,Lin,Bound) + ; % equal to lowerbound: put new strictness + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% udu(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. + +udu(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_u(Bound))), + setarg(3,AttX,strictness(0)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => U = -1/K*Rest + 1/K*X with U an unconstrained variable + Ki is -1.0/Kuc, + add_linear_ff(Rest,Ki,[0.0,0.0,l(X* -1.0,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables: add X to basis and reconsider basis + basis_add(X,_), + determine_active_dec(Lin), % try to lower R + reconsider(X) + ). +udu(t_u(U),X,Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> % smaller than upperbound: update and reconsider basis + Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; true % equal to upperbound and nonstrict: keep + ). +udu(t_l(L),X,Lin,Bound,_Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> fail % smaller than lowerbound: fail + ; TestBL > 1.0e-10 + -> % larger than lowerbound: use new and reconsider basis + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + reconsider_upper(X,Lin,Bound) + ; solve_bound(Lin,Bound) % equal to lowerbound: solve + ). +udu(t_lu(L,U),X,Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> % smaller than upperbound: check lowerbound + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> fail % smaller than lowerbound: fail + ; TestBL > 1.0e-10 + -> % larger than lowerbound: update and reconsider basis + Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; % equal to lowerbound: check strictness and possibly solve + Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true % equal to upperbound and nonstrict: keep + ). + +% udus(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of dependent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. + +udus(t_none,X,Lin,Bound,_Sold) :- + get_attr(X,itf,AttX), + arg(5,AttX,order(Ord)), + setarg(2,AttX,type(t_u(Bound))), + setarg(3,AttX,strictness(1)), + ( unconstrained(Lin,Uc,Kuc,Rest) + -> % X = Lin => U = -1/K*Rest + 1/K*X with U an unconstrained variable + Ki is -1.0/Kuc, + add_linear_ff(Rest,Ki,[0.0,0.0,l(X* -1.0,Ord)],Ki,LinU), + get_attr(Uc,itf,AttU), + arg(5,AttU,order(OrdU)), + arg(6,AttU,class(Class)), + backsubst(Class,OrdU,LinU) + ; % no unconstrained variables: add X to basis and reconsider basis + basis_add(X,_), + determine_active_dec(Lin), + reconsider(X) + ). +udus(t_u(U),X,Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> % smaller than upperbound: update bound and reconsider basis + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; % equal to upperbound: set new strictness + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +udus(t_l(L),X,Lin,Bound,Sold) :- + Bound - L > 1.0e-10, % larger than lowerbound: update and reconsider basis + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound). +udus(t_lu(L,U),X,Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> % smaller than upperbound: check lowerbound, possibly update and reconsider basis + Bound - L > 1.0e-10, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)), + reconsider_upper(X,Lin,Bound) + ; % equal to upperbound: update strictness + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% uiu(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. + +uiu(t_none,X,_Lin,Bound,_) :- % X had no bounds + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(0)). +uiu(t_u(U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> % smaller than upperbound: update. + Strict is Sold /\ 2, % update strictness: strictness of lowerbound is kept, + % strictness of upperbound is set to non-strict + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)) + ; true % equal to upperbound and nonstrict: keep + ). +uiu(t_l(L),X,Lin,Bound,_Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> fail % Lowerbound was smaller than new upperbound: fail + ; TestBL > 1.0e-10 + -> % Upperbound is larger than lowerbound: store new bound + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))) + ; solve_bound(Lin,Bound) % Lowerbound was equal to new upperbound: solve + ). +uiu(t_L(L),X,Lin,Bound,_Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> fail % Same as for t_l + ; TestBL > 1.0e-10 + -> % Same as for t_l (new bound becomes t_Lu) + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))) + ; solve_bound(Lin,Bound) % Same as for t_l + ). +uiu(t_lu(L,U),X,Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % Upperbound was smaller than new bound: keep + ; TestUB > 1.0e-10 + -> TestBL is Bound - L, % Upperbound was larger than new bound: check lowerbound + ( TestBL < -1.0e-10 + -> fail % Lowerbound was larger than new bound: fail + ; TestBL > 1.0e-10 + -> % Lowerbound was smaller than new bound: store new bound + Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; % Lowerbound was equal to new bound: solve + Sold /\ 2 =:= 0, % Only solve when strictness matches + solve_bound(Lin,Bound) + ) + ; true % Upperbound was equal to new bound and new bound non-strict: keep + ). +uiu(t_Lu(L,U),X,Lin,Bound,Sold) :- % See t_lu case + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true + ; TestUB > 1.0e-10 + -> TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> fail + ; TestBL > 1.0e-10 + -> Strict is Sold /\ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uiu(t_U(U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> % smaller than active upperbound: check how much active upperbound can be lowered. + % if enough, just lower bound, otherwise update the bound, make X dependent and reconsider basis + Strict is Sold /\ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound - (Lb + U) < 1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_U(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_u(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_U(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; true % equal to upperbound and non-strict: keep + ). +uiu(t_lU(L,U),X,Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true % larger than upperbound: keep + ; TestUB > 1.0e-10 + -> TestBL is Bound-L, + ( TestBL < -1.0e-10 + -> fail % smaller than lowerbound: fail + ; TestBL > 1.0e-10 + -> % larger than lowerbound: see t_U case for rest + Strict is Sold /\ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound - (Lb + U) < 1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_lU(L,Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_lu(L,Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_lU(L,Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; % equal to lowerbound: check strictness and solve + Sold /\ 2 =:= 0, + solve_bound(Lin,Bound) + ) + ; true % equal to upperbound and non-strict: keep + % smaller than upperbound: check lowerbound + ). + +% uius(Type,X,Lin,Bound,Strict) +% +% Updates upper bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. (see also uiu/5) + +uius(t_none,X,_Lin,Bound,_Sold) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(1)). +uius(t_u(U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true + ; TestUB > 1.0e-10 + -> Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_u(Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_l(L),X,_Lin,Bound,Sold) :- + Bound - L > 1.0e-10, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)). +uius(t_L(L),X,_Lin,Bound,Sold) :- + Bound - L > 1.0e-10, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))), + setarg(3,Att,strictness(Strict)). +uius(t_lu(L,U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true + ; TestUB > 1.0e-10 + -> Bound - L > 1.0e-10, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_Lu(L,U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true + ; TestUB > 1.0e-10 + -> Bound - L > 1.0e-10, + Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_Lu(L,Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_U(U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true + ; TestUB > 1.0e-10 + -> Strict is Sold \/ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound - (Lb + U) < 1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_U(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_u(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_U(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uius(t_lU(L,U),X,_Lin,Bound,Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> true + ; TestUB > 1.0e-10 + -> Bound - L > 1.0e-10, + Strict is Sold \/ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + lb(ClassX,OrdX,Vlb-Vb-Lb), + Bound - (Lb + U) < 1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_lU(L,Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vlb,X,Vb,t_lu(L,Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_lU(L,Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - U, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 1, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% uil(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new non-strict +% bound Bound. (see also uiu/5) + + +uil(t_none,X,_Lin,Bound,_Sold) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(0)). +uil(t_l(L),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)) + ; true + ). +uil(t_u(U),X,Lin,Bound,_Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail + ; TestUB > 1.0e-10 + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))) + ; solve_bound(Lin,Bound) + ). +uil(t_U(U),X,Lin,Bound,_Sold) :- + TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail + ; TestUB > 1.0e-10 + -> get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))) + ; solve_bound(Lin,Bound) + ). +uil(t_lu(L,U),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail + ; TestUB > 1.0e-10 + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uil(t_lU(L,U),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail + ; TestUB > 1.0e-10 + -> Strict is Sold /\ 1, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). +uil(t_L(L),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> Strict is Sold /\ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound - (Ub + L) > -1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_L(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_l(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_L(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; true + ). +uil(t_Lu(L,U),X,Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> TestUB is U - Bound, + ( TestUB < -1.0e-10 + -> fail + ; TestUB > 1.0e-10 + -> Strict is Sold /\ 1, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound - (Ub + L) > -1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,t_Lu(Bound,U)), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_lu(Bound,U)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_Lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Sold /\ 1 =:= 0, + solve_bound(Lin,Bound) + ) + ; true + ). + +% uils(Type,X,Lin,Bound,Strict) +% +% Updates lower bound of independent variable X with linear equation +% Lin that had type Type and strictness Strict, to the new strict +% bound Bound. (see also uiu/5) + +uils(t_none,X,_Lin,Bound,_Sold) :- + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(2)). +uils(t_l(L),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_l(Bound))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_u(U),X,_Lin,Bound,Sold) :- + U - Bound > 1.0e-10, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)). +uils(t_U(U),X,_Lin,Bound,Sold) :- + U - Bound > 1.0e-10, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))), + setarg(3,Att,strictness(Strict)). +uils(t_lu(L,U),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> U - Bound > 1.0e-10, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lu(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_lU(L,U),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> U - Bound > 1.0e-10, + Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(2,Att,type(t_lU(Bound,U))), + setarg(3,Att,strictness(Strict)) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_L(L),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> Strict is Sold \/ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound - (Ub + L) > -1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_L(Bound))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_l(Bound)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_L(Bound))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). +uils(t_Lu(L,U),X,_Lin,Bound,Sold) :- + TestBL is Bound - L, + ( TestBL < -1.0e-10 + -> true + ; TestBL > 1.0e-10 + -> U - Bound > 1.0e-10, + Strict is Sold \/ 2, + ( get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + ub(ClassX,OrdX,Vub-Vb-Ub), + Bound - (Ub + L) > -1.0e-10 + -> get_attr(X,itf,Att2), % changed? + setarg(2,Att2,type(t_Lu(Bound,U))), + setarg(3,Att2,strictness(Strict)), + pivot_a(Vub,X,Vb,t_lu(Bound,U)), + reconsider(X) + ; get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), + arg(6,Att,class(ClassX)), + setarg(2,Att,type(t_Lu(Bound,U))), + setarg(3,Att,strictness(Strict)), + Delta is Bound - L, + backsubst_delta(ClassX,OrdX,X,Delta) + ) + ; Strict is Sold \/ 2, + get_attr(X,itf,Att), + setarg(3,Att,strictness(Strict)) + ). + +% reconsider_upper(X,Lin,U) +% +% Checks if the upperbound of X which is U, satisfies the bounds +% of the variables in Lin: let R be the sum of all the bounds on +% the variables in Lin, and I be the inhomogene part of Lin, then +% upperbound U should be larger or equal to R + I (R may contain +% lowerbounds). +% See also rcb/3 in bv.pl + +reconsider_upper(X,[I,R|H],U) :- + R + I - U > -1.0e-10, % violation + !, + dec_step(H,Status), % we want to decrement R + rcbl_status(Status,X,[],Binds,[],u(U)), + export_binding(Binds). +reconsider_upper( _, _, _). + +% reconsider_lower(X,Lin,L) +% +% Checks if the lowerbound of X which is L, satisfies the bounds +% of the variables in Lin: let R be the sum of all the bounds on +% the variables in Lin, and I be the inhomogene part of Lin, then +% lowerbound L should be smaller or equal to R + I (R may contain +% upperbounds). +% See also rcb/3 in bv.pl + +reconsider_lower(X,[I,R|H],L) :- + R + I - L < 1.0e-10, % violation + !, + inc_step(H,Status), % we want to increment R + rcbl_status(Status,X,[],Binds,[],l(L)), + export_binding(Binds). +reconsider_lower(_,_,_). + +% +% lin is dereferenced +% + +% solve_bound(Lin,Bound) +% +% Solves the linear equation Lin - Bound = 0 +% Lin is the linear equation of X, a variable whose bounds have narrowed to value Bound + +solve_bound(Lin,Bound) :- + Bound >= -1.0e-10, + Bound =< 1.0e-10, + !, + solve(Lin). +solve_bound(Lin,Bound) :- + Nb is -Bound, + normalize_scalar(Nb,Nbs), + add_linear_11(Nbs,Lin,Eq), + solve(Eq). diff --git a/packages/clpqr/clpr/itf_r.pl b/packages/clpqr/clpr/itf_r.pl new file mode 100644 index 000000000..753e2037b --- /dev/null +++ b/packages/clpqr/clpr/itf_r.pl @@ -0,0 +1,227 @@ +/* + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(itf_r, + [ + do_checks/8 + ]). +:- use_module(bv_r, + [ + deref/2, + detach_bounds_vlv/5, + solve/1, + solve_ord_x/3 + ]). +:- use_module(nf_r, + [ + nf/2 + ]). +:- use_module(store_r, + [ + add_linear_11/3, + indep/2, + nf_coeff_of/3 + ]). +:- use_module('../clpqr/class', + [ + class_drop/2 + ]). + +do_checks(Y,Ty,St,Li,Or,Cl,No,Later) :- + numbers_only(Y), + verify_nonzero(No,Y), + verify_type(Ty,St,Y,Later,[]), + verify_lin(Or,Cl,Li,Y), + maplist(call,Later). + +numbers_only(Y) :- + ( var(Y) + ; integer(Y) + ; float(Y) + ; throw(type_error(_X = Y,2,'a real number',Y)) + ), + !. + +% verify_nonzero(Nonzero,Y) +% +% if Nonzero = nonzero, then verify that Y is not zero +% (if possible, otherwise set Y to be nonzero) + +verify_nonzero(nonzero,Y) :- + ( var(Y) + -> ( get_attr(Y,itf,Att) + -> setarg(8,Att,nonzero) + ; put_attr(Y,itf,t(clpr,n,n,n,n,n,n,nonzero,n,n,n)) + ) + ; ( Y < -1.0e-10 + -> true + ; Y > 1.0e-10 + ) + ). +verify_nonzero(n,_). % X is not nonzero + +% verify_type(type(Type),strictness(Strict),Y,[OL|OLT],OLT) +% +% if possible verifies whether Y satisfies the type and strictness of X +% if not possible to verify, then returns the constraints that follow from +% the type and strictness + +verify_type(type(Type),strictness(Strict),Y) --> + verify_type2(Y,Type,Strict). +verify_type(n,n,_) --> []. + +verify_type2(Y,TypeX,StrictX) --> + {var(Y)}, + !, + verify_type_var(TypeX,Y,StrictX). +verify_type2(Y,TypeX,StrictX) --> + {verify_type_nonvar(TypeX,Y,StrictX)}. + +% verify_type_nonvar(Type,Nonvar,Strictness) +% +% verifies whether the type and strictness are satisfied with the Nonvar + +verify_type_nonvar(t_none,_,_). +verify_type_nonvar(t_l(L),Value,S) :- ilb(S,L,Value). +verify_type_nonvar(t_u(U),Value,S) :- iub(S,U,Value). +verify_type_nonvar(t_lu(L,U),Value,S) :- + ilb(S,L,Value), + iub(S,U,Value). +verify_type_nonvar(t_L(L),Value,S) :- ilb(S,L,Value). +verify_type_nonvar(t_U(U),Value,S) :- iub(S,U,Value). +verify_type_nonvar(t_Lu(L,U),Value,S) :- + ilb(S,L,Value), + iub(S,U,Value). +verify_type_nonvar(t_lU(L,U),Value,S) :- + ilb(S,L,Value), + iub(S,U,Value). + +% ilb(Strict,Lower,Value) & iub(Strict,Upper,Value) +% +% check whether Value is satisfiable with the given lower/upper bound and +% strictness. +% strictness is encoded as follows: +% 2 = strict lower bound +% 1 = strict upper bound +% 3 = strict lower and upper bound +% 0 = no strict bounds + +ilb(S,L,V) :- + S /\ 2 =:= 0, + !, + L - V < 1.0e-10. % non-strict +ilb(_,L,V) :- L - V < -1.0e-10. % strict + +iub(S,U,V) :- + S /\ 1 =:= 0, + !, + V - U < 1.0e-10. % non-strict +iub(_,U,V) :- V - U < -1.0e-10. % strict + +% +% Running some goals after X=Y simplifies the coding. It should be possible +% to run the goals here and taking care not to put_atts/2 on X ... +% + +% verify_type_var(Type,Var,Strictness,[OutList|OutListTail],OutListTail) +% +% returns the inequalities following from a type and strictness satisfaction +% test with Var + +verify_type_var(t_none,_,_) --> []. +verify_type_var(t_l(L),Y,S) --> llb(S,L,Y). +verify_type_var(t_u(U),Y,S) --> lub(S,U,Y). +verify_type_var(t_lu(L,U),Y,S) --> + llb(S,L,Y), + lub(S,U,Y). +verify_type_var(t_L(L),Y,S) --> llb(S,L,Y). +verify_type_var(t_U(U),Y,S) --> lub(S,U,Y). +verify_type_var(t_Lu(L,U),Y,S) --> + llb(S,L,Y), + lub(S,U,Y). +verify_type_var(t_lU(L,U),Y,S) --> + llb(S,L,Y), + lub(S,U,Y). + +% llb(Strict,Lower,Value,[OL|OLT],OLT) and lub(Strict,Upper,Value,[OL|OLT],OLT) +% +% returns the inequalities following from the lower and upper bounds and the +% strictness see also lb and ub +llb(S,L,V) --> + {S /\ 2 =:= 0}, + !, + [clpr:{L =< V}]. +llb(_,L,V) --> [clpr:{L < V}]. + +lub(S,U,V) --> + {S /\ 1 =:= 0}, + !, + [clpr:{V =< U}]. +lub(_,U,V) --> [clpr:{V < U}]. + +% +% We used to drop X from the class/basis to avoid trouble with subsequent +% put_atts/2 on X. Now we could let these dead but harmless updates happen. +% In R however, exported bindings might conflict, e.g. 0 \== 0.0 +% +% If X is indep and we do _not_ solve for it, we are in deep shit +% because the ordering is violated. +% +verify_lin(order(OrdX),class(Class),lin(LinX),Y) :- + !, + ( indep(LinX,OrdX) + -> detach_bounds_vlv(OrdX,LinX,Class,Y,NewLinX), + % if there were bounds, they are requeued already + class_drop(Class,Y), + nf(-Y,NfY), + deref(NfY,LinY), + add_linear_11(NewLinX,LinY,Lind), + ( nf_coeff_of(Lind,OrdX,_) + -> % X is element of Lind + solve_ord_x(Lind,OrdX,Class) + ; solve(Lind) % X is gone, can safely solve Lind + ) + ; class_drop(Class,Y), + nf(-Y,NfY), + deref(NfY,LinY), + add_linear_11(LinX,LinY,Lind), + solve(Lind) + ). +verify_lin(_,_,_,_). \ No newline at end of file diff --git a/packages/clpqr/clpr/nf_r.pl b/packages/clpqr/clpr/nf_r.pl new file mode 100644 index 000000000..8c0b57e19 --- /dev/null +++ b/packages/clpqr/clpr/nf_r.pl @@ -0,0 +1,1205 @@ +/* + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +/** @pred split(+ _Line_,+ _Separators_,- _Split_) + + + +Unify _Words_ with a set of strings obtained from _Line_ by +using the character codes in _Separators_ as separators. As an +example, consider: + +~~~~~{.prolog} +?- split("Hello * I am free"," *",S). + +S = ["Hello","I","am","free"] ? + +no +~~~~~ + + +*/ +:- module(nf_r, + [ + {}/1, + nf/2, + entailed/1, + split/3, + repair/2, + nf_constant/2, + wait_linear/3, + nf2term/2 + ]). + +:- use_module('../clpqr/geler', + [ + geler/3 + ]). +:- use_module(bv_r, + [ + export_binding/2, + log_deref/4, + solve/1, + 'solve_<'/1, + 'solve_=<'/1, + 'solve_=\\='/1 + ]). +:- use_module(ineq_r, + [ + ineq_one/4, + ineq_one_s_p_0/1, + ineq_one_s_n_0/1, + ineq_one_n_p_0/1, + ineq_one_n_n_0/1 + ]). +:- use_module(store_r, + [ + add_linear_11/3, + normalize_scalar/2 + ]). + +goal_expansion(geler(X,Y),geler(clpr,X,Y)). + +% ------------------------------------------------------------------------- + +% {Constraint} +% +% Adds the constraint Constraint to the constraint store. +% +% First rule is to prevent binding with other rules when a variable is input +% Constraints are converted to normal form and if necessary, submitted to the linear +% equality/inequality solver (bv + ineq) or to the non-linear store (geler) + +{Rel} :- + var(Rel), + !, + throw(instantiation_error({Rel},1)). +{R,Rs} :- + !, + {R},{Rs}. +{R;Rs} :- + !, + ({R};{Rs}). % for entailment checking +{L < R} :- + !, + nf(L-R,Nf), + submit_lt(Nf). +{L > R} :- + !, + nf(R-L,Nf), + submit_lt(Nf). +{L =< R} :- + !, + nf(L-R,Nf), + submit_le( Nf). +{<=(L,R)} :- + !, + nf(L-R,Nf), + submit_le(Nf). +{L >= R} :- + !, + nf(R-L,Nf), + submit_le(Nf). +{L =\= R} :- + !, + nf(L-R,Nf), + submit_ne(Nf). +{L =:= R} :- + !, + nf(L-R,Nf), + submit_eq(Nf). +{L = R} :- + !, + nf(L-R,Nf), + submit_eq(Nf). +{Rel} :- throw(type_error({Rel},1,'a constraint',Rel)). + +% entailed(C) +% +% s -> c = ~s v c = ~(s /\ ~c) +% where s is the store and c is the constraint for which +% we want to know whether it is entailed. +% C is negated and added to the store. If this fails, then c is entailed by s + +entailed(C) :- + negate(C,Cn), + \+ {Cn}. + +% negate(C,Res). +% +% Res is the negation of constraint C +% first rule is to prevent binding with other rules when a variable is input + +negate(Rel,_) :- + var(Rel), + !, + throw(instantiation_error(entailed(Rel),1)). +negate((A,B),(Na;Nb)) :- + !, + negate(A,Na), + negate(B,Nb). +negate((A;B),(Na,Nb)) :- + !, + negate(A,Na), + negate(B,Nb). +negate(A=B) :- !. +negate(A>B,A=B) :- !. +negate(A>=B,A A = 0 +% b4) nonlinear -> geler +% c) Nf=[A,B|Rest] +% c1) A=k +% c11) (B=c*X^+1 or B=c*X^-1), Rest=[] -> B=-k/c or B=-c/k +% c12) invertible(A,B) +% c13) linear(B|Rest) +% c14) geler +% c2) linear(Nf) +% c3) nonlinear -> geler + +submit_eq([]). % trivial success: case a +submit_eq([T|Ts]) :- + submit_eq(Ts,T). +submit_eq([],A) :- submit_eq_b(A). % case b +submit_eq([B|Bs],A) :- submit_eq_c(A,B,Bs). % case c + +% submit_eq_b(A) +% +% Handles case b of submit_eq/1 + +% case b1: A is a constant (non-zero) +submit_eq_b(v(_,[])) :- + !, + fail. +% case b2/b3: A is n*X^P => X = 0 +submit_eq_b(v(_,[X^P])) :- + var(X), + P > 0, + !, + export_binding(X,0.0). +% case b2: non-linear is invertible: NL(X) = 0 => X - inv(NL)(0) = 0 +submit_eq_b(v(_,[NL^1])) :- + nonvar(NL), + nl_invertible(NL,X,0.0,Inv), + !, + nf(-Inv,S), + nf_add(X,S,New), + submit_eq(New). +% case b4: A is non-linear and not invertible => submit equality to geler +submit_eq_b(Term) :- + term_variables(Term,Vs), + geler(Vs,nf_r:resubmit_eq([Term])). + +% submit_eq_c(A,B,Rest) +% +% Handles case c of submit_eq/1 + +% case c1: A is a constant +submit_eq_c(v(I,[]),B,Rest) :- + !, + submit_eq_c1(Rest,B,I). +% case c2: A,B and Rest are linear +submit_eq_c(A,B,Rest) :- % c2 + A = v(_,[X^1]), + var(X), + B = v(_,[Y^1]), + var(Y), + linear(Rest), + !, + Hom = [A,B|Rest], + % 'solve_='(Hom). + nf_length(Hom,0,Len), + log_deref(Len,Hom,[],HomD), + solve(HomD). +% case c3: A, B or Rest is non-linear => geler +submit_eq_c(A,B,Rest) :- + Norm = [A,B|Rest], + term_variables(Norm,Vs), + geler(Vs,nf_r:resubmit_eq(Norm)). + +% submit_eq_c1(Rest,B,K) +% +% Handles case c1 of submit_eq/1 + +% case c11a: +% i+kX^p=0 if p is an odd integer +% special case: one solution if P is negativ but also for a negative X +submit_eq_c1([], v(K,[X^P]), I) :- + var(X), + P =\= 0, + 0 > (-I/K), + integer(P) =:= P, + 1 =:= integer(P) mod 2, + !, + Val is -((I/K) ** (1/P)), + export_binding(X,Val). +% case c11b: +% i+kX^p=0 for p =\= 0, integer(P) =:= P +% special case: generate 2 solutions if p is a positive even integer +submit_eq_c1([], v(K,[X^P]), I) :- + var(X), + P =\= 0, + 0 =< (-I/K), + integer(P) =:= P, + 0 =:= integer(P) mod 2, + !, + Val is (-I/K) ** (1/P), + ( export_binding(X,Val) + ; + ValNeg is -Val, + export_binding(X, ValNeg) + ). +% case c11c: +% i+kX^p=0 for p =\= 0, 0 =< (-I/K) +submit_eq_c1([], v(K,[X^P]), I) :- + var(X), + P =\= 0, + 0 =< (-I/K), + !, + Val is (-I/K) ** (1/P), + export_binding(X,Val). +% case c11d: fail if var(X) and none of the above. +submit_eq_c1([], v(_K,[X^_P]), _I) :- + var(X), + !, + fail. +% case c11e: fail for { -25 = _X^2.5 } and { -25 = _X^(-2.5) } and may be others! +% if you uncomment this case { -25 = _X^2.5 } throw an error(evaluation_error(undefined)) +% and { -25 = _X^(-2.5) } succeed with an unbound X +submit_eq_c1([], v(K,[X^P]), I) :- + nonvar(X), + X = exp(_,_), % TLS added 03/12 + 1 =:= abs(P), + 0 >= I, + 0 >= K, + !, + fail. +% case c12: non-linear, invertible: cNL(X)^1+k=0 => inv(NL)(-k/c) = 0 ; +% cNL(X)^-1+k=0 => inv(NL)(-c/k) = 0 +submit_eq_c1([],v(K,[NL^P]),I) :- + nonvar(NL), + ( P =:= 1, + Y is -I/K + ; P =:= -1, + Y is -K/I + ), + nl_invertible(NL,X,Y,Inv), + !, + nf(-Inv,S), + nf_add(X,S,New), + submit_eq(New). +% case c13: linear: X + Y + Z + c = 0 => +submit_eq_c1(Rest,B,I) :- + B = v(_,[Y^1]), + var(Y), + linear(Rest), + !, + % 'solve_='( [v(I,[]),B|Rest]). + Hom = [B|Rest], + nf_length(Hom,0,Len), + normalize_scalar(I,Nonvar), + log_deref(Len,Hom,[],HomD), + add_linear_11(Nonvar,HomD,LinD), + solve(LinD). +% case c14: other cases => geler +submit_eq_c1(Rest,B,I) :- + Norm = [v(I,[]),B|Rest], + term_variables(Norm,Vs), + geler(Vs,nf_r:resubmit_eq(Norm)). + +% ----------------------------------------------------------------------- + +% submit_lt(Nf) +% +% Submits the inequality Nf<0 to the constraint store, where Nf is in normal form. + +% 0 < 0 => fail +submit_lt([]) :- fail. +% A + B < 0 +submit_lt([A|As]) :- submit_lt(As,A). + +% submit_lt(As,A) +% +% Does what submit_lt/1 does where Nf = [A|As] + +% v(K,P) < 0 +submit_lt([],v(K,P)) :- submit_lt_b(P,K). +% A + B + Bs < 0 +submit_lt([B|Bs],A) :- submit_lt_c(Bs,A,B). + +% submit_lt_b(P,K) +% +% Does what submit_lt/2 does where A = [v(K,P)] and As = [] + +% c < 0 +submit_lt_b([],I) :- + !, + I < -1.0e-10. +% cX^1 < 0 : if c < 0 then X > 0, else X < 0 +submit_lt_b([X^1],K) :- + var(X), + !, + ( K > 1.0e-10 + -> ineq_one_s_p_0(X) % X is strictly negative + ; ineq_one_s_n_0(X) % X is strictly positive + ). +% non-linear => geler +submit_lt_b(P,K) :- + term_variables(P,Vs), + geler(Vs,nf_r:resubmit_lt([v(K,P)])). + +% submit_lt_c(Bs,A,B) +% +% Does what submit_lt/2 does where As = [B|Bs]. + +% c + kX < 0 => kX < c +submit_lt_c([],A,B) :- + A = v(I,[]), + B = v(K,[Y^1]), + var(Y), + !, + ineq_one(strict,Y,K,I). +% linear < 0 => solve, non-linear < 0 => geler +submit_lt_c(Rest,A,B) :- + Norm = [A,B|Rest], + ( linear(Norm) + -> 'solve_<'(Norm) + ; term_variables(Norm,Vs), + geler(Vs,nf_r:resubmit_lt(Norm)) + ). + +% submit_le(Nf) +% +% Submits the inequality Nf =< 0 to the constraint store, where Nf is in normal form. +% See also submit_lt/1 + +% 0 =< 0 => success +submit_le([]). +% A + B =< 0 +submit_le([A|As]) :- submit_le(As,A). + +% submit_le(As,A) +% +% See submit_lt/2. This handles less or equal. + +% v(K,P) =< 0 +submit_le([],v(K,P)) :- submit_le_b(P,K). +% A + B + Bs =< 0 +submit_le([B|Bs],A) :- submit_le_c(Bs,A,B). + +% submit_le_b(P,K) +% +% See submit_lt_b/2. This handles less or equal. + +% c =< 0 +submit_le_b([],I) :- + !, + I < 1.0e-10. +% cX^1 =< 0: if c < 0 then X >= 0, else X =< 0 +submit_le_b([X^1],K) :- + var(X), + !, + ( K > 1.0e-10 + -> ineq_one_n_p_0(X) % X is non-strictly negative + ; ineq_one_n_n_0(X) % X is non-strictly positive + ). +% cX^P =< 0 => geler +submit_le_b(P,K) :- + term_variables(P,Vs), + geler(Vs,nf_r:resubmit_le([v(K,P)])). + +% submit_le_c(Bs,A,B) +% +% See submit_lt_c/3. This handles less or equal. + +% c + kX^1 =< 0 => kX =< 0 +submit_le_c([],A,B) :- + A = v(I,[]), + B = v(K,[Y^1]), + var(Y), + !, + ineq_one(nonstrict,Y,K,I). +% A, B & Rest are linear => solve, otherwise => geler +submit_le_c(Rest,A,B) :- + Norm = [A,B|Rest], + ( linear(Norm) + -> 'solve_=<'(Norm) + ; term_variables(Norm,Vs), + geler(Vs,nf_r:resubmit_le(Norm)) + ). + +% submit_ne(Nf) +% +% Submits the inequality Nf =\= 0 to the constraint store, where Nf is in normal form. +% if Nf is a constant => check constant = 0, else if Nf is linear => solve else => geler + +submit_ne(Norm1) :- + ( nf_constant(Norm1,K) + -> \+ (K >= -1.0e-10, K =< 1.0e-10) % K =\= 0 + ; linear(Norm1) + -> 'solve_=\\='(Norm1) + ; term_variables(Norm1,Vs), + geler(Vs,nf_r:resubmit_ne(Norm1)) + ). + +% linear(A) +% +% succeeds when A is linear: all elements are of the form v(_,[]) or v(_,[X^1]) + +linear([]). +linear(v(_,Ps)) :- linear_ps(Ps). +linear([A|As]) :- + linear(A), + linear(As). + +% linear_ps(A) +% +% Succeeds when A = V^1 with V a variable. +% This reflects the linearity of v(_,A). + +linear_ps([]). +linear_ps([V^1]) :- var(V). % excludes sin(_), ... + +% +% Goal delays until Term gets linear. +% At this time, Var will be bound to the normalform of Term. +% +:- meta_predicate wait_linear( ?, ?, :). +% +wait_linear(Term,Var,Goal) :- + nf(Term,Nf), + ( linear(Nf) + -> Var = Nf, + call(Goal) + ; term_variables(Nf,Vars), + geler(Vars,nf_r:wait_linear_retry(Nf,Var,Goal)) + ). +% +% geler clients +% +resubmit_eq(N) :- + repair(N,Norm), + submit_eq(Norm). +resubmit_lt(N) :- + repair(N,Norm), + submit_lt(Norm). +resubmit_le(N) :- + repair(N,Norm), + submit_le(Norm). +resubmit_ne(N) :- + repair(N,Norm), + submit_ne(Norm). +wait_linear_retry(Nf0,Var,Goal) :- + repair(Nf0,Nf), + ( linear(Nf) + -> Var = Nf, + call(Goal) + ; term_variables(Nf,Vars), + geler(Vars,nf_r:wait_linear_retry(Nf,Var,Goal)) + ). +% ----------------------------------------------------------------------- + +% nl_invertible(F,X,Y,Res) +% +% Res is the evaluation of the inverse of nonlinear function F in variable X +% where X is Y + +nl_invertible(sin(X),X,Y,Res) :- Res is asin(Y). +nl_invertible(cos(X),X,Y,Res) :- Res is acos(Y). +nl_invertible(tan(X),X,Y,Res) :- Res is atan(Y). +nl_invertible(exp(B,C),X,A,Res) :- + ( nf_constant(B,Kb) + -> A > 1.0e-10, + Kb > 1.0e-10, + TestKb is Kb - 1.0, % Kb =\= 1.0 + \+ (TestKb >= -1.0e-10, TestKb =< 1.0e-10), + X = C, % note delayed unification + Res is log(A)/log(Kb) + ; nf_constant(C,Kc), + \+ (A >= -1.0e-10, A =< 1.0e-10), % A =\= 0 + Kc > 1.0e-10, % Kc > 0 + X = B, % note delayed unification + Res is A**(1.0/Kc) + ). + +% ----------------------------------------------------------------------- + +% nf(Exp,Nf) +% +% Returns in Nf, the normal form of expression Exp +% +% v(A,[B^C,D^E|...]) means A*B^C*D^E*... where A is a scalar (number) +% v(A,[]) means scalar A + +% variable X => 1*X^1 +nf(X,Norm) :- + var(X), + !, + Norm = [v(1.0,[X^1])]. +nf(X,Norm) :- + number(X), + !, + nf_number(X,Norm). +% +nf(#(Const),Norm) :- + monash_constant(Const,Value), + !, + Norm = [v(Value,[])]. +% +nf(-A,Norm) :- + !, + nf(A,An), + nf_mul_factor(v(-1.0,[]),An,Norm). +nf(+A,Norm) :- + !, + nf(A,Norm). +% +nf(A+B,Norm) :- + !, + nf(A,An), + nf(B,Bn), + nf_add(An,Bn,Norm). +nf(A-B,Norm) :- + !, + nf(A,An), + nf(-B,Bn), + nf_add(An,Bn,Norm). +% +nf(A*B,Norm) :- + !, + nf(A,An), + nf(B,Bn), + nf_mul(An,Bn,Norm). +nf(A/B,Norm) :- + !, + nf(A,An), + nf(B,Bn), + nf_div(Bn,An,Norm). +% non-linear function, one argument: Term = f(Arg) equals f'(Sa1) = Skel +nf(Term,Norm) :- + nonlin_1(Term,Arg,Skel,Sa1), + !, + nf(Arg,An), + nf_nonlin_1(Skel,An,Sa1,Norm). +% non-linear function, two arguments: Term = f(A1,A2) equals f'(Sa1,Sa2) = Skel +nf(Term,Norm) :- + nonlin_2(Term,A1,A2,Skel,Sa1,Sa2), + !, + nf(A1,A1n), + nf(A2,A2n), + nf_nonlin_2(Skel,A1n,A2n,Sa1,Sa2,Norm). +% +nf(Term,_) :- + throw(type_error(nf(Term,_),1,'a numeric expression',Term)). + +% nf_number(N,Res) +% +% If N is a number, N is normalized + +nf_number(N,Res) :- + number(N), + ( (N >= -1.0e-10, N =< 1.0e-10) % N =:= 0 + -> Res = [] + ; Res = [v(N,[])] + ). + +nonlin_1(abs(X),X,abs(Y),Y). +nonlin_1(sin(X),X,sin(Y),Y). +nonlin_1(cos(X),X,cos(Y),Y). +nonlin_1(tan(X),X,tan(Y),Y). +nonlin_2(min(A,B),A,B,min(X,Y),X,Y). +nonlin_2(max(A,B),A,B,max(X,Y),X,Y). +nonlin_2(exp(A,B),A,B,exp(X,Y),X,Y). +nonlin_2(pow(A,B),A,B,exp(X,Y),X,Y). % pow->exp +nonlin_2(A^B,A,B,exp(X,Y),X,Y). + +nf_nonlin_1(Skel,An,S1,Norm) :- + ( nf_constant(An,S1) + -> nl_eval(Skel,Res), + nf_number(Res,Norm) + ; S1 = An, + Norm = [v(1.0,[Skel^1])]). +nf_nonlin_2(Skel,A1n,A2n,S1,S2,Norm) :- + ( nf_constant(A1n,S1), + nf_constant(A2n,S2) + -> nl_eval(Skel,Res), + nf_number(Res,Norm) + ; Skel=exp(_,_), + nf_constant(A2n,Exp), + integerp(Exp,I) + -> nf_power(I,A1n,Norm) + ; S1 = A1n, + S2 = A2n, + Norm = [v(1.0,[Skel^1])] + ). + +% evaluates non-linear functions in one variable where the variable is bound +nl_eval(abs(X),R) :- R is abs(X). +nl_eval(sin(X),R) :- R is sin(X). +nl_eval(cos(X),R) :- R is cos(X). +nl_eval(tan(X),R) :- R is tan(X). +% evaluates non-linear functions in two variables where both variables are +% bound +nl_eval(min(X,Y),R) :- R is min(X,Y). +nl_eval(max(X,Y),R) :- R is max(X,Y). +nl_eval(exp(X,Y),R) :- R is X**Y. + +monash_constant(X,_) :- + var(X), + !, + fail. +monash_constant(p,3.14259265). +monash_constant(pi,3.14259265). +monash_constant(e,2.71828182). +monash_constant(zero,1.0e-10). + +% +% check if a Nf consists of just a constant +% + +nf_constant([],0.0). +nf_constant([v(K,[])],K). + +% split(NF,SNF,C) +% +% splits a normalform expression NF into two parts: +% - a constant term C (which might be 0) +% - the homogene part of the expression +% +% this method depends on the polynf ordering, i.e. [] < [X^1] ... + +split([],[],0.0). +split([First|T],H,I) :- + ( First = v(I,[]) + -> H = T + ; I = 0.0, + H = [First|T] + ). + +% nf_add(A,B,C): merges two normalized additions into a new normalized addition +% +% a normalized addition is one where the terms are ordered, e.g. X^1 < Y^1, X^1 < X^2 etc. +% terms in the same variable with the same exponent are added, +% e.g. when A contains v(5,[X^1]) and B contains v(4,[X^1]) then C contains v(9,[X^1]). + +nf_add([],Bs,Bs). +nf_add([A|As],Bs,Cs) :- nf_add(Bs,A,As,Cs). + +nf_add([],A,As,Cs) :- Cs = [A|As]. +nf_add([B|Bs],A,As,Cs) :- + A = v(Ka,Pa), + B = v(Kb,Pb), + compare(Rel,Pa,Pb), + nf_add_case(Rel,A,As,Cs,B,Bs,Ka,Kb,Pa). + +% nf_add_case(Rel,A,As,Cs,B,Bs,Ka,Kb,Pa) +% +% merges sorted lists [A|As] and [B|Bs] into new sorted list Cs +% A = v(Ka,Pa) and B = v(Kb,_) +% Rel is the ordering relation (<, > or =) between A and B. +% when Rel is =, Ka and Kb are added to form a new scalar for Pa +nf_add_case(<,A,As,Cs,B,Bs,_,_,_) :- + Cs = [A|Rest], + nf_add(As,B,Bs,Rest). +nf_add_case(>,A,As,Cs,B,Bs,_,_,_) :- + Cs = [B|Rest], + nf_add(Bs,A,As,Rest). +nf_add_case(=,_,As,Cs,_,Bs,Ka,Kb,Pa) :- + Kc is Ka + Kb, + ( (Kc >= -1.0e-10, Kc =< 1.0e-10) % Kc =:= 0.0 + -> nf_add(As,Bs,Cs) + ; Cs = [v(Kc,Pa)|Rest], + nf_add(As,Bs,Rest) + ). + +nf_mul(A,B,Res) :- + nf_length(A,0,LenA), + nf_length(B,0,LenB), + nf_mul_log(LenA,A,[],LenB,B,Res). + +nf_mul_log(0,As,As,_,_,[]) :- !. +nf_mul_log(1,[A|As],As,Lb,B,R) :- + !, + nf_mul_factor_log(Lb,B,[],A,R). +nf_mul_log(2,[A1,A2|As],As,Lb,B,R) :- + !, + nf_mul_factor_log(Lb,B,[],A1,A1b), + nf_mul_factor_log(Lb,B,[],A2,A2b), + nf_add(A1b,A2b,R). +nf_mul_log(N,A0,A2,Lb,B,R) :- + P is N>>1, + Q is N-P, + nf_mul_log(P,A0,A1,Lb,B,Rp), + nf_mul_log(Q,A1,A2,Lb,B,Rq), + nf_add(Rp,Rq,R). + + +% nf_add_2: does the same thing as nf_add, but only has 2 elements to combine. +nf_add_2(Af,Bf,Res) :- % unfold: nf_add([Af],[Bf],Res). + Af = v(Ka,Pa), + Bf = v(Kb,Pb), + compare(Rel,Pa,Pb), + nf_add_2_case(Rel,Af,Bf,Res,Ka,Kb,Pa). + +nf_add_2_case(<,Af,Bf,[Af,Bf],_,_,_). +nf_add_2_case(>,Af,Bf,[Bf,Af],_,_,_). +nf_add_2_case(=,_, _,Res,Ka,Kb,Pa) :- + Kc is Ka + Kb, + ( (Kc >= -1.0e-10, Kc =< 1.0e-10) % Kc =:= 0 + -> Res = [] + ; Res = [v(Kc,Pa)] + ). + +% nf_mul_k(A,B,C) +% +% C is the result of the multiplication of each element of A (of the form v(_,_)) with scalar B (which shouldn't be 0) +nf_mul_k([],_,[]). +nf_mul_k([v(I,P)|Vs],K,[v(Ki,P)|Vks]) :- + Ki is K*I, + nf_mul_k(Vs,K,Vks). + +% nf_mul_factor(A,Sum,Res) +% +% multiplies each element of the list Sum with factor A which is of the form v(_,_) +% and puts the result in the sorted list Res. +nf_mul_factor(v(K,[]),Sum,Res) :- + !, + nf_mul_k(Sum,K,Res). +nf_mul_factor(F,Sum,Res) :- + nf_length(Sum,0,Len), + nf_mul_factor_log(Len,Sum,[],F,Res). + +% nf_mul_factor_log(Len,[Sum|SumTail],SumTail,F,Res) +% +% multiplies each element of Sum with F and puts the result in the sorted list Res +% Len is the length of Sum +% Sum is split logarithmically each step + +nf_mul_factor_log(0,As,As,_,[]) :- !. +nf_mul_factor_log(1,[A|As],As,F,[R]) :- + !, + mult(A,F,R). +nf_mul_factor_log(2,[A,B|As],As,F,Res) :- + !, + mult(A,F,Af), + mult(B,F,Bf), + nf_add_2(Af,Bf,Res). +nf_mul_factor_log(N,A0,A2,F,R) :- + P is N>>1, % P is rounded(N/2) + Q is N-P, + nf_mul_factor_log(P,A0,A1,F,Rp), + nf_mul_factor_log(Q,A1,A2,F,Rq), + nf_add(Rp,Rq,R). + +% mult(A,B,C) +% +% multiplies A and B into C each of the form v(_,_) + +mult(v(Ka,La),v(Kb,Lb),v(Kc,Lc)) :- + Kc is Ka*Kb, + pmerge(La,Lb,Lc). + +% pmerge(A,B,C) +% +% multiplies A and B into sorted C, where each is of the form of the second argument of v(_,_) + +pmerge([],Bs,Bs). +pmerge([A|As],Bs,Cs) :- pmerge(Bs,A,As,Cs). + +pmerge([],A,As,Res) :- Res = [A|As]. +pmerge([B|Bs],A,As,Res) :- + A = Xa^Ka, + B = Xb^Kb, + compare(R,Xa,Xb), + pmerge_case(R,A,As,Res,B,Bs,Ka,Kb,Xa). + +% pmerge_case(Rel,A,As,Res,B,Bs,Ka,Kb,Xa) +% +% multiplies and sorts [A|As] with [B|Bs] into Res where each is of the form of +% the second argument of v(_,_) +% +% A is Xa^Ka and B is Xb^Kb, Rel is ordening relation between Xa and Xb + +pmerge_case(<,A,As,Res,B,Bs,_,_,_) :- + Res = [A|Tail], + pmerge(As,B,Bs,Tail). +pmerge_case(>,A,As,Res,B,Bs,_,_,_) :- + Res = [B|Tail], + pmerge(Bs,A,As,Tail). +pmerge_case(=,_,As,Res,_,Bs,Ka,Kb,Xa) :- + Kc is Ka + Kb, + ( Kc =:= 0 + -> pmerge(As,Bs,Res) + ; Res = [Xa^Kc|Tail], + pmerge(As,Bs,Tail) + ). + +% nf_div(Factor,In,Out) +% +% Out is the result of the division of each element in In (which is of the form v(_,_)) by Factor. + +% division by zero +nf_div([],_,_) :- + !, + zero_division. +% division by v(K,P) => multiplication by v(1/K,P^-1) +nf_div([v(K,P)],Sum,Res) :- + !, + Ki is 1.0/K, + mult_exp(P,-1,Pi), + nf_mul_factor(v(Ki,Pi),Sum,Res). +nf_div(D,A,[v(1.0,[(A/D)^1])]). + +% zero_division +% +% called when a division by zero is performed +zero_division :- fail. % raise_exception(_) ? + +% mult_exp(In,Factor,Out) +% +% Out is the result of the multiplication of the exponents of the elements in In +% (which are of the form X^Exp by Factor. +mult_exp([],_,[]). +mult_exp([X^P|Xs],K,[X^I|Tail]) :- + I is K*P, + mult_exp(Xs,K,Tail). +% +% raise to integer powers +% +% | ?- time({(1+X+Y+Z)^15=0}). (sicstus, try with SWI) +% Timing 00:00:02.610 2.610 iterative +% Timing 00:00:00.660 0.660 binomial +nf_power(N,Sum,Norm) :- + integer(N), + compare(Rel,N,0), + ( Rel = (<) + -> Pn is -N, + % nf_power_pos(Pn,Sum,Inorm), + binom(Sum,Pn,Inorm), + nf_div(Inorm,[v(1.0,[])],Norm) + ; Rel = (>) + -> % nf_power_pos(N,Sum,Norm) + binom(Sum,N,Norm) + ; Rel = (=) + -> % 0^0 is indeterminate but we say 1 + Norm = [v(1.0,[])] + ). +% +% N>0 +% +% iterative method: X^N = X*(X^N-1) +nf_power_pos(1,Sum,Norm) :- + !, + Sum = Norm. +nf_power_pos(N,Sum,Norm) :- + N1 is N-1, + nf_power_pos(N1,Sum,Pn1), + nf_mul(Sum,Pn1,Norm). +% +% N>0 +% +% binomial method +binom(Sum,1,Power) :- + !, + Power = Sum. +binom([],_,[]). +binom([A|Bs],N,Power) :- + ( Bs = [] + -> nf_power_factor(A,N,Ap), + Power = [Ap] + ; Bs = [_|_] + -> factor_powers(N,A,v(1.0,[]),Pas), + sum_powers(N,Bs,[v(1.0,[])],Pbs,[]), + combine_powers(Pas,Pbs,0,N,1,[],Power) + ). + +combine_powers([],[],_,_,_,Pi,Pi). +combine_powers([A|As],[B|Bs],L,R,C,Pi,Po) :- + nf_mul(A,B,Ab), + nf_mul_k(Ab,C,Abc), + nf_add(Abc,Pi,Pii), + L1 is L+1, + R1 is R-1, + C1 is C*R//L1, + combine_powers(As,Bs,L1,R1,C1,Pii,Po). + +nf_power_factor(v(K,P),N,v(Kn,Pn)) :- + Kn is K**N, + mult_exp(P,N,Pn). + +factor_powers(0,_,Prev,[[Prev]]) :- !. +factor_powers(N,F,Prev,[[Prev]|Ps]) :- + N1 is N-1, + mult(Prev,F,Next), + factor_powers(N1,F,Next,Ps). +sum_powers(0,_,Prev,[Prev|Lt],Lt) :- !. +sum_powers(N,S,Prev,L0,Lt) :- + N1 is N-1, + nf_mul(S,Prev,Next), + sum_powers(N1,S,Next,L0,[Prev|Lt]). + +% ------------------------------------------------------------------------------ +repair(Sum,Norm) :- + nf_length(Sum,0,Len), + repair_log(Len,Sum,[],Norm). +repair_log(0,As,As,[]) :- !. +repair_log(1,[v(Ka,Pa)|As],As,R) :- + !, + repair_term(Ka,Pa,R). +repair_log(2,[v(Ka,Pa),v(Kb,Pb)|As],As,R) :- + !, + repair_term(Ka,Pa,Ar), + repair_term(Kb,Pb,Br), + nf_add(Ar,Br,R). +repair_log(N,A0,A2,R) :- + P is N>>1, + Q is N-P, + repair_log(P,A0,A1,Rp), + repair_log(Q,A1,A2,Rq), + nf_add(Rp,Rq,R). + +repair_term(K,P,Norm) :- + length(P,Len), + repair_p_log(Len,P,[],Pr,[v(1.0,[])],Sum), + nf_mul_factor(v(K,Pr),Sum,Norm). + +repair_p_log(0,Ps,Ps,[],L0,L0) :- !. +repair_p_log(1,[X^P|Ps],Ps,R,L0,L1) :- + !, + repair_p(X,P,R,L0,L1). +repair_p_log(2,[X^Px,Y^Py|Ps],Ps,R,L0,L2) :- + !, + repair_p(X,Px,Rx,L0,L1), + repair_p(Y,Py,Ry,L1,L2), + pmerge(Rx,Ry,R). +repair_p_log(N,P0,P2,R,L0,L2) :- + P is N>>1, + Q is N-P, + repair_p_log(P,P0,P1,Rp,L0,L1), + repair_p_log(Q,P1,P2,Rq,L1,L2), + pmerge(Rp,Rq,R). + +repair_p(Term,P,[Term^P],L0,L0) :- var(Term). +repair_p(Term,P,[],L0,L1) :- + nonvar(Term), + repair_p_one(Term,TermN), + nf_power(P,TermN,TermNP), + nf_mul(TermNP,L0,L1). +% +% An undigested term a/b is distinguished from an +% digested one by the fact that its arguments are +% digested -> cuts after repair of args! +% +repair_p_one(Term,TermN) :- + nf_number(Term,TermN), % freq. shortcut for nf/2 case below + !. +repair_p_one(A1/A2,TermN) :- + repair(A1,A1n), + repair(A2,A2n), + !, + nf_div(A2n,A1n,TermN). +repair_p_one(Term,TermN) :- + nonlin_1(Term,Arg,Skel,Sa), + repair(Arg,An), + !, + nf_nonlin_1(Skel,An,Sa,TermN). +repair_p_one(Term,TermN) :- + nonlin_2(Term,A1,A2,Skel,Sa1,Sa2), + repair(A1,A1n), + repair(A2,A2n), + !, + nf_nonlin_2(Skel,A1n,A2n,Sa1,Sa2,TermN). +repair_p_one(Term,TermN) :- + nf(Term,TermN). + +nf_length([],Li,Li). +nf_length([_|R],Li,Lo) :- + Lii is Li+1, + nf_length(R,Lii,Lo). +% ------------------------------------------------------------------------------ +% nf2term(NF,Term) +% +% transforms a normal form into a readable term + +% empty normal form = 0 +nf2term([],0.0). +% term is first element (+ next elements) +nf2term([F|Fs],T) :- + f02t(F,T0), % first element + yfx(Fs,T0,T). % next elements + +yfx([],T0,T0). +yfx([F|Fs],T0,TN) :- + fn2t(F,Ft,Op), + T1 =.. [Op,T0,Ft], + yfx(Fs,T1,TN). + +% f02t(v(K,P),T) +% +% transforms the first element of the normal form (something of the form v(K,P)) +% into a readable term +f02t(v(K,P),T) :- + ( % just a constant + P = [] + -> T = K + ; TestK is K - 1.0, % K =:= 1 + (TestK >= -1.0e-10, TestK =< 1.0e-10) + -> p2term(P,T) + ; TestK is K + 1.0, % K =:= -1 + (TestK >= -1.0e-10, TestK =< 1.0e-10) + -> T = -Pt, + p2term(P,Pt) + ; T = K*Pt, + p2term(P,Pt) + ). + +% f02t(v(K,P),T,Op) +% +% transforms a next element of the normal form (something of the form v(K,P)) +% into a readable term +fn2t(v(K,P),Term,Op) :- + ( TestK is K - 1.0, % K =:= 1 + (TestK >= -1.0e-10, TestK =< 1.0e-10) + -> Term = Pt, + Op = + + ; TestK is K + 1.0, % K =:= -1 + (TestK >= -1.0e-10, TestK =< 1.0e-10) + -> Term = Pt, + Op = - + ; K < -1.0e-10 % K < 0 + -> Kf is -K, + Term = Kf*Pt, + Op = - + ; % K > 0 + Term = K*Pt, + Op = + + ), + p2term(P,Pt). + +% transforms the P part in v(_,P) into a readable term +p2term([X^P|Xs],Term) :- + ( Xs = [] + -> pe2term(X,Xt), + exp2term(P,Xt,Term) + ; Xs = [_|_] + -> Term = Xst*Xtp, + pe2term(X,Xt), + exp2term(P,Xt,Xtp), + p2term(Xs,Xst) + ). + +% +exp2term(1,X,X) :- !. +exp2term(-1,X,1.0/X) :- !. +exp2term(P,X,Term) :- + % Term = exp(X,Pn) + Term = X^P. + +pe2term(X,Term) :- + var(X), + Term = X. +pe2term(X,Term) :- + nonvar(X), + X =.. [F|Args], + pe2term_args(Args,Argst), + Term =.. [F|Argst]. + +pe2term_args([],[]). +pe2term_args([A|As],[T|Ts]) :- + nf2term(A,T), + pe2term_args(As,Ts). + +% transg(Goal,[OutList|OutListTail],OutListTail) +% +% puts the equalities and inequalities that are implied by the elements in Goal +% in the difference list OutList +% +% called by geler.pl for project.pl + +transg(resubmit_eq(Nf)) --> + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpr:{Term=Z}]. +transg(resubmit_lt(Nf)) --> + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpr:{Term + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpr:{Term= + { + nf2term([],Z), + nf2term(Nf,Term) + }, + [clpr:{Term=\=Z}]. +transg(wait_linear_retry(Nf,Res,Goal)) --> + { + nf2term(Nf,Term) + }, + [clpr:{Term=Res},Goal]. + +integerp(X) :- + floor(X)=:=X. + +integerp(X,I) :- + floor(X)=:=X, + I is integer(X). diff --git a/packages/clpqr/clpr/store_r.pl b/packages/clpqr/clpr/store_r.pl new file mode 100644 index 000000000..86373d087 --- /dev/null +++ b/packages/clpqr/clpr/store_r.pl @@ -0,0 +1,427 @@ +/* $Id$ + + Part of CLP(R) (Constraint Logic Programming over Reals) + + Author: Leslie De Koninck + E-mail: Leslie.DeKoninck@cs.kuleuven.be + WWW: http://www.swi-prolog.org + http://www.ai.univie.ac.at/cgi-bin/tr-online?number+95-09 + Copyright (C): 2004, K.U. Leuven and + 1992-1995, Austrian Research Institute for + Artificial Intelligence (OFAI), + Vienna, Austria + + This software is part of Leslie De Koninck's master thesis, supervised + by Bart Demoen and daily advisor Tom Schrijvers. It is based on CLP(Q,R) + by Christian Holzbaur for SICStus Prolog and distributed under the + license details below with permission from all mentioned authors. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(store_r, + [ + add_linear_11/3, + add_linear_f1/4, + add_linear_ff/5, + normalize_scalar/2, + delete_factor/4, + mult_linear_factor/3, + nf_rhs_x/4, + indep/2, + isolate/3, + nf_substitute/4, + mult_hom/3, + nf2sum/3, + nf_coeff_of/3, + renormalize/2 + ]). + +% normalize_scalar(S,[N,Z]) +% +% Transforms a scalar S into a linear expression [S,0] + +normalize_scalar(S,[S,0.0]). + +% renormalize(List,Lin) +% +% Renormalizes the not normalized linear expression in List into +% a normalized one. It does so to take care of unifications. +% (e.g. when a variable X is bound to a constant, the constant is added to +% the constant part of the linear expression; when a variable X is bound to +% another variable Y, the scalars of both are added) + +renormalize([I,R|Hom],Lin) :- + length(Hom,Len), + renormalize_log(Len,Hom,[],Lin0), + add_linear_11([I,R],Lin0,Lin). + +% renormalize_log(Len,Hom,HomTail,Lin) +% +% Logarithmically renormalizes the homogene part of a not normalized +% linear expression. See also renormalize/2. + +renormalize_log(1,[Term|Xs],Xs,Lin) :- + !, + Term = l(X*_,_), + renormalize_log_one(X,Term,Lin). +renormalize_log(2,[A,B|Xs],Xs,Lin) :- + !, + A = l(X*_,_), + B = l(Y*_,_), + renormalize_log_one(X,A,LinA), + renormalize_log_one(Y,B,LinB), + add_linear_11(LinA,LinB,Lin). +renormalize_log(N,L0,L2,Lin) :- + P is N>>1, + Q is N-P, + renormalize_log(P,L0,L1,Lp), + renormalize_log(Q,L1,L2,Lq), + add_linear_11(Lp,Lq,Lin). + +% renormalize_log_one(X,Term,Res) +% +% Renormalizes a term in X: if X is a nonvar, the term becomes a scalar. + +renormalize_log_one(X,Term,Res) :- + var(X), + Term = l(X*K,_), + get_attr(X,itf,Att), + arg(5,Att,order(OrdX)), % Order might have changed + Res = [0.0,0.0,l(X*K,OrdX)]. +renormalize_log_one(X,Term,Res) :- + nonvar(X), + Term = l(X*K,_), + Xk is X*K, + normalize_scalar(Xk,Res). + +% ----------------------------- sparse vector stuff ---------------------------- % + +% add_linear_ff(LinA,Ka,LinB,Kb,LinC) +% +% Linear expression LinC is the result of the addition of the 2 linear expressions +% LinA and LinB, each one multiplied by a scalar (Ka for LinA and Kb for LinB). + +add_linear_ff(LinA,Ka,LinB,Kb,LinC) :- + LinA = [Ia,Ra|Ha], + LinB = [Ib,Rb|Hb], + LinC = [Ic,Rc|Hc], + Ic is Ia*Ka+Ib*Kb, + Rc is Ra*Ka+Rb*Kb, + add_linear_ffh(Ha,Ka,Hb,Kb,Hc). + +% add_linear_ffh(Ha,Ka,Hb,Kb,Hc) +% +% Homogene part Hc is the result of the addition of the 2 homogene parts Ha and Hb, +% each one multiplied by a scalar (Ka for Ha and Kb for Hb) + +add_linear_ffh([],_,Ys,Kb,Zs) :- mult_hom(Ys,Kb,Zs). +add_linear_ffh([l(X*Kx,OrdX)|Xs],Ka,Ys,Kb,Zs) :- + add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb). + +% add_linear_ffh(Ys,X,Kx,OrdX,Xs,Zs,Ka,Kb) +% +% Homogene part Zs is the result of the addition of the 2 homogene parts Ys and +% [l(X*Kx,OrdX)|Xs], each one multiplied by a scalar (Ka for [l(X*Kx,OrdX)|Xs] and Kb for Ys) + +add_linear_ffh([],X,Kx,OrdX,Xs,Zs,Ka,_) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs). +add_linear_ffh([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka,Kb) :- + compare(Rel,OrdX,OrdY), + ( Rel = (=) + -> Kz is Kx*Ka+Ky*Kb, + ( % Kz =:= 0 + Kz =< 1.0e-10, + Kz >= -1.0e-10 + -> add_linear_ffh(Xs,Ka,Ys,Kb,Zs) + ; Zs = [l(X*Kz,OrdX)|Ztail], + add_linear_ffh(Xs,Ka,Ys,Kb,Ztail) + ) + ; Rel = (<) + -> Zs = [l(X*Kz,OrdX)|Ztail], + Kz is Kx*Ka, + add_linear_ffh(Xs,Y,Ky,OrdY,Ys,Ztail,Kb,Ka) + ; Rel = (>) + -> Zs = [l(Y*Kz,OrdY)|Ztail], + Kz is Ky*Kb, + add_linear_ffh(Ys,X,Kx,OrdX,Xs,Ztail,Ka,Kb) + ). + +% add_linear_f1(LinA,Ka,LinB,LinC) +% +% special case of add_linear_ff with Kb = 1 + +add_linear_f1(LinA,Ka,LinB,LinC) :- + LinA = [Ia,Ra|Ha], + LinB = [Ib,Rb|Hb], + LinC = [Ic,Rc|Hc], + Ic is Ia*Ka+Ib, + Rc is Ra*Ka+Rb, + add_linear_f1h(Ha,Ka,Hb,Hc). + +% add_linear_f1h(Ha,Ka,Hb,Hc) +% +% special case of add_linear_ffh/5 with Kb = 1 + +add_linear_f1h([],_,Ys,Ys). +add_linear_f1h([l(X*Kx,OrdX)|Xs],Ka,Ys,Zs) :- + add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka). + +% add_linear_f1h(Ys,X,Kx,OrdX,Xs,Zs,Ka) +% +% special case of add_linear_ffh/8 with Kb = 1 + +add_linear_f1h([],X,Kx,OrdX,Xs,Zs,Ka) :- mult_hom([l(X*Kx,OrdX)|Xs],Ka,Zs). +add_linear_f1h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs,Ka) :- + compare(Rel,OrdX,OrdY), + ( Rel = (=) + -> Kz is Kx*Ka+Ky, + ( % Kz =:= 0.0 + Kz =< 1.0e-10, + Kz >= -1.0e-10 + -> add_linear_f1h(Xs,Ka,Ys,Zs) + ; Zs = [l(X*Kz,OrdX)|Ztail], + add_linear_f1h(Xs,Ka,Ys,Ztail) + ) + ; Rel = (<) + -> Zs = [l(X*Kz,OrdX)|Ztail], + Kz is Kx*Ka, + add_linear_f1h(Xs,Ka,[l(Y*Ky,OrdY)|Ys],Ztail) + ; Rel = (>) + -> Zs = [l(Y*Ky,OrdY)|Ztail], + add_linear_f1h(Ys,X,Kx,OrdX,Xs,Ztail,Ka) + ). + +% add_linear_11(LinA,LinB,LinC) +% +% special case of add_linear_ff with Ka = 1 and Kb = 1 + +add_linear_11(LinA,LinB,LinC) :- + LinA = [Ia,Ra|Ha], + LinB = [Ib,Rb|Hb], + LinC = [Ic,Rc|Hc], + Ic is Ia+Ib, + Rc is Ra+Rb, + add_linear_11h(Ha,Hb,Hc). + +% add_linear_11h(Ha,Hb,Hc) +% +% special case of add_linear_ffh/5 with Ka = 1 and Kb = 1 + +add_linear_11h([],Ys,Ys). +add_linear_11h([l(X*Kx,OrdX)|Xs],Ys,Zs) :- + add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs). + +% add_linear_11h(Ys,X,Kx,OrdX,Xs,Zs) +% +% special case of add_linear_ffh/8 with Ka = 1 and Kb = 1 + +add_linear_11h([],X,Kx,OrdX,Xs,[l(X*Kx,OrdX)|Xs]). +add_linear_11h([l(Y*Ky,OrdY)|Ys],X,Kx,OrdX,Xs,Zs) :- + compare(Rel,OrdX,OrdY), + ( Rel = (=) + -> Kz is Kx+Ky, + ( % Kz =:= 0.0 + Kz =< 1.0e-10, + Kz >= -1.0e-10 + -> add_linear_11h(Xs,Ys,Zs) + ; Zs = [l(X*Kz,OrdX)|Ztail], + add_linear_11h(Xs,Ys,Ztail) + ) + ; Rel = (<) + -> Zs = [l(X*Kx,OrdX)|Ztail], + add_linear_11h(Xs,Y,Ky,OrdY,Ys,Ztail) + ; Rel = (>) + -> Zs = [l(Y*Ky,OrdY)|Ztail], + add_linear_11h(Ys,X,Kx,OrdX,Xs,Ztail) + ). + +% mult_linear_factor(Lin,K,Res) +% +% Linear expression Res is the result of multiplication of linear +% expression Lin by scalar K + +mult_linear_factor(Lin,K,Mult) :- + TestK is K - 1.0, % K =:= 1 + TestK =< 1.0e-10, + TestK >= -1.0e-10, % avoid copy + !, + Mult = Lin. +mult_linear_factor(Lin,K,Res) :- + Lin = [I,R|Hom], + Res = [Ik,Rk|Mult], + Ik is I*K, + Rk is R*K, + mult_hom(Hom,K,Mult). + +% mult_hom(Hom,K,Res) +% +% Homogene part Res is the result of multiplication of homogene part +% Hom by scalar K + +mult_hom([],_,[]). +mult_hom([l(A*Fa,OrdA)|As],F,[l(A*Fan,OrdA)|Afs]) :- + Fan is F*Fa, + mult_hom(As,F,Afs). + +% nf_substitute(Ord,Def,Lin,Res) +% +% Linear expression Res is the result of substitution of Var in +% linear expression Lin, by its definition in the form of linear +% expression Def + +nf_substitute(OrdV,LinV,LinX,LinX1) :- + delete_factor(OrdV,LinX,LinW,K), + add_linear_f1(LinV,K,LinW,LinX1). + +% delete_factor(Ord,Lin,Res,Coeff) +% +% Linear expression Res is the result of the deletion of the term +% Var*Coeff where Var has ordering Ord from linear expression Lin + +delete_factor(OrdV,Lin,Res,Coeff) :- + Lin = [I,R|Hom], + Res = [I,R|Hdel], + delete_factor_hom(OrdV,Hom,Hdel,Coeff). + +% delete_factor_hom(Ord,Hom,Res,Coeff) +% +% Homogene part Res is the result of the deletion of the term +% Var*Coeff from homogene part Hom + +delete_factor_hom(VOrd,[Car|Cdr],RCdr,RKoeff) :- + Car = l(_*Koeff,Ord), + compare(Rel,VOrd,Ord), + ( Rel= (=) + -> RCdr = Cdr, + RKoeff=Koeff + ; Rel= (>) + -> RCdr = [Car|RCdr1], + delete_factor_hom(VOrd,Cdr,RCdr1,RKoeff) + ). + + +% nf_coeff_of(Lin,OrdX,Coeff) +% +% Linear expression Lin contains the term l(X*Coeff,OrdX) + +nf_coeff_of([_,_|Hom],VOrd,Coeff) :- + nf_coeff_hom(Hom,VOrd,Coeff). + +% nf_coeff_hom(Lin,OrdX,Coeff) +% +% Linear expression Lin contains the term l(X*Coeff,OrdX) where the +% order attribute of X = OrdX + +nf_coeff_hom([l(_*K,OVar)|Vs],OVid,Coeff) :- + compare(Rel,OVid,OVar), + ( Rel = (=) + -> Coeff = K + ; Rel = (>) + -> nf_coeff_hom(Vs,OVid,Coeff) + ). + +% nf_rhs_x(Lin,OrdX,Rhs,K) +% +% Rhs = R + I where Lin = [I,R|Hom] and l(X*K,OrdX) is a term of Hom + +nf_rhs_x(Lin,OrdX,Rhs,K) :- + Lin = [I,R|Tail], + nf_coeff_hom(Tail,OrdX,K), + Rhs is R+I. % late because X may not occur in H + +% isolate(OrdN,Lin,Lin1) +% +% Linear expression Lin1 is the result of the transformation of linear expression +% Lin = 0 which contains the term l(New*K,OrdN) into an equivalent expression Lin1 = New. + +isolate(OrdN,Lin,Lin1) :- + delete_factor(OrdN,Lin,Lin0,Coeff), + K is -1.0/Coeff, + mult_linear_factor(Lin0,K,Lin1). + +% indep(Lin,OrdX) +% +% succeeds if Lin = [0,_|[l(X*1,OrdX)]] + +indep(Lin,OrdX) :- + Lin = [I,_|[l(_*K,OrdY)]], + OrdX == OrdY, + % K =:= 1.0 + TestK is K - 1.0, + TestK =< 1.0e-10, + TestK >= -1.0e-10, + % I =:= 0 + I =< 1.0e-10, + I >= -1.0e-10. + +% nf2sum(Lin,Sofar,Term) +% +% Transforms a linear expression into a sum +% (e.g. the expression [5,_,[l(X*2,OrdX),l(Y*-1,OrdY)]] gets transformed into 5 + 2*X - Y) + +nf2sum([],I,I). +nf2sum([X|Xs],I,Sum) :- + ( % I =:= 0.0 + I =< 1.0e-10, + I >= -1.0e-10 + -> X = l(Var*K,_), + ( % K =:= 1.0 + TestK is K - 1.0, + TestK =< 1.0e-10, + TestK >= -1.0e-10 + -> hom2sum(Xs,Var,Sum) + ; % K =:= -1.0 + TestK is K + 1.0, + TestK =< 1.0e-10, + TestK >= -1.0e-10 + -> hom2sum(Xs,-Var,Sum) + ; hom2sum(Xs,K*Var,Sum) + ) + ; hom2sum([X|Xs],I,Sum) + ). + +% hom2sum(Hom,Sofar,Term) +% +% Transforms a linear expression into a sum +% this predicate handles all but the first term +% (the first term does not need a concatenation symbol + or -) +% see also nf2sum/3 + +hom2sum([],Term,Term). +hom2sum([l(Var*K,_)|Cs],Sofar,Term) :- + ( % K =:= 1.0 + TestK is K - 1.0, + TestK =< 1.0e-10, + TestK >= -1.0e-10 + -> Next = Sofar + Var + ; % K =:= -1.0 + TestK is K + 1.0, + TestK =< 1.0e-10, + TestK >= -1.0e-10 + -> Next = Sofar - Var + ; % K < 0.0 + K < -1.0e-10 + -> Ka is -K, + Next = Sofar - Ka*Var + ; Next = Sofar + K*Var + ), + hom2sum(Cs,Next,Term). diff --git a/packages/clpqr/configure.in b/packages/clpqr/configure.in new file mode 100644 index 000000000..cfcbb74f5 --- /dev/null +++ b/packages/clpqr/configure.in @@ -0,0 +1,12 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_INIT(install-sh) +AC_PREREQ([2.50]) + +AC_ARG_ENABLE(clpqr, + [ --enable-clpqr install clpqr library ], + use_clpqr="$enableval", use_clpqr=yes) + +m4_include([../ac_swi_noc.m4]) + +AC_OUTPUT(Makefile) diff --git a/packages/clpqr/install-sh b/packages/clpqr/install-sh new file mode 100755 index 000000000..ab74c882e --- /dev/null +++ b/packages/clpqr/install-sh @@ -0,0 +1,238 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +tranformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/packages/http b/packages/http deleted file mode 160000 index f98511b9c..000000000 --- a/packages/http +++ /dev/null @@ -1 +0,0 @@ -Subproject commit f98511b9c0f6113a04512abad346b2ee0c399478 diff --git a/packages/jpl b/packages/jpl deleted file mode 160000 index 8b043d9f8..000000000 --- a/packages/jpl +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 8b043d9f8261e701723d7e75391dcb99937206d5 diff --git a/packages/jpl/Makefile.in b/packages/jpl/Makefile.in new file mode 100755 index 000000000..87d9f0351 --- /dev/null +++ b/packages/jpl/Makefile.in @@ -0,0 +1,196 @@ +################################################################ +# @configure_input@ +# +# Build JPL. Building JPL for Unix currently relies on the following +# assumptions: +# +# * $JAVA_HOME points to the JDK top directory +# * $PATH includes $JAVA_HOME/bin +# * ELF Dynamic Linker semantics +# +# Author: Jan Wielemaker, based on shell-scripts from Paul Singleton. +################################################################ + +PACKAGE=jpl +PKGCFLAGS=@JPLCFLAGS@ +PKGLDFLAGS=@JPLLDFLAGS@ + +include ../Makefile.defs + +LIBS=@LIBS@ + +JAVA_HOME=@JAVA_HOME@ +JAVAC=@JAVAC@ +JAVACFLAGS=@JAVACFLAGS@ +JAVA=@JAVA@ +JUNIT=@JUNIT@ +JAVALIBS=@JAVALIBS@ + +LIBPL= $(srcdir)/jpl.pl +LIBJPL= @LIBJPL@.@SO@ +TARGETS= $(LIBJPL) +OBJ= src/c/jpl.o + +# YAP has some extra hacks that need to be compiled in. +ifeq (@PROLOG_SYSTEM@,yap) +src/c/jpl.o: $(srcdir)/src/c/jpl.c $(srcdir)/src/c/hacks.c + $(CC) -c $(CFLAGS) $(srcdir)/src/c/jpl.c -o src/c/jpl.o +endif + +all: $(TARGETS) jpl.jar exjava-compile jpl_doc + +# linking order counts here: otherwise libjpl.so will not remember +# it needs libYap.so +@LIBJPL@.@SO@: $(OBJ) + $(LD) $(LDSOFLAGS) -o $@ $(OBJ) $(LIBS) $(JAVALIBS) $(LIBPLEMBED) + if [ -r @LIBJPL@.@SO@ ]; then \ + rm -f @LIBJPL@.jnilib && ln -s @LIBJPL@.@SO@ @LIBJPL@.jnilib ; \ + fi + +jpl.jar:: + (cd src/java && $(MAKE) jpl_jar) +jpl_doc:: + (cd src/java && $(MAKE) jpl_doc) + +################################################################ +# Verify the package +################################################################ + +check: check_pl check_java + +check_pl: jpltest.jar + $(PL) -q -f test_jpl.pl -g run_tests,halt -t 'halt(1)' +check_java: jpltest.jar + JUNIT=$(JUNIT) JAVA=$(JAVA) JAVA_PRELOAD=$(JAVA_PRELOAD) $(srcdir)/test-java.sh + +jpltest.jar: + (cd src/java && $(MAKE) test_jar) + +################################################################ +# Installation +################################################################ + +DOCDIRS= $(srcdir) $(srcdir)/java_api \ + $(srcdir)/java_api/javadoc $(srcdir)/java_api/javadoc/jpl \ + $(srcdir)/java_api/javadoc/jpl/class-use \ + $(srcdir)/java_api/javadoc/jpl/fli \ + $(srcdir)/java_api/javadoc/jpl/fli/class-use \ + $(srcdir)/java_api/javadoc/resources \ + $(srcdir)/prolog_api \ + $(srcdir)/prolog_api/overview +DOCFILES= $(shell cd $(srcdir)/docs && find . -name '*.html' -o -name '*.gif' -o -name '*.jpg') + +EXPL= $(PKGEXDIR)/jpl/prolog +EXPLS= jpl_colour_choose_demo.pl \ + jpl_jlist_demo.pl \ + jpl_midi_demo.pl \ + jpl_table_demo.pl \ + jpl_text_entry_demo.pl \ + jpl_versions_demo.pl +EXJAVA= $(PKGEXDIR)/jpl/java +EXJAVAS= Exceptions Exceptions2 Family FamilyMT Test Test2 Time \ + Versions Zahed SemWeb + + +install: all $(LIBPL) + mkdir -p $(DESTDIR)$(SOLIBDIR) + for f in $(TARGETS); do \ + $(INSTALL_PROGRAM) "$$f" "$(DESTDIR)$(SOLIBDIR)"; \ + done +ifeq (@SO@,dylib) + (cd $(DESTDIR)$(SOLIBDIR) && ln -sf @LIBJPL@.@SO@ @LIBJPL@.jnilib) +endif + mkdir -p $(DESTDIR)$(PLLIBDIR) + mkdir -p $(DESTDIR)$(PLLIBDIR)/jpl + for f in $(LIBPL); do \ + $(INSTALL_DATA) $$f $(DESTDIR)$(PLLIBDIR); \ + done + $(INSTALL_DATA) jpl.jar $(DESTDIR)$(PLLIBDIR)/jpl + $(PL) -f none -g make -t halt + mkdir -p "$(DESTDIR)$(PLLIBDIR)" + for f in $(LIBPL); do \ + $(INSTALL_DATA) $$f $(DESTDIR)$(PLLIBDIR); \ + done + $(MKINDEX) + +install-examples:: + expl-install exjava-install + +ln-install:: + @$(MAKE) INSTALL_DATA='../ln-install' install + +rpm-install: install html-install + +html-install:: expl-install exjava-install + mkdir -p $(DESTDIR)$(PKGDOCDIR)/jpl + @printf "Creating directories " + @for d in $(DOCDIRS); do \ + mkdir -p $(DESTDIR)$(PKGDOCDIR)/jpl/$$d; printf "."; \ + done + @echo "ok" + @printf "Copying documentation files " + @for f in $(DOCFILES); do \ + $(INSTALL_DATA) docs/$$f $(DESTDIR)$(PKGDOCDIR)/jpl/$$f; printf "."; \ + done + @echo "ok" + +expl-install:: + echo "Installing Prolog examples" + mkdir -p $(DESTDIR)$(EXPL) + @for f in $(EXPLS) README; do \ + $(INSTALL_DATA) $(srcdir)/examples/prolog/$$f $(DESTDIR)$(EXPL)/$$f; \ + done + +exjava-compile: jpl.jar + echo "Compiling Java examples" + for d in $(EXJAVAS); do \ + if [ ! -f examples/java/$$d/$$d.class ]; then \ + echo $$d; \ + mkdir -p examples/java/$$d; \ + (cd examples/java/$$d && "$(JAVAC)" $(JAVACFLAGS) -d . -classpath "../../../jpl.jar" $(srcdir)/examples/java/$$d/$$d.java); \ + fi; \ + done + +exjava-install: exjava-compile + echo "Installing Java examples" + mkdir -p "$(DESTDIR)$(EXJAVA)" + $(INSTALL_DATA) $(srcdir)/examples/java/README "$(DESTDIR)$(EXJAVA)" + $(INSTALL_DATA) $(srcdir)/examples/java/env.@CMDEXT@ "$(DESTDIR)$(EXJAVA)" + for d in $(EXJAVAS); do \ + mkdir -p $(DESTDIR)$(EXJAVA)/$$d; \ + $(INSTALL_SCRIPT) $(srcdir)/examples/java/$$d/run.@CMDEXT@ "$(DESTDIR)$(EXJAVA)/$$d" ;\ + $(INSTALL_DATA) $(srcdir)/examples/java/$$d/README "$(DESTDIR)$(EXJAVA)/$$d" ;\ + $(INSTALL_DATA) $(srcdir)/examples/java/$$d/$$d.java "$(DESTDIR)$(EXJAVA)/$$d" ;\ + for f in $(srcdir)/examples/java/$$d/*.pl; do \ + $(INSTALL_DATA) "$$f" "$(DESTDIR)$(EXJAVA)/$$d"; \ + done ;\ + $(INSTALL_DATA) examples/java/$$d/$$d*.class $(DESTDIR)$(EXJAVA)/$$d ;\ + done + $(INSTALL_DATA) $(srcdir)/examples/java/SemWeb/test.rdf "$(DESTDIR)$(EXJAVA)/SemWeb" + +pdf-install:: + mkdir -p $(DESTDIR)$(PKGDOCDIR) + $(INSTALL) -m 644 $(DOC).pdf "$(DESTDIR)$(PKGDOCDIR)" + +uninstall:: + (cd $(PLBASE)/lib/$(PLARCH) && rm -f $(TARGETS)) + (cd $(PLBASE)/library && rm -f $(LIBPL)) + $(PL) -f none -g make -t halt + +################################################################ +# Clean +################################################################ + +clean: + rm -f $(OBJ) *~ *.o *% a.out core config.log + rm -f TestJPL.class + find examples/java -name '*.class' -delete + (cd src/java && $(MAKE) clean) + +distclean: clean + rm -rf autom4te.cache + rm -f $(TARGETS) config.cache config.h config.status Makefile + rm -f $(DOC).aux $(DOC).log $(DOC).out $(DOC).toc + rm -rf html + (cd src/java && $(MAKE) distclean) + diff --git a/packages/jpl/Makefile.mak b/packages/jpl/Makefile.mak new file mode 100644 index 000000000..16325a78f --- /dev/null +++ b/packages/jpl/Makefile.mak @@ -0,0 +1,119 @@ +################################################################ +# Build the SWI-Prolog tabling package for MS-Windows +# +# Author: Jan Wielemaker +# +# Use: +# nmake /f Makefile.mak +# nmake /f Makefile.mak install +################################################################ + +PLHOME=..\.. +!include ..\..\src\rules.mk +JAVA="$(JAVA_HOME)\bin\java" + +PKGDLL=jpl + +EXDIR= $(PKGDOC)\examples\jpl +EXPL= $(EXDIR)\prolog +EXPLS= jpl_colour_choose_demo.pl \ + jpl_jlist_demo.pl \ + jpl_midi_demo.pl \ + jpl_table_demo.pl \ + jpl_text_entry_demo.pl \ + jpl_versions_demo.pl +EXJAVA= $(EXDIR)\java +EXJAVAS= Exceptions Exceptions2 Family FamilyMT Test Test2 Time \ + Versions Zahed SemWeb + + +CFLAGS = $(CFLAGS) \ + -I"$(JAVA_HOME)\include" \ + -I"$(JAVA_HOME)\include\win32" +LIBS = $(LIBS) "$(JAVA_HOME)\lib\jvm.lib" + +OBJ= src\c\jpl.obj + +all: checkenv $(PKGDLL).dll jar + +jar:: + chdir src\java & $(MAKE) + +checkenv:: + @if not exist "$(JAVA_HOME)\lib\jvm.lib" \ + echo FATAL ERROR: No JAVA_HOME defined? && exit 1 + +$(PKGDLL).dll: $(OBJ) + $(LD) /dll /out:$@ $(LDFLAGS) $(OBJ) $(PLLIB) $(LIBS) + +!IF "$(CFG)" == "rt" +install: idll +!ELSE +install: idll ilib +!ENDIF + +idll:: + copy $(PKGDLL).dll "$(BINDIR)" +ilib:: + copy jpl.pl "$(PLBASE)\library" + copy jpl.jar "$(PLBASE)\lib" + $(MAKEINDEX) + +html-install:: expl-install exjava-install + @echo CVS > nocopy + xcopy /Q /S /I /Y /EXCLUDE:nocopy docs "$(PKGDOC)\jpl" + del nocopy + +xpce-install:: + +expl-install:: + if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)" + if not exist "$(EXPL)/$(NULL)" $(MKDIR) "$(EXPL)" + cd examples\prolog & \ + @for %f in ($(EXPLS)) do @copy %f "$(EXPL)" + copy examples\prolog\README "$(EXPL)\README.TXT" + +exjava-install:: + if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)" + if not exist "$(EXJAVA)/$(NULL)" $(MKDIR) "$(EXJAVA)" + copy examples\java\README "$(EXJAVA)"\README.TXT + copy examples\java\env.bat "$(EXJAVA)" + for %f in ($(EXJAVAS)) do if not exist "$(EXJAVA)\%f\$(NULL)" mkdir "$(EXJAVA)\%f" + for %f in ($(EXJAVAS)) do copy examples\java\%f\run.bat "$(EXJAVA)\%f + for %f in ($(EXJAVAS)) do copy examples\java\%f\README "$(EXJAVA)\%f\README.txt + for %f in ($(EXJAVAS)) do copy examples\java\%f\%f.java "$(EXJAVA)\%f + for %f in ($(EXJAVAS)) do if exist examples\java\%f\*.pl copy examples\java\%f\*.pl "$(EXJAVA)\%f" + copy examples\java\SemWeb\test.rdf "$(EXJAVA)\SemWeb" + +uninstall:: + del "$(PLBASE)\bin\$(PKGDLL).dll" + del "$(PLBASE)\library\jpl.pl" + del "$(PLBASE)\lib\jpl.jar" + $(MAKEINDEX) + +################################################################ +# Verify the package +################################################################ + +check: check_pl check_java + +check_pl:: + "$(PLCON)" -q -f test_jpl.pl -g run_tests,halt -t 'halt(1)' +check_java:: + set CLASSPATH=$(JUNIT);jpl.jar;jpltest.jar + $(JAVA) junit.textui.TestRunner jpl.test.TestJUnit + +################################################################ +# Cleanup +################################################################ + +clean:: + if exist $(OBJ) del $(OBJ) + if exist *.obj del *.obj + if exist *~ del *~ + chdir src\java & $(MAKE) clean + +distclean: clean + -DEL *.dll *.lib *.exp *.pdb *.ilk 2>nul + chdir src\java & $(MAKE) distclean + diff --git a/packages/jpl/README.MacOS b/packages/jpl/README.MacOS new file mode 100644 index 000000000..6c584859a --- /dev/null +++ b/packages/jpl/README.MacOS @@ -0,0 +1,23 @@ +# Compiling JPL for MacOS + +Updated: Nov 5, 2013 for MacOS 10.9 + +# Using Apple's Java distribution + +Somehow MacOS did not install the Java SDK correctly, so I ended up without +jni.h. I did not find a resolution for that. + +# Using Oracle's SDK + +Download from + + - http://www.oracle.com/technetwork/java/javase/downloads/jdk7-downloads-1880260.html + +which installs + + - /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home + +Set $JAVAPREFIX to + + - /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/bin + \ No newline at end of file diff --git a/packages/jpl/README.html b/packages/jpl/README.html new file mode 100644 index 000000000..e4aaa65d5 --- /dev/null +++ b/packages/jpl/README.html @@ -0,0 +1,152 @@ + + + + + JPL 3.0 documentation home page + + + + + + + +

JPL 3.x documentation home +page

+
+

Introduction

+

JPL 3.x is a dynamic, +bidirectional interface +between SWI-Prolog 5.2.0 or later and Java 2 +runtimes (see JPL 3.x +Objectives).  It offers two APIs:

+
    +
  • +

    Java +API (Java-calls-Prolog): this +interface comprises public Java classes which support:

    +
      +
    • +

      constructing Java +representations of Prolog terms and queries

      +
      • +
    • +

      calling queries within SWI-Prolog +engines

      +
      • +
    • +

      retrieving (as Java representations of Prolog terms) any +bindings created by a call

      +
      • +
    +
    • +
+
    +
  • +

    Prolog +API (Prolog-calls-Java): this +interface comprises Prolog library predicates which support:

    +
      +
    • +

      creating instances (objects) of +Java classes (built-in and user-defined)

      +
      • +
    • +

      calling methods of Java objects +(and static methods of classes), perhaps returning values or object +references

      +
      • +
    • +

      getting and setting the values of fields of Java objects and +classes

      +
      • +
    +
    • +
+

Calls to the two APIs can be nested, +e.g. Java code can call Prolog predicates which call Java methods +which call Prolog predicates etc.

+
+

Prerequisites

+

JPL 3.x currently requires SWI-Prolog 5.2.0 +or later (it uses multi-threading FLI calls not available in older +versions).  If you are using SWI-Prolog 5.1.X, then +you should probably upgrade to the latest stable 5.2.X +release.  Support for earlier versions may be added in the +future.

+

JPL 3.x currently requires a Java 2 +runtime (or development kit), and has been tested with +Sun's jdk1.3.1_01.

+

JPL 3.x contains a native library (jpl.c) +written in ANSI/ISO C and designed to be portable to many +operating system platforms for which suitable compilers are +available.  It has, however, only been tested with Microsoft +Visual C/C++ 5 under Windows NT 4.0 (SP6a).  I +shall be grateful if anyone can (show me how to) tidily adapt the +source and makefiles to build for other platforms.

+
+

Documentation

+

This alpha release of JPL 3.x contains a +hotch-potch of documentation, some left over from Fred Dushin's +(Java-calls-Prolog) JPL 1.0.1 and now obsolete or misleading, +some rewritten for JPL 2.0.2 and still mostly applicable, +and some written for the first release of my Prolog-calls-Java +interface, now part of JPL, and also mostly still +relevant.
+

+

In addition to this document (index.html in jpl's root folder) there +are:
+

+ +

+
+

Installation

+

Put the three library files (jpl.dll, jpl.jar +and jpl.pl) where they can be found by your OS, by your +Java apps and by SWI-Prolog respectively; for details, see JPL +3.x Installation.

+
+

Testing

+

Each of the folders within jpl\examples\java +contains a simple Java application which tests some +aspect of JPL.  These applications are +already compiled, and each folder contains a (DOS/Windows) +script run.bat which announces and +runs the demo.
+ 
+Each of the Prolog source files within jpl/examples/prolog contains a +self-contained Prolog application which exercises JPL from within +Prolog; start an interactive SWI-Prolog session as usual, and then +consult and run these files.
+

+
+
Paul Singleton
+
February 2004
+ + diff --git a/packages/jpl/jpl.doc b/packages/jpl/jpl.doc new file mode 100644 index 000000000..6c06c5011 --- /dev/null +++ b/packages/jpl/jpl.doc @@ -0,0 +1,63 @@ +\documentclass[11pt]{article} +\usepackage{times} +\usepackage{pl} +\usepackage{html} +\sloppy +\makeindex + +\onefile +\htmloutput{html} % Output directory +\htmlmainfile{index} % Main document file +\bodycolor{white} % Page colour + +\begin{document} + +\title{JPL: a SWI-Prolog to Java Interface} +\author{Paul Singleton \\ + Jambusters Ltd \\ + United Kingdom \\ + E-mail: \email{paul@jbgb.com}} + +\maketitle + +\begin{abstract} +This document describes JPL, the SWI-Prolog interface to Java. +\end{abstract} + +\pagebreak +\tableofcontents +\pagebreak + +\section{Introduction} + +\section{Installation} + +\subsection{Unix systems} + +Installation on Unix system uses the commonly found {\em configure}, +{\em make} and {\em make install} sequence. SWI-Prolog should be +installed before building this package. If SWI-Prolog is not installed +as \program{pl}, the environment variable \env{PL} must be set to the +name of the SWI-Prolog executable. Installation is now accomplished +using: + +\begin{code} +% ./configure +% make +% make install +\end{code} + +This installs the foreign libraries in \file{$PLBASE/lib/$PLARCH} and +the Prolog library files in \file{$PLBASE/library}, where +\file{$PLBASE} refers to the SWI-Prolog `home-directory'. + + +\section{Acknowledgments} + +\bibliographystyle{plain} +\bibliography{odbc} + +\printindex + +\end{document} + diff --git a/packages/jpl/jpl.pl b/packages/jpl/jpl.pl new file mode 100644 index 000000000..159ceba65 --- /dev/null +++ b/packages/jpl/jpl.pl @@ -0,0 +1,4715 @@ +/* $Id$ + + Part of JPL -- SWI-Prolog/Java interface + + Author: Paul Singleton, Fred Dushin and Jan Wielemaker + E-mail: paul@jbgb.com + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2004, Paul Singleton + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(jpl, + [ jpl_get_default_jvm_opts/1, + jpl_set_default_jvm_opts/1, + jpl_get_actual_jvm_opts/1, + jpl_pl_lib_version/1, + jpl_c_lib_version/1, + jpl_new/3, + jpl_call/4, + jpl_get/3, + jpl_set/3, + jpl_servlet_byref/3, + jpl_servlet_byval/3, + jpl_class_to_classname/2, + jpl_class_to_type/2, + jpl_classname_to_class/2, + jpl_classname_to_type/2, + jpl_datum_to_type/2, + jpl_false/1, + jpl_is_class/1, + jpl_is_false/1, + jpl_is_null/1, + jpl_is_object/1, + jpl_is_object_type/1, + jpl_is_ref/1, + jpl_is_true/1, + jpl_is_type/1, + jpl_is_void/1, + jpl_null/1, + jpl_object_to_class/2, + jpl_object_to_type/2, + jpl_primitive_type/1, + jpl_ref_to_type/2, + jpl_true/1, + jpl_type_to_class/2, + jpl_type_to_classname/2, + jpl_void/1, + jpl_array_to_length/2, + jpl_array_to_list/2, + jpl_datums_to_array/2, + jpl_enumeration_element/2, + jpl_enumeration_to_list/2, + jpl_hashtable_pair/2, + jpl_iterator_element/2, + jpl_list_to_array/2, + % introduced by vsc + jpl_list_to_array/3, + % end of introduced by vsc + jpl_terms_to_array/2, + jpl_map_element/2, + jpl_set_element/2 + ]). + +:- expects_dialect(swi). + +:- use_module(library(lists)). +:- use_module(library(apply)). +:- use_module(library(shlib)). + +% suppress debugging this library +:- set_prolog_flag(generate_debug_info, false). + +%------------------------------------------------------------------------------ + +jpl_get_default_jvm_opts( Opts) :- + jni_get_default_jvm_opts( Opts). + +%------------------------------------------------------------------------------ + +jpl_set_default_jvm_opts( Opts) :- + is_list( Opts), + length( Opts, N), + jni_set_default_jvm_opts( N, Opts). + +%------------------------------------------------------------------------------ + +jpl_get_actual_jvm_opts( Opts) :- + jni_get_actual_jvm_opts( Opts). + +%------------------------------------------------------------------------------ + +jpl_assert( Fact) :- + ( jpl_assert_policy( Fact, yes) + -> assert( Fact) + ; true + ). + +%------------------------------------------------------------------------------ + +jpl_assert_policy( jpl_field_spec_cache(_,_,_,_,_,_), yes). +jpl_assert_policy( jpl_method_spec_cache(_,_,_,_,_,_,_,_), yes). +jpl_assert_policy( jpl_class_tag_type_cache(_,_), yes). +jpl_assert_policy( jpl_classname_type_cache(_,_), yes). +jpl_assert_policy( jpl_iref_type_cache(_,_), no). % must correspond to JPL_CACHE_TYPE_OF_REF in jpl.c + +jpl_assert_policy( jpl_field_spec_is_cached(_), YN) :- + jpl_assert_policy( jpl_field_spec_cache(_,_,_,_,_,_), YN). +jpl_assert_policy( jpl_method_spec_is_cached(_), YN) :- + jpl_assert_policy( jpl_method_spec_cache(_,_,_,_,_,_,_,_), YN). + +%------------------------------------------------------------------------------ + +% jpl_tidy_iref_type_cache( +Iref) :- +% delete the cached type info, if any, under Iref; +% called from jpl.c's jni_free_iref() via jni_tidy_iref_type_cache() + +jpl_tidy_iref_type_cache( Iref) :- + % write( '[decaching types for iref='), write( Iref), write( ']'), nl, + retractall( jpl_iref_type_cache(Iref,_)), + true. + +%------------------------------------------------------------------------------ + +% jpl_call(+X, +MethodSpec, +Params, -Result) :- +% X should be: +% an object reference +% (for static or instance methods) +% a classname, descriptor or type +% (for static methods of the denoted class) +% +% MethodSpec should be: +% a method name (as an atom) +% (may involve dynamic overload resolution based on inferred types of params) +% +% Params should be: +% a proper list (perhaps empty) of suitable actual parameters for the named method +% +% finally, an attempt will be made to unify Result with the returned result + +jpl_call(X, Mspec, Params, R) :- + ( jpl_object_to_type(X, Type) % the usual case (goal fails safely if X is var or rubbish) + -> Obj = X, + Kind = instance + ; var(X) + -> throw(error(instantiation_error, + context(jpl_call/4, + '1st arg must be bound to an object, classname, descriptor or type'))) + ; atom(X) + -> ( jpl_classname_to_type( X, Type) % does this attempt to load the class? + -> ( jpl_type_to_class( Type, ClassObj) + -> Kind = static + ; throw(error(existence_error(class,X), + context(jpl_call/4, + 'the named class cannot be found'))) + ) + ; throw(error(type_error(class_name_or_descriptor,X), + context(jpl_call/4, '1st arg must be an object, classname, descriptor or type'))) + ) + ; X = class(_,_) + -> Type = X, + jpl_type_to_class( Type, ClassObj), + Kind = static + ; X = array(_) + -> throw(error(type_error(object_or_class,X), + context(jpl_call/4, 'cannot call a static method of an array type, as none exists'))) + ; throw(error(domain_error(object_or_class,X), + context(jpl_call/4, + '1st arg must be an object, classname, descriptor or type'))) + ), + ( atom(Mspec) % the usual case, i.e. a method name + -> true + ; var(Mspec) + -> throw(error(instantiation_error, + context(jpl_call/4, '2nd arg must be an atom naming a public method of the class or object'))) + ; throw(error(type_error(method_name,Mspec), + context(jpl_call/4, '2nd arg must be an atom naming a public method of the class or object'))) + ), + ( is_list(Params) + -> ( catch( + jpl_datums_to_types(Params, Taps), + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_call/4,Msg))) + ) + -> true + ; throw(error(type_error(method_params,Params), + context(jpl_call/4, 'not all actual parameters are convertible to Java values or references'))) + ), + length( Params, A) + ; var(Params) + -> throw(error(instantiation_error, + context(jpl_call/4, '3rd arg must be a proper list of actual parameters for the named method'))) + ; throw(error(type_error(method_params,Params), + context(jpl_call/4, '3rd arg must be a proper list of actual parameters for the named method'))) + ), + ( Kind == instance + -> jpl_call_instance(Type, Obj, Mspec, Params, Taps, A, Rx) + ; jpl_call_static(Type, ClassObj, Mspec, Params, Taps, A, Rx) + ), + ( nonvar(R), + R = {Term} % yucky way of requesting Term->term conversion + -> ( jni_jref_to_term( Rx, TermX) % fails if Rx isn't a JRef to a jpl.Term + -> Term = TermX + ; throw(error(type_error, + context(jpl_call/4, 'result is not a jpl.Term instance as required'))) + ) + ; R = Rx + ). + +%------------------------------------------------------------------------------ + +%% jpl_call_instance(+ObjectType, +Object, +MethodName, Params, +%% ActualParamTypes, Arity, -Result) +% +% call the MethodName-d method (instance or static) of Object +% (which is of ObjectType), which most specifically applies to +% Params, which we have found to be (respectively) of +% ActualParamTypes, and of which there are Arity, yielding Result + +jpl_call_instance(Type, Obj, Mname, Params, Taps, A, Rx) :- + findall( % get remaining details of all accessible methods of Obj's class (as denoted by Type) + z5(I,Mods,MID,Tr,Tfps), + jpl_method_spec(Type, I, Mname, A, Mods, MID, Tr, Tfps), + Z5s + ), + ( Z5s = [] + -> throw(error(existence_error(method,Mname/A), + context(jpl_call/4, + 'the class or object has no public methods with the given name and quantity of parameters'))) + ; findall( + z5(I,Mods,MID,Tr,Tfps), % those to which Params is assignable + ( member(z5(I,Mods,MID,Tr,Tfps), Z5s), + jpl_types_fit_types(Taps, Tfps) % assignability test: actual param types "fit" formal param types + ), + Z5sA % Params-assignable methods + ), + ( Z5sA == [] + -> throw(error(type_error(method_params,Params), + context(jpl_call/4, + 'the actual parameters are not assignable to the formal parameters of any of the named methods'))) + + ; Z5sA = [z5(I,Mods,MID,Tr,Tfps)] + -> true % exactly one applicable method + ; jpl_z5s_to_most_specific_z5(Z5sA, z5(I,Mods,MID,Tr,Tfps)) + -> true % exactly one most-specific applicable method + ; throw(error(existence_error(most_specific_method,Mname/Params), + context(jpl_call/4, + 'more than one most-specific method is found for the actual parameters (this should not happen)'))) + ) + ), + ( member(static, Mods) % if the chosen method is static + -> jpl_object_to_class(Obj, ClassObj), % get a java.lang.Class instance which personifies Obj's class + jpl_call_static_method(Tr, ClassObj, MID, Tfps, Params, Rx) % call static method w.r.t. associated Class object + ; jpl_call_instance_method(Tr, Obj, MID, Tfps, Params, Rx) % else call (non-static) method w.r.t. object itself + ). + +%------------------------------------------------------------------------------ + +%% jpl_call_static(+ClassType, +ClassObject, +MethodName, Params, +%% ActualParamTypes, Arity, -Result) +% +% call the MethodName-d static method of the class (which is of +% ClassType, and which is represented by the java.lang.Class +% instance ClassObject) which most specifically applies to Params, +% which we have found to be (respectively) of ActualParamTypes, +% and of which there are Arity, yielding Result + +jpl_call_static(Type, ClassObj, Mname, Params, Taps, A, Rx) :- + findall( % get all accessible static methods of the class denoted by Type and ClassObj + z5(I,Mods,MID,Tr,Tfps), + ( jpl_method_spec(Type, I, Mname, A, Mods, MID, Tr, Tfps), + member(static, Mods) + ), + Z5s + ), + ( Z5s = [] + -> throw(error(existence_error(method,Mname/A), + context(jpl_call/4, + 'the class has no public static methods with the given name and quantity of parameters'))) + ; findall( + z5(I,Mods,MID,Tr,Tfps), + ( member(z5(I,Mods,MID,Tr,Tfps), Z5s), + jpl_types_fit_types(Taps, Tfps) % assignability test: actual param types "fit" formal param types + ), + Z5sA % Params-assignable methods + ), + ( Z5sA == [] + -> throw(error(type_error(method_params,Params), + context(jpl_call/4, + 'the actual parameters are not assignable to the formal parameters of any of the named methods'))) + ; Z5sA = [z5(I,Mods,MID,Tr,Tfps)] + -> true % exactly one applicable method + ; jpl_z5s_to_most_specific_z5(Z5sA, z5(I,Mods,MID,Tr,Tfps)) + -> true % exactly one most-specific applicable method + ; throw(error(existence_error(most_specific_method,Mname/Params), + context(jpl_call/4, + 'more than one most-specific method is found for the actual parameters (this should not happen)'))) + ) + ), + jpl_call_static_method(Tr, ClassObj, MID, Tfps, Params, Rx). + +%------------------------------------------------------------------------------ + +% jpl_call_instance_method(+Type, +ClassObject, +MethodID, +FormalParamTypes, +Params, -Result) :- + +jpl_call_instance_method(void, Class, MID, Tfps, Ps, R) :- + jCallVoidMethod(Class, MID, Tfps, Ps), + jpl_void(R). + +jpl_call_instance_method(boolean, Class, MID, Tfps, Ps, R) :- + jCallBooleanMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(byte, Class, MID, Tfps, Ps, R) :- + jCallByteMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(char, Class, MID, Tfps, Ps, R) :- + jCallCharMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(short, Class, MID, Tfps, Ps, R) :- + jCallShortMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(int, Class, MID, Tfps, Ps, R) :- + jCallIntMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(long, Class, MID, Tfps, Ps, R) :- + jCallLongMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(float, Class, MID, Tfps, Ps, R) :- + jCallFloatMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(double, Class, MID, Tfps, Ps, R) :- + jCallDoubleMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(array(_), Class, MID, Tfps, Ps, R) :- + jCallObjectMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(class(_,_), Class, MID, Tfps, Ps, R) :- + jCallObjectMethod(Class, MID, Tfps, Ps, R). + +%------------------------------------------------------------------------------ + +% jpl_call_static_method(+Type, +ClassObject, +MethodID, +FormalParamTypes, +Params, -Result) :- + +jpl_call_static_method(void, Class, MID, Tfps, Ps, R) :- + jCallStaticVoidMethod(Class, MID, Tfps, Ps), + jpl_void(R). + +jpl_call_static_method(boolean, Class, MID, Tfps, Ps, R) :- + jCallStaticBooleanMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(byte, Class, MID, Tfps, Ps, R) :- + jCallStaticByteMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(char, Class, MID, Tfps, Ps, R) :- + jCallStaticCharMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(short, Class, MID, Tfps, Ps, R) :- + jCallStaticShortMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(int, Class, MID, Tfps, Ps, R) :- + jCallStaticIntMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(long, Class, MID, Tfps, Ps, R) :- + jCallStaticLongMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(float, Class, MID, Tfps, Ps, R) :- + jCallStaticFloatMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(double, Class, MID, Tfps, Ps, R) :- + jCallStaticDoubleMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(array(_), Class, MID, Tfps, Ps, R) :- + jCallStaticObjectMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(class(_,_), Class, MID, Tfps, Ps, R) :- + jCallStaticObjectMethod(Class, MID, Tfps, Ps, R). + +%------------------------------------------------------------------------------ + +%type jpl_fergus_find_candidate(list(T), T, T, list(T)) + +jpl_fergus_find_candidate([], Candidate, Candidate, []). + +jpl_fergus_find_candidate([X|Xs], Candidate0, Candidate, Rest) :- + ( jpl_fergus_greater(X, Candidate0) + -> Candidate1 = X, + Rest = [Candidate0|Rest1] + ; Candidate1 = Candidate0, + Rest = [X|Rest1] + ), + jpl_fergus_find_candidate(Xs, Candidate1, Candidate, Rest1). + +%------------------------------------------------------------------------------ + +jpl_fergus_greater(z5(_,_,_,_,Tps1), z5(_,_,_,_,Tps2)) :- + jpl_types_fit_types(Tps1, Tps2). +jpl_fergus_greater(z3(_,_,Tps1), z3(_,_,Tps2)) :- + jpl_types_fit_types(Tps1, Tps2). + +%------------------------------------------------------------------------------ + +%type jpl_fergus_is_the_greatest(list(T), T) + +%% jpl_fergus_is_the_greatest(Xs, GreatestX) +% +% Xs is a list of things for which jpl_fergus_greater/2 defines a +% partial ordering; GreatestX is one of those, than which none is +% greater; fails if there is more than one such; this algorithm +% was contributed to c.l.p by Fergus Henderson in response to my +% "there must be a better way" challenge: there was, this is it + +jpl_fergus_is_the_greatest([X|Xs], Greatest) :- + jpl_fergus_find_candidate(Xs, X, Greatest, Rest), + forall( + member(R, Rest), + jpl_fergus_greater(Greatest, R) + ). + +%------------------------------------------------------------------------------ + +%% jpl_get(+X, +Fspec, -V) +% +% X can be: +% * a classname, a descriptor, or an (object or array) type +% (for static fields); +% * a non-array object +% (for static and non-static fields) +% * an array +% (for 'length' pseudo field, or indexed element retrieval), +% but not: +% * a String +% (clashes with class name; anyway, String has no fields to retrieve) +% +% Fspec can be: +% * an atomic field name, +% * or an integral array index (to get an element from an array, +% * or a pair I-J of integers (to get a subrange (slice?) of an +% array) +% +% finally, an attempt will be made to unify V with the retrieved value + +jpl_get(X, Fspec, V) :- + ( jpl_object_to_type(X, Type) + -> Obj = X, + jpl_get_instance( Type, Type, Obj, Fspec, Vx) % pass Type twice for FAI + ; var(X) + -> throw(error(instantiation_error, + context(jpl_get/3, + '1st arg must be bound to an object, classname, descriptor or type'))) + ; jpl_is_type(X) % e.g. class([java,lang],['String']), array(int) + -> Type = X, + ( jpl_type_to_class(Type, ClassObj) + -> jpl_get_static( Type, ClassObj, Fspec, Vx) + ; jpl_type_to_classname( Type, Classname), + throw(error(existence_error(class,Classname), + context(jpl_get/3, + 'the named class cannot be found'))) + ) + ; atom(X) + -> ( jpl_classname_to_type( X, Type) % does this attempt to load the class? + -> ( jpl_type_to_class( Type, ClassObj) + -> jpl_get_static( Type, ClassObj, Fspec, Vx) + ; throw(error(existence_error(class,X), + context(jpl_get/3, + 'the named class cannot be found'))) + ) + ; throw(error(type_error(class_name_or_descriptor,X), + context(jpl_get/3, '1st arg must be an object, classname, descriptor or type'))) + ) + + ; throw(error(domain_error(object_or_class,X), + context(jpl_get/3, + '1st arg must be bound to an object, classname, descriptor or type'))) + ), + ( nonvar(V), + V = {Term} % yucky way of requesting Term->term conversion + -> ( jni_jref_to_term( Vx, TermX) % fails if Rx is not a JRef to a jpl.Term + -> Term = TermX + ; throw(error(type_error, + context(jpl_call/4, 'result is not a jpl.Term instance as required'))) + ) + ; V = Vx + ). + +%------------------------------------------------------------------------------ + +%% jpl_get_static(+Type, +ClassObject, +FieldName, -Value) +% +% ClassObject is an instance of java.lang.Class which represents +% the same class as Type; Value (Vx below) is guaranteed unbound +% on entry, and will, before exit, be unified with the retrieved +% value + +jpl_get_static(Type, ClassObj, Fname, Vx) :- + ( atom(Fname) % assume it's a field name + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_get/3, '2nd arg must be bound to an atom naming a public field of the class'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_get/3, '2nd arg must be an atom naming a public field of the class'))) + ), + % get static fields of the denoted class + findall( + z4(I,Mods,FID,Tf), + ( jpl_field_spec(Type, I, Fname, Mods, FID, Tf), + member(static, Mods) + ), + Z4s + ), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_get/3, + 'the class or object has no public static field with the given name'))) + ; Z4s = [z4(I,_Mods,FID,Tf)] + -> jpl_get_static_field(Tf, ClassObj, FID, Vx) + ; throw(error(existence_error(unique_field,Fname), + context(jpl_get/3, + 'more than one field is found with the given name'))) + ). + +%------------------------------------------------------------------------------ + +% jpl_get_instance(+Type, +Type, +Object, +FieldSpecifier, -Value) :- + +jpl_get_instance(class(_,_), Type, Obj, Fname, Vx) :- + ( atom(Fname) % the usual case + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_get/3, '2nd arg must be bound to an atom naming a public field of the class or object'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_get/3, '2nd arg must be an atom naming a public field of the class or object'))) + ), + findall(z4(I,Mods,FID,Tf), + jpl_field_spec(Type, I, Fname, Mods, FID, Tf), + Z4s), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_get/3, + 'the class or object has no public field with the given name'))) + ; Z4s = [z4(I,Mods,FID,Tf)] + -> ( member(static, Mods) + -> jpl_object_to_class(Obj, ClassObj), + jpl_get_static_field(Tf, ClassObj, FID, Vx) + ; jpl_get_instance_field(Tf, Obj, FID, Vx) + ) + ; throw(error(existence_error(unique_field,Fname), + context(jpl_get/3, + 'more than one field is found with the given name'))) + ). + +jpl_get_instance(array(ElementType), _, Array, Fspec, Vx) :- + ( var(Fspec) + -> throw(error(instantiation_error, + context(jpl_get/3, + 'when 1st arg is an array, 2nd arg must be bound to an index, an index range, or ''length'''))) + ; integer(Fspec) + -> ( Fspec < 0 % lo bound check + -> throw(error(domain_error(array_index,Fspec), + context(jpl_get/3, + 'when 1st arg is an array, integral 2nd arg must be non-negative'))) + ; jGetArrayLength(Array, Len), + Fspec >= Len % hi bound check + -> throw(error(domain_error(array_index,Fspec), + context(jpl_get/3, + 'when 1st arg is an array, integral 2nd arg must not exceed upper bound of array'))) + ; jpl_get_array_element(ElementType, Array, Fspec, Vx) + ) + ; Fspec = N-M % NB should we support e.g. 3-2 -> [] ? + -> ( integer(N), + integer(M) + -> ( N >= 0, + M >= N + -> jGetArrayLength(Array, Len), + ( N >= Len + -> throw(error(domain_error(array_index_range,N-M), + context(jpl_get/3, + 'lower bound of array index range must not exceed upper bound of array'))) + ; M >= Len + -> throw(error(domain_error(array_index_range,N-M), + context(jpl_get/3, + 'upper bound of array index range must not exceed upper bound of array'))) + ; jpl_get_array_elements(ElementType, Array, N, M, Vx) + ) + ; throw(error(domain_error(array_index_range,N-M), + context(jpl_get/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; throw(error(type_error(array_index_range,N-M), + context(jpl_get/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; atom(Fspec) + -> ( Fspec == length % special-case for this solitary array "method" + -> jGetArrayLength(Array, Vx) + ; throw(error(domain_error(array_field_name,Fspec), + context(jpl_get/3, + 'the array has no public field with the given name'))) + ) + ; throw(error(type_error(array_lookup_spec,Fspec), + context(jpl_get/3, + 'when 1st arg is an array, 2nd arg must be an index, an index range, or ''length'''))) + ). + +%------------------------------------------------------------------------------ + +%% jpl_get_array_element(+ElementType, +Array, +Index, -Vc) +% +% Array is (a reference to) an array of ElementType; Vc is +% (unified with a JPL repn of) its Index-th (numbered from 0) +% element Java values are now converted to Prolog terms within +% foreign code +% +% @tbd more of this could be done within foreign code ... + +jpl_get_array_element(Type, Array, Index, Vc) :- + ( ( Type = class(_,_) + ; Type = array(_) + ) + -> jGetObjectArrayElement(Array, Index, Vr) + ; jpl_primitive_type(Type) + -> jni_type_to_xput_code(Type, Xc), + jni_alloc_buffer(Xc, 1, Bp), % one-element buf for a Type + jpl_get_primitive_array_region(Type, Array, Index, 1, Bp), + jni_fetch_buffer_value(Bp, 0, Vr, Xc), % zero-th element + jni_free_buffer(Bp) + ), + Vr = Vc. % redundant since Vc is always (?) unbound at call + +%------------------------------------------------------------------------------ + +%% jpl_get_array_elements(+ElementType, +Array, +N, +M, -Vs) +% +% serves only jpl_get_instance Vs will always be unbound on entry + +jpl_get_array_elements(ElementType, Array, N, M, Vs) :- + ( ( ElementType = class(_,_) + ; ElementType = array(_) + ) + -> jpl_get_object_array_elements(Array, N, M, Vs) + ; jpl_get_primitive_array_elements(ElementType, Array, N, M, Vs) + ). + +%------------------------------------------------------------------------------ + +jpl_get_instance_field(boolean, Obj, FieldID, V) :- + jGetBooleanField(Obj, FieldID, V). +jpl_get_instance_field(byte, Obj, FieldID, V) :- + jGetByteField(Obj, FieldID, V). +jpl_get_instance_field(char, Obj, FieldID, V) :- + jGetCharField(Obj, FieldID, V). +jpl_get_instance_field(short, Obj, FieldID, V) :- + jGetShortField(Obj, FieldID, V). +jpl_get_instance_field(int, Obj, FieldID, V) :- + jGetIntField(Obj, FieldID, V). +jpl_get_instance_field(long, Obj, FieldID, V) :- + jGetLongField(Obj, FieldID, V). +jpl_get_instance_field(float, Obj, FieldID, V) :- + jGetFloatField(Obj, FieldID, V). +jpl_get_instance_field(double, Obj, FieldID, V) :- + jGetDoubleField(Obj, FieldID, V). +jpl_get_instance_field(class(_,_), Obj, FieldID, V) :- + jGetObjectField(Obj, FieldID, V). +jpl_get_instance_field(array(_), Obj, FieldID, V) :- + jGetObjectField(Obj, FieldID, V). + +%------------------------------------------------------------------------------ + +%% jpl_get_object_array_elements(+Array, +LoIndex, +HiIndex, -Vcs) +% +% Array should be a (zero-based) array of some object (array or +% non-array) type; LoIndex is an integer, 0 =< LoIndex < +% length(Array); HiIndex is an integer, LoIndex-1 =< HiIndex < +% length(Array); at call, Vcs will be unbound; at exit, Vcs will +% be a list of (references to) the array's elements +% [LoIndex..HiIndex] inclusive + +jpl_get_object_array_elements(Array, Lo, Hi, Vcs) :- + ( Lo =< Hi + -> Vcs = [Vc|Vcs2], + jGetObjectArrayElement(Array, Lo, Vc), + Next is Lo+1, + jpl_get_object_array_elements(Array, Next, Hi, Vcs2) + ; Vcs = [] + ). + +%------------------------------------------------------------------------------ + +%% jpl_get_primitive_array_elements(+ElementType, +Array, +LoIndex, +HiIndex, -Vcs) +% +% Array should be a (zero-based) Java array of (primitive) +% ElementType; Vcs should be unbound on entry, and on exit will be +% a list of (JPL representations of the values of) the elements +% [LoIndex..HiIndex] inclusive + +jpl_get_primitive_array_elements(ElementType, Array, Lo, Hi, Vcs) :- + Size is Hi-Lo+1, + ( Size == 0 + -> Vcs = [] + ; jni_type_to_xput_code(ElementType, Xc), + jni_alloc_buffer(Xc, Size, Bp), + jpl_get_primitive_array_region(ElementType, Array, Lo, Size, Bp), + jpl_primitive_buffer_to_array(ElementType, Xc, Bp, 0, Size, Vcs), + jni_free_buffer(Bp) + ). + +%------------------------------------------------------------------------------ + +jpl_get_primitive_array_region(boolean, Array, Lo, S, I) :- + jGetBooleanArrayRegion(Array, Lo, S, jbuf(I,boolean)). +jpl_get_primitive_array_region(byte, Array, Lo, S, I) :- + jGetByteArrayRegion(Array, Lo, S, jbuf(I,byte)). +jpl_get_primitive_array_region(char, Array, Lo, S, I) :- + jGetCharArrayRegion(Array, Lo, S, jbuf(I,char)). +jpl_get_primitive_array_region(short, Array, Lo, S, I) :- + jGetShortArrayRegion(Array, Lo, S, jbuf(I,short)). +jpl_get_primitive_array_region(int, Array, Lo, S, I) :- + jGetIntArrayRegion(Array, Lo, S, jbuf(I,int)). +jpl_get_primitive_array_region(long, Array, Lo, S, I) :- + jGetLongArrayRegion(Array, Lo, S, jbuf(I,long)). +jpl_get_primitive_array_region(float, Array, Lo, S, I) :- + jGetFloatArrayRegion(Array, Lo, S, jbuf(I,float)). +jpl_get_primitive_array_region(double, Array, Lo, S, I) :- + jGetDoubleArrayRegion(Array, Lo, S, jbuf(I,double)). + +%------------------------------------------------------------------------------ + +jpl_get_static_field(boolean, Array, FieldID, V) :- + jGetStaticBooleanField(Array, FieldID, V). +jpl_get_static_field(byte, Array, FieldID, V) :- + jGetStaticByteField(Array, FieldID, V). +jpl_get_static_field(char, Array, FieldID, V) :- + jGetStaticCharField(Array, FieldID, V). +jpl_get_static_field(short, Array, FieldID, V) :- + jGetStaticShortField(Array, FieldID, V). +jpl_get_static_field(int, Array, FieldID, V) :- + jGetStaticIntField(Array, FieldID, V). +jpl_get_static_field(long, Array, FieldID, V) :- + jGetStaticLongField(Array, FieldID, V). +jpl_get_static_field(float, Array, FieldID, V) :- + jGetStaticFloatField(Array, FieldID, V). +jpl_get_static_field(double, Array, FieldID, V) :- + jGetStaticDoubleField(Array, FieldID, V). +jpl_get_static_field(class(_,_), Array, FieldID, V) :- + jGetStaticObjectField(Array, FieldID, V). +jpl_get_static_field(array(_), Array, FieldID, V) :- + jGetStaticObjectField(Array, FieldID, V). + +%------------------------------------------------------------------------------ + +%% jpl_new(+X, +Params, -V) +% +% X can be: +% * an atomic classname +% e.g. 'java.lang.String' +% * an atomic descriptor +% e.g. '[I' or 'Ljava.lang.String;' +% * a suitable type +% i.e. any class(_,_) or array(_) +% +% if X is an object (non-array) type or descriptor and Params is a +% list of values or references, then V is the result of an invocation +% of that type's most specifically-typed constructor to whose +% respective formal parameters the actual Params are assignable (and +% assigned) +% +% if X is an array type or descriptor and Params is a list of values +% or references, each of which is (independently) assignable to the +% array element type, then V is a new array of as many elements as +% Params has members, initialised with the respective members of +% Params; +% +% if X is an array type or descriptor and Params is a non-negative +% integer N, then V is a new array of that type, with N elements, each +% initialised to Java's appropriate default value for the type; +% +% If V is {Term} then we attempt to convert a new jpl.Term instance to +% a corresponding term; this is of little obvious use here, but is +% consistent with jpl_call/4 and jpl_get/3 + +jpl_new(X, Params, V) :- + ( var(X) + -> throw(error(instantiation_error, + context(jpl_new/3, + '1st arg must be bound to a classname, descriptor or object type'))) + ; jpl_is_type(X) % NB only class(_,_) or array(_) + -> Type = X + ; atom(X) % e.g. 'java.lang.String', '[L', 'boolean' + -> ( jpl_classname_to_type(X, Type) + -> true + ; throw(error(domain_error(classname,X), + context(jpl_new/3, + 'if 1st arg is an atom, it must be a classname or descriptor'))) + ) + ; throw(error(type_error(instantiable,X), + context(jpl_new/3, + '1st arg must be a classname, descriptor or object type'))) + ), + jpl_new_1(Type, Params, Vx), + ( nonvar(V), + V = {Term} % yucky way of requesting Term->term conversion + -> ( jni_jref_to_term( Vx, TermX) % fails if Rx is not a JRef to a jpl.Term + -> Term = TermX + ; throw(error(type_error, + context(jpl_call/4, 'result is not a jpl.Term instance as required'))) + ) + ; V = Vx + ). + +%------------------------------------------------------------------------------ + +% jpl_new_1(+Tx, +Params, -Vx) :- +% (serves only jpl_new/3) +% +% Tx can be: +% a class(_,_) or array(_) type; +% +% Params must be: +% a proper list of constructor parameters +% +% at exit, Vx is bound to a JPL reference to a new, initialised instance of Tx + +jpl_new_1(class(Ps,Cs), Params, Vx) :- + !, % green (see below) + Tx = class(Ps,Cs), + ( var(Params) + -> throw(error(instantiation_error, + context(jpl_new/3, + '2nd arg must be a proper list of valid parameters for a constructor'))) + ; \+ is_list(Params) + -> throw(error(type_error(list,Params), + context(jpl_new/3, + '2nd arg must be a proper list of valid parameters for a constructor'))) + ; true + ), + length(Params, A), % the "arity" of the required constructor + jpl_type_to_class(Tx, Cx), % throws Java exception if class is not found + N = '', % JNI's constructor naming convention for GetMethodID() + Tr = void, % all constructors have this return "type" + findall( + z3(I,MID,Tfps), + jpl_method_spec(Tx, I, N, A, _Mods, MID, Tr, Tfps), % cached + Z3s + ), + ( Z3s == [] % no constructors which require the given qty of parameters? + -> jpl_type_to_classname( Tx, Cn), + ( jpl_call( Cx, isInterface, [], @(true)) + -> throw(error(type_error(concrete_class,Cn), + context(jpl_new/3, + 'cannot create instance of an interface'))) + ; throw(error(existence_error(constructor,Cn/A), + context(jpl_new/3, + 'no constructor found with the corresponding quantity of parameters'))) + ) + ; ( catch( + jpl_datums_to_types(Params, Taps), % infer actual parameter types + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_new/3,Msg))) + ) + -> true + ; throw(error(domain_error(list(jpl_datum),Params), + context(jpl_new/3, + 'one or more of the actual parameters is not a valid representation of any Java value or object'))) + ), + findall( + z3(I,MID,Tfps), % select constructors to which actual parameters are assignable + ( member(z3(I,MID,Tfps), Z3s), + jpl_types_fit_types(Taps, Tfps) % assignability test: actual parameter types "fit" formal parameter types? + ), + Z3sA + ), + ( Z3sA == [] % no type-assignable constructors? + -> ( Z3s = [_] + -> throw(error(existence_error(constructor,Tx/A), + context(jpl_new/3, + 'the actual parameters are not assignable to the formal parameter types of the only constructor which takes this qty of parameters'))) + ; throw(error(type_error(constructor_args,Params), + context(jpl_new/3, + 'the actual parameters are not assignable to the formal parameter types of any of the constructors which take this qty of parameters'))) + ) + ; Z3sA = [z3(I,MID,Tfps)] + -> true + ; jpl_z3s_to_most_specific_z3(Z3sA, z3(I,MID,Tfps)) + -> true + ; throw(error(type_error(constructor_params,Params), + context(jpl_new/3, + 'more than one most-specific matching constructor (shouldn''t happen)'))) + ) + ), + catch( + jNewObject(Cx, MID, Tfps, Params, Vx), + error(java_exception(@(_)), 'java.lang.InstantiationException'), + ( jpl_type_to_classname( Tx, Cn), + throw(error(type_error(concrete_class,Cn), + context(jpl_new/3, + 'cannot create instance of an abstract class'))) + ) + ), + jpl_cache_type_of_ref(Tx, Vx). % since we know it + +jpl_new_1(array(T), Params, Vx) :- + !, + ( var(Params) + -> throw(error(instantiation_error, + context(jpl_new/3, + 'when constructing a new array, 2nd arg must either be a non-negative integer (denoting the required array length) or a proper list of valid element values'))) + ; integer(Params) % integer I -> array[0..I-1] of default values + -> ( Params >= 0 + -> Len is Params + ; throw(error(domain_error(array_length,Params), + context(jpl_new/3, + 'when constructing a new array, if the 2nd arg is an integer (denoting the required array length) then it must be non-negative'))) + ) + ; is_list(Params) % [V1,..VN] -> array[0..N-1] of respective values + -> length(Params, Len) + ), + jpl_new_array(T, Len, Vx), % NB may throw out-of-memory exception + ( nth0(I, Params, Param), % nmember fails silently when Params is integer + jpl_set(Vx, I, Param), + fail + ; true + ), + jpl_cache_type_of_ref(array(T), Vx). % since we know it + +jpl_new_1(T, _Params, _Vx) :- % doomed attempt to create new primitive type instance (formerly a dubious completist feature :-) + jpl_primitive_type(T), + !, + throw(error(domain_error(object_type,T), + context(jpl_new/3, + 'cannot construct an instance of a primitive type'))). + % ( var(Params) + % -> throw(error(instantiation_error, + % context(jpl_new/3, + % 'when constructing a new instance of a primitive type, 2nd arg must be bound (to a representation of a suitable value)'))) + % ; Params == [] + % -> jpl_primitive_type_default_value(T, Vx) + % ; Params = [Param] + % -> jpl_primitive_type_term_to_value(T, Param, Vx) + % ; throw(error(domain_error(constructor_args,Params), + % context(jpl_new/3, + % 'when constructing a new instance of a primitive type, 2nd arg must either be an empty list (indicating that the default value of that type is required) or a list containing exactly one representation of a suitable value)'))) + % ). + +jpl_new_1( T, _, _) :- + throw(error(domain_error(jpl_type,T), + context(jpl_new/3, + '1st arg must denote a known or plausible type'))). + +%------------------------------------------------------------------------------ + +% jpl_new_array(+ElementType, +Length, -NewArray) :- + +jpl_new_array(boolean, Len, A) :- + jNewBooleanArray(Len, A). + +jpl_new_array(byte, Len, A) :- + jNewByteArray(Len, A). + +jpl_new_array(char, Len, A) :- + jNewCharArray(Len, A). + +jpl_new_array(short, Len, A) :- + jNewShortArray(Len, A). + +jpl_new_array(int, Len, A) :- + jNewIntArray(Len, A). + +jpl_new_array(long, Len, A) :- + jNewLongArray(Len, A). + +jpl_new_array(float, Len, A) :- + jNewFloatArray(Len, A). + +jpl_new_array(double, Len, A) :- + jNewDoubleArray(Len, A). + +jpl_new_array(array(T), Len, A) :- + jpl_type_to_class(array(T), C), + jNewObjectArray(Len, C, @(null), A). % initialise each element to null + +jpl_new_array(class(Ps,Cs), Len, A) :- + jpl_type_to_class(class(Ps,Cs), C), + jNewObjectArray(Len, C, @(null), A). + +%------------------------------------------------------------------------------ + +% jpl_set(+X, +Fspec, +V) :- +% basically, sets the Fspec-th field of class or object X to value V +% iff it is assignable +% +% X can be: +% a class instance +% (for static or non-static fields) +% an array +% (for indexed element or subrange assignment) +% a classname, or a class/2 or array/1 type +% (for static fields) +% but not: +% a String (no fields to retrieve) +% +% Fspec can be: +% an atomic field name +% (overloading through shadowing has yet to be handled properly) +% an array index I +% (X must be an array object: V is assigned to X[I]) +% a pair I-J of integers +% (X must be an array object, V must be a list of values: successive members of V are assigned to X[I..J]) +% +% V must be a suitable value or object + +jpl_set(X, Fspec, V) :- + ( jpl_object_to_type(X, Type) % the usual case (test is safe if X is var or rubbish) + -> Obj = X, + catch( + jpl_set_instance(Type, Type, Obj, Fspec, V), % first 'Type' is for FAI + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_set/3,Msg))) + ) + ; var(X) + -> throw(error(instantiation_error, + context(jpl_set/3, + '1st arg must be an object, classname, descriptor or type'))) + ; ( atom(X) + -> ( jpl_classname_to_type(X, Type) % it's a classname or descriptor... + -> true + ; throw(error(existence_error(class,X), + context(jpl_set/3, + 'the named class cannot be found'))) + ) + ; ( X = class(_,_) % it's a class type... + ; X = array(_) % ...or an array type + ) + -> Type = X + ), + ( jpl_type_to_class( Type, ClassObj) % ...whose Class object is available + -> true + ; jpl_type_to_classname( Type, Classname), + throw(error(existence_error(class,Classname), + context(jpl_set/3, + 'the class cannot be found'))) + ) + -> catch( + jpl_set_static(Type, ClassObj, Fspec, V), + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_set/3,Msg))) + ) + ; throw(error(domain_error(object_or_class,X), + context(jpl_set/3, + '1st arg must be an object, classname, descriptor or type'))) + ). + +%------------------------------------------------------------------------------ + +% jpl_set_instance(+Type, +Type, +ObjectReference, +FieldName, +Value) :- +% ObjectReference is a JPL reference to a Java object +% of the class denoted by Type (which is passed twice for first agument indexing); +% FieldName should name a public, non-final (static or non-static) field of this object, +% but could be anything, and is validated here; +% Value should be assignable to the named field, but could be anything, and is validated here + +jpl_set_instance(class(_,_), Type, Obj, Fname, V) :- % a non-array object + ( atom(Fname) % the usual case + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_set/3, + '2nd arg must be bound to the name of a public, non-final field'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_set/3, + '2nd arg must be the name of a public, non-final field'))) + ), + findall( + z4(I,Mods,FID,Tf), + jpl_field_spec(Type, I, Fname, Mods, FID, Tf), % public fields of class denoted by Type + Z4s + ), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_set/3, + 'no public fields of the object have this name'))) + ; Z4s = [z4(I,Mods,FID,Tf)] + -> ( member(final, Mods) + -> throw(error(permission_error(modify,final_field,Fname), + context(jpl_set/3, + 'cannot assign a value to a final field (actually you could but I''ve decided not to let you)'))) + ; jpl_datum_to_type( V, Tv) + -> ( jpl_type_fits_type( Tv, Tf) + -> ( member(static, Mods) + -> jpl_object_to_class(Obj, ClassObj), + jpl_set_static_field(Tf, ClassObj, FID, V) + ; jpl_set_instance_field(Tf, Obj, FID, V) % oughta be jpl_set_instance_field? + ) + ; jpl_type_to_nicename( Tf, NNf), + throw(error(type_error(NNf,V), + context(jpl_set/3, + 'the value is not assignable to the named field of the class'))) + ) + ; throw(error(type_error(field_value,V), + context(jpl_set/3, + '3rd arg does not represent any Java value or object'))) + ) + ; throw(error(existence_error(field,Fname), % 'existence'? or some other sort of error maybe? + context(jpl_set/3, + 'more than one public field of the object has this name (this should not happen)'))) + ). + + +jpl_set_instance(array(Type), _, Obj, Fspec, V) :- + ( is_list(V) % a list of array element values + -> Vs = V + ; var(V) + -> throw(error(instantiation_error, + context(jpl_set/3, 'when 1st arg is an array, 3rd arg must be bound to a suitable element value or list of values'))) + ; Vs = [V] % a single array element value + ), + length(Vs, Iv), + ( var(Fspec) + -> throw(error(instantiation_error, + context(jpl_set/3, + 'when 1st arg is an array, 2nd arg must be bound to an index or index range'))) + ; integer(Fspec) % single-element assignment + -> ( Fspec < 0 + -> throw(error(domain_error(array_index,Fspec), + context(jpl_set/3, + 'when 1st arg is an array, an integral 2nd arg must be a non-negative index'))) + ; Iv is 1 + -> N is Fspec + ; Iv is 0 + -> throw(error(domain_error(array_element(Fspec),Vs), + context(jpl_set/3, + 'no values for array element assignment: needs one'))) + ; throw(error(domain_error(array_element(Fspec),Vs), + context(jpl_set/3, + 'too many values for array element assignment: needs one'))) + ) + ; Fspec = N-M % element-sequence assignment + -> ( integer(N), + integer(M) + -> ( N >= 0, + Size is (M-N)+1, + Size >= 0 + -> ( Size == Iv + -> true + ; Size < Iv + -> throw(error(domain_error(array_elements(N-M),Vs), + context(jpl_set/3, + 'too few values for array range assignment'))) + ; throw(error(domain_error(array_elements(N-M),Vs), + context(jpl_set/3, + 'too many values for array range assignment'))) + ) + ; throw(error(domain_error(array_index_range,N-M), + context(jpl_set/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; throw(error(type_error(array_index_range,N-M), + context(jpl_set/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; atom(Fspec) + -> ( Fspec == length + -> throw(error(permission_error(modify,final_field,length), + context(jpl_set/3, + 'cannot assign a value to a final field'))) + ; throw(error(existence_error(field,Fspec), + context(jpl_set/3, + 'array has no field with that name'))) + ) + ; throw(error(domain_error(array_index,Fspec), + context(jpl_set/3, + 'when 1st arg is an array object, 2nd arg must be a non-negative index or index range'))) + ), + jpl_set_array(Type, Obj, N, Iv, Vs). + +%------------------------------------------------------------------------------ + +% jpl_set_static(+Type, +ClassObj, +FieldName, +Value) :- +% we can rely on: +% Type being a class/2 type representing some accessible class +% ClassObj being an instance of java.lang.Class which represents the same class as Type +% but FieldName could be anything, so we validate it here, +% look for a suitable (static) field of the target class, +% then call jpl_set_static_field/4 to attempt to assign Value (which could be anything) to it +% +% NB this does not yet handle shadowed fields correctly... + +jpl_set_static(Type, ClassObj, Fname, V) :- + ( atom(Fname) % the usual case + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_set/3, + 'when 1st arg denotes a class, 2nd arg must be bound to the name of a public, static, non-final field'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_set/3, + 'when 1st arg denotes a class, 2nd arg must be the name of a public, static, non-final field'))) + ), + findall( % get all static fields of the denoted class + z4(I,Mods,FID,Tf), + ( jpl_field_spec(Type, I, Fname, Mods, FID, Tf), + member(static, Mods) + ), + Z4s + ), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_set/3, + 'class has no public static fields of this name'))) + ; Z4s = [z4(I,Mods,FID,Tf)] % exactly one synonymous field? + -> ( member(final, Mods) + -> throw(error(permission_error(modify,final_field,Fname), + context(jpl_set/3, + 'cannot assign a value to a final field'))) + ; jpl_datum_to_type(V, Tv) + -> ( jpl_type_fits_type(Tv, Tf) + -> jpl_set_static_field(Tf, ClassObj, FID, V) + ; jpl_type_to_nicename(Tf, NNf), + throw(error(type_error(NNf,V), + context(jpl_set/3, + 'the value is not assignable to the named field of the class'))) + ) + ; throw(error(type_error(field_value,V), + context(jpl_set/3, + '3rd arg does not represent any Java value or object'))) + ) + ; throw(error(existence_error(field,Fname), + context(jpl_set/3, + 'more than one public static field of the class has this name (this should not happen)(?)'))) + ). + +%------------------------------------------------------------------------------ + +%% jpl_set_array(+ElementType, +Array, +Offset, +DatumQty, +Datums) +% +% Datums, of which there are DatumQty, are stashed in successive +% elements of Array which is an array of ElementType starting at +% the Offset-th (numbered from 0) throws +% error(type_error(acyclic,_),context(jpl_datum_to_type/2,_)) + +jpl_set_array(T, A, N, I, Ds) :- + ( jpl_datums_to_types(Ds, Tds) % most specialised types of given values + -> ( jpl_types_fit_type(Tds, T) % all assignable to element type? + -> true + ; throw(error(type_error(array(T),Ds), + context(jpl_set/3, + 'not all values are assignable to the array element type'))) + ) + ; throw(error(type_error(array(T),Ds), + context(jpl_set/3, + 'not all values are convertible to Java values or references'))) + ), + ( ( T = class(_,_) + ; T = array(_) % array elements are objects + ) + -> ( nth0(J, Ds, D), % for each datum + Nd is N+J, % compute array index + ( D = {Tq} % quoted term? + -> jni_term_to_jref(Tq, D2) % convert to a JPL reference to a corresponding jpl.Term object + ; D = D2 + ), + jSetObjectArrayElement(A, Nd, D2), + fail % iterate + ; true + ) + ; jpl_primitive_type(T) % array elements are primitive values + -> jni_type_to_xput_code(T, Xc), + jni_alloc_buffer(Xc, I, Bp), % I-element buf of required primitive type + jpl_set_array_1(Ds, T, 0, Bp), + jpl_set_elements(T, A, N, I, Bp), + jni_free_buffer(Bp) + ; throw(error(system_error(array_element_type,T), + context(jpl_set/3, + 'array element type is unknown (this should not happen)'))) + ). + +%------------------------------------------------------------------------------ + +%% jpl_set_array_1(+Values, +Type, +BufferIndex, +BufferPointer) +% +% successive members of Values are stashed as (primitive) Type +% from the BufferIndex-th element (numbered from 0) onwards of the +% buffer indicated by BufferPointer NB this could be done more +% efficiently (?) within foreign code... + +jpl_set_array_1([], _, _, _). +jpl_set_array_1([V|Vs], Tprim, Ib, Bp) :- + jni_type_to_xput_code(Tprim, Xc), + jni_stash_buffer_value(Bp, Ib, V, Xc), + Ibnext is Ib+1, + jpl_set_array_1(Vs, Tprim, Ibnext, Bp). + +%------------------------------------------------------------------------------ + +jpl_set_elements(boolean, Obj, N, I, Bp) :- + jSetBooleanArrayRegion(Obj, N, I, jbuf(Bp,boolean)). +jpl_set_elements(char, Obj, N, I, Bp) :- + jSetCharArrayRegion(Obj, N, I, jbuf(Bp,char)). +jpl_set_elements(byte, Obj, N, I, Bp) :- + jSetByteArrayRegion(Obj, N, I, jbuf(Bp,byte)). +jpl_set_elements(short, Obj, N, I, Bp) :- + jSetShortArrayRegion(Obj, N, I, jbuf(Bp,short)). +jpl_set_elements(int, Obj, N, I, Bp) :- + jSetIntArrayRegion(Obj, N, I, jbuf(Bp,int)). +jpl_set_elements(long, Obj, N, I, Bp) :- + jSetLongArrayRegion(Obj, N, I, jbuf(Bp,long)). +jpl_set_elements(float, Obj, N, I, Bp) :- + jSetFloatArrayRegion(Obj, N, I, jbuf(Bp,float)). +jpl_set_elements(double, Obj, N, I, Bp) :- + jSetDoubleArrayRegion(Obj, N, I, jbuf(Bp,double)). + +%------------------------------------------------------------------------------ + +%% jpl_set_instance_field(+Type, +Obj, +FieldID, +V) +% +% we can rely on Type, Obj and FieldID being valid, and on V being +% assignable (if V is a quoted term then it is converted here) + +jpl_set_instance_field(boolean, Obj, FieldID, V) :- + jSetBooleanField(Obj, FieldID, V). +jpl_set_instance_field(byte, Obj, FieldID, V) :- + jSetByteField(Obj, FieldID, V). +jpl_set_instance_field(char, Obj, FieldID, V) :- + jSetCharField(Obj, FieldID, V). +jpl_set_instance_field(short, Obj, FieldID, V) :- + jSetShortField(Obj, FieldID, V). +jpl_set_instance_field(int, Obj, FieldID, V) :- + jSetIntField(Obj, FieldID, V). +jpl_set_instance_field(long, Obj, FieldID, V) :- + jSetLongField(Obj, FieldID, V). +jpl_set_instance_field(float, Obj, FieldID, V) :- + jSetFloatField(Obj, FieldID, V). +jpl_set_instance_field(double, Obj, FieldID, V) :- + jSetDoubleField(Obj, FieldID, V). +jpl_set_instance_field(class(_,_), Obj, FieldID, V) :- % also handles byval term assignments + ( V = {T} % quoted term? + -> jni_term_to_jref(T, V2) % convert to a JPL reference to a corresponding jpl.Term object + ; V = V2 + ), + jSetObjectField(Obj, FieldID, V2). +jpl_set_instance_field(array(_), Obj, FieldID, V) :- + jSetObjectField(Obj, FieldID, V). + +%------------------------------------------------------------------------------ + +% jpl_set_static_field(+Type, +ClassObj, +FieldID, +V) :- +% we can rely on Type, ClassObj and FieldID being valid, +% and on V being assignable (if V is a quoted term then it is converted here) + +jpl_set_static_field(boolean, Obj, FieldID, V) :- + jSetStaticBooleanField(Obj, FieldID, V). + +jpl_set_static_field(byte, Obj, FieldID, V) :- + jSetStaticByteField(Obj, FieldID, V). + +jpl_set_static_field(char, Obj, FieldID, V) :- + jSetStaticCharField(Obj, FieldID, V). + +jpl_set_static_field(short, Obj, FieldID, V) :- + jSetStaticShortField(Obj, FieldID, V). + +jpl_set_static_field(int, Obj, FieldID, V) :- + jSetStaticIntField(Obj, FieldID, V). + +jpl_set_static_field(long, Obj, FieldID, V) :- + jSetStaticLongField(Obj, FieldID, V). + +jpl_set_static_field(float, Obj, FieldID, V) :- + jSetStaticFloatField(Obj, FieldID, V). + +jpl_set_static_field(double, Obj, FieldID, V) :- + jSetStaticDoubleField(Obj, FieldID, V). + +jpl_set_static_field(class(_,_), Obj, FieldID, V) :- % also handles byval term assignments + ( V = {T} % quoted term? + -> jni_term_to_jref(T, V2) % convert to a JPL reference to a corresponding jpl.Term object + ; V = V2 + ), + jSetStaticObjectField(Obj, FieldID, V2). + +jpl_set_static_field(array(_), Obj, FieldID, V) :- + jSetStaticObjectField(Obj, FieldID, V). + +%------------------------------------------------------------------------------ + +% jpl_z3s_to_most_specific_z3(+Zs, -Z) :- +% Zs is a list of arity-matching, type-suitable z3(I,MID,Tfps) +% Z is the single most specific element of Zs, +% i.e. that than which no other z3/3 has a more specialised signature; +% fails if there is more than one such + +jpl_z3s_to_most_specific_z3(Zs, Z) :- + jpl_fergus_is_the_greatest(Zs, Z). + +%------------------------------------------------------------------------------ + +% jpl_z5s_to_most_specific_z5(+Zs, -Z) :- +% Zs is a list of arity-matching, type-suitable z5(I,Mods,MID,Tr,Tfps) +% Z is the single most specific element of Zs, +% i.e. that than which no other z5/5 has a more specialised signature +% (this fails if there is more than one such) + +jpl_z5s_to_most_specific_z5(Zs, Z) :- + jpl_fergus_is_the_greatest(Zs, Z). + +%------------------------------------------------------------------------------ + +% jpl_pl_lib_version(-VersionString) :- +% jpl_pl_lib_version(-Major, -Minor, -Patch, -Status) :- + +jpl_pl_lib_version(VersionString) :- + jpl_pl_lib_version(Major, Minor, Patch, Status), + atomic_list_concat([Major,'.',Minor,'.',Patch,'-',Status], VersionString). + + +jpl_pl_lib_version(3, 1, 4, alpha). + +%------------------------------------------------------------------------------ + +% jpl_type_alfa(0'$) --> % presumably not allowed +% "$". % given the "inner class" syntax? + +jpl_type_alfa(0'_) --> + "_", + !. + +jpl_type_alfa(C) --> + [C], { C>=0'a, C=<0'z }, + !. + +jpl_type_alfa(C) --> + [C], { C>=0'A, C=<0'Z }. + +%------------------------------------------------------------------------------ + +jpl_type_alfa_num(C) --> + jpl_type_alfa(C), + !. + +jpl_type_alfa_num(C) --> + [C], { C>=0'0, C=<0'9 }. + +%------------------------------------------------------------------------------ + +jpl_type_array_classname(array(T)) --> + "[", jpl_type_classname_2(T). + +%------------------------------------------------------------------------------ + +jpl_type_array_descriptor(array(T)) --> + "[", jpl_type_descriptor_1(T). + +%------------------------------------------------------------------------------ + +jpl_type_bare_class_descriptor(class(Ps,Cs)) --> + jpl_type_slashed_package_parts(Ps), jpl_type_class_parts(Cs). + +%------------------------------------------------------------------------------ + +jpl_type_bare_classname(class(Ps,Cs)) --> + jpl_type_dotted_package_parts(Ps), jpl_type_class_parts(Cs). + +%------------------------------------------------------------------------------ + +jpl_type_class_descriptor(class(Ps,Cs)) --> + "L", jpl_type_bare_class_descriptor(class(Ps,Cs)), ";". + +%------------------------------------------------------------------------------ + +jpl_type_class_part(N) --> + jpl_type_id(N). + +%------------------------------------------------------------------------------ + +jpl_type_class_parts([C|Cs]) --> + jpl_type_class_part(C), jpl_type_inner_class_parts(Cs). + +%------------------------------------------------------------------------------ + +jpl_type_classname_1(T) --> + jpl_type_bare_classname(T), + !. + +jpl_type_classname_1(T) --> + jpl_type_array_classname(T), + !. + +jpl_type_classname_1(T) --> + jpl_type_primitive(T). + +%------------------------------------------------------------------------------ + +jpl_type_classname_2(T) --> + jpl_type_delimited_classname(T). + +jpl_type_classname_2(T) --> + jpl_type_array_classname(T). + +jpl_type_classname_2(T) --> + jpl_type_primitive(T). + +%------------------------------------------------------------------------------ + +jpl_type_delimited_classname(Class) --> + "L", jpl_type_bare_classname(Class), ";". + +%------------------------------------------------------------------------------ + +jpl_type_descriptor_1(T) --> + jpl_type_primitive(T), + !. + +jpl_type_descriptor_1(T) --> + jpl_type_class_descriptor(T), + !. + +jpl_type_descriptor_1(T) --> + jpl_type_array_descriptor(T), + !. + +jpl_type_descriptor_1(T) --> + jpl_type_method_descriptor(T). + +%------------------------------------------------------------------------------ + +jpl_type_dotted_package_parts([P|Ps]) --> + jpl_type_package_part(P), ".", !, jpl_type_dotted_package_parts(Ps). + +jpl_type_dotted_package_parts([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_findclassname(T) --> + jpl_type_bare_class_descriptor(T). + +jpl_type_findclassname(T) --> + jpl_type_array_descriptor(T). + +%------------------------------------------------------------------------------ + +jpl_type_id(A) --> + { nonvar(A) -> atom_codes(A,[C|Cs]) ; true }, + jpl_type_alfa(C), jpl_type_id_rest(Cs), + { atom_codes(A, [C|Cs]) }. + +%------------------------------------------------------------------------------ + +jpl_type_id_rest([C|Cs]) --> + jpl_type_alfa_num(C), !, jpl_type_id_rest(Cs). + +jpl_type_id_rest([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_id_v2(A) --> % inner class name parts (empirically) + { nonvar(A) -> atom_codes(A,Cs) ; true }, + jpl_type_id_rest(Cs), + { atom_codes(A, Cs) }. + +%------------------------------------------------------------------------------ + +jpl_type_inner_class_part(N) --> + jpl_type_id_v2(N). + +%------------------------------------------------------------------------------ + +jpl_type_inner_class_parts([C|Cs]) --> + "$", jpl_type_inner_class_part(C), !, jpl_type_inner_class_parts(Cs). + +jpl_type_inner_class_parts([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_method_descriptor(method(Ts,T)) --> + "(", jpl_type_method_descriptor_args(Ts), ")", jpl_type_method_descriptor_return(T). + +%------------------------------------------------------------------------------ + +jpl_type_method_descriptor_args([T|Ts]) --> + jpl_type_descriptor_1(T), !, jpl_type_method_descriptor_args(Ts). + +jpl_type_method_descriptor_args([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_method_descriptor_return(T) --> + jpl_type_void(T). + +jpl_type_method_descriptor_return(T) --> + jpl_type_descriptor_1(T). + +%------------------------------------------------------------------------------ + +jpl_type_package_part(N) --> + jpl_type_id(N). + +%------------------------------------------------------------------------------ + +jpl_type_primitive(boolean) --> + "Z", + !. + +jpl_type_primitive(byte) --> + "B", + !. + +jpl_type_primitive(char) --> + "C", + !. + +jpl_type_primitive(short) --> + "S", + !. + +jpl_type_primitive(int) --> + "I", + !. + +jpl_type_primitive(long) --> + "J", + !. + +jpl_type_primitive(float) --> + "F", + !. + +jpl_type_primitive(double) --> + "D". + +%------------------------------------------------------------------------------ + +jpl_type_slashed_package_parts([P|Ps]) --> + jpl_type_package_part(P), "/", !, jpl_type_slashed_package_parts(Ps). + +jpl_type_slashed_package_parts([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_void(void) --> + "V". + +%------------------------------------------------------------------------------ + +%type jCallBooleanMethod(object, method_id, types, datums, boolean) + +% jCallBooleanMethod(+Obj, +MethodID, +Types, +Params, -Rbool) :- + +jCallBooleanMethod(Obj, MethodID, Types, Params, Rbool) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(39, Obj, MethodID, ParamBuf, Rbool). + +%------------------------------------------------------------------------------ + +%type jCallByteMethod(object, method_id, types, datums, byte) + +% jCallByteMethod(+Obj, +MethodID, +Types, +Params, -Rbyte) :- + +jCallByteMethod(Obj, MethodID, Types, Params, Rbyte) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(42, Obj, MethodID, ParamBuf, Rbyte). + +%------------------------------------------------------------------------------ + +%type jCallCharMethod(object, method_id, types, datums, char) + +% jCallCharMethod(+Obj, +MethodID, +Types, +Params, -Rchar) :- + +jCallCharMethod(Obj, MethodID, Types, Params, Rchar) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(45, Obj, MethodID, ParamBuf, Rchar). + +%------------------------------------------------------------------------------ + +%type jCallDoubleMethod(object, method_id, types, datums, double) + +% jCallDoubleMethod(+Obj, +MethodID, +Types, +Params, -Rdouble) :- + +jCallDoubleMethod(Obj, MethodID, Types, Params, Rdouble) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(60, Obj, MethodID, ParamBuf, Rdouble). + +%------------------------------------------------------------------------------ + +%type jCallFloatMethod(object, method_id, types, datums, float) + +% jCallFloatMethod(+Obj, +MethodID, +Types, +Params, -Rfloat) :- + +jCallFloatMethod(Obj, MethodID, Types, Params, Rfloat) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(57, Obj, MethodID, ParamBuf, Rfloat). + +%------------------------------------------------------------------------------ + +%type jCallIntMethod(object, method_id, types, datums, int) + +% jCallIntMethod(+Obj, +MethodID, +Types, +Params, -Rint) :- + +jCallIntMethod(Obj, MethodID, Types, Params, Rint) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(51, Obj, MethodID, ParamBuf, Rint). + +%------------------------------------------------------------------------------ + +%type jCallLongMethod(object, method_id, types, datums, long) + +% jCallLongMethod(+Obj, +MethodID, +Types, +Params, -Rlong) :- + +jCallLongMethod(Obj, MethodID, Types, Params, Rlong) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(54, Obj, MethodID, ParamBuf, Rlong). + +%------------------------------------------------------------------------------ + +%type jCallObjectMethod(object, method_id, types, datums, object) + +% jCallObjectMethod(+Obj, +MethodID, +Types, +Params, -Robj) :- + +jCallObjectMethod(Obj, MethodID, Types, Params, Robj) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(36, Obj, MethodID, ParamBuf, Robj). + +%------------------------------------------------------------------------------ + +%type jCallShortMethod(object, method_id, types, datums, short) + +% jCallShortMethod(+Obj, +MethodID, +Types, +Params, -Rshort) :- + +jCallShortMethod(Obj, MethodID, Types, Params, Rshort) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(48, Obj, MethodID, ParamBuf, Rshort). + +%------------------------------------------------------------------------------ + +%type jCallStaticBooleanMethod(class, types, datums, boolean) + +% jCallStaticBooleanMethod(+Class, +MethodID, +Types, +Params, -Rbool) :- + +jCallStaticBooleanMethod(Class, MethodID, Types, Params, Rbool) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(119, Class, MethodID, ParamBuf, Rbool). + +%------------------------------------------------------------------------------ + +%type jCallStaticByteMethod(class, method_id, types, datums, byte) + +% jCallStaticByteMethod(+Class, +MethodID, +Types, +Params, -Rbyte) :- + +jCallStaticByteMethod(Class, MethodID, Types, Params, Rbyte) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(122, Class, MethodID, ParamBuf, Rbyte). + +%------------------------------------------------------------------------------ + +%type jCallStaticCharMethod(class, method_id, types, datums, char) + +% jCallStaticCharMethod(+Class, +MethodID, +Types, +Params, -Rchar) :- + +jCallStaticCharMethod(Class, MethodID, Types, Params, Rchar) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(125, Class, MethodID, ParamBuf, Rchar). + +%------------------------------------------------------------------------------ + +%type jCallStaticDoubleMethod(class, method_id, types, datums, double) + +% jCallStaticDoubleMethod(+Class, +MethodID, +Types, +Params, -Rdouble) :- + +jCallStaticDoubleMethod(Class, MethodID, Types, Params, Rdouble) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(140, Class, MethodID, ParamBuf, Rdouble). + +%------------------------------------------------------------------------------ + +%type jCallStaticFloatMethod(class, method_id, types, datums, float) + +% jCallStaticFloatMethod(+Class, +MethodID, +Types, +Params, -Rfloat) :- + +jCallStaticFloatMethod(Class, MethodID, Types, Params, Rfloat) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(137, Class, MethodID, ParamBuf, Rfloat). + +%------------------------------------------------------------------------------ + +%type jCallStaticIntMethod(class, method_id, types, datums, int) + +% jCallStaticIntMethod(+Class, +MethodID, +Types, +Params, -Rint) :- + +jCallStaticIntMethod(Class, MethodID, Types, Params, Rint) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(131, Class, MethodID, ParamBuf, Rint). + +%------------------------------------------------------------------------------ + +%type jCallStaticLongMethod(class, method_id, types, datums, long) + +% jCallStaticLongMethod(+Class, +MethodID, +Types, +Params, -Rlong) :- + +jCallStaticLongMethod(Class, MethodID, Types, Params, Rlong) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(134, Class, MethodID, ParamBuf, Rlong). + +%------------------------------------------------------------------------------ + +%type jCallStaticObjectMethod(class, method_id, types, datums, object) + +% jCallStaticObjectMethod(+Class, +MethodID, +Types, +Params, -Robj) :- + +jCallStaticObjectMethod(Class, MethodID, Types, Params, Robj) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(116, Class, MethodID, ParamBuf, Robj). + +%------------------------------------------------------------------------------ + +%type jCallStaticShortMethod(class, method_id, types, datums, short) + +% jCallStaticShortMethod(+Class, +MethodID, +Types, +Params, -Rshort) :- + +jCallStaticShortMethod(Class, MethodID, Types, Params, Rshort) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(128, Class, MethodID, ParamBuf, Rshort). + +%------------------------------------------------------------------------------ + +%type jCallStaticVoidMethod(class, method_id, types, datums) + +% jCallStaticVoidMethod(+Class, +MethodID, +Types, +Params) :- + +jCallStaticVoidMethod(Class, MethodID, Types, Params) :- + jni_params_put(Params, Types, ParamBuf), + jni_void(143, Class, MethodID, ParamBuf). + +%------------------------------------------------------------------------------ + +%type jCallVoidMethod(object, method_id, types, datums) + +% jCallVoidMethod(+Obj, +MethodID, +Types, +Params) :- + +jCallVoidMethod(Obj, MethodID, Types, Params) :- + jni_params_put(Params, Types, ParamBuf), + jni_void(63, Obj, MethodID, ParamBuf). + +%------------------------------------------------------------------------------ + +%type jFindClass(findclassname, class) + +% jFindClass(+ClassName, -Class) :- + +jFindClass(ClassName, Class) :- + jni_func(6, ClassName, Class). + +%------------------------------------------------------------------------------ + +%type jGetArrayLength(array, int) + +% jGetArrayLength(+Array, -Size) :- + +jGetArrayLength(Array, Size) :- + jni_func(171, Array, Size). + +%------------------------------------------------------------------------------ + +%type jGetBooleanArrayRegion(boolean_array, int, int, boolean_buf) + +% jGetBooleanArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetBooleanArrayRegion(Array, Start, Len, Buf) :- + jni_void(199, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetBooleanField(object, field_id, boolean) + +% jGetBooleanField(+Obj, +FieldID, -Rbool) :- + +jGetBooleanField(Obj, FieldID, Rbool) :- + jni_func(96, Obj, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jGetByteArrayRegion(byte_array, int, int, byte_buf) + +% jGetByteArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetByteArrayRegion(Array, Start, Len, Buf) :- + jni_void(200, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetByteField(object, field_id, byte) + +% jGetByteField(+Obj, +FieldID, -Rbyte) :- + +jGetByteField(Obj, FieldID, Rbyte) :- + jni_func(97, Obj, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jGetCharArrayRegion(char_array, int, int, char_buf) + +% jGetCharArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetCharArrayRegion(Array, Start, Len, Buf) :- + jni_void(201, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetCharField(object, field_id, char) + +% jGetCharField(+Obj, +FieldID, -Rchar) :- + +jGetCharField(Obj, FieldID, Rchar) :- + jni_func(98, Obj, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jGetDoubleArrayRegion(double_array, int, int, double_buf) + +% jGetDoubleArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetDoubleArrayRegion(Array, Start, Len, Buf) :- + jni_void(206, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetDoubleField(object, field_id, double) + +% jGetDoubleField(+Obj, +FieldID, -Rdouble) :- + +jGetDoubleField(Obj, FieldID, Rdouble) :- + jni_func(103, Obj, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jGetFieldID(class, descriptor, field_id) + +% jGetFieldID(+Class, +Name, +Typedescriptor, -FieldID) :- + +jGetFieldID(Class, Name, Type, FieldID) :- + jpl_type_to_descriptor(Type, TD), + jni_func(94, Class, Name, TD, FieldID). + +%------------------------------------------------------------------------------ + +%type jGetFloatArrayRegion(float_array, int, int, float_buf) + +% jGetFloatArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetFloatArrayRegion(Array, Start, Len, Buf) :- + jni_void(205, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetFloatField(object, field_id, float) + +% jGetFloatField(+Obj, +FieldID, -Rfloat) :- + +jGetFloatField(Obj, FieldID, Rfloat) :- + jni_func(102, Obj, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jGetIntArrayRegion(int_array, int, int, int_buf) + +% jGetIntArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetIntArrayRegion(Array, Start, Len, Buf) :- + jni_void(203, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetIntField(object, field_id, int) + +% jGetIntField(+Obj, +FieldID, -Rint) :- + +jGetIntField(Obj, FieldID, Rint) :- + jni_func(100, Obj, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jGetLongArrayRegion(long_array, int, int, long_buf) + +% jGetLongArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetLongArrayRegion(Array, Start, Len, Buf) :- + jni_void(204, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetLongField(object, field_id, long) + +% jGetLongField(+Obj, +FieldID, -Rlong) :- + +jGetLongField(Obj, FieldID, Rlong) :- + jni_func(101, Obj, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jGetMethodID(class, name, descriptor, method_id) + +% jGetMethodID(+Class, +Name, +TypeDescriptor, -MethodID) :- + +jGetMethodID(Class, Name, Type, MethodID) :- + jpl_type_to_descriptor(Type, TD), + jni_func(33, Class, Name, TD, MethodID). + +%------------------------------------------------------------------------------ + +%type jGetObjectArrayElement(object_array, int, object) + +% jGetObjectArrayElement(+Array, +Index, -Obj) :- + +jGetObjectArrayElement(Array, Index, Obj) :- + jni_func(173, Array, Index, Obj). + +%------------------------------------------------------------------------------ + +%type jGetObjectClass(object, class) + +% jGetObjectClass(+Object, -Class) :- + +jGetObjectClass(Object, Class) :- + jni_func(31, Object, Class). + +%------------------------------------------------------------------------------ + +%type jGetObjectField(object, field_id, object) + +% jGetObjectField(+Obj, +FieldID, -RObj) :- + +jGetObjectField(Obj, FieldID, Robj) :- + jni_func(95, Obj, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jGetShortArrayRegion(short_array, int, int, short_buf) + +% jGetShortArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetShortArrayRegion(Array, Start, Len, Buf) :- + jni_void(202, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetShortField(object, field_id, short) + +% jGetShortField(+Obj, +FieldID, -Rshort) :- + +jGetShortField(Obj, FieldID, Rshort) :- + jni_func(99, Obj, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +%type jGetStaticBooleanField(class, field_id, boolean) + +% jGetStaticBooleanField(+Class, +FieldID, -Rbool) :- + +jGetStaticBooleanField(Class, FieldID, Rbool) :- + jni_func(146, Class, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jGetStaticByteField(class, field_id, byte) + +% jGetStaticByteField(+Class, +FieldID, -Rbyte) :- + +jGetStaticByteField(Class, FieldID, Rbyte) :- + jni_func(147, Class, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jGetStaticCharField(class, field_id, char) + +% jGetStaticCharField(+Class, +FieldID, -Rchar) :- + +jGetStaticCharField(Class, FieldID, Rchar) :- + jni_func(148, Class, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jGetStaticDoubleField(class, field_id, double) + +% jGetStaticDoubleField(+Class, +FieldID, -Rdouble) :- + +jGetStaticDoubleField(Class, FieldID, Rdouble) :- + jni_func(153, Class, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jGetStaticFieldID(class, name, field_id) + +% jGetStaticFieldID(+Class, +Name, +TypeDescriptor, -FieldID) :- + +jGetStaticFieldID(Class, Name, Type, FieldID) :- + jpl_type_to_descriptor(Type, TD), % cache this? + jni_func(144, Class, Name, TD, FieldID). + +%------------------------------------------------------------------------------ + +%type jGetStaticFloatField(class, field_id, float) + +% jGetStaticFloatField(+Class, +FieldID, -Rfloat) :- + +jGetStaticFloatField(Class, FieldID, Rfloat) :- + jni_func(152, Class, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jGetStaticIntField(class, field_id, int) + +% jGetStaticIntField(+Class, +FieldID, -Rint) :- + +jGetStaticIntField(Class, FieldID, Rint) :- + jni_func(150, Class, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jGetStaticLongField(class, field_id, long) + +% jGetStaticLongField(+Class, +FieldID, -Rlong) :- + +jGetStaticLongField(Class, FieldID, Rlong) :- + jni_func(151, Class, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jGetStaticMethodID(class, name, method_id) + +% jGetStaticMethodID(+Class, +Name, +TypeDescriptor, -MethodID) :- + +jGetStaticMethodID(Class, Name, Type, MethodID) :- + jpl_type_to_descriptor(Type, TD), + jni_func(113, Class, Name, TD, MethodID). + +%------------------------------------------------------------------------------ + +%type jGetStaticObjectField(class, field_id, object) + +% jGetStaticObjectField(+Class, +FieldID, -RObj) :- + +jGetStaticObjectField(Class, FieldID, Robj) :- + jni_func(145, Class, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jGetStaticShortField(class, field_id, short) + +% jGetStaticShortField(+Class, +FieldID, -Rshort) :- + +jGetStaticShortField(Class, FieldID, Rshort) :- + jni_func(149, Class, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +%type jGetSuperclass(object, object) + +% jGetSuperclass(+Class1, -Class2) :- + +jGetSuperclass(Class1, Class2) :- + jni_func(10, Class1, Class2). + +%------------------------------------------------------------------------------ + +%type jIsAssignableFrom(object, object) + +% jIsAssignableFrom(+Class1, +Class2) :- + +jIsAssignableFrom(Class1, Class2) :- + jni_func(11, Class1, Class2, @(true)). + +%------------------------------------------------------------------------------ + +%type jNewBooleanArray(int, boolean_array) + +% jNewBooleanArray(+Length, -Array) :- + +jNewBooleanArray(Length, Array) :- + jni_func(175, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewByteArray(int, byte_array) + +% jNewByteArray(+Length, -Array) :- + +jNewByteArray(Length, Array) :- + jni_func(176, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewCharArray(int, char_array) + +% jNewCharArray(+Length, -Array) :- + +jNewCharArray(Length, Array) :- + jni_func(177, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewDoubleArray(int, double_array) + +% jNewDoubleArray(+Length, -Array) :- + +jNewDoubleArray(Length, Array) :- + jni_func(182, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewFloatArray(int, float_array) + +% jNewFloatArray(+Length, -Array) :- + +jNewFloatArray(Length, Array) :- + jni_func(181, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewIntArray(int, int_array) + +% jNewIntArray(+Length, -Array) :- + +jNewIntArray(Length, Array) :- + jni_func(179, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewLongArray(int, long_array) + +% jNewLongArray(+Length, -Array) :- + +jNewLongArray(Length, Array) :- + jni_func(180, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewObject(class, method_id, types, datums, object) + +% jNewObject(+Class, +MethodID, +Types, +Params, -Obj) :- + +jNewObject(Class, MethodID, Types, Params, Obj) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(30, Class, MethodID, ParamBuf, Obj). + +%------------------------------------------------------------------------------ + +%type jNewObjectArray(int, class, object, object_array) + +% jNewObjectArray(+Len, +Class, +InitVal, -Array) :- + +jNewObjectArray(Len, Class, InitVal, Array) :- + jni_func(172, Len, Class, InitVal, Array). + +%------------------------------------------------------------------------------ + +%type jNewShortArray(int, short_array) + +% jNewShortArray(+Length, -Array) :- + +jNewShortArray(Length, Array) :- + jni_func(178, Length, Array). + +%------------------------------------------------------------------------------ + +%type jSetBooleanArrayRegion(boolean_array, int, int, boolean_buf) + +% jSetBooleanArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetBooleanArrayRegion(Array, Start, Len, Buf) :- + jni_void(207, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetBooleanField(object, field_id, boolean) + +% jSetBooleanField(+Obj, +FieldID, +Rbool) :- + +jSetBooleanField(Obj, FieldID, Rbool) :- + jni_void(105, Obj, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jSetByteArrayRegion(byte_array, int, int, byte_buf) + +% jSetByteArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetByteArrayRegion(Array, Start, Len, Buf) :- + jni_void(208, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetByteField(object, field_id, byte) + +% jSetByteField(+Obj, +FieldID, +Rbyte) :- + +jSetByteField(Obj, FieldID, Rbyte) :- + jni_void(106, Obj, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jSetCharArrayRegion(char_array, int, int, char_buf) + +% jSetCharArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetCharArrayRegion(Array, Start, Len, Buf) :- + jni_void(209, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetCharField(object, field_id, char) + +% jSetCharField(+Obj, +FieldID, +Rchar) :- + +jSetCharField(Obj, FieldID, Rchar) :- + jni_void(107, Obj, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jSetDoubleArrayRegion(double_array, int, int, double_buf) + +% jSetDoubleArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetDoubleArrayRegion(Array, Start, Len, Buf) :- + jni_void(214, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetDoubleField(object, field_id, double) + +% jSetDoubleField(+Obj, +FieldID, +Rdouble) :- + +jSetDoubleField(Obj, FieldID, Rdouble) :- + jni_void(112, Obj, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jSetFloatArrayRegion(float_array, int, int, float_buf) + +% jSetFloatArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetFloatArrayRegion(Array, Start, Len, Buf) :- + jni_void(213, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetFloatField(object, field_id, float) + +% jSetFloatField(+Obj, +FieldID, +Rfloat) :- + +jSetFloatField(Obj, FieldID, Rfloat) :- + jni_void(111, Obj, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jSetIntArrayRegion(int_array, int, int, int_buf) + +% jSetIntArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetIntArrayRegion(Array, Start, Len, Buf) :- + jni_void(211, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetIntField(object, field_id, int) + +% jSetIntField(+Obj, +FieldID, +Rint) :- + +jSetIntField(Obj, FieldID, Rint) :- + jni_void(109, Obj, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jSetLongArrayRegion(long_array, int, int, long_buf) + +% jSetLongArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetLongArrayRegion(Array, Start, Len, Buf) :- + jni_void(212, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetLongField(object, field_id, long) + +% jSetLongField(+Obj, +FieldID, +Rlong) :- + +jSetLongField(Obj, FieldID, Rlong) :- + jni_void(110, Obj, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jSetObjectArrayElement(object_array, int, object) + +% jSetObjectArrayElement(+Array, +Index, +Obj) :- + +jSetObjectArrayElement(Array, Index, Obj) :- + jni_void(174, Array, Index, Obj). + +%------------------------------------------------------------------------------ + +%type jSetObjectField(object, field_id, object) + +% jSetObjectField(+Obj, +FieldID, +RObj) :- + +jSetObjectField(Obj, FieldID, Robj) :- + jni_void(104, Obj, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jSetShortArrayRegion(short_array, int, int, short_buf) + +% jSetShortArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetShortArrayRegion(Array, Start, Len, Buf) :- + jni_void(210, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetShortField(object, field_id, short) + +% jSetShortField(+Obj, +FieldID, +Rshort) :- + +jSetShortField(Obj, FieldID, Rshort) :- + jni_void(108, Obj, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +%type jSetStaticBooleanField(class, field_id, boolean) + +% jSetStaticBooleanField(+Class, +FieldID, +Rbool) :- + +jSetStaticBooleanField(Class, FieldID, Rbool) :- + jni_void(155, Class, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jSetStaticByteField(class, field_id, byte) + +% jSetStaticByteField(+Class, +FieldID, +Rbyte) :- + +jSetStaticByteField(Class, FieldID, Rbyte) :- + jni_void(156, Class, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jSetStaticCharField(class, field_id, char) + +% jSetStaticCharField(+Class, +FieldID, +Rchar) :- + +jSetStaticCharField(Class, FieldID, Rchar) :- + jni_void(157, Class, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jSetStaticDoubleField(class, field_id, double) + +% jSetStaticDoubleField(+Class, +FieldID, +Rdouble) :- + +jSetStaticDoubleField(Class, FieldID, Rdouble) :- + jni_void(162, Class, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jSetStaticFloatField(class, field_id, float) + +% jSetStaticFloatField(+Class, +FieldID, +Rfloat) :- + +jSetStaticFloatField(Class, FieldID, Rfloat) :- + jni_void(161, Class, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jSetStaticIntField(class, field_id, int) + +% jSetStaticIntField(+Class, +FieldID, +Rint) :- + +jSetStaticIntField(Class, FieldID, Rint) :- + jni_void(159, Class, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jSetStaticLongField(class, field_id, long) + +% jSetStaticLongField(+Class, +FieldID, +Rlong) :- + +jSetStaticLongField(Class, FieldID, Rlong) :- + jni_void(160, Class, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jSetStaticObjectField(class, field_id, object) + +% jSetStaticObjectField(+Class, +FieldID, +Robj) :- + +jSetStaticObjectField(Class, FieldID, Robj) :- + jni_void(154, Class, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jSetStaticShortField(class, field_id, short) + +% jSetStaticShortField(+Class, +FieldID, +Rshort) :- + +jSetStaticShortField(Class, FieldID, Rshort) :- + jni_void(158, Class, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +% jni_params_put(+Params, +Types, -ParamBuf) :- +% the old form used a static buffer, hence was not re-entrant; +% the new form allocates a buffer of one jvalue per arg, +% puts the (converted) args into respective elements, then returns it +% (the caller is responsible for freeing it) + +jni_params_put(As, Ts, ParamBuf) :- + jni_ensure_jvm, % in case e.g. NewStringUTF() is called + length(As, N), + jni_type_to_xput_code(jvalue, Xc), % Xc will be 15 + jni_alloc_buffer(Xc, N, ParamBuf), + jni_params_put_1(As, 0, Ts, ParamBuf). + +%------------------------------------------------------------------------------ + +% jni_params_put_1(+Params, +N, +JPLTypes, +ParamBuf) :- +% Params is a (full or partial) list of args-not-yet-stashed, +% and Types are their (JPL) types (e.g. 'boolean'); +% N is the arg and buffer index (0+) at which the head of Params is to be stashed; +% the old form used a static buffer and hence was non-reentrant; +% the new form uses a dynamically allocated buffer (which oughta be freed after use) +% +%NB if the (user-provided) actual params were to be unsuitable for conversion +%NB to the method-required types, this would fail silently (without freeing the buffer); +%NB it's not clear whether the overloaded-method-resolution ensures that all args +%NB are convertible + +jni_params_put_1([], _, [], _). + +jni_params_put_1([A|As], N, [Tjni|Ts], ParamBuf) :- % type checking? + ( jni_type_to_xput_code(Tjni, Xc) + -> ( A = {Term} % a quoted general term? + -> jni_term_to_jref( Term, Ax) % convert it to a @(Tag) ref to a new Term instance + ; A = Ax + ), + jni_param_put(N, Xc, Ax, ParamBuf) % foreign + ; fail % oughta raise an exception? + ), + N2 is N+1, + jni_params_put_1(As, N2, Ts, ParamBuf). % stash remaining params (if any) + +%------------------------------------------------------------------------------ + +% jni_type_to_xput_code(+JspType, -JniXputCode) :- +% NB JniXputCode determines widening and casting in foreign code +% NB the codes could be compiled into jni_method_spec_cache etc. +% instead of, or as well as, types (for - small - efficiency gain) + +jni_type_to_xput_code(boolean, 1). % JNI_XPUT_BOOLEAN + +jni_type_to_xput_code(byte, 2). % JNI_XPUT_BYTE + +jni_type_to_xput_code(char, 3). % JNI_XPUT_CHAR + +jni_type_to_xput_code(short, 4). % JNI_XPUT_SHORT + +jni_type_to_xput_code(int, 5). % JNI_XPUT_INT + +jni_type_to_xput_code(long, 6). % JNI_XPUT_LONG + +jni_type_to_xput_code(float, 7). % JNI_XPUT_FLOAT + +jni_type_to_xput_code(double, 8). % JNI_XPUT_DOUBLE + +jni_type_to_xput_code(class(_,_), 12). % JNI_XPUT_REF + +jni_type_to_xput_code(array(_), 12). % JNI_XPUT_REF + +jni_type_to_xput_code(jvalue, 15). % JNI_XPUT_JVALUE + +%------------------------------------------------------------------------------ + +% jpl_class_to_constructor_array(+Class, -MethodArray) :- +% might this be done more efficiently in foreign code? or in Java? + +jpl_class_to_constructor_array(Cx, Ma) :- + jpl_classname_to_class('java.lang.Class', CC), % cacheable? + jGetMethodID( + CC, + getConstructors, + method([],array(class([java,lang,reflect],['Constructor']))), + MID + ), % cacheable? + jCallObjectMethod(Cx, MID, [], [], Ma). + +%------------------------------------------------------------------------------ + +% jpl_class_to_constructors(+Class, -Methods) :- + +jpl_class_to_constructors(Cx, Ms) :- + jpl_class_to_constructor_array(Cx, Ma), + jpl_object_array_to_list(Ma, Ms). + +%------------------------------------------------------------------------------ + +% jpl_class_to_field_array(+Class, -FieldArray) :- + +jpl_class_to_field_array(Cx, Fa) :- + jpl_classname_to_class('java.lang.Class', CC), % cacheable? + jGetMethodID( + CC, + getFields, + method([],array(class([java,lang,reflect],['Field']))), + MID + ), % cacheable? + jCallObjectMethod(Cx, MID, [], [], Fa). + +%------------------------------------------------------------------------------ + +% jpl_class_to_fields(+Class, -Fields) :- +% do this in Java (ditto for methods)? + +jpl_class_to_fields(C, Fs) :- + jpl_class_to_field_array(C, Fa), + jpl_object_array_to_list(Fa, Fs). + +%------------------------------------------------------------------------------ + +% jpl_class_to_method_array(+Class, -MethodArray) :- +% migrate into foreign code for efficiency? + +jpl_class_to_method_array(Cx, Ma) :- + jpl_classname_to_class('java.lang.Class', CC), % cacheable? + jGetMethodID( + CC, + getMethods, + method([],array(class([java,lang,reflect],['Method']))), + MID + ), % cacheable? + jCallObjectMethod(Cx, MID, [], [], Ma). + +%------------------------------------------------------------------------------ + +% jpl_class_to_methods(+Class, -Methods) :- +% also used for constructors +% do this in Java (ditto for fields)? + +jpl_class_to_methods(Cx, Ms) :- + jpl_class_to_method_array(Cx, Ma), + jpl_object_array_to_list(Ma, Ms). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_modifiers(+Method, -Modifiers) :- +% migrate into foreign code for efficiency? + +jpl_constructor_to_modifiers(X, Ms) :- + jpl_classname_to_class('java.lang.reflect.Constructor', Cx), % cached? + jpl_method_to_modifiers_1(X, Cx, Ms). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_name(+Method, -Name) :- +% it is a JNI convention that each constructor behaves (at least, +% for reflection), as a method whose name is '' + +jpl_constructor_to_name(_X, ''). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_parameter_types(+Method, -ParameterTypes) :- +% migrate to foreign code for efficiency? + +jpl_constructor_to_parameter_types(X, Tfps) :- + jpl_classname_to_class('java.lang.reflect.Constructor', Cx), % cached? + jpl_method_to_parameter_types_1(X, Cx, Tfps). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_return_type(+Method, -Type) :- +% it is a JNI convention that, for the purposes of retrieving a MethodID, +% a constructor has a return type of 'void' + +jpl_constructor_to_return_type(_X, void). + +%------------------------------------------------------------------------------ + +% jpl_field_spec(+Type, -Index, -Name, -Modifiers, -MID, -FieldType) :- +% I'm unsure whether arrays have fields, but if they do, this will handle them correctly + +jpl_field_spec(T, I, N, Mods, MID, Tf) :- + ( jpl_field_spec_is_cached(T) + -> jpl_field_spec_cache(T, I, N, Mods, MID, Tf) + ; jpl_type_to_class(T, C), + jpl_class_to_fields(C, Fs), + ( T = array(_BaseType) % regardless of base type... + -> Tci = array(_) % ...the "cache index" type is this + ; Tci = T + ), + jpl_field_spec_1(C, Tci, Fs), + jpl_assert(jpl_field_spec_is_cached(Tci)), + jpl_field_spec_cache(Tci, I, N, Mods, MID, Tf) + ). + +%------------------------------------------------------------------------------ + +jpl_field_spec_1(C, Tci, Fs) :- + ( nth1(I, Fs, F), + jpl_field_to_name(F, N), + jpl_field_to_modifiers(F, Mods), + jpl_field_to_type(F, Tf), + ( member(static, Mods) + -> jGetStaticFieldID(C, N, Tf, MID) + ; jGetFieldID(C, N, Tf, MID) + ), + jpl_assert(jpl_field_spec_cache(Tci,I,N,Mods,MID,Tf)), + fail + ; true + ). + +%------------------------------------------------------------------------------ + +:- dynamic jpl_field_spec_cache/6. % document this... + +%------------------------------------------------------------------------------ + +:- dynamic jpl_field_spec_is_cached/1. % document this... + +%------------------------------------------------------------------------------ + +%type jpl_field_to_modifiers(object, ordset(modifier)) + +% jpl_field_to_modifiers(+Field, -Modifiers) :- + +jpl_field_to_modifiers(F, Ms) :- + jpl_classname_to_class('java.lang.reflect.Field', Cf), + jpl_method_to_modifiers_1(F, Cf, Ms). + +%------------------------------------------------------------------------------ + +% jpl_field_to_name(+Field, -Name) :- + +jpl_field_to_name(F, N) :- + jpl_classname_to_class('java.lang.reflect.Field', Cf), + jpl_member_to_name_1(F, Cf, N). + +%------------------------------------------------------------------------------ + +%type jpl_field_to_type(object, type) + +% jpl_field_to_type(+Field, -Type) :- + +jpl_field_to_type(F, Tf) :- + jpl_classname_to_class('java.lang.reflect.Field', Cf), + jGetMethodID(Cf, getType, method([],class([java,lang],['Class'])), MID), + jCallObjectMethod(F, MID, [], [], Cr), + jpl_class_to_type(Cr, Tf). + +%------------------------------------------------------------------------------ + +%type jpl_method_spec(type, integer, name, arity, ordset(modifier), method_id, type, list(type)) + +% jpl_method_spec(+Type, -Index, -Name, -Arity, -Modifiers, -MID, -ReturnType, -ParameterTypes) :- +% generates pertinent details of all accessible methods of Type (class/2 or array/1), +% populating or using the cache as appropriate + +jpl_method_spec(T, I, N, A, Mods, MID, Tr, Tfps) :- + ( jpl_method_spec_is_cached(T) + -> jpl_method_spec_cache(T, I, N, A, Mods, MID, Tr, Tfps) + ; jpl_type_to_class(T, C), + jpl_class_to_constructors(C, Xs), + jpl_class_to_methods(C, Ms), + ( T = array(_BaseType) % regardless of base type... + -> Tci = array(_) % ...the "cache index" type is this + ; Tci = T + ), + jpl_method_spec_1(C, Tci, Xs, Ms), + jpl_assert(jpl_method_spec_is_cached(Tci)), + jpl_method_spec_cache(Tci, I, N, A, Mods, MID, Tr, Tfps) + ). + +%------------------------------------------------------------------------------ + +%type jpl_method_spec_1(class, partial_type, list(method), list(method)) + +% jpl_method_spec_1(+ClassObject, +CacheIndexType, +Constructors, +Methods) :- +% if the original type is e.g. array(byte) then CacheIndexType is array(_) else it is that type; + +jpl_method_spec_1(C, Tci, Xs, Ms) :- + ( ( nth1(I, Xs, X), % generate constructors, numbered from 1 + jpl_constructor_to_name(X, N), + jpl_constructor_to_modifiers(X, Mods), + jpl_constructor_to_return_type(X, Tr), + jpl_constructor_to_parameter_types(X, Tfps) + ; length(Xs, J0), + nth1(J, Ms, M), % generate members, continuing numbering + I is J0+J, + jpl_method_to_name(M, N), + jpl_method_to_modifiers(M, Mods), + jpl_method_to_return_type(M, Tr), + jpl_method_to_parameter_types(M, Tfps) + ), + length(Tfps, A), % arity + ( member(static, Mods) + -> jGetStaticMethodID(C, N, method(Tfps,Tr), MID) + ; jGetMethodID(C, N, method(Tfps,Tr), MID) + ), + jpl_assert(jpl_method_spec_cache(Tci,I,N,A,Mods,MID,Tr,Tfps)), + fail + ; true + ). + +%------------------------------------------------------------------------------ + +:- dynamic jpl_method_spec_cache/8. + +%------------------------------------------------------------------------------ + +:- dynamic jpl_method_spec_is_cached/1. + +%------------------------------------------------------------------------------ + +% jpl_method_to_modifiers(+Method, -ModifierSet) :- + +jpl_method_to_modifiers(M, Ms) :- + jpl_classname_to_class('java.lang.reflect.Method', Cm), + jpl_method_to_modifiers_1(M, Cm, Ms). + +%------------------------------------------------------------------------------ + +%type jpl_method_to_modifiers_1(object, object, ordset(modifier)) + +% jpl_method_to_modifiers_1(+Method, +ConstructorClass, -ModifierSet) :- + +jpl_method_to_modifiers_1(XM, Cxm, Ms) :- + jGetMethodID(Cxm, getModifiers, method([],int), MID), + jCallIntMethod(XM, MID, [], [], I), + jpl_modifier_int_to_modifiers(I, Ms). + +%------------------------------------------------------------------------------ + +% jpl_method_to_name(+Method, -Name) :- + +jpl_method_to_name(M, N) :- + jpl_classname_to_class('java.lang.reflect.Method', CM), + jpl_member_to_name_1(M, CM, N). + +%------------------------------------------------------------------------------ + +jpl_member_to_name_1(M, CM, N) :- + jGetMethodID(CM, getName, method([],class([java,lang],['String'])), MID), + jCallObjectMethod(M, MID, [], [], N). + +%------------------------------------------------------------------------------ + +% jpl_method_to_parameter_types(+Method, -Types) :- + +jpl_method_to_parameter_types(M, Tfps) :- + jpl_classname_to_class('java.lang.reflect.Method', Cm), + jpl_method_to_parameter_types_1(M, Cm, Tfps). + +%------------------------------------------------------------------------------ + +% jpl_method_to_parameter_types_1(+XM, +Cxm, -Tfps) :- +% XM is (a JPL ref to) an instance of java.lang.reflect.[Constructor|Method] + +jpl_method_to_parameter_types_1(XM, Cxm, Tfps) :- + jGetMethodID(Cxm, getParameterTypes, method([],array(class([java,lang],['Class']))), MID), + jCallObjectMethod(XM, MID, [], [], Atp), + jpl_object_array_to_list(Atp, Ctps), + jpl_classes_to_types(Ctps, Tfps). + +%------------------------------------------------------------------------------ + +% jpl_method_to_return_type(+Method, -Type) :- + +jpl_method_to_return_type(M, Tr) :- + jpl_classname_to_class('java.lang.reflect.Method', Cm), + jGetMethodID(Cm, getReturnType, method([],class([java,lang],['Class'])), MID), + jCallObjectMethod(M, MID, [], [], Cr), + jpl_class_to_type(Cr, Tr). + +%------------------------------------------------------------------------------ + +jpl_modifier_bit(public, 0x001). +jpl_modifier_bit(private, 0x002). +jpl_modifier_bit(protected, 0x004). +jpl_modifier_bit(static, 0x008). +jpl_modifier_bit(final, 0x010). +jpl_modifier_bit(synchronized, 0x020). +jpl_modifier_bit(volatile, 0x040). +jpl_modifier_bit(transient, 0x080). +jpl_modifier_bit(native, 0x100). +jpl_modifier_bit(interface, 0x200). +jpl_modifier_bit(abstract, 0x400). + +%------------------------------------------------------------------------------ + +%type jpl_modifier_int_to_modifiers(integer, ordset(modifier)) + +% jpl_modifier_int_to_modifiers(+Int, -ModifierSet) :- +% ModifierSet is an ordered (hence canonical) list, +% possibly empty (although I suspect never in practice?), +% of modifier atoms, e.g. [public,static] + +jpl_modifier_int_to_modifiers(I, Ms) :- + setof( + M, % should use e.g. set_of_all/3 + B^(jpl_modifier_bit(M, B), + (B /\ I) =\= 0 + ), + Ms + ). + +%------------------------------------------------------------------------------ + +% jpl_servlet_byref(+Config, +Request, +Response) :- +% this serves the "byref" servlet demo, +% exemplifying one tactic for implementing a servlet in Prolog +% by accepting the Request and Response objects as JPL references +% and accessing their members via JPL as required; +% see also jpl_servlet_byval/3 + +jpl_servlet_byref(Config, Request, Response) :- + jpl_call(Config, getServletContext, [], Context), + + jpl_call(Response, setStatus, [200], _), + jpl_call(Response, setContentType, ['text/html'], _), + jpl_call(Response, getWriter, [], W), + + jpl_call(W, println, ['

jpl_servlet_byref/3 says:

'], _),
+
+	jpl_call(W, println, ['\nservlet context stuff:'], _),
+
+	jpl_call(Context, getInitParameterNames, [], ContextInitParameterNameEnum),
+	jpl_enumeration_to_list(ContextInitParameterNameEnum, ContextInitParameterNames),
+	length(ContextInitParameterNames, NContextInitParameterNames),
+	atomic_list_concat(['\tContext.InitParameters = ',NContextInitParameterNames], NContextInitParameterNamesMsg),
+	jpl_call(W, println, [NContextInitParameterNamesMsg], _),
+	(   member(ContextInitParameterName, ContextInitParameterNames),
+	jpl_call(Context, getInitParameter, [ContextInitParameterName], ContextInitParameter),
+	atomic_list_concat(['\t\tContext.InitParameter[',ContextInitParameterName,'] = ',ContextInitParameter], ContextInitParameterMsg),
+	jpl_call(W, println, [ContextInitParameterMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(Context, getMajorVersion, [], MajorVersion),
+	atomic_list_concat(['\tContext.MajorVersion = ',MajorVersion], MajorVersionMsg),
+	jpl_call(W, println, [MajorVersionMsg], _),
+
+	jpl_call(Context, getMinorVersion, [], MinorVersion),
+	atomic_list_concat(['\tContext.MinorVersion = ',MinorVersion], MinorVersionMsg),
+	jpl_call(W, println, [MinorVersionMsg], _),
+
+	jpl_call(Context, getServerInfo, [], ServerInfo),
+	atomic_list_concat(['\tContext.ServerInfo = ',ServerInfo], ServerInfoMsg),
+	jpl_call(W, println, [ServerInfoMsg], _),
+
+	jpl_call(W, println, ['\nservlet config stuff:'], _),
+
+	jpl_call(Config, getServletName, [], ServletName),
+	(   ServletName == @(null)
+	->  ServletNameAtom = null
+	;   ServletNameAtom = ServletName
+	),
+	atomic_list_concat(['\tConfig.ServletName = ',ServletNameAtom], ServletNameMsg),
+	jpl_call(W, println, [ServletNameMsg], _),
+
+	jpl_call(Config, getInitParameterNames, [], ConfigInitParameterNameEnum),
+	jpl_enumeration_to_list(ConfigInitParameterNameEnum, ConfigInitParameterNames),
+	length(ConfigInitParameterNames, NConfigInitParameterNames),
+	atomic_list_concat(['\tConfig.InitParameters = ',NConfigInitParameterNames], NConfigInitParameterNamesMsg),
+	jpl_call(W, println, [NConfigInitParameterNamesMsg], _),
+	(   member(ConfigInitParameterName, ConfigInitParameterNames),
+	jpl_call(Config, getInitParameter, [ConfigInitParameterName], ConfigInitParameter),
+	atomic_list_concat(['\t\tConfig.InitParameter[',ConfigInitParameterName,'] = ',ConfigInitParameter], ConfigInitParameterMsg),
+	jpl_call(W, println, [ConfigInitParameterMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(W, println, ['\nrequest stuff:'], _),
+
+	jpl_call(Request, getAttributeNames, [], AttributeNameEnum),
+	jpl_enumeration_to_list(AttributeNameEnum, AttributeNames),
+	length(AttributeNames, NAttributeNames),
+	atomic_list_concat(['\tRequest.Attributes = ',NAttributeNames], NAttributeNamesMsg),
+	jpl_call(W, println, [NAttributeNamesMsg], _),
+	(   member(AttributeName, AttributeNames),
+	jpl_call(Request, getAttribute, [AttributeName], Attribute),
+	jpl_call(Attribute, toString, [], AttributeString),
+	atomic_list_concat(['\t\tRequest.Attribute[',AttributeName,'] = ',AttributeString], AttributeMsg),
+	jpl_call(W, println, [AttributeMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(Request, getCharacterEncoding, [], CharacterEncoding),
+	(   CharacterEncoding == @(null)
+	->  CharacterEncodingAtom = ''
+	;   CharacterEncodingAtom = CharacterEncoding
+	),
+	atomic_list_concat(['\tRequest.CharacterEncoding',' = ',CharacterEncodingAtom], CharacterEncodingMsg),
+	jpl_call(W, println, [CharacterEncodingMsg], _),
+
+	jpl_call(Request, getContentLength, [], ContentLength),
+	atomic_list_concat(['\tRequest.ContentLength',' = ',ContentLength], ContentLengthMsg),
+	jpl_call(W, println, [ContentLengthMsg], _),
+
+	jpl_call(Request, getContentType, [], ContentType),
+	(   ContentType == @(null)
+	->  ContentTypeAtom = ''
+	;   ContentTypeAtom = ContentType
+	),
+	atomic_list_concat(['\tRequest.ContentType',' = ',ContentTypeAtom], ContentTypeMsg),
+	jpl_call(W, println, [ContentTypeMsg], _),
+
+	jpl_call(Request, getParameterNames, [], ParameterNameEnum),
+	jpl_enumeration_to_list(ParameterNameEnum, ParameterNames),
+	length(ParameterNames, NParameterNames),
+	atomic_list_concat(['\tRequest.Parameters = ',NParameterNames], NParameterNamesMsg),
+	jpl_call(W, println, [NParameterNamesMsg], _),
+	(   member(ParameterName, ParameterNames),
+	jpl_call(Request, getParameter, [ParameterName], Parameter),
+	atomic_list_concat(['\t\tRequest.Parameter[',ParameterName,'] = ',Parameter], ParameterMsg),
+	jpl_call(W, println, [ParameterMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(Request, getProtocol, [], Protocol),
+	atomic_list_concat(['\tRequest.Protocol',' = ',Protocol], ProtocolMsg),
+	jpl_call(W, println, [ProtocolMsg], _),
+
+	jpl_call(Request, getRemoteAddr, [], RemoteAddr),
+	atomic_list_concat(['\tRequest.RemoteAddr',' = ',RemoteAddr], RemoteAddrMsg),
+	jpl_call(W, println, [RemoteAddrMsg], _),
+
+	jpl_call(Request, getRemoteHost, [], RemoteHost),
+	atomic_list_concat(['\tRequest.RemoteHost',' = ',RemoteHost], RemoteHostMsg),
+	jpl_call(W, println, [RemoteHostMsg], _),
+
+	jpl_call(Request, getScheme, [], Scheme),
+	atomic_list_concat(['\tRequest.Scheme',' = ',Scheme], SchemeMsg),
+	jpl_call(W, println, [SchemeMsg], _),
+
+	jpl_call(Request, getServerName, [], ServerName),
+	atomic_list_concat(['\tRequest.ServerName',' = ',ServerName], ServerNameMsg),
+	jpl_call(W, println, [ServerNameMsg], _),
+
+	jpl_call(Request, getServerPort, [], ServerPort),
+	atomic_list_concat(['\tRequest.ServerPort',' = ',ServerPort], ServerPortMsg),
+	jpl_call(W, println, [ServerPortMsg], _),
+
+	jpl_call(Request, isSecure, [], @(Secure)),
+	atomic_list_concat(['\tRequest.Secure',' = ',Secure], SecureMsg),
+	jpl_call(W, println, [SecureMsg], _),
+
+	jpl_call(W, println, ['\nHTTP request stuff:'], _),
+
+	jpl_call(Request, getAuthType, [], AuthType),
+	(   AuthType == @(null)
+	->  AuthTypeAtom = ''
+	;   AuthTypeAtom = AuthType
+	),
+	atomic_list_concat(['\tRequest.AuthType',' = ',AuthTypeAtom], AuthTypeMsg),
+	jpl_call(W, println, [AuthTypeMsg], _),
+
+	jpl_call(Request, getContextPath, [], ContextPath),
+	(   ContextPath == @(null)
+	->  ContextPathAtom = ''
+	;   ContextPathAtom = ContextPath
+	),
+	atomic_list_concat(['\tRequest.ContextPath',' = ',ContextPathAtom], ContextPathMsg),
+	jpl_call(W, println, [ContextPathMsg], _),
+
+	jpl_call(Request, getCookies, [], CookieArray),
+	(   CookieArray == @(null)
+	->  Cookies = []
+	;   jpl_array_to_list(CookieArray, Cookies)
+	),
+	length(Cookies, NCookies),
+	atomic_list_concat(['\tRequest.Cookies',' = ',NCookies], NCookiesMsg),
+	jpl_call(W, println, [NCookiesMsg], _),
+	(   nth0(NCookie, Cookies, Cookie),
+	atomic_list_concat(['\t\tRequest.Cookie[',NCookie,']'], CookieMsg),
+	jpl_call(W, println, [CookieMsg], _),
+
+	jpl_call(Cookie, getName, [], CookieName),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Name = ',CookieName], CookieNameMsg),
+	jpl_call(W, println, [CookieNameMsg], _),
+
+	jpl_call(Cookie, getValue, [], CookieValue),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Value = ',CookieValue], CookieValueMsg),
+	jpl_call(W, println, [CookieValueMsg], _),
+
+	jpl_call(Cookie, getPath, [], CookiePath),
+	(   CookiePath == @(null)
+	->  CookiePathAtom = ''
+	;   CookiePathAtom = CookiePath
+	),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Path = ',CookiePathAtom], CookiePathMsg),
+	jpl_call(W, println, [CookiePathMsg], _),
+
+	jpl_call(Cookie, getComment, [], CookieComment),
+	(   CookieComment == @(null)
+	->  CookieCommentAtom = ''
+	;   CookieCommentAtom = CookieComment
+	),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Comment = ',CookieCommentAtom], CookieCommentMsg),
+	jpl_call(W, println, [CookieCommentMsg], _),
+
+	jpl_call(Cookie, getDomain, [], CookieDomain),
+	(   CookieDomain == @(null)
+	->  CookieDomainAtom = ''
+	;   CookieDomainAtom = CookieDomain
+	),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Domain = ',CookieDomainAtom], CookieDomainMsg),
+	jpl_call(W, println, [CookieDomainMsg], _),
+
+	jpl_call(Cookie, getMaxAge, [], CookieMaxAge),
+	atomic_list_concat(['\t\t\tRequest.Cookie.MaxAge = ',CookieMaxAge], CookieMaxAgeMsg),
+	jpl_call(W, println, [CookieMaxAgeMsg], _),
+
+	jpl_call(Cookie, getVersion, [], CookieVersion),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Version = ',CookieVersion], CookieVersionMsg),
+	jpl_call(W, println, [CookieVersionMsg], _),
+
+	jpl_call(Cookie, getSecure, [], @(CookieSecure)),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Secure',' = ',CookieSecure], CookieSecureMsg),
+	jpl_call(W, println, [CookieSecureMsg], _),
+
+	fail
+	;   true
+	),
+
+	jpl_call(W, println, ['
'], _), + + true. + +%------------------------------------------------------------------------------ + +% jpl_servlet_byval(+MultiMap, -ContentType, -BodyAtom) :- +% this exemplifies an alternative (to jpl_servlet_byref) tactic +% for implementing a servlet in Prolog; +% most Request fields are extracted in Java before this is called, +% and passed in as a multimap (a map, some of whose values are maps) + +jpl_servlet_byval(MM, CT, Ba) :- + CT = 'text/html', + multimap_to_atom(MM, MMa), + atomic_list_concat(['', + '

jpl_servlet_byval/3 says:

',
+		     MMa,
+		     '
' + ], Ba). + +%------------------------------------------------------------------------------ + +%type jpl_cache_type_of_ref(jpl_type, ref) + +% jpl_cache_type_of_ref(+Type, +Ref) :- +% Type must be a proper (concrete) JPL type; +% Ref must be a proper JPL reference (not void); +% Type is memoed (if policy so dictates) as the type of the referenced object (unless it's null) +% by iref (so as not to disable atom-based GC) +% NB obsolete lemmas must be watched-out-for and removed + +jpl_cache_type_of_ref(T, @(Tag)) :- + ( jpl_assert_policy( jpl_iref_type_cache(_,_), no) + -> true + ; \+ ground(T) % shouldn't happen (implementation error) + -> write('[jpl_cache_type_of_ref/2: arg 1 is not ground]'), nl, % oughta throw an exception + fail + ; \+ atom(Tag) % shouldn't happen (implementation error) + -> write('[jpl_cache_type_of_ref/2: arg 2 is not an atomic-tag ref]'), nl, % oughta throw an exception + fail + ; Tag == null % a null ref? (this is valid) + -> true % silently ignore it + ; jni_tag_to_iref(Tag, Iref) + -> ( jpl_iref_type_cache(Iref, TC) % we expect TC == T + -> ( T == TC + -> true + ; % write('[JPL: found obsolete tag-type lemma...]'), nl, % or keep statistics? (why?) + retractall(jpl_iref_type_cache(Iref,_)), + jpl_assert(jpl_iref_type_cache(Iref,T)) + ) + ; jpl_assert(jpl_iref_type_cache(Iref,T)) + ) + ; write('[jpl_cache_type_of_ref/2: jni_tagatom_to_iref(Tag,_) failed]'), nl, % oughta throw an exception + fail + ). + +%------------------------------------------------------------------------------ + +% jpl_class_tag_type_cache(-Tag, -ClassType) :- +% Tag is the tag part of an @(Tag) reference +% to a JVM instance of java.lang.Class +% which denotes ClassType; +% we index on Tag rather than on Iref so as to keep these objects around +% even after an atom garbage collection +% (if needed once, they are likely to be needed again) + +:- dynamic jpl_class_tag_type_cache/2. + +%------------------------------------------------------------------------------ + +% jpl_class_to_ancestor_classes(+Class, -AncestorClasses) :- +% AncestorClasses will be a list of (JPL references to) instances of java.lang.Class +% denoting the "implements" lineage (?), nearest first +% (the first member denotes the class which Class directly implements, +% the next (if any) denotes the class which *that* class implements, +% and so on to java.lang.Object) + +jpl_class_to_ancestor_classes(C, Cas) :- + ( jpl_class_to_super_class(C, Ca) + -> Cas = [Ca|Cas2], + jpl_class_to_ancestor_classes(Ca, Cas2) + ; Cas = [] + ). + +%------------------------------------------------------------------------------ + +% jpl_class_to_classname(+Class, -ClassName) :- +% Class is a reference to a class object; +% ClassName is its canonical (?) source-syntax (dotted) name, +% e.g. 'java.util.Date' +% not used outside jni_junk and jpl_test (is this (still) true?); +% oughta use the available caches (but their indexing doesn't suit) + +jpl_class_to_classname(C, CN) :- + jpl_call(C, getName, [], CN). + +%------------------------------------------------------------------------------ + +% jpl_class_to_raw_classname(+Class, -ClassName) :- +% hmm, I forget exactly what a "raw" classname is... + +jpl_class_to_raw_classname(Cobj, CN) :- + jpl_classname_to_class('java.lang.Class', CC), % cached? + jGetMethodID(CC, getName, method([],class([java,lang],['String'])), MIDgetName), + jCallObjectMethod(Cobj, MIDgetName, [], [], S), + S = CN. + +%------------------------------------------------------------------------------ + +% jpl_class_to_raw_classname_chars(+Class, -ClassnameChars) :- +% Class is a reference to a class object; +% ClassnameChars is a chars representation of its dotted name, e.g. +% "java.util.Date" + +jpl_class_to_raw_classname_chars(Cobj, CsCN) :- + jpl_class_to_raw_classname(Cobj, CN), + atom_codes(CN, CsCN). + +%------------------------------------------------------------------------------ + +jpl_class_to_super_class(C, Cx) :- + jGetSuperclass(C, Cx), + Cx \== @(null), % as returned when C is java.lang.Object, i.e. no superclass + jpl_cache_type_of_ref(class([java,lang],['Class']), Cx). + +%------------------------------------------------------------------------------ + +% jpl_class_to_type(+ClassObject, -Type) :- +% ClassObject is a reference to a class object of Type +% NB should ensure that, if not found in cache, then cache is updated; +% intriguingly (?), getParameterTypes returns class objects with names +% 'boolean', 'byte' etc. and even 'void' (?!) + +jpl_class_to_type(@(Tag), Type) :- + ( jpl_class_tag_type_cache(Tag, Tx) + -> true + ; jpl_class_to_raw_classname_chars(@(Tag), Cs), % uncached + jpl_classname_chars_to_type(Cs, Tr), + jpl_type_to_canonical_type(Tr, Tx), % map e.g. class([],[byte]) -> byte + jpl_assert(jpl_class_tag_type_cache(Tag,Tx)) + -> true % the elseif goal should be determinate, but just in case... + ), + Type = Tx. + +%------------------------------------------------------------------------------ + +jpl_classes_to_types([], []). + +jpl_classes_to_types([C|Cs], [T|Ts]) :- + jpl_class_to_type(C, T), + jpl_classes_to_types(Cs, Ts). + +%------------------------------------------------------------------------------ + +jpl_classname_chars_to_type(Cs, Type) :- + ( phrase(jpl_type_classname_1(Type), Cs) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_classname_to_class(+ClassName, -Class) :- +% ClassName unambiguously represents a class, +% e.g. 'java.lang.String' +% Class is a (canonical) reference to the corresponding class object; +% uses caches where the class is already encountered + +jpl_classname_to_class(N, C) :- + jpl_classname_to_type(N, T), % cached + jpl_type_to_class(T, C). % cached + +%------------------------------------------------------------------------------ + +% jpl_classname_to_type(+Classname, -Type) :- +% Classname is a source-syntax (dotted) class name, +% e.g. 'java.util.Date', '[java.util.Date' or '[L' +% Type is its corresponding JPL type structure, +% e.g. class([java,util],['Date']), array(class([java,util],['Date'])), array(long) +% +%thinks +% by "classname" do I mean "typename"? +% should this throw an exception for unbound CN? is this public API? + +jpl_classname_to_type(CN, T) :- + ( jpl_classname_type_cache(CN, Tx) + -> Tx = T + ; atom_codes(CN, CsCN), + phrase(jpl_type_classname_1(T), CsCN) + -> jpl_assert(jpl_classname_type_cache(CN,T)), + true + ). + +%------------------------------------------------------------------------------ + +% jpl_classname_type_cache( -Classname, -Type) :- +% Classname is the atomic name of Type; +% NB may denote a class which cannot be found + +:- dynamic jpl_classname_type_cache/2. + +%------------------------------------------------------------------------------ + +% jpl_datum_to_type(+Datum, -Type) :- +% Datum must be a proper JPL representation +% of an instance of one (or more) Java types; +% Type is the unique most specialised type of which Datum denotes an instance; +% N.B. 3 is an instance of byte, char, short, int and long, +% of which byte and char are the joint, overlapping most specialised types, +% so this relates 3 to the pseudo subtype 'char_byte'; +% see jpl_type_to_preferred_concrete_type/2 for converting inferred types +% to instantiable types + +jpl_datum_to_type(D, T) :- + ( jpl_value_to_type(D, T) + -> true + ; jpl_ref_to_type(D, T) + -> true + ; nonvar( D), + D = {Term} + -> ( cyclic_term(Term) + -> throw(error(type_error(acyclic,Term), + context(jpl_datum_to_type/2,'must be acyclic'))) + ; atom( Term) + -> T = class([jpl],['Atom']) + ; integer( Term) + -> T = class([jpl],['Integer']) + ; float( Term) + -> T = class([jpl],['Float']) + ; var( Term) + -> T = class([jpl],['Variable']) + ; T = class([jpl],['Compound']) + ) + ). + +%------------------------------------------------------------------------------ + +jpl_datums_to_most_specific_common_ancestor_type([D], T) :- + jpl_datum_to_type(D, T). + +jpl_datums_to_most_specific_common_ancestor_type([D1,D2|Ds], T0) :- + jpl_datum_to_type(D1, T1), + jpl_type_to_ancestor_types(T1, Ts1), + jpl_datums_to_most_specific_common_ancestor_type_1([D2|Ds], [T1|Ts1], [T0|_]). + +%------------------------------------------------------------------------------ + +jpl_datums_to_most_specific_common_ancestor_type_1([], Ts, Ts). + +jpl_datums_to_most_specific_common_ancestor_type_1([D|Ds], Ts1, Ts0) :- + jpl_datum_to_type(D, Tx), + jpl_lineage_types_type_to_common_lineage_types(Ts1, Tx, Ts2), + jpl_datums_to_most_specific_common_ancestor_type_1(Ds, Ts2, Ts0). + +%------------------------------------------------------------------------------ + +% jpl_datums_to_types(+Datums, -Types) :- +% each member of Datums is a JPL value or ref, +% denoting an instance of some Java type, +% and the corresponding member of Types denotes the most specialised type +% of which it is an instance (including some I invented for the overlaps +% between char and short, etc,) + +jpl_datums_to_types([], []). + +jpl_datums_to_types([D|Ds], [T|Ts]) :- + jpl_datum_to_type(D, T), + jpl_datums_to_types(Ds, Ts). + +%------------------------------------------------------------------------------ + +% jpl_false(-X) :- +% X is (by unification) the proper JPL datum which represents the Java boolean value 'false' +% c.f. jpl_is_false/1 + +jpl_false(@(false)). + +%------------------------------------------------------------------------------ + +% jpl_ground_is_type(+X) :- +% X, known to be ground, is (or at least superficially resembles :-) a JPL type + +jpl_ground_is_type(X) :- + jpl_primitive_type(X), + !. + +jpl_ground_is_type(array(X)) :- + jpl_ground_is_type(X). + +jpl_ground_is_type(class(_,_)). + +jpl_ground_is_type(method(_,_)). + +%------------------------------------------------------------------------------ + +:- dynamic jpl_iref_type_cache/2. + +%------------------------------------------------------------------------------ + +% jpl_is_class(?X) :- +% X is a JPL ref to a java.lang.Class object + +jpl_is_class(X) :- + jpl_is_object(X), + jpl_object_to_type(X, class([java,lang],['Class'])). + +%------------------------------------------------------------------------------ + +% jpl_is_false(?X) :- +% X is the proper JPL datum which represents the Java boolean value 'false'; +% whatever, no further instantiation of X occurs + +jpl_is_false(X) :- + X == @(false). + +%------------------------------------------------------------------------------ + +% jpl_is_fieldID(?X) :- +% X is a proper JPL field ID structure (jfieldID/1); +% applications should not be messing with these (?); +% whatever, no further instantiation of X occurs + +jpl_is_fieldID(jfieldID(X)) :- % NB a var arg may get bound... + integer(X). + +%------------------------------------------------------------------------------ + +% jpl_is_methodID(?X) :- +% X is a proper JPL method ID structure (jmethodID/1); +% applications should not be messing with these (?); +% whatever, no further instantiation of X occurs + +jpl_is_methodID(jmethodID(X)) :- % NB a var arg may get bound... + integer(X). + +%------------------------------------------------------------------------------ + +% jpl_is_null(?X) :- +% X is the proper JPL datum which represents Java's 'null' reference; +% whatever, no further instantiation of X occurs + +jpl_is_null(X) :- + X == @(null). + +%------------------------------------------------------------------------------ + +% jpl_is_object(?X) :- +% X is a proper, plausible JPL object reference; +% NB this checks only syntax, not whether the object exists; +% whatever, no further instantiation of X occurs + +jpl_is_object(X) :- + jpl_is_ref(X), % (syntactically, at least...) + X \== @(null). + +%------------------------------------------------------------------------------ + +% jpl_is_object_type(+T) :- +% T is an object (class or array) type, +% not e.g. a primitive, null or void + +jpl_is_object_type(T) :- + \+ var(T), + jpl_non_var_is_object_type(T). + +%------------------------------------------------------------------------------ + +% jpl_is_ref(?T) :- +% the arbitrary term T is a proper, syntactically plausible JPL reference, +% either to a Java object +% (which may not exist, although a jpl_is_current_ref/1 might be useful) +% or to Java's notional but important 'null' non-object; +% whatever, no further instantiation of X occurs; +% NB to distinguish tags from void/false/true, +% could check initial character(s) or length? or adopt strong/weak scheme... + +jpl_is_ref(@(Y)) :- + atom(Y), % presumably a (garbage-collectable) tag + Y \== void, % not a ref + Y \== false, % not a ref + Y \== true. % not a ref + +%------------------------------------------------------------------------------ + +% jpl_is_true(?X) :- +% X is a proper JPL datum, representing the Java boolean value 'true'; +% whatever, no further instantiation of X occurs + +jpl_is_true(X) :- + X == @(true). + +%------------------------------------------------------------------------------ + +% jpl_is_type(+X) :- + +jpl_is_type(X) :- + ground(X), + jpl_ground_is_type(X). + +%------------------------------------------------------------------------------ + +% jpl_is_void(?X) :- +% X is the proper JPL datum which represents the pseudo Java value 'void' +% (which is returned by jpl_call/4 when invoked on void methods); +% NB you can try passing 'void' back to Java, but it won't ever be interested; +% whatever, no further instantiation of X occurs + +jpl_is_void(X) :- + X == @(void). + +%------------------------------------------------------------------------------ + +jpl_lineage_types_type_to_common_lineage_types(Ts, Tx, Ts0) :- + ( append(_, [Tx|Ts2], Ts) + -> [Tx|Ts2] = Ts0 + ; jpl_type_to_super_type(Tx, Tx2) + -> jpl_lineage_types_type_to_common_lineage_types(Ts, Tx2, Ts0) + ). + +%------------------------------------------------------------------------------ + +jpl_non_var_is_object_type(class(_,_)). + +jpl_non_var_is_object_type(array(_)). + +%------------------------------------------------------------------------------ + +% jpl_null(-X) :- +% X is (by unification) the proper JPL datum which represents the Java reference 'null'; +% c.f. jpl_is_null/1 + +jpl_null(@(null)). + +%------------------------------------------------------------------------------ + +% jpl_object_array_to_list(+ArrayObject, -Values) :- +% Values is a list of JPL values (primitive values or object references) +% representing the respective elements of ArrayObject + +jpl_object_array_to_list(A, Vs) :- + jpl_array_to_length(A, N), + jpl_object_array_to_list_1(A, 0, N, Vs). + +%------------------------------------------------------------------------------ + +% jpl_object_array_to_list_1(+A, +I, +N, -Xs) :- + +jpl_object_array_to_list_1(A, I, N, Xs) :- + ( I == N + -> Xs = [] + ; jGetObjectArrayElement(A, I, X), + Xs = [X|Xs2], + J is I+1, + jpl_object_array_to_list_1(A, J, N, Xs2) + ). + +%------------------------------------------------------------------------------ + +% jpl_object_to_class(+Object, -Class) :- +% Object must be a valid object (should this throw an exception otherwise?); +% Class is a (canonical) reference to the (canonical) class object +% which represents the class of Object; +% NB wot's the point of caching the type if we don't look there first? + +jpl_object_to_class(Obj, C) :- + jGetObjectClass(Obj, C), + jpl_cache_type_of_ref(class([java,lang],['Class']), C). + +%------------------------------------------------------------------------------ + +% jpl_object_to_type(+Object, -Type) :- +% Object must be a proper JPL reference to a Java object +% (i.e. a class or array instance, but not null, void or String); +% Type is the JPL type of that object + +jpl_object_to_type(@(Tag), Type) :- + jpl_tag_to_type(Tag, Type). + +%------------------------------------------------------------------------------ + +jpl_object_type_to_super_type(T, Tx) :- + ( ( T = class(_,_) + ; T = array(_) + ) + -> jpl_type_to_class(T, C), + jpl_class_to_super_class(C, Cx), + Cx \== @(null), + jpl_class_to_type(Cx, Tx) + ). + +%------------------------------------------------------------------------------ + +% jpl_primitive_buffer_to_array(+Type, +Xc, +Bp, +I, +Size, -Vcs) :- +% Bp points to a buffer of (sufficient) Type values; +% Vcs will be unbound on entry, +% and on exit will be a list of Size of them, starting at index I +% (the buffer is indexed from zero) + +jpl_primitive_buffer_to_array(T, Xc, Bp, I, Size, [Vc|Vcs]) :- + jni_fetch_buffer_value(Bp, I, Vc, Xc), + Ix is I+1, + ( Ix < Size + -> jpl_primitive_buffer_to_array(T, Xc, Bp, Ix, Size, Vcs) + ; Vcs = [] + ). + +%------------------------------------------------------------------------------ + +jpl_primitive_type(boolean). +jpl_primitive_type(char). +jpl_primitive_type(byte). +jpl_primitive_type(short). +jpl_primitive_type(int). +jpl_primitive_type(long). +jpl_primitive_type(float). +jpl_primitive_type(double). + +%------------------------------------------------------------------------------ + +% jpl_primitive_type_default_value(-Type, -Value) :- +% each element of any array of (primitive) Type created by jpl_new/3, +% or any instance of (primitive) Type created by jpl_new/3, +% should be initialised to Value (to mimic Java semantics) + +jpl_primitive_type_default_value(boolean, @(false)). +jpl_primitive_type_default_value(char, 0). +jpl_primitive_type_default_value(byte, 0). +jpl_primitive_type_default_value(short, 0). +jpl_primitive_type_default_value(int, 0). +jpl_primitive_type_default_value(long, 0). +jpl_primitive_type_default_value(float, 0.0). +jpl_primitive_type_default_value(double, 0.0). + +%------------------------------------------------------------------------------ + +jpl_primitive_type_super_type(T, Tx) :- + ( jpl_type_fits_type_direct_prim(T, Tx) + ; jpl_type_fits_type_direct_xtra(T, Tx) + ). + +%------------------------------------------------------------------------------ + +% jpl_primitive_type_term_to_value(+Type, +Term, -Val) :- +% Term, after widening iff appropriate, represents an instance of Type; +% Val is the instance of Type which it represents (often the same thing); +% currently used only by jpl_new_1 when creating an "instance" +% of a primitive type (which may be misguided completism - you can't +% do that in Java) + +jpl_primitive_type_term_to_value(Type, Term, Val) :- + ( jpl_primitive_type_term_to_value_1(Type, Term, Val) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_primitive_type_term_to_value_1(+Type, +RawValue, -WidenedValue) :- +% I'm not worried about structure duplication here +% NB this oughta be done in foreign code... + +jpl_primitive_type_term_to_value_1(boolean, @(false), @(false)). + +jpl_primitive_type_term_to_value_1(boolean, @(true), @(true)). + +jpl_primitive_type_term_to_value_1(char, I, I) :- + integer(I), + I >= 0, + I =< 65535. % (2**16)-1. + +jpl_primitive_type_term_to_value_1(byte, I, I) :- + integer(I), + I >= 128, % -(2**7) + I =< 127. % (2**7)-1 + +jpl_primitive_type_term_to_value_1(short, I, I) :- + integer(I), + I >= -32768, % -(2**15) + I =< 32767. % (2**15)-1 + +jpl_primitive_type_term_to_value_1(int, I, I) :- + integer(I), + I >= -2147483648, % -(2**31) + I =< 2147483647. % (2**31)-1 + +jpl_primitive_type_term_to_value_1(long, I, I) :- + integer(I), + I >= -9223372036854775808, % -(2**63) + I =< 9223372036854775807. % (2**63)-1 + +jpl_primitive_type_term_to_value_1(float, I, F) :- + integer(I), + F is float(I). + +jpl_primitive_type_term_to_value_1(float, F, F) :- + float(F). + +jpl_primitive_type_term_to_value_1(double, I, F) :- + integer(I), + F is float(I). + +jpl_primitive_type_term_to_value_1(double, F, F) :- + float(F). + +%------------------------------------------------------------------------------ + +jpl_primitive_type_to_ancestor_types(T, Ts) :- + ( jpl_primitive_type_super_type(T, Ta) + -> Ts = [Ta|Tas], + jpl_primitive_type_to_ancestor_types(Ta, Tas) + ; Ts = [] + ). + +%------------------------------------------------------------------------------ + +jpl_primitive_type_to_super_type(T, Tx) :- + jpl_primitive_type_super_type(T, Tx). + +%------------------------------------------------------------------------------ + +% jpl_ref_to_type(+Ref, -Type) :- +% Ref must be a proper JPL reference (to an object, null or void); +% Type is its type + +jpl_ref_to_type(@(X), T) :- + ( X == null + -> T = null + ; X == void + -> T = void + ; jpl_tag_to_type(X, T) + ). + +%------------------------------------------------------------------------------ + +% jpl_tag_to_type(+Tag, -Type) :- +% Tag must be an (atomic) object tag; +% Type is its type (either from the cache or by reflection); + +jpl_tag_to_type(Tag, Type) :- + jni_tag_to_iref(Tag, Iref), + ( jpl_iref_type_cache(Iref, T) + -> true % T is Tag's type + ; jpl_object_to_class(@(Tag), Cobj), % else get ref to class obj + jpl_class_to_type(Cobj, T), % get type of class it denotes + jpl_assert(jpl_iref_type_cache(Iref,T)) + ), + Type = T. + +%------------------------------------------------------------------------------ + +% jpl_true(-X) :- +% X is (by unification) the proper JPL datum which represents the Java boolean value 'true'; +%cf jpl_is_true/1 + +jpl_true(@(true)). + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type(+TypeX, +TypeY) :- +% TypeX and TypeY must each be proper JPL types; +% this succeeds iff TypeX is assignable to TypeY + +jpl_type_fits_type(Tx, Ty) :- + ( jpl_type_fits_type_1(Tx, Ty) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type_1(+T1, +T2) :- +% it doesn't matter that this leaves choicepoints; it serves only jpl_type_fits_type/2 + +jpl_type_fits_type_1(T, T). + +% vsc: seems to make sense. + +jpl_type_fits_type_1(class(Ps1,Cs1), class(Ps2,Cs2)) :- + jpl_type_to_class(class(Ps1,Cs1), C1), + jpl_type_to_class(class(Ps2,Cs2), C2), + jIsAssignableFrom(C1, C2). + +jpl_type_fits_type_1(array(T1), class(Ps2,Cs2)) :- + jpl_type_to_class(array(T1), C1), + jpl_type_to_class(class(Ps2,Cs2), C2), + jIsAssignableFrom(C1, C2). + +jpl_type_fits_type_1(array(T1), array(T2)) :- + jpl_type_fits_type_1(T1, T2). + +jpl_type_fits_type_1(array(T1), array(T2)) :- + jpl_type_to_class(array(T1), C1), + jpl_type_to_class(array(T2), C2), + jIsAssignableFrom(C1, C2). + +jpl_type_fits_type_1(null, class(_,_)). + +jpl_type_fits_type_1(null, array(_)). + +jpl_type_fits_type_1(T1, T2) :- + jpl_type_fits_type_xprim(T1, T2). + +%------------------------------------------------------------------------------ + +jpl_type_fits_type_direct_prim(float, double). +jpl_type_fits_type_direct_prim(long, float). +jpl_type_fits_type_direct_prim(int, long). +jpl_type_fits_type_direct_prim(char, int). +jpl_type_fits_type_direct_prim(short, int). +jpl_type_fits_type_direct_prim(byte, short). + +%------------------------------------------------------------------------------ + +jpl_type_fits_type_direct_xprim(Tp, Tq) :- + jpl_type_fits_type_direct_prim(Tp, Tq). + +jpl_type_fits_type_direct_xprim(Tp, Tq) :- + jpl_type_fits_type_direct_xtra(Tp, Tq). + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type_direct_xtra(-PseudoType, -ConcreteType) :- +% this predicate defines the direct subtype-supertype relationships +% which involve the intersection pseudo types char_int, char_short and char_byte + +jpl_type_fits_type_direct_xtra(char_int, int). % char_int is a direct subtype of int +jpl_type_fits_type_direct_xtra(char_int, char). % etc. +jpl_type_fits_type_direct_xtra(char_short, short). +jpl_type_fits_type_direct_xtra(char_short, char). +jpl_type_fits_type_direct_xtra(char_byte, byte). +jpl_type_fits_type_direct_xtra(char_byte, char). + +jpl_type_fits_type_direct_xtra(overlong, float). % 6/Oct/2006 experiment + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type_xprim(-Tp, -T) :- +% indeterminate; +% serves only jpl_type_fits_type_1/2 + +jpl_type_fits_type_xprim(Tp, T) :- + jpl_type_fits_type_direct_xprim(Tp, Tq), + ( Tq = T + ; jpl_type_fits_type_xprim(Tq, T) + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_ancestor_types(+T, -Tas) :- +% this does not accommodate the assignability of null, +% but that's OK (?) since "type assignability" and "type ancestry" are not equivalent + +jpl_type_to_ancestor_types(T, Tas) :- + ( ( T = class(_,_) + ; T = array(_) + ) + -> jpl_type_to_class(T, C), + jpl_class_to_ancestor_classes(C, Cas), + jpl_classes_to_types(Cas, Tas) + ; jpl_primitive_type_to_ancestor_types(T, Tas) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_canonical_type(+Type, -CanonicalType) :- +% Type must be a type, not necessarily canonical; +% CanonicalType will be equivalent and canonical + +%eg jpl_type_to_canonical_type(class([],[byte]), byte) + +jpl_type_to_canonical_type(array(T), array(Tc)) :- + !, + jpl_type_to_canonical_type(T, Tc). + +jpl_type_to_canonical_type(class([],[void]), void) :- + !. + +jpl_type_to_canonical_type(class([],[N]), N) :- + jpl_primitive_type(N), + !. + +jpl_type_to_canonical_type(class(Ps,Cs), class(Ps,Cs)) :- + !. + +jpl_type_to_canonical_type(void, void) :- + !. + +jpl_type_to_canonical_type(P, P) :- + jpl_primitive_type(P). + +%------------------------------------------------------------------------------ + +% jpl_type_to_class(+Type, -ClassObject) :- +% incomplete types are now never cached (or otherwise passed around); +% jFindClass throws an exception if FCN can't be found + +%nb if this is public API maybe oughta restore the ground(T) check and throw exception + +jpl_type_to_class(T, @(Tag)) :- + % ground(T), % 9/Nov/2004 removed this spurious (?) check + ( jpl_class_tag_type_cache(ClassTag,T) + -> Tag = ClassTag + ; ( jpl_type_to_findclassname(T, FCN) % peculiar syntax for FindClass() + -> jFindClass(FCN, @(ClassTag)), % which caches type of @ClassTag + % jpl_cache_type_of_ref(T, @(ClassTag)) + jpl_cache_type_of_ref(class([java,lang],['Class']), @(ClassTag)) % 9/Nov/2004 bugfix (?) + ), + jpl_assert(jpl_class_tag_type_cache(ClassTag,T)) + ), + Tag = ClassTag. + +%------------------------------------------------------------------------------ + +% jpl_type_to_nicename(+Type, -NiceName) :- +% Type, which is a class or array type (not sure about the others...), +% is denoted by ClassName in dotted syntax + +%nb is this used? is "nicename" well defined and necessary? +%nb this could use caching if indexing were amenable + +%eg jpl_type_to_nicename(class([java,util],['Date']), 'java.util.Date') +%eg jpl_type_to_nicename(boolean, boolean) + +%cf jpl_type_to_classname/2 + +jpl_type_to_nicename(T, NN) :- + ( jpl_primitive_type( T) + -> NN = T + ; ( phrase(jpl_type_classname_1(T), Cs) + -> atom_codes(CNx, Cs), % green commit to first solution + NN = CNx + ) + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_classname(+Type, -ClassName) :- +% Type, which is a class or array type (not sure about the others...), +% is denoted by ClassName in dotted syntax + +%eg jpl_type_to_classname(class([java,util],['Date']), 'java.util.Date') + +%cf jpl_type_to_nicename/2 + +jpl_type_to_classname(T, CN) :- + ( phrase(jpl_type_classname_1(T), Cs) + -> atom_codes(CNx, Cs), % green commit to first solution + CN = CNx + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_descriptor(+Type, -Descriptor) :- +% Type (denoting any Java type) +% (can also be a JPL method/2 structure (?!)) +% is represented by Descriptor (JVM internal syntax) +% I'd cache this, but I'd prefer more efficient indexing on types (hashed?) + +jpl_type_to_descriptor(T, D) :- + ( phrase(jpl_type_descriptor_1(T), Cs) + -> atom_codes(Dx, Cs), + D = Dx + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_findclassname(+Type, -FindClassName) :- +% FindClassName denotes Type (class or array only) +% in the syntax required peculiarly by FindClass() + +jpl_type_to_findclassname(T, FCN) :- + ( phrase(jpl_type_findclassname(T), Cs) + -> atom_codes(FCNx, Cs), + FCN = FCNx + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_super_type(+Type, -SuperType) :- +% Type oughta be a proper JPL type; +% SuperType is the (at most one) type which it directly implements (if it's a class); +% if Type denotes a class, this works only if that class can be found; +% if Type = array(Type) then I dunno what happens... + +jpl_type_to_super_type(T, Tx) :- + ( jpl_object_type_to_super_type(T, Tx) + -> true + ; jpl_primitive_type_to_super_type(T, Tx) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_preferred_concrete_type( +Type, -ConcreteType) :- +% Type must be a canonical JPL type, +% possibly a pseudo (inferred) type such as char_int or array(char_byte); +% ConcreteType is the preferred concrete (Java-instantiable) type; +% introduced 16/Apr/2005 to fix bug whereby jpl_list_to_array([1,2,3],A) failed +% because the lists's inferred type of array(char_byte) is not Java-instantiable + +jpl_type_to_preferred_concrete_type( T, Tc) :- + ( jpl_type_to_preferred_concrete_type_1( T, TcX) + -> Tc = TcX + ). + +%------------------------------------------------------------------------------ + +jpl_type_to_preferred_concrete_type_1( char_int, int). + +jpl_type_to_preferred_concrete_type_1( char_short, short). + +jpl_type_to_preferred_concrete_type_1( char_byte, byte). + +jpl_type_to_preferred_concrete_type_1( array(T), array(Tc)) :- + jpl_type_to_preferred_concrete_type_1( T, Tc). + +jpl_type_to_preferred_concrete_type_1( T, T). + +%------------------------------------------------------------------------------ + +% jpl_types_fit_type(+Types, +Type) :- +% each member of Types is (independently) (if that means anything) +% assignable to Type +% e.g. for dynamic type check when attempting to assign list of values to array + +jpl_types_fit_type([], _). + +jpl_types_fit_type([T1|T1s], T2) :- + jpl_type_fits_type(T1, T2), + jpl_types_fit_type(T1s, T2). + +%------------------------------------------------------------------------------ + +% jpl_types_fit_types(+Types1, +Types2) :- +% each member type of Types1 "fits" the respective member type of Types2 + +jpl_types_fit_types([], []). + +jpl_types_fit_types([T1|T1s], [T2|T2s]) :- + jpl_type_fits_type(T1, T2), + jpl_types_fit_types(T1s, T2s). + +%------------------------------------------------------------------------------ + +% jpl_value_to_type(+Value, -Type) :- +% Value must be a proper JPL datum other than a ref +% i.e. primitive, String or void; +% it is of (unique most specific) Type, +% which may be one of the pseudo types char_byte, char_short or char_int + +jpl_value_to_type(V, T) :- + ground(V), % critically assumed by jpl_value_to_type_1/2 + ( jpl_value_to_type_1(V, Tv) % 2nd arg must be unbound + -> T = Tv + ). + +%------------------------------------------------------------------------------ + +%% jpl_value_to_type_1(+Value, -Type) is semidet. +% +% Type is the unique most specific JPL type of which Value +% represents an instance; called solely by jpl_value_to_type/2, +% which commits to first solution; +% +% NB some integer values are of JPL-peculiar uniquely most +% specific subtypes, i.e. char_byte, char_short, char_int but all +% are understood by JPL's internal utilities which call this proc +% +% NB we regard float as subtype of double +% +% NB objects and refs always have straightforward types + +jpl_value_to_type_1(@(false), boolean) :- !. +jpl_value_to_type_1(@(true), boolean) :- !. +jpl_value_to_type_1(A, class([java,lang],['String'])) :- % yes it's a "value" + atom(A), !. +jpl_value_to_type_1(I, T) :- + integer(I), !, + ( I >= 0 + -> ( I < 128 + -> T = char_byte + ; I < 32768 -> T = char_short + ; I < 65536 -> T = char_int + ; I < 2147483648 -> T = int + ; I =< 9223372036854775807 -> T = long + ; T = overlong + ) + ; I >= -128 -> T = byte + ; I >= -32768 -> T = short + ; I >= -2147483648 -> T = int + ; I >= -9223372036854775808 -> T = long + ; T = overlong + ). +jpl_value_to_type_1(F, float) :- + float(F). + +%------------------------------------------------------------------------------ + +% jpl_void(-X) :- +% X is (by unification) the proper JPL datum which represents the pseudo Java value 'void'; +% c.f. jpl_is_void/1 + +jpl_void(@(void)). + +%------------------------------------------------------------------------------ + +%type jpl_array_to_length(array, integer) + +% jpl_array_to_length(+ArrayObject, -Length) :- +% must validate ArrayObject before making the JNI call... + +jpl_array_to_length(A, N) :- + ( jpl_ref_to_type(A, array(_)) % can this be done cheaper e.g. in foreign code? + -> jGetArrayLength(A, N) % *must* be array, else undefined (crash?) + ). + +%------------------------------------------------------------------------------ + +%type jpl_array_to_list(array, list(datum)) + +% jpl_array_to_list(+Array, -Elements) :- + +jpl_array_to_list(A, Es) :- + jpl_array_to_length(A, Len), + ( Len > 0 + -> LoBound is 0, + HiBound is Len-1, + jpl_get(A, LoBound-HiBound, Es) + ; Es = [] + ). + +%------------------------------------------------------------------------------ + +%type jpl_datums_to_array(list(datum), array) + +% jpl_datums_to_array(+Ds, -A) :- +% A will be a ref to a new JVM array, +% whose base type is the most specific Java type +% of which each member of Datums is (directly or indirectly) an instance; +% NB this fails (without warning, currently) if: +% Ds is an empty list (no base type can be inferred) +% Ds contains a primitive value and an object or array ref (no common supertype) + +jpl_datums_to_array(Ds, A) :- + ground(Ds), + jpl_datums_to_most_specific_common_ancestor_type(Ds, T), % T may be pseudo e.g. char_byte + jpl_type_to_preferred_concrete_type( T, Tc), % bugfix added 16/Apr/2005 + jpl_new(array(Tc), Ds, A). + +%------------------------------------------------------------------------------ + +%type jpl_datums_to_array(list(datum), type, array) + +% jpl_datums_to_array(+Ds, +Type, -A) :- +% A will be a ref to a new JVM array, +% whose base type is the most specific Java type +% of which each member of Datums is (directly or indirectly) an instance; +% NB this fails (without warning, currently) if: +% Ds is an empty list (no base type can be inferred) +% Ds contains a primitive value and an object or array ref (no common supertype) + +jpl_datums_to_array(Ds, Tc, A) :- + ground(Ds), + ground(Tc), + jpl_new(array(Tc), Ds, A). + +%------------------------------------------------------------------------------ + +%type jpl_enumeration_element(object, datum) + +% jpl_enumeration_element(+Enumeration, -Element) :- +% generates each Element from the Enumeration; +% if the element is a java.lang.String then Element will be an atom; +% if the element is null then Element will (oughta) be null; +% otherwise I reckon it has to be an object ref + +jpl_enumeration_element(En, E) :- + ( jpl_call(En, hasMoreElements, [], @(true)) + -> jpl_call(En, nextElement, [], Ex), + ( E = Ex + ; jpl_enumeration_element(En, E) + ) + ). + +%------------------------------------------------------------------------------ + +%type jpl_enumeration_to_list(object, list(datum)) + +% jpl_enumeration_to_list(+Enumeration, -Elements) :- + +jpl_enumeration_to_list(EN, Es) :- + ( jpl_call(EN, hasMoreElements, [], @(true)) + -> jpl_call(EN, nextElement, [], E), + Es = [E|Es1], + jpl_enumeration_to_list(EN, Es1) + ; Es = [] + ). + +%------------------------------------------------------------------------------ + +%type jpl_hashtable_pair(object, pair(datum,datum)) + +% jpl_hashtable_pair(+HashTable, -KeyValuePair) :- +% generates Key-Value pairs from the given HashTable +% NB String is converted to atom but Integer is presumably returned as an object ref +% (i.e. as elsewhere, no auto unboxing); +%nb this is anachronistic (oughta use the Map interface?) + +jpl_hashtable_pair(HT, K-V) :- + jpl_call(HT, keys, [], Ek), + jpl_enumeration_to_list(Ek, Ks), + member(K, Ks), + jpl_call(HT, get, [K], V). + +%------------------------------------------------------------------------------ + +%type jpl_iterator_element(object, datum) + +% jpl_iterator_element(+Iterator, -Element) :- + +jpl_iterator_element(I, E) :- + ( jpl_call(I, hasNext, [], @(true)) + -> ( jpl_call(I, next, [], E) % surely it's steadfast... + ; jpl_iterator_element(I, E) + ) + ). + +%------------------------------------------------------------------------------ + +%type jpl_list_to_array(list(datum), array) + +% jpl_list_to_array(+Datums, -Array) :- +% Datums is a proper list of JPL datums (values or refs); +% if they have a most specific common supertype, +% Array is an array, of that base type, +% whose respective elements are Datums + +jpl_list_to_array(Ds, A) :- + jpl_datums_to_array(Ds, A). + +%------------------------------------------------------------------------------ + +%type jpl_list_to_array(list(datum), type, array) + +% jpl_list_to_array(+Datums, -Array) :- +% Datums is a proper list of JPL datums (values or refs); +% they must have a common supertype Type, +% Array is an array, of that base Type, +% whose respective elements are Datums + +jpl_list_to_array(Ds, Type, A) :- + jpl_datums_to_array(Ds, Type, A). + +%------------------------------------------------------------------------------ + +%type jpl_terms_to_array(list(term), array) + +% jpl_terms_to_array(+Terms, -Array) :- +% Terms is a proper list of arbitrary terms; +% Array is an array of jpl.Term, +% whose elements represent the respective members of the list + +jpl_terms_to_array(Ts, A) :- + jpl_terms_to_array_1(Ts, Ts2), + jpl_new( array(class([jpl],['Term'])), Ts2, A). + +%------------------------------------------------------------------------------ + +jpl_terms_to_array_1([], []). + +jpl_terms_to_array_1([T|Ts], [{T}|Ts2]) :- + jpl_terms_to_array_1(Ts, Ts2). + +%------------------------------------------------------------------------------ + +%type jpl_map_element(object, pair(datum,datum)) + +% jpl_map_element(+Map, -KeyValue) :- +% Map must be an instance of any implementation of the java.util.Map interface; +% this generates each Key-Value pair from the Map + +jpl_map_element(M, K-V) :- + jpl_call(M, entrySet, [], ES), + jpl_set_element(ES, E), + jpl_call(E, getKey, [], K), + jpl_call(E, getValue, [], V). + +%------------------------------------------------------------------------------ + +%type jpl_set_element(object, datum) + +% jpl_set_element(+Set, -Element) :- + +jpl_set_element(S, E) :- + jpl_call(S, iterator, [], I), + jpl_iterator_element(I, E). + +%------------------------------------------------------------------------------ + +% is_pair(?T) :- +% I define a half-decent "pair" as having a ground key (any val) + +is_pair(Key-_Val) :- + ground(Key). + +%------------------------------------------------------------------------------ + +is_pairs(List) :- + is_list(List), + maplist(is_pair, List). + +%------------------------------------------------------------------------------ + +multimap_to_atom(KVs, A) :- + multimap_to_atom_1(KVs, '', Cz, []), + flatten(Cz, Cs), + atomic_list_concat(Cs, A). + +%------------------------------------------------------------------------------ + +multimap_to_atom_1([], _, Cs, Cs). +multimap_to_atom_1([K-V|KVs], T, Cs1, Cs0) :- + Cs1 = [T,K,' = '|Cs2], + ( is_list(V) + -> ( is_pairs(V) + -> V = V2 + ; findall(N-Ve, nth1(N, V, Ve), V2) + ), + T2 = [' ',T], + Cs2 = ['\n'|Cs2a], + multimap_to_atom_1(V2, T2, Cs2a, Cs3) + ; to_atom(V, AV), + Cs2 = [AV,'\n'|Cs3] + ), + multimap_to_atom_1(KVs, T, Cs3, Cs0). + +%------------------------------------------------------------------------------ + +%% to_atom(+Term, -Atom) +% +% unifies Atom with a printed representation of Term. +% +% @tbd Sort of quoting requirements and use format(codes(Codes), +% ...) + +to_atom(Term, Atom) :- + ( atom(Term) + -> Atom = Term % avoid superfluous quotes + ; term_to_atom(Term, Atom) + ). + +%------------------------------------------------------------------------------ + + /******************************* + * MESSAGES * + *******************************/ + +:- multifile + prolog:error_message/3. + +prolog:error_message(java_exception(Ex)) --> + ( { jpl_call(Ex, toString, [], Msg) + } + -> [ 'Java exception: ~w'-[Msg] ] + ; [ 'Java exception: ~w'-[Ex] ] + ). + + + /******************************* + * PATHS * + *******************************/ + +:- multifile user:file_search_path/2. +:- dynamic user:file_search_path/2. + +:- if(current_prolog_flag(version_data,yap(_,_,_,_))). + +user:file_search_path(jar, library('.')). +:-else. +user:file_search_path(jar, swi(lib)). +:-endif. + +%% add_search_path(+Var, +Value) is det. +% +% Add value to the end of search-path Var. Value is normally a +% directory. Does not change the environment if Dir is already in +% Var. +% +% @param Value Path to add in OS notation. + +add_search_path(Path, Dir) :- + ( getenv(Path, Old) + -> ( current_prolog_flag(windows, true) + -> Sep = (;) + ; Sep = (:) + ), + ( atomic_list_concat(Current, Sep, Old), + memberchk(Dir, Current) + -> true % already present + ; atomic_list_concat([Old, Sep, Dir], New), + setenv(Path, New) + ) + ; setenv(Path, Dir) + ). + +%% search_path_separator(-Sep:atom) +% +% Separator used the the OS in =PATH=, =LD_LIBRARY_PATH=, +% =CLASSPATH=, etc. + +search_path_separator((;)) :- + current_prolog_flag(windows, true), !. +search_path_separator(:). + + /******************************* + * LOAD THE JVM * + *******************************/ + +%% check_java_environment +% +% Verify the Java environment. Preferably we would create, but +% most Unix systems do not allow putenv("LD_LIBRARY_PATH=..." in +% the current process. A suggesting found on the net is to modify +% LD_LIBRARY_PATH right at startup and next execv() yourself, but +% this doesn't work if we want to load Java on demand or if Prolog +% itself is embedded in another application. +% +% So, after reading lots of pages on the web, I decided checking +% the environment and producing a sensible error message is the +% best we can do. +% +% Please not that Java2 doesn't require $CLASSPATH to be set, so +% we do not check for that. + +check_java_environment :- + check_lib(java), + check_lib(jvm). + +check_lib(Name) :- + check_shared_object(Name, File, EnvVar, Absolute), + ( Absolute == (-) + -> ( current_prolog_flag(windows, true) + -> A = '%', Z = '%' + ; A = '$', Z = '' + ), + format(string(Msg), 'Please add directory holding ~w to ~w~w~w', + [ File, A, EnvVar, Z ]), + throw(error(existence_error(library, Name), + context(_, Msg))) + ; true + ). + +%% check_shared_object(+Lib, -File, -EnvVar, -AbsFile) is semidet. +% +% True if AbsFile is existing .so/.dll file for Lib. +% +% @param File Full name of Lib (i.e. libjpl.so or jpl.dll) +% @param EnvVar Search-path for shared objects. + +check_shared_object(Name, File, EnvVar, Absolute) :- + libfile(Name, File), + library_search_path(Path, EnvVar), + ( member(Dir, Path), + atomic_list_concat([Dir, File], /, Absolute), + exists_file(Absolute) + -> true + ; Absolute = (-) + ). + +libfile(Base, File) :- + current_prolog_flag(unix, true), !, + atom_concat(lib, Base, F0), + current_prolog_flag(shared_object_extension, Ext), + file_name_extension(F0, Ext, File). +libfile(Base, File) :- + current_prolog_flag(windows, true), !, + current_prolog_flag(shared_object_extension, Ext), + file_name_extension(Base, Ext, File). + + +%% library_search_path(-Dirs:list, -EnvVar) is det. +% +% Dirs is the list of directories searched for shared +% objects/DLLs. EnvVar is the variable in which the search path os +% stored. + +library_search_path(Path, EnvVar) :- + current_prolog_flag(shared_object_search_path, EnvVar), + search_path_separator(Sep), + ( getenv(EnvVar, Env), + atomic_list_concat(Path, Sep, Env) + -> true + ; Path = [] + ). + + +%% add_jpl_to_classpath +% +% Add jpl.jar to =CLASSPATH= to facilitate callbacks + +add_jpl_to_classpath :- + absolute_file_name(jar('jpl.jar'), + [ access(read) + ], JplJAR), !, + ( getenv('CLASSPATH', Old) + -> true + ; Old = '.' + ), + ( current_prolog_flag(windows, true) + -> Separator = ';' + ; Separator = ':' + ), + atomic_list_concat([JplJAR, Old], Separator, New), + setenv('CLASSPATH', New). + + +%% libjpl(-Spec) is det. +% +% Return the spec for loading the JPL shared object. This shared +% object must be called libjpl.so as the Java System.loadLibrary() +% call used by jpl.jar adds the lib* prefix. + +libjpl(File) :- + ( current_prolog_flag(unix, true) + -> File = foreign(libjpl) + ; File = foreign(jpl) + ). + +%% add_jpl_to_ldpath(+JPL) is det. +% +% Add the directory holding jpl.so to search path for dynamic +% libraries. This is needed for callback from Java. Java appears +% to use its own search and the new value of the variable is +% picked up correctly. + +add_jpl_to_ldpath(JPL) :- + absolute_file_name(JPL, File, + [ file_type(executable), + file_errors(fail) + ]), !, + file_directory_name(File, Dir), + prolog_to_os_filename(Dir, OsDir), + current_prolog_flag(shared_object_search_path, PathVar), + add_search_path(PathVar, OsDir). +add_jpl_to_ldpath(_). + +%% add_java_to_ldpath is det. +% +% Adds the directories holding jvm.dll and java.dll to the %PATH%. +% This appears to work on Windows. Unfortunately most Unix systems +% appear to inspect the content of LD_LIBRARY_PATH only once. + +add_java_to_ldpath :- + current_prolog_flag(windows, true), !, + phrase(java_dirs, Extra), + ( Extra \== [] + -> print_message(informational, extend_ld_path(Extra)), + maplist(win_add_dll_directory, Extra) + ; true + ). +add_java_to_ldpath. + +%% java_dirs// is det. +% +% DCG that produces existing candidate directories holding +% Java related DLLs + +java_dirs --> + % JDK directories + java_dir(jvm, '/jre/bin/client'), + java_dir(jvm, '/jre/bin/server'), + java_dir(java, '/jre/bin'), + % JRE directories + java_dir(jvm, '/bin/client'), + java_dir(jvm, '/bin/server'), + java_dir(java, '/bin'). + +java_dir(DLL, _SubPath) --> + { check_shared_object(DLL, _, _Var, Abs), + Abs \== (-) + }, !. +java_dir(_DLL, SubPath) --> + { java_home(JavaHome), + atom_concat(JavaHome, SubPath, SubDir), + exists_directory(SubDir) + }, !, + [SubDir]. +java_dir(_, _) --> []. + + +%% java_home(-Home) is semidet +% +% Find the home location of Java. +% +% @param Home JAVA home in OS notation + +java_home_win_key( + jre, + 'HKEY_LOCAL_MACHINE/Software/JavaSoft/Java Runtime Environment'). +java_home_win_key( + jdk, + 'HKEY_LOCAL_MACHINE/Software/JavaSoft/Java Development Kit'). + +java_home(Home) :- + getenv('JAVA_HOME', Home), + exists_directory(Home), !. +:- if(current_prolog_flag(windows, true)). +java_home(Home) :- + java_home_win_key(_, Key0), % TBD: user can't choose jre or jdk + catch(win_registry_get_value(Key0, 'CurrentVersion', Version), _, fail), + atomic_list_concat([Key0, Version], /, Key), + win_registry_get_value(Key, 'JavaHome', WinHome), + prolog_to_os_filename(Home, WinHome), + exists_directory(Home), !. +:- else. +java_home(Home) :- + member(Home, [ '/usr/lib/java', + '/usr/local/lib/java' + ]), + exists_directory(Home), !. +:- endif. + +:- dynamic + jvm_ready/0. +:- volatile + jvm_ready/0. + +setup_jvm :- + jvm_ready, !. +setup_jvm :- + add_jpl_to_classpath, + add_java_to_ldpath, + libjpl(JPL), + add_jpl_to_ldpath(JPL), + catch(load_foreign_library(JPL), E, report_java_setup_problem(E)), + assert(jvm_ready). + +report_java_setup_problem(E) :- + print_message(error, E), + check_java_environment. + + /******************************* + * MESSAGES * + *******************************/ + +:- multifile + prolog:message//1. + +prolog:message(extend_ld_path(Dirs)) --> + [ 'Extended DLL search path with'-[] ], + dir_per_line(Dirs). + +dir_per_line([]) --> []. +dir_per_line([H|T]) --> + [ nl, ' ~q'-[H] ], + dir_per_line(T). + +% Initialize JVM + +:- initialization(setup_jvm, now). % must be ready before export diff --git a/packages/jpl/jpl/CMakeFiles/CMakeDirectoryInformation.cmake b/packages/jpl/jpl/CMakeFiles/CMakeDirectoryInformation.cmake new file mode 100644 index 000000000..bab203dbc --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/CMakeDirectoryInformation.cmake @@ -0,0 +1,16 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Relative path conversion top directories. +set(CMAKE_RELATIVE_PATH_TOP_SOURCE "/Users/vsc/git/yap-6.3") +set(CMAKE_RELATIVE_PATH_TOP_BINARY "/Users/vsc/git/yap-6.3") + +# Force unix paths in dependencies. +set(CMAKE_FORCE_UNIX_PATHS 1) + + +# The C and CXX include file regular expressions for this directory. +set(CMAKE_C_INCLUDE_REGEX_SCAN "^.*$") +set(CMAKE_C_INCLUDE_REGEX_COMPLAIN "^$") +set(CMAKE_CXX_INCLUDE_REGEX_SCAN ${CMAKE_C_INCLUDE_REGEX_SCAN}) +set(CMAKE_CXX_INCLUDE_REGEX_COMPLAIN ${CMAKE_C_INCLUDE_REGEX_COMPLAIN}) diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/DependInfo.cmake b/packages/jpl/jpl/CMakeFiles/jplYap.dir/DependInfo.cmake new file mode 100644 index 000000000..77ec52163 --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/DependInfo.cmake @@ -0,0 +1,42 @@ +# The set of languages for which implicit dependencies are needed: +set(CMAKE_DEPENDS_LANGUAGES + "C" + ) +# The set of files for implicit dependencies of each language: +set(CMAKE_DEPENDS_CHECK_C + "/Users/vsc/git/yap-6.3/packages/jpl/src/c/jpl.c" "/Users/vsc/git/yap-6.3/packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o" + ) +set(CMAKE_C_COMPILER_ID "Clang") + +# Preprocessor definitions for this target. +set(CMAKE_TARGET_DEFINITIONS_C + "COROUTINING=1" + "DEBUG=1" + "DEPTH_LIMIT=1" + "HAVE_CONFIG_H" + "LOW_LEVEL_TRACER=1" + "RATIONAL_TREES=1" + "TABLING=1" + "USE_THREADEAD_CODE=1" + "UTF8PROC=1" + "_YAP_NOT_INSTALLED_=1" + ) + +# The include file search paths: +set(CMAKE_C_TARGET_INCLUDE_PATH + "." + "H" + "include" + "os" + "utf8proc" + "JIT/HPP" + "/usr/local/include" + "OPTYap" + "/System/Library/Frameworks/JavaVM.framework/Headers" + ) + +# Targets to which this target links. +set(CMAKE_TARGET_LINKED_INFO_FILES + "/Users/vsc/git/yap-6.3/CMakeFiles/libYap.dir/DependInfo.cmake" + "/Users/vsc/git/yap-6.3/utf8proc/CMakeFiles/utf8proc.dir/DependInfo.cmake" + ) diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/build.make b/packages/jpl/jpl/CMakeFiles/jplYap.dir/build.make new file mode 100644 index 000000000..a51d65424 --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/build.make @@ -0,0 +1,118 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Delete rule output on recipe failure. +.DELETE_ON_ERROR: + + +#============================================================================= +# Special targets provided by cmake. + +# Disable implicit rules so canonical targets will work. +.SUFFIXES: + + +# Remove some rules from gmake that .SUFFIXES does not remove. +SUFFIXES = + +.SUFFIXES: .hpux_make_needs_suffix_list + + +# Suppress display of executed commands. +$(VERBOSE).SILENT: + + +# A target that is always out of date. +cmake_force: + +.PHONY : cmake_force + +#============================================================================= +# Set environment variables for the build. + +# The shell in which to execute make rules. +SHELL = /bin/sh + +# The CMake executable. +CMAKE_COMMAND = /usr/local/Cellar/cmake/3.3.2/bin/cmake + +# The command to remove a file. +RM = /usr/local/Cellar/cmake/3.3.2/bin/cmake -E remove -f + +# Escaping for special characters. +EQUALS = = + +# The top-level source directory on which CMake was run. +CMAKE_SOURCE_DIR = /Users/vsc/git/yap-6.3 + +# The top-level build directory on which CMake was run. +CMAKE_BINARY_DIR = /Users/vsc/git/yap-6.3 + +# Include any dependencies generated for this target. +include packages/jpl/CMakeFiles/jplYap.dir/depend.make + +# Include the progress variables for this target. +include packages/jpl/CMakeFiles/jplYap.dir/progress.make + +# Include the compile flags for this target's objects. +include packages/jpl/CMakeFiles/jplYap.dir/flags.make + +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o: packages/jpl/CMakeFiles/jplYap.dir/flags.make +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o: packages/jpl/src/c/jpl.c + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_1) "Building C object packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o" + cd /Users/vsc/git/yap-6.3/packages/jpl && /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc $(C_DEFINES) $(C_FLAGS) -o CMakeFiles/jplYap.dir/src/c/jpl.c.o -c /Users/vsc/git/yap-6.3/packages/jpl/src/c/jpl.c + +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.i: cmake_force + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green "Preprocessing C source to CMakeFiles/jplYap.dir/src/c/jpl.c.i" + cd /Users/vsc/git/yap-6.3/packages/jpl && /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc $(C_DEFINES) $(C_FLAGS) -E /Users/vsc/git/yap-6.3/packages/jpl/src/c/jpl.c > CMakeFiles/jplYap.dir/src/c/jpl.c.i + +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.s: cmake_force + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green "Compiling C source to assembly CMakeFiles/jplYap.dir/src/c/jpl.c.s" + cd /Users/vsc/git/yap-6.3/packages/jpl && /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc $(C_DEFINES) $(C_FLAGS) -S /Users/vsc/git/yap-6.3/packages/jpl/src/c/jpl.c -o CMakeFiles/jplYap.dir/src/c/jpl.c.s + +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.requires: + +.PHONY : packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.requires + +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.provides: packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.requires + $(MAKE) -f packages/jpl/CMakeFiles/jplYap.dir/build.make packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.provides.build +.PHONY : packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.provides + +packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.provides.build: packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o + + +# Object files for target jplYap +jplYap_OBJECTS = \ +"CMakeFiles/jplYap.dir/src/c/jpl.c.o" + +# External object files for target jplYap +jplYap_EXTERNAL_OBJECTS = + +packages/jpl/libjpl.dylib: packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o +packages/jpl/libjpl.dylib: packages/jpl/CMakeFiles/jplYap.dir/build.make +packages/jpl/libjpl.dylib: libYap.6.3.4.dylib +packages/jpl/libjpl.dylib: utf8proc/libutf8proc.1.3.0.dylib +packages/jpl/libjpl.dylib: /usr/local/lib/libgmp.dylib +packages/jpl/libjpl.dylib: /usr/local/opt/readline/lib/libreadline.dylib +packages/jpl/libjpl.dylib: /usr/lib/libncurses.dylib +packages/jpl/libjpl.dylib: packages/jpl/CMakeFiles/jplYap.dir/link.txt + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green --bold --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_2) "Linking C shared library libjpl.dylib" + cd /Users/vsc/git/yap-6.3/packages/jpl && $(CMAKE_COMMAND) -E cmake_link_script CMakeFiles/jplYap.dir/link.txt --verbose=$(VERBOSE) + +# Rule to build all files generated by this target. +packages/jpl/CMakeFiles/jplYap.dir/build: packages/jpl/libjpl.dylib + +.PHONY : packages/jpl/CMakeFiles/jplYap.dir/build + +packages/jpl/CMakeFiles/jplYap.dir/requires: packages/jpl/CMakeFiles/jplYap.dir/src/c/jpl.c.o.requires + +.PHONY : packages/jpl/CMakeFiles/jplYap.dir/requires + +packages/jpl/CMakeFiles/jplYap.dir/clean: + cd /Users/vsc/git/yap-6.3/packages/jpl && $(CMAKE_COMMAND) -P CMakeFiles/jplYap.dir/cmake_clean.cmake +.PHONY : packages/jpl/CMakeFiles/jplYap.dir/clean + +packages/jpl/CMakeFiles/jplYap.dir/depend: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -E cmake_depends "Unix Makefiles" /Users/vsc/git/yap-6.3 /Users/vsc/git/yap-6.3/packages/jpl /Users/vsc/git/yap-6.3 /Users/vsc/git/yap-6.3/packages/jpl /Users/vsc/git/yap-6.3/packages/jpl/CMakeFiles/jplYap.dir/DependInfo.cmake --color=$(COLOR) +.PHONY : packages/jpl/CMakeFiles/jplYap.dir/depend + diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/cmake_clean.cmake b/packages/jpl/jpl/CMakeFiles/jplYap.dir/cmake_clean.cmake new file mode 100644 index 000000000..cc7b93dc9 --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/cmake_clean.cmake @@ -0,0 +1,10 @@ +file(REMOVE_RECURSE + "CMakeFiles/jplYap.dir/src/c/jpl.c.o" + "libjpl.pdb" + "libjpl.dylib" +) + +# Per-language clean rules from dependency scanning. +foreach(lang C) + include(CMakeFiles/jplYap.dir/cmake_clean_${lang}.cmake OPTIONAL) +endforeach() diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/depend.make b/packages/jpl/jpl/CMakeFiles/jplYap.dir/depend.make new file mode 100644 index 000000000..594cf931a --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/depend.make @@ -0,0 +1,2 @@ +# Empty dependencies file for jplYap. +# This may be replaced when dependencies are built. diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/flags.make b/packages/jpl/jpl/CMakeFiles/jplYap.dir/flags.make new file mode 100644 index 000000000..f71c2328f --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/flags.make @@ -0,0 +1,8 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# compile C with /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc +C_FLAGS = -g -fPIC -I/Users/vsc/git/yap-6.3 -I/Users/vsc/git/yap-6.3/H -I/Users/vsc/git/yap-6.3/include -I/Users/vsc/git/yap-6.3/os -I/Users/vsc/git/yap-6.3/utf8proc -I/Users/vsc/git/yap-6.3/JIT/HPP -I/usr/local/include -I/Users/vsc/git/yap-6.3/OPTYap -I/System/Library/Frameworks/JavaVM.framework/Headers -Wall -Wstrict-prototypes -Wmissing-prototypes -fexceptions + +C_DEFINES = -DCOROUTINING=1 -DDEBUG=1 -DDEPTH_LIMIT=1 -DHAVE_CONFIG_H -DLOW_LEVEL_TRACER=1 -DRATIONAL_TREES=1 -DTABLING=1 -DUSE_THREADEAD_CODE=1 -DUTF8PROC=1 -D_YAP_NOT_INSTALLED_=1 -DjplYap_EXPORTS + diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/link.txt b/packages/jpl/jpl/CMakeFiles/jplYap.dir/link.txt new file mode 100644 index 000000000..3cac8660e --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/link.txt @@ -0,0 +1 @@ +/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc -g -dynamiclib -Wl,-headerpad_max_install_names -o libjpl.dylib -install_name @rpath/libjpl.dylib CMakeFiles/jplYap.dir/src/c/jpl.c.o ../../libYap.6.3.4.dylib -framework JavaVM -framework JavaVM -ldl ../../utf8proc/libutf8proc.1.3.0.dylib /usr/local/lib/libgmp.dylib /usr/local/opt/readline/lib/libreadline.dylib /usr/lib/libncurses.dylib -Wl,-rpath,/Users/vsc/git/yap-6.3 diff --git a/packages/jpl/jpl/CMakeFiles/jplYap.dir/progress.make b/packages/jpl/jpl/CMakeFiles/jplYap.dir/progress.make new file mode 100644 index 000000000..eda664886 --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/jplYap.dir/progress.make @@ -0,0 +1,3 @@ +CMAKE_PROGRESS_1 = +CMAKE_PROGRESS_2 = 31 + diff --git a/packages/jpl/jpl/CMakeFiles/progress.marks b/packages/jpl/jpl/CMakeFiles/progress.marks new file mode 100644 index 000000000..fb1e7bc86 --- /dev/null +++ b/packages/jpl/jpl/CMakeFiles/progress.marks @@ -0,0 +1 @@ +54 diff --git a/packages/jpl/jpl/CMakeLists.txt b/packages/jpl/jpl/CMakeLists.txt new file mode 100644 index 000000000..21c5ac6eb --- /dev/null +++ b/packages/jpl/jpl/CMakeLists.txt @@ -0,0 +1,68 @@ +#CHECK: JavaLibs + +set (JPL_SOURCES + src/c/jpl.c) + +macro_optional_find_package(Java ON) +find_package(Java COMPONENTS Development) +#find_package(Java COMPONENTS Runtime) +macro_log_feature (Java_Development_FOUND "Java" + "Use Java System" + "http://www.java.org" FALSE) + +if (Java_Development_FOUND) + # Java_JAVA_EXECUTABLE = the full path to the Java runtime + # Java_JAVAC_EXECUTABLE = the full path to the Java compiler + # Java_JAVAH_EXECUTABLE = the full path to the Java header generator + # Java_JAVADOC_EXECUTABLE = the full path to the Java documention generator + # Java_JAR_EXECUTABLE = the full path to the Java archiver + # Java_VERSION_STRING = Version of java found, eg. 1.6.0_12 + # Java_VERSION_MAJOR = The major version of the package found. + # Java_VERSION_MINOR = The minor version of the package found. + # Java_VERSION_PATCH = The patch version of the package found. + # Java_VERSION_TWEAK = The tweak version of the package found (after '_') + # Java_VERSION = This is set to: $major.$minor.$patch(.$tweak) + # JAVA_LIBRARIES - path to the java library + # JAVA_INCLUDE_PATH - path to where Java.h is found (deprecated) + # JAVA_INCLUDE_DIRS - path to where Java.h is found + # JAVA_DEBUG_LIBRARIES - path to the debug library (deprecated) + # JAVALIBS_VERSION_STRING - version of the Java libs found (since CMake 2.8.8) + # + # + # + # The Java_ADDITIONAL_VERSIONS variable can be used to specify a list + # of version numbers that should be taken into account when searching + # for Java. You need to set this variable before calling + # find_package(JavaLibs). + # + macro_optional_find_package(JNI ON) + # JNI_INCLUDE_DIRS = the include dirs to use + # JNI_LIBRARIES = the libraries to use + # JNI_FOUND = TRUE if JNI headers and libraries were found. + # JAVA_AWT_LIBRARY = the path to the jawt library + # JAVA_JVM_LIBRARY = the path to the jvm library + # JAVA_INCLUDE_PATH = the include path to jni.h + # JAVA_INCLUDE_PATH2 = the include path to jni_md.h + # JAVA_AWT_INCLUDE_PATH = the include path to jawt.h + + add_library (jplYap SHARED src/c/jpl.c) + + add_subdirectory (src/java) + + include_directories (${JAVA_INCLUDE_DIRS} ${JNI_INCLUDE_DIRS}) + + target_link_libraries(jplYap libYap ${JAVA_LIBRARIES} ${JNI_LIBRARIES}) + + set_target_properties(jplYap PROPERTIES + OUTPUT_NAME jpl ) + + install(TARGETS jplYap + LIBRARY DESTINATION ${dlls} + ) + + install(FILES jpl.pl + DESTINATION ${libpl} + ) + + +endif (Java_Development_FOUND) diff --git a/packages/jpl/jpl/ChangeLog b/packages/jpl/jpl/ChangeLog new file mode 100644 index 000000000..b8d052bec --- /dev/null +++ b/packages/jpl/jpl/ChangeLog @@ -0,0 +1,105 @@ +[May 21 2008] + + * Enhanced: Bug#247: build test only conditionally. Keri Harris. + +Nov 28, 2006 + + * PORT: Bug#357: Updated config.{guess,sub}, needed for development + version of FC. Mary Ellen Foster. + +[Jan 30 2008] + + * FIXED: Bug#347: JPL pointer conversion. Mary Ellen Foster. + See remark with the bug-report for further info. + +[Jan 23 2008] + + * PORT: Bug#346: Allow overriding COFLAGS and CWFLAGS in package + configuration. Keri Harris. +Oct 23, 2007 + + * ADDED: On Windows, automatically find the JRE is the SDK is not present. + Ilmars Poikans. + +Aug 8, 2007 + + * FIXED: JRef handling on 64-bit non-Windows platforms. + Fixed by Paul Singleton. + +May 24, 2007 + + * FIXED: (JW) Exchange of codes 128..255. Lorenz Wallner. + +Mar 16, 2007 + + * INSTALL: Really do not require plunit fro normal distribution. + +Apr. 24, 2007 + + * FIXED: Bug#263. Crash in 64-bit version. Fixed by Paul Singleton. + +Feb 28, 2007 + + * FIXED: Bug#260: errornous integer check. Keri Harris. + +Nov 23, 2006 + + * NEW: Integrated Paul Singletons changes. Added test-cases, cleanup + of installation, etc. Joint effort of Paul Singleton and Jan Wielemaker. + +Nov 8, 2006 + + * PORT: Started work on support for 64-bit linux. Jan Wielemaker. + +Jul 31, 2006 + + * CONFIG: Add support for IBM java and Linux/PPC. Keri Harris. + +Jan 31, 2006 + + * CONFIG: Windows-XP configure problem on amd64. Keri Harris. + +Oct 28, 2004 + + * CONFIG: Bug#197: Handle absolute path for JAVAC. Owen Cliffe. + +Sep 28, 2004 + + * CONFIG: Force the use of javac (Sun Java) in configure if nothing is + specified by the user. + +May 27, 2004 + + * CLEANUP: Made Test2 example stand-alone rather than relying on things + wired into jpl.jar and jpl.pl (removed support from there). + +May 26, 2004 + + * ADDED: examples/java/SemWeb: Using the SWI-Prolog semantic web library + (rdf_db.pl) from Java. + +May 25, 2004 + + * ENHANCED: Also use the default engine. This means no engines are created + if they are not needed. + + * ENHANCED: Initially only make a single engine. Make upto 10 as they + are needed. (JW) + +May 24, 2004 + + * ADDED: Initial test suite (check.pl) (JW) + +May 14, 2004 + + * JW: Added Makefile for jpl.jar + * jpl.c: changed Sprintf() to DEBUG(level, Sdprintf()) + * exceptions: generate error(java_exception(Ex), ClassName). Provide + hook for normal readable error messages. + +May 12, 2004 + + * JW: Removed jpl_demo/0 + * JW: Included library(lists) and removed list predicates + * JW: Cleanup of is_pairs/1 and is_pair/1. + diff --git a/packages/jpl/jpl/ISSUES b/packages/jpl/jpl/ISSUES new file mode 100644 index 000000000..45eafe972 --- /dev/null +++ b/packages/jpl/jpl/ISSUES @@ -0,0 +1,58 @@ +ELF systems and libpl.so +======================== + +On Unix systems, SWI-Prolog is normally compiled as an application and +static library (lib/$PLARCH/libpl.a). First of all this is easier ported +on may Unix systems and second, shared object require position +independent code (-fpic) and this is (depending on the processor) +generally slower than application code running at a fixed address. + +We link jpl.so using -lpl, so it is linked to the dynamic libpl.so if +Prolog is configured using -enable-shared or to the static libpl.a +otherwise. On ELF systems that can handle position-dependent (i.e. +compiled _without_ -fpic) code in shared objects this works fine. If +libjpl.so is loaded directly from Java it will use the Prolog kernel +included in libjpl.so. If it is invoked through Prolog, the Prolog +application is before libjpl.so in the ELF search path and therefore all +Prolog symbols are resolved against the application. + +There are two drawbacks to this approach. The libjpl.so file could have +been a small and version independent library, while it is now bulky due +to the embedded Prolog engine and version dependent. + +Summarising, if your OS cannot load position dependent .so files you +MUST configure SWI-Prolog using --enable-shared. If it can (Linux), the +choice is yours and depends on the performance penalty paid on your +processor (approx. 7% on an AMD Athon), how you wish to arrange +versioning and how keen you are on memory sharing. + + +Installed components (Unix) +=========================== + +Make install installs the following components: + + * $PLBASE/library/jpl.pl + * $PLBASE/lib/jpl.jar + * $PLBASE/lib/$PLARCH/libjpl.so + +The disadvantage of this is that $PLBASE/lib/$PLARCH must be in +$LD_LIBRARY_PATH to be able to call Prolog from Java (either when +embedding Prolog in Java or using a Prolog -> Java -> Prolog callback). +Unfortunately all the other Prolog .so files are loaded by explicitely +searching for them. + + +Finding Java on Windows +======================= + +It appears the following keys are relevant for SUN SDK: + +?- win_registry_get_value('HKEY_LOCAL_MACHINE/Software/JavaSoft/Java Development Kit', + 'CurrentVersion', X). + + X = 1.4 + +?- win_registry_get_value('HKEY_LOCAL_MACHINE/Software/JavaSoft/Java Development Kit/1.4', 'JavaHome', X). + + X = 'C:\\j2sdk1.4.2_04' diff --git a/packages/jpl/jpl/Makefile.in b/packages/jpl/jpl/Makefile.in new file mode 100755 index 000000000..87d9f0351 --- /dev/null +++ b/packages/jpl/jpl/Makefile.in @@ -0,0 +1,196 @@ +################################################################ +# @configure_input@ +# +# Build JPL. Building JPL for Unix currently relies on the following +# assumptions: +# +# * $JAVA_HOME points to the JDK top directory +# * $PATH includes $JAVA_HOME/bin +# * ELF Dynamic Linker semantics +# +# Author: Jan Wielemaker, based on shell-scripts from Paul Singleton. +################################################################ + +PACKAGE=jpl +PKGCFLAGS=@JPLCFLAGS@ +PKGLDFLAGS=@JPLLDFLAGS@ + +include ../Makefile.defs + +LIBS=@LIBS@ + +JAVA_HOME=@JAVA_HOME@ +JAVAC=@JAVAC@ +JAVACFLAGS=@JAVACFLAGS@ +JAVA=@JAVA@ +JUNIT=@JUNIT@ +JAVALIBS=@JAVALIBS@ + +LIBPL= $(srcdir)/jpl.pl +LIBJPL= @LIBJPL@.@SO@ +TARGETS= $(LIBJPL) +OBJ= src/c/jpl.o + +# YAP has some extra hacks that need to be compiled in. +ifeq (@PROLOG_SYSTEM@,yap) +src/c/jpl.o: $(srcdir)/src/c/jpl.c $(srcdir)/src/c/hacks.c + $(CC) -c $(CFLAGS) $(srcdir)/src/c/jpl.c -o src/c/jpl.o +endif + +all: $(TARGETS) jpl.jar exjava-compile jpl_doc + +# linking order counts here: otherwise libjpl.so will not remember +# it needs libYap.so +@LIBJPL@.@SO@: $(OBJ) + $(LD) $(LDSOFLAGS) -o $@ $(OBJ) $(LIBS) $(JAVALIBS) $(LIBPLEMBED) + if [ -r @LIBJPL@.@SO@ ]; then \ + rm -f @LIBJPL@.jnilib && ln -s @LIBJPL@.@SO@ @LIBJPL@.jnilib ; \ + fi + +jpl.jar:: + (cd src/java && $(MAKE) jpl_jar) +jpl_doc:: + (cd src/java && $(MAKE) jpl_doc) + +################################################################ +# Verify the package +################################################################ + +check: check_pl check_java + +check_pl: jpltest.jar + $(PL) -q -f test_jpl.pl -g run_tests,halt -t 'halt(1)' +check_java: jpltest.jar + JUNIT=$(JUNIT) JAVA=$(JAVA) JAVA_PRELOAD=$(JAVA_PRELOAD) $(srcdir)/test-java.sh + +jpltest.jar: + (cd src/java && $(MAKE) test_jar) + +################################################################ +# Installation +################################################################ + +DOCDIRS= $(srcdir) $(srcdir)/java_api \ + $(srcdir)/java_api/javadoc $(srcdir)/java_api/javadoc/jpl \ + $(srcdir)/java_api/javadoc/jpl/class-use \ + $(srcdir)/java_api/javadoc/jpl/fli \ + $(srcdir)/java_api/javadoc/jpl/fli/class-use \ + $(srcdir)/java_api/javadoc/resources \ + $(srcdir)/prolog_api \ + $(srcdir)/prolog_api/overview +DOCFILES= $(shell cd $(srcdir)/docs && find . -name '*.html' -o -name '*.gif' -o -name '*.jpg') + +EXPL= $(PKGEXDIR)/jpl/prolog +EXPLS= jpl_colour_choose_demo.pl \ + jpl_jlist_demo.pl \ + jpl_midi_demo.pl \ + jpl_table_demo.pl \ + jpl_text_entry_demo.pl \ + jpl_versions_demo.pl +EXJAVA= $(PKGEXDIR)/jpl/java +EXJAVAS= Exceptions Exceptions2 Family FamilyMT Test Test2 Time \ + Versions Zahed SemWeb + + +install: all $(LIBPL) + mkdir -p $(DESTDIR)$(SOLIBDIR) + for f in $(TARGETS); do \ + $(INSTALL_PROGRAM) "$$f" "$(DESTDIR)$(SOLIBDIR)"; \ + done +ifeq (@SO@,dylib) + (cd $(DESTDIR)$(SOLIBDIR) && ln -sf @LIBJPL@.@SO@ @LIBJPL@.jnilib) +endif + mkdir -p $(DESTDIR)$(PLLIBDIR) + mkdir -p $(DESTDIR)$(PLLIBDIR)/jpl + for f in $(LIBPL); do \ + $(INSTALL_DATA) $$f $(DESTDIR)$(PLLIBDIR); \ + done + $(INSTALL_DATA) jpl.jar $(DESTDIR)$(PLLIBDIR)/jpl + $(PL) -f none -g make -t halt + mkdir -p "$(DESTDIR)$(PLLIBDIR)" + for f in $(LIBPL); do \ + $(INSTALL_DATA) $$f $(DESTDIR)$(PLLIBDIR); \ + done + $(MKINDEX) + +install-examples:: + expl-install exjava-install + +ln-install:: + @$(MAKE) INSTALL_DATA='../ln-install' install + +rpm-install: install html-install + +html-install:: expl-install exjava-install + mkdir -p $(DESTDIR)$(PKGDOCDIR)/jpl + @printf "Creating directories " + @for d in $(DOCDIRS); do \ + mkdir -p $(DESTDIR)$(PKGDOCDIR)/jpl/$$d; printf "."; \ + done + @echo "ok" + @printf "Copying documentation files " + @for f in $(DOCFILES); do \ + $(INSTALL_DATA) docs/$$f $(DESTDIR)$(PKGDOCDIR)/jpl/$$f; printf "."; \ + done + @echo "ok" + +expl-install:: + echo "Installing Prolog examples" + mkdir -p $(DESTDIR)$(EXPL) + @for f in $(EXPLS) README; do \ + $(INSTALL_DATA) $(srcdir)/examples/prolog/$$f $(DESTDIR)$(EXPL)/$$f; \ + done + +exjava-compile: jpl.jar + echo "Compiling Java examples" + for d in $(EXJAVAS); do \ + if [ ! -f examples/java/$$d/$$d.class ]; then \ + echo $$d; \ + mkdir -p examples/java/$$d; \ + (cd examples/java/$$d && "$(JAVAC)" $(JAVACFLAGS) -d . -classpath "../../../jpl.jar" $(srcdir)/examples/java/$$d/$$d.java); \ + fi; \ + done + +exjava-install: exjava-compile + echo "Installing Java examples" + mkdir -p "$(DESTDIR)$(EXJAVA)" + $(INSTALL_DATA) $(srcdir)/examples/java/README "$(DESTDIR)$(EXJAVA)" + $(INSTALL_DATA) $(srcdir)/examples/java/env.@CMDEXT@ "$(DESTDIR)$(EXJAVA)" + for d in $(EXJAVAS); do \ + mkdir -p $(DESTDIR)$(EXJAVA)/$$d; \ + $(INSTALL_SCRIPT) $(srcdir)/examples/java/$$d/run.@CMDEXT@ "$(DESTDIR)$(EXJAVA)/$$d" ;\ + $(INSTALL_DATA) $(srcdir)/examples/java/$$d/README "$(DESTDIR)$(EXJAVA)/$$d" ;\ + $(INSTALL_DATA) $(srcdir)/examples/java/$$d/$$d.java "$(DESTDIR)$(EXJAVA)/$$d" ;\ + for f in $(srcdir)/examples/java/$$d/*.pl; do \ + $(INSTALL_DATA) "$$f" "$(DESTDIR)$(EXJAVA)/$$d"; \ + done ;\ + $(INSTALL_DATA) examples/java/$$d/$$d*.class $(DESTDIR)$(EXJAVA)/$$d ;\ + done + $(INSTALL_DATA) $(srcdir)/examples/java/SemWeb/test.rdf "$(DESTDIR)$(EXJAVA)/SemWeb" + +pdf-install:: + mkdir -p $(DESTDIR)$(PKGDOCDIR) + $(INSTALL) -m 644 $(DOC).pdf "$(DESTDIR)$(PKGDOCDIR)" + +uninstall:: + (cd $(PLBASE)/lib/$(PLARCH) && rm -f $(TARGETS)) + (cd $(PLBASE)/library && rm -f $(LIBPL)) + $(PL) -f none -g make -t halt + +################################################################ +# Clean +################################################################ + +clean: + rm -f $(OBJ) *~ *.o *% a.out core config.log + rm -f TestJPL.class + find examples/java -name '*.class' -delete + (cd src/java && $(MAKE) clean) + +distclean: clean + rm -rf autom4te.cache + rm -f $(TARGETS) config.cache config.h config.status Makefile + rm -f $(DOC).aux $(DOC).log $(DOC).out $(DOC).toc + rm -rf html + (cd src/java && $(MAKE) distclean) + diff --git a/packages/jpl/jpl/Makefile.mak b/packages/jpl/jpl/Makefile.mak new file mode 100644 index 000000000..16325a78f --- /dev/null +++ b/packages/jpl/jpl/Makefile.mak @@ -0,0 +1,119 @@ +################################################################ +# Build the SWI-Prolog tabling package for MS-Windows +# +# Author: Jan Wielemaker +# +# Use: +# nmake /f Makefile.mak +# nmake /f Makefile.mak install +################################################################ + +PLHOME=..\.. +!include ..\..\src\rules.mk +JAVA="$(JAVA_HOME)\bin\java" + +PKGDLL=jpl + +EXDIR= $(PKGDOC)\examples\jpl +EXPL= $(EXDIR)\prolog +EXPLS= jpl_colour_choose_demo.pl \ + jpl_jlist_demo.pl \ + jpl_midi_demo.pl \ + jpl_table_demo.pl \ + jpl_text_entry_demo.pl \ + jpl_versions_demo.pl +EXJAVA= $(EXDIR)\java +EXJAVAS= Exceptions Exceptions2 Family FamilyMT Test Test2 Time \ + Versions Zahed SemWeb + + +CFLAGS = $(CFLAGS) \ + -I"$(JAVA_HOME)\include" \ + -I"$(JAVA_HOME)\include\win32" +LIBS = $(LIBS) "$(JAVA_HOME)\lib\jvm.lib" + +OBJ= src\c\jpl.obj + +all: checkenv $(PKGDLL).dll jar + +jar:: + chdir src\java & $(MAKE) + +checkenv:: + @if not exist "$(JAVA_HOME)\lib\jvm.lib" \ + echo FATAL ERROR: No JAVA_HOME defined? && exit 1 + +$(PKGDLL).dll: $(OBJ) + $(LD) /dll /out:$@ $(LDFLAGS) $(OBJ) $(PLLIB) $(LIBS) + +!IF "$(CFG)" == "rt" +install: idll +!ELSE +install: idll ilib +!ENDIF + +idll:: + copy $(PKGDLL).dll "$(BINDIR)" +ilib:: + copy jpl.pl "$(PLBASE)\library" + copy jpl.jar "$(PLBASE)\lib" + $(MAKEINDEX) + +html-install:: expl-install exjava-install + @echo CVS > nocopy + xcopy /Q /S /I /Y /EXCLUDE:nocopy docs "$(PKGDOC)\jpl" + del nocopy + +xpce-install:: + +expl-install:: + if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)" + if not exist "$(EXPL)/$(NULL)" $(MKDIR) "$(EXPL)" + cd examples\prolog & \ + @for %f in ($(EXPLS)) do @copy %f "$(EXPL)" + copy examples\prolog\README "$(EXPL)\README.TXT" + +exjava-install:: + if not exist "$(EXDIR)/$(NULL)" $(MKDIR) "$(EXDIR)" + if not exist "$(EXJAVA)/$(NULL)" $(MKDIR) "$(EXJAVA)" + copy examples\java\README "$(EXJAVA)"\README.TXT + copy examples\java\env.bat "$(EXJAVA)" + for %f in ($(EXJAVAS)) do if not exist "$(EXJAVA)\%f\$(NULL)" mkdir "$(EXJAVA)\%f" + for %f in ($(EXJAVAS)) do copy examples\java\%f\run.bat "$(EXJAVA)\%f + for %f in ($(EXJAVAS)) do copy examples\java\%f\README "$(EXJAVA)\%f\README.txt + for %f in ($(EXJAVAS)) do copy examples\java\%f\%f.java "$(EXJAVA)\%f + for %f in ($(EXJAVAS)) do if exist examples\java\%f\*.pl copy examples\java\%f\*.pl "$(EXJAVA)\%f" + copy examples\java\SemWeb\test.rdf "$(EXJAVA)\SemWeb" + +uninstall:: + del "$(PLBASE)\bin\$(PKGDLL).dll" + del "$(PLBASE)\library\jpl.pl" + del "$(PLBASE)\lib\jpl.jar" + $(MAKEINDEX) + +################################################################ +# Verify the package +################################################################ + +check: check_pl check_java + +check_pl:: + "$(PLCON)" -q -f test_jpl.pl -g run_tests,halt -t 'halt(1)' +check_java:: + set CLASSPATH=$(JUNIT);jpl.jar;jpltest.jar + $(JAVA) junit.textui.TestRunner jpl.test.TestJUnit + +################################################################ +# Cleanup +################################################################ + +clean:: + if exist $(OBJ) del $(OBJ) + if exist *.obj del *.obj + if exist *~ del *~ + chdir src\java & $(MAKE) clean + +distclean: clean + -DEL *.dll *.lib *.exp *.pdb *.ilk 2>nul + chdir src\java & $(MAKE) distclean + diff --git a/packages/jpl/jpl/README.MacOS b/packages/jpl/jpl/README.MacOS new file mode 100644 index 000000000..6c584859a --- /dev/null +++ b/packages/jpl/jpl/README.MacOS @@ -0,0 +1,23 @@ +# Compiling JPL for MacOS + +Updated: Nov 5, 2013 for MacOS 10.9 + +# Using Apple's Java distribution + +Somehow MacOS did not install the Java SDK correctly, so I ended up without +jni.h. I did not find a resolution for that. + +# Using Oracle's SDK + +Download from + + - http://www.oracle.com/technetwork/java/javase/downloads/jdk7-downloads-1880260.html + +which installs + + - /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home + +Set $JAVAPREFIX to + + - /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/bin + \ No newline at end of file diff --git a/packages/jpl/jpl/README.html b/packages/jpl/jpl/README.html new file mode 100644 index 000000000..e4aaa65d5 --- /dev/null +++ b/packages/jpl/jpl/README.html @@ -0,0 +1,152 @@ + + + + + JPL 3.0 documentation home page + + + + + + + +

JPL 3.x documentation home +page

+
+

Introduction

+

JPL 3.x is a dynamic, +bidirectional interface +between SWI-Prolog 5.2.0 or later and Java 2 +runtimes (see JPL 3.x +Objectives).  It offers two APIs:

+
    +
  • +

    Java +API (Java-calls-Prolog): this +interface comprises public Java classes which support:

    +
      +
    • +

      constructing Java +representations of Prolog terms and queries

      +
      • +
    • +

      calling queries within SWI-Prolog +engines

      +
      • +
    • +

      retrieving (as Java representations of Prolog terms) any +bindings created by a call

      +
      • +
    +
    • +
+
    +
  • +

    Prolog +API (Prolog-calls-Java): this +interface comprises Prolog library predicates which support:

    +
      +
    • +

      creating instances (objects) of +Java classes (built-in and user-defined)

      +
      • +
    • +

      calling methods of Java objects +(and static methods of classes), perhaps returning values or object +references

      +
      • +
    • +

      getting and setting the values of fields of Java objects and +classes

      +
      • +
    +
    • +
+

Calls to the two APIs can be nested, +e.g. Java code can call Prolog predicates which call Java methods +which call Prolog predicates etc.

+
+

Prerequisites

+

JPL 3.x currently requires SWI-Prolog 5.2.0 +or later (it uses multi-threading FLI calls not available in older +versions).  If you are using SWI-Prolog 5.1.X, then +you should probably upgrade to the latest stable 5.2.X +release.  Support for earlier versions may be added in the +future.

+

JPL 3.x currently requires a Java 2 +runtime (or development kit), and has been tested with +Sun's jdk1.3.1_01.

+

JPL 3.x contains a native library (jpl.c) +written in ANSI/ISO C and designed to be portable to many +operating system platforms for which suitable compilers are +available.  It has, however, only been tested with Microsoft +Visual C/C++ 5 under Windows NT 4.0 (SP6a).  I +shall be grateful if anyone can (show me how to) tidily adapt the +source and makefiles to build for other platforms.

+
+

Documentation

+

This alpha release of JPL 3.x contains a +hotch-potch of documentation, some left over from Fred Dushin's +(Java-calls-Prolog) JPL 1.0.1 and now obsolete or misleading, +some rewritten for JPL 2.0.2 and still mostly applicable, +and some written for the first release of my Prolog-calls-Java +interface, now part of JPL, and also mostly still +relevant.
+

+

In addition to this document (index.html in jpl's root folder) there +are:
+

+ +

+
+

Installation

+

Put the three library files (jpl.dll, jpl.jar +and jpl.pl) where they can be found by your OS, by your +Java apps and by SWI-Prolog respectively; for details, see JPL +3.x Installation.

+
+

Testing

+

Each of the folders within jpl\examples\java +contains a simple Java application which tests some +aspect of JPL.  These applications are +already compiled, and each folder contains a (DOS/Windows) +script run.bat which announces and +runs the demo.
+ 
+Each of the Prolog source files within jpl/examples/prolog contains a +self-contained Prolog application which exercises JPL from within +Prolog; start an interactive SWI-Prolog session as usual, and then +consult and run these files.
+

+
+
Paul Singleton
+
February 2004
+ + diff --git a/packages/jpl/jpl/ac/ac_jni_include_dirs.m4 b/packages/jpl/jpl/ac/ac_jni_include_dirs.m4 new file mode 100755 index 000000000..aa88b21b4 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_jni_include_dirs.m4 @@ -0,0 +1,150 @@ +dnl Modified by Peter Green to correct include paths +dnl with OpenJDK on all architectures other than i386 and amd64 + + +dnl Original version is available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_jni_include_dirs.html +dnl + + +AC_DEFUN([AC_JNI_INCLUDE_DIR],[ + +JNI_INCLUDE_DIRS="" + +if test "x$JAVAPREFIX" = x; then + test "x$JAVAC" = x && AC_MSG_ERROR(['$JAVAC' undefined]) + + case "$JAVAC" in + /*) _ACJNI_JAVAC="$JAVAC" + ;; + *) AC_PATH_PROG(_ACJNI_JAVAC, $JAVAC, no) + ;; + esac + + AC_PATH_PROG(_ACJNI_JAVAC, $JAVAC, no) + test "x$_ACJNI_JAVAC" = xno && AC_MSG_ERROR([$JAVAC could not be found in path]) + + _ACJNI_FOLLOW_SYMLINKS("$_ACJNI_JAVAC") + _JTOPDIR=`echo "$_ACJNI_FOLLOWED" | sed -e 's://*:/:g' -e 's:/[[^/]]*$::'` +else + _JTOPDIR="$(dirname "$JAVAPREFIX")" +fi + +found=no +while test $found = no; do + if test -f "$_JTOPDIR/include/jni.h"; then + JNI_INCLUDE_DIRS="$JNI_INCLUDE_DIRS $_JTOPDIR/include" + _JINC="$_JTOPDIR/include" + found=yes + elif test -f "$_JTOPDIR/Headers/jni.h"; then + JNI_INCLUDE_DIRS="$JNI_INCLUDE_DIRS $_JTOPDIR/Headers" + _JINC="$_JTOPDIR/Headers" + found=yes + elif test -f "$_JTOPDIR/Contents/Home/include/jni.h"; then + _JTOPDIR="$_JTOPDIR/Contents/Home" + JNI_INCLUDE_DIRS="$JNI_INCLUDE_DIRS $_JTOPDIR/include" + _JINC="$_JTOPDIR/include" + found=yes + else + _JTOPDIR2=`echo "$_JTOPDIR" | sed -e 's:/[[^/]]*$::'` + if test "$_JTOPDIR2" = "$_JTOPDIR"; then + AC_MSG_ERROR([cannot find java include files]) + found=oops + else + _JTOPDIR="$_JTOPDIR2" + _JINC="$_JTOPDIR2/include" + fi + fi +done + +AC_MSG_RESULT(_JTOPDIR="$_JTOPDIR") + +# get the likely subdirectories for system specific java includes +case "$host_os" in +bsdi*) _JNI_INC_SUBDIRS="bsdos";; +linux*) _JNI_INC_SUBDIRS="linux genunix";; +mingw32*) _JNI_INC_SUBDIRS="win32";; +osf*) _JNI_INC_SUBDIRS="alpha";; +solaris*) _JNI_INC_SUBDIRS="solaris";; +darwin*) _JNI_INC_SUBDIRS="darwin genunix";; +*) _JNI_INC_SUBDIRS="genunix";; +esac + +# add any subdirectories that are present +for JINCSUBDIR in $_JNI_INC_SUBDIRS +do + if test -d "$_JINC/$JINCSUBDIR"; then + JNI_INCLUDE_DIRS="$JNI_INCLUDE_DIRS $_JINC/$JINCSUBDIR" + fi +done + +case "$host_os" in +mingw32*) JNI_CLIENT_DIRS="$_JTOPDIR/lib $_JTOPDIR/jre/bin $_JTOPDIR/jre/bin/server" + ;; + +*) case "$host_cpu" in + i?86) + _JNI_LIBDIRS="lib/i386 lib/amd64 lib" + _JNI_LIBSUBDIRS="server client" + ;; + x86_64) + _JNI_LIBDIRS="lib/amd64" + _JNI_LIBSUBDIRS="server" + ;; + powerpc) + case "$host_os" in + linux*) + _JNI_LIBDIRS="lib/ppc bin" + _JNI_LIBSUBDIRS="server classic" + ;; + *) + _JNI_LIBDIRS="" + esac + ;; + *) + # Fallback option should work on all architectures except + # amd64 and powerpc which are special cased above. + _JNI_LIBDIRS="lib/$host_cpu" + _JNI_LIBSUBDIRS="server" +esac + +for d in $_JNI_LIBDIRS; do + for subd in $_JNI_LIBSUBDIRS; do + echo "Trying $_JTOPDIR/jre/$d/$subd" + if test -d $_JTOPDIR/jre/$d/$subd; then + JNI_CLIENT_DIRS="$JNI_CLIENT_DIRS $_JTOPDIR/jre/$d/$subd $_JTOPDIR/jre/$d" + case "$target_os" in + *linux*) + JAVALIBS="$JAVALIBS -Wl,-R$_JTOPDIR/jre/$d/$subd -Wl,-R$_JTOPDIR/jre/$d" + ;; + **) + ;; + esac + fi + done +done + +;; +esac + +]) + +# _ACJNI_FOLLOW_SYMLINKS +# Follows symbolic links on , +# finally setting variable _ACJNI_FOLLOWED +# -------------------- +AC_DEFUN([_ACJNI_FOLLOW_SYMLINKS],[ +# find the include directory relative to the javac executable +_cur="$1" +while ls -ld "$_cur" 2>/dev/null | grep " -> " >/dev/null; do + AC_MSG_CHECKING(symlink for $_cur) + _slink=`ls -ld "$_cur" | sed 's/.* -> //'` + case "$_slink" in + /*) _cur="$_slink";; + # 'X' avoids triggering unwanted echo options. + *) _cur=`echo "X$_cur" | sed -e 's/^X//' -e 's:[[^/]]*$::'`"$_slink";; + esac + AC_MSG_RESULT($_cur) +done +_ACJNI_FOLLOWED="$_cur" +])# _ACJNI diff --git a/packages/jpl/jpl/ac/ac_prog_jar.m4 b/packages/jpl/jpl/ac/ac_prog_jar.m4 new file mode 100644 index 000000000..54478d2a9 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_jar.m4 @@ -0,0 +1,15 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_jar.html +dnl +AC_DEFUN([AC_PROG_JAR],[ +AC_REQUIRE([AC_EXEEXT])dnl +if test "x$JAR" = x; then + if test "x$JAVAPREFIX" = x; then + AC_CHECK_PROGS(JAR, jar$EXEEXT) + else + AC_PATH_PROGS(JAR, jar$EXEEXT, , $JAVAPREFIX) + fi +fi +test "x$JAR" = x && AC_MSG_ERROR([no acceptable jar program found in \$PATH]) +AC_PROVIDE([$0])dnl +]) diff --git a/packages/jpl/jpl/ac/ac_prog_java.m4 b/packages/jpl/jpl/ac/ac_prog_java.m4 new file mode 100644 index 000000000..05a60d6e2 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_java.m4 @@ -0,0 +1,16 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_java.html +dnl +AC_DEFUN([AC_PROG_JAVA],[ +AC_REQUIRE([AC_EXEEXT])dnl +if test "x$JAVA" = x; then + if test "x$JAVAPREFIX" = x; then + AC_CHECK_PROGS(JAVA, kaffe$EXEEXT java$EXEEXT) + else + AC_PATH_PROGS(JAVA, kaffe$EXEEXT java$EXEEXT, , $JAVAPREFIX) + fi +fi +test "x$JAVA" = x && AC_MSG_ERROR([no acceptable Java virtual machine found in \$PATH]) +AC_PROG_JAVA_WORKS +AC_PROVIDE([$0])dnl +]) diff --git a/packages/jpl/jpl/ac/ac_prog_java_cc.m4 b/packages/jpl/jpl/ac/ac_prog_java_cc.m4 new file mode 100644 index 000000000..bd67f4332 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_java_cc.m4 @@ -0,0 +1,31 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_java_cc.html +dnl +# AC_PROG_JAVA_CC([COMPILER ...]) +# -------------------------- +# COMPILER ... is a space separated list of java compilers to search for. +# This just gives the user an opportunity to specify an alternative +# search list for the java compiler. +AC_DEFUN([AC_PROG_JAVA_CC], +[AC_ARG_VAR([JAVA_CC], [java compiler command])dnl +AC_ARG_VAR([JAVA_CC_FLAGS], [java compiler flags])dnl +m4_ifval([$1], + [AC_CHECK_TOOLS(JAVA_CC, [$1])], +[AC_CHECK_TOOL(JAVA_CC, gcj) +if test -z "$JAVA_CC"; then + AC_CHECK_TOOL(JAVA_CC, javac) +fi +if test -z "$JAVA_CC"; then + AC_CHECK_TOOL(JAVA_CC, jikes) +fi +]) + +if test "$JAVA_CC" = "gcj"; then + if test "$GCJ_OPTS" = ""; then + AC_SUBST(GCJ_OPTS,-C) + fi + AC_SUBST(JAVA_CC_OPTS, @GCJ_OPTS@, + [Define the compilation options for GCJ]) +fi +test -z "$JAVA_CC" && AC_MSG_ERROR([no acceptable java compiler found in \$PATH]) +])# AC_PROG_JAVA_CC diff --git a/packages/jpl/jpl/ac/ac_prog_java_works.m4 b/packages/jpl/jpl/ac/ac_prog_java_works.m4 new file mode 100644 index 000000000..69334ea4e --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_java_works.m4 @@ -0,0 +1,85 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_java_works.html +dnl +AC_DEFUN([AC_PROG_JAVA_WORKS], [ +AC_CHECK_PROG(uudecode, uudecode$EXEEXT, yes) +if test x$uudecode = xyes; then +AC_CACHE_CHECK([if uudecode can decode base 64 file], ac_cv_prog_uudecode_base64, [ +dnl /** +dnl * Test.java: used to test if java compiler works. +dnl */ +dnl public class Test +dnl { +dnl +dnl public static void +dnl main( String[] argv ) +dnl { +dnl System.exit (0); +dnl } +dnl +dnl } +cat << \EOF > Test.uue +begin-base64 644 Test.class +yv66vgADAC0AFQcAAgEABFRlc3QHAAQBABBqYXZhL2xhbmcvT2JqZWN0AQAE +bWFpbgEAFihbTGphdmEvbGFuZy9TdHJpbmc7KVYBAARDb2RlAQAPTGluZU51 +bWJlclRhYmxlDAAKAAsBAARleGl0AQAEKEkpVgoADQAJBwAOAQAQamF2YS9s +YW5nL1N5c3RlbQEABjxpbml0PgEAAygpVgwADwAQCgADABEBAApTb3VyY2VG +aWxlAQAJVGVzdC5qYXZhACEAAQADAAAAAAACAAkABQAGAAEABwAAACEAAQAB +AAAABQO4AAyxAAAAAQAIAAAACgACAAAACgAEAAsAAQAPABAAAQAHAAAAIQAB +AAEAAAAFKrcAErEAAAABAAgAAAAKAAIAAAAEAAQABAABABMAAAACABQ= +==== +EOF +if uudecode$EXEEXT Test.uue; then + ac_cv_prog_uudecode_base64=yes +else + echo "configure: __oline__: uudecode had trouble decoding base 64 file 'Test.uue'" >&AC_FD_CC + echo "configure: failed file was:" >&AC_FD_CC + cat Test.uue >&AC_FD_CC + ac_cv_prog_uudecode_base64=no +fi +rm -f Test.uue]) +fi +if test x$ac_cv_prog_uudecode_base64 != xyes; then + rm -f Test.class + AC_MSG_WARN([I have to compile Test.class from scratch]) + if test x$ac_cv_prog_javac_works = xno; then + AC_MSG_ERROR([Cannot compile java source. $JAVAC does not work properly]) + fi + if test x$ac_cv_prog_javac_works = x; then + AC_PROG_JAVAC + fi +fi +AC_CACHE_CHECK(if $JAVA works, ac_cv_prog_java_works, [ +JAVA_TEST=Test.java +CLASS_TEST=Test.class +TEST=Test +changequote(, )dnl +cat << \EOF > $JAVA_TEST +/* [#]line __oline__ "configure" */ +public class Test { +public static void main (String args[]) { + System.exit (0); +} } +EOF +changequote([, ])dnl +if test x$ac_cv_prog_uudecode_base64 != xyes; then + if AC_TRY_COMMAND("$JAVAC" $JAVACFLAGS $JAVA_TEST) && test -s $CLASS_TEST; then + : + else + echo "configure: failed program was:" >&AC_FD_CC + cat $JAVA_TEST >&AC_FD_CC + AC_MSG_ERROR(The Java compiler $JAVAC failed (see config.log, check the CLASSPATH?)) + fi +fi +if AC_TRY_COMMAND("$JAVA" $JAVAFLAGS $TEST) >/dev/null 2>&1; then + ac_cv_prog_java_works=yes +else + echo "configure: failed program was:" >&AC_FD_CC + cat $JAVA_TEST >&AC_FD_CC + AC_MSG_ERROR(The Java VM $JAVA failed (see config.log, check the CLASSPATH?)) +fi +rm -fr $JAVA_TEST $CLASS_TEST Test.uue +]) +AC_PROVIDE([$0])dnl +] +) diff --git a/packages/jpl/jpl/ac/ac_prog_javac.m4 b/packages/jpl/jpl/ac/ac_prog_javac.m4 new file mode 100644 index 000000000..8b3a09088 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_javac.m4 @@ -0,0 +1,25 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_javac.html +dnl +AC_DEFUN([AC_PROG_JAVAC],[ +AC_REQUIRE([AC_EXEEXT])dnl +if test "x$JAVAC" = x; then + if test "x$JAVAPREFIX" = x; then + AC_CHECK_PROGS(JAVAC, jikes$EXEEXT javac$EXEEXT gcj$EXEEXT guavac$EXEEXT) + else + AC_PATH_PROGS(JAVAC, jikes$EXEEXT javac$EXEEXT gcj$EXEEXT guavac$EXEEXT, , "$JAVAPREFIX") + fi +fi +test "x$JAVAC" = x && AC_MSG_ERROR([no acceptable Java compiler found in \$PATH]) +if test "$JAVAC" = "gcj$EXEEXT"; then + case "$JAVACFLAGS" in + *-C*) + ;; + *) + JAVACFLAGS="$JAVACFLAGS -C" + ;; + esac +fi +AC_PROG_JAVAC_WORKS +AC_PROVIDE([$0])dnl +]) diff --git a/packages/jpl/jpl/ac/ac_prog_javac_works.m4 b/packages/jpl/jpl/ac/ac_prog_javac_works.m4 new file mode 100644 index 000000000..706c31d85 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_javac_works.m4 @@ -0,0 +1,23 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_javac_works.html +dnl +AC_DEFUN([AC_PROG_JAVAC_WORKS],[ +AC_CACHE_CHECK([if $JAVAC works], ac_cv_prog_javac_works, [ +JAVA_TEST=Test.java +CLASS_TEST=Test.class +cat << \EOF > $JAVA_TEST +/* [#]line __oline__ "configure" */ +public class Test { +} +EOF +if AC_TRY_COMMAND("$JAVAC" $JAVACFLAGS $JAVA_TEST) >/dev/null 2>&1; then + ac_cv_prog_javac_works=yes +else + AC_MSG_ERROR([The Java compiler $JAVAC failed (see config.log, check the CLASSPATH?)]) + echo "configure: failed program was:" >&AC_FD_CC + cat $JAVA_TEST >&AC_FD_CC +fi +rm -f $JAVA_TEST $CLASS_TEST +]) +AC_PROVIDE([$0])dnl +]) diff --git a/packages/jpl/jpl/ac/ac_prog_javadoc.m4 b/packages/jpl/jpl/ac/ac_prog_javadoc.m4 new file mode 100644 index 000000000..f433ebb06 --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_javadoc.m4 @@ -0,0 +1,16 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_javadoc.html +dnl +AC_DEFUN([AC_PROG_JAVADOC],[ +AC_REQUIRE([AC_EXEEXT])dnl +if test "x$JAVADOC" = x; then + if test "x$JAVAPREFIX" = x; then + AC_CHECK_PROGS(JAVADOC, javadoc$EXEEXT) + else + AC_PATH_PROGS(JAVADOC, javadoc$EXEEXT, , "$JAVAPREFIX") + fi +fi +test "x$JAVADOC" = x && AC_MSG_ERROR([no acceptable javadoc generator found in \$PATH]) +AC_PROVIDE([$0])dnl +]) + diff --git a/packages/jpl/jpl/ac/ac_prog_javah.m4 b/packages/jpl/jpl/ac/ac_prog_javah.m4 new file mode 100644 index 000000000..4ee71f7bb --- /dev/null +++ b/packages/jpl/jpl/ac/ac_prog_javah.m4 @@ -0,0 +1,20 @@ +dnl Available from the GNU Autoconf Macro Archive at: +dnl http://www.gnu.org/software/ac-archive/htmldoc/ac_prog_javah.html +dnl +AC_DEFUN([AC_PROG_JAVAH],[ +AC_REQUIRE([AC_CANONICAL_SYSTEM])dnl +AC_REQUIRE([AC_PROG_CPP])dnl +AC_PATH_PROG(JAVAH,javah) +if test x"`eval 'echo $ac_cv_path_JAVAH'`" != x ; then + AC_TRY_CPP([#include ],,[ + ac_save_CPPFLAGS="$CPPFLAGS" +changequote(, )dnl + ac_dir=`echo $ac_cv_path_JAVAH | sed 's,\(.*\)/[^/]*/[^/]*$,\1/include,'` + ac_machdep=`echo $build_os | sed 's,[-0-9].*,,' | sed 's,cygwin,win32,'` +changequote([, ])dnl + CPPFLAGS="$ac_save_CPPFLAGS -I$ac_dir -I$ac_dir/$ac_machdep" + AC_TRY_CPP([#include ], + ac_save_CPPFLAGS="$CPPFLAGS", + AC_MSG_WARN([unable to include ])) + CPPFLAGS="$ac_save_CPPFLAGS"]) +fi]) diff --git a/packages/jpl/jpl/aclocal.m4 b/packages/jpl/jpl/aclocal.m4 new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/packages/jpl/jpl/aclocal.m4 @@ -0,0 +1 @@ + diff --git a/packages/jpl/jpl/config.guess b/packages/jpl/jpl/config.guess new file mode 100755 index 000000000..872b96a16 --- /dev/null +++ b/packages/jpl/jpl/config.guess @@ -0,0 +1,1537 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, +# 2011, 2012 Free Software Foundation, Inc. + +timestamp='2012-09-25' + +# This file 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 General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + + +# Originally written by Per Bothner. Please send patches (context +# diff format) to and include a ChangeLog +# entry. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ELF__ + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit ;; + *:Bitrig:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerpc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + exitcode=$? + trap '' 0 + exit $exitcode ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm*:riscos:*:*|arm*:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + s390x:SunOS:*:*) + echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + echo i386-pc-auroraux${UNAME_RELEASE} + exit ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + eval $set_cc_for_build + SUN_ARCH="i386" + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH="x86_64" + fi + fi + echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[4567]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + UNAME_PROCESSOR=`/usr/bin/uname -p` + case ${UNAME_PROCESSOR} in + amd64) + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + *:MINGW64*:*) + echo ${UNAME_MACHINE}-pc-mingw64 + exit ;; + *:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + i*:MSYS*:*) + echo ${UNAME_MACHINE}-pc-msys + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + *:Interix*:*) + case ${UNAME_MACHINE} in + x86) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + authenticamd | genuineintel | EM64T) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + IA64) + echo ia64-unknown-interix${UNAME_RELEASE} + exit ;; + esac ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + 8664:Windows_NT:*) + echo x86_64-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + aarch64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + aarch64_be:Linux:*:*) + UNAME_MACHINE=aarch64_be + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit ;; + arm*:Linux:*:*) + eval $set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + echo ${UNAME_MACHINE}-unknown-linux-gnu + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo ${UNAME_MACHINE}-unknown-linux-gnueabi + else + echo ${UNAME_MACHINE}-unknown-linux-gnueabihf + fi + fi + exit ;; + avr32*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + cris:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-gnu + exit ;; + crisv32:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-gnu + exit ;; + frv:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + hexagon:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + i*86:Linux:*:*) + LIBC=gnu + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #ifdef __dietlibc__ + LIBC=dietlibc + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` + echo "${UNAME_MACHINE}-pc-linux-${LIBC}" + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + mips:Linux:*:* | mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef ${UNAME_MACHINE} + #undef ${UNAME_MACHINE}el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=${UNAME_MACHINE}el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=${UNAME_MACHINE} + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } + ;; + or32:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + padre:Linux:*:*) + echo sparc-unknown-linux-gnu + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-gnu ;; + PA8*) echo hppa2.0-unknown-linux-gnu ;; + *) echo hppa-unknown-linux-gnu ;; + esac + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + tile*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-gnu + exit ;; + x86_64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + xtensa*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i586. + # Note: whatever this is, it MUST be the same as what config.sub + # prints for the "djgpp" host, or else GDB configury will decide that + # this is a cross-build. + echo i586-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + echo i586-pc-haiku + exit ;; + x86_64:Haiku:*:*) + echo x86_64-unknown-haiku + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + SX-7:SUPER-UX:*:*) + echo sx7-nec-superux${UNAME_RELEASE} + exit ;; + SX-8:SUPER-UX:*:*) + echo sx8-nec-superux${UNAME_RELEASE} + exit ;; + SX-8R:SUPER-UX:*:*) + echo sx8r-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + case $UNAME_PROCESSOR in + i386) + eval $set_cc_for_build + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + UNAME_PROCESSOR="x86_64" + fi + fi ;; + unknown) UNAME_PROCESSOR=powerpc ;; + esac + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NEO-?:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk${UNAME_RELEASE} + exit ;; + NSE-*:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; + i*86:AROS:*:*) + echo ${UNAME_MACHINE}-pc-aros + exit ;; + x86_64:VMkernel:*:*) + echo ${UNAME_MACHINE}-unknown-esx + exit ;; +esac + +eval $set_cc_for_build +cat >$dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix\n"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +# if !defined (ultrix) +# include +# if defined (BSD) +# if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +# else +# if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# endif +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# else + printf ("vax-dec-ultrix\n"); exit (0); +# endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + c34*) + echo c34-convex-bsd + exit ;; + c38*) + echo c38-convex-bsd + exit ;; + c4*) + echo c4-convex-bsd + exit ;; + esac +fi + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/packages/jpl/jpl/config.sub b/packages/jpl/jpl/config.sub new file mode 100755 index 000000000..bdda9e4a3 --- /dev/null +++ b/packages/jpl/jpl/config.sub @@ -0,0 +1,1786 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, +# 2011, 2012 Free Software Foundation, Inc. + +timestamp='2012-08-18' + +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file 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 General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + + +# Please send patches to . Submit a context +# diff and a properly formatted GNU ChangeLog entry. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ + linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | \ + kopensolaris*-gnu* | \ + storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + android-linux) + os=-linux-android + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis | -knuth | -cray | -microblaze) + os= + basic_machine=$1 + ;; + -bluegene*) + os=-cnk + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*178) + os=-lynxos178 + ;; + -lynx*5) + os=-lynxos5 + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | aarch64 | aarch64_be \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ + | be32 | be64 \ + | bfin \ + | c4x | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | epiphany \ + | fido | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ + | i370 | i860 | i960 | ia64 \ + | ip2k | iq2000 \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | maxq | mb | microblaze | mcore | mep | metag \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64octeon | mips64octeonel \ + | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | moxie \ + | mt \ + | msp430 \ + | nds32 | nds32le | nds32be \ + | nios | nios2 \ + | ns16k | ns32k \ + | open8 \ + | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pyramid \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | we32k \ + | x86 | xc16x | xstormy16 | xtensa \ + | z8k | z80) + basic_machine=$basic_machine-unknown + ;; + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | picochip) + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + ms1) + basic_machine=mt-unknown + ;; + + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + xgate) + basic_machine=$basic_machine-unknown + os=-none + ;; + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | aarch64-* | aarch64_be-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* | avr32-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | clipper-* | craynv-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* | iq2000-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64octeon-* | mips64octeonel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ + | msp430-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nios-* | nios2-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pyramid-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ + | tahoe-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tile*-* \ + | tron-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xc16x-* | xps100-* \ + | xstormy16-* | xtensa*-* \ + | ymp-* \ + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + abacus) + basic_machine=abacus-unknown + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aros) + basic_machine=i386-pc + os=-aros + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + blackfin) + basic_machine=bfin-unknown + os=-linux + ;; + blackfin-*) + basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=-cnk + ;; + c54x-*) + basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + cegcc) + basic_machine=arm-unknown + os=-cegcc + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown + os=-elf + ;; + crds | unos) + basic_machine=m68k-crds + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dicos) + basic_machine=i686-pc + os=-dicos + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m68knommu) + basic_machine=m68k-unknown + os=-linux + ;; + m68knommu-*) + basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + microblaze) + basic_machine=microblaze-xilinx + ;; + mingw64) + basic_machine=x86_64-pc + os=-mingw64 + ;; + mingw32) + basic_machine=i386-pc + os=-mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + os=-mingw32ce + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + msys) + basic_machine=i386-pc + os=-msys + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + nacl) + basic_machine=le32-unknown + os=-nacl + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + parisc) + basic_machine=hppa-unknown + os=-linux + ;; + parisc-*) + basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc | ppcbe) basic_machine=powerpc-unknown + ;; + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rdos) + basic_machine=i386-pc + os=-rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sde) + basic_machine=mipsisa32-sde + os=-elf + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sh5el) + basic_machine=sh5le-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tile*) + basic_machine=$basic_machine-unknown + os=-linux-gnu + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + z80-*-coff) + basic_machine=z80-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) + basic_machine=sh-unknown + ;; + sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -auroraux) + os=-auroraux + ;; + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ + | -sym* | -kopensolaris* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* | -aros* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -bitrig* | -openbsd* | -solidbsd* \ + | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ + | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* | -cegcc* \ + | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ + | -linux-newlib* | -linux-musl* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -os400*) + os=-os400 + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -tpf*) + os=-tpf + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -kaos*) + os=-kaos + ;; + -zvmoe) + os=-zvmoe + ;; + -dicos*) + os=-dicos + ;; + -nacl*) + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + score-*) + os=-elf + ;; + spu-*) + os=-elf + ;; + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + c4x-* | tic4x-*) + os=-coff + ;; + hexagon-*) + os=-elf + ;; + tic54x-*) + os=-coff + ;; + tic55x-*) + os=-coff + ;; + tic6x-*) + os=-coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + ;; + m68*-cisco) + os=-aout + ;; + mep-*) + os=-elf + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-haiku) + os=-haiku + ;; + *-ibm) + os=-aix + ;; + *-knuth) + os=-mmixware + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -cnk*|-aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -os400*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/packages/jpl/jpl/configure.in b/packages/jpl/jpl/configure.in new file mode 100644 index 000000000..b2bd5d133 --- /dev/null +++ b/packages/jpl/jpl/configure.in @@ -0,0 +1,158 @@ +dnl Process this file with autoconf to produce a configure script. + +m4_ifdef([HAS_TOP],[m4_ignore],[ AC_INIT(install-sh) +AC_PREREQ([2.50]) +AC_CONFIG_HEADER(config.h) +]) + +AC_SUBST(JAVA_HOME) +AC_SUBST(JAVACFLAGS) +AC_SUBST(JAVALIBS) +AC_SUBST(JUNIT) +AC_SUBST(JPLCFLAGS) +AC_SUBST(JPLLDFLAGS) +AC_SUBST(LIBJPL) +AC_SUBST(JAVA_PRELOAD) +AC_SUBST(CMDEXT) + +m4_ifdef([HAS_TOP],[m4_ignore],[ +m4_include([../ac_swi_c.m4]) + ]) + +CMDEXT=sh + +if test "x$JAVALIBS" = "x"; then + case "$PLARCH" in + *darwin*) + JAVALIBS="-Wl,-framework,JavaVM" + ;; + *powerpc-linux*) + JAVALIBS="-ljava -ljvm" + ;; + *win32*|*win64*) + JAVALIBS="-ljvm" + CMDEXT=bat + ;; + *) + JAVALIBS="-ljava -lverify -ljvm" + ;; + esac +fi + +case "$PLARCH" in + *win32*) + JPLLDFLAGS="$JPLLDFLAGS -Wl,--kill-at" + LIBJPL=jpl + ;; + *win64*) + LIBJPL=jpl + ;; + *) + LIBJPL=libjpl + ;; +esac + +dnl ================================================================ +dnl Java stuff +dnl ================================================================ + +AC_CANONICAL_HOST dnl needed to get $host_os + +dnl if test "x$JAVACFLAGS" = x; then +dnl JAVACFLAGS="-source 1.4 -target 1.4" +dnl fi + +m4_include([ac/ac_prog_java.m4]) +m4_include([ac/ac_prog_java_works.m4]) +m4_include([ac/ac_prog_javac.m4]) +m4_include([ac/ac_prog_javac_works.m4]) +m4_include([ac/ac_prog_javadoc.m4]) +m4_include([ac/ac_jni_include_dirs.m4]) +m4_include([ac/ac_prog_jar.m4]) + +java_abs_paths=no +AC_CHECKING(Java configuration) +if test -r /etc/java/java2.conf; then + AC_MSG_RESULT(Using /etc/java/java2.conf) + eval `grep '\(JAVA\|JRE\|JDK\|SDK\).*=' /etc/java/java2.conf | sed 's/ *= */=/'` + if test ! -z "$JAVA_BINDIR"; then + PATH="$PATH:$JAVA_BINDIR" + java_abs_paths=yes + fi +fi + +AC_PROG_JAVAC(javac) +AC_PROG_JAVA(java) +AC_PROG_JAR(jar) +AC_PROG_JAVADOC(javadoc) + +escape_space() +{ sed -e "s/Program Files/Program-SPACE-Files/g" -e "s/ (x86)/SPACEX86/g" +} + +unescape_space() +{ sed -e "s/-SPACE-/ /g" -e "s/SPACEX86/ (x86)/g" +} + +AC_JNI_INCLUDE_DIR +for d in $(echo $JNI_INCLUDE_DIRS | escape_space); do + JPLCFLAGS="$JPLCFLAGS -I'$d'" +done +JPLCFLAGS="$(echo $JPLCFLAGS | unescape_space)" + +for d in $(echo $JNI_CLIENT_DIRS | escape_space); do + JPLLDFLAGS="$JPLLDFLAGS -L'$d'" +done +JPLLDFLAGS="$(echo $JPLLDFLAGS | unescape_space)" + + case "$PLARCH" in + *darwin*) + ;; + **) + for d in $(echo $JNI_CLIENT_DIRS | escape_space); do + if test -f "$d/libjsig.$SO"; then + JAVALIBS="-ljsig $JAVALIBS" + JAVA_PRELOAD=$d/libjsig.$SO + break + fi + done +esac +JAVA_PRELOAD="$(echo $JAVA_PRELOAD | unescape_space)" + +if test "$java_abs_paths" = yes; then + JAVA_CC="$JAVA_BINDIR/$JAVA_CC" +fi + +AC_ARG_WITH(junit, [ --with-junit=PATH Specify location of the junit JAR file], + [case "$withval" in + yes) JUNIT=/usr/share/java/junit.jar + ;; + no) JUNIT="" + ;; + *) JUNIT="$withval" + ;; + esac + ], + [ if test "x$JUNIT" = "x" -a -r /usr/share/java/junit.jar; then + JUNIT=/usr/share/java/junit.jar + fi + ] + ) + +AC_CHECK_HEADERS(wchar.h) +AC_CHECK_SIZEOF(wchar_t, 4) +AC_CHECK_SIZEOF(void*, 4) +AC_CHECK_SIZEOF(long, 4) +AC_CHECK_SIZEOF(long long, 8) + +if test $i_am_cross_compiling = yes +then + #mingw: we know where things are + JPLCFLAGS="-I \"$yap_cv_java\"/include -I \"$yap_cv_java\"/include/win32" + JAVALIBS="-L \"$yap_cv_java\"/jre/bin/server -L \"$yap_cv_java\"/jre/bin/client -ljvm" +fi + + + +m4_ifdef([HAS_TOP],[m4_ignore], [AC_OUTPUT(Makefile src/java/Makefile)]) + diff --git a/packages/jpl/jpl/demo.pl b/packages/jpl/jpl/demo.pl new file mode 100644 index 000000000..52ab1196f --- /dev/null +++ b/packages/jpl/jpl/demo.pl @@ -0,0 +1,28 @@ +:- asserta(file_search_path(foreign, '.')). +:- asserta(file_search_path(jpl_examples, 'examples/prolog')). +:- asserta(file_search_path(jar, '.')). +:- asserta(file_search_path(library, '.')). + +:- use_module(library(jpl)). + + /******************************* + * DEMOS * + *******************************/ + +jpl_demo :- + absolute_file_name(jpl_examples(.), + [ file_type(directory), + access(read) + ], + ExampleDir), + atom_concat(ExampleDir, '/*.pl', Pattern), + expand_file_name(Pattern, Examples), + tag_basename(Examples, Entries), + menu('Select JPL example', Entries, Example), + consult(Example). + +tag_basename([], []). +tag_basename([H|T0], [H:B|T]) :- + file_base_name(H, B), + tag_basename(T0, T). + diff --git a/packages/jpl/jpl/docs/index.html b/packages/jpl/jpl/docs/index.html new file mode 100644 index 000000000..db2301a69 --- /dev/null +++ b/packages/jpl/jpl/docs/index.html @@ -0,0 +1,45 @@ + + + + + JPL: A bidirectional Prolog/Java interface + + +

JPL: A bidirectional Prolog/Java interface

+ +
+
+This version of the documentation is a quick and dirty collection of +the available documentation. It contains error, references to obsolete +constructs, limitations that have been removed, etc. We hope this situation +will improve soon. +
+
+ +

+JPL is a library using the SWI-Prolog foreign interface and the Java jni +interface providing a bidirectional interface between Java and Prolog +that can be used to embed Prolog in Java as well as for embedding Java +in Prolog. In both setups it provides a reentrant bidirectional interface. + +

+ +
+Paul Singleton
+Fred Dushin
+Jan Wielemaker +
+ + + diff --git a/packages/jpl/jpl/docs/installation.html b/packages/jpl/jpl/docs/installation.html new file mode 100644 index 000000000..9cb51ab86 --- /dev/null +++ b/packages/jpl/jpl/docs/installation.html @@ -0,0 +1,181 @@ + + + + + + + JPL 3.x installation + + +

+JPL 3.x installation

+
+First check that the prerequisites (see the home page) are satisfied +(you have SWI-Prolog 5.2.0 or later, a Java 2 SDK, and a compatible +operating +system). +

Unzip jpl.zip +somewhere +safe (maybe into the \pl +folder of your SWI-Prolog +installation): it creates a folder \jpl +which you should retain. +

+

Inspect your new \jpl +folder: it should contain +

+
jpl
 +--- examples
 |     +--- Exceptions
 |     +--- Exceptions2
 |     +--- Family
 |     +--- Test
 |     +--- Test2
 |     +--- Time
 |     +--- Zahed
 |     +--- (and maybe more...)
 |
 +--- docs  (HTML files in here are accessible via links from the home page)
 |
 +--- src
 |     +--- c
 |     |    +--- build.bat  (Windows script to recompile jpl.c to jpl.dll)
 |     |    +--- build.sh  (Linux script to recompile jpl.c to libjpl.so)
 |     +--- java
 |
 +--- jpl.dll  (a native library - for Windows in this case)
+ |
+ +--- jpl.jar  (a Java library)
+ |
+ +--- jpl.pl  (a Prolog library)
+ |
+ +--- README.html  (JPL's documentation "home page")
+
+
+Put the three library files (jpl.dll, jpl.jar +and jpl.pl) where +each +can be found: +
    +
  • jpl.dll must be +found +by the Windows kernel, +and can go in any folder on your PATH; +perhaps %SWI_HOME_DIR%\bin +or your Windows system folder
    • +
  • jpl.jar must be +found +by any Java VMs +(and compilers) used with JPL; +one possibility is to put it on your global CLASSPATH
    • +
  • jpl.pl is a Prolog +source +module, and must be found by any SWI-Prolog +engines used with JPL: +I suggest putting it in %SWI_HOME_DIR%\library +and then invoking make_library_index/1 +on that folder (see a SWI-Prolog +manual for details) so that the autoloader can find it.
    • +
+For SWI-Prolog to +initialise +(or make the first call) to JPL, +it is necessary that a folder containing the JVMlibrary +(jvm.dll) is on your PATH; +if you are using a recent Sun JRE, +look for a PATH entry of the form C:\jdk1.3.1_01\jre\bin\hotspot; +or C:\jdk1.3.1_01\jre\bin\client; +
+
+If your applications start in Java, and then call SWI-Prolog, +it is necessary that the SWI-Prolog +library libpl.dll +is in a folder on the PATH
+ 
+Try the Java example in +
examples/java/Versions
+or the Prolog example in +
examples/prolog/jpl_versions_demo.pl
+to confirm that all three libraries are installed and compatible.
+

Installation troubleshooting

+If the example programs don't run successfully, look carefully at any +error +messages; they typically indicate where the problem lies.  Then +check +the installation instruction s and prerequisites carefully. +
+  +
    +
  • If you get a message about
    • +
+
... jpl.dll ... Access is denied ...
+
then you may have lost execute +permission +on jpl.dll +(please consult local Windows expertise +if you don't know how to correct this).
+
    +
  • If jpl_examples/0 +complains that
    • +
+
The +dynamic link library jvm.dll could not be found in the specified path +
+ 
+
then you should locate jvm.dll within +the +Java runtime which you intend to use, and ensure that its directory is +within the PATH.
+
    +
  • if the Java examples (e.g. jpl\examples\Exception\run.bat) +complain that
    • +
+
The +name specified is not recognized as an internal or external command, +operable +program or batch file. +
+
+
  +
+then there is no Java executable java.exe +in any folder on your PATH: you should have a PATH entry such as C:\jdk1.3.1_01\bin;
+
    +
  • if the Java examples complain that
    • +
+
The +dynamic link library libpl.dll could not be found in the specified path
+
or
+
Exception +in thread "main" java.lang.UnsatisfiedLinkError: C:\paul\bin\jpl.dll: +Can't +find dependent libraries +
+
+
then there is no SWI-Prolog +library libpl.dll +in any folder on your PATH: you should have a PATH entry such as C:\Program +Files\pl\bin
+
+
+
+
Paul Singleton
+
+February 2004
+
+  + + diff --git a/packages/jpl/jpl/docs/java_api/getting_started.html b/packages/jpl/jpl/docs/java_api/getting_started.html new file mode 100644 index 000000000..d4b847f94 --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/getting_started.html @@ -0,0 +1,289 @@ + + + + + + + + Getting Started + + +
+

JPL 2.x +Getting Started

+
+
This section provides a tutorial +introduction to JPL +through its JPL 2.x Java API overview, +the +interface most programmers are likely to use.  +The source code described here can be found in the examples +directory of +the +JPL distribution.  Feel free to consult the source files and run +the +demonstration program as you read this section. +
+
+

Verifying the installation

+To confirm that JPL and SWI-Prolog are basically able to +work together, open a console window and go into this directory: +
+ 
jpl/examples/
+
+read the README.txt file, and run the various examples which it +describes.
+
+Each Java example will run as an application (i.e. each has a main() +method), exercises SWI-Prolog, and writes something to System.out +or System.err. +

If you see some plausible output, with no serious error messages, +then +all may be well. +

+

Creating a Prolog database in a text file

+To experiment with JPL, we'll first create a Prolog +database +in a text file.  We will eventually load this database into the +Prolog +engine through the JPL 2.x Java API overview. +

Type the following in a text editor and save the result in a file +called +test.pl +

+
child_of(joe, ralf).
+ child_of(mary, joe).
+ child_of(steve, joe). +

descendent_of(X, Y) :-
+     child_of(X, Y).
+ descendent_of(X, Y) :-
+     child_of(Z, Y),
+     descendent_of(X, Z).

+
+You may wish to load this database into an interactive Prolog session +to +experiment with the predicates in this database before experimenting +with +JPL. +

Initializing The Prolog engine

+Although the jpl.JPL class provides a number of methods for +initializing +the Prolog engine from within Java, their use is not usually necessary: +Prolog will be automatically initialised with default parameters +at the first attempt to use it. +

Consulting the Prolog database from its text file

+In an ordinary interactive Prolog session, we'd load the above Prolog +database +using the Prolog consult/1 predicate, +a built-in +predicate in standard Prolog.  Note, however, that as a Prolog +predicate, +"calling" consult/1 is just an example +of making +a Prolog query, and this is how we perform it with JPL. +

First we construct an instance of jpl.Query, whose name is consult +and whose arguments (just one) comprise the atom 'test.pl': +

+
Query q1 =
+     new Query(
+         +"consult",
+         new +Term[] +{new Atom("test.pl")}
+     );
+Then we call the query() method of this Query object, +which +returns a Boolean value indicating its success: +
System.out.println( "consult " + +(q1.query() +? "succeeded" : "failed"));
+At this point, this process may seem a bit long-winded; however, you +should +soon see that the classes are sufficiently general that they provide a +robust and powerful interface into the Prolog engine.  There is +also +considerable scope for writing "convenience" classes and methods, but +in +this introduction we deliberately employ the general, primitive +facilities +of the JPL 2.x Java API overview. +

Querying the Database

+Using the same technique, we can query the Prolog database about +inferences +it can make.  To ask whether the Prolog query child_of(joe,ralf)is +true, given the above Prolog database, for example, we write: +
Query q2 =
+     new Query(
+         +"child_of",
+         new +Term[] +{new Atom("joe"),new Atom("ralf")}
+     ); +

System.out.println(
+     "child_of(joe,ralf) is " + +
+     ( q2.query() ? "provable" : +"not +provable" )
+ );

+
+To take an example that requires a bit more work on the part of the +Prolog +engine, on the other hand, we can ask whether descendent_of(steve,ralf) +is true: +
Query q3 =
+     new Query(
+         +"descendent_of",
+         new +Term[] +{new Atom("steve"),new Atom("ralf")}
+     ); +

System.out.println(
+     "descendent_of(joe,ralf) is " ++
+     ( q3.query() ? "provable" : +"not +provable" )
+ );

+
+

+Querying with Variables

+A ground query is relatively straightforward; it is essentially +either provable or not, and there is typically no point in +backtracking.  +Once we use variables, however, things get +a bit more complicated. +

Using the jpl.Variable class, we can construct a non ground +query; +and using other methods of Query we can obtain a solution +in the form of a java.util.Hashtable.  If the +Query has one or more solutions, then its +Query.oneSolution() +method returns a Hashtable representing +the first solution, otherwise +it returns null: +

+
Variable X = new Variable(); +

Query q4 =
+     new Query(
+         +"descendent_of",
+         new +Term[] +{X,new Atom("ralf")}
+     );

+

java.util.Hashtable solution;

+

solution = q4.oneSolution(); +

+

System.out.println( "first solution of +descendent_of(X, +ralf)");
+ System.out.println( "X = " + solution.get(X));

+
+The HashTable contains bindings in the form of Terms, +each +of which is indexed by its corresponding Variable in the Query. +

+Finding all solutions

+The previous query finds only the first solution.  Often, however, +one wants all solutions, or at least more than just the first.  +The +Query +class also provides the allSolutions() method, which returns an +array of zero or more Hashtables, each of which represents a +given +solution. +

In this example we reuse the query q4, +which was reset to its initial state by the call of oneSolution(), +and instead call allSolutions(), +which +returns an array of solutions: +

+
java.util.Hashtable[] solutions = q4.allSolutions(); +

for ( int i=0 ; i<solutions.length ; i++ ) { +
+     System.out.println( "X = " + +solutions[i].get(X));
+ }

+
+Equivalently, one can obtain each solution by exploiting the Enumeration +interface, which the Query class implements.  In this +example, +we iteratively call hasMoreSolutions() and nextSolution() to +exhaustion: +
+ 
System.out.println( "each solution of descendent_of(X, ralf)");
+ 
while ( q4.hasMoreSolutions() ){
    solution = q4.nextSolution();
    System.out.println( "X = " + solution.get(X));
}
+
+In this final example, we reuse the previous variable X +with a new variable Y in a new +query +q5: +
Variable Y = new Variable(); +

Query q5 =
+     new Query(
+         +"descendent_of",
+         new +Term[] +{X,Y}
+     );

+

while ( q5.hasMoreSolutions() ){ +
+     solution = q5.nextSolution(); +
+     System.out.println( "X = " + +solution.get(X) ++ ", Y = " + solution.get(Y));
+ }

+
+The hasMoreSolutions method of the Query class returns +a +boolean, +indicating whether there are any solutions "left" in the query.  +If +the answer to this is 'yes', then the solution can be obtained in the +form +of a Hashtable by the nextSolution method. +
Note.  By calling hasMoreSolutions +you are actually making the query to the Prolog engine; the "answer" to +the query is cached in the Query class instance and returned +from nextSolution.
+

+Where to Go From Here

+This section provides a brief tutorial on getting started with the +High-Level +Interface.  You should read the JPL 2.x Java API overview +section for more information about using these +interfaces.  +Feel free to consult the JPL 3.x Java API reference +section +for detailed information about particular classes. +
+
+
+
+
December 2003 (revised)
+
+
+
+ + diff --git a/packages/jpl/jpl/docs/java_api/gotchas.html b/packages/jpl/jpl/docs/java_api/gotchas.html new file mode 100644 index 000000000..6f1f0bf8c --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/gotchas.html @@ -0,0 +1,45 @@ + + + + + + JPL 3.x Java-calls-Prolog gotchas + + +

+JPL 3.x Java API gotchas +

+
+

arg indexing

+
the Term[] args of +a Compound are indexed (like +all Java arrays) from zero, whereas in Prolog the args of a structure +are conventionally numbered from one.
+
+

representing @(null)
+

+
there is no jpl.JNull +class: instead, use new +JRef(null) to represent @(null) +(which itself represents Java's null).  +If you don't know what this all means, don't worry: it only affects +those writing hybrid Java+Prolog programs which call each other +nestedly.
+
+

all solutions of a Query with no solutions

+
Query.allSolutions() +now returns an empty array of Map +if the Query has no solutions +(in 1.x versions it inconsistently returned null).
+
+
+
+
Paul Singleton
+
+drafted Wednesday 4th February 2004
+
+
+ + diff --git a/packages/jpl/jpl/docs/java_api/high-level_interface.html b/packages/jpl/jpl/docs/java_api/high-level_interface.html new file mode 100644 index 000000000..2b13ee564 --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/high-level_interface.html @@ -0,0 +1,537 @@ + + + + + High-Level Interface + + + + + + + + + +

JPL 3.x +Java API overview
+

+
+

Table of Contents

+ +
+

Introduction

+

The JPL 3.0.1 Java-calls-Prolog API provides a set +of classes that hide almost all of the messy detail in the Low-Level +Interface.  It is less flexible than the Low-Level +Interface, but it also has less of a learning curve, and in many ways +is more natural and Prolog-like than the Low-Level Interface.

+

The Java package jpl contains all of the classes in this +interface.  None of the classes correspond with any of the data +types in the Prolog Foreign Language Interface (FLI).
+ 

+

The Class Hierarchy

+

The API consists of the following class hierarchy:

+
Term
 |
 +--- Variable
 |
 +--- Compound
 |      |
 |      +--- Atom
 |
 +--- Integer
 |
 +--- Float
 
Query
 
JPLException
 |
 +-- PrologException
+

Term is an abstract class: only its subclasses can be +instantiated.

+

Each instance of Query contains a Term (denoting the +goal which is to be proven), and much more besides.

+

Each instance of Compound has a (java.lang.String) name and +an array of (Term) arguments (it must have at least one).

+

Atom is a specialisation of Compound with zero +arguments.
+ 

+

Initializing +Prolog

+

The jpl.JPL class initializes the Prolog VM (e.g. +libpl.dll in Win32), if necessary, when the first Query +is activated, using default parameter values.  Before +initialization takes place, these default values can be read, and +altered.

+
public String[] getDefaultInitArgs();
public void setDefaultInitArgs(String[] args);
+

After initialization, the parameter values which were actually used +can be read.

+
public String[] getActualInitArgs();
+

(This method returns null if initialization has not +occurred, and thus it can be used as a test.)
+This allows Java +library classes to employ JPL without placing any +burden of initialization upon the applications which use them.  +It can also ensure that the Prolog VM is initialized only if and when +it is +needed.

+

Explicit initialization is supported as in JPL 1.0.1: +

+
public void init();
public void init( String args[] );
+

Java code which requires a Prolog VM to be initialized in a +particular way can check whether initialization has already occurred: +if not, it can specify parameters and force it to be attempted; if +so, it can retrieve and check the initialisation parameters actually +used, to determine whether the initialization meets its requirements. +
+ 
+This version of JPL +does not support reinitialization of a Prolog VM.

+

For details about the legal parameter values, see your local +Prolog documentation.  Most users will rely on automatic +initialization.
+ 

+

Creating Terms

+

The Term-based classes in the jpl package are best +thought of as a structured concrete syntax for Prolog terms: they do +not correspond to any particular terms within the Prolog engine; +rather, they are a means for constructing queries which can called +within Prolog, and they are also a means for representing (and +exploring) the results +of such calls.
+Term instances are never changed by any +activity within the Prolog engine: indeed; it doesn't know of their +existence.
+The Term class is +abstract, so it cannot be directly instantiated; to create a Term, +create an instance of one of its five subclasses.

+
Note. A Term in +the jpl packagee is not to be +confused with a term_t in +the jpl.fli package.  The +latter has an important internal role in +managing state in the Prolog stack; the former is just a data +structure in the Java heap.
+

Atoms

+

An Atom is a Compound with zero arguments.  To +create an Atom, pass a (String) name to its constructor:

+
Atom aristotle = new Atom("aristotle");
Atom alexander = new Atom("alexander");
+
Note.  Two Atoms by +the same name +are effectively identical.  Feel free to reuse Atom +instances when constructing compound Terms.
+ Note.  +The name in an Atom need not be lower case: it can be any +UTF-8 string (?).
+

The Atom class inherits Compound's name() +accessor to obtain the name of the Atom (it also inherits +Compound's arity() accessor, but this always returns +zero for an Atom).  Atom's +toString() method yields a +String form of the atom's name which is quoted, iff necessary, +according to Prolog source text syntax, and can thus be used when +constructing fragments of Prolog source text, e.g. new queries.
+

+

Variables

+

Variables have identifying +names, which must comply with conventional Prolog source text syntax.

+
Variable X = new Variable("X"); // a regular variable
+
Variable X = new Variable("_"); // an "anonymous" variable
+
Variable X = new Variable("_Y"); // a "dont-tell-me" variable, whose bindings we don't want to know
+

Integers

+

An Integer is a specialized Term that holds a Java long +value.  This class corresponds to the Prolog integer +type (SWI-Prolog integers are 32-bit for now, but we are looking ahead +and beyond...).

+
jpl.Integer i = new jpl.Integer(5);
+

Be careful to avoid confusion with java.lang.integer, e.g. +by always qualifying the class name as in the example above.

+

The jpl.Integer class has an intValue() accessor to +obtain the int value of an instance, and also longValue(), floatValue() and doubleValue() (just like +java.lang.Integer has).

+

Floats

+

A Float is a specialized Term that holds a Java +double value.  This class corresponds to the Prolog float +type (SWI-Prolog floats are 64-bit ISO/IEC), on which arithmetic +operations can be performed.

+
jpl.Float f = new jpl.Float(3.14159265);
+

As with integers, avoid confusion between jpl.Float and +java.lang.Float.

+

The jpl.Float class has a doubleValue() accessor to +obtain +the double value of an instance, and also a floatValue() accessor.

+

Compounds

+

A Compound is a Term that contains a name and a +sequence (array) of Term arguments, as reflected in this +class's constructor:

+
Compound teacher_of = new Compound(
 "teacher_of",
 new Term[] {
 new Atom("aristotle"),
 new Atom("alexander")
 }
 );
+

Note the use of Java's anonymous array syntax

+
new Term[] { ..., ... }
+

to specify the arguments (any quantity >= 1) of the Compound.
+
+In +this example, the Java variable teacher_of refers to a +Compound instance, which represents the Prolog term +teacher_of(aristotle,alexander).

+
Note. Care +should be taken in creating Compound Terms, especially +if Variable references are used.  For example, the +following construction:
+
Variable X = new Variable();
+Variable Y = new Variable();
+Compound father_of = new Compound( "teacher_of", new Term[]{X,Y});
+
corresponds with the Prolog term teacher_of(X,Y), +whereas
+
Variable X = new Variable();
+Compound father_of = new Compound( "teacher_of", new Term[]{X,X});
+
corresponds with the Prolog term teacher_of(X,X), +two terms that can resolve very differently depending on the Prolog +database.  The general rule of thumb should be, reuse Term + references that are or contain Variables only if you know +that that is what you mean.
+

To obtain the (String) name of a Compound, use the name() +accessor method.

+
public String name();
+

To obtain the arity of a Compound, use the arity() +accessor method.

+
public int arity();
+

To obtain an array of a Compound's arguments, use the args() +accessor method.

+
public Term[] args();
+

To obtain the ith argument of a compound (numbered from 1), +use the arg() accessor method (with an int parameter +value between 1 and Arity inclusive).

+
public Term arg( int i);
+

To obtain the ith argument of a compound (numbered from 0), +use the arg0() accessor method (with an int parameter +value between 0 and Arity-1 inclusive).

+
public Term arg0( int i);
+

Queries

+

A Query contains a Term, representing a Prolog goal: +

+
Term goal = new Compound( "teacher_of", new Term[]{new Atom("aristotle"),new Atom("alexander")});
Query q = new Query( goal );
+

The Query q in this example represents the Prolog +query +

+
?- teacher_of(aristotle,alexander).
+

The Util Class

+

The Util class provides various static utility methods for +managing JPL Terms.

+
Term termArrayToList( Term t[])
Term[] listToTermArray( Term t)
Term[] bindingsToTermArray( Hashtable bs)
+

Querying Prolog

+

To ask the Prolog engine a query via the High-Level Interface, one +first constructs a Query instance, as in the above example, +and then uses the java.util.Enumeration interface, which the +Query class implements, to obtain solutions (where a +"solution" is what is known in logic programming jargon as +a substitution, which is a collection of bindings, each +of which relates one of the Variables within the Query's +goal to a Term representation of the Prolog term to which the +corresponding Prolog variable was bound by the proof).

+
public interface Enumeration {
 public boolean hasMoreElements();
 public Object nextElement();
}
+

The hasMoreElements() method can be used to determine +whether +a Query has any (or any further) solutions.  In the above +example, the method call

+
q.hasMoreElements()
+

returns true if the Prolog query teaches(aristotle,alexander) +is provable, and false otherwise.  In this example, the +Prolog query is a ground term, so the "solution" to the +Query is merely a truth value, and is given by the +hasMoreElements() method.

+

Where a Query's goal contains Variables, on the +other hand, its execution yields a sequence of bindings of these +Variables to Terms.  The High-Level interface uses +a java.util.Hashtable to represent these bindings; the Objects +in the table are Terms, keyed (uniquely) by Variable +instances.

+

For example, to print all of Aristotle's pupils, i.e., all the +bindings of X which satisfy teaches(aristotle,X), one +could write

+
Variable X = new Variable();
Query q = new Query( "teaches", new Term[]{new Atom("aristotle"),X});
while ( q.hasMoreElements() ) {
 Hashtable binding = (Hashtable) q.nextElement();
 Term t = (Term) binding.get( X);
 System.out.println( t);
}
+
Note.  If a Query's +goal contains +no variables (i.e. it is "ground"), the Query. +nextElement() method will still return a Hashtable for +each solution, although each table will be empty.
+ Note.  +If a Query's goal contains more than one occurrence of some Variable, +then each  solution Hashtable will have +only one binding for that Variable.
+

For convenience, the Query class provides a +hasMoreSolutions() and nextSolution() method with the +following signatures:

+
public boolean hasMoreSolutions();
public Hashtable nextSolution();
+

Using the nextSolution() method avoids having to cast the +result of the nextElement() method to Hashtable.

+

Obtaining one Solution

+

Often, you'll just want just the first solution to a query.  +The Query class provides a method for this:

+
public Hashtable oneSolution();
+

If the Query has no solutions, this method returns null; +otherwise, a non-null return indicates success.  If the Query +is a ground query (i.e. contains no variables), the returned +Hashtable will be empty (i.e. will contain no bindings).

+

Obtaining all Solutions

+

You may want all solutions to a query.  The Query +class provides a method for this:

+
public Hashtable[] allSolutions();
+

The returned array will contain all the Query's solutions, +in +the order they were obtained (as with Prolog's findall/3, duplicates +are not removed).  If the Query has no solutions, this +method returns an empty array (N.B. not null as in JPL +1.0.1).

+

Discovering whether a query has any +solutions

+

Sometimes an application is interested only in whether or not a +query is provable, but not in any details of its possible +solutions.  +The Query class provides the hasSolution method for +this common special case:

+
public boolean hasSolution();
+

This method is equivalent to (but sometimes more efficient than) +calling oneSolution and asking whether the return value is +non-null (i.e. whether the query succeeded).

+

Terminating Queries

+

Queries terminate automatically when the hasMoreSolutions() +method returns false, and once a Query is +terminated, another can be started.  Unfortunately, the Prolog +engine is currently such that it can handle only one query at a +time.  As a result, it is not possible, in the High-Level +Interface, to ask two different Query objects whether they +have any solutions without first exhausting all of the solutions of +one.  Therefore, programmers must take care to ensure that +all solutions are exhausted before starting new queries.  This +has particular importance in multi-threaded contexts, but it can also +present difficulties even in single-threaded programs.  See the +Multi-Threaded Queries section +for a discussion of how to manage Queries in multi-threaded contexts. +

+

To terminate a Query before all of its solutions have been +exhausted, use the rewind() method:

+
public void rewind();
+

This method stops a Query, setting it back into a state +where +it can be restarted.  It also permits other queries to be +started.  Here is an example in which the first three solutions +to the Query are obtained:

+
Query query = // obtain Query somehow
for ( int i = 0; i < 3 && query.hasMoreSolutions(); ++i ){
 Hashtable solution = query.nextSolution();
 // process solution...
}
query.rewind();
+

You may call rewind() on an inactive Query without +ill-effect, and you should always call rewind if you have not +exhausted all solutions to a Query.

+

If you are using the query(), oneSolution(), or +allSolutions() methods, you need not worry about rewinding the +Query; it is done automatically for you.
+ 

+

Multi-Threaded Queries

+

The Prolog engine can only have one query open at a time.  +This presents difficulties for multi-threaded programs in which the +programmer has no control over when Queries are executed.  JPL +makes as much of the High-Level Interface thread-safe as it can.  +Unfortunately, the programmer must take responsibility in a limited +set of circumstances to ensure that all calls to the High-Level +Interface are thread safe.

+

It is worth noting that if the programmer confines use of Query +methods to hasSolution(), oneSolution(), and +allSolutions(), that subset of the Query interface is +thread-safe.  For many programmers, these methods suffice.  +However, if the hasMoreSolutions(), hasMoreElements(), +nextSolution(), nextElement(), or rewind() +methods are explicitly invoked, thread-safety is lost.  The +problem is that while the blocks of these programs are synchronized +so that in effect no two Query objects can invoke any of these +methods concurrently, there is nothing that prevents a Query +object in one thread from calling one of these methods, and another +Query object in a different thread from calling this same +method, or even another that could produce indeterminate results.

+

The Query class, however, does make synchronization around +these methods possible by providing a reference to the monitor object +that locks competing threads from executing critical code.  The +reference is obtained by the static method

+
public static Object lock();
+

Thus, programmers can wrap calls to these non-thread-safe methods in +synchronized blocks, using the lock object to prevent other threads +from entering any of these methods.  To write a thread-safe loop +to process all of a Query's solutions, for example, one might +write

+
Query query = // obtain Query
synchronized ( Query.lock() ){
 while ( query.hasMoreSolutions() ){
 Hashtable solution = query.nextSolution();
 // process solution...
 }
}
+


+Note that the query(), oneSolution(), and +allSolutions() methods effectively do the same as the above +code snippet, so there is no need to explicitly synchronized on the +Query's monitor object when these methods are called.
+  +

+

Exceptions

+

The JPL package provides fairly crude exception +handling.  The base class for all JPL Exceptions +is JPLException, which is a java.lang.RuntimeException +(and hence need not be declared), and which will be thrown in the +absence of any other kind of exception that can be thrown, usually as +the result of some programming error.  Converting the exception +to a java.lang.String should provide some descriptive +information about the reason for the error.  All other JPL +excpetion classes extend this class.  Currently there are two, +the QueryInProgressException class and the PrologException +class.

+

A QueryInProgressException is thrown when a Query is +opened while another is in progress; this exception can be caught in +multi-threaded situations, but a better strategy for managing +multi-threaded situations is discussed in the Multi-Threaded +Queries section.  If you obey the rules discussed in this +section, you should have no reason to catch this exception.

+

A PrologException is thrown either during execution of a +Prolog built-in predicate or by an explicit call, by Prolog +application code, of the Prolog predicate throw/1.

+

There is currently no means of gracefully handling exceptions +caused by malformed parameters (e.g., undefined predicates) passed +through the High-Level Interface to the Prolog engine (?).
+  +

+

Debugging

+

Each Term type (together with the Query class) +supports an implementation of toString() which returns a +more-or-less familiar Prolog textual representation of the Term +or Query.

+

Sometimes, however, this information is not sufficient, so we have +provided a method debugString() which provides a more verbose +and explicit representation, including the types (atom, integer etc) +of each term and subterm.

+

In general, Term and Query instances are represented +in the form (type data), where type is the name of the +type (e.g., Atom, Compound, Tuple, etc.), and +data is a representation of the contents of the Term.  +For example, if the Term is an Atom, the data is the +Atom's name.  The arguments of Compounds are +represented by comma-separated lists within square brackets ('[' +']').

+

Viewing the structure of a Term or Query can be +useful in determining whether an error lies on the Prolog or Java +side of your JPL applications.

+

Perhaps better still, Term implements (in a basic but +adequate way) the javax.swing.TreeModel interface, and its +display() method creates a JFrame containing a +browseable JTree representation of the term.
+ 

+

Version information

+

To obtain the current version of JPL you are using, +you may obtain a reference to the jpl.Version static instance +of the JPL class by calling the JPL.version() static +method.  This will return a jpl.Version structure, which +has the following final fields:

+
package jpl;
public class Version {
 public final int major;                // e.g. 2
 public final int minor;                // e.g. 0
 public final int patch;                // e.g. 2
 public final java.lang.String status;  // e.g. "alpha"
}
+

You may wish to use this class instance to obtain fine-grained +information about the current JPL version, e.g.

+
if ( JPL.version().major == 2 ) {
+

You may also simply call the version_string() static method +of +the jpl.JPL class.  This will return a java.lang.String +representation of the current JPL version.

+

The version string can be written to the standard output stream by +running the main() method of the jpl.JPL class.

+
linux% java jpl.JPL
JPL 2.0.2-alpha
+

What's Missing

+

The current implementation of the +High-Level Interface lacks support for modules, and for multiple +Prolog engines.
+ 
+ 

+
+

up   +prev  next  API

+ + diff --git a/packages/jpl/jpl/docs/java_api/index.html b/packages/jpl/jpl/docs/java_api/index.html new file mode 100644 index 000000000..531f094c0 --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/index.html @@ -0,0 +1,166 @@ + + + + + + + + + + + + JPL A Java Interface to Prolog + + + +
+
+

+
+ A Java Interface to Prolog

+
+ +

News

+ March 18, 2003 + + May 5, 1999 +
    +
  • JPL 1.0.1 released.  This release contains the following changes:
    • + +
      +
    • Fixed a bug with the representation of Tuples.  They are now + always binary terms, though generally structured as binary +trees.  The interface is the same, except we now require that Tuples +contain at least two elements.  (The single element constructor +has been removed, but I consider this a patch, not an interface change)
      • +
    • Added an ith() accessor to the Compound and Query classes. This is +used to obtain the ith element in the array of Terms in the Compound or Query.
      • +
    • Added a debugString() method to the Term and Query classes.  +This is used to obtain more detailed information about the structure of the + Term or Query.
      • +
    • Updated and fixed some of the documentation.
      • +
    • JPL is now released under the terms of the Gnu Library Public License, + not the Gnu General Public License.  All relevant files have been updated.
      • + +
    + +
+ See the Copyright and +License Information section for more information. +

Feb 25, 1999

+ +
    +
  • JPL 1.0.0 is out.  Check the download +section for information about how to retrieve it.  I hope most +of the core interfaces are frozen.
    • +
  • I am in need of Solaris testers!  I have access to a Solaris +box, but it has ancient and outdated compilers, libs, etc.  If anyone +gets this to compile on any platform other than Linux, please send me patches.
    • +
  • Eventually I'd like to work out some config scripts.  For now +you must config manually.  Sorry.
    • +
  • I have not even tried getting this to run under Windows.  Anyone +with more expertise (and patience) than I is welcome to give it a go!
    • + +
+ +

General Description

+ JPL is a set of Java classes and C functions providing an interface between + Java and Prolog.  JPL uses the Java Native Interface (JNI) to connect + to a Prolog engine through the Prolog Foreign Language Interface (FLI), +which is more or less in the process of being standardized in various implementations + of Prolog.  JPL is not a pure Java implementation of Prolog; it makes + extensive use of native implementations of Prolog on supported platforms.  + The current version of JPL only works with SWI-Prolog. +

Currently, JPL only supports the embedding of a Prolog engine within the +Java VM.  Future versions may support the embedding of a Java VM within +Prolog, so that, for example, one could take advantage of the rich class structure +of the Java environment from within Prolog.

+ +

JPL is designed in two layers, a low-level interface to the Prolog FLI + and a high-level Java interface for the Java programmer who is not concerned + with the details of the Prolog FLI.  The low-level interface is provided + for C programmers who may wish to port their C implementations which use +the FLI to Java with minimal fuss.

+ +

Requirements

+ JPL now requires SWI-Prolog version 3.1.0 or later, which is available +at the following URL: +
http://www.swi-prolog.org/
+ SWI-Prolog license information is available here: +
http://www.swi-prolog.org/license.html
+ You will also need a Java development environment.  Sun's Java website +is a good place to start: +
http://java.sun.com/
+JPL 2.0.2 was developed and tested on Windows NT4, and has not yet been compiled +on any non-Windows platform
+JPL1.0.1 was written and tested on Linux kernel 2.1.24.  It should compile + on any other UNIX system with a full suite of gnu tools. +

Copyright and License +Information

+ JPL is released under the terms of the Gnu Library Public License: +
Copyright (c) 2003 Paul Singleton.  All rights reserved. +
+Copyright (c) 1998 Fred Dushin.  All rights reserved. +

This library is free software; you can redistribute + it and/or modify it under the terms of the GNU Library Public License as +published by the Free Software Foundation; either version 2 of the License, +or (at your option) any later version.

+ +

This library 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 Library +Public License for more details.

+
+ This means, among other things, that you may use this software in + commercial products without being required to distribute your software under +the same licensing terms.  See the License for +more details. +

Documentation

+ The Documentation for JPL is organized into the following sections: +
    +
  1. Getting Started
    2. +
  2. The Low-Level Interface
    3. +
  3. The High-Level Interface
    4. +
  4. Gnu Public License
    5. +
  5. The JPL API
    6. + +
+ +

Download (this section is obsolete)

+ Gnu-zipped, UNIX compressed, and Zipped versions of the source distribution + are available at: +
http://blackcat.cat.syr.edu/~fadushin/software/jpl/download
+ You may be interested in viewing the ChangeLog. + +

The latest version of JPL is available by the World Wide Web at the following +URL:

+ +
http://blackcat.cat.syr.edu/~fadushin/software/jpl
+ Writing free software is only gratifying if you hear from users.  +Please feel free to contact the author, Fred Dushin, at the following address: + +
fadushin@top.cis.syr.edu
+ +
Happy Prologging.
+ +

+ These pages were created using Netscape + Communicator, 4.5 for Linux on the +PowerPC.  The +JPL logo was made by the Gimp.
+
+ + diff --git a/packages/jpl/jpl/docs/java_api/lgpl.html b/packages/jpl/jpl/docs/java_api/lgpl.html new file mode 100644 index 000000000..66df9cb27 --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/lgpl.html @@ -0,0 +1,471 @@ + + + + + + GNU Library General Public License - GNU Project - Free Software Foundation (FSF) + + + + +

+GNU Library General Public License

+[image of a Philosophical Gnu] +(jpeg 7k)(jpeg 141k)no +gifs due to patent problems +

+

+

+Table of Contents

+ + + +
+

+GNU +LIBRARY GENERAL PUBLIC LICENSE

+Version 2, June 1991 +
Copyright (C) 1991 Free Software Foundation, Inc.
+59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+
+[This is the first released version of the library GPL.  It is
+ numbered 2 because it goes with version 2 of the ordinary GPL.]
+ +

+Preamble

+The licenses for most software are designed to take away your freedom to +share and change it. By contrast, the GNU General Public Licenses are intended +to guarantee your freedom to share and change free software--to make sure +the software is free for all its users. +

This license, the Library General Public License, applies to some specially +designated Free Software Foundation software, and to any other libraries +whose authors decide to use it. You can use it for your libraries, too. +

When we speak of free software, we are referring to freedom, not price. +Our General Public Licenses are designed to make sure that you have the +freedom to distribute copies of free software (and charge for this service +if you wish), that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free programs; +and that you know you can do these things. +

To protect your rights, we need to make restrictions that forbid anyone +to deny you these rights or to ask you to surrender the rights. These restrictions +translate to certain responsibilities for you if you distribute copies +of the library, or if you modify it. +

For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source code. +If you link a program with the library, you must provide complete object +files to the recipients so that they can relink them with the library, +after making changes to the library and recompiling it. And you must show +them these terms so they know their rights. +

Our method of protecting your rights has two steps: (1) copyright the +library, and (2) offer you this license which gives you legal permission +to copy, distribute and/or modify the library. +

Also, for each distributor's protection, we want to make certain that +everyone understands that there is no warranty for this free library. If +the library is modified by someone else and passed on, we want its recipients +to know that what they have is not the original version, so that any problems +introduced by others will not reflect on the original authors' reputations. +

Finally, any free program is threatened constantly by software patents. +We wish to avoid the danger that companies distributing free software will +individually obtain patent licenses, thus in effect transforming the program +into proprietary software. To prevent this, we have made it clear that +any patent must be licensed for everyone's free use or not licensed at +all. +

Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain designated +libraries. This license is quite different from the ordinary one; be sure +to read it in full, and don't assume that anything in it is the same as +in the ordinary license. +

The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to +a program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, +in a textual and legal sense, the linked executable is a combined work, +a derivative of the original library, and the ordinary General Public License +treats it as such. +

Because of this blurred distinction, using the ordinary General Public +License for libraries did not effectively promote software sharing, because +most developers did not use the libraries. We concluded that weaker conditions +might promote sharing better. +

However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the libraries +themselves. This Library General Public License is intended to permit developers +of non-free programs to use free libraries, while preserving your freedom +as a user of such programs to change the free libraries that are incorporated +in them. (We have not seen how to achieve this as regards changes in header +files, but we have achieved it as regards changes in the actual functions +of the Library.) The hope is that this will lead to faster development +of free libraries. +

The precise terms and conditions for copying, distribution and modification +follow. Pay close attention to the difference between a "work based on +the library" and a "work that uses the library". The former contains code +derived from the library, while the latter only works together with the +library. +

Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. +

+TERMS +AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

+0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized party +saying it may be distributed under the terms of this Library General Public +License (also called "this License"). Each licensee is addressed as "you". +

A "library" means a collection of software functions and/or data prepared +so as to be conveniently linked with application programs (which use some +of those functions and data) to form executables. +

The "Library", below, refers to any such software library or work which +has been distributed under these terms. A "work based on the Library" means +either the Library or any derivative work under copyright law: that is +to say, a work containing the Library or a portion of it, either verbatim +or with modifications and/or translated straightforwardly into another +language. (Hereinafter, translation is included without limitation in the +term "modification".) +

"Source code" for a work means the preferred form of the work for making +modifications to it. For a library, complete source code means all the +source code for all modules it contains, plus any associated interface +definition files, plus the scripts used to control compilation and installation +of the library. +

Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of running +a program using the Library is not restricted, and output from such a program +is covered only if its contents constitute a work based on the Library +(independent of the use of the Library in a tool for writing it). Whether +that is true depends on what the Library does and what the program that +uses the Library does. +

1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate copyright +notice and disclaimer of warranty; keep intact all the notices that refer +to this License and to the absence of any warranty; and distribute a copy +of this License along with the Library. +

You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. +

2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and distribute +such modifications or work under the terms of Section 1 above, provided +that you also meet all of these conditions:  +

    +
  • +a) The modified work must itself be a software library.
    • + +
  • +b) You must cause the files modified to carry prominent notices +stating that you changed the files and the date of any change.
    • + +
  • +c) You must cause the whole of the work to be licensed at no charge +to all third parties under the terms of this License.
    • + +
  • +d) If a facility in the modified Library refers to a function or +a table of data to be supplied by an application program that uses the +facility, other than as an argument passed when the facility is invoked, +then you must make a good faith effort to ensure that, in the event an +application does not supply such function or table, the facility still +operates, and performs whatever part of its purpose remains meaningful. +(For example, a function in a library to compute square roots has a purpose +that is entirely well-defined independent of the application. Therefore, +Subsection 2d requires that any application-supplied function or table +used by this function must be optional: if the application does not supply +it, the square root function must still compute square roots.)
    • +
+These requirements apply to the modified work as a whole. If identifiable +sections of that work are not derived from the Library, and can be reasonably +considered independent and separate works in themselves, then this License, +and its terms, do not apply to those sections when you distribute them +as separate works. But when you distribute the same sections as part of +a whole which is a work based on the Library, the distribution of the whole +must be on the terms of this License, whose permissions for other licensees +extend to the entire whole, and thus to each and every part regardless +of who wrote it. +

Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to exercise +the right to control the distribution of derivative or collective works +based on the Library. +

In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of a +storage or distribution medium does not bring the other work under the +scope of this License. +

3. You may opt to apply the terms of the ordinary GNU General +Public License instead of this License to a given copy of the Library. +To do this, you must alter all the notices that refer to this License, +so that they refer to the ordinary GNU General Public License, version +2, instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in these +notices. +

Once this change is made in a given copy, it is irreversible for that +copy, so the ordinary GNU General Public License applies to all subsequent +copies and derivative works made from that copy. +

This option is useful when you wish to copy part of the code of the +Library into a program that is not a library. +

4. You may copy and distribute the Library (or a portion or derivative +of it, under Section 2) in object code or executable form under the terms +of Sections 1 and 2 above provided that you accompany it with the complete +corresponding machine-readable source code, which must be distributed under +the terms of Sections 1 and 2 above on a medium customarily used for software +interchange. +

If distribution of object code is made by offering access to copy from +a designated place, then offering equivalent access to copy the source +code from the same place satisfies the requirement to distribute the source +code, even though third parties are not compelled to copy the source along +with the object code. +

5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a work, +in isolation, is not a derivative work of the Library, and therefore falls +outside the scope of this License. +

However, linking a "work that uses the Library" with the Library creates +an executable that is a derivative of the Library (because it contains +portions of the Library), rather than a "work that uses the library". The +executable is therefore covered by this License. Section 6 states terms +for distribution of such executables. +

When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a derivative +work of the Library even though the source code is not. Whether this is +true is especially significant if the work can be linked without the Library, +or if the work is itself a library. The threshold for this to be true is +not precisely defined by law. +

If such an object file uses only numerical parameters, data structure +layouts and accessors, and small macros and small inline functions (ten +lines or less in length), then the use of the object file is unrestricted, +regardless of whether it is legally a derivative work. (Executables containing +this object code plus portions of the Library will still fall under Section +6.) +

Otherwise, if the work is a derivative of the Library, you may distribute +the object code for the work under the terms of Section 6. Any executables +containing that work also fall under Section 6, whether or not they are +linked directly with the Library itself. +

6. As an exception to the Sections above, you may also compile +or link a "work that uses the Library" with the Library to produce a work +containing portions of the Library, and distribute that work under terms +of your choice, provided that the terms permit modification of the work +for the customer's own use and reverse engineering for debugging such modifications. +

You must give prominent notice with each copy of the work that the Library +is used in it and that the Library and its use are covered by this License. +You must supply a copy of this License. If the work during execution displays +copyright notices, you must include the copyright notice for the Library +among them, as well as a reference directing the user to the copy of this +License. Also, you must do one of these things:  +

    +
  • +a) Accompany the work with the complete corresponding machine-readable +source code for the Library including whatever changes were used in the +work (which must be distributed under Sections 1 and 2 above); and, if +the work is an executable linked with the Library, with the complete machine-readable +"work that uses the Library", as object code and/or source code, so that +the user can modify the Library and then relink to produce a modified executable +containing the modified Library. (It is understood that the user who changes +the contents of definitions files in the Library will not necessarily be +able to recompile the application to use the modified definitions.)
    • + +
  • +b) Accompany the work with a written offer, valid for at least three +years, to give the same user the materials specified in Subsection 6a, +above, for a charge no more than the cost of performing this distribution.
    • + +
  • +c) If distribution of the work is made by offering access to copy +from a designated place, offer equivalent access to copy the above specified +materials from the same place.
    • + +
  • +d) Verify that the user has already received a copy of these materials +or that you have already sent this user a copy.
    • +
+For an executable, the required form of the "work that uses the Library" +must include any data and utility programs needed for reproducing the executable +from it. However, as a special exception, the source code distributed need +not include anything that is normally distributed (in either source or +binary form) with the major components (compiler, kernel, and so on) of +the operating system on which the executable runs, unless that component +itself accompanies the executable. +

It may happen that this requirement contradicts the license restrictions +of other proprietary libraries that do not normally accompany the operating +system. Such a contradiction means you cannot use both them and the Library +together in an executable that you distribute. +

7. You may place library facilities that are a work based on +the Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on the +Library and of the other library facilities is otherwise permitted, and +provided that you do these two things:  +

    +
  • +a) Accompany the combined library with a copy of the same work based +on the Library, uncombined with any other library facilities. This must +be distributed under the terms of the Sections above.
    • + +
  • +b) Give prominent notice with the combined library of the fact that +part of it is a work based on the Library, and explaining where to find +the accompanying uncombined form of the same work.
    • +
+8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense, link with, or distribute the Library +is void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under this +License will not have their licenses terminated so long as such parties +remain in full compliance. +

9. You are not required to accept this License, since you have +not signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are prohibited +by law if you do not accept this License. Therefore, by modifying or distributing +the Library (or any work based on the Library), you indicate your acceptance +of this License to do so, and all its terms and conditions for copying, +distributing or modifying the Library or works based on it. +

10. Each time you redistribute the Library (or any work based +on the Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further restrictions +on the recipients' exercise of the rights granted herein. You are not responsible +for enforcing compliance by third parties to this License. +

11. If, as a consequence of a court judgment or allegation of +patent infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or otherwise) +that contradict the conditions of this License, they do not excuse you +from the conditions of this License. If you cannot distribute so as to +satisfy simultaneously your obligations under this License and any other +pertinent obligations, then as a consequence you may not distribute the +Library at all. For example, if a patent license would not permit royalty-free +redistribution of the Library by all those who receive copies directly +or indirectly through you, then the only way you could satisfy both it +and this License would be to refrain entirely from distribution of the +Library. +

If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other circumstances. +

It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any such +claims; this section has the sole purpose of protecting the integrity of +the free software distribution system which is implemented by public license +practices. Many people have made generous contributions to the wide range +of software distributed through that system in reliance on consistent application +of that system; it is up to the author/donor to decide if he or she is +willing to distribute software through any other system and a licensee +cannot impose that choice. +

This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. +

12. If the distribution and/or use of the Library is restricted +in certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may +add an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus excluded. +In such case, this License incorporates the limitation as if written in +the body of this License. +

13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. Such +new versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. +

Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free Software +Foundation. If the Library does not specify a license version number, you +may choose any version ever published by the Free Software Foundation. +

14. If you wish to incorporate parts of the Library into other +free programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is copyrighted +by the Free Software Foundation, write to the Free Software Foundation; +we sometimes make exceptions for this. Our decision will be guided by the +two goals of preserving the free status of all derivatives of our free +software and of promoting the sharing and reuse of software generally. +

NO WARRANTY +

15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS +NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER +PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK +AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE +LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. +

16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO +IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR +DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT +LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED +BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY +OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF +THE POSSIBILITY OF SUCH DAMAGES. +

+END OF TERMS AND CONDITIONS

+ +

+How +to Apply These Terms to Your New Libraries

+If you develop a new library, and you want it to be of the greatest possible +use to the public, we recommend making it free software that everyone can +redistribute and change. You can do so by permitting redistribution under +these terms (or, alternatively, under the terms of the ordinary General +Public License). +

To apply these terms, attach the following notices to the library. It +is safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. +

one line to give the library's name and an idea of what it does.
+Copyright (C) year  name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+This library 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
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library 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.
+Also add information on how to contact you by electronic and paper mail. +

You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if necessary. +Here is a sample; alter the names: +

Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
+
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
+That's all there is to it!  +
Return to GNU's home page. +

FSF & GNU inquiries & questions to +gnu@gnu.org. +Other ways to contact the FSF. +

Comments on these web pages to +webmasters@www.gnu.org, +send other questions to +gnu@gnu.org. +

Copyright notice above. +
Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111, USA +

Updated:16 Feb 1998 tower +

+ + diff --git a/packages/jpl/jpl/docs/java_api/logo.jpg b/packages/jpl/jpl/docs/java_api/logo.jpg new file mode 100644 index 000000000..d997869fa Binary files /dev/null and b/packages/jpl/jpl/docs/java_api/logo.jpg differ diff --git a/packages/jpl/jpl/docs/java_api/low-level_interface.html b/packages/jpl/jpl/docs/java_api/low-level_interface.html new file mode 100644 index 000000000..87f08feb1 --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/low-level_interface.html @@ -0,0 +1,311 @@ + + + + + + + + Low-Level Interface + + + +
up     prev + +next     API +
+ +
+


JPL 2.0.2 Low-Level Interface

+ +


+
+

+Table of Contents

+ + + +
+

+Introduction

+[Note: if you just want to build hybrid Java+Prolog applications, you +probably don't need to know about this interface: see the High-Level +interface documentation] +
  +
The JPL Low-Level interface is implemented by the Java +package jpl.fli.  This package contains a set of classes that +mirror the data types in the SWI-Prolog Foreign Language Interface +(FLI), together with a class jpl.fli.Prolog, which contains static +variables and static native methods which reflect the constants and functions +in the FLI.  The package is designed to serve as a direct translation +of the Prolog FLI and is generally not intended for the average user.  +Its main purpose is to support the High-Level interface (q.v.), use of +which is preferable in most applications. +

This section provides a detailed description of the Low-Level interface +for the programmer who may wish to use it much as he or she would the FLI.  +As such, it presumes familiarity with the Prolog FLI.  This document +is not a tutorial on how to use the Prolog FLI; consult your local +Prolog documentation for how to use the FLI.  Programmers who wish +to use JPL without having to know any of the nitty gritty +details of the Low-Level interface may skip this section and read the High-Level +interface section.  For information about the SWI-Prolog FLI, see +your local SWI-Prolog documentation. +
  +
The JPL Low-Level interface is highly SWI-Prolog specific, +unlike the High-Level interface (which could potentially be implemented +on top of at least some other Prolog systems). +
  +

+Supported Data Types

+The Low-Level interface provides definitions for the following support +classes, which are essentially "holder" classes for the corresponding data +types in the FLI: +
    +
    LongHolder
+  |
+  +--- term_t
+  |
+  +--  atom_t
+  |
+  +--  functor_t
+  |
+  +--  qid_t
+  |
+  +--  fid_t
+
+PointerHolder
+  |
+  +--  predicate_t
+  |
+  +--  module_t
    +
+With the exception of predicate_t and module_t, these classes +hold Java long (signed 64-bit) values, corresponding to the C types in +the FLI by the same name (unsigned long values).  The module_t +and predicate_t classes also hold long values, but their values +are understood to be C pointers (void *). +
Note.  The fact that we are using +signed values to represent unsigned values should not be a problem, since +we are not using these values in arithmetic expressions that could cause +errors as a result of casts.  However, any SWI-Prolog implementation +that has a word size larger than 4 bytes is not guaranteed to work correctly +with this version of the Low-Level interface.
+The Low-Level interface also provides the following convenience classes +used to get information back to the JavaVM from Prolog: +
    +
  • +IntHolder
    • + +
  • +LongHolder
    • + +
  • +DoubleHolder
    • + +
  • +StringHolder
    • + +
  • +PointerHolder
    • +
+These classes are for use where a SWI-Prolog FLI function takes modifiable +(by reference) parameters. +

+jpl.fli.Prolog

+The class jpl.fli.Prolog contains a set of Java constant (static +final) and static native method declarations.  These declarations +more or less mirror those in the header files for the FLI (in SWI-Prolog, +SWI-Prolog.h), and can all be found in the C source file jpl_fli_Prolog.c. +

The general rule of thumb is as follows: +

    +
  • +All constant and function names (with a few notable exceptions) are the +same as those in the FLI, with the Prolog implementation-specific prefix +(in the case of SWI-Prolog, PL_) +removed.  For example, the constant PL_VARIABLE +in the FLI becomes just VARIABLE, +and the FLI function PL_new_term_ref() +becomes just new_term_ref().  +A notable exception is the throw +FLI function, which is renamed to _throw in the FLI;  throw +is a reserved word in Java.
    • + +
  • +All the constant values are the same in the Low-Level interface as they +are in the FLI.
    • + +
  • +The signatures of FLI functions (with a few notable exceptions) are preserved +in the Low-Level interface.  The Low-Level interface provides the +above types for this purpose.
    • + +
  • +Read parameters of the primitive Java types (e.g., int, float, +long, +etc.) are preserved.
    • + +
  • +Modify parameters of the primitive Java types take Holder classes (e.g., +IntHolder, +DoubleHolder, +LongHolder, +etc.) in which the values are written, instead of pointers to these types.
    • + +
  • +Parameters of other types that are read and read/modify parameters in the +FLI still take structures (e.g., jpl.fli.term_t) as arguments in +the Low-Level interface.  This preserves the signature of these methods +as much as possible.   A notable exception is the FLI strip_module +function, which takes a module_t * +as a parameter; in the Low-Level interface, the strip_module method +takes a module_t, not a Holder for this type.
    • +
+ +

+Using the Low-Level Interface

+Programmers already comfortable with the FLI should find no surprises.  +For example, to create a term_t in Java, one would do the same as +one would do in C: +
+
term_t t = Prolog.new_term_ref();
+
+The difference is that the Java method is now a static native method of +the Prolog class, so the syntax is slightly different than the corresponding +call in C.  Moreover, many of the same rules in the FLI apply to the +Low-Level interface, as well.  To make a term reference which contains +an atom, for example, one must first create the term_t, then an +atom_t, +and then put the atom into the term, as in the FLI: +
+
term_t term = Prolog.new_term_ref();
+atom_t atom = Prolog.new_atom( "foo" );
+Prolog.put_atom( term, atom );
+
+ +

+Caveats

+There is nothing special about the Low-Level interface; it is really just +a straight Java mapping of the FLI, and C programmers familiar with the +FLI should have little difficulty using it.  On the other hand, translating +the FLI to Java raises some peculiarities that should be mentioned. +

+Sequential Term References

+In the FLI, one can create sequential term references via the new_term_refs +function: +
+
term_t t0 = Prolog.new_term_refs( n);
+
+Subsequent references are obtained by t0+1, t0+2, etc.  +However, Java does not support operator overloading, so we can't obtain +subsequent term references by offsetting an initial reference.  We +can, however, obtain the value field of a term_t structure an compute +subsequent references off that value, as in, for example, t0.value+1, +t0.value+2, +etc. +

+Variable-length Argument Lists

+Some of the C functions in the FLI (e.g, PL_cons_functor()) take +variable-length arguments, function definitions whose argument lengths +are not known at compile time.  However, Java has no support for such +definitions; all method definitions must have determinable signatures at +compile time. +
  +
JPL 1.0.1 was designed and implemented before Java acquired anonymous +array syntax (in Java 1.1), which make it feasible to redefine a method +to take an array of arguments in place of a variable-length argument list.  +Since the SWI-Prolog FLI provides alternative functions that are equivalent +to these variable-length argument functions, JPL 1.0.1 implemented +these.  The High-Level interface exploits anonymous array syntax (e.g. +when constructing a Compound), but it has not been considered necessary +to revise the implementation of the Low-Level interface. +
  +

+Currently unsupported +FLI functions

+A number of SWI-Prolog FLI functions are currently unsupported, and not +needed by the High-Level interface, but could and might be supported in +future versions (preference is likely to be given to those which can sensibly +be made available to applications via the High-Level interface, or which +are necessary to support future extensions to the High-Level interface). +
  +

+Unsupportable FLI functions

+Some SWI-Prolog FLI functions seem inherently unsupportable within this +interface: +
+
+
+PL_signal()
+ +
+Java can't feasibly register a C function as s signal handler
+
+ +
+PL_action()
+ +
+problems with the argument types and qty; some of these actions may be +useful...
+
+ +
+PL_query()
+ +
+the ARGC, ARGV, MAX_INTEGER, MIN_INTEGER options are redundant
+ +
+QUERY_VERSION might be useful...
+ +
+SYMBOLFILE ?
+
+ +
+PL_dispatch_hook()
+PL_abort_hook()
+PL_abort_unhook()
+PL_on_halt()
+PL_agc_hook()
+ +
+these are of little value within Java (unless we can install Java methods?!)
+
+
+ +
+
up   prev    +next  API
+ + + diff --git a/packages/jpl/jpl/docs/java_api/philosophical-gnu-sm.jpg b/packages/jpl/jpl/docs/java_api/philosophical-gnu-sm.jpg new file mode 100644 index 000000000..e6a7a23b3 Binary files /dev/null and b/packages/jpl/jpl/docs/java_api/philosophical-gnu-sm.jpg differ diff --git a/packages/jpl/jpl/docs/java_api/programming_notes.html b/packages/jpl/jpl/docs/java_api/programming_notes.html new file mode 100644 index 000000000..99780ac63 --- /dev/null +++ b/packages/jpl/jpl/docs/java_api/programming_notes.html @@ -0,0 +1,135 @@ + + + + + + + + Programming Notes + + + +
up     prev    +next     API +
+ +
+


Programming Notes

+ +


+
+
+
+
+
+
+

This section provides a description of some of the nitty-gritty involved +in getting the high-level interface to work.  It presumes extensive +familiarity with the High-Level interface, in addition to the Low-Level +Interface and the Prolog Foreign Language Interface (FLI). +

+Overview

+The High-Level Interface provides, in essence, a set of Java data structures +for invoking queries on a Prolog engine.  By itself, the High-Level +interface makes no direct calls to the Prolog Abstract Machine (AM).  +Instead, the High-Level interface rests entirely on top of the Low-LevelInterface, +a Java implementation of the FLI.  The Low-Level interface is more +or less in 1-1 correspondence with the FLI (barring methods that do not +make sense in the Java environment). +

The following describes a typical execution of a Prolog query using +the interfaces described in the jpl.Query class.  Assume the High-Level +Interface programmer (hereafter, just 'the programmer') has constructed +a jpl.Term structure (assume, for simplicity, that the programmer is invoking +a predicate of arity 1), and is about to use the Query class to make a +query using the hasMoreSolutions/nextSolution protocol.  Roughly the +following sequence of events occurs. +

    +
  1. +The jpl.Term is converted to a jpl.fli.term_t
    2. + +
  2. +A call to the Prolog AM is opened using the Low-Level Interface Prolog.open_query +method with the predicate name and term_t just created
    3. + +
  3. +For any jpl.Variable occurrence (i.e., instance) in the original +jpl.Term +given to the Query, convert the term_ts that are bound to +those variables o jpl.Terms, and construct a +Hashtable of +these Terms, indexed by the Variables in the Query.
    4. + +
  4. +Close the query using the Low-Level Interface Prolog.close_query +method if there are no more solutions.  Otherwise, keep the query +open for subsequent calls to hasMoreSolutions.
    5. +
+Significantly more bookeeping is required to prevent the programmer from +opening a query while another is open, maintaining state about the status +of the query, and so forth, but the above gives a rough approximation of +what occurs in typical "successful" calls to the Prolog AM.  The remainder +of this section describes these steps in some detail. +

+Translating Terms to term_ts

+Translating jpl.Terms to jpl.fli.term_ts is relatively straightforward.  +Each Term subclass knows more or less how to convert itself to a +term_t via its pack method, and the top-level Term static +method terms_to_term_ts takes an array of Terms and performs +the conversion for the Query.  The following features of the +FLI, however, help explain the perhaps mysterious signature of pack. +
    +
  • +The Prolog FLI requires that term_t references first be created, +and then data of an appropriate type be "put" into the term_t reference +using one of the FLI _put functions.  For example, to create +an atom in the FLI, one first creates a term_t, and then "puts" +an atom_t into the term_t.
    • + +


        +term_t t = PL_new_term_ref(); +
        atom_t +a = PL_new_atom( "a" ); +
        PL_put_atom( +t, a ); +

    Translating a Term to a term_t requires mimicking this behavior. +

  • +In the case of Compound Terms,
    • + +
  • +A term_t in the Prolog FLI is, literally, an unsigned long value.  +It is essentially an index into the Prolog AM.  A sequence of term_ts +is a set of consecutive long values, typically created via the FLI +C funtion PL_new_term_refs().  In order to construct a compound +term_t, in the FLI, one must create such a sequence of term_ts +(as many as the arity of the compound), and then use the various FLI _put +functions to put terms into the term_ts that have just been created.
    • + +
     
+ +

+Computing Substitutions

+ +


Translating term_ts to Terms +

+Terms

+A jpl.Term structure holds, as an element, a jpl.fli.term_t +structure, which itself is a class which holds a long value.  This +long value is in fact a pointer (though not a C pointer) to Prolog term +in the Prolog Abstract Machine (AM).  Unfortunately, these low-level +values are not really valid throughout the life of the jpl.Term.  +Indeed, they are only valid pointers into the Prolog AM during the execution +of a Prolog query.  They must, therefore, be treated with exceptional +caution, and are consequently kept well-hidden from the user of the High-Level +Interface. +
  +
  +
  +
  +
+
up   +prev     +next  +API
+ + + diff --git a/packages/jpl/jpl/docs/objectives.html b/packages/jpl/jpl/docs/objectives.html new file mode 100644 index 000000000..7cdd54329 --- /dev/null +++ b/packages/jpl/jpl/docs/objectives.html @@ -0,0 +1,42 @@ + + + + JPL 3.x objectives + + + +

JPL 3.x Objectives

+
+
    +
  • enable Prolog applications to exploit any Java classes, instances, +methods etc. (without requiring any wrappers, metadata etc. to be set +up first)
    • +
  • enable Java applications to manipulate any Standard Prolog libraries, +predicates, etc. (without requiring any wrappers, metadata etc. to be +set up first)
    • +
  • enable hybrid Prolog+Java applications to be designed and +implemented so as to take best advantage of both language systems, and +to be testable, debuggable, maintainable etc.
    • +
  • minimum impact deployability: +runtime support for Prolog+Java apps must be a position-independent, +self-sufficient filestore tree, requiring no changes to registries, +system libraries, system configuration files etc.
    +
    • +
  • minimum dependency deployability: +as with JVMs, the Prolog+Java runtime support must depend upon nothing +which cannot be taken for granted in healthy OS installations
    • +
  • minimum vulnerability deployability: +the Prolog+Java runtime support must be immune to legitimate variations +in its environment (PATH settings, other applications and libraries +including other Prolog+Java apps, etc.)
    • +
  • (to be developed...)
    +
    • +
+
+
Paul Singleton
+
drafted 19th February 2004
+
+ + diff --git a/packages/jpl/jpl/docs/prolog_api/api.html b/packages/jpl/jpl/docs/prolog_api/api.html new file mode 100644 index 000000000..5ea3b2df3 --- /dev/null +++ b/packages/jpl/jpl/docs/prolog_api/api.html @@ -0,0 +1,382 @@ + + + + + api + + + + + + + +

JPL 3.x Prolog API +reference

+
+
+
jpl_new( +ClassOrType, ++Params, -Result)
+
unifies Result with a JPL reference to +a new instance of ClassOrType, constructed with Params,  +e.g. jpl_new('javax.swing.JFrame', ['JPL demo'], F).  +There are many other ways to call this predicate: see BlahBlah.
+
+
+
jpl_call( +Object, ++Method, +Params, -Result)
+
unifies Result with a JPL reference to +(or value of) the result of calling the named method of Object +with Params, e.g. jpl_call(F, setVisible, [@(true)], +_).  There are many other ways to call this predicate: see BlahBlah.
+
+
+
jpl_get( +Object, ++Field, -Value)
+
unifies Value to the value of, or a reference to, the +named field of Object.  There are many other ways to call this +predicate: see BlahBlah..
+
+
+
jpl_set( +Object, ++Field, +Value)
+
sets the named field of Object to Value +(a JPL +reference or value).  There are many other ways to call this +predicate: see BlahBlah..
+
+
+
+


+Java inspection

+
+
jpl_class_to_classname( + +Class, -Classname)
+
Class must be a JPL reference to +a Java class object (i.e. an instance of java.lang.Class); Classname +is its canonical dotted name, e.g. 'java.util.Date'.
+ 
+
jpl_class_to_type( +Class, +-Type)
+
Class must be a JPL reference to +a Java class object (i.e. an instance of java.lang.Class); Type +is its JPL +type, e.g. class([java,util],['Date']) +or array(double).
+ 
+
jpl_classname_to_class( + +Classname, -Class)
+
Classname must be a canonical dotted name (an atom) +of a +Java class, e.g. 'java.util.Date'; Class is a + JPL +reference to a corresponding Java class object (i.e. an instance of +java.lang.Class).
+ 
+
jpl_classname_to_type( + +Classname, -Type)
+
Classname must be a canonical dotted name (an atom) +of a Java class, e.g. 'java.util.Date'; Type +is its JPL +type, e.g. class([java,util],['Date']).
+ 
+
jpl_datum_to_type( +Datum, +-Type)
+
Datum must be a valid JPL +representation of some Java object or value e.g. 3, fred, + @(false); Type is its JPL type, e.g. char_byte, + class([java,lang],['String']), boolean.
+ 
+
jpl_false( -Datum)
+
Datum is the JPL +representation of the Java boolean value false, i.e. @(false).
+ 
+
jpl_is_class( ?Term) +
+
Term is a JPL reference to +a Java class object, i.e. to an instance of java.lang.Class. No further +instantiation of Term will take place; if it is not ground, +this predicate fails.
+ 
+
jpl_is_false( ?Term) +
+
Term is the JPL +representation of the Java boolean value false. No further instantiation of Term +will take place; if it is not ground, this predicate fails.
+ 
+
jpl_is_null( ?Term)
+
Term is a JPL +representation of the Java boolean value null. No further instantiation of Term +will take place; if it is not ground, this predicate fails.
+ 
+
jpl_is_object( ?Term) +
+
Term is a JPL reference to +a Java object. No further instantiation of Term will take +place; if it is not ground, this predicate fails.
+ 
+
jpl_is_object_type( ?Term) +
+
Term is a JPL class or +array type (but not null, void, or one of +the primitive types).  No further instantiation of Term +will take place; if it is not ground, this predicate fails.
+
+
+
 jpl_is_ref( ?Term) +
+
Term is a JPL class or +array type, or is null (i.e. the JPL type of +Java's null reference) (but not void or one of the +primitive types).  No further instantiation of Term +will take place; if it is not ground, this predicate fails.
+
+
+
 jpl_is_true( ?Term) +
+
Term is the JPL +representation of the Java boolean value true.  No further +instantiation of Term will take place; if it is not ground, +this predicate fails.
+ 
+
jpl_is_type( ?Term)
+
Term is a JPL type, e.g. char_byte, + float, array(int).  No further +instantiation of Term will take place; if it not ground, +this predicate fails.
+ 
+
jpl_is_void( ?Term)
+
Term is the JPL +representation of the (notional but convenient) Java value void, i.e. @(void).  +No further instantiation of Term will take place; if it not +ground, this predicate fails.
+ 
+
jpl_null( -Datum)
+
Datum is the JPL +representation of the Java null reference null.
+ 
+
jpl_object_to_class( +Object, +-Class)
+
Object is a JPL reference to +a Java object; Class is a JPL reference to +a Java class object (an instance of java.lang.Class) +which represents Object's class.
+ 
+
jpl_object_to_type( +Object, +-Type)
+
Object is a JPL reference to +a Java object; Type is its JPL type, e.g. array(boolean), + class([javax,sql],['Timestamp']).
+ 
+
jpl_primitive_type( -Type) +
+
Type is one of the JPL primitive +types boolean, char, byte, short, + int, long, float, double.
+ 
+
jpl_ref_to_type( +Ref, +-Type)
+
Ref is a JPL reference to +a Java object; Type is the JPL type of Object, +e.g. array(boolean), class([javax,sql],['Timestamp']).
+ 
+
jpl_true( -Datum)
+
Datum is the JPL +representation of the Java boolean value true.
+ 
+
jpl_type_to_class( +Type, +-Class)
+
Type is a JPL class (or +array) type, e.g. class([javax,sql],['Timestamp']) or array(boolean); + Class is a JPL reference to +a Java class object (an instance of java.lang.Class) +which corresponds to Type.
+ 
+
jpl_type_to_classname( + +Type, -Classname)
+
Type is a JPL class (or +array) type, e.g. class([javax,sql],['Timestamp']) or array(boolean); + Classname is its canonical dotted name (an atom).
+
+
+
 jpl_void( -Datum) +
+
Datum is the JPL +representation of the (notional but convenient) Java value void, i.e. @(void).
+
+
+


+Utilities

+
+
 jpl_array_to_length( + +Array, +-Length)
+
Array is a JPL reference to +a Java array;  Length is its length (an integer).
+
+
+
 jpl_array_to_list( +Array, +-ListOfDatums)
+
Array is a JPL reference to +a Java array (of any base type); ListOfDatums is a (Prolog) +list of JPL +references to, or values of, its respective elements.
+ 
+
jpl_datums_to_array( +ListOfDatums, +-Array) 
+
ListOfDatums is a (Prolog) list of JPL references +or values; Array is a JPL reference to +a Java array of corresponding objects or values.  The base type of + Array is the most specific Java type of which each +member of ListOfDatums is (directly or indirectly) an +instance. If there is no such type, this predicate fails. Values of +Java primitive types are not automatically "boxed". Lists which are +mixtures of numbers, booleans and object references cannot be converted +to Java arrays with this predicate.
+
+
+
 jpl_enumeration_element( + +Enumeration, -Element) 
+
Enumeration is a JPL reference to +a Java object whose class implements the java.util.Enumeration interface; Element +is an element of Enumeration.  This predicate can +generate each element of an enumeration.
+
+
+
jpl_enumeration_to_list( + +Enumeration, -ListOfElement)
+
Enumeration is a JPL reference to +a Java object whose class implements the java.util.Enumeration +interface;  ListOfElement is a list of JPL references +to each element of Enumeration.
+
+
+
 jpl_hashtable_pair( + +Hashtable, +-KeyValuePair)
+
Hashtable is a JPL reference to +a Java hashtable object (an instance of java.util.Hashtable); KeyValuePair +is a -/2 compound term whose first arg is a key (atom or +ref) from Hashtable, and whose second arg is its +corresponding value (atom or ref), e.g.fred-@'J#0008127852'.
+ 
+
jpl_iterator_element( +Iterator, +-Element)
+
Iterator is a JPL reference to +a Java object whose class implements the java.util.Iterator interface; Element +is a JPL +reference to one of its elements.  This predicate can generate all +elements.
+ 
+
jpl_list_to_array( +ListOfDatum, +-Array)
+
This is a synonym for jpl_datums_to_array/2, in case +you forget that JPL +values and references are called "datums".
+ 
+
jpl_map_element( +Map, +-KeyValuePair)
+
Map is a JPL reference to +a Java object whose class implements the java.util.Map interface; KeyValuePair +is a -/2 compound term whose first arg is a key (atom or +ref) from Map, and whose second arg is its corresponding +value (atom or ref), e.g. -(fred,@'J#0008127852'), or fred-@'J#0008127852' +using conventional operator definitions.
+ 
+
jpl_set_element( +Set, +-Element)
+
Set is a JPL reference to +a Java object whose class implements the java.util.Set interface; Element +is a JPL +reference to an object (or null) within Set.  This +predicate can generate all elements of Set
+
+


+Miscellaneous

+
+
jpl_c_lib_version( -Version) +
+
unifies Version to an atom (e.g. '3.0.1-alpha') +whose name is the version identifier of the 'C' library which JPL is +using.
+
+
+
jpl_c_lib_version( -Major, + -Minor, -Patch, -Status)
+
unifies Major, Minor, Patch and Status +to the corresponding components (e.g. 3, 0, 1 +and alpha) of the version identifier of the 'C' library which +JPL is using.
+ 
+
+
+
Paul Singleton
+
drafted 18th February 2004
+
+ + diff --git a/packages/jpl/jpl/docs/prolog_api/gotchas.html b/packages/jpl/jpl/docs/prolog_api/gotchas.html new file mode 100644 index 000000000..a1564316c --- /dev/null +++ b/packages/jpl/jpl/docs/prolog_api/gotchas.html @@ -0,0 +1,40 @@ + + + + + + JPL 3.x Prolog-calls-Java gotchas + + +

+JPL 3.x Prolog API gotchas +

+
+

calling methods with no parameters +

+
you must pass an empty parameter list when calling Java +methods which take no parameters, e.g.
+ 
jpl_call('java.lang.System', gc, [], _)
+
+

calling void methods +

+
you must accept an @(void) result when calling void Java +methods, e.g. either
+ 
jpl_call('java.lang.System', gc, [], @(void))
+which explicitly matches the expected result, or
+ 
jpl_call('java.lang.System', gc, [], _)
+which uses an anonymous variable to ignore the result.
+
+

(more to come...)
+

+
+
+
Paul Singleton
+
+drafted Wednesday 4th February 2004
+
+
+ + diff --git a/packages/jpl/jpl/docs/prolog_api/overview.html b/packages/jpl/jpl/docs/prolog_api/overview.html new file mode 100644 index 000000000..c71613140 --- /dev/null +++ b/packages/jpl/jpl/docs/prolog_api/overview.html @@ -0,0 +1,973 @@ + + + + + + + A SWI-Prolog to Java interface + + +

JPL 3.x Prolog API +overview

+
+ +
+

Introduction

+This is an overview of +an interface which allows SWI-Prolog programs to dynamically create and +manipulate Java objects. +

Here are some significant features of +the interface and its implementation:

+
    +
+
    +
  • it is completely dynamic: no +precompilation is required to manipulate any Java classes which can be +found at run time, and any objects which can be instantiated from them
    +
    • +
+ +
    +
  • it is interoperable with JPL's Java API +(which has evolved from Fred Dushin's JPL +1.0.1)
    • +
+ +
    +
  • it requires a Java 2 JVM and class +libraries (although it doesn't depend on any Java 2-specific +facilities, and originally was developed for use with both 1.1 and 1.2 +JVMs, I haven't tested it with 1.1 recently, and don't support this)
    • +
+
    +
  • it exploits the Invocation API +of the Java Native Interface: this is a mandatory feature of +any compliant +JVM (even the now defunct "Microsoft Virtual Machine" supported JNI, +although they seemed to want to keep that a secret :-)
    • +
+
    +
  • it is implemented with a fair +amount of +Prolog code in one module (jpl.pl)  +(which I believe to be ISO Standard Prolog compliant +and portable) and a SWI-Prolog-specific foreign library (jpl.dll for Windows), implemented +in ANSI C but making a lot of use of the SWI-Prolog Foreign +Language Interface
    • +
+
    +
  • the foreign-language part has so +far been tested only under Windows NT4, but is believed to be readily +portable to SWI-Prolog +on other platforms
    • +
+
    +
  • as far as is feasible, Java data +values and +object references are represented within Prolog canonically and without +loss +of information (minor exceptions: Java float and double values are both converted to +Prolog float values; Java byte, char, short, int and long values are all converted to +Prolog integer values; the +type distinctions which are lost are normally of no significance)
    +
    • +
+
    +
  • references within Prolog to Java +objects:
    • +
      +
    • should be treated as opaque +handles
      • +
    • are canonical (two references +are ==/2 +equal if-and-only-if they refer to the same +object within the JVM)
      • +
    • are represented as structures +containing +a distinctive atom so as to exploit SWI-Prolog's atom garbage +collection: when an object reference is garbage-collected in Prolog, +the JVM garbage collector +is informed, so there is sound and complete overall garbage collection +of +Java objects within the combined Prolog+Java system
      • +
    +
+
    +
  • Java class methods can be called +by name: JPL invisibly fetches (and +caches) essential +details of method invocation, exploiting Java Reflection +facilities
    • +
+
    +
  • the API is similar to that of +XPCE: the +four main interface calls are jsp_new, jsp_call, jsp_set and jsp_get (there is no jsp_free, +since Java's garbage collection +is extended transparently into Prolog)
    • +
+
    +
  • jsp_call resolves +overloaded methods automatically and dynamically, inferring the types +of the call's actual parameters, +and identifying the most specific of the applicable method +implementations +(similarly, jsp_new resolves overloaded constructors)
    • +
+
    +
  • Prolog code which uses the API +calls is +responsible for passing suitably-typed values and references, since the +JNI +doesn't perform complete dynamic type-checking, and nor currently does JPL (although +the overloaded method resolution mechanism could probably be +adapted to do this)
    • +
+
    +
  • Prolog code can reason about the +types +of Java data values, object references, fields and methods: JPL supports a +canonical +representation of all Java types as structured terms (e.g. array(array(byte))) and also as atomic JVM signatures
    • +
+
    +
  • the Prolog-calls-Java (mine) and +Java-calls-Prolog (Fred's) parts of JPL +are largely independent; mine concentrates on representing all Java +data +values and objects within Prolog, and supporting manipulation of +objects; +Fred's concentrates on representing any Prolog term within Java, and +supporting +the calling of goals within Prolog and the retrieving of results back +into +Java
    • +
+
    +
  • when called from Prolog, void +methods return a void value +(which is distinct from all other JPL values and +references)
    • +
+
    +
  • it uses @/1 to +construct representations of certain Java values; if  @/1 is defined +as a +prefix operator (as used by XPCE), then you can write @false, @true, @null etc. in +your +source code; otherwise (and for +portability) you'll have to write e.g. @(true) etc.
    • +
+
+

JPL types (Java +types, as seen by Prolog)

+
All Java values and object +references which are passed between Prolog engines and Java VMs via JPL's Prolog API +are seen as instances of types within this simplified JPL type system:
+
+a datum   (this term is introduced, out of +necessity, to refer jointly to values + and refs) +
is a value    +(values are copied between Prolog and the JVM)
+
+
+
+
is a boolean
+
+
+
+
+
or a char
+
+
+
+
+
or a long, int, + short or byte
+
+
+
+
+
or a double +or float
+
+
+
+
+
or a string   +(an instance of java.lang.String)
+
+
+
+
+
or a void     +(an artificial value returned by calls to Java void methods)
+ or a ref +
is null
+
+
+
+
+
or an object    +(held within the JVM, and represented in Prolog by a canonical +reference) +
is an array
+
+
+
+
+
+
+
or a class +instance (other than of java.lang.String)
+
+
+
+
+
+

representation of +Java values and references within Prolog

+Instances of JPL types are +represented within Prolog as follows:
+
boolean has two +values, +represented by @(true) and @(false) +

char values are +represented by corresponding Prolog integers

+

int, short +and byte values are represented by corresponding Prolog integers +

+

long values are +represented as Prolog integers if possible (32-bit in current +SWI-Prolog), else as jlong(Hi,Lo) where Hi is an integer corresponding to the +top32 +bits of the long, and Lo similarly represents the lower 32 bits

+

double and float +values are represented as Prolog floats (which are equivalent to Java +doubles) (there may be minor rounding, normalisation or +loss-of-precision issues when +a Java float is widened to a Prolog float then narrowed back again, but +what +the heck)

+

string values +(immutable instances +of java.lang.String) are +represented as Prolog atoms (in UTF-8 encoding)

+

null has only one +value, represented +as @(null)

+

void has only one +value, represented +as @(void)

+

array and class +instance references are currently represented as @(Tag), where +Tag ia an atom whose name encodes +a JNI global reference value; this may change, but won't affect Prolog +programs +which respect the opacity of references

+
+
+

representation of +Java types within Prolog (1): structured notation

+The JPL Prolog API +allows Prolog +applications to inspect, manipulate, and reason about the types of Java +values, references, +methods etc., and this section describes how these types themselves (as +opposed to instances thereof) are represented.  Predicates which +pass these type representations include jpl_class_to_type/2, jpl_classname_to_type/2, +jpl_datum_to_type/2, +jpl_is_object_type/1, +jpl_is_type/1, jpl_object_to_type/2, +jpl_primitive_type/1, +jpl_ref_to_type/2, jpl_type_to_class/2. jpl_type_to_classname/2. +
void is +represented as void
+
null is +represented as null
+
the primitive types are +represented as boolean, char, byte, short, int, long, float, double
+
classes are +represented as class(package_parts,classname_parts) +
e.g.  class([java,util],['Date'])
+ array types are +represented as array(type) +
e.g.  array(boolean)
+
+
+
e.g.  array(class([java,lang],['String'])
+
+
+This structured notation for Java types +is designed to be convenient for composition and decomposition by +matching (unification).
+
+

representation of +Java types within Prolog (2): descriptor notation

+The descriptor notation for Java +types is one of two textual notations employed by the JVM and the Java +class libraries; JPL +(necessarily) +supports both (and supports conversion between all three +representations). +

Examples:

+
'Z' denotes boolean +

'B' denotes byte

+

'C' denotes char

+

'S' denotes short

+

'I' denotes int

+

'J' denotes long

+

'F' denotes float

+

'D' denotes double

+

'Ljava/util/Date;' (for example) denotes the Java +class java.util.Date +

+

'[type' denotes an array of type +

+

'(argument_types)return_type' denotes the type of a method

+
+
+

representation of +Java types within Prolog (3): classname notation

+The classname notation for Java +types is the other textual notation employed by the JVM and the Java +class libraries.  It is a (seemingly unnecessary) variation on the +descriptor notation, used by a few JNI routines.  It has +the slight advantage that, in the +case of simple class types only, it resembles the Java source text +notation for classes.  This representation is supported only +because certain JNI functions use it; it is used within JPL's +implementation of jpl_call/4 +etc.  You may encounter this notation when tracing JPL activity, +but otherwise you need not know about it. +

Examples:

+
'java.util.Vector' denotes the Java class java.util.Vector
+
'[B' denotes an array of boolean
+
'[Ljava.lang.String;' denotes an array of string
+
+

Using the JPL 3.x Prolog +API
+

+

creating +instances of Java classes

+To create an instance of a Java class from +within Prolog, +call jpl_new(+Class,+Params,-Ref) with a classname, a list of +actual parameters for the +constructor, and a variable to be bound to the new reference, e.g. +
jpl_new( 'javax.swing.JFrame', +['frame with dialog'], F)
+which binds F to a new object +reference, e.g. +
 @('J#0008272420')
+(not that the details of this structure +are of any necessary concern to the Prolog programmer or to the +applications she +writes).
+NB for convenience, this predicate is overloaded: Class can also be a class type in structured notation, e.g. array(boolean).
+ +

+
+

calling methods +of Java objects or classes

+The object reference generated by the jpl_new/3 +call (above) can be passed to other JPL API +predicates such as
+ +
jpl_call( +Ref, +Method, +Params, +-Result)
+ e.g. +
jpl_call( F, setVisible, [@(true)], +_)
+which calls the setVisible method +of the object to which F refers, effectively passing it the +Java value true. +

(This call should display the new JFrame +in the top left corner of the desktop.)

+

Note the anonymous variable passed as +the fourth argument to jsp_call/4.  A variable in this +position receives +the result of the method call: either a value or a reference.  +Since +SetVisible() is a void method, the call returns the +(artificial) +reference @(void).

+

Some may prefer to code this call thus: +

+
jpl_call( F, setVisible, [@true], +@void)
+which documents the programmer's +understanding that this is a void method +(and fails if it isn't :-).
+ 
+If the +Ref +argument represents a class, then the named static method of that +class  is called. +

+
+

fetching +field values of Java objects or classes

+The jpl_get/3 API predicate can +retrieve the value of an instance field or a static field, e.g. +
jpl_get( 'java.awt.Color', pink, +Pink)
+which binds the Prolog variable Pink to a +reference to the predefined java.awt.Color +"constant" which is held in the static final .pink field of the +java.awt.Color +class. +

More generally, jpl_get/3 has +the following +interface:

+
jpl_get( +Class_or_Object, +Field, +-Datum)
+If the first argument represents a class, +then +a static field of that class with FieldName is accessed. +

+
+

setting +field values of Java objects or classes

+Object and class fields can be set (i.e. +have values or references assigned to them) by the jpl_set/3 +API procedure, which has the following interface: +
jpl_set( +Class_or_Object, +Field, ++Datum)
+where Datum must be a value or +reference of a type suitable for assignment to the named field of the +class or object. +

+
+

a slightly longer example

+This code fragment +
    findall(
        Ar,
        (   current_prolog_flag( N, V),
            term_to_atom( V, Va),
            jpl_new( '[Ljava.lang.String;', [N,Va], Ar)
        ),
        Ars
    ),
    jpl_new( '[[Ljava.lang.String;', Ars, Ac),
    jpl_datums_to_array( [name,value], Ah),
    jpl_new( 'javax.swing.JFrame', ['current_prolog_flag'], F),
    jpl_call( F, getContentPane, [], CP),
    jpl_new( 'javax.swing.JTable', [Ac,Ah], T),
    jpl_new( 'javax.swing.JScrollPane', [T], SP),
    jpl_call( CP, add, [SP,'Center'], _),
    jpl_call( F, setSize, [600,400], _),
+builds an array of arrays of strings +containing the names and values of the current SWI-Prolog "flags", and +displays it in +a JTable within a ScrollPane within a JFrame: +
+In addition to JPL API calls, +this +code calls jpl_datums_to_array/2, a utility which converts any +list +of valid representations of Java values (or objects) into a new Java +array, +whose base type is the most specialised type of which all list members +are +instances, and which is defined thus: +
+ 
jpl_datums_to_array( Ds, A) :-
    ground( Ds),
    jpl_datums_to_most_specific_common_ancestor_type( Ds, T),
    jpl_new( array(T), Ds, A).
+
+Having found the "most specific common +ancestor type" (my phrase :-), a new array of this type is created, +whose elements are initialised to the successive members of the list of +datums. +

This illustrates another mode of +operation of jpl_new/3:

+
jpl_new( +ArrayType, +InitialValues, +-ArrayRef)
+See the relevant Appendix for fuller +details of the API procedures. +

Don't forget the possibility of writing +and +manipulating new Java classes to serve your Prolog applications: this +interface +is not designed to make Java programming redundant :-)

+

+

+jpl_new( +X, +Argz, -V) :- +
X can be: +
    +
  • a suitable type
    • +
      +
    • i.e. any class(_,_), array(_) or +primitive +type (e.g. byte but not void)
      • +
    +
  • an atomic classname
    • +
      +
    • e.g. 'java.lang.String'
      • +
    • e.g. 'Ljava.lang.String;'   (a redundant but legitimate form)
      • +
    +
  • an atomic descriptor
    • +
      +
    • e.g. '[I'
      • +
    +
  • a class object
    • +
      +
    • i.e. an object whose type +is  class([java,lang],['Class'])
      • +
    +
+
+
if X denotes a +primitive +type and Argz is castable to a value of that type, then V is that value +(a +pointless mode of operation, but somehow complete...)
+
if X denotes an +array +type and Argz is a non-negative integer, then V is a new +array +of that many elements, initialised to the appropriate default value
+
if X denotes an +array +type and Argz is a list of datums, each of which is +(independently) +castable to the array element type, then V is a new array of as many elements as Argz has +members, +initialised to the results of casting the respective members of Argz
+
if X denotes a +non-array +object type and Argz is a list of datums, then V is the result +of +an invocation of that type's most specifically-typed constructor to +whose +respective parameters the members of Argz are assignable
+

+jpl_call( +X, +Method, ++Args, -R) :- +
X can be: +
  • a type, class +object or classname (for static methods of the denoted +class, +or for static or instance methods of java.lang.Class)
    • +
    +
    +
    +
  • a class instance or +array +(for static or instance methods)
    • +
    + Method can be: +
  • an atomic method +name (if this name is ambiguous, as a result of method overloading, +then it will be resolved by considering the types of Args, as far as they can be inferred)
    • +
    +
    +
    +
  • an integral method +index +(untested: for static overload resolution)
    • +
    +
    +
    +
  • a methodID/1 +structure +(ditto)
    • +
    + Args must be +
      +
    • a proper list (possibly empty) +of ground +arguments
      • +
    + Finally, an attempt will be made to +unify R with the returned +result.
    +

    +jpl_set( +X, +Field, +V) +:- +
    basically, sets the Fspec-th field +of +object X to value V +

    X can be:

    +
      +
    • a class object, a classname, +or an (object or array) type (for static fields, or +java.lang.Class fields)
      • +
    +
    +
    +
      +
    • a class instance (for +non-static +fields)
      • +
    +
    +
    +
      +
    • an array (for indexed +element or +subrange assignment)
      • +
    +
    +
    +
      +
    • but not a string (no +fields to +retrieve)
      • +
    + Field can be: +
      +
    • an atomic field name +(overloading will +be resolved dynamically, by considering the inferred type of V)
      • +
    +
    +
    +
      +
    • an integral field index (static +resolution: not tried yet)
      • +
    +
    +
    +
      +
    • a fieldID/1 (static resolution: not tried yet)
      • +
    +
    +
    +
      +
    • a variable (field names, or +array indices, are generated)(?!)
      • +
    +
    +
    +
      +
    • an array index I (X must be an +array +object: X[I] is assigned V)
      • +
    +
    +
    +
      +
    • a pair I-J of integers +(J can be a variable) (X must be an +array +object, V must be a list of values: X[I-J] will be +assigned V)
      • +
    + V +must be ground (although one day we may pass variables to JPL?!)
    +

    +jpl_get( +X, +Field, -V) +:- +
    X can be: +
      +
    • a class object, a classname, +or an (object or array) type (for static fields, or +java.lang.Class fields)
      • +
    +
    +
    +
      +
    • a class instance (for +non-static +fields)
      • +
    +
    +
    +
      +
    • an array (for the +'length' pseudo +field, or for indexed element retrieval)
      • +
    +
    +
    +
      +
    • but not a String (clashes with +classname; anyway, java.lang.String has no fields to retrieve)
      • +
    + Field can be +
      +
    • an atomic field name
      • +
    +
    +
    +
      +
    • or an integral field index +(these are +a secret :-)
      • +
    +
    +
    +
      +
    • or a fieldID/1 (not +for general consumption :-)
      • +
    +
    +
    +
      +
    • or an integral array index +(high-bound +checking is done by JVM, maybe throwing an exception)
      • +
    +
    +
    +
      +
    • or a variable (field names, or +array indices, are generated)
      • +
    +
    +
    +
      +
    • or a pair I-J of integers +or +variables (array subranges are generated) (relational or what?!)
      +
      • +
    + Immediately before jpl_get/4 returns, an attempt will be made to unify V with the +internally computed result.
    +
    +

    exceptions thrown by Java
    +

    +Uncaught exceptions thrown by the JVM in +the course of +handling a JPL +3.x Prolog API call are mapped onto Standard Prolog exceptions, +e.g. +
    + 
    jpl_new( 'java.util.Date', [yesterday], D)
    +
    +raises the Prolog exception +
    java_exception('java.lang.IllegalArgumentException', +@'J#0008408972')
    +because, as the exception suggests, yesterday is not a valid +constructor argument.
    + 
    +Java exceptions +are always returned as Prolog exceptions with this structure:
    +
    java_exception( classname, reference_to_exception_object)
    +
    +

    testing

    +For a rudimentary test, run +
    + 
    ?- jpl_demo.
    +
    +and wait patiently for some Swing windows +to +appear (but not too patiently, in case something is wrong...) +

    +
    +

    to do

    +Apart from any bugs I don't know about, +this interface is usable and useful as it stands.  Nevertheless +there are some things "to do" at some stage in the future, e.g. +
      +
    • support non-virtual method calls +(i.e. +explicitly call a method of some ancestor class despite there being an +overriding method (i.e. of the same name etc.) in a "nearer" class). + I believe +this is a fairly arcane Java feature, but it is needed for +completeness; +I want to accommodate it without complicating the syntax of regular +method +calls.
      • +
    +
      +
    • map the JVM's vprintf() +messages +onto something in SWI-Prolog (the user_error stream?)
      • +
    +
      +
    • catch the JVM's abort() and exit() events, +and +handle them appropriately (e.g. stop a Java abort from killing +the +SWI-Prolog process)
      • +
    +
      +
    • propagate SWI-Prolog's ABORT +action into +the JVM as appropriate, e.g. to interrupt a pending JPL call
      • +
    +
      +
    • reduce the (extravagant) overheads +of +each JPL +call +(without compromising functionality or safety)
      • +
    +
    +
    Paul +Singleton
    +
    drafted 10th November 2000
    +
    revised 14th December 2000
    +     +
    +
    revised 11th March 2003
    +revised 18th February 2004
    +
    +
    +
    +
    + + diff --git a/packages/jpl/jpl/docs/prolog_api/screendump.jpg b/packages/jpl/jpl/docs/prolog_api/screendump.jpg new file mode 100644 index 000000000..df8c83875 Binary files /dev/null and b/packages/jpl/jpl/docs/prolog_api/screendump.jpg differ diff --git a/packages/jpl/jpl/docs/release_notes.html b/packages/jpl/jpl/docs/release_notes.html new file mode 100644 index 000000000..830d84948 --- /dev/null +++ b/packages/jpl/jpl/docs/release_notes.html @@ -0,0 +1,555 @@ + + + + + + JPL release notes + + +

    +JPL release notes

    + +
    +
    +

    JPL +3.0.3 Release Notes

    +

    Changes within the distribution

    +
      +
    • the demo +folder has been renamed examples +(more idiomatic)(?) and its contents have been moved into a new java +folder, which is accompanied by a new prolog +folder for Prolog examples
      • +
    +

    Java API changes

    +
      +
    • to simplify the construction of queries, the Query(java.lang.String) constructor +now parses its string arg as if it were Prolog source text, and +constructs a new query whose goal is the resulting term.  This is +backwards compatible with (all but very unusual) previous usage, e.g.
      • +
    +
    new Query("statistics")
    +
    and allows arbitrarily complex goals to +be created textually, e.g.
    +
    new Query("setof(_A,current_atom(_A),_As),length(_As,N)")
    +NB _A and _As are dont-tell-me variables (this +property is determined by their initial underscore), whose bindings are +by default not returned when the query is called (saving computational +time and space).  This behaviour can be overridden (globally) with
    +
    jpl.JPL.setDTMMode( false)
    +to +allow Java+JPL+Prolog +implementation of a Prolog IDE which emulates the behaviour of the +traditional top-level interpreter. 
    +
    +
      +
    • to further simplify construction of queries, the Query(java.lang.String text, jpl.Term[] args) constructor now parses +its text +argument as a Prolog source text fragment; if it represents an atom, +the constructor behaves as before (building a Compound goal from the given name +and args), but if it represents a compound term with one or more atomic +subterms whose names are a single questionmark +character, e.g.
      • +
    +
    "setof(P,mypred(?,P,?),Ps), length(Ps,?)"
    +
    and the args comprise as +many terms as there are questionmarks, then the new query's goal is a +rewriting of text's +term, with each questionmark replaced by the corresponding element of args.  This +is designed to mimic the established and useful idiom of passing +parameters into SQL prepared +statements.  It allows all the constant parts of a +parameterised query to be defined textually.
    +
    +
    +
    Paul Singleton
    +
    Friday12th March 2004
    + 
    +
    +
    +

    JPL +3.0.2 Release Notes

    +

    Changes within the distribution

    +
      +
    • new classes folder: the +root directory of the distribution now contains +a classes folder, holding copies of the jpl.* and jpl.fli.* class files
      • +
    • new demo: in +demo/FamilyMT is a new variant of the Family demo which +exercises multiple Prolog engines (from a  shared pool) called by +multiple Java threads.
      • +
    +

    C library changes:

    +
      +
    • lots of refactoring and tidying in preparation for porting (to +Linux+gcc initially)
      • +
    • added Prolog "foreign" functions jpl_c_lib_version/1 +and jpl_c_lib_version/4 for +making library version identification available to Prolog
      • +
    • added Java "native" method get_string_chars(), +needed if Prolog returns a string to Java (which it does sometime even +if you don't want it to)
      • +
    • commented out various unused functions
      • +
    • added Java "native" method action_abort() +but it doesn't work yet...
      • +
    • added support for new jpl.JRef +type
      +
      • +
    +

    Java API changes
    +

    +
      +
    • altered the semantics of Variable +to be a purely lexical entity; a Variable +instance should be created with a name which is valid in Prolog source +syntax; the argumentless Variable() +constructor is currently deprecated and constructs a variable with a +"new" name in the sequence "_1", "_2" etc. so as not to completely +break older programs
      • +
    • bindings from successful calls are now keyed by the names of the variables, rather than +by Variable objects +themselves; this is part of a revamp to allow goals to be defined by +source text fragments
      +
      • +
    • implemented these methods for all + Term subclasses (to +simplify coding of term checking and traversal etc.):
      • +
      +
      type()
      +
      +
      +
      returns jpl.fli.Prolog.ATOM, + COMPOUND, FLOAT, INT or VARIABLE
      +
      +
      hasFunctor( String name, int arity)
      +
      fails unless called appropriately;
      +
      +
      intValue()
      +longValue()
      +floatValue()
      +doubleValue()
      +
      yield +the Java int value (or long, float or double value respectively) of an Integer or Float instance; each will throw an +exception +for Atom, Compound and Variable instances; the names of +these methods follow the precedent set by java.lang.Integer etc. and remember +that a Prolog integer is not equivalent to a Java int (it may be longer +or shorter), nor is a Prolog float equivalent to a Java float (it may +have a different precision)
      +
      +
      arg( int argNo)
      +
      +
      calling arg() inappropriately (i.e. for jpl.Atom, jpl.Integer, jpl.Float and jpl.Variable instances) throws a runtime exception +but is not a compile-time error; this method considers the args to be +numbered from 1 upwards (i.e. Prolog convention, not Java array +convention)
      +
      name()
      +
      +
      +
      Variable.name() returns the +variable's lexical name, Atom.name() +and Compound.name() behave as +before, Integer.name() and Float.name() each throw an exception +if called (but are valid at compile time)
      +
      +
      +
    • altered these methods for all Term +subclasses:
      • +
        +
      • toString() now yields +a valid (quoted if necessary) Prolog source text representation
        +
        • +
      +
    • deprecated Compound.arg0() +and all *.debugString() methods
      • +
    • deprecated Float.value() +(see floatValue() and doubleValue())
      +
      • +
    • jpl.Integer now holds a long value (to allow for +other/future Prolog implementations with >32-bit integers) but this +is backwards compatible if I understand Java correctly...
      +
      • +
    • deprecated jpl.Halt() +pending a rethink about how best to clean up and terminate a hybrid +Java+Prolog application
      +
      • +
    • added Query.abort() but +it doesn't work yet...
      +
      • +
    +
    +
    Paul Singleton
    +
    Sunday 22nd February 2004
    +  +
    +
    +
    +

    JPL +3.0.0 Release Notes

    +This +release is a +work-in-progress, and +is being made available only to a few enthusiasts who don't mind the +likelihood that the API will change before 3.x becomes stable.
    +

    Java API: new Variable semantics
    +

    +
    A Variable must be +created with a name, e.g.
    +     + 
    new Variable("X")
    +or as an anonymous variable
    + 
    new Variable("_")
    +
    +
    or as a dont-tell-me variable
    +
    +
    + 
    new Variable("_Q")
    +
    +
    Each binding within a solution is now +indexed by the name of +its associated Variable, hence
    +
    +
    + 
    solution.get("X")
    +
    +
    New variables returned in bindings are +given new, sequential names, e.g. "_283".
    + 
    +Each Variable instance within +a Java application is just a lexical token in the alternative Prolog +concrete syntax which Term and +its subclasses comprise.  Two instances of Variable("X") are no different +from one shared instance: you are free to reuse such lexical elements, +but this has nothing to do with the sharing of variables which can +occur within a Prolog engine.
    + 
    +The bindings of anonymous and dont-tell-me +variables (i.e. those whose names begin with an underscore character) +are not returned to Java: use them to avoid the computational time and +space costs of constructing Term +representations of bindings in which you are not interested.
    +
    +

    Java API: easier Term and Query construction

    +
    Now that Variables +are named, and bindings are keyed by the names of variables, it is +easier to construct Term (and +hence Query) instances.
    + 
    +This utility (NB liable to be renamed or moved into a different class) +converts a valid Prolog source text representation of a term into a +corresponding Term hierarchy:
    + 
    Term jpl.Util.textToTerm( String sourcetext)
    +A new (in JPL 3.0.0) Query +constructor
    + 
    Query( String sourcetext)
    +allows queries to be created from source text, e.g.
    + 
    new Query("findall(_A,current_atom(_A),_As),length(_As,N)")
    +and oneSolution(), allSolutions() and nextSolution() will return +bindings of N +(but not of the dont-tell-me +variables _A +and _As), +e.g.
    + 
    q.oneSolution().get("N")
    +returns a jpl.Integer +representing the Prolog integer value to which N was bound by the successful +call of the query.
    +
    +

    Java API: deprecated methods
    +

    +
      +
    • Query.query()
      • +
    +
    use Query.hasSolution() +instead
    +
    +
      +
    • Query.rewind()
      • +
    +
    use Query.close() +instead
    +
    +

    Java API: fixes

    +
    array methods inherited from java.lang.Object are now callable, +e.g.
    +
    +
      +
        + 
        jpl_new(array(int), [4,5,6], A),
        jpl_call(A, hashCode, [], H).
        +
      +
    + +

    Java API: planned or under consideration
    +

    +
      +
    • drop Term.display(), +which cutely displays any Term +in a Swing tree view in a new window.
      • +
    +
      +
    • support non-virtual method calls, e.g. by
      • +
    +
    jpl_call(+Obj, +Class:Method, +Args, -Result)
    +
      +
    • finish the current tidy-up
      +
      • +
    +
      +
    • passing (or returning) Prolog terms to Java by reference; we +might stash them in Prolog's recorded +database (see PL_record +in the SWI-Prolog Reference Manual), and return an instance of some +yet-to-be-designed JPL class which erases the recorded term when the +referring object is garbage-collected
      +
      • +
    +
      +
    • convenience constructs in Prolog akin to import in Java, allowing +us to write e.g.
      • +
    +
    jpl_new('Timestamp', X, R)
    +
    when we mean
    +
    jpl_new('javax.sql.Timestamp', X, R)
    +
      +
    • renaming the package jpl more +globally: unfortunately, org.jpl has +already been taken :-)
      • +
    +
      +
    • ditching jpl.Util and +moving its (static, utility) methods into jpl.JPL
      • +
    +
      +
    • deprecate all .args(), + .arg0(), .arg1() methods and replace with
      • +
    +
    public final Term[] args;
    +
      +
    • require any Variable's +name to conform to Prolog source syntax, so that valid source texts can +be reconstructed from Term +instances by the toString() +methods
      • +
    +
    Paul Singleton
    +
    Wednesday 4th February 2004
    + 
    +
    +
    +

    JPL +2.0.2 Release Notes

    +

    Java API: canonical representation of terms

    +
    +

    rationale

    +"List" and "Tuple" terms are not recognised as distinct +types +by the Prolog engine: they are just conventions: it doesn't follow that +every ./2 or []/0 +should be represented externally as instances of List or Nil, +nor that {}/2 should be represented as + Tuple.  +There are many other informal types, and it's not clear which of them +deserve +the same treatment.  The simplest policy is to provide special +support +for none of them, and this is what JPL 2.x.x does.  +This also ensures that there is only one valid representation of a +Prolog +term as JPL class instances (otherwise we would have to +be +careful to recognise every Atom whose name is "[]" as being +equivalent +to an instance of Nil).
    +
      +
    • these classes have been dropped (sorry, not deprecated: they +don't fit +into the new scheme)
      • +
        +
      • Tuple (see above)
        • +
      • List (see above)
        • +
      • Nil (see above)
        • +
      • String (these are obsolete and more-or-less deprecated +in +recent +SWI-Prolog releases)
        • +
      • Long (this doesn't have a clear role)
        • +
      +
    • the Term class hierarchy has been rearranged thus:
      • +
        + 
        Term (abstract)
          |
          +--- Compound
          |      |
          |      +--- Atom (special case)
          |
          +--- Integer
          |
          +--- Float
          |
          +--- Variable

        Query
        +
      +Note that an Atom is a Compound whose arity is +zero.  +It is naughty to construct a Compound with zero arity (this +violates +canonicity), and JPL code never does this when exporting +terms from Prolog.  Application code written in Java, using JPL, +should avoid doing this.  Maybe we should raise an exception if it +is attempted (maybe we do, I can't remember :-) +

      Note also that, although a Query contains a Term +(among +other Prolog-related state), it is not related to it by inheritance.

      +
    +

     Java API: lazy initialisation

    +
    It is no longer necessary to explicitly initialise JPL +before calling any of the methods which access the Prolog engine.  +This allows you to develop Java classes which make use of JPL, +and to make them available as "library" classes for use freely in +applications, +without placing a burden upon the application programmer to explicitly +initialise JPL. +

    Instead, JPL (and, if necessary, the Prolog engine) +is +initialised "lazily", at the first attempt to invoke the Prolog +engine.  +At this point, a "default" sequence of initialisation parameters is +used: +initial values for these are compiled into JPL, but they +can be redefined at any time up until initialisation occurs.

    +

    It is also possible for Java applications to discover (as a String[]) +exactly what sequence of JPL initialisation parameters +were +actually used (this call returns null if Prolog is not yet initialised, +and can thus be used as a test of this state).

    +

    If a Java application needs to use Prolog with, say, a larger than +normal +heap or stack, it should attempt to redefine the default initialisation +parameters, and hope that the Prolog engine is not yet initialised (if +it is, there's not much it can do about it) (in newer versions of +SWI-Prolog +it could restart it, but this is rather drastic, might disrupt other +activities, +and is not yet supported via JPL).

    +

    Finally, the JPL 1.0.1 static jpl.JPL.init() +method is still supported, for backwards compatibility.

    +

    These changes are not only for convenience, and to allow +development +of easy-to-use library code, but are part of a plan to combine Fred +Dushin's  +Java-calls-Prolog interface with Paul Singleton's Prolog-calls-Java +interface, +to support hybrid Prolog+Java application programming in which either

    +
      +
    • the JVM is alive before Prolog is started
      • +
    • the Prolog engine is alive before a JVM is started
      • +
    • a C or C++ main() starts both of them.
      • +
    +
    +

    Java API: miscellaneous changes
    +

    +
      +
    • new constructors:
      • +
        + 
        new jpl.Query( Term t)
        +
      +
    • withdrawn constructors:
      • +
        + 
        +all the multi-argument convenience constructors for Compound +etc., since Java 1.1 onwards supports "anonymous arrays" which can +(fairly) +conveniently be used to create Compounds of any arity, e.g. + 
        new Compound( "pair", new Term[] { new Atom("one"), new Atom("two") } )
        +
      +
    • new accessor methods:
      • +
        + 
        String Compound.name()
        + 
        int Compound.arity()
        +
      +NB an Atom is a special case of a Compound, and +inherits +its  name() and an arity() accessors
      + 
    • deprecated accessor methods:
      • +
        + 
        Compound.atom()
        +
      + (although Prolog conventionally, and necessarily, returns the +"name" +of a term's principal functor as an atom, this "name" is really a +string, +and in Java we can represent it as such; the best Prolog can return is +"the atom whose name is the same as the name of this compound", whereas +we can simply return the name).
      + 
    • deprecated method:
      • +
        + 
        jpl.Query.query() is renamed jpl.Query.hasSolution()
        +
      +for consistency with oneSolution() and allSolutions() +
    +

    Java API: bug fixes

    +
    Only one "bug" has been fixed, and this was already flagged +by Fred as an issue: it concerns the conversion, from Prolog into JPL, +of terms which contain shared variables (i.e. several instances of the +same variable).  Transput of any (non-cyclic) term from Prolog +into +Java and back, using JPL, should yield a new term which +is +identical to the original apart from having all new variables (but in a +similar pattern of sharing).
    +
    +
    Paul Singleton
    +
    +drafted Tuesday 20th February 2001
    +revised Thursday 19th April 2001
    +

    +
    +
    + + diff --git a/packages/jpl/jpl/examples/java/.cvsignore b/packages/jpl/jpl/examples/java/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Exceptions/.cvsignore b/packages/jpl/jpl/examples/java/Exceptions/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Exceptions/Exceptions.java b/packages/jpl/jpl/examples/java/Exceptions/Exceptions.java new file mode 100644 index 000000000..1b87c8280 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions/Exceptions.java @@ -0,0 +1,33 @@ +//tabstop=4 + +import jpl.Query; // empirically, we need this, but I don't know why... +import jpl.fli.Prolog; +import jpl.*; + +public class Exceptions +{ + public static void + main( java.lang.String argv[] ) + { + // currently, SWI-Prolog's default args are suited to interactive use with an attached console, + // not to embedded use like this, so we override them before they are used + // (by JPL, when it necessarily initialises Prolog when .hasSolution() is first called) + + Prolog.set_default_init_args( + new String[] { + "libpl.dll", + "-f", "none", + "-g", "set_prolog_flag(debug_on_error,false)", + "-q" + } + ); + + System.out.print( "calling\n\n"); + System.out.print( "?- X is Y.\n\n"); + System.out.print( "in Prolog to force a Prolog 'instantiation_error' exception,\n" ); + System.out.print( "which should be returned via Java as an uncaught jpl.PrologException in thread \"main\":\n\n" ); + + (new Query("X is Y")).hasSolution(); + } + +} diff --git a/packages/jpl/jpl/examples/java/Exceptions/README b/packages/jpl/jpl/examples/java/Exceptions/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Exceptions/run.bat b/packages/jpl/jpl/examples/java/Exceptions/run.bat new file mode 100644 index 000000000..e0b1adff4 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Exceptions.class ( + echo Compiling Exceptions.java + javac Exceptions.java +) + +java Exceptions + +pause diff --git a/packages/jpl/jpl/examples/java/Exceptions/run.sh b/packages/jpl/jpl/examples/java/Exceptions/run.sh new file mode 100755 index 000000000..379771142 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Exceptions + diff --git a/packages/jpl/jpl/examples/java/Exceptions2/.cvsignore b/packages/jpl/jpl/examples/java/Exceptions2/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions2/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Exceptions2/Exceptions2.java b/packages/jpl/jpl/examples/java/Exceptions2/Exceptions2.java new file mode 100644 index 000000000..9f851a0cb --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions2/Exceptions2.java @@ -0,0 +1,34 @@ +//tabstop=4 + +import jpl.fli.Prolog; +import jpl.*; + +public class Exceptions2 +{ + public static void + main( java.lang.String argv[] ) + { + + Prolog.set_default_init_args( + new String[] { + "libpl.dll", + "-f", "none", + "-g", "set_prolog_flag(debug_on_error,false)", + "-q" + } + ); + + System.out.print( "Calling\n\n"); + System.out.print( "?- X is Y.\n\n"); + System.out.print( "in Prolog to force an 'instantiation_error' exception,\n" ); + System.out.print( "whose getMessage() will be println-ed to System.out.\n\n" ); + + try { + (new Query("X is Y")).hasSolution(); + } catch (jpl.PrologException e) { + System.out.println( e.getMessage()); + } + + } + +} diff --git a/packages/jpl/jpl/examples/java/Exceptions2/README b/packages/jpl/jpl/examples/java/Exceptions2/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions2/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Exceptions2/run.bat b/packages/jpl/jpl/examples/java/Exceptions2/run.bat new file mode 100644 index 000000000..dc366c01e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions2/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Exceptions2.class ( + echo Compiling Exceptions2.java + javac Exceptions2.java +) + +java Exceptions2 + +pause diff --git a/packages/jpl/jpl/examples/java/Exceptions2/run.sh b/packages/jpl/jpl/examples/java/Exceptions2/run.sh new file mode 100755 index 000000000..b0695968b --- /dev/null +++ b/packages/jpl/jpl/examples/java/Exceptions2/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Exceptions2 + diff --git a/packages/jpl/jpl/examples/java/Family/.cvsignore b/packages/jpl/jpl/examples/java/Family/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Family/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Family/Family.java b/packages/jpl/jpl/examples/java/Family/Family.java new file mode 100755 index 000000000..e12fec715 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Family/Family.java @@ -0,0 +1,70 @@ +import java.util.Hashtable; +import jpl.*; +import jpl.Query; + +public class Family +{ + public static void + main( String argv[] ) + { + + String t1 = "consult('family.pl')"; + Query q1 = new Query(t1); + + System.out.println( t1 + " " + (q1.hasSolution() ? "succeeded" : "failed") ); + + //-------------------------------------------------- + + String t2 = "child_of(joe, ralf)"; + Query q2 = new Query(t2); + + System.out.println( t2 + " is " + (q2.hasSolution() ? "provable" : "not provable") ); + + //-------------------------------------------------- + + String t3 = "descendent_of(steve, ralf)"; + Query q3 = new Query(t3); + + System.out.println( t3 + " is " +(q3.hasSolution() ? "provable" : "not provable") ); + + //-------------------------------------------------- + + String t4 = "descendent_of(X, ralf)"; + Query q4 = new Query(t4); + + System.out.println( "first solution of " + t4 + ": X = " + q4.oneSolution().get("X")); + + //-------------------------------------------------- + + java.util.Hashtable[] ss4 = q4.allSolutions(); + + System.out.println( "all solutions of " + t4); + for ( int i=0 ; i current thread ) + 0x00007fddf6001800 JavaThread "DestroyJavaVM" [_thread_blocked, id=3335, stack(0x0000000103ef9000,0x0000000103ff9000)] + 0x00007fddf3059000 JavaThread "Thread-19" [_thread_in_native, id=32003, stack(0x000000011d03f000,0x000000011d13f000)] + 0x00007fddf20db800 JavaThread "Thread-18" [_thread_in_native, id=31491, stack(0x000000011cf3c000,0x000000011d03c000)] + 0x00007fddf5002000 JavaThread "Thread-17" [_thread_in_native, id=30979, stack(0x000000011ce39000,0x000000011cf39000)] + 0x00007fddf3058800 JavaThread "Thread-16" [_thread_in_native, id=30467, stack(0x000000011cd36000,0x000000011ce36000)] + 0x00007fddf6001000 JavaThread "Thread-15" [_thread_in_native, id=29955, stack(0x000000011cc33000,0x000000011cd33000)] + 0x00007fddf3920800 JavaThread "Thread-14" [_thread_in_native, id=29443, stack(0x000000011cb30000,0x000000011cc30000)] + 0x00007fddf4821000 JavaThread "Thread-13" [_thread_in_native, id=28931, stack(0x000000011ca2d000,0x000000011cb2d000)] + 0x00007fddf391f800 JavaThread "Thread-12" [_thread_in_native, id=28419, stack(0x000000011c92a000,0x000000011ca2a000)] + 0x00007fddf3057800 JavaThread "Thread-11" [_thread_in_native, id=27907, stack(0x000000011c827000,0x000000011c927000)] + 0x00007fddf284b800 JavaThread "Thread-10" [_thread_in_native, id=27395, stack(0x000000011c724000,0x000000011c824000)] + 0x00007fddf3057000 JavaThread "Thread-9" [_thread_in_native, id=26883, stack(0x000000011bc21000,0x000000011bd21000)] + 0x00007fddf6000000 JavaThread "Thread-8" [_thread_in_Java, id=26371, stack(0x000000011b11e000,0x000000011b21e000)] + 0x00007fddf4820800 JavaThread "Thread-7" [_thread_in_vm, id=25859, stack(0x000000011a61b000,0x000000011a71b000)] + 0x00007fddf481f800 JavaThread "Thread-6" [_thread_in_native, id=25347, stack(0x0000000119b18000,0x0000000119c18000)] + 0x00007fddf391f000 JavaThread "Thread-5" [_thread_in_native, id=24835, stack(0x0000000119015000,0x0000000119115000)] + 0x00007fddf391e000 JavaThread "Thread-4" [_thread_in_Java, id=24323, stack(0x0000000118512000,0x0000000118612000)] + 0x00007fddf391d800 JavaThread "Thread-3" [_thread_in_native, id=23811, stack(0x0000000117a0f000,0x0000000117b0f000)] +=>0x00007fddf391c800 JavaThread "Thread-2" [_thread_in_native, id=23299, stack(0x0000000116f0c000,0x000000011700c000)] + 0x00007fddf391c000 JavaThread "Thread-1" [_thread_in_native, id=22787, stack(0x0000000116407000,0x0000000116507000)] + 0x00007fddf38a3800 JavaThread "Thread-0" [_thread_in_native, id=22275, stack(0x0000000116304000,0x0000000116404000)] + 0x00007fddf3847800 JavaThread "Service Thread" daemon [_thread_blocked, id=21251, stack(0x00000001152c1000,0x00000001153c1000)] + 0x00007fddf302e000 JavaThread "C2 CompilerThread1" daemon [_thread_blocked, id=20739, stack(0x00000001151be000,0x00000001152be000)] + 0x00007fddf302c800 JavaThread "C2 CompilerThread0" daemon [_thread_blocked, id=20227, stack(0x00000001150bb000,0x00000001151bb000)] + 0x00007fddf301d000 JavaThread "Signal Dispatcher" daemon [_thread_blocked, id=19715, stack(0x0000000114fb8000,0x00000001150b8000)] + 0x00007fddf4802000 JavaThread "Finalizer" daemon [_thread_blocked, id=14595, stack(0x0000000114d69000,0x0000000114e69000)] + 0x00007fddf2802000 JavaThread "Reference Handler" daemon [_thread_blocked, id=14083, stack(0x0000000114c66000,0x0000000114d66000)] + +Other Threads: + 0x00007fddf383e800 VMThread [stack: 0x0000000114b63000,0x0000000114c63000] [id=13571] + 0x00007fddf386a000 WatcherThread [stack: 0x00000001153c4000,0x00000001154c4000] [id=21763] + +VM state:not at safepoint (normal execution) + +VM Mutex/Monitor currently owned by a thread: None + +Heap + PSYoungGen total 76800K, used 29064K [0x00000007aaa80000, 0x00000007b0000000, 0x0000000800000000) + eden space 66048K, 44% used [0x00000007aaa80000,0x00000007ac6e2310,0x00000007aeb00000) + from space 10752K, 0% used [0x00000007af580000,0x00000007af580000,0x00000007b0000000) + to space 10752K, 0% used [0x00000007aeb00000,0x00000007aeb00000,0x00000007af580000) + ParOldGen total 174592K, used 0K [0x0000000700000000, 0x000000070aa80000, 0x00000007aaa80000) + object space 174592K, 0% used [0x0000000700000000,0x0000000700000000,0x000000070aa80000) + PSPermGen total 21504K, used 2803K [0x00000006fae00000, 0x00000006fc300000, 0x0000000700000000) + object space 21504K, 13% used [0x00000006fae00000,0x00000006fb0bcfe8,0x00000006fc300000) + +Card table byte_map: [0x0000000108b61000,0x000000010938b000] byte_map_base: 0x000000010538a000 + +Polling page: 0x0000000103ffb000 + +Code Cache [0x0000000105aa1000, 0x0000000105d11000, 0x0000000108aa1000) + total_blobs=188 nmethods=4 adapters=139 free_code_cache=48763Kb largest_free_block=49916480 + +Compilation events (6 events): +Event: 0.067 Thread 0x00007fddf302c800 1 java.lang.String::indexOf (70 bytes) +Event: 0.068 Thread 0x00007fddf302e000 2 java.lang.String::hashCode (55 bytes) +Event: 0.073 Thread 0x00007fddf302c800 nmethod 1 0x0000000105b061d0 code [0x0000000105b06320, 0x0000000105b064c8] +Event: 0.073 Thread 0x00007fddf302e000 nmethod 2 0x0000000105b02a50 code [0x0000000105b02ba0, 0x0000000105b02d18] +Event: 0.082 Thread 0x00007fddf302c800 3 sun.nio.cs.UTF_8$Encoder::encode (361 bytes) +Event: 0.087 Thread 0x00007fddf302c800 nmethod 3 0x0000000105b00350 code [0x0000000105b004c0, 0x0000000105b009e8] + +GC Heap History (0 events): +No events + +Deoptimization events (0 events): +No events + +Internal exceptions (10 events): +Event: 0.092 Thread 0x00007fddf3001800 Threw 0x00000007aab8f610 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.092 Thread 0x00007fddf3001800 Threw 0x00000007aab92458 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.092 Thread 0x00007fddf3001800 Threw 0x00000007aab950d8 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.093 Thread 0x00007fddf3001800 Threw 0x00000007aab97dc0 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.093 Thread 0x00007fddf3001800 Threw 0x00000007aab9ab08 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.093 Thread 0x00007fddf3001800 Threw 0x00000007aab9da20 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.094 Thread 0x00007fddf3001800 Threw 0x00000007aaba0960 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.094 Thread 0x00007fddf3001800 Threw 0x00000007aaba38c8 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.095 Thread 0x00007fddf3001800 Threw 0x00000007aaba68b0 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 +Event: 0.095 Thread 0x00007fddf3001800 Threw 0x00000007aaba9858 at /HUDSON/workspace/7u-2-build-macosx-x86_64/jdk7u45/229/hotspot/src/share/vm/prims/jvm.cpp:1244 + +Events (10 events): +Event: 0.124 Thread 0x00007fddf4820800 Thread added: 0x00007fddf4820800 +Event: 0.125 Thread 0x00007fddf6000000 Thread added: 0x00007fddf6000000 +Event: 0.125 Thread 0x00007fddf3057000 Thread added: 0x00007fddf3057000 +Event: 0.125 Thread 0x00007fddf284b800 Thread added: 0x00007fddf284b800 +Event: 0.125 Thread 0x00007fddf3057800 Thread added: 0x00007fddf3057800 +Event: 0.125 Thread 0x00007fddf391f800 Thread added: 0x00007fddf391f800 +Event: 0.125 Thread 0x00007fddf4821000 Thread added: 0x00007fddf4821000 +Event: 0.125 Thread 0x00007fddf3920800 Thread added: 0x00007fddf3920800 +Event: 0.126 Thread 0x00007fddf6001000 Thread added: 0x00007fddf6001000 +Event: 0.126 Thread 0x00007fddf3058800 Thread added: 0x00007fddf3058800 + + +Dynamic libraries: +0x000000000301a000 /System/Library/Frameworks/Cocoa.framework/Versions/A/Cocoa +0x000000000301a000 /System/Library/Frameworks/Security.framework/Versions/A/Security +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/ApplicationServices +0x000000000301a000 /usr/lib/libz.1.dylib +0x000000000301a000 /usr/lib/libSystem.B.dylib +0x000000000301a000 /usr/lib/libobjc.A.dylib +0x000000000301a000 /System/Library/Frameworks/CoreFoundation.framework/Versions/A/CoreFoundation +0x000000000301a000 /System/Library/Frameworks/Foundation.framework/Versions/C/Foundation +0x000000000301a000 /System/Library/Frameworks/AppKit.framework/Versions/C/AppKit +0x000000000301a000 /System/Library/Frameworks/CoreData.framework/Versions/A/CoreData +0x000000000301a000 /System/Library/PrivateFrameworks/RemoteViewServices.framework/Versions/A/RemoteViewServices +0x000000000301a000 /System/Library/Frameworks/AudioToolbox.framework/Versions/A/AudioToolbox +0x000000000301a000 /System/Library/Frameworks/AudioUnit.framework/Versions/A/AudioUnit +0x000000000301a000 /System/Library/PrivateFrameworks/DataDetectorsCore.framework/Versions/A/DataDetectorsCore +0x000000000301a000 /System/Library/PrivateFrameworks/DesktopServicesPriv.framework/Versions/A/DesktopServicesPriv +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/HIToolbox.framework/Versions/A/HIToolbox +0x000000000301a000 /System/Library/Frameworks/QuartzCore.framework/Versions/A/QuartzCore +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/SpeechRecognition.framework/Versions/A/SpeechRecognition +0x000000000301a000 /usr/lib/libauto.dylib +0x000000000301a000 /usr/lib/libicucore.A.dylib +0x000000000301a000 /usr/lib/libxml2.2.dylib +0x000000000301a000 /System/Library/PrivateFrameworks/CoreUI.framework/Versions/A/CoreUI +0x000000000301a000 /System/Library/Frameworks/CoreAudio.framework/Versions/A/CoreAudio +0x000000000301a000 /System/Library/Frameworks/DiskArbitration.framework/Versions/A/DiskArbitration +0x000000000301a000 /usr/lib/liblangid.dylib +0x000000000301a000 /System/Library/PrivateFrameworks/MultitouchSupport.framework/Versions/A/MultitouchSupport +0x000000000301a000 /System/Library/Frameworks/IOKit.framework/Versions/A/IOKit +0x000000000301a000 /usr/lib/libDiagnosticMessagesClient.dylib +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/CoreServices +0x000000000301a000 /System/Library/PrivateFrameworks/PerformanceAnalysis.framework/Versions/A/PerformanceAnalysis +0x000000000301a000 /System/Library/PrivateFrameworks/GenerationalStorage.framework/Versions/A/GenerationalStorage +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/OpenGL +0x000000000301a000 /System/Library/PrivateFrameworks/Sharing.framework/Versions/A/Sharing +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/ImageIO +0x000000000301a000 /System/Library/Frameworks/CoreText.framework/Versions/A/CoreText +0x000000000301a000 /System/Library/Frameworks/CoreGraphics.framework/Versions/A/CoreGraphics +0x000000000301a000 /System/Library/PrivateFrameworks/Backup.framework/Versions/A/Backup +0x000000000301a000 /System/Library/Frameworks/CFNetwork.framework/Versions/A/CFNetwork +0x000000000301a000 /System/Library/Frameworks/SystemConfiguration.framework/Versions/A/SystemConfiguration +0x000000000301a000 /usr/lib/libCRFSuite.dylib +0x000000000301a000 /usr/lib/libc++.1.dylib +0x000000000301a000 /usr/lib/libc++abi.dylib +0x000000000301a000 /usr/lib/system/libcache.dylib +0x000000000301a000 /usr/lib/system/libcommonCrypto.dylib +0x000000000301a000 /usr/lib/system/libcompiler_rt.dylib +0x000000000301a000 /usr/lib/system/libcopyfile.dylib +0x000000000301a000 /usr/lib/system/libcorecrypto.dylib +0x000000000301a000 /usr/lib/system/libdispatch.dylib +0x000000000301a000 /usr/lib/system/libdyld.dylib +0x000000000301a000 /usr/lib/system/libkeymgr.dylib +0x000000000301a000 /usr/lib/system/liblaunch.dylib +0x000000000301a000 /usr/lib/system/libmacho.dylib +0x000000000301a000 /usr/lib/system/libquarantine.dylib +0x000000000301a000 /usr/lib/system/libremovefile.dylib +0x000000000301a000 /usr/lib/system/libsystem_asl.dylib +0x000000000301a000 /usr/lib/system/libsystem_blocks.dylib +0x000000000301a000 /usr/lib/system/libsystem_c.dylib +0x000000000301a000 /usr/lib/system/libsystem_configuration.dylib +0x000000000301a000 /usr/lib/system/libsystem_dnssd.dylib +0x000000000301a000 /usr/lib/system/libsystem_info.dylib +0x000000000301a000 /usr/lib/system/libsystem_kernel.dylib +0x000000000301a000 /usr/lib/system/libsystem_m.dylib +0x000000000301a000 /usr/lib/system/libsystem_malloc.dylib +0x000000000301a000 /usr/lib/system/libsystem_network.dylib +0x000000000301a000 /usr/lib/system/libsystem_notify.dylib +0x000000000301a000 /usr/lib/system/libsystem_platform.dylib +0x000000000301a000 /usr/lib/system/libsystem_pthread.dylib +0x000000000301a000 /usr/lib/system/libsystem_sandbox.dylib +0x000000000301a000 /usr/lib/system/libsystem_stats.dylib +0x000000000301a000 /usr/lib/system/libunc.dylib +0x000000000301a000 /usr/lib/system/libunwind.dylib +0x000000000301a000 /usr/lib/system/libxpc.dylib +0x000000000301a000 /usr/lib/libbsm.0.dylib +0x000000000301a000 /usr/lib/libsqlite3.dylib +0x000000000301a000 /usr/lib/libxar.1.dylib +0x000000000301a000 /usr/lib/libpam.2.dylib +0x000000000301a000 /usr/lib/libOpenScriptingUtil.dylib +0x000000000301a000 /usr/lib/libbz2.1.0.dylib +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/CarbonCore.framework/Versions/A/CarbonCore +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/Metadata.framework/Versions/A/Metadata +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/OSServices.framework/Versions/A/OSServices +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/SearchKit.framework/Versions/A/SearchKit +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/AE.framework/Versions/A/AE +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/LaunchServices.framework/Versions/A/LaunchServices +0x000000000301a000 /System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/DictionaryServices.framework/Versions/A/DictionaryServices +0x000000000301a000 /System/Library/Frameworks/NetFS.framework/Versions/A/NetFS +0x000000000301a000 /usr/lib/system/libkxld.dylib +0x000000000301a000 /System/Library/PrivateFrameworks/NetAuth.framework/Versions/A/NetAuth +0x000000000301a000 /System/Library/PrivateFrameworks/TCC.framework/Versions/A/TCC +0x000000000301a000 /System/Library/Frameworks/OpenDirectory.framework/Versions/A/Frameworks/CFOpenDirectory.framework/Versions/A/CFOpenDirectory +0x000000000301a000 /System/Library/Frameworks/ServiceManagement.framework/Versions/A/ServiceManagement +0x000000000301a000 /usr/lib/libxslt.1.dylib +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/Ink.framework/Versions/A/Ink +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/ATS.framework/Versions/A/ATS +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/ColorSync.framework/Versions/A/ColorSync +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/HIServices.framework/Versions/A/HIServices +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/LangAnalysis.framework/Versions/A/LangAnalysis +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/PrintCore.framework/Versions/A/PrintCore +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/QD.framework/Versions/A/QD +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/SpeechSynthesis.framework/Versions/A/SpeechSynthesis +0x000000000301a000 /System/Library/Frameworks/IOSurface.framework/Versions/A/IOSurface +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Accelerate +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vImage.framework/Versions/A/vImage +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/vecLib +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libvDSP.dylib +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libvMisc.dylib +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libLAPACK.dylib +0x000000000301a000 /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/ATS.framework/Versions/A/Resources/libFontParser.dylib +0x000000000301a000 /System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/ATS.framework/Versions/A/Resources/libFontRegistry.dylib +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/Resources/libJPEG.dylib +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/Resources/libTIFF.dylib +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/Resources/libPng.dylib +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/Resources/libGIF.dylib +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/Resources/libJP2.dylib +0x000000000301a000 /System/Library/Frameworks/ImageIO.framework/Versions/A/Resources/libRadiance.dylib +0x000000000301a000 /usr/lib/libcups.2.dylib +0x000000000301a000 /System/Library/Frameworks/Kerberos.framework/Versions/A/Kerberos +0x000000000301a000 /System/Library/Frameworks/GSS.framework/Versions/A/GSS +0x000000000301a000 /usr/lib/libresolv.9.dylib +0x000000000301a000 /usr/lib/libiconv.2.dylib +0x000000000301a000 /System/Library/PrivateFrameworks/Heimdal.framework/Versions/A/Heimdal +0x000000000301a000 /System/Library/PrivateFrameworks/TrustEvaluationAgent.framework/Versions/A/TrustEvaluationAgent +0x000000000301a000 /usr/lib/libheimdal-asn1.dylib +0x000000000301a000 /System/Library/Frameworks/OpenDirectory.framework/Versions/A/OpenDirectory +0x000000000301a000 /System/Library/PrivateFrameworks/CommonAuth.framework/Versions/A/CommonAuth +0x000000000301a000 /System/Library/Frameworks/SecurityFoundation.framework/Versions/A/SecurityFoundation +0x000000000301a000 /System/Library/PrivateFrameworks/Bom.framework/Versions/A/Bom +0x000000000301a000 /System/Library/Frameworks/CoreVideo.framework/Versions/A/CoreVideo +0x000000000301a000 /System/Library/Frameworks/QuartzCore.framework/Versions/A/Frameworks/CoreImage.framework/Versions/A/CoreImage +0x000000000301a000 /System/Library/Frameworks/QuartzCore.framework/Versions/A/Frameworks/ScalableUserInterface.framework/Versions/A/ScalableUserInterface +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLU.dylib +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGFXShared.dylib +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLImage.dylib +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libCVMSPluginSupport.dylib +0x000000000301a000 /System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libCoreVMClient.dylib +0x000000000301a000 /System/Library/PrivateFrameworks/FaceCore.framework/Versions/A/FaceCore +0x000000000301a000 /System/Library/PrivateFrameworks/CrashReporterSupport.framework/Versions/A/CrashReporterSupport +0x000000000301a000 /System/Library/Frameworks/OpenCL.framework/Versions/A/OpenCL +0x000000000301a000 /System/Library/PrivateFrameworks/AppleFSCompression.framework/Versions/A/AppleFSCompression +0x000000000301a000 /System/Library/PrivateFrameworks/Ubiquity.framework/Versions/A/Ubiquity +0x000000000301a000 /System/Library/PrivateFrameworks/IconServices.framework/Versions/A/IconServices +0x000000000301a000 /System/Library/PrivateFrameworks/ChunkingLibrary.framework/Versions/A/ChunkingLibrary +0x000000000301a000 /System/Library/PrivateFrameworks/CoreSymbolication.framework/Versions/A/CoreSymbolication +0x000000000301a000 /System/Library/PrivateFrameworks/Symbolication.framework/Versions/A/Symbolication +0x000000000301a000 /System/Library/PrivateFrameworks/DebugSymbols.framework/Versions/A/DebugSymbols +0x0000000105000000 /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/jre/lib/server/libjvm.dylib +0x000000000301a000 /usr/lib/libstdc++.6.dylib +0x0000000105a53000 /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/jre/lib/libverify.dylib +0x0000000105a60000 /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/jre/lib/libjava.dylib +0x0000000105a98000 /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/jre/lib/libzip.dylib +0x0000000114e6b000 /System/Library/Frameworks/JavaVM.framework/Frameworks/JavaRuntimeSupport.framework/JavaRuntimeSupport +0x0000000114e83000 /System/Library/Frameworks/JavaVM.framework/Versions/A/Frameworks/JavaNativeFoundation.framework/Versions/A/JavaNativeFoundation +0x0000000114e98000 /System/Library/Frameworks/JavaVM.framework/Versions/A/JavaVM +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Carbon +0x0000000114ea5000 /System/Library/PrivateFrameworks/JavaLaunching.framework/Versions/A/JavaLaunching +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/CommonPanels.framework/Versions/A/CommonPanels +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/Help.framework/Versions/A/Help +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/ImageCapture.framework/Versions/A/ImageCapture +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/OpenScripting.framework/Versions/A/OpenScripting +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/Print.framework/Versions/A/Print +0x000000000301a000 /System/Library/Frameworks/Carbon.framework/Versions/A/Frameworks/SecurityHI.framework/Versions/A/SecurityHI +0x000000011552a000 /usr/local/lib/Yap/libjpl.dylib +0x0000000115543000 /usr/local/opt/readline/lib/libreadline.6.dylib +0x000000000301a000 /usr/lib/libncurses.5.4.dylib +0x000000011557a000 /usr/local/lib/libgmp.10.dylib +0x00000001155ed000 /usr/local/lib/libYap.6.dylib + +VM Arguments: +jvm_args: -Djava.library.path=/usr/local/lib/Yap +java_command: FamilyMT +Launcher Type: SUN_STANDARD + +Environment Variables: +CLASSPATH=.:/usr/local/share/Yap/jpl/jpl.jar +PATH=/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:/opt/X11/bin:/usr/texbin +LD_LIBRARY_PATH=/usr/local/lib/Yap +SHELL=/bin/bash +DISPLAY=/tmp/launch-Js9YCZ/org.macosforge.xquartz:0 +DYLD_FALLBACK_LIBRARY_PATH=/usr/X11/lib:/usr/lib:: + +Signal Handlers: +SIGSEGV: [libjvm.dylib+0x525415], sa_mask[0]=0xfffefeff, sa_flags=0x00000043 +SIGBUS: [libjvm.dylib+0x525415], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGFPE: [libjvm.dylib+0x41891a], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGPIPE: [libjvm.dylib+0x41891a], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGXFSZ: [libjvm.dylib+0x41891a], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGILL: [libjvm.dylib+0x41891a], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGUSR1: SIG_DFL, sa_mask[0]=0x63807efb, sa_flags=0x00000000 +SIGUSR2: [libjvm.dylib+0x41840c], sa_mask[0]=0x00000000, sa_flags=0x00000042 +SIGHUP: [libjvm.dylib+0x41669b], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGINT: [libjvm.dylib+0x41669b], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGTERM: [libjvm.dylib+0x41669b], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 +SIGQUIT: [libjvm.dylib+0x41669b], sa_mask[0]=0xfffefeff, sa_flags=0x00000042 + + +--------------- S Y S T E M --------------- + +OS:Bsduname:Darwin 13.4.0 Darwin Kernel Version 13.4.0: Sun Aug 17 19:50:11 PDT 2014; root:xnu-2422.115.4~1/RELEASE_X86_64 x86_64 +rlimit: STACK 8192k, CORE 0k, NPROC 709, NOFILE 10240, AS infinity +load average:1.09 1.27 1.38 + +CPU:total 8 (4 cores per cpu, 2 threads per core) family 6 model 58 stepping 9, cmov, cx8, fxsr, mmx, sse, sse2, sse3, ssse3, sse4.1, sse4.2, popcnt, avx, aes, erms, ht, tsc, tscinvbit, tscinv + +Memory: 4k page, physical 16777216k(4194304k free) + +/proc/meminfo: + + +vm_info: Java HotSpot(TM) 64-Bit Server VM (24.45-b08) for bsd-amd64 JRE (1.7.0_45-b18), built on Oct 8 2013 05:54:16 by "java_re" with gcc 4.2.1 (Based on Apple Inc. build 5658) (LLVM build 2336.11.00) + +time: Mon Oct 13 07:11:42 2014 +elapsed time: 0 seconds + diff --git a/packages/jpl/jpl/examples/java/FamilyMT/run.bat b/packages/jpl/jpl/examples/java/FamilyMT/run.bat new file mode 100644 index 000000000..e116ef674 --- /dev/null +++ b/packages/jpl/jpl/examples/java/FamilyMT/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist FamilyMT.class ( + echo Compiling FamilyMT.java + javac FamilyMT.java +) + +java FamilyMT + +pause diff --git a/packages/jpl/jpl/examples/java/FamilyMT/run.sh b/packages/jpl/jpl/examples/java/FamilyMT/run.sh new file mode 100755 index 000000000..9fa9a4a80 --- /dev/null +++ b/packages/jpl/jpl/examples/java/FamilyMT/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run FamilyMT + diff --git a/packages/jpl/jpl/examples/java/README b/packages/jpl/jpl/examples/java/README new file mode 100644 index 000000000..0b2329269 --- /dev/null +++ b/packages/jpl/jpl/examples/java/README @@ -0,0 +1,65 @@ +JPL 3.0.0 for Windows +===================== + +Tests for the Java-calls-Prolog interface: +------------------------------------------ + +This directory contains various rudimentary tests for JPL3's +Java-calls-Prolog interface, each within a separate folder. + +Exceptions + demonstrates how an uncaught Prolog exception is turned + into a Java exception (also uncaught, in this example) + +Exceptions2 + demonstrates how an uncaught Prolog exception is turned + into a Java exception, which in this example is caught, + converted to a String and printed on System.out (and + also shown in a Swing treeview gadget) + +Family + consults some parent-child relationship clauses (from + family.pl) and runs some simple queries + +FamilyMT + consults some parent-child relationship clauses (from + family.pl) and then sets off twenty threads, each doing the + queries of Family (above). As there are only five available + Prolog engines by default, the threads sometimes get to wait. + +Test + runs a simple set of tests of the High-Level Interface. + You should run this test once you have gotten JPL built, + or if you are experiencing any problems with the package. + +Test2 + recursively computes factorial(10) by alternately calling + Prolog from Java and Java from Prolog + +Time + runs a set of timing experiments, designed to gauge the speed + with which terms are exchanged between Java and Prolog + +Versions + tries to discover which versions (e.g. 3.0.3-alpha) of each JPL + library (i.e. Prolog, C and Java) are installed, and congratulates + you if they are the same + +Zahed + creates a trivial-in-Prolog-but-horrible-in-JPL1.x query goal + and calls it against a trivial Prolog database; this would be much + nicer if it used recent facilities for creating queries from + Prolog source text fragments + +NB each folder contains a Java application which should be run within +its folder so it can find any corresponding .pl (Prolog source) files: +Windows users can use 'compile.bat' to (re)compile each demo, and +'run.bat' to run it. + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +July 2003 +January 2004 (revised) +December 2004 (not revised much apart from this line) + diff --git a/packages/jpl/jpl/examples/java/SemWeb/.cvsignore b/packages/jpl/jpl/examples/java/SemWeb/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/SemWeb/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/SemWeb/README b/packages/jpl/jpl/examples/java/SemWeb/README new file mode 100644 index 000000000..173080345 --- /dev/null +++ b/packages/jpl/jpl/examples/java/SemWeb/README @@ -0,0 +1,36 @@ +Java calling Prolog semweb library +---------------------------------- + +This demo is a very simple example of loading and using the SWI-Prolog +semantic web library for parsing and querying of RDF data. Its main +purpose is actually to illustrate and test access from Prolog to foreign +resources. This demo uses sgml2pl.so and rdf_db.so, providing the XML +parser and RDF database. + +ELF systems (Linux, Solaris and many more) +------------------------------------------ + +In the current setup libjpl.so contains the Prolog kernel and therefore +the extensions must get the PL_* symbols from this library. Java loads +shared objects without making their symbols available to other modules. +This problem is avoided by preloading libjpl.so as illustrated in the +run_preloaded function defined in env.sh. Below is a portable +shell-script skeleton to deal with this situation: + +---------------------------------------------------------------- +#!/bin/sh + +class=SemWeb + +eval `$PL -dump-runtime-variables` +JPLSO="$PLBASE/lib/$PLARCH/libjpl.$PLSOEXT" +JPLJAR="$PLBASE/lib/jpl.jar" + +if [ -z "$CLASSPATH" ]; then + CLASSPATH=".:$JPLJAR"; +else + CLASSPATH=".:$JPLJAR:$CLASSPATH" +fi + +env LD_PRELOAD=$JPLSO java $class +---------------------------------------------------------------- diff --git a/packages/jpl/jpl/examples/java/SemWeb/SemWeb.java b/packages/jpl/jpl/examples/java/SemWeb/SemWeb.java new file mode 100644 index 000000000..2e47e15f5 --- /dev/null +++ b/packages/jpl/jpl/examples/java/SemWeb/SemWeb.java @@ -0,0 +1,28 @@ +import java.util.Hashtable; +import jpl.*; +import jpl.Query; + +public class SemWeb +{ public static void + main(String argv[]) + { String t1 = "use_module(library('semweb/rdf_db'))"; + Query q1 = new Query(t1); + + System.out.println( t1 + " " + (q1.hasSolution() ? "succeeded" : "failed") ); + + Query ql = new Query("rdf_load('test.rdf')"); + System.out.println(ql.hasSolution() ? "loaded" : "load failed"); + + String t2 = "rdf(S,P,O)"; + Query q2 = new Query(t2); + while ( q2.hasMoreSolutions() ) + { java.util.Hashtable s2 = q2.nextSolution(); + System.out.println("{" + s2.get("S") + + ", " + s2.get("P") + + ", " + s2.get("O") + "}"); + } + } + +} + + diff --git a/packages/jpl/jpl/examples/java/SemWeb/run.bat b/packages/jpl/jpl/examples/java/SemWeb/run.bat new file mode 100644 index 000000000..db3083e45 --- /dev/null +++ b/packages/jpl/jpl/examples/java/SemWeb/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist SemWeb.class ( + echo Compiling SemWeb.java + javac SemWeb.java +) + +java SemWeb + +pause diff --git a/packages/jpl/jpl/examples/java/SemWeb/run.sh b/packages/jpl/jpl/examples/java/SemWeb/run.sh new file mode 100755 index 000000000..3dc4d1912 --- /dev/null +++ b/packages/jpl/jpl/examples/java/SemWeb/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run_preloaded SemWeb + diff --git a/packages/jpl/jpl/examples/java/SemWeb/test.rdf b/packages/jpl/jpl/examples/java/SemWeb/test.rdf new file mode 100644 index 000000000..5ef9c3301 --- /dev/null +++ b/packages/jpl/jpl/examples/java/SemWeb/test.rdf @@ -0,0 +1,15 @@ + + + + + + + + 200 + + + + diff --git a/packages/jpl/jpl/examples/java/Test/.cvsignore b/packages/jpl/jpl/examples/java/Test/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Test/README b/packages/jpl/jpl/examples/java/Test/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Test/Test.java b/packages/jpl/jpl/examples/java/Test/Test.java new file mode 100644 index 000000000..02d901c33 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test/Test.java @@ -0,0 +1,588 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ + + + +import java.util.Hashtable; +import jpl.Query; // empirically, we need this, but I don't know why... +import jpl.*; + +public class Test +{ + public static void + main( java.lang.String argv[] ) + { + // JPL.init(); // we don't need this with the current JPL (lazy init-on-demand) + + run_tests(); + } + + static void + run_tests() + { + test_0(); + test_1(); + test_2(); + test_3(); + test_4(); + test_5(); + test_6(); + test_7(); + test_8(); + test_9(); + test_10(); + test_11(); + + // test_101(); + } + + static void + test_0() + { + System.out.print( "test 0..." ); + + Query query = + new Query("consult('test.pl')"); + + if ( !query.hasSolution() ){ + System.out.println( "consult('test.pl') failed" ); + System.exit( 1 ); + } + System.out.println( "passed." ); + } + + static Term a = + new Atom( "a" ); + static Term b = + new Atom( "b" ); + static Term f_a = + new Compound( + "f", + new Term[] {a} + ); + static Term pair_a_b = + new Compound( + "-", + new Term[] {a,b} + ); + + static void + test_1() + { + System.out.print( "test 1..." ); + Query query = + new Query("p(a)"); + + if ( !query.hasSolution() ){ + System.out.println( "p(a) failed" ); + System.exit( 1 ); + } + System.out.println( "passed." ); + } + + static void + test_2() + { + System.out.print( "test 2..." ); + Query query = + new Query( + "p", + new Term[] {f_a} + ); + + if ( !query.hasSolution() ){ + System.out.println( "p(f(a)) failed" ); + System.exit( 1 ); + } + System.out.println( "passed." ); + } + + static void + test_3() + { + System.out.print( "test 3..." ); + Query query = + new Query( + "p", + new Term[] {pair_a_b} + ); + + if ( !query.hasSolution() ){ + System.out.println( "p( a-b ) failed" ); + System.exit( 1 ); + } + System.out.println( "passed." ); + } + + static void + test_4() + { + System.out.print( "test 4..." ); + Variable X = new Variable("X"); + Query query = + new Query( + "p", + new Term[] {X} + ); + + Term[] target = new Term[] {a,f_a,pair_a_b,new Variable("_")}; + + Hashtable[] solutions = query.allSolutions(); + + if ( solutions.length != 4 ){ + System.out.println( "p(X) failed:" ); + System.out.println( "\tExpected: 4 solutions" ); + System.out.println( "\tGot: " + solutions.length ); + System.exit( 1 ); + } + + for ( int i = 0; i < solutions.length-1; ++i ){ + Term binding = (Term)solutions[i].get( "X" ); + if ( ! binding.equals( target[i] ) ){ + System.out.println( "p(X) failed" ); + System.out.println( "\tExpected: " + target[i]); + System.out.println( "\tGot: " + binding); + System.exit( 1 ); + } + } + + System.out.println( "passed." ); + } + + static void + test_5() + { + System.out.print( "test 5..." ); + Variable X = new Variable("X"); + Variable Y = new Variable("Y"); + Query query = + new Query( + "p", + new Term[] {X,Y} + ); + + Term[] x_target = new Term[] {a,a}; + Term[] y_target = new Term[] {a,b}; + + Hashtable[] solutions = query.allSolutions(); + + if ( solutions.length != 2 ){ + System.out.println( "p(X, Y) failed:" ); + System.out.println( "\tExpected: 2 solutions" ); + System.out.println( "\tGot: " + solutions.length ); + System.exit( 1 ); + } + + for ( int i = 0; i < solutions.length; ++i ){ + Object x_binding = solutions[i].get("X"); + if ( ! x_binding.equals( x_target[i] ) ){ + System.out.println( "p(X, Y) failed:" ); + System.out.println( "\tExpected: " + x_target[i] ); + System.out.println( "\tGot: " + x_binding ); + System.exit( 1 ); + } + Object y_binding = solutions[i].get("Y"); + if ( ! y_binding.equals( y_target[i] ) ){ + System.out.println( "p( X, Y ) failed:" ); + System.out.println( "\tExpected: " + y_target[i] ); + System.out.println( "\tGot: " + y_binding ); + System.exit( 1 ); + } + } + System.out.println( "passed." ); + } + + static void + test_6() + { + System.out.print( "test 6..." ); + Variable X = new Variable("X"); + Query query = + new Query( + "p", + new Term[] {X,X} + ); + + Term[] x_target = new Term[] {a}; + + Hashtable[] solutions = query.allSolutions(); + + if ( solutions.length != 1 ){ + System.out.println( "p(X, X) failed:" ); + System.out.println( "\tExpected: 1 solution" ); + System.out.println( "\tGot: " + solutions.length ); + System.exit( 1 ); + } + + for ( int i = 0; i < solutions.length; ++i ){ + Object x_binding = solutions[i].get("X"); + if ( ! x_binding.equals( x_target[i] ) ){ + System.out.println( "p(X, X) failed:" ); + System.out.println( "\tExpected: " + x_target[i] ); + System.out.println( "\tGot: " + x_binding ); + System.exit( 1 ); + } + } + System.out.println( "passed." ); + } + + static void + test_7() + { + System.out.print( "test 7..." ); + Variable X = new Variable("X"); + Variable Y = new Variable("Y"); + Query query = + new Query( + "r", + new Term[] { + new Compound( + "f", + new Term[] {X,X} + ), + Y + } + ); + + Hashtable[] solutions = query.allSolutions(); + + if ( solutions.length != 2 ){ + System.out.println( "r(f(X,X), Y) failed:" ); + System.out.println( "\tExpected: 2 solutions" ); + System.out.println( "\tGot: " + solutions.length ); + System.exit( 1 ); + } + + Object x_binding, y_binding; + + x_binding = solutions[0].get("X"); + y_binding = solutions[0].get("Y"); + if ( x_binding != y_binding ){ + System.out.println( "r(f(X,X), Y) failed:" ); + System.out.println( Util.toString( solutions[0] ) ); + System.out.println( "\tThe variables to which X and Y are bound in the first solution should be identical." ); + System.exit( 1 ); + } + + x_binding = solutions[1].get("X"); + y_binding = solutions[1].get("Y"); + if ( x_binding == y_binding ){ + System.out.println( "r(f(X,X), Y) failed:" ); + System.out.println( Util.toString( solutions[1] ) ); + System.out.println( "\tThe variables to which X and Y are bound in the second solution should be distinct." ); + System.exit( 1 ); + } + if ( x_binding.equals( y_binding ) ){ + System.out.println( "r(f(X,X), Y) failed:" ); + System.out.println( Util.toString( solutions[1] ) ); + System.out.println( "\tThe variables to which X and Y are bound in the second solution should not be \"equal\"." ); + System.exit( 1 ); + } + /* + if ( ! solutions[0].get("X").equals( solutions[1].get("X") ) ){ + System.out.println( "r(f(X,X), Y) failed:" ); + System.out.println( Util.toString( solutions[0] ) ); + System.out.println( + "\tThe variable to which X is bound in the first solution (" + solutions[0].get("X") + ")\n" + + "\tshould be equal to the variable to which X is bound in the second (" + solutions[1].get("X") + ")"); + System.exit( 1 ); + } + */ + System.out.println( "passed." ); + } + + static void + test_8() + { + System.out.print( "test 8..." ); + Variable X = new Variable("X"); + Query query = + new Query( + "r", + new Term[] { + new Compound( + "f", + new Term[] {X,X} + ), + X + } + ); + + Hashtable[] solutions = query.allSolutions(); + + if ( solutions.length != 2 ){ + System.out.println( "r( f( X, X ), X ) failed:" ); + System.out.println( "\tExpected: 2 solutions" ); + System.out.println( "\tGot: " + solutions.length ); + System.exit( 1 ); + } + /* + if ( ! solutions[0].get("X").equals( solutions[1].get("X") ) ){ + System.out.println( "r( f( X, X ), X ) failed:" ); + System.out.println( Util.toString( solutions[0] ) ); + System.out.println( + "\tThe variable to which X is bound in the first solution\n" + + "\tshould be equal to the variable to which X is bound in the second." ); + System.exit( 1 ); + } + */ + System.out.println( "passed." ); + } + + // corresponds with Prolog List: [a-a,a-b] + static Term test_9_solution = + Util.termArrayToList( + new Term[] { + new Compound( "-", new Term[] {a,a}), + new Compound( "-", new Term[] {a,b}) + } + ); + + static void + test_9() + { + System.out.print( "test 9..." ); + Variable X = new Variable("X"); + Variable Y = new Variable("Y"); + Variable XYs = new Variable("XYs"); + Query query = + new Query( + "bagof", + new Term[] { + new Compound( + "-", + new Term[] {X,Y} + ), + new Compound( + "p", + new Term[] {X,Y} + ), + XYs + } + ); + + Hashtable[] solutions = query.allSolutions(); + + if ( solutions.length != 1 ){ + System.out.println( "bagof(X-Y, p(X,Y), XYs) failed:" ); + System.out.println( "\tExpected: 1 solution" ); + System.out.println( "\tGot: " + solutions.length ); + System.exit( 1 ); + } + + Term term = (Term) solutions[0].get("XYs"); + + // if ( ! (term instanceof List) ){ + if ( ! (term instanceof Compound && ".".equals(((Compound)term).name()) && ((Compound)term).arity()==2) ){ + System.out.println( "bagof(X-Y, p(X,Y), XYs) failed:" ); + System.out.println( "\tExpected: XYs to be a List" ); + System.out.println( "\tGot: " + term ); + System.exit( 1 ); + } + + if ( ! term.equals( test_9_solution ) ){ + System.out.println( "bagof(X-Y, p(X,Y), XYs) failed:" ); + System.out.println( "\tExpected: " + test_9_solution ); + System.out.println( "\tGot: " + term ); + System.exit( 1 ); + } + + System.out.println( "passed." ); + } + + static void + test_10() + { + System.out.print( "test 10..." ); + Query query = + new Query( "t" ); + + try { + boolean b = query.hasSolution(); + System.out.println( "t failed:" ); + System.out.println( "\tExpected: JPLException" ); + System.out.println( "\tGot: " + b ); + System.exit( 1 ); + } catch ( PrologException e ){ + } + + System.out.println( "passed." ); + } + + static void + test_11() + { + System.out.print( "test 11..." ); + Term tuple = + new Compound( + "t", + new Term[]{ + new Atom( "a" ), + new Atom( "b" ), + new Atom( "c" ), + new Atom( "d" ), + new Atom( "e" ) + } + ); + + try { + Variable X = new Variable("X"); + Query query = new Query( "tuple", new Term[] {X} ); + + java.util.Hashtable solution = query.oneSolution(); + + Term result = (Term) solution.get("X"); + + if ( result == null || ! result.equals( tuple ) ){ + System.out.println( "failed:" ); + System.out.println( "\tresult: " + result ); + System.out.println( "\ttuple: " + tuple ); + System.exit( 1 ); + } + + Term term; + + term = new Atom( "a" ); + if ( ((Compound)result).arg( 1 ) == null || !((Compound)result).arg( 1 ).equals( term ) ){ + System.out.println( "failed:" ); + System.out.println( "\t((Compound)result).arg( 1 ): " + ((Compound)result).arg( 1 ) ); + System.out.println( "\tterm : " + term ); + System.exit( 1 ); + } + term = new Atom( "b" ); + if ( ((Compound)result).arg( 2 ) == null || !((Compound)result).arg( 2 ).equals( term ) ){ + System.out.println( "failed:" ); + System.out.println( "\t((Compound)result).arg( 2 ): " + ((Compound)result).arg( 2 ) ); + System.out.println( "\tterm : " + term ); + System.exit( 1 ); + } + term = new Atom( "e" ); + if ( ((Compound)result).arg( 5 ) == null || !((Compound)result).arg( 5 ).equals( term ) ){ + System.out.println( "failed:" ); + System.out.println( "\t((Compound)result).arg( 5 ): " + ((Compound)result).arg( 5 ) ); + System.out.println( "\tterm : " + term ); + System.exit( 1 ); + } + // arg0(6) throws an exception, as I'd expect it to... + // if ( ((Compound)result).arg( 7 ) != null ){ + // System.out.println( "failed:" ); + // System.out.println( "\t((Compound)result).arg( 7 ): " + ((Compound)result).arg( 7 ) ); + // System.out.println( "\tshould be null" ); + // System.exit( 1 ); + // } + } catch ( PrologException e ){ + System.out.println( "failed" ); + e.printStackTrace(); + System.exit( 1 ); + } + + System.out.println( "passed." ); + } + + static void + test_101() + { + System.out.print( "test 101..." ); + Thread[] threads = new Thread[10]; + + for ( int i = 0; i < threads.length; ++i ){ + threads[i] = new QueryThread( i ); + } + for ( int i = 0; i < threads.length; ++i ){ + threads[i].start(); + } + for ( int i = 0; i < threads.length; ++i ){ + try { + threads[i].join(); + } catch ( InterruptedException ie ){ + ie.printStackTrace(); + System.exit( 1 ); + } + } + System.out.println( "passed." ); + } + + private static class + QueryThread extends Thread + { + private int id_ = -1; + + public + QueryThread( int id ) + { + this.id_ = id; + } + + public java.lang.String + toString() + { + return "(QueryThread id=" + id_ + ")"; + } + + + public void + run() + { + Query query = + new Query( + "p", + new Term[] { + new Atom("a"), + new Atom("a") + } + ); + + for ( int i = 0; i < 10; ++i ){ + try { + query.hasSolution(); + } catch ( jpl.JPLException e ){ + System.out.println( "Threaded p( a, a ) threw exception: " + e); + System.exit( 1 ); + } + System.out.print( id_ ); + Thread.yield(); + } + for ( int i = 0; i < 10; ++i ){ + // synchronized ( Query.lock() ){ + try { + while ( query.hasMoreSolutions() ){ + Thread.yield(); + query.nextSolution(); + } + } catch ( jpl.JPLException e ){ + System.out.println( "Threaded p( a, a ) threw exception: " + e); + System.exit( 1 ); + } + System.out.print( id_ ); + // } + } + } + } + + + // more to come?? +} diff --git a/packages/jpl/jpl/examples/java/Test/run.bat b/packages/jpl/jpl/examples/java/Test/run.bat new file mode 100644 index 000000000..7d436db93 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Test.class ( + echo Compiling Test.java + javac Test.java +) + +java Test + +pause diff --git a/packages/jpl/jpl/examples/java/Test/run.sh b/packages/jpl/jpl/examples/java/Test/run.sh new file mode 100755 index 000000000..a0a0ed42c --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Test + diff --git a/packages/jpl/jpl/examples/java/Test/test.pl b/packages/jpl/jpl/examples/java/Test/test.pl new file mode 100644 index 000000000..b9e5f0afd --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test/test.pl @@ -0,0 +1,39 @@ +% a simple database for Test.java +p( a). + +p( f(a)). + +p( a-b). + +p( _X). + + +p( a, a). + +p( a, b). + + +q( f(X,X)). + +q( f(_X,_Y)). + + +r( f(X,X), X). + +r( f(X,X), _Y). + + +s( X, f(X,X)). + +s( _Y, f(X,X)). + + +tuple( t(a,b,c,d,e)). + + +t :- + throw( 'this is an error message'). + +display( X) :- + write( X). + diff --git a/packages/jpl/jpl/examples/java/Test2/.cvsignore b/packages/jpl/jpl/examples/java/Test2/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test2/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Test2/README b/packages/jpl/jpl/examples/java/Test2/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test2/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Test2/Test2.java b/packages/jpl/jpl/examples/java/Test2/Test2.java new file mode 100644 index 000000000..e7679099c --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test2/Test2.java @@ -0,0 +1,26 @@ +//tabstop=4 + +import jpl.*; + +public class Test2 +{ public static int fac(int n) + { if (n == 1) + { return 1; + } else + { return n * ((jpl.Integer) + new Query(new Compound("jpl_test_fac", new Term[] + { new jpl.Integer(n - 1), + new Variable("F") + })).oneSolution().get("F")).intValue(); + } + } + + public static void + main( java.lang.String argv[] ) + { new Query("consult('test2.pl')").oneSolution(); + + System.out.print( "calling Prolog to call Java to call Prolog...\n" ); + + System.out.println( "factorial(10) = " + fac(10)); + } +} diff --git a/packages/jpl/jpl/examples/java/Test2/run.bat b/packages/jpl/jpl/examples/java/Test2/run.bat new file mode 100644 index 000000000..0fc90a4b4 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test2/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Test2.class ( + echo Compiling Test2.java + javac Test2.java +) + +java Test2 + +pause diff --git a/packages/jpl/jpl/examples/java/Test2/run.sh b/packages/jpl/jpl/examples/java/Test2/run.sh new file mode 100755 index 000000000..e1246ecee --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test2/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Test2 + diff --git a/packages/jpl/jpl/examples/java/Test2/test2.pl b/packages/jpl/jpl/examples/java/Test2/test2.pl new file mode 100644 index 000000000..b6c3e2b29 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Test2/test2.pl @@ -0,0 +1,13 @@ +% jpl_test_fac(+N, -F) :- +% F is the factorial of the positive integer N + +:- use_module(library(jpl)). + +jpl_test_fac(N, F) :- + ( N == 1 + -> F = 1 + ; N2 is N-1, + jpl_call('Test2', fac, [N2], F2), + F is N*F2 + ). + diff --git a/packages/jpl/jpl/examples/java/Time/.cvsignore b/packages/jpl/jpl/examples/java/Time/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Time/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Time/README b/packages/jpl/jpl/examples/java/Time/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Time/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Time/Time.java b/packages/jpl/jpl/examples/java/Time/Time.java new file mode 100644 index 000000000..26c34e35c --- /dev/null +++ b/packages/jpl/jpl/examples/java/Time/Time.java @@ -0,0 +1,338 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ + + + +import java.util.Hashtable; +import jpl.Query; // empirically, we need this, but I don't know why... +import jpl.*; + +public class Time +{ + static int tree_depth = 10; + static int num_tests = 5; + static int num_trials = 10; + static long[][] data = null; + static Term tree = null; + static Atom empty_tree = new Atom("t"); + static Timer timer = new Timer(); + + public static void + main( java.lang.String argv[] ) + { + parse_params( argv ); + + JPL.init(); + + run_tests(); + } + + static void + parse_params( java.lang.String argv[] ) + { + int i = 0; + + while ( i < argv.length ){ + if ( argv[i].equals( "-help" ) ){ + print_help(); + System.exit( 1 ); + } else if ( argv[i].equals( "-num_trials" ) ){ + num_trials = java.lang.Integer.valueOf( argv[i+1] ).intValue(); + i += 2; + } else if ( argv[i].equals( "-tree_depth" ) ){ + tree_depth = java.lang.Integer.valueOf( argv[i+1] ).intValue(); + i += 2; + } else { + System.err.println( "Unrecognized option: " + argv[i] ); + print_help(); + System.exit( 1 ); + } + } + data = new long[num_tests][num_trials]; + } + + static void + print_help() + { + System.out.println( + "java Time\n" + + "\t-help print this screen\n" + + "\t-num_trials specify number of trials (default: 10)\n" + + "\t-tree_depth specify depth of binary tree (default: 10)\n" + + "" ); + } + + static void + run_tests() + { + test_0(); + test_1(); + test_2(); + test_3(); + test_4(); + + print_results(); + } + + static void + test_0() + { + System.out.print( "test 0..." ); + Query query = + new Query("consult('time.pl')"); + + if ( !query.hasSolution() ){ + System.out.println( "consult('time.pl') failed" ); + System.exit( 1 ); + } + System.out.println( "passed." ); + + System.out.print( "trees" ); + for ( int i = 0; i < num_trials; ++i ){ + timer.start(); + tree = create_tree(); + timer.stop(); + + data[0][i] = timer.getElapsedTimeInMillis(); + System.out.print( "." ); + } + System.out.println( "done." ); + } + + static void + test_1() + { + Query query = new Query( "traverse", new Term[]{tree} ); + + System.out.print( "traverse" ); + for ( int i = 0; i < num_trials; ++i ){ + + timer.start(); + query.hasSolution(); + timer.stop(); + + data[1][i] = timer.getElapsedTimeInMillis(); + System.out.print( "." ); + } + System.out.println( "done." ); + } + + static void + test_2() + { + Query query = new Query( "noop", new Term[]{tree} ); + + System.out.print( "noop" ); + for ( int i = 0; i < num_trials; ++i ){ + + timer.start(); + java.util.Hashtable solution = query.oneSolution(); + timer.stop(); + + data[2][i] = timer.getElapsedTimeInMillis(); + System.out.print( "." ); + } + System.out.println( "done." ); + } + + static void + test_3() + { + Variable Y = new Variable("Y"); + Query query = new Query( "noop_nobind", new Term[]{tree,Y} ); + + System.out.print( "noop_nobind" ); + for ( int i = 0; i < num_trials; ++i ){ + + timer.start(); + boolean ok = query.hasSolution(); + timer.stop(); + + data[3][i] = timer.getElapsedTimeInMillis(); + System.out.print( "." ); + } + System.out.println( "done." ); + } + + static void + test_4() + { + Variable Y = new Variable("Y"); + Query query = new Query( "noop_bind", new Term[]{tree,Y} ); + + System.out.print( "noop_bind" ); + for ( int i = 0; i < num_trials; ++i ){ + + timer.start(); + java.util.Hashtable solution = query.oneSolution(); + timer.stop(); + + data[4][i] = timer.getElapsedTimeInMillis(); + System.out.print( "." ); + } + System.out.println( "done." ); + } + + static java.text.NumberFormat format = + java.text.NumberFormat.getInstance(); + static { + format.setMaximumFractionDigits(3); + } + + + static void + print_results() + { + long num_terms = (long)(Math.pow( 2, tree_depth ) + 1); + System.out.println(); + System.out.println( "num_trials: " + num_trials ); + System.out.println( "tree_depth: " + tree_depth + + " (= " + num_terms + " terms)" ); + System.out.println(); + + for ( int j = 0; j < num_tests; ++j ){ + System.out.print( "test_" + j + "\t\t" ); + } + System.out.println( "\n" ); + for ( int i = 0; i < num_trials; ++i ){ + for ( int j = 0; j < num_tests; ++j ){ + System.out.print( data[j][i] + "\t\t" ); + } + System.out.println(); + } + System.out.println( "\n" ); + + for ( int j = 0; j < num_tests; ++j ){ + System.out.println( + "test_" + j + ": " + + "avg: " + format.format( avg( j ) ) + "ms\t\t" + + format.format( avg( j )/num_terms ) + "ms/term" + ); + } + } + + static double + avg( int test ) + { + long min = java.lang.Long.MAX_VALUE, + max = java.lang.Long.MIN_VALUE; + + long sum = 0L; + for ( int i = 0; i < num_trials; ++i ){ + sum += data[test][i]; + if ( min < data[test][i] ){ + min = data[test][i]; + } + if ( max > data[test][i] ){ + max = data[test][i]; + } + } + //sum -= (min+max); + + return sum/(num_trials/*-2*/); + } + + + static Term + create_tree() + { + return binary_tree( tree_depth ); + } + + static Term + binary_tree( int depth ) + { + if ( depth <= 0 ){ + return empty_tree; + } else { + return + new Compound( + "t", + new Term[]{ + binary_tree( depth - 1 ), + binary_tree( depth - 1 ) + } + ); + } + } + + + static class Timer + { + private java.util.Calendar calendar = java.util.Calendar.getInstance(); + + private long start_time = 0L, + stop_time = 0L; + + boolean running = false; + + public + Timer() + { + } + + public void + start() + { + if ( !running ){ + start_time = getMillis(); + running = true; + } + } + + private long + getMillis() + { + return System.currentTimeMillis(); + } + + public void + stop() + { + if ( running ){ + stop_time = getMillis(); + running = false; + } + } + + public long + getElapsedTimeInMillis() + { + if ( running ){ + return getMillis() - start_time; + } else { + return stop_time - start_time; + } + } + + public double + getElapsedTimeInSeconds() + { + return getElapsedTimeInMillis()/1000; + } + } +} diff --git a/packages/jpl/jpl/examples/java/Time/run.bat b/packages/jpl/jpl/examples/java/Time/run.bat new file mode 100644 index 000000000..d3a2624b5 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Time/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Time.class ( + echo Compiling Time.java + javac Time.java +) + +java Time + +pause diff --git a/packages/jpl/jpl/examples/java/Time/run.sh b/packages/jpl/jpl/examples/java/Time/run.sh new file mode 100755 index 000000000..e04535e94 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Time/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Time + diff --git a/packages/jpl/jpl/examples/java/Time/time.pl b/packages/jpl/jpl/examples/java/Time/time.pl new file mode 100644 index 000000000..c0101e016 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Time/time.pl @@ -0,0 +1,17 @@ +% a simple database for Time.java + +traverse( []). + +traverse( [H|T]) :- + traverse( H), + traverse( T). + + +noop( _X). + + +noop_nobind( _X, _Y). + + +noop_bind( X, X). + diff --git a/packages/jpl/jpl/examples/java/Versions/.cvsignore b/packages/jpl/jpl/examples/java/Versions/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Versions/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Versions/README b/packages/jpl/jpl/examples/java/Versions/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Versions/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Versions/Versions.java b/packages/jpl/jpl/examples/java/Versions/Versions.java new file mode 100644 index 000000000..70a48a073 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Versions/Versions.java @@ -0,0 +1,41 @@ +import java.util.Hashtable; +import jpl.*; + +public class Versions +{ + public static void + main( String argv[] ) + { + + Compound goal1 = + new Compound("consult", + new Term[] { + new Compound("library", + new Term[] { + new Atom("jpl") } + ) + }); + Query q1 = new Query(goal1); + if ( !q1.hasSolution() ) { + System.out.println( "consult(library(jpl)) failed" ); + return; + } + String prologVersion = ((Term) (new Query("jpl_pl_lib_version(V)")).oneSolution().get("V")).name(); + String javaVersion = jpl.JPL.version_string(); + String cVersion = jpl.fli.Prolog.get_c_lib_version(); + + System.out.println( "prolog library version; " + prologVersion ); + System.out.println( " java library version; " + javaVersion ); + System.out.println( " c library version; " + cVersion ); + + if ( prologVersion.equals(javaVersion) && javaVersion.equals(cVersion) ) { + System.out.println( "BINGO! you appear to have the same version of each library installed"); + } else { + System.out.println( "WHOOPS! you appear not to have the same version of each library installed"); + } + + } + +} + + diff --git a/packages/jpl/jpl/examples/java/Versions/run.bat b/packages/jpl/jpl/examples/java/Versions/run.bat new file mode 100644 index 000000000..f10627d3b --- /dev/null +++ b/packages/jpl/jpl/examples/java/Versions/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Versions.class ( + echo Compiling Versions.java + javac Versions.java +) + +java Versions + +pause diff --git a/packages/jpl/jpl/examples/java/Versions/run.sh b/packages/jpl/jpl/examples/java/Versions/run.sh new file mode 100755 index 000000000..4f36f20d9 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Versions/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Versions + diff --git a/packages/jpl/jpl/examples/java/Zahed/.cvsignore b/packages/jpl/jpl/examples/java/Zahed/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/examples/java/Zahed/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/examples/java/Zahed/README b/packages/jpl/jpl/examples/java/Zahed/README new file mode 100644 index 000000000..be623b89e --- /dev/null +++ b/packages/jpl/jpl/examples/java/Zahed/README @@ -0,0 +1,14 @@ +compile.bat + will compile this demo + +run.bat + will run it + +..\README.txt + may explain what is happening + +---- + +Paul Singleton (paul.singleton@bcs.org.uk) +February 2004 + diff --git a/packages/jpl/jpl/examples/java/Zahed/Zahed.java b/packages/jpl/jpl/examples/java/Zahed/Zahed.java new file mode 100644 index 000000000..e48141b72 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Zahed/Zahed.java @@ -0,0 +1,66 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ + +// calls gen([t(c,q,[]),t(v,[],a)],ANSWER). + +import java.util.Hashtable; +import jpl.*; + +public class Zahed +{ + public static void + main( java.lang.String argv[] ) + { + + Compound goal1 = new Compound("consult", new Term[] { new Atom("zahed.pl") }); + Query q1 = new Query(goal1); + System.out.println( "new query..." ); + if ( !q1.hasSolution() ){ + System.out.println( "failed" ); + System.out.println( "consult('zahed.pl') failed" ); + return; + } + + Term t2 = new Compound("t", new Term[] { new Atom("v"), new Atom("[]"), new Atom("a") }); + Compound list2 = new Compound(".", new Term[] { t2, new Atom("[]") }); + + Compound t1 = new Compound("t", new Term[] { new Atom("c"), new Atom("q"), new Atom("[]") }); + Compound list1 = new Compound(".", new Term[] { t1, list2 }); + + Variable answer = new Variable("A"); + + Compound goal2 = new Compound("gen", new Term[] { list1, answer }); + + Query q2 = new Query(goal2); + Hashtable solution = q2.oneSolution(); + if ( solution == null ) { + System.out.println( "failed" ); + } else { + System.out.println( solution.get("A").toString()); + } + } +} diff --git a/packages/jpl/jpl/examples/java/Zahed/run.bat b/packages/jpl/jpl/examples/java/Zahed/run.bat new file mode 100644 index 000000000..3e02ba55c --- /dev/null +++ b/packages/jpl/jpl/examples/java/Zahed/run.bat @@ -0,0 +1,11 @@ +@echo off +call ..\env.bat + +if not exist Zahed.class ( + echo Compiling Zahed.java + javac Zahed.java +) + +java Zahed + +pause diff --git a/packages/jpl/jpl/examples/java/Zahed/run.sh b/packages/jpl/jpl/examples/java/Zahed/run.sh new file mode 100755 index 000000000..6816c00dc --- /dev/null +++ b/packages/jpl/jpl/examples/java/Zahed/run.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +. ../env.sh + +run Zahed + diff --git a/packages/jpl/jpl/examples/java/Zahed/zahed.pl b/packages/jpl/jpl/examples/java/Zahed/zahed.pl new file mode 100644 index 000000000..4d6b15e16 --- /dev/null +++ b/packages/jpl/jpl/examples/java/Zahed/zahed.pl @@ -0,0 +1,4 @@ +% simple dummy predicate to test Zahed's goal from Java: + +gen( [t(_,_,_),t(_,_,_)], ok). + diff --git a/packages/jpl/jpl/examples/java/env.bat b/packages/jpl/jpl/examples/java/env.bat new file mode 100644 index 000000000..11294566c --- /dev/null +++ b/packages/jpl/jpl/examples/java/env.bat @@ -0,0 +1,21 @@ +@echo off + +REM Set variables needed by the examples +REM This script assumes both the bin directories of SWI-Prolog and the Java +REM SDK to be in %PATH%. If this is not the case, you may wish to set %PATH% +REM in this script. + +REM Find the Prolog coordinates + +swipl.exe -dump-runtime-variables=cmd > %TEMP%\plrtvars.bat +call %TEMP%\plrtvars.bat +del %TEMP%\plrtvars.bat + +REM Find classpath for jpl.jar. First case holds if we are in the source tree. + +if exist ..\..\..\jpl.jar ( + set CLASSPATH=.;..\..\..\jpl.jar +) else ( + set CLASSPATH=.;%PLBASE%\lib\jpl.jar +) + diff --git a/packages/jpl/jpl/examples/java/env.sh b/packages/jpl/jpl/examples/java/env.sh new file mode 100644 index 000000000..32fbeed8f --- /dev/null +++ b/packages/jpl/jpl/examples/java/env.sh @@ -0,0 +1,168 @@ +################################################################ +# Setup the environment for compiling and running the demos on +# Unix like platforms. This script is sourced from the run.sh +# scripts in the various example directories. +# +# You may need to edit this before running the demos +# +# Required setup +# +# * The directory holding java and javac must be in $PATH +# * JPL must be installed +# * Prolog must be available as one of "swi-prolog", "swipl" +# or "pl" in $PATH +# +################################################################ + +findexe() +{ oldifs="$IFS" + IFS=: + for d in $PATH; do + if [ -x $d/$1 ]; then + IFS="$oldifs" + return 0 + fi + done + IFS="$oldifs" + return 1 +} + +if [ "$JPL_COMPILE_ONLY" != "yes" ]; then + for f in swi-prolog swipl pl; do + if [ -z "$PL" ]; then + if findexe $f; then + PL="$f" + fi + fi + done +fi + + +if findexe java; then + true +elif [ -x "$JAVA_HOME"/bin/java ]; then + PATH="$PATH:$JAVA_HOME/bin" +else + echo "ERROR: Cannot find java. Please ensure JAVA_HOME is set" + echo "ERROR: properly or java is in $PATH" + exit 1 +fi + +if findexe javac; then + true +else + echo "ERROR: Cannot find javac. This demo requires the SDK to" + echo "ERROR: be installed and accessible through JAVA_HOME" + echo "ERROR: or PATH" + exit 1 +fi + +################################################################ +# Setup the environment +################################################################ + +EXEC="$PL" +eval `eval $PL -dump-runtime-variables` + +if [ -z "$PLBASE" ]; then + PLLIBDIR="$YAP_ROOTDIR/lib/Yap" + if [ -z "$JPLJAR" ]; then + JPLJAR="$YAP_ROOTDIR/share/Yap/jpl/jpl.jar" + fi +else + PLLIBDIR="$PLBASE/lib/$PLARCH" +fi + +if [ -z "$JPLJAR" ]; then + JPLJAR="$PLBASE/lib/jpl.jar" +fi + +if [ -z "$LD_LIBRARY_PATH" ]; then + LD_LIBRARY_PATH="$PLLIBDIR"; +else + LD_LIBRARY_PATH="$LD_LIBRARY_PATH:$PLLIBDIR" +fi + +if [ -z "$CLASSPATH" ]; then + CLASSPATH=".:$JPLJAR"; +else + CLASSPATH=".:$JPLJAR:$CLASSPATH" +fi + +export LD_LIBRARY_PATH CLASSPATH + +################################################################ +# compile Class +# +# Compile the indicated class if necessary +################################################################ + +compile() +{ if test -z $CLASSDIR; then + CLASSDIR="." + fi + if [ ! -f $CLASSDIR/$1.class ]; then + echo "Compiling $1" + javac $1.java -d $CLASSDIR + elif [ $1.java -nt $CLASSDIR/$1.class ]; then + echo "Recompiling $1" + javac $1.java -d $CLASSDIR + fi +} + + +################################################################ +# run Class +# +# Compiles Class if the .class file does not exsist and runs it +# Note that some systems (Linux, ...) find the libjpl.xxx from +# LD_LIBRARY_PATH. MacOS finds this only when named libjpl.jnilib +# and using -Djava.library.path=. We pass both, hoping to +# satisfy most systems ... +################################################################ + +run() +{ compile $1 + + if [ "$JPL_COMPILE_ONLY" != "yes" ]; then + echo "" + echo "JPL demo: $1" + echo "" + + java -Djava.library.path=$PLLIBDIR $1 + + fi +} + +################################################################ +# run_preloaded Class +# +# As run Class, but preloads libjpl.so to be able to use foreign +# extensions to Prolog. See the SemWeb example +# +# This isn't needed for installations using SWI-Prolog through +# the libpl.$PLSOEXT shared object. For the moment this is only +# MacOS, which ignores LD_PRELOAD, so we'll ignore this issue for +# the moment +################################################################ + +run_preloaded() +{ compile $1 + + if [ "$JPL_COMPILE_ONLY" != "yes" ]; then + + if [ -z "$PLBASE" ]; then + JPLSO="$YAP_ROOTDIR/lib/Yap/libjpl.$YAP_SHLIB_SUFFIX $YAP_ROOTDIR/lib/libYap.$YAP_SHLIB_SUFFIX" + else + JPLSO="$PLBASE/lib/$PLARCH/libjpl.$PLSOEXT" + fi + + echo "" + echo "JPL demo: $1" + echo "Using preloaded $JPLSO" + echo "" + + + env LD_PRELOAD="$JPLSO" java -Djava.library.path=$PLLIBDIR $1 + fi +} diff --git a/packages/jpl/jpl/examples/prolog/README b/packages/jpl/jpl/examples/prolog/README new file mode 100644 index 000000000..7ab8a9400 --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/README @@ -0,0 +1,16 @@ +Each .pl file in this folder contains the Prolog source text +of a simple demonstration of JPL in action calling Java from +Prolog. + +Each file contains one or more predicate definitions, then +a directive to run the demo. + +Consulting a file, either by double-clicking it from Windows +Explorer (if you have a default SWI-Prolog installation) or +by e.g. + + ?- [jpl_versions_demo]. + +from the Prolog top-level prompt, will consult and then run +the demo. + diff --git a/packages/jpl/jpl/examples/prolog/jpl_colour_choose_demo.pl b/packages/jpl/jpl/examples/prolog/jpl_colour_choose_demo.pl new file mode 100644 index 000000000..fa6754c3c --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/jpl_colour_choose_demo.pl @@ -0,0 +1,26 @@ +% shoes a JColorChooser dialog, on top of a (necessary) JFrame, +% and awaits OK/Cancel click + +:- use_module(library(jpl)). + +jpl_colour_choose_demo :- + jpl_new( 'javax.swing.JFrame', ['frame with dialog'], F), + jpl_call( F, setLocation, [400,300], _), + jpl_call( F, setSize, [400,300], _), + jpl_call( F, setVisible, [@(true)], _), + jpl_call( F, toFront, [], _), + jpl_call( F, getContentPane, [], CP), + jpl_get( 'java.awt.Color', pink, Pink), + jpl_call( 'javax.swing.JColorChooser', showDialog, [CP,'pick a colo(u)r',Pink], C), + jpl_call( F, dispose, [], _), + ( C == @(null) + -> write( 'you cancelled') + ; write( 'you chose '), write( C) + ), + nl. + + +% this directive runs the above demo + +:- jpl_colour_choose_demo. + diff --git a/packages/jpl/jpl/examples/prolog/jpl_jlist_demo.pl b/packages/jpl/jpl/examples/prolog/jpl_jlist_demo.pl new file mode 100644 index 000000000..8385b6cd9 --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/jpl_jlist_demo.pl @@ -0,0 +1,23 @@ +:- use_module(library(jpl)). + +jpl_jlist_demo :- + jpl_new( 'javax.swing.JFrame', ['modules'], F), + jpl_new( 'javax.swing.DefaultListModel', [], DLM), + jpl_new( 'javax.swing.JList', [DLM], L), + jpl_call( F, getContentPane, [], CP), + jpl_call( CP, add, [L], _), + ( current_module( M), + jpl_call( DLM, addElement, [M], _), + fail + ; true + ), + jpl_call( F, pack, [], _), + jpl_call( F, getHeight, [], H), + jpl_call( F, setSize, [150,H], _), + jpl_call( F, setVisible, [@(true)], _). + + +% this directive runs the above demo + +:- jpl_jlist_demo. + diff --git a/packages/jpl/jpl/examples/prolog/jpl_midi_demo.pl b/packages/jpl/jpl/examples/prolog/jpl_midi_demo.pl new file mode 100644 index 000000000..e90eaef74 --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/jpl_midi_demo.pl @@ -0,0 +1,36 @@ +:- use_module(library(jpl)). + +:- if(current_prolog_flag(dialect, yap)). +sleep(T) :- unix(sleep(T)). +:- endif. + +jpl_midi_demo :- + jpl_midi_demo( 20). % play 20 random notes + + +jpl_midi_demo( N) :- + jpl_call( 'javax.sound.midi.MidiSystem', getSynthesizer, [], Synth), + jpl_call( Synth, open, [], _), + jpl_call( Synth, getChannels, [], Channels), + jpl_get( Channels, 0, Channel0), % i.e. Channel0 = Channels[0] + jpl_midi_demo( N, Channel0), + jpl_call( Synth, close, [], _). + + +jpl_midi_demo( N, Channel) :- + ( N @> 0 + -> Note is 50+random(50), % see MIDI docs for pitch relationship + Velocity is 100, % arbitrary value > 0 + jpl_call( Channel, noteOn, [Note,Velocity], _), + sleep( 0.5), % play note for approx 0.5 seconds + jpl_call( Channel, noteOff, [Note], _), + Nx is N-1, + jpl_midi_demo( Nx, Channel) % play remaining notes + ; true + ). + + +% this directive runs the above demo + +:- jpl_midi_demo. + diff --git a/packages/jpl/jpl/examples/prolog/jpl_table_demo.pl b/packages/jpl/jpl/examples/prolog/jpl_table_demo.pl new file mode 100644 index 000000000..0d7294c17 --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/jpl_table_demo.pl @@ -0,0 +1,30 @@ +:- use_module(library(jpl)). + +% jpl_table_demo :- +% displays the names and values of all current Prolog flags +% in a new JTable (within a new JScrollPane, within a new JFrame) + +jpl_table_demo :- + findall( + Ar, + ( current_prolog_flag( N, V), % assume atom(N) + term_to_atom( V, Va), + jpl_list_to_array( [N,Va], Ar) % or jpl_new( '[Ljava.lang.String;', [N,Va], Ar) + ), + Ars + ), + jpl_list_to_array( Ars, Ac), % or jpl_new( '[[Ljava.lang.String;', Ars, Ac) + jpl_list_to_array( [name,value], Ah), + jpl_new( 'javax.swing.JFrame', ['current_prolog_flag'], F), + jpl_call( F, getContentPane, [], CP), + jpl_new( 'javax.swing.JTable', [Ac,Ah], T), + jpl_new( 'javax.swing.JScrollPane', [T], SP), + jpl_call( CP, add, [SP,'Center'], _), + jpl_call( F, setSize, [600,400], _), + jpl_call( F, setVisible, [@(true)], _). + + +% this directive runs the above demo + +:- jpl_table_demo. + diff --git a/packages/jpl/jpl/examples/prolog/jpl_text_entry_demo.pl b/packages/jpl/jpl/examples/prolog/jpl_text_entry_demo.pl new file mode 100644 index 000000000..f1d7f09dd --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/jpl_text_entry_demo.pl @@ -0,0 +1,24 @@ +:- use_module(library(jpl)). + +% shows a JOptionPane dialog, on top of a (necessary) new JFrame, +% and awaits text entry and OK/Cancel button click + +jpl_text_entry_demo :- + jpl_new( 'javax.swing.JFrame', ['frame with dialog'], F), + jpl_call( F, setLocation, [400,300], _), + jpl_call( F, setSize, [400,300], _), + jpl_call( F, setVisible, [@(true)], _), + jpl_call( F, toFront, [], _), + jpl_call( 'javax.swing.JOptionPane', showInputDialog, [F,'type your name'], N), + jpl_call( F, dispose, [], _), + ( N == @(null) + -> write( 'you cancelled') + ; write( 'you typed '), write( N) + ), + nl. + + +% this directive runs the above demo + +:- jpl_text_entry_demo. + diff --git a/packages/jpl/jpl/examples/prolog/jpl_versions_demo.pl b/packages/jpl/jpl/examples/prolog/jpl_versions_demo.pl new file mode 100644 index 000000000..5db53a2ab --- /dev/null +++ b/packages/jpl/jpl/examples/prolog/jpl_versions_demo.pl @@ -0,0 +1,23 @@ +:- use_module(library(jpl)). + +jpl_versions_demo :- + jpl_call( 'jpl.JPL', version_string, [], Vj), + jpl_c_lib_version( Vc), + jpl_pl_lib_version( Vp), + + nl, + write( 'prolog library version: '), write( Vp), nl, + write( ' java library version: '), write( Vj), nl, + write( ' c library version: '), write( Vc), nl, + ( Vp == Vj, + Vj == Vc + -> write( 'BINGO! you appear to have the same version of each library installed'), nl + ; write( 'WHOOPS! you appear not to have the same version of each library installed'), nl + ), + nl. + + +% this directive runs the above demo + +:- jpl_versions_demo. + diff --git a/packages/jpl/jpl/install-sh b/packages/jpl/jpl/install-sh new file mode 100755 index 000000000..ab74c882e --- /dev/null +++ b/packages/jpl/jpl/install-sh @@ -0,0 +1,238 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +tranformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/packages/jpl/jpl/jpl.doc b/packages/jpl/jpl/jpl.doc new file mode 100644 index 000000000..6c06c5011 --- /dev/null +++ b/packages/jpl/jpl/jpl.doc @@ -0,0 +1,63 @@ +\documentclass[11pt]{article} +\usepackage{times} +\usepackage{pl} +\usepackage{html} +\sloppy +\makeindex + +\onefile +\htmloutput{html} % Output directory +\htmlmainfile{index} % Main document file +\bodycolor{white} % Page colour + +\begin{document} + +\title{JPL: a SWI-Prolog to Java Interface} +\author{Paul Singleton \\ + Jambusters Ltd \\ + United Kingdom \\ + E-mail: \email{paul@jbgb.com}} + +\maketitle + +\begin{abstract} +This document describes JPL, the SWI-Prolog interface to Java. +\end{abstract} + +\pagebreak +\tableofcontents +\pagebreak + +\section{Introduction} + +\section{Installation} + +\subsection{Unix systems} + +Installation on Unix system uses the commonly found {\em configure}, +{\em make} and {\em make install} sequence. SWI-Prolog should be +installed before building this package. If SWI-Prolog is not installed +as \program{pl}, the environment variable \env{PL} must be set to the +name of the SWI-Prolog executable. Installation is now accomplished +using: + +\begin{code} +% ./configure +% make +% make install +\end{code} + +This installs the foreign libraries in \file{$PLBASE/lib/$PLARCH} and +the Prolog library files in \file{$PLBASE/library}, where +\file{$PLBASE} refers to the SWI-Prolog `home-directory'. + + +\section{Acknowledgments} + +\bibliographystyle{plain} +\bibliography{odbc} + +\printindex + +\end{document} + diff --git a/packages/jpl/jpl/jpl.pl b/packages/jpl/jpl/jpl.pl new file mode 100644 index 000000000..208506f4f --- /dev/null +++ b/packages/jpl/jpl/jpl.pl @@ -0,0 +1,4715 @@ +/* $Id$ + + Part of JPL -- SWI-Prolog/Java interface + + Author: Paul Singleton, Fred Dushin and Jan Wielemaker + E-mail: paul@jbgb.com + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2004, Paul Singleton + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(jpl, + [ jpl_get_default_jvm_opts/1, + jpl_set_default_jvm_opts/1, + jpl_get_actual_jvm_opts/1, + jpl_pl_lib_version/1, + jpl_c_lib_version/1, + jpl_new/3, + jpl_call/4, + jpl_get/3, + jpl_set/3, + jpl_servlet_byref/3, + jpl_servlet_byval/3, + jpl_class_to_classname/2, + jpl_class_to_type/2, + jpl_classname_to_class/2, + jpl_classname_to_type/2, + jpl_datum_to_type/2, + jpl_false/1, + jpl_is_class/1, + jpl_is_false/1, + jpl_is_null/1, + jpl_is_object/1, + jpl_is_object_type/1, + jpl_is_ref/1, + jpl_is_true/1, + jpl_is_type/1, + jpl_is_void/1, + jpl_null/1, + jpl_object_to_class/2, + jpl_object_to_type/2, + jpl_primitive_type/1, + jpl_ref_to_type/2, + jpl_true/1, + jpl_type_to_class/2, + jpl_type_to_classname/2, + jpl_void/1, + jpl_array_to_length/2, + jpl_array_to_list/2, + jpl_datums_to_array/2, + jpl_enumeration_element/2, + jpl_enumeration_to_list/2, + jpl_hashtable_pair/2, + jpl_iterator_element/2, + jpl_list_to_array/2, + % introduced by vsc + jpl_list_to_array/3, + % end of introduced by vsc + jpl_terms_to_array/2, + jpl_map_element/2, + jpl_set_element/2 + ]). + +:- expects_dialect(swi). + +:- use_module(library(lists)). +:- use_module(library(apply)). +:- use_module(library(shlib)). + +% suppress debugging this library +:- set_prolog_flag(generate_debug_info, false). + +%------------------------------------------------------------------------------ + +jpl_get_default_jvm_opts( Opts) :- + jni_get_default_jvm_opts( Opts). + +%------------------------------------------------------------------------------ + +jpl_set_default_jvm_opts( Opts) :- + is_list( Opts), + length( Opts, N), + jni_set_default_jvm_opts( N, Opts). + +%------------------------------------------------------------------------------ + +jpl_get_actual_jvm_opts( Opts) :- + jni_get_actual_jvm_opts( Opts). + +%------------------------------------------------------------------------------ + +jpl_assert( Fact) :- + ( jpl_assert_policy( Fact, yes) + -> assert( Fact) + ; true + ). + +%------------------------------------------------------------------------------ + +jpl_assert_policy( jpl_field_spec_cache(_,_,_,_,_,_), yes). +jpl_assert_policy( jpl_method_spec_cache(_,_,_,_,_,_,_,_), yes). +jpl_assert_policy( jpl_class_tag_type_cache(_,_), yes). +jpl_assert_policy( jpl_classname_type_cache(_,_), yes). +jpl_assert_policy( jpl_iref_type_cache(_,_), no). % must correspond to JPL_CACHE_TYPE_OF_REF in jpl.c + +jpl_assert_policy( jpl_field_spec_is_cached(_), YN) :- + jpl_assert_policy( jpl_field_spec_cache(_,_,_,_,_,_), YN). +jpl_assert_policy( jpl_method_spec_is_cached(_), YN) :- + jpl_assert_policy( jpl_method_spec_cache(_,_,_,_,_,_,_,_), YN). + +%------------------------------------------------------------------------------ + +% jpl_tidy_iref_type_cache( +Iref) :- +% delete the cached type info, if any, under Iref; +% called from jpl.c's jni_free_iref() via jni_tidy_iref_type_cache() + +jpl_tidy_iref_type_cache( Iref) :- + % write( '[decaching types for iref='), write( Iref), write( ']'), nl, + retractall( jpl_iref_type_cache(Iref,_)), + true. + +%------------------------------------------------------------------------------ + +% jpl_call(+X, +MethodSpec, +Params, -Result) :- +% X should be: +% an object reference +% (for static or instance methods) +% a classname, descriptor or type +% (for static methods of the denoted class) +% +% MethodSpec should be: +% a method name (as an atom) +% (may involve dynamic overload resolution based on inferred types of params) +% +% Params should be: +% a proper list (perhaps empty) of suitable actual parameters for the named method +% +% finally, an attempt will be made to unify Result with the returned result + +jpl_call(X, Mspec, Params, R) :- + ( jpl_object_to_type(X, Type) % the usual case (goal fails safely if X is var or rubbish) + -> Obj = X, + Kind = instance + ; var(X) + -> throw(error(instantiation_error, + context(jpl_call/4, + '1st arg must be bound to an object, classname, descriptor or type'))) + ; atom(X) + -> ( jpl_classname_to_type( X, Type) % does this attempt to load the class? + -> ( jpl_type_to_class( Type, ClassObj) + -> Kind = static + ; throw(error(existence_error(class,X), + context(jpl_call/4, + 'the named class cannot be found'))) + ) + ; throw(error(type_error(class_name_or_descriptor,X), + context(jpl_call/4, '1st arg must be an object, classname, descriptor or type'))) + ) + ; X = class(_,_) + -> Type = X, + jpl_type_to_class( Type, ClassObj), + Kind = static + ; X = array(_) + -> throw(error(type_error(object_or_class,X), + context(jpl_call/4, 'cannot call a static method of an array type, as none exists'))) + ; throw(error(domain_error(object_or_class,X), + context(jpl_call/4, + '1st arg must be an object, classname, descriptor or type'))) + ), + ( atom(Mspec) % the usual case, i.e. a method name + -> true + ; var(Mspec) + -> throw(error(instantiation_error, + context(jpl_call/4, '2nd arg must be an atom naming a public method of the class or object'))) + ; throw(error(type_error(method_name,Mspec), + context(jpl_call/4, '2nd arg must be an atom naming a public method of the class or object'))) + ), + ( is_list(Params) + -> ( catch( + jpl_datums_to_types(Params, Taps), + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_call/4,Msg))) + ) + -> true + ; throw(error(type_error(method_params,Params), + context(jpl_call/4, 'not all actual parameters are convertible to Java values or references'))) + ), + length( Params, A) + ; var(Params) + -> throw(error(instantiation_error, + context(jpl_call/4, '3rd arg must be a proper list of actual parameters for the named method'))) + ; throw(error(type_error(method_params,Params), + context(jpl_call/4, '3rd arg must be a proper list of actual parameters for the named method'))) + ), + ( Kind == instance + -> jpl_call_instance(Type, Obj, Mspec, Params, Taps, A, Rx) + ; jpl_call_static(Type, ClassObj, Mspec, Params, Taps, A, Rx) + ), + ( nonvar(R), + R = {Term} % yucky way of requesting Term->term conversion + -> ( jni_jref_to_term( Rx, TermX) % fails if Rx isn't a JRef to a jpl.Term + -> Term = TermX + ; throw(error(type_error, + context(jpl_call/4, 'result is not a jpl.Term instance as required'))) + ) + ; R = Rx + ). + +%------------------------------------------------------------------------------ + +%% jpl_call_instance(+ObjectType, +Object, +MethodName, Params, +%% ActualParamTypes, Arity, -Result) +% +% call the MethodName-d method (instance or static) of Object +% (which is of ObjectType), which most specifically applies to +% Params, which we have found to be (respectively) of +% ActualParamTypes, and of which there are Arity, yielding Result + +jpl_call_instance(Type, Obj, Mname, Params, Taps, A, Rx) :- + findall( % get remaining details of all accessible methods of Obj's class (as denoted by Type) + z5(I,Mods,MID,Tr,Tfps), + jpl_method_spec(Type, I, Mname, A, Mods, MID, Tr, Tfps), + Z5s + ), + ( Z5s = [] + -> throw(error(existence_error(method,Mname/A), + context(jpl_call/4, + 'the class or object has no public methods with the given name and quantity of parameters'))) + ; findall( + z5(I,Mods,MID,Tr,Tfps), % those to which Params is assignable + ( member(z5(I,Mods,MID,Tr,Tfps), Z5s), + jpl_types_fit_types(Taps, Tfps) % assignability test: actual param types "fit" formal param types + ), + Z5sA % Params-assignable methods + ), + ( Z5sA == [] + -> throw(error(type_error(method_params,Params), + context(jpl_call/4, + 'the actual parameters are not assignable to the formal parameters of any of the named methods'))) + + ; Z5sA = [z5(I,Mods,MID,Tr,Tfps)] + -> true % exactly one applicable method + ; jpl_z5s_to_most_specific_z5(Z5sA, z5(I,Mods,MID,Tr,Tfps)) + -> true % exactly one most-specific applicable method + ; throw(error(existence_error(most_specific_method,Mname/Params), + context(jpl_call/4, + 'more than one most-specific method is found for the actual parameters (this should not happen)'))) + ) + ), + ( member(static, Mods) % if the chosen method is static + -> jpl_object_to_class(Obj, ClassObj), % get a java.lang.Class instance which personifies Obj's class + jpl_call_static_method(Tr, ClassObj, MID, Tfps, Params, Rx) % call static method w.r.t. associated Class object + ; jpl_call_instance_method(Tr, Obj, MID, Tfps, Params, Rx) % else call (non-static) method w.r.t. object itself + ). + +%------------------------------------------------------------------------------ + +%% jpl_call_static(+ClassType, +ClassObject, +MethodName, Params, +%% ActualParamTypes, Arity, -Result) +% +% call the MethodName-d static method of the class (which is of +% ClassType, and which is represented by the java.lang.Class +% instance ClassObject) which most specifically applies to Params, +% which we have found to be (respectively) of ActualParamTypes, +% and of which there are Arity, yielding Result + +jpl_call_static(Type, ClassObj, Mname, Params, Taps, A, Rx) :- + findall( % get all accessible static methods of the class denoted by Type and ClassObj + z5(I,Mods,MID,Tr,Tfps), + ( jpl_method_spec(Type, I, Mname, A, Mods, MID, Tr, Tfps), + member(static, Mods) + ), + Z5s + ), + ( Z5s = [] + -> throw(error(existence_error(method,Mname/A), + context(jpl_call/4, + 'the class has no public static methods with the given name and quantity of parameters'))) + ; findall( + z5(I,Mods,MID,Tr,Tfps), + ( member(z5(I,Mods,MID,Tr,Tfps), Z5s), + jpl_types_fit_types(Taps, Tfps) % assignability test: actual param types "fit" formal param types + ), + Z5sA % Params-assignable methods + ), + ( Z5sA == [] + -> throw(error(type_error(method_params,Params), + context(jpl_call/4, + 'the actual parameters are not assignable to the formal parameters of any of the named methods'))) + ; Z5sA = [z5(I,Mods,MID,Tr,Tfps)] + -> true % exactly one applicable method + ; jpl_z5s_to_most_specific_z5(Z5sA, z5(I,Mods,MID,Tr,Tfps)) + -> true % exactly one most-specific applicable method + ; throw(error(existence_error(most_specific_method,Mname/Params), + context(jpl_call/4, + 'more than one most-specific method is found for the actual parameters (this should not happen)'))) + ) + ), + jpl_call_static_method(Tr, ClassObj, MID, Tfps, Params, Rx). + +%------------------------------------------------------------------------------ + +% jpl_call_instance_method(+Type, +ClassObject, +MethodID, +FormalParamTypes, +Params, -Result) :- + +jpl_call_instance_method(void, Class, MID, Tfps, Ps, R) :- + jCallVoidMethod(Class, MID, Tfps, Ps), + jpl_void(R). + +jpl_call_instance_method(boolean, Class, MID, Tfps, Ps, R) :- + jCallBooleanMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(byte, Class, MID, Tfps, Ps, R) :- + jCallByteMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(char, Class, MID, Tfps, Ps, R) :- + jCallCharMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(short, Class, MID, Tfps, Ps, R) :- + jCallShortMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(int, Class, MID, Tfps, Ps, R) :- + jCallIntMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(long, Class, MID, Tfps, Ps, R) :- + jCallLongMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(float, Class, MID, Tfps, Ps, R) :- + jCallFloatMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(double, Class, MID, Tfps, Ps, R) :- + jCallDoubleMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(array(_), Class, MID, Tfps, Ps, R) :- + jCallObjectMethod(Class, MID, Tfps, Ps, R). + +jpl_call_instance_method(class(_,_), Class, MID, Tfps, Ps, R) :- + jCallObjectMethod(Class, MID, Tfps, Ps, R). + +%------------------------------------------------------------------------------ + +% jpl_call_static_method(+Type, +ClassObject, +MethodID, +FormalParamTypes, +Params, -Result) :- + +jpl_call_static_method(void, Class, MID, Tfps, Ps, R) :- + jCallStaticVoidMethod(Class, MID, Tfps, Ps), + jpl_void(R). + +jpl_call_static_method(boolean, Class, MID, Tfps, Ps, R) :- + jCallStaticBooleanMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(byte, Class, MID, Tfps, Ps, R) :- + jCallStaticByteMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(char, Class, MID, Tfps, Ps, R) :- + jCallStaticCharMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(short, Class, MID, Tfps, Ps, R) :- + jCallStaticShortMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(int, Class, MID, Tfps, Ps, R) :- + jCallStaticIntMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(long, Class, MID, Tfps, Ps, R) :- + jCallStaticLongMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(float, Class, MID, Tfps, Ps, R) :- + jCallStaticFloatMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(double, Class, MID, Tfps, Ps, R) :- + jCallStaticDoubleMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(array(_), Class, MID, Tfps, Ps, R) :- + jCallStaticObjectMethod(Class, MID, Tfps, Ps, R). + +jpl_call_static_method(class(_,_), Class, MID, Tfps, Ps, R) :- + jCallStaticObjectMethod(Class, MID, Tfps, Ps, R). + +%------------------------------------------------------------------------------ + +%type jpl_fergus_find_candidate(list(T), T, T, list(T)) + +jpl_fergus_find_candidate([], Candidate, Candidate, []). + +jpl_fergus_find_candidate([X|Xs], Candidate0, Candidate, Rest) :- + ( jpl_fergus_greater(X, Candidate0) + -> Candidate1 = X, + Rest = [Candidate0|Rest1] + ; Candidate1 = Candidate0, + Rest = [X|Rest1] + ), + jpl_fergus_find_candidate(Xs, Candidate1, Candidate, Rest1). + +%------------------------------------------------------------------------------ + +jpl_fergus_greater(z5(_,_,_,_,Tps1), z5(_,_,_,_,Tps2)) :- + jpl_types_fit_types(Tps1, Tps2). +jpl_fergus_greater(z3(_,_,Tps1), z3(_,_,Tps2)) :- + jpl_types_fit_types(Tps1, Tps2). + +%------------------------------------------------------------------------------ + +%type jpl_fergus_is_the_greatest(list(T), T) + +%% jpl_fergus_is_the_greatest(Xs, GreatestX) +% +% Xs is a list of things for which jpl_fergus_greater/2 defines a +% partial ordering; GreatestX is one of those, than which none is +% greater; fails if there is more than one such; this algorithm +% was contributed to c.l.p by Fergus Henderson in response to my +% "there must be a better way" challenge: there was, this is it + +jpl_fergus_is_the_greatest([X|Xs], Greatest) :- + jpl_fergus_find_candidate(Xs, X, Greatest, Rest), + forall( + member(R, Rest), + jpl_fergus_greater(Greatest, R) + ). + +%------------------------------------------------------------------------------ + +%% jpl_get(+X, +Fspec, -V) +% +% X can be: +% * a classname, a descriptor, or an (object or array) type +% (for static fields); +% * a non-array object +% (for static and non-static fields) +% * an array +% (for 'length' pseudo field, or indexed element retrieval), +% but not: +% * a String +% (clashes with class name; anyway, String has no fields to retrieve) +% +% Fspec can be: +% * an atomic field name, +% * or an integral array index (to get an element from an array, +% * or a pair I-J of integers (to get a subrange (slice?) of an +% array) +% +% finally, an attempt will be made to unify V with the retrieved value + +jpl_get(X, Fspec, V) :- + ( jpl_object_to_type(X, Type) + -> Obj = X, + jpl_get_instance( Type, Type, Obj, Fspec, Vx) % pass Type twice for FAI + ; var(X) + -> throw(error(instantiation_error, + context(jpl_get/3, + '1st arg must be bound to an object, classname, descriptor or type'))) + ; jpl_is_type(X) % e.g. class([java,lang],['String']), array(int) + -> Type = X, + ( jpl_type_to_class(Type, ClassObj) + -> jpl_get_static( Type, ClassObj, Fspec, Vx) + ; jpl_type_to_classname( Type, Classname), + throw(error(existence_error(class,Classname), + context(jpl_get/3, + 'the named class cannot be found'))) + ) + ; atom(X) + -> ( jpl_classname_to_type( X, Type) % does this attempt to load the class? + -> ( jpl_type_to_class( Type, ClassObj) + -> jpl_get_static( Type, ClassObj, Fspec, Vx) + ; throw(error(existence_error(class,X), + context(jpl_get/3, + 'the named class cannot be found'))) + ) + ; throw(error(type_error(class_name_or_descriptor,X), + context(jpl_get/3, '1st arg must be an object, classname, descriptor or type'))) + ) + + ; throw(error(domain_error(object_or_class,X), + context(jpl_get/3, + '1st arg must be bound to an object, classname, descriptor or type'))) + ), + ( nonvar(V), + V = {Term} % yucky way of requesting Term->term conversion + -> ( jni_jref_to_term( Vx, TermX) % fails if Rx is not a JRef to a jpl.Term + -> Term = TermX + ; throw(error(type_error, + context(jpl_call/4, 'result is not a jpl.Term instance as required'))) + ) + ; V = Vx + ). + +%------------------------------------------------------------------------------ + +%% jpl_get_static(+Type, +ClassObject, +FieldName, -Value) +% +% ClassObject is an instance of java.lang.Class which represents +% the same class as Type; Value (Vx below) is guaranteed unbound +% on entry, and will, before exit, be unified with the retrieved +% value + +jpl_get_static(Type, ClassObj, Fname, Vx) :- + ( atom(Fname) % assume it's a field name + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_get/3, '2nd arg must be bound to an atom naming a public field of the class'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_get/3, '2nd arg must be an atom naming a public field of the class'))) + ), + % get static fields of the denoted class + findall( + z4(I,Mods,FID,Tf), + ( jpl_field_spec(Type, I, Fname, Mods, FID, Tf), + member(static, Mods) + ), + Z4s + ), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_get/3, + 'the class or object has no public static field with the given name'))) + ; Z4s = [z4(I,_Mods,FID,Tf)] + -> jpl_get_static_field(Tf, ClassObj, FID, Vx) + ; throw(error(existence_error(unique_field,Fname), + context(jpl_get/3, + 'more than one field is found with the given name'))) + ). + +%------------------------------------------------------------------------------ + +% jpl_get_instance(+Type, +Type, +Object, +FieldSpecifier, -Value) :- + +jpl_get_instance(class(_,_), Type, Obj, Fname, Vx) :- + ( atom(Fname) % the usual case + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_get/3, '2nd arg must be bound to an atom naming a public field of the class or object'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_get/3, '2nd arg must be an atom naming a public field of the class or object'))) + ), + findall(z4(I,Mods,FID,Tf), + jpl_field_spec(Type, I, Fname, Mods, FID, Tf), + Z4s), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_get/3, + 'the class or object has no public field with the given name'))) + ; Z4s = [z4(I,Mods,FID,Tf)] + -> ( member(static, Mods) + -> jpl_object_to_class(Obj, ClassObj), + jpl_get_static_field(Tf, ClassObj, FID, Vx) + ; jpl_get_instance_field(Tf, Obj, FID, Vx) + ) + ; throw(error(existence_error(unique_field,Fname), + context(jpl_get/3, + 'more than one field is found with the given name'))) + ). + +jpl_get_instance(array(ElementType), _, Array, Fspec, Vx) :- + ( var(Fspec) + -> throw(error(instantiation_error, + context(jpl_get/3, + 'when 1st arg is an array, 2nd arg must be bound to an index, an index range, or ''length'''))) + ; integer(Fspec) + -> ( Fspec < 0 % lo bound check + -> throw(error(domain_error(array_index,Fspec), + context(jpl_get/3, + 'when 1st arg is an array, integral 2nd arg must be non-negative'))) + ; jGetArrayLength(Array, Len), + Fspec >= Len % hi bound check + -> throw(error(domain_error(array_index,Fspec), + context(jpl_get/3, + 'when 1st arg is an array, integral 2nd arg must not exceed upper bound of array'))) + ; jpl_get_array_element(ElementType, Array, Fspec, Vx) + ) + ; Fspec = N-M % NB should we support e.g. 3-2 -> [] ? + -> ( integer(N), + integer(M) + -> ( N >= 0, + M >= N + -> jGetArrayLength(Array, Len), + ( N >= Len + -> throw(error(domain_error(array_index_range,N-M), + context(jpl_get/3, + 'lower bound of array index range must not exceed upper bound of array'))) + ; M >= Len + -> throw(error(domain_error(array_index_range,N-M), + context(jpl_get/3, + 'upper bound of array index range must not exceed upper bound of array'))) + ; jpl_get_array_elements(ElementType, Array, N, M, Vx) + ) + ; throw(error(domain_error(array_index_range,N-M), + context(jpl_get/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; throw(error(type_error(array_index_range,N-M), + context(jpl_get/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; atom(Fspec) + -> ( Fspec == length % special-case for this solitary array "method" + -> jGetArrayLength(Array, Vx) + ; throw(error(domain_error(array_field_name,Fspec), + context(jpl_get/3, + 'the array has no public field with the given name'))) + ) + ; throw(error(type_error(array_lookup_spec,Fspec), + context(jpl_get/3, + 'when 1st arg is an array, 2nd arg must be an index, an index range, or ''length'''))) + ). + +%------------------------------------------------------------------------------ + +%% jpl_get_array_element(+ElementType, +Array, +Index, -Vc) +% +% Array is (a reference to) an array of ElementType; Vc is +% (unified with a JPL repn of) its Index-th (numbered from 0) +% element Java values are now converted to Prolog terms within +% foreign code +% +% @tbd more of this could be done within foreign code ... + +jpl_get_array_element(Type, Array, Index, Vc) :- + ( ( Type = class(_,_) + ; Type = array(_) + ) + -> jGetObjectArrayElement(Array, Index, Vr) + ; jpl_primitive_type(Type) + -> jni_type_to_xput_code(Type, Xc), + jni_alloc_buffer(Xc, 1, Bp), % one-element buf for a Type + jpl_get_primitive_array_region(Type, Array, Index, 1, Bp), + jni_fetch_buffer_value(Bp, 0, Vr, Xc), % zero-th element + jni_free_buffer(Bp) + ), + Vr = Vc. % redundant since Vc is always (?) unbound at call + +%------------------------------------------------------------------------------ + +%% jpl_get_array_elements(+ElementType, +Array, +N, +M, -Vs) +% +% serves only jpl_get_instance Vs will always be unbound on entry + +jpl_get_array_elements(ElementType, Array, N, M, Vs) :- + ( ( ElementType = class(_,_) + ; ElementType = array(_) + ) + -> jpl_get_object_array_elements(Array, N, M, Vs) + ; jpl_get_primitive_array_elements(ElementType, Array, N, M, Vs) + ). + +%------------------------------------------------------------------------------ + +jpl_get_instance_field(boolean, Obj, FieldID, V) :- + jGetBooleanField(Obj, FieldID, V). +jpl_get_instance_field(byte, Obj, FieldID, V) :- + jGetByteField(Obj, FieldID, V). +jpl_get_instance_field(char, Obj, FieldID, V) :- + jGetCharField(Obj, FieldID, V). +jpl_get_instance_field(short, Obj, FieldID, V) :- + jGetShortField(Obj, FieldID, V). +jpl_get_instance_field(int, Obj, FieldID, V) :- + jGetIntField(Obj, FieldID, V). +jpl_get_instance_field(long, Obj, FieldID, V) :- + jGetLongField(Obj, FieldID, V). +jpl_get_instance_field(float, Obj, FieldID, V) :- + jGetFloatField(Obj, FieldID, V). +jpl_get_instance_field(double, Obj, FieldID, V) :- + jGetDoubleField(Obj, FieldID, V). +jpl_get_instance_field(class(_,_), Obj, FieldID, V) :- + jGetObjectField(Obj, FieldID, V). +jpl_get_instance_field(array(_), Obj, FieldID, V) :- + jGetObjectField(Obj, FieldID, V). + +%------------------------------------------------------------------------------ + +%% jpl_get_object_array_elements(+Array, +LoIndex, +HiIndex, -Vcs) +% +% Array should be a (zero-based) array of some object (array or +% non-array) type; LoIndex is an integer, 0 =< LoIndex < +% length(Array); HiIndex is an integer, LoIndex-1 =< HiIndex < +% length(Array); at call, Vcs will be unbound; at exit, Vcs will +% be a list of (references to) the array's elements +% [LoIndex..HiIndex] inclusive + +jpl_get_object_array_elements(Array, Lo, Hi, Vcs) :- + ( Lo =< Hi + -> Vcs = [Vc|Vcs2], + jGetObjectArrayElement(Array, Lo, Vc), + Next is Lo+1, + jpl_get_object_array_elements(Array, Next, Hi, Vcs2) + ; Vcs = [] + ). + +%------------------------------------------------------------------------------ + +%% jpl_get_primitive_array_elements(+ElementType, +Array, +LoIndex, +HiIndex, -Vcs) +% +% Array should be a (zero-based) Java array of (primitive) +% ElementType; Vcs should be unbound on entry, and on exit will be +% a list of (JPL representations of the values of) the elements +% [LoIndex..HiIndex] inclusive + +jpl_get_primitive_array_elements(ElementType, Array, Lo, Hi, Vcs) :- + Size is Hi-Lo+1, + ( Size == 0 + -> Vcs = [] + ; jni_type_to_xput_code(ElementType, Xc), + jni_alloc_buffer(Xc, Size, Bp), + jpl_get_primitive_array_region(ElementType, Array, Lo, Size, Bp), + jpl_primitive_buffer_to_array(ElementType, Xc, Bp, 0, Size, Vcs), + jni_free_buffer(Bp) + ). + +%------------------------------------------------------------------------------ + +jpl_get_primitive_array_region(boolean, Array, Lo, S, I) :- + jGetBooleanArrayRegion(Array, Lo, S, jbuf(I,boolean)). +jpl_get_primitive_array_region(byte, Array, Lo, S, I) :- + jGetByteArrayRegion(Array, Lo, S, jbuf(I,byte)). +jpl_get_primitive_array_region(char, Array, Lo, S, I) :- + jGetCharArrayRegion(Array, Lo, S, jbuf(I,char)). +jpl_get_primitive_array_region(short, Array, Lo, S, I) :- + jGetShortArrayRegion(Array, Lo, S, jbuf(I,short)). +jpl_get_primitive_array_region(int, Array, Lo, S, I) :- + jGetIntArrayRegion(Array, Lo, S, jbuf(I,int)). +jpl_get_primitive_array_region(long, Array, Lo, S, I) :- + jGetLongArrayRegion(Array, Lo, S, jbuf(I,long)). +jpl_get_primitive_array_region(float, Array, Lo, S, I) :- + jGetFloatArrayRegion(Array, Lo, S, jbuf(I,float)). +jpl_get_primitive_array_region(double, Array, Lo, S, I) :- + jGetDoubleArrayRegion(Array, Lo, S, jbuf(I,double)). + +%------------------------------------------------------------------------------ + +jpl_get_static_field(boolean, Array, FieldID, V) :- + jGetStaticBooleanField(Array, FieldID, V). +jpl_get_static_field(byte, Array, FieldID, V) :- + jGetStaticByteField(Array, FieldID, V). +jpl_get_static_field(char, Array, FieldID, V) :- + jGetStaticCharField(Array, FieldID, V). +jpl_get_static_field(short, Array, FieldID, V) :- + jGetStaticShortField(Array, FieldID, V). +jpl_get_static_field(int, Array, FieldID, V) :- + jGetStaticIntField(Array, FieldID, V). +jpl_get_static_field(long, Array, FieldID, V) :- + jGetStaticLongField(Array, FieldID, V). +jpl_get_static_field(float, Array, FieldID, V) :- + jGetStaticFloatField(Array, FieldID, V). +jpl_get_static_field(double, Array, FieldID, V) :- + jGetStaticDoubleField(Array, FieldID, V). +jpl_get_static_field(class(_,_), Array, FieldID, V) :- + jGetStaticObjectField(Array, FieldID, V). +jpl_get_static_field(array(_), Array, FieldID, V) :- + jGetStaticObjectField(Array, FieldID, V). + +%------------------------------------------------------------------------------ + +%% jpl_new(+X, +Params, -V) +% +% X can be: +% * an atomic classname +% e.g. 'java.lang.String' +% * an atomic descriptor +% e.g. '[I' or 'Ljava.lang.String;' +% * a suitable type +% i.e. any class(_,_) or array(_) +% +% if X is an object (non-array) type or descriptor and Params is a +% list of values or references, then V is the result of an invocation +% of that type's most specifically-typed constructor to whose +% respective formal parameters the actual Params are assignable (and +% assigned) +% +% if X is an array type or descriptor and Params is a list of values +% or references, each of which is (independently) assignable to the +% array element type, then V is a new array of as many elements as +% Params has members, initialised with the respective members of +% Params; +% +% if X is an array type or descriptor and Params is a non-negative +% integer N, then V is a new array of that type, with N elements, each +% initialised to Java's appropriate default value for the type; +% +% If V is {Term} then we attempt to convert a new jpl.Term instance to +% a corresponding term; this is of little obvious use here, but is +% consistent with jpl_call/4 and jpl_get/3 + +jpl_new(X, Params, V) :- + ( var(X) + -> throw(error(instantiation_error, + context(jpl_new/3, + '1st arg must be bound to a classname, descriptor or object type'))) + ; jpl_is_type(X) % NB only class(_,_) or array(_) + -> Type = X + ; atom(X) % e.g. 'java.lang.String', '[L', 'boolean' + -> ( jpl_classname_to_type(X, Type) + -> true + ; throw(error(domain_error(classname,X), + context(jpl_new/3, + 'if 1st arg is an atom, it must be a classname or descriptor'))) + ) + ; throw(error(type_error(instantiable,X), + context(jpl_new/3, + '1st arg must be a classname, descriptor or object type'))) + ), + jpl_new_1(Type, Params, Vx), + ( nonvar(V), + V = {Term} % yucky way of requesting Term->term conversion + -> ( jni_jref_to_term( Vx, TermX) % fails if Rx is not a JRef to a jpl.Term + -> Term = TermX + ; throw(error(type_error, + context(jpl_call/4, 'result is not a jpl.Term instance as required'))) + ) + ; V = Vx + ). + +%------------------------------------------------------------------------------ + +% jpl_new_1(+Tx, +Params, -Vx) :- +% (serves only jpl_new/3) +% +% Tx can be: +% a class(_,_) or array(_) type; +% +% Params must be: +% a proper list of constructor parameters +% +% at exit, Vx is bound to a JPL reference to a new, initialised instance of Tx + +jpl_new_1(class(Ps,Cs), Params, Vx) :- + !, % green (see below) + Tx = class(Ps,Cs), + ( var(Params) + -> throw(error(instantiation_error, + context(jpl_new/3, + '2nd arg must be a proper list of valid parameters for a constructor'))) + ; \+ is_list(Params) + -> throw(error(type_error(list,Params), + context(jpl_new/3, + '2nd arg must be a proper list of valid parameters for a constructor'))) + ; true + ), + length(Params, A), % the "arity" of the required constructor + jpl_type_to_class(Tx, Cx), % throws Java exception if class is not found + N = '', % JNI's constructor naming convention for GetMethodID() + Tr = void, % all constructors have this return "type" + findall( + z3(I,MID,Tfps), + jpl_method_spec(Tx, I, N, A, _Mods, MID, Tr, Tfps), % cached + Z3s + ), + ( Z3s == [] % no constructors which require the given qty of parameters? + -> jpl_type_to_classname( Tx, Cn), + ( jpl_call( Cx, isInterface, [], @(true)) + -> throw(error(type_error(concrete_class,Cn), + context(jpl_new/3, + 'cannot create instance of an interface'))) + ; throw(error(existence_error(constructor,Cn/A), + context(jpl_new/3, + 'no constructor found with the corresponding quantity of parameters'))) + ) + ; ( catch( + jpl_datums_to_types(Params, Taps), % infer actual parameter types + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_new/3,Msg))) + ) + -> true + ; throw(error(domain_error(list(jpl_datum),Params), + context(jpl_new/3, + 'one or more of the actual parameters is not a valid representation of any Java value or object'))) + ), + findall( + z3(I,MID,Tfps), % select constructors to which actual parameters are assignable + ( member(z3(I,MID,Tfps), Z3s), + jpl_types_fit_types(Taps, Tfps) % assignability test: actual parameter types "fit" formal parameter types? + ), + Z3sA + ), + ( Z3sA == [] % no type-assignable constructors? + -> ( Z3s = [_] + -> throw(error(existence_error(constructor,Tx/A), + context(jpl_new/3, + 'the actual parameters are not assignable to the formal parameter types of the only constructor which takes this qty of parameters'))) + ; throw(error(type_error(constructor_args,Params), + context(jpl_new/3, + 'the actual parameters are not assignable to the formal parameter types of any of the constructors which take this qty of parameters'))) + ) + ; Z3sA = [z3(I,MID,Tfps)] + -> true + ; jpl_z3s_to_most_specific_z3(Z3sA, z3(I,MID,Tfps)) + -> true + ; throw(error(type_error(constructor_params,Params), + context(jpl_new/3, + 'more than one most-specific matching constructor (shouldn''t happen)'))) + ) + ), + catch( + jNewObject(Cx, MID, Tfps, Params, Vx), + error(java_exception(@(_)), 'java.lang.InstantiationException'), + ( jpl_type_to_classname( Tx, Cn), + throw(error(type_error(concrete_class,Cn), + context(jpl_new/3, + 'cannot create instance of an abstract class'))) + ) + ), + jpl_cache_type_of_ref(Tx, Vx). % since we know it + +jpl_new_1(array(T), Params, Vx) :- + !, + ( var(Params) + -> throw(error(instantiation_error, + context(jpl_new/3, + 'when constructing a new array, 2nd arg must either be a non-negative integer (denoting the required array length) or a proper list of valid element values'))) + ; integer(Params) % integer I -> array[0..I-1] of default values + -> ( Params >= 0 + -> Len is Params + ; throw(error(domain_error(array_length,Params), + context(jpl_new/3, + 'when constructing a new array, if the 2nd arg is an integer (denoting the required array length) then it must be non-negative'))) + ) + ; is_list(Params) % [V1,..VN] -> array[0..N-1] of respective values + -> length(Params, Len) + ), + jpl_new_array(T, Len, Vx), % NB may throw out-of-memory exception + ( nth0(I, Params, Param), % nmember fails silently when Params is integer + jpl_set(Vx, I, Param), + fail + ; true + ), + jpl_cache_type_of_ref(array(T), Vx). % since we know it + +jpl_new_1(T, _Params, _Vx) :- % doomed attempt to create new primitive type instance (formerly a dubious completist feature :-) + jpl_primitive_type(T), + !, + throw(error(domain_error(object_type,T), + context(jpl_new/3, + 'cannot construct an instance of a primitive type'))). + % ( var(Params) + % -> throw(error(instantiation_error, + % context(jpl_new/3, + % 'when constructing a new instance of a primitive type, 2nd arg must be bound (to a representation of a suitable value)'))) + % ; Params == [] + % -> jpl_primitive_type_default_value(T, Vx) + % ; Params = [Param] + % -> jpl_primitive_type_term_to_value(T, Param, Vx) + % ; throw(error(domain_error(constructor_args,Params), + % context(jpl_new/3, + % 'when constructing a new instance of a primitive type, 2nd arg must either be an empty list (indicating that the default value of that type is required) or a list containing exactly one representation of a suitable value)'))) + % ). + +jpl_new_1( T, _, _) :- + throw(error(domain_error(jpl_type,T), + context(jpl_new/3, + '1st arg must denote a known or plausible type'))). + +%------------------------------------------------------------------------------ + +% jpl_new_array(+ElementType, +Length, -NewArray) :- + +jpl_new_array(boolean, Len, A) :- + jNewBooleanArray(Len, A). + +jpl_new_array(byte, Len, A) :- + jNewByteArray(Len, A). + +jpl_new_array(char, Len, A) :- + jNewCharArray(Len, A). + +jpl_new_array(short, Len, A) :- + jNewShortArray(Len, A). + +jpl_new_array(int, Len, A) :- + jNewIntArray(Len, A). + +jpl_new_array(long, Len, A) :- + jNewLongArray(Len, A). + +jpl_new_array(float, Len, A) :- + jNewFloatArray(Len, A). + +jpl_new_array(double, Len, A) :- + jNewDoubleArray(Len, A). + +jpl_new_array(array(T), Len, A) :- + jpl_type_to_class(array(T), C), + jNewObjectArray(Len, C, @(null), A). % initialise each element to null + +jpl_new_array(class(Ps,Cs), Len, A) :- + jpl_type_to_class(class(Ps,Cs), C), + jNewObjectArray(Len, C, @(null), A). + +%------------------------------------------------------------------------------ + +% jpl_set(+X, +Fspec, +V) :- +% basically, sets the Fspec-th field of class or object X to value V +% iff it is assignable +% +% X can be: +% a class instance +% (for static or non-static fields) +% an array +% (for indexed element or subrange assignment) +% a classname, or a class/2 or array/1 type +% (for static fields) +% but not: +% a String (no fields to retrieve) +% +% Fspec can be: +% an atomic field name +% (overloading through shadowing has yet to be handled properly) +% an array index I +% (X must be an array object: V is assigned to X[I]) +% a pair I-J of integers +% (X must be an array object, V must be a list of values: successive members of V are assigned to X[I..J]) +% +% V must be a suitable value or object + +jpl_set(X, Fspec, V) :- + ( jpl_object_to_type(X, Type) % the usual case (test is safe if X is var or rubbish) + -> Obj = X, + catch( + jpl_set_instance(Type, Type, Obj, Fspec, V), % first 'Type' is for FAI + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_set/3,Msg))) + ) + ; var(X) + -> throw(error(instantiation_error, + context(jpl_set/3, + '1st arg must be an object, classname, descriptor or type'))) + ; ( atom(X) + -> ( jpl_classname_to_type(X, Type) % it's a classname or descriptor... + -> true + ; throw(error(existence_error(class,X), + context(jpl_set/3, + 'the named class cannot be found'))) + ) + ; ( X = class(_,_) % it's a class type... + ; X = array(_) % ...or an array type + ) + -> Type = X + ), + ( jpl_type_to_class( Type, ClassObj) % ...whose Class object is available + -> true + ; jpl_type_to_classname( Type, Classname), + throw(error(existence_error(class,Classname), + context(jpl_set/3, + 'the class cannot be found'))) + ) + -> catch( + jpl_set_static(Type, ClassObj, Fspec, V), + error(type_error(acyclic,Te),context(jpl_datum_to_type/2,Msg)), + throw(error(type_error(acyclic,Te),context(jpl_set/3,Msg))) + ) + ; throw(error(domain_error(object_or_class,X), + context(jpl_set/3, + '1st arg must be an object, classname, descriptor or type'))) + ). + +%------------------------------------------------------------------------------ + +% jpl_set_instance(+Type, +Type, +ObjectReference, +FieldName, +Value) :- +% ObjectReference is a JPL reference to a Java object +% of the class denoted by Type (which is passed twice for first agument indexing); +% FieldName should name a public, non-final (static or non-static) field of this object, +% but could be anything, and is validated here; +% Value should be assignable to the named field, but could be anything, and is validated here + +jpl_set_instance(class(_,_), Type, Obj, Fname, V) :- % a non-array object + ( atom(Fname) % the usual case + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_set/3, + '2nd arg must be bound to the name of a public, non-final field'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_set/3, + '2nd arg must be the name of a public, non-final field'))) + ), + findall( + z4(I,Mods,FID,Tf), + jpl_field_spec(Type, I, Fname, Mods, FID, Tf), % public fields of class denoted by Type + Z4s + ), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_set/3, + 'no public fields of the object have this name'))) + ; Z4s = [z4(I,Mods,FID,Tf)] + -> ( member(final, Mods) + -> throw(error(permission_error(modify,final_field,Fname), + context(jpl_set/3, + 'cannot assign a value to a final field (actually you could but I''ve decided not to let you)'))) + ; jpl_datum_to_type( V, Tv) + -> ( jpl_type_fits_type( Tv, Tf) + -> ( member(static, Mods) + -> jpl_object_to_class(Obj, ClassObj), + jpl_set_static_field(Tf, ClassObj, FID, V) + ; jpl_set_instance_field(Tf, Obj, FID, V) % oughta be jpl_set_instance_field? + ) + ; jpl_type_to_nicename( Tf, NNf), + throw(error(type_error(NNf,V), + context(jpl_set/3, + 'the value is not assignable to the named field of the class'))) + ) + ; throw(error(type_error(field_value,V), + context(jpl_set/3, + '3rd arg does not represent any Java value or object'))) + ) + ; throw(error(existence_error(field,Fname), % 'existence'? or some other sort of error maybe? + context(jpl_set/3, + 'more than one public field of the object has this name (this should not happen)'))) + ). + + +jpl_set_instance(array(Type), _, Obj, Fspec, V) :- + ( is_list(V) % a list of array element values + -> Vs = V + ; var(V) + -> throw(error(instantiation_error, + context(jpl_set/3, 'when 1st arg is an array, 3rd arg must be bound to a suitable element value or list of values'))) + ; Vs = [V] % a single array element value + ), + length(Vs, Iv), + ( var(Fspec) + -> throw(error(instantiation_error, + context(jpl_set/3, + 'when 1st arg is an array, 2nd arg must be bound to an index or index range'))) + ; integer(Fspec) % single-element assignment + -> ( Fspec < 0 + -> throw(error(domain_error(array_index,Fspec), + context(jpl_set/3, + 'when 1st arg is an array, an integral 2nd arg must be a non-negative index'))) + ; Iv is 1 + -> N is Fspec + ; Iv is 0 + -> throw(error(domain_error(array_element(Fspec),Vs), + context(jpl_set/3, + 'no values for array element assignment: needs one'))) + ; throw(error(domain_error(array_element(Fspec),Vs), + context(jpl_set/3, + 'too many values for array element assignment: needs one'))) + ) + ; Fspec = N-M % element-sequence assignment + -> ( integer(N), + integer(M) + -> ( N >= 0, + Size is (M-N)+1, + Size >= 0 + -> ( Size == Iv + -> true + ; Size < Iv + -> throw(error(domain_error(array_elements(N-M),Vs), + context(jpl_set/3, + 'too few values for array range assignment'))) + ; throw(error(domain_error(array_elements(N-M),Vs), + context(jpl_set/3, + 'too many values for array range assignment'))) + ) + ; throw(error(domain_error(array_index_range,N-M), + context(jpl_set/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; throw(error(type_error(array_index_range,N-M), + context(jpl_set/3, + 'array index range must be a non-decreasing pair of non-negative integers'))) + ) + ; atom(Fspec) + -> ( Fspec == length + -> throw(error(permission_error(modify,final_field,length), + context(jpl_set/3, + 'cannot assign a value to a final field'))) + ; throw(error(existence_error(field,Fspec), + context(jpl_set/3, + 'array has no field with that name'))) + ) + ; throw(error(domain_error(array_index,Fspec), + context(jpl_set/3, + 'when 1st arg is an array object, 2nd arg must be a non-negative index or index range'))) + ), + jpl_set_array(Type, Obj, N, Iv, Vs). + +%------------------------------------------------------------------------------ + +% jpl_set_static(+Type, +ClassObj, +FieldName, +Value) :- +% we can rely on: +% Type being a class/2 type representing some accessible class +% ClassObj being an instance of java.lang.Class which represents the same class as Type +% but FieldName could be anything, so we validate it here, +% look for a suitable (static) field of the target class, +% then call jpl_set_static_field/4 to attempt to assign Value (which could be anything) to it +% +% NB this does not yet handle shadowed fields correctly... + +jpl_set_static(Type, ClassObj, Fname, V) :- + ( atom(Fname) % the usual case + -> true + ; var(Fname) + -> throw(error(instantiation_error, + context(jpl_set/3, + 'when 1st arg denotes a class, 2nd arg must be bound to the name of a public, static, non-final field'))) + ; throw(error(type_error(field_name,Fname), + context(jpl_set/3, + 'when 1st arg denotes a class, 2nd arg must be the name of a public, static, non-final field'))) + ), + findall( % get all static fields of the denoted class + z4(I,Mods,FID,Tf), + ( jpl_field_spec(Type, I, Fname, Mods, FID, Tf), + member(static, Mods) + ), + Z4s + ), + ( Z4s = [] + -> throw(error(existence_error(field,Fname), + context(jpl_set/3, + 'class has no public static fields of this name'))) + ; Z4s = [z4(I,Mods,FID,Tf)] % exactly one synonymous field? + -> ( member(final, Mods) + -> throw(error(permission_error(modify,final_field,Fname), + context(jpl_set/3, + 'cannot assign a value to a final field'))) + ; jpl_datum_to_type(V, Tv) + -> ( jpl_type_fits_type(Tv, Tf) + -> jpl_set_static_field(Tf, ClassObj, FID, V) + ; jpl_type_to_nicename(Tf, NNf), + throw(error(type_error(NNf,V), + context(jpl_set/3, + 'the value is not assignable to the named field of the class'))) + ) + ; throw(error(type_error(field_value,V), + context(jpl_set/3, + '3rd arg does not represent any Java value or object'))) + ) + ; throw(error(existence_error(field,Fname), + context(jpl_set/3, + 'more than one public static field of the class has this name (this should not happen)(?)'))) + ). + +%------------------------------------------------------------------------------ + +%% jpl_set_array(+ElementType, +Array, +Offset, +DatumQty, +Datums) +% +% Datums, of which there are DatumQty, are stashed in successive +% elements of Array which is an array of ElementType starting at +% the Offset-th (numbered from 0) throws +% error(type_error(acyclic,_),context(jpl_datum_to_type/2,_)) + +jpl_set_array(T, A, N, I, Ds) :- + ( jpl_datums_to_types(Ds, Tds) % most specialised types of given values + -> ( jpl_types_fit_type(Tds, T) % all assignable to element type? + -> true + ; throw(error(type_error(array(T),Ds), + context(jpl_set/3, + 'not all values are assignable to the array element type'))) + ) + ; throw(error(type_error(array(T),Ds), + context(jpl_set/3, + 'not all values are convertible to Java values or references'))) + ), + ( ( T = class(_,_) + ; T = array(_) % array elements are objects + ) + -> ( nth0(J, Ds, D), % for each datum + Nd is N+J, % compute array index + ( D = {Tq} % quoted term? + -> jni_term_to_jref(Tq, D2) % convert to a JPL reference to a corresponding jpl.Term object + ; D = D2 + ), + jSetObjectArrayElement(A, Nd, D2), + fail % iterate + ; true + ) + ; jpl_primitive_type(T) % array elements are primitive values + -> jni_type_to_xput_code(T, Xc), + jni_alloc_buffer(Xc, I, Bp), % I-element buf of required primitive type + jpl_set_array_1(Ds, T, 0, Bp), + jpl_set_elements(T, A, N, I, Bp), + jni_free_buffer(Bp) + ; throw(error(SYSTEM_ERROR_INTERNAL(array_element_type,T), + context(jpl_set/3, + 'array element type is unknown (this should not happen)'))) + ). + +%------------------------------------------------------------------------------ + +%% jpl_set_array_1(+Values, +Type, +BufferIndex, +BufferPointer) +% +% successive members of Values are stashed as (primitive) Type +% from the BufferIndex-th element (numbered from 0) onwards of the +% buffer indicated by BufferPointer NB this could be done more +% efficiently (?) within foreign code... + +jpl_set_array_1([], _, _, _). +jpl_set_array_1([V|Vs], Tprim, Ib, Bp) :- + jni_type_to_xput_code(Tprim, Xc), + jni_stash_buffer_value(Bp, Ib, V, Xc), + Ibnext is Ib+1, + jpl_set_array_1(Vs, Tprim, Ibnext, Bp). + +%------------------------------------------------------------------------------ + +jpl_set_elements(boolean, Obj, N, I, Bp) :- + jSetBooleanArrayRegion(Obj, N, I, jbuf(Bp,boolean)). +jpl_set_elements(char, Obj, N, I, Bp) :- + jSetCharArrayRegion(Obj, N, I, jbuf(Bp,char)). +jpl_set_elements(byte, Obj, N, I, Bp) :- + jSetByteArrayRegion(Obj, N, I, jbuf(Bp,byte)). +jpl_set_elements(short, Obj, N, I, Bp) :- + jSetShortArrayRegion(Obj, N, I, jbuf(Bp,short)). +jpl_set_elements(int, Obj, N, I, Bp) :- + jSetIntArrayRegion(Obj, N, I, jbuf(Bp,int)). +jpl_set_elements(long, Obj, N, I, Bp) :- + jSetLongArrayRegion(Obj, N, I, jbuf(Bp,long)). +jpl_set_elements(float, Obj, N, I, Bp) :- + jSetFloatArrayRegion(Obj, N, I, jbuf(Bp,float)). +jpl_set_elements(double, Obj, N, I, Bp) :- + jSetDoubleArrayRegion(Obj, N, I, jbuf(Bp,double)). + +%------------------------------------------------------------------------------ + +%% jpl_set_instance_field(+Type, +Obj, +FieldID, +V) +% +% we can rely on Type, Obj and FieldID being valid, and on V being +% assignable (if V is a quoted term then it is converted here) + +jpl_set_instance_field(boolean, Obj, FieldID, V) :- + jSetBooleanField(Obj, FieldID, V). +jpl_set_instance_field(byte, Obj, FieldID, V) :- + jSetByteField(Obj, FieldID, V). +jpl_set_instance_field(char, Obj, FieldID, V) :- + jSetCharField(Obj, FieldID, V). +jpl_set_instance_field(short, Obj, FieldID, V) :- + jSetShortField(Obj, FieldID, V). +jpl_set_instance_field(int, Obj, FieldID, V) :- + jSetIntField(Obj, FieldID, V). +jpl_set_instance_field(long, Obj, FieldID, V) :- + jSetLongField(Obj, FieldID, V). +jpl_set_instance_field(float, Obj, FieldID, V) :- + jSetFloatField(Obj, FieldID, V). +jpl_set_instance_field(double, Obj, FieldID, V) :- + jSetDoubleField(Obj, FieldID, V). +jpl_set_instance_field(class(_,_), Obj, FieldID, V) :- % also handles byval term assignments + ( V = {T} % quoted term? + -> jni_term_to_jref(T, V2) % convert to a JPL reference to a corresponding jpl.Term object + ; V = V2 + ), + jSetObjectField(Obj, FieldID, V2). +jpl_set_instance_field(array(_), Obj, FieldID, V) :- + jSetObjectField(Obj, FieldID, V). + +%------------------------------------------------------------------------------ + +% jpl_set_static_field(+Type, +ClassObj, +FieldID, +V) :- +% we can rely on Type, ClassObj and FieldID being valid, +% and on V being assignable (if V is a quoted term then it is converted here) + +jpl_set_static_field(boolean, Obj, FieldID, V) :- + jSetStaticBooleanField(Obj, FieldID, V). + +jpl_set_static_field(byte, Obj, FieldID, V) :- + jSetStaticByteField(Obj, FieldID, V). + +jpl_set_static_field(char, Obj, FieldID, V) :- + jSetStaticCharField(Obj, FieldID, V). + +jpl_set_static_field(short, Obj, FieldID, V) :- + jSetStaticShortField(Obj, FieldID, V). + +jpl_set_static_field(int, Obj, FieldID, V) :- + jSetStaticIntField(Obj, FieldID, V). + +jpl_set_static_field(long, Obj, FieldID, V) :- + jSetStaticLongField(Obj, FieldID, V). + +jpl_set_static_field(float, Obj, FieldID, V) :- + jSetStaticFloatField(Obj, FieldID, V). + +jpl_set_static_field(double, Obj, FieldID, V) :- + jSetStaticDoubleField(Obj, FieldID, V). + +jpl_set_static_field(class(_,_), Obj, FieldID, V) :- % also handles byval term assignments + ( V = {T} % quoted term? + -> jni_term_to_jref(T, V2) % convert to a JPL reference to a corresponding jpl.Term object + ; V = V2 + ), + jSetStaticObjectField(Obj, FieldID, V2). + +jpl_set_static_field(array(_), Obj, FieldID, V) :- + jSetStaticObjectField(Obj, FieldID, V). + +%------------------------------------------------------------------------------ + +% jpl_z3s_to_most_specific_z3(+Zs, -Z) :- +% Zs is a list of arity-matching, type-suitable z3(I,MID,Tfps) +% Z is the single most specific element of Zs, +% i.e. that than which no other z3/3 has a more specialised signature; +% fails if there is more than one such + +jpl_z3s_to_most_specific_z3(Zs, Z) :- + jpl_fergus_is_the_greatest(Zs, Z). + +%------------------------------------------------------------------------------ + +% jpl_z5s_to_most_specific_z5(+Zs, -Z) :- +% Zs is a list of arity-matching, type-suitable z5(I,Mods,MID,Tr,Tfps) +% Z is the single most specific element of Zs, +% i.e. that than which no other z5/5 has a more specialised signature +% (this fails if there is more than one such) + +jpl_z5s_to_most_specific_z5(Zs, Z) :- + jpl_fergus_is_the_greatest(Zs, Z). + +%------------------------------------------------------------------------------ + +% jpl_pl_lib_version(-VersionString) :- +% jpl_pl_lib_version(-Major, -Minor, -Patch, -Status) :- + +jpl_pl_lib_version(VersionString) :- + jpl_pl_lib_version(Major, Minor, Patch, Status), + atomic_list_concat([Major,'.',Minor,'.',Patch,'-',Status], VersionString). + + +jpl_pl_lib_version(3, 1, 4, alpha). + +%------------------------------------------------------------------------------ + +% jpl_type_alfa(0'$) --> % presumably not allowed +% "$". % given the "inner class" syntax? + +jpl_type_alfa(0'_) --> + "_", + !. + +jpl_type_alfa(C) --> + [C], { C>=0'a, C=<0'z }, + !. + +jpl_type_alfa(C) --> + [C], { C>=0'A, C=<0'Z }. + +%------------------------------------------------------------------------------ + +jpl_type_alfa_num(C) --> + jpl_type_alfa(C), + !. + +jpl_type_alfa_num(C) --> + [C], { C>=0'0, C=<0'9 }. + +%------------------------------------------------------------------------------ + +jpl_type_array_classname(array(T)) --> + "[", jpl_type_classname_2(T). + +%------------------------------------------------------------------------------ + +jpl_type_array_descriptor(array(T)) --> + "[", jpl_type_descriptor_1(T). + +%------------------------------------------------------------------------------ + +jpl_type_bare_class_descriptor(class(Ps,Cs)) --> + jpl_type_slashed_package_parts(Ps), jpl_type_class_parts(Cs). + +%------------------------------------------------------------------------------ + +jpl_type_bare_classname(class(Ps,Cs)) --> + jpl_type_dotted_package_parts(Ps), jpl_type_class_parts(Cs). + +%------------------------------------------------------------------------------ + +jpl_type_class_descriptor(class(Ps,Cs)) --> + "L", jpl_type_bare_class_descriptor(class(Ps,Cs)), ";". + +%------------------------------------------------------------------------------ + +jpl_type_class_part(N) --> + jpl_type_id(N). + +%------------------------------------------------------------------------------ + +jpl_type_class_parts([C|Cs]) --> + jpl_type_class_part(C), jpl_type_inner_class_parts(Cs). + +%------------------------------------------------------------------------------ + +jpl_type_classname_1(T) --> + jpl_type_bare_classname(T), + !. + +jpl_type_classname_1(T) --> + jpl_type_array_classname(T), + !. + +jpl_type_classname_1(T) --> + jpl_type_primitive(T). + +%------------------------------------------------------------------------------ + +jpl_type_classname_2(T) --> + jpl_type_delimited_classname(T). + +jpl_type_classname_2(T) --> + jpl_type_array_classname(T). + +jpl_type_classname_2(T) --> + jpl_type_primitive(T). + +%------------------------------------------------------------------------------ + +jpl_type_delimited_classname(Class) --> + "L", jpl_type_bare_classname(Class), ";". + +%------------------------------------------------------------------------------ + +jpl_type_descriptor_1(T) --> + jpl_type_primitive(T), + !. + +jpl_type_descriptor_1(T) --> + jpl_type_class_descriptor(T), + !. + +jpl_type_descriptor_1(T) --> + jpl_type_array_descriptor(T), + !. + +jpl_type_descriptor_1(T) --> + jpl_type_method_descriptor(T). + +%------------------------------------------------------------------------------ + +jpl_type_dotted_package_parts([P|Ps]) --> + jpl_type_package_part(P), ".", !, jpl_type_dotted_package_parts(Ps). + +jpl_type_dotted_package_parts([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_findclassname(T) --> + jpl_type_bare_class_descriptor(T). + +jpl_type_findclassname(T) --> + jpl_type_array_descriptor(T). + +%------------------------------------------------------------------------------ + +jpl_type_id(A) --> + { nonvar(A) -> atom_codes(A,[C|Cs]) ; true }, + jpl_type_alfa(C), jpl_type_id_rest(Cs), + { atom_codes(A, [C|Cs]) }. + +%------------------------------------------------------------------------------ + +jpl_type_id_rest([C|Cs]) --> + jpl_type_alfa_num(C), !, jpl_type_id_rest(Cs). + +jpl_type_id_rest([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_id_v2(A) --> % inner class name parts (empirically) + { nonvar(A) -> atom_codes(A,Cs) ; true }, + jpl_type_id_rest(Cs), + { atom_codes(A, Cs) }. + +%------------------------------------------------------------------------------ + +jpl_type_inner_class_part(N) --> + jpl_type_id_v2(N). + +%------------------------------------------------------------------------------ + +jpl_type_inner_class_parts([C|Cs]) --> + "$", jpl_type_inner_class_part(C), !, jpl_type_inner_class_parts(Cs). + +jpl_type_inner_class_parts([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_method_descriptor(method(Ts,T)) --> + "(", jpl_type_method_descriptor_args(Ts), ")", jpl_type_method_descriptor_return(T). + +%------------------------------------------------------------------------------ + +jpl_type_method_descriptor_args([T|Ts]) --> + jpl_type_descriptor_1(T), !, jpl_type_method_descriptor_args(Ts). + +jpl_type_method_descriptor_args([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_method_descriptor_return(T) --> + jpl_type_void(T). + +jpl_type_method_descriptor_return(T) --> + jpl_type_descriptor_1(T). + +%------------------------------------------------------------------------------ + +jpl_type_package_part(N) --> + jpl_type_id(N). + +%------------------------------------------------------------------------------ + +jpl_type_primitive(boolean) --> + "Z", + !. + +jpl_type_primitive(byte) --> + "B", + !. + +jpl_type_primitive(char) --> + "C", + !. + +jpl_type_primitive(short) --> + "S", + !. + +jpl_type_primitive(int) --> + "I", + !. + +jpl_type_primitive(long) --> + "J", + !. + +jpl_type_primitive(float) --> + "F", + !. + +jpl_type_primitive(double) --> + "D". + +%------------------------------------------------------------------------------ + +jpl_type_slashed_package_parts([P|Ps]) --> + jpl_type_package_part(P), "/", !, jpl_type_slashed_package_parts(Ps). + +jpl_type_slashed_package_parts([]) --> + []. + +%------------------------------------------------------------------------------ + +jpl_type_void(void) --> + "V". + +%------------------------------------------------------------------------------ + +%type jCallBooleanMethod(object, method_id, types, datums, boolean) + +% jCallBooleanMethod(+Obj, +MethodID, +Types, +Params, -Rbool) :- + +jCallBooleanMethod(Obj, MethodID, Types, Params, Rbool) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(39, Obj, MethodID, ParamBuf, Rbool). + +%------------------------------------------------------------------------------ + +%type jCallByteMethod(object, method_id, types, datums, byte) + +% jCallByteMethod(+Obj, +MethodID, +Types, +Params, -Rbyte) :- + +jCallByteMethod(Obj, MethodID, Types, Params, Rbyte) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(42, Obj, MethodID, ParamBuf, Rbyte). + +%------------------------------------------------------------------------------ + +%type jCallCharMethod(object, method_id, types, datums, char) + +% jCallCharMethod(+Obj, +MethodID, +Types, +Params, -Rchar) :- + +jCallCharMethod(Obj, MethodID, Types, Params, Rchar) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(45, Obj, MethodID, ParamBuf, Rchar). + +%------------------------------------------------------------------------------ + +%type jCallDoubleMethod(object, method_id, types, datums, double) + +% jCallDoubleMethod(+Obj, +MethodID, +Types, +Params, -Rdouble) :- + +jCallDoubleMethod(Obj, MethodID, Types, Params, Rdouble) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(60, Obj, MethodID, ParamBuf, Rdouble). + +%------------------------------------------------------------------------------ + +%type jCallFloatMethod(object, method_id, types, datums, float) + +% jCallFloatMethod(+Obj, +MethodID, +Types, +Params, -Rfloat) :- + +jCallFloatMethod(Obj, MethodID, Types, Params, Rfloat) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(57, Obj, MethodID, ParamBuf, Rfloat). + +%------------------------------------------------------------------------------ + +%type jCallIntMethod(object, method_id, types, datums, int) + +% jCallIntMethod(+Obj, +MethodID, +Types, +Params, -Rint) :- + +jCallIntMethod(Obj, MethodID, Types, Params, Rint) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(51, Obj, MethodID, ParamBuf, Rint). + +%------------------------------------------------------------------------------ + +%type jCallLongMethod(object, method_id, types, datums, long) + +% jCallLongMethod(+Obj, +MethodID, +Types, +Params, -Rlong) :- + +jCallLongMethod(Obj, MethodID, Types, Params, Rlong) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(54, Obj, MethodID, ParamBuf, Rlong). + +%------------------------------------------------------------------------------ + +%type jCallObjectMethod(object, method_id, types, datums, object) + +% jCallObjectMethod(+Obj, +MethodID, +Types, +Params, -Robj) :- + +jCallObjectMethod(Obj, MethodID, Types, Params, Robj) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(36, Obj, MethodID, ParamBuf, Robj). + +%------------------------------------------------------------------------------ + +%type jCallShortMethod(object, method_id, types, datums, short) + +% jCallShortMethod(+Obj, +MethodID, +Types, +Params, -Rshort) :- + +jCallShortMethod(Obj, MethodID, Types, Params, Rshort) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(48, Obj, MethodID, ParamBuf, Rshort). + +%------------------------------------------------------------------------------ + +%type jCallStaticBooleanMethod(class, types, datums, boolean) + +% jCallStaticBooleanMethod(+Class, +MethodID, +Types, +Params, -Rbool) :- + +jCallStaticBooleanMethod(Class, MethodID, Types, Params, Rbool) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(119, Class, MethodID, ParamBuf, Rbool). + +%------------------------------------------------------------------------------ + +%type jCallStaticByteMethod(class, method_id, types, datums, byte) + +% jCallStaticByteMethod(+Class, +MethodID, +Types, +Params, -Rbyte) :- + +jCallStaticByteMethod(Class, MethodID, Types, Params, Rbyte) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(122, Class, MethodID, ParamBuf, Rbyte). + +%------------------------------------------------------------------------------ + +%type jCallStaticCharMethod(class, method_id, types, datums, char) + +% jCallStaticCharMethod(+Class, +MethodID, +Types, +Params, -Rchar) :- + +jCallStaticCharMethod(Class, MethodID, Types, Params, Rchar) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(125, Class, MethodID, ParamBuf, Rchar). + +%------------------------------------------------------------------------------ + +%type jCallStaticDoubleMethod(class, method_id, types, datums, double) + +% jCallStaticDoubleMethod(+Class, +MethodID, +Types, +Params, -Rdouble) :- + +jCallStaticDoubleMethod(Class, MethodID, Types, Params, Rdouble) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(140, Class, MethodID, ParamBuf, Rdouble). + +%------------------------------------------------------------------------------ + +%type jCallStaticFloatMethod(class, method_id, types, datums, float) + +% jCallStaticFloatMethod(+Class, +MethodID, +Types, +Params, -Rfloat) :- + +jCallStaticFloatMethod(Class, MethodID, Types, Params, Rfloat) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(137, Class, MethodID, ParamBuf, Rfloat). + +%------------------------------------------------------------------------------ + +%type jCallStaticIntMethod(class, method_id, types, datums, int) + +% jCallStaticIntMethod(+Class, +MethodID, +Types, +Params, -Rint) :- + +jCallStaticIntMethod(Class, MethodID, Types, Params, Rint) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(131, Class, MethodID, ParamBuf, Rint). + +%------------------------------------------------------------------------------ + +%type jCallStaticLongMethod(class, method_id, types, datums, long) + +% jCallStaticLongMethod(+Class, +MethodID, +Types, +Params, -Rlong) :- + +jCallStaticLongMethod(Class, MethodID, Types, Params, Rlong) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(134, Class, MethodID, ParamBuf, Rlong). + +%------------------------------------------------------------------------------ + +%type jCallStaticObjectMethod(class, method_id, types, datums, object) + +% jCallStaticObjectMethod(+Class, +MethodID, +Types, +Params, -Robj) :- + +jCallStaticObjectMethod(Class, MethodID, Types, Params, Robj) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(116, Class, MethodID, ParamBuf, Robj). + +%------------------------------------------------------------------------------ + +%type jCallStaticShortMethod(class, method_id, types, datums, short) + +% jCallStaticShortMethod(+Class, +MethodID, +Types, +Params, -Rshort) :- + +jCallStaticShortMethod(Class, MethodID, Types, Params, Rshort) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(128, Class, MethodID, ParamBuf, Rshort). + +%------------------------------------------------------------------------------ + +%type jCallStaticVoidMethod(class, method_id, types, datums) + +% jCallStaticVoidMethod(+Class, +MethodID, +Types, +Params) :- + +jCallStaticVoidMethod(Class, MethodID, Types, Params) :- + jni_params_put(Params, Types, ParamBuf), + jni_void(143, Class, MethodID, ParamBuf). + +%------------------------------------------------------------------------------ + +%type jCallVoidMethod(object, method_id, types, datums) + +% jCallVoidMethod(+Obj, +MethodID, +Types, +Params) :- + +jCallVoidMethod(Obj, MethodID, Types, Params) :- + jni_params_put(Params, Types, ParamBuf), + jni_void(63, Obj, MethodID, ParamBuf). + +%------------------------------------------------------------------------------ + +%type jFindClass(findclassname, class) + +% jFindClass(+ClassName, -Class) :- + +jFindClass(ClassName, Class) :- + jni_func(6, ClassName, Class). + +%------------------------------------------------------------------------------ + +%type jGetArrayLength(array, int) + +% jGetArrayLength(+Array, -Size) :- + +jGetArrayLength(Array, Size) :- + jni_func(171, Array, Size). + +%------------------------------------------------------------------------------ + +%type jGetBooleanArrayRegion(boolean_array, int, int, boolean_buf) + +% jGetBooleanArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetBooleanArrayRegion(Array, Start, Len, Buf) :- + jni_void(199, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetBooleanField(object, field_id, boolean) + +% jGetBooleanField(+Obj, +FieldID, -Rbool) :- + +jGetBooleanField(Obj, FieldID, Rbool) :- + jni_func(96, Obj, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jGetByteArrayRegion(byte_array, int, int, byte_buf) + +% jGetByteArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetByteArrayRegion(Array, Start, Len, Buf) :- + jni_void(200, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetByteField(object, field_id, byte) + +% jGetByteField(+Obj, +FieldID, -Rbyte) :- + +jGetByteField(Obj, FieldID, Rbyte) :- + jni_func(97, Obj, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jGetCharArrayRegion(char_array, int, int, char_buf) + +% jGetCharArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetCharArrayRegion(Array, Start, Len, Buf) :- + jni_void(201, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetCharField(object, field_id, char) + +% jGetCharField(+Obj, +FieldID, -Rchar) :- + +jGetCharField(Obj, FieldID, Rchar) :- + jni_func(98, Obj, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jGetDoubleArrayRegion(double_array, int, int, double_buf) + +% jGetDoubleArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetDoubleArrayRegion(Array, Start, Len, Buf) :- + jni_void(206, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetDoubleField(object, field_id, double) + +% jGetDoubleField(+Obj, +FieldID, -Rdouble) :- + +jGetDoubleField(Obj, FieldID, Rdouble) :- + jni_func(103, Obj, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jGetFieldID(class, descriptor, field_id) + +% jGetFieldID(+Class, +Name, +Typedescriptor, -FieldID) :- + +jGetFieldID(Class, Name, Type, FieldID) :- + jpl_type_to_descriptor(Type, TD), + jni_func(94, Class, Name, TD, FieldID). + +%------------------------------------------------------------------------------ + +%type jGetFloatArrayRegion(float_array, int, int, float_buf) + +% jGetFloatArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetFloatArrayRegion(Array, Start, Len, Buf) :- + jni_void(205, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetFloatField(object, field_id, float) + +% jGetFloatField(+Obj, +FieldID, -Rfloat) :- + +jGetFloatField(Obj, FieldID, Rfloat) :- + jni_func(102, Obj, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jGetIntArrayRegion(int_array, int, int, int_buf) + +% jGetIntArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetIntArrayRegion(Array, Start, Len, Buf) :- + jni_void(203, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetIntField(object, field_id, int) + +% jGetIntField(+Obj, +FieldID, -Rint) :- + +jGetIntField(Obj, FieldID, Rint) :- + jni_func(100, Obj, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jGetLongArrayRegion(long_array, int, int, long_buf) + +% jGetLongArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetLongArrayRegion(Array, Start, Len, Buf) :- + jni_void(204, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetLongField(object, field_id, long) + +% jGetLongField(+Obj, +FieldID, -Rlong) :- + +jGetLongField(Obj, FieldID, Rlong) :- + jni_func(101, Obj, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jGetMethodID(class, name, descriptor, method_id) + +% jGetMethodID(+Class, +Name, +TypeDescriptor, -MethodID) :- + +jGetMethodID(Class, Name, Type, MethodID) :- + jpl_type_to_descriptor(Type, TD), + jni_func(33, Class, Name, TD, MethodID). + +%------------------------------------------------------------------------------ + +%type jGetObjectArrayElement(object_array, int, object) + +% jGetObjectArrayElement(+Array, +Index, -Obj) :- + +jGetObjectArrayElement(Array, Index, Obj) :- + jni_func(173, Array, Index, Obj). + +%------------------------------------------------------------------------------ + +%type jGetObjectClass(object, class) + +% jGetObjectClass(+Object, -Class) :- + +jGetObjectClass(Object, Class) :- + jni_func(31, Object, Class). + +%------------------------------------------------------------------------------ + +%type jGetObjectField(object, field_id, object) + +% jGetObjectField(+Obj, +FieldID, -RObj) :- + +jGetObjectField(Obj, FieldID, Robj) :- + jni_func(95, Obj, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jGetShortArrayRegion(short_array, int, int, short_buf) + +% jGetShortArrayRegion(+Array, +Start, +Len, +Buf) :- + +jGetShortArrayRegion(Array, Start, Len, Buf) :- + jni_void(202, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jGetShortField(object, field_id, short) + +% jGetShortField(+Obj, +FieldID, -Rshort) :- + +jGetShortField(Obj, FieldID, Rshort) :- + jni_func(99, Obj, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +%type jGetStaticBooleanField(class, field_id, boolean) + +% jGetStaticBooleanField(+Class, +FieldID, -Rbool) :- + +jGetStaticBooleanField(Class, FieldID, Rbool) :- + jni_func(146, Class, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jGetStaticByteField(class, field_id, byte) + +% jGetStaticByteField(+Class, +FieldID, -Rbyte) :- + +jGetStaticByteField(Class, FieldID, Rbyte) :- + jni_func(147, Class, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jGetStaticCharField(class, field_id, char) + +% jGetStaticCharField(+Class, +FieldID, -Rchar) :- + +jGetStaticCharField(Class, FieldID, Rchar) :- + jni_func(148, Class, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jGetStaticDoubleField(class, field_id, double) + +% jGetStaticDoubleField(+Class, +FieldID, -Rdouble) :- + +jGetStaticDoubleField(Class, FieldID, Rdouble) :- + jni_func(153, Class, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jGetStaticFieldID(class, name, field_id) + +% jGetStaticFieldID(+Class, +Name, +TypeDescriptor, -FieldID) :- + +jGetStaticFieldID(Class, Name, Type, FieldID) :- + jpl_type_to_descriptor(Type, TD), % cache this? + jni_func(144, Class, Name, TD, FieldID). + +%------------------------------------------------------------------------------ + +%type jGetStaticFloatField(class, field_id, float) + +% jGetStaticFloatField(+Class, +FieldID, -Rfloat) :- + +jGetStaticFloatField(Class, FieldID, Rfloat) :- + jni_func(152, Class, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jGetStaticIntField(class, field_id, int) + +% jGetStaticIntField(+Class, +FieldID, -Rint) :- + +jGetStaticIntField(Class, FieldID, Rint) :- + jni_func(150, Class, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jGetStaticLongField(class, field_id, long) + +% jGetStaticLongField(+Class, +FieldID, -Rlong) :- + +jGetStaticLongField(Class, FieldID, Rlong) :- + jni_func(151, Class, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jGetStaticMethodID(class, name, method_id) + +% jGetStaticMethodID(+Class, +Name, +TypeDescriptor, -MethodID) :- + +jGetStaticMethodID(Class, Name, Type, MethodID) :- + jpl_type_to_descriptor(Type, TD), + jni_func(113, Class, Name, TD, MethodID). + +%------------------------------------------------------------------------------ + +%type jGetStaticObjectField(class, field_id, object) + +% jGetStaticObjectField(+Class, +FieldID, -RObj) :- + +jGetStaticObjectField(Class, FieldID, Robj) :- + jni_func(145, Class, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jGetStaticShortField(class, field_id, short) + +% jGetStaticShortField(+Class, +FieldID, -Rshort) :- + +jGetStaticShortField(Class, FieldID, Rshort) :- + jni_func(149, Class, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +%type jGetSuperclass(object, object) + +% jGetSuperclass(+Class1, -Class2) :- + +jGetSuperclass(Class1, Class2) :- + jni_func(10, Class1, Class2). + +%------------------------------------------------------------------------------ + +%type jIsAssignableFrom(object, object) + +% jIsAssignableFrom(+Class1, +Class2) :- + +jIsAssignableFrom(Class1, Class2) :- + jni_func(11, Class1, Class2, @(true)). + +%------------------------------------------------------------------------------ + +%type jNewBooleanArray(int, boolean_array) + +% jNewBooleanArray(+Length, -Array) :- + +jNewBooleanArray(Length, Array) :- + jni_func(175, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewByteArray(int, byte_array) + +% jNewByteArray(+Length, -Array) :- + +jNewByteArray(Length, Array) :- + jni_func(176, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewCharArray(int, char_array) + +% jNewCharArray(+Length, -Array) :- + +jNewCharArray(Length, Array) :- + jni_func(177, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewDoubleArray(int, double_array) + +% jNewDoubleArray(+Length, -Array) :- + +jNewDoubleArray(Length, Array) :- + jni_func(182, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewFloatArray(int, float_array) + +% jNewFloatArray(+Length, -Array) :- + +jNewFloatArray(Length, Array) :- + jni_func(181, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewIntArray(int, int_array) + +% jNewIntArray(+Length, -Array) :- + +jNewIntArray(Length, Array) :- + jni_func(179, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewLongArray(int, long_array) + +% jNewLongArray(+Length, -Array) :- + +jNewLongArray(Length, Array) :- + jni_func(180, Length, Array). + +%------------------------------------------------------------------------------ + +%type jNewObject(class, method_id, types, datums, object) + +% jNewObject(+Class, +MethodID, +Types, +Params, -Obj) :- + +jNewObject(Class, MethodID, Types, Params, Obj) :- + jni_params_put(Params, Types, ParamBuf), + jni_func(30, Class, MethodID, ParamBuf, Obj). + +%------------------------------------------------------------------------------ + +%type jNewObjectArray(int, class, object, object_array) + +% jNewObjectArray(+Len, +Class, +InitVal, -Array) :- + +jNewObjectArray(Len, Class, InitVal, Array) :- + jni_func(172, Len, Class, InitVal, Array). + +%------------------------------------------------------------------------------ + +%type jNewShortArray(int, short_array) + +% jNewShortArray(+Length, -Array) :- + +jNewShortArray(Length, Array) :- + jni_func(178, Length, Array). + +%------------------------------------------------------------------------------ + +%type jSetBooleanArrayRegion(boolean_array, int, int, boolean_buf) + +% jSetBooleanArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetBooleanArrayRegion(Array, Start, Len, Buf) :- + jni_void(207, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetBooleanField(object, field_id, boolean) + +% jSetBooleanField(+Obj, +FieldID, +Rbool) :- + +jSetBooleanField(Obj, FieldID, Rbool) :- + jni_void(105, Obj, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jSetByteArrayRegion(byte_array, int, int, byte_buf) + +% jSetByteArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetByteArrayRegion(Array, Start, Len, Buf) :- + jni_void(208, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetByteField(object, field_id, byte) + +% jSetByteField(+Obj, +FieldID, +Rbyte) :- + +jSetByteField(Obj, FieldID, Rbyte) :- + jni_void(106, Obj, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jSetCharArrayRegion(char_array, int, int, char_buf) + +% jSetCharArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetCharArrayRegion(Array, Start, Len, Buf) :- + jni_void(209, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetCharField(object, field_id, char) + +% jSetCharField(+Obj, +FieldID, +Rchar) :- + +jSetCharField(Obj, FieldID, Rchar) :- + jni_void(107, Obj, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jSetDoubleArrayRegion(double_array, int, int, double_buf) + +% jSetDoubleArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetDoubleArrayRegion(Array, Start, Len, Buf) :- + jni_void(214, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetDoubleField(object, field_id, double) + +% jSetDoubleField(+Obj, +FieldID, +Rdouble) :- + +jSetDoubleField(Obj, FieldID, Rdouble) :- + jni_void(112, Obj, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jSetFloatArrayRegion(float_array, int, int, float_buf) + +% jSetFloatArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetFloatArrayRegion(Array, Start, Len, Buf) :- + jni_void(213, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetFloatField(object, field_id, float) + +% jSetFloatField(+Obj, +FieldID, +Rfloat) :- + +jSetFloatField(Obj, FieldID, Rfloat) :- + jni_void(111, Obj, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jSetIntArrayRegion(int_array, int, int, int_buf) + +% jSetIntArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetIntArrayRegion(Array, Start, Len, Buf) :- + jni_void(211, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetIntField(object, field_id, int) + +% jSetIntField(+Obj, +FieldID, +Rint) :- + +jSetIntField(Obj, FieldID, Rint) :- + jni_void(109, Obj, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jSetLongArrayRegion(long_array, int, int, long_buf) + +% jSetLongArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetLongArrayRegion(Array, Start, Len, Buf) :- + jni_void(212, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetLongField(object, field_id, long) + +% jSetLongField(+Obj, +FieldID, +Rlong) :- + +jSetLongField(Obj, FieldID, Rlong) :- + jni_void(110, Obj, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jSetObjectArrayElement(object_array, int, object) + +% jSetObjectArrayElement(+Array, +Index, +Obj) :- + +jSetObjectArrayElement(Array, Index, Obj) :- + jni_void(174, Array, Index, Obj). + +%------------------------------------------------------------------------------ + +%type jSetObjectField(object, field_id, object) + +% jSetObjectField(+Obj, +FieldID, +RObj) :- + +jSetObjectField(Obj, FieldID, Robj) :- + jni_void(104, Obj, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jSetShortArrayRegion(short_array, int, int, short_buf) + +% jSetShortArrayRegion(+Array, +Start, +Len, +Buf) :- + +jSetShortArrayRegion(Array, Start, Len, Buf) :- + jni_void(210, Array, Start, Len, Buf). + +%------------------------------------------------------------------------------ + +%type jSetShortField(object, field_id, short) + +% jSetShortField(+Obj, +FieldID, +Rshort) :- + +jSetShortField(Obj, FieldID, Rshort) :- + jni_void(108, Obj, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +%type jSetStaticBooleanField(class, field_id, boolean) + +% jSetStaticBooleanField(+Class, +FieldID, +Rbool) :- + +jSetStaticBooleanField(Class, FieldID, Rbool) :- + jni_void(155, Class, FieldID, Rbool). + +%------------------------------------------------------------------------------ + +%type jSetStaticByteField(class, field_id, byte) + +% jSetStaticByteField(+Class, +FieldID, +Rbyte) :- + +jSetStaticByteField(Class, FieldID, Rbyte) :- + jni_void(156, Class, FieldID, Rbyte). + +%------------------------------------------------------------------------------ + +%type jSetStaticCharField(class, field_id, char) + +% jSetStaticCharField(+Class, +FieldID, +Rchar) :- + +jSetStaticCharField(Class, FieldID, Rchar) :- + jni_void(157, Class, FieldID, Rchar). + +%------------------------------------------------------------------------------ + +%type jSetStaticDoubleField(class, field_id, double) + +% jSetStaticDoubleField(+Class, +FieldID, +Rdouble) :- + +jSetStaticDoubleField(Class, FieldID, Rdouble) :- + jni_void(162, Class, FieldID, Rdouble). + +%------------------------------------------------------------------------------ + +%type jSetStaticFloatField(class, field_id, float) + +% jSetStaticFloatField(+Class, +FieldID, +Rfloat) :- + +jSetStaticFloatField(Class, FieldID, Rfloat) :- + jni_void(161, Class, FieldID, Rfloat). + +%------------------------------------------------------------------------------ + +%type jSetStaticIntField(class, field_id, int) + +% jSetStaticIntField(+Class, +FieldID, +Rint) :- + +jSetStaticIntField(Class, FieldID, Rint) :- + jni_void(159, Class, FieldID, Rint). + +%------------------------------------------------------------------------------ + +%type jSetStaticLongField(class, field_id, long) + +% jSetStaticLongField(+Class, +FieldID, +Rlong) :- + +jSetStaticLongField(Class, FieldID, Rlong) :- + jni_void(160, Class, FieldID, Rlong). + +%------------------------------------------------------------------------------ + +%type jSetStaticObjectField(class, field_id, object) + +% jSetStaticObjectField(+Class, +FieldID, +Robj) :- + +jSetStaticObjectField(Class, FieldID, Robj) :- + jni_void(154, Class, FieldID, Robj). + +%------------------------------------------------------------------------------ + +%type jSetStaticShortField(class, field_id, short) + +% jSetStaticShortField(+Class, +FieldID, +Rshort) :- + +jSetStaticShortField(Class, FieldID, Rshort) :- + jni_void(158, Class, FieldID, Rshort). + +%------------------------------------------------------------------------------ + +% jni_params_put(+Params, +Types, -ParamBuf) :- +% the old form used a static buffer, hence was not re-entrant; +% the new form allocates a buffer of one jvalue per arg, +% puts the (converted) args into respective elements, then returns it +% (the caller is responsible for freeing it) + +jni_params_put(As, Ts, ParamBuf) :- + jni_ensure_jvm, % in case e.g. NewStringUTF() is called + length(As, N), + jni_type_to_xput_code(jvalue, Xc), % Xc will be 15 + jni_alloc_buffer(Xc, N, ParamBuf), + jni_params_put_1(As, 0, Ts, ParamBuf). + +%------------------------------------------------------------------------------ + +% jni_params_put_1(+Params, +N, +JPLTypes, +ParamBuf) :- +% Params is a (full or partial) list of args-not-yet-stashed, +% and Types are their (JPL) types (e.g. 'boolean'); +% N is the arg and buffer index (0+) at which the head of Params is to be stashed; +% the old form used a static buffer and hence was non-reentrant; +% the new form uses a dynamically allocated buffer (which oughta be freed after use) +% +%NB if the (user-provided) actual params were to be unsuitable for conversion +%NB to the method-required types, this would fail silently (without freeing the buffer); +%NB it's not clear whether the overloaded-method-resolution ensures that all args +%NB are convertible + +jni_params_put_1([], _, [], _). + +jni_params_put_1([A|As], N, [Tjni|Ts], ParamBuf) :- % type checking? + ( jni_type_to_xput_code(Tjni, Xc) + -> ( A = {Term} % a quoted general term? + -> jni_term_to_jref( Term, Ax) % convert it to a @(Tag) ref to a new Term instance + ; A = Ax + ), + jni_param_put(N, Xc, Ax, ParamBuf) % foreign + ; fail % oughta raise an exception? + ), + N2 is N+1, + jni_params_put_1(As, N2, Ts, ParamBuf). % stash remaining params (if any) + +%------------------------------------------------------------------------------ + +% jni_type_to_xput_code(+JspType, -JniXputCode) :- +% NB JniXputCode determines widening and casting in foreign code +% NB the codes could be compiled into jni_method_spec_cache etc. +% instead of, or as well as, types (for - small - efficiency gain) + +jni_type_to_xput_code(boolean, 1). % JNI_XPUT_BOOLEAN + +jni_type_to_xput_code(byte, 2). % JNI_XPUT_BYTE + +jni_type_to_xput_code(char, 3). % JNI_XPUT_CHAR + +jni_type_to_xput_code(short, 4). % JNI_XPUT_SHORT + +jni_type_to_xput_code(int, 5). % JNI_XPUT_INT + +jni_type_to_xput_code(long, 6). % JNI_XPUT_LONG + +jni_type_to_xput_code(float, 7). % JNI_XPUT_FLOAT + +jni_type_to_xput_code(double, 8). % JNI_XPUT_DOUBLE + +jni_type_to_xput_code(class(_,_), 12). % JNI_XPUT_REF + +jni_type_to_xput_code(array(_), 12). % JNI_XPUT_REF + +jni_type_to_xput_code(jvalue, 15). % JNI_XPUT_JVALUE + +%------------------------------------------------------------------------------ + +% jpl_class_to_constructor_array(+Class, -MethodArray) :- +% might this be done more efficiently in foreign code? or in Java? + +jpl_class_to_constructor_array(Cx, Ma) :- + jpl_classname_to_class('java.lang.Class', CC), % cacheable? + jGetMethodID( + CC, + getConstructors, + method([],array(class([java,lang,reflect],['Constructor']))), + MID + ), % cacheable? + jCallObjectMethod(Cx, MID, [], [], Ma). + +%------------------------------------------------------------------------------ + +% jpl_class_to_constructors(+Class, -Methods) :- + +jpl_class_to_constructors(Cx, Ms) :- + jpl_class_to_constructor_array(Cx, Ma), + jpl_object_array_to_list(Ma, Ms). + +%------------------------------------------------------------------------------ + +% jpl_class_to_field_array(+Class, -FieldArray) :- + +jpl_class_to_field_array(Cx, Fa) :- + jpl_classname_to_class('java.lang.Class', CC), % cacheable? + jGetMethodID( + CC, + getFields, + method([],array(class([java,lang,reflect],['Field']))), + MID + ), % cacheable? + jCallObjectMethod(Cx, MID, [], [], Fa). + +%------------------------------------------------------------------------------ + +% jpl_class_to_fields(+Class, -Fields) :- +% do this in Java (ditto for methods)? + +jpl_class_to_fields(C, Fs) :- + jpl_class_to_field_array(C, Fa), + jpl_object_array_to_list(Fa, Fs). + +%------------------------------------------------------------------------------ + +% jpl_class_to_method_array(+Class, -MethodArray) :- +% migrate into foreign code for efficiency? + +jpl_class_to_method_array(Cx, Ma) :- + jpl_classname_to_class('java.lang.Class', CC), % cacheable? + jGetMethodID( + CC, + getMethods, + method([],array(class([java,lang,reflect],['Method']))), + MID + ), % cacheable? + jCallObjectMethod(Cx, MID, [], [], Ma). + +%------------------------------------------------------------------------------ + +% jpl_class_to_methods(+Class, -Methods) :- +% also used for constructors +% do this in Java (ditto for fields)? + +jpl_class_to_methods(Cx, Ms) :- + jpl_class_to_method_array(Cx, Ma), + jpl_object_array_to_list(Ma, Ms). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_modifiers(+Method, -Modifiers) :- +% migrate into foreign code for efficiency? + +jpl_constructor_to_modifiers(X, Ms) :- + jpl_classname_to_class('java.lang.reflect.Constructor', Cx), % cached? + jpl_method_to_modifiers_1(X, Cx, Ms). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_name(+Method, -Name) :- +% it is a JNI convention that each constructor behaves (at least, +% for reflection), as a method whose name is '' + +jpl_constructor_to_name(_X, ''). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_parameter_types(+Method, -ParameterTypes) :- +% migrate to foreign code for efficiency? + +jpl_constructor_to_parameter_types(X, Tfps) :- + jpl_classname_to_class('java.lang.reflect.Constructor', Cx), % cached? + jpl_method_to_parameter_types_1(X, Cx, Tfps). + +%------------------------------------------------------------------------------ + +% jpl_constructor_to_return_type(+Method, -Type) :- +% it is a JNI convention that, for the purposes of retrieving a MethodID, +% a constructor has a return type of 'void' + +jpl_constructor_to_return_type(_X, void). + +%------------------------------------------------------------------------------ + +% jpl_field_spec(+Type, -Index, -Name, -Modifiers, -MID, -FieldType) :- +% I'm unsure whether arrays have fields, but if they do, this will handle them correctly + +jpl_field_spec(T, I, N, Mods, MID, Tf) :- + ( jpl_field_spec_is_cached(T) + -> jpl_field_spec_cache(T, I, N, Mods, MID, Tf) + ; jpl_type_to_class(T, C), + jpl_class_to_fields(C, Fs), + ( T = array(_BaseType) % regardless of base type... + -> Tci = array(_) % ...the "cache index" type is this + ; Tci = T + ), + jpl_field_spec_1(C, Tci, Fs), + jpl_assert(jpl_field_spec_is_cached(Tci)), + jpl_field_spec_cache(Tci, I, N, Mods, MID, Tf) + ). + +%------------------------------------------------------------------------------ + +jpl_field_spec_1(C, Tci, Fs) :- + ( nth1(I, Fs, F), + jpl_field_to_name(F, N), + jpl_field_to_modifiers(F, Mods), + jpl_field_to_type(F, Tf), + ( member(static, Mods) + -> jGetStaticFieldID(C, N, Tf, MID) + ; jGetFieldID(C, N, Tf, MID) + ), + jpl_assert(jpl_field_spec_cache(Tci,I,N,Mods,MID,Tf)), + fail + ; true + ). + +%------------------------------------------------------------------------------ + +:- dynamic jpl_field_spec_cache/6. % document this... + +%------------------------------------------------------------------------------ + +:- dynamic jpl_field_spec_is_cached/1. % document this... + +%------------------------------------------------------------------------------ + +%type jpl_field_to_modifiers(object, ordset(modifier)) + +% jpl_field_to_modifiers(+Field, -Modifiers) :- + +jpl_field_to_modifiers(F, Ms) :- + jpl_classname_to_class('java.lang.reflect.Field', Cf), + jpl_method_to_modifiers_1(F, Cf, Ms). + +%------------------------------------------------------------------------------ + +% jpl_field_to_name(+Field, -Name) :- + +jpl_field_to_name(F, N) :- + jpl_classname_to_class('java.lang.reflect.Field', Cf), + jpl_member_to_name_1(F, Cf, N). + +%------------------------------------------------------------------------------ + +%type jpl_field_to_type(object, type) + +% jpl_field_to_type(+Field, -Type) :- + +jpl_field_to_type(F, Tf) :- + jpl_classname_to_class('java.lang.reflect.Field', Cf), + jGetMethodID(Cf, getType, method([],class([java,lang],['Class'])), MID), + jCallObjectMethod(F, MID, [], [], Cr), + jpl_class_to_type(Cr, Tf). + +%------------------------------------------------------------------------------ + +%type jpl_method_spec(type, integer, name, arity, ordset(modifier), method_id, type, list(type)) + +% jpl_method_spec(+Type, -Index, -Name, -Arity, -Modifiers, -MID, -ReturnType, -ParameterTypes) :- +% generates pertinent details of all accessible methods of Type (class/2 or array/1), +% populating or using the cache as appropriate + +jpl_method_spec(T, I, N, A, Mods, MID, Tr, Tfps) :- + ( jpl_method_spec_is_cached(T) + -> jpl_method_spec_cache(T, I, N, A, Mods, MID, Tr, Tfps) + ; jpl_type_to_class(T, C), + jpl_class_to_constructors(C, Xs), + jpl_class_to_methods(C, Ms), + ( T = array(_BaseType) % regardless of base type... + -> Tci = array(_) % ...the "cache index" type is this + ; Tci = T + ), + jpl_method_spec_1(C, Tci, Xs, Ms), + jpl_assert(jpl_method_spec_is_cached(Tci)), + jpl_method_spec_cache(Tci, I, N, A, Mods, MID, Tr, Tfps) + ). + +%------------------------------------------------------------------------------ + +%type jpl_method_spec_1(class, partial_type, list(method), list(method)) + +% jpl_method_spec_1(+ClassObject, +CacheIndexType, +Constructors, +Methods) :- +% if the original type is e.g. array(byte) then CacheIndexType is array(_) else it is that type; + +jpl_method_spec_1(C, Tci, Xs, Ms) :- + ( ( nth1(I, Xs, X), % generate constructors, numbered from 1 + jpl_constructor_to_name(X, N), + jpl_constructor_to_modifiers(X, Mods), + jpl_constructor_to_return_type(X, Tr), + jpl_constructor_to_parameter_types(X, Tfps) + ; length(Xs, J0), + nth1(J, Ms, M), % generate members, continuing numbering + I is J0+J, + jpl_method_to_name(M, N), + jpl_method_to_modifiers(M, Mods), + jpl_method_to_return_type(M, Tr), + jpl_method_to_parameter_types(M, Tfps) + ), + length(Tfps, A), % arity + ( member(static, Mods) + -> jGetStaticMethodID(C, N, method(Tfps,Tr), MID) + ; jGetMethodID(C, N, method(Tfps,Tr), MID) + ), + jpl_assert(jpl_method_spec_cache(Tci,I,N,A,Mods,MID,Tr,Tfps)), + fail + ; true + ). + +%------------------------------------------------------------------------------ + +:- dynamic jpl_method_spec_cache/8. + +%------------------------------------------------------------------------------ + +:- dynamic jpl_method_spec_is_cached/1. + +%------------------------------------------------------------------------------ + +% jpl_method_to_modifiers(+Method, -ModifierSet) :- + +jpl_method_to_modifiers(M, Ms) :- + jpl_classname_to_class('java.lang.reflect.Method', Cm), + jpl_method_to_modifiers_1(M, Cm, Ms). + +%------------------------------------------------------------------------------ + +%type jpl_method_to_modifiers_1(object, object, ordset(modifier)) + +% jpl_method_to_modifiers_1(+Method, +ConstructorClass, -ModifierSet) :- + +jpl_method_to_modifiers_1(XM, Cxm, Ms) :- + jGetMethodID(Cxm, getModifiers, method([],int), MID), + jCallIntMethod(XM, MID, [], [], I), + jpl_modifier_int_to_modifiers(I, Ms). + +%------------------------------------------------------------------------------ + +% jpl_method_to_name(+Method, -Name) :- + +jpl_method_to_name(M, N) :- + jpl_classname_to_class('java.lang.reflect.Method', CM), + jpl_member_to_name_1(M, CM, N). + +%------------------------------------------------------------------------------ + +jpl_member_to_name_1(M, CM, N) :- + jGetMethodID(CM, getName, method([],class([java,lang],['String'])), MID), + jCallObjectMethod(M, MID, [], [], N). + +%------------------------------------------------------------------------------ + +% jpl_method_to_parameter_types(+Method, -Types) :- + +jpl_method_to_parameter_types(M, Tfps) :- + jpl_classname_to_class('java.lang.reflect.Method', Cm), + jpl_method_to_parameter_types_1(M, Cm, Tfps). + +%------------------------------------------------------------------------------ + +% jpl_method_to_parameter_types_1(+XM, +Cxm, -Tfps) :- +% XM is (a JPL ref to) an instance of java.lang.reflect.[Constructor|Method] + +jpl_method_to_parameter_types_1(XM, Cxm, Tfps) :- + jGetMethodID(Cxm, getParameterTypes, method([],array(class([java,lang],['Class']))), MID), + jCallObjectMethod(XM, MID, [], [], Atp), + jpl_object_array_to_list(Atp, Ctps), + jpl_classes_to_types(Ctps, Tfps). + +%------------------------------------------------------------------------------ + +% jpl_method_to_return_type(+Method, -Type) :- + +jpl_method_to_return_type(M, Tr) :- + jpl_classname_to_class('java.lang.reflect.Method', Cm), + jGetMethodID(Cm, getReturnType, method([],class([java,lang],['Class'])), MID), + jCallObjectMethod(M, MID, [], [], Cr), + jpl_class_to_type(Cr, Tr). + +%------------------------------------------------------------------------------ + +jpl_modifier_bit(public, 0x001). +jpl_modifier_bit(private, 0x002). +jpl_modifier_bit(protected, 0x004). +jpl_modifier_bit(static, 0x008). +jpl_modifier_bit(final, 0x010). +jpl_modifier_bit(synchronized, 0x020). +jpl_modifier_bit(volatile, 0x040). +jpl_modifier_bit(transient, 0x080). +jpl_modifier_bit(native, 0x100). +jpl_modifier_bit(interface, 0x200). +jpl_modifier_bit(abstract, 0x400). + +%------------------------------------------------------------------------------ + +%type jpl_modifier_int_to_modifiers(integer, ordset(modifier)) + +% jpl_modifier_int_to_modifiers(+Int, -ModifierSet) :- +% ModifierSet is an ordered (hence canonical) list, +% possibly empty (although I suspect never in practice?), +% of modifier atoms, e.g. [public,static] + +jpl_modifier_int_to_modifiers(I, Ms) :- + setof( + M, % should use e.g. set_of_all/3 + B^(jpl_modifier_bit(M, B), + (B /\ I) =\= 0 + ), + Ms + ). + +%------------------------------------------------------------------------------ + +% jpl_servlet_byref(+Config, +Request, +Response) :- +% this serves the "byref" servlet demo, +% exemplifying one tactic for implementing a servlet in Prolog +% by accepting the Request and Response objects as JPL references +% and accessing their members via JPL as required; +% see also jpl_servlet_byval/3 + +jpl_servlet_byref(Config, Request, Response) :- + jpl_call(Config, getServletContext, [], Context), + + jpl_call(Response, setStatus, [200], _), + jpl_call(Response, setContentType, ['text/html'], _), + jpl_call(Response, getWriter, [], W), + + jpl_call(W, println, ['

    jpl_servlet_byref/3 says:

    '], _),
+
+	jpl_call(W, println, ['\nservlet context stuff:'], _),
+
+	jpl_call(Context, getInitParameterNames, [], ContextInitParameterNameEnum),
+	jpl_enumeration_to_list(ContextInitParameterNameEnum, ContextInitParameterNames),
+	length(ContextInitParameterNames, NContextInitParameterNames),
+	atomic_list_concat(['\tContext.InitParameters = ',NContextInitParameterNames], NContextInitParameterNamesMsg),
+	jpl_call(W, println, [NContextInitParameterNamesMsg], _),
+	(   member(ContextInitParameterName, ContextInitParameterNames),
+	jpl_call(Context, getInitParameter, [ContextInitParameterName], ContextInitParameter),
+	atomic_list_concat(['\t\tContext.InitParameter[',ContextInitParameterName,'] = ',ContextInitParameter], ContextInitParameterMsg),
+	jpl_call(W, println, [ContextInitParameterMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(Context, getMajorVersion, [], MajorVersion),
+	atomic_list_concat(['\tContext.MajorVersion = ',MajorVersion], MajorVersionMsg),
+	jpl_call(W, println, [MajorVersionMsg], _),
+
+	jpl_call(Context, getMinorVersion, [], MinorVersion),
+	atomic_list_concat(['\tContext.MinorVersion = ',MinorVersion], MinorVersionMsg),
+	jpl_call(W, println, [MinorVersionMsg], _),
+
+	jpl_call(Context, getServerInfo, [], ServerInfo),
+	atomic_list_concat(['\tContext.ServerInfo = ',ServerInfo], ServerInfoMsg),
+	jpl_call(W, println, [ServerInfoMsg], _),
+
+	jpl_call(W, println, ['\nservlet config stuff:'], _),
+
+	jpl_call(Config, getServletName, [], ServletName),
+	(   ServletName == @(null)
+	->  ServletNameAtom = null
+	;   ServletNameAtom = ServletName
+	),
+	atomic_list_concat(['\tConfig.ServletName = ',ServletNameAtom], ServletNameMsg),
+	jpl_call(W, println, [ServletNameMsg], _),
+
+	jpl_call(Config, getInitParameterNames, [], ConfigInitParameterNameEnum),
+	jpl_enumeration_to_list(ConfigInitParameterNameEnum, ConfigInitParameterNames),
+	length(ConfigInitParameterNames, NConfigInitParameterNames),
+	atomic_list_concat(['\tConfig.InitParameters = ',NConfigInitParameterNames], NConfigInitParameterNamesMsg),
+	jpl_call(W, println, [NConfigInitParameterNamesMsg], _),
+	(   member(ConfigInitParameterName, ConfigInitParameterNames),
+	jpl_call(Config, getInitParameter, [ConfigInitParameterName], ConfigInitParameter),
+	atomic_list_concat(['\t\tConfig.InitParameter[',ConfigInitParameterName,'] = ',ConfigInitParameter], ConfigInitParameterMsg),
+	jpl_call(W, println, [ConfigInitParameterMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(W, println, ['\nrequest stuff:'], _),
+
+	jpl_call(Request, getAttributeNames, [], AttributeNameEnum),
+	jpl_enumeration_to_list(AttributeNameEnum, AttributeNames),
+	length(AttributeNames, NAttributeNames),
+	atomic_list_concat(['\tRequest.Attributes = ',NAttributeNames], NAttributeNamesMsg),
+	jpl_call(W, println, [NAttributeNamesMsg], _),
+	(   member(AttributeName, AttributeNames),
+	jpl_call(Request, getAttribute, [AttributeName], Attribute),
+	jpl_call(Attribute, toString, [], AttributeString),
+	atomic_list_concat(['\t\tRequest.Attribute[',AttributeName,'] = ',AttributeString], AttributeMsg),
+	jpl_call(W, println, [AttributeMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(Request, getCharacterEncoding, [], CharacterEncoding),
+	(   CharacterEncoding == @(null)
+	->  CharacterEncodingAtom = ''
+	;   CharacterEncodingAtom = CharacterEncoding
+	),
+	atomic_list_concat(['\tRequest.CharacterEncoding',' = ',CharacterEncodingAtom], CharacterEncodingMsg),
+	jpl_call(W, println, [CharacterEncodingMsg], _),
+
+	jpl_call(Request, getContentLength, [], ContentLength),
+	atomic_list_concat(['\tRequest.ContentLength',' = ',ContentLength], ContentLengthMsg),
+	jpl_call(W, println, [ContentLengthMsg], _),
+
+	jpl_call(Request, getContentType, [], ContentType),
+	(   ContentType == @(null)
+	->  ContentTypeAtom = ''
+	;   ContentTypeAtom = ContentType
+	),
+	atomic_list_concat(['\tRequest.ContentType',' = ',ContentTypeAtom], ContentTypeMsg),
+	jpl_call(W, println, [ContentTypeMsg], _),
+
+	jpl_call(Request, getParameterNames, [], ParameterNameEnum),
+	jpl_enumeration_to_list(ParameterNameEnum, ParameterNames),
+	length(ParameterNames, NParameterNames),
+	atomic_list_concat(['\tRequest.Parameters = ',NParameterNames], NParameterNamesMsg),
+	jpl_call(W, println, [NParameterNamesMsg], _),
+	(   member(ParameterName, ParameterNames),
+	jpl_call(Request, getParameter, [ParameterName], Parameter),
+	atomic_list_concat(['\t\tRequest.Parameter[',ParameterName,'] = ',Parameter], ParameterMsg),
+	jpl_call(W, println, [ParameterMsg], _),
+	fail
+	;   true
+	),
+
+	jpl_call(Request, getProtocol, [], Protocol),
+	atomic_list_concat(['\tRequest.Protocol',' = ',Protocol], ProtocolMsg),
+	jpl_call(W, println, [ProtocolMsg], _),
+
+	jpl_call(Request, getRemoteAddr, [], RemoteAddr),
+	atomic_list_concat(['\tRequest.RemoteAddr',' = ',RemoteAddr], RemoteAddrMsg),
+	jpl_call(W, println, [RemoteAddrMsg], _),
+
+	jpl_call(Request, getRemoteHost, [], RemoteHost),
+	atomic_list_concat(['\tRequest.RemoteHost',' = ',RemoteHost], RemoteHostMsg),
+	jpl_call(W, println, [RemoteHostMsg], _),
+
+	jpl_call(Request, getScheme, [], Scheme),
+	atomic_list_concat(['\tRequest.Scheme',' = ',Scheme], SchemeMsg),
+	jpl_call(W, println, [SchemeMsg], _),
+
+	jpl_call(Request, getServerName, [], ServerName),
+	atomic_list_concat(['\tRequest.ServerName',' = ',ServerName], ServerNameMsg),
+	jpl_call(W, println, [ServerNameMsg], _),
+
+	jpl_call(Request, getServerPort, [], ServerPort),
+	atomic_list_concat(['\tRequest.ServerPort',' = ',ServerPort], ServerPortMsg),
+	jpl_call(W, println, [ServerPortMsg], _),
+
+	jpl_call(Request, isSecure, [], @(Secure)),
+	atomic_list_concat(['\tRequest.Secure',' = ',Secure], SecureMsg),
+	jpl_call(W, println, [SecureMsg], _),
+
+	jpl_call(W, println, ['\nHTTP request stuff:'], _),
+
+	jpl_call(Request, getAuthType, [], AuthType),
+	(   AuthType == @(null)
+	->  AuthTypeAtom = ''
+	;   AuthTypeAtom = AuthType
+	),
+	atomic_list_concat(['\tRequest.AuthType',' = ',AuthTypeAtom], AuthTypeMsg),
+	jpl_call(W, println, [AuthTypeMsg], _),
+
+	jpl_call(Request, getContextPath, [], ContextPath),
+	(   ContextPath == @(null)
+	->  ContextPathAtom = ''
+	;   ContextPathAtom = ContextPath
+	),
+	atomic_list_concat(['\tRequest.ContextPath',' = ',ContextPathAtom], ContextPathMsg),
+	jpl_call(W, println, [ContextPathMsg], _),
+
+	jpl_call(Request, getCookies, [], CookieArray),
+	(   CookieArray == @(null)
+	->  Cookies = []
+	;   jpl_array_to_list(CookieArray, Cookies)
+	),
+	length(Cookies, NCookies),
+	atomic_list_concat(['\tRequest.Cookies',' = ',NCookies], NCookiesMsg),
+	jpl_call(W, println, [NCookiesMsg], _),
+	(   nth0(NCookie, Cookies, Cookie),
+	atomic_list_concat(['\t\tRequest.Cookie[',NCookie,']'], CookieMsg),
+	jpl_call(W, println, [CookieMsg], _),
+
+	jpl_call(Cookie, getName, [], CookieName),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Name = ',CookieName], CookieNameMsg),
+	jpl_call(W, println, [CookieNameMsg], _),
+
+	jpl_call(Cookie, getValue, [], CookieValue),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Value = ',CookieValue], CookieValueMsg),
+	jpl_call(W, println, [CookieValueMsg], _),
+
+	jpl_call(Cookie, getPath, [], CookiePath),
+	(   CookiePath == @(null)
+	->  CookiePathAtom = ''
+	;   CookiePathAtom = CookiePath
+	),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Path = ',CookiePathAtom], CookiePathMsg),
+	jpl_call(W, println, [CookiePathMsg], _),
+
+	jpl_call(Cookie, getComment, [], CookieComment),
+	(   CookieComment == @(null)
+	->  CookieCommentAtom = ''
+	;   CookieCommentAtom = CookieComment
+	),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Comment = ',CookieCommentAtom], CookieCommentMsg),
+	jpl_call(W, println, [CookieCommentMsg], _),
+
+	jpl_call(Cookie, getDomain, [], CookieDomain),
+	(   CookieDomain == @(null)
+	->  CookieDomainAtom = ''
+	;   CookieDomainAtom = CookieDomain
+	),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Domain = ',CookieDomainAtom], CookieDomainMsg),
+	jpl_call(W, println, [CookieDomainMsg], _),
+
+	jpl_call(Cookie, getMaxAge, [], CookieMaxAge),
+	atomic_list_concat(['\t\t\tRequest.Cookie.MaxAge = ',CookieMaxAge], CookieMaxAgeMsg),
+	jpl_call(W, println, [CookieMaxAgeMsg], _),
+
+	jpl_call(Cookie, getVersion, [], CookieVersion),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Version = ',CookieVersion], CookieVersionMsg),
+	jpl_call(W, println, [CookieVersionMsg], _),
+
+	jpl_call(Cookie, getSecure, [], @(CookieSecure)),
+	atomic_list_concat(['\t\t\tRequest.Cookie.Secure',' = ',CookieSecure], CookieSecureMsg),
+	jpl_call(W, println, [CookieSecureMsg], _),
+
+	fail
+	;   true
+	),
+
+	jpl_call(W, println, ['
    '], _), + + true. + +%------------------------------------------------------------------------------ + +% jpl_servlet_byval(+MultiMap, -ContentType, -BodyAtom) :- +% this exemplifies an alternative (to jpl_servlet_byref) tactic +% for implementing a servlet in Prolog; +% most Request fields are extracted in Java before this is called, +% and passed in as a multimap (a map, some of whose values are maps) + +jpl_servlet_byval(MM, CT, Ba) :- + CT = 'text/html', + multimap_to_atom(MM, MMa), + atomic_list_concat(['', + '

    jpl_servlet_byval/3 says:

    ',
+		     MMa,
+		     '
    ' + ], Ba). + +%------------------------------------------------------------------------------ + +%type jpl_cache_type_of_ref(jpl_type, ref) + +% jpl_cache_type_of_ref(+Type, +Ref) :- +% Type must be a proper (concrete) JPL type; +% Ref must be a proper JPL reference (not void); +% Type is memoed (if policy so dictates) as the type of the referenced object (unless it's null) +% by iref (so as not to disable atom-based GC) +% NB obsolete lemmas must be watched-out-for and removed + +jpl_cache_type_of_ref(T, @(Tag)) :- + ( jpl_assert_policy( jpl_iref_type_cache(_,_), no) + -> true + ; \+ ground(T) % shouldn't happen (implementation error) + -> write('[jpl_cache_type_of_ref/2: arg 1 is not ground]'), nl, % oughta throw an exception + fail + ; \+ atom(Tag) % shouldn't happen (implementation error) + -> write('[jpl_cache_type_of_ref/2: arg 2 is not an atomic-tag ref]'), nl, % oughta throw an exception + fail + ; Tag == null % a null ref? (this is valid) + -> true % silently ignore it + ; jni_tag_to_iref(Tag, Iref) + -> ( jpl_iref_type_cache(Iref, TC) % we expect TC == T + -> ( T == TC + -> true + ; % write('[JPL: found obsolete tag-type lemma...]'), nl, % or keep statistics? (why?) + retractall(jpl_iref_type_cache(Iref,_)), + jpl_assert(jpl_iref_type_cache(Iref,T)) + ) + ; jpl_assert(jpl_iref_type_cache(Iref,T)) + ) + ; write('[jpl_cache_type_of_ref/2: jni_tagatom_to_iref(Tag,_) failed]'), nl, % oughta throw an exception + fail + ). + +%------------------------------------------------------------------------------ + +% jpl_class_tag_type_cache(-Tag, -ClassType) :- +% Tag is the tag part of an @(Tag) reference +% to a JVM instance of java.lang.Class +% which denotes ClassType; +% we index on Tag rather than on Iref so as to keep these objects around +% even after an atom garbage collection +% (if needed once, they are likely to be needed again) + +:- dynamic jpl_class_tag_type_cache/2. + +%------------------------------------------------------------------------------ + +% jpl_class_to_ancestor_classes(+Class, -AncestorClasses) :- +% AncestorClasses will be a list of (JPL references to) instances of java.lang.Class +% denoting the "implements" lineage (?), nearest first +% (the first member denotes the class which Class directly implements, +% the next (if any) denotes the class which *that* class implements, +% and so on to java.lang.Object) + +jpl_class_to_ancestor_classes(C, Cas) :- + ( jpl_class_to_super_class(C, Ca) + -> Cas = [Ca|Cas2], + jpl_class_to_ancestor_classes(Ca, Cas2) + ; Cas = [] + ). + +%------------------------------------------------------------------------------ + +% jpl_class_to_classname(+Class, -ClassName) :- +% Class is a reference to a class object; +% ClassName is its canonical (?) source-syntax (dotted) name, +% e.g. 'java.util.Date' +% not used outside jni_junk and jpl_test (is this (still) true?); +% oughta use the available caches (but their indexing doesn't suit) + +jpl_class_to_classname(C, CN) :- + jpl_call(C, getName, [], CN). + +%------------------------------------------------------------------------------ + +% jpl_class_to_raw_classname(+Class, -ClassName) :- +% hmm, I forget exactly what a "raw" classname is... + +jpl_class_to_raw_classname(Cobj, CN) :- + jpl_classname_to_class('java.lang.Class', CC), % cached? + jGetMethodID(CC, getName, method([],class([java,lang],['String'])), MIDgetName), + jCallObjectMethod(Cobj, MIDgetName, [], [], S), + S = CN. + +%------------------------------------------------------------------------------ + +% jpl_class_to_raw_classname_chars(+Class, -ClassnameChars) :- +% Class is a reference to a class object; +% ClassnameChars is a chars representation of its dotted name, e.g. +% "java.util.Date" + +jpl_class_to_raw_classname_chars(Cobj, CsCN) :- + jpl_class_to_raw_classname(Cobj, CN), + atom_codes(CN, CsCN). + +%------------------------------------------------------------------------------ + +jpl_class_to_super_class(C, Cx) :- + jGetSuperclass(C, Cx), + Cx \== @(null), % as returned when C is java.lang.Object, i.e. no superclass + jpl_cache_type_of_ref(class([java,lang],['Class']), Cx). + +%------------------------------------------------------------------------------ + +% jpl_class_to_type(+ClassObject, -Type) :- +% ClassObject is a reference to a class object of Type +% NB should ensure that, if not found in cache, then cache is updated; +% intriguingly (?), getParameterTypes returns class objects with names +% 'boolean', 'byte' etc. and even 'void' (?!) + +jpl_class_to_type(@(Tag), Type) :- + ( jpl_class_tag_type_cache(Tag, Tx) + -> true + ; jpl_class_to_raw_classname_chars(@(Tag), Cs), % uncached + jpl_classname_chars_to_type(Cs, Tr), + jpl_type_to_canonical_type(Tr, Tx), % map e.g. class([],[byte]) -> byte + jpl_assert(jpl_class_tag_type_cache(Tag,Tx)) + -> true % the elseif goal should be determinate, but just in case... + ), + Type = Tx. + +%------------------------------------------------------------------------------ + +jpl_classes_to_types([], []). + +jpl_classes_to_types([C|Cs], [T|Ts]) :- + jpl_class_to_type(C, T), + jpl_classes_to_types(Cs, Ts). + +%------------------------------------------------------------------------------ + +jpl_classname_chars_to_type(Cs, Type) :- + ( phrase(jpl_type_classname_1(Type), Cs) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_classname_to_class(+ClassName, -Class) :- +% ClassName unambiguously represents a class, +% e.g. 'java.lang.String' +% Class is a (canonical) reference to the corresponding class object; +% uses caches where the class is already encountered + +jpl_classname_to_class(N, C) :- + jpl_classname_to_type(N, T), % cached + jpl_type_to_class(T, C). % cached + +%------------------------------------------------------------------------------ + +% jpl_classname_to_type(+Classname, -Type) :- +% Classname is a source-syntax (dotted) class name, +% e.g. 'java.util.Date', '[java.util.Date' or '[L' +% Type is its corresponding JPL type structure, +% e.g. class([java,util],['Date']), array(class([java,util],['Date'])), array(long) +% +%thinks +% by "classname" do I mean "typename"? +% should this throw an exception for unbound CN? is this public API? + +jpl_classname_to_type(CN, T) :- + ( jpl_classname_type_cache(CN, Tx) + -> Tx = T + ; atom_codes(CN, CsCN), + phrase(jpl_type_classname_1(T), CsCN) + -> jpl_assert(jpl_classname_type_cache(CN,T)), + true + ). + +%------------------------------------------------------------------------------ + +% jpl_classname_type_cache( -Classname, -Type) :- +% Classname is the atomic name of Type; +% NB may denote a class which cannot be found + +:- dynamic jpl_classname_type_cache/2. + +%------------------------------------------------------------------------------ + +% jpl_datum_to_type(+Datum, -Type) :- +% Datum must be a proper JPL representation +% of an instance of one (or more) Java types; +% Type is the unique most specialised type of which Datum denotes an instance; +% N.B. 3 is an instance of byte, char, short, int and long, +% of which byte and char are the joint, overlapping most specialised types, +% so this relates 3 to the pseudo subtype 'char_byte'; +% see jpl_type_to_preferred_concrete_type/2 for converting inferred types +% to instantiable types + +jpl_datum_to_type(D, T) :- + ( jpl_value_to_type(D, T) + -> true + ; jpl_ref_to_type(D, T) + -> true + ; nonvar( D), + D = {Term} + -> ( cyclic_term(Term) + -> throw(error(type_error(acyclic,Term), + context(jpl_datum_to_type/2,'must be acyclic'))) + ; atom( Term) + -> T = class([jpl],['Atom']) + ; integer( Term) + -> T = class([jpl],['Integer']) + ; float( Term) + -> T = class([jpl],['Float']) + ; var( Term) + -> T = class([jpl],['Variable']) + ; T = class([jpl],['Compound']) + ) + ). + +%------------------------------------------------------------------------------ + +jpl_datums_to_most_specific_common_ancestor_type([D], T) :- + jpl_datum_to_type(D, T). + +jpl_datums_to_most_specific_common_ancestor_type([D1,D2|Ds], T0) :- + jpl_datum_to_type(D1, T1), + jpl_type_to_ancestor_types(T1, Ts1), + jpl_datums_to_most_specific_common_ancestor_type_1([D2|Ds], [T1|Ts1], [T0|_]). + +%------------------------------------------------------------------------------ + +jpl_datums_to_most_specific_common_ancestor_type_1([], Ts, Ts). + +jpl_datums_to_most_specific_common_ancestor_type_1([D|Ds], Ts1, Ts0) :- + jpl_datum_to_type(D, Tx), + jpl_lineage_types_type_to_common_lineage_types(Ts1, Tx, Ts2), + jpl_datums_to_most_specific_common_ancestor_type_1(Ds, Ts2, Ts0). + +%------------------------------------------------------------------------------ + +% jpl_datums_to_types(+Datums, -Types) :- +% each member of Datums is a JPL value or ref, +% denoting an instance of some Java type, +% and the corresponding member of Types denotes the most specialised type +% of which it is an instance (including some I invented for the overlaps +% between char and short, etc,) + +jpl_datums_to_types([], []). + +jpl_datums_to_types([D|Ds], [T|Ts]) :- + jpl_datum_to_type(D, T), + jpl_datums_to_types(Ds, Ts). + +%------------------------------------------------------------------------------ + +% jpl_false(-X) :- +% X is (by unification) the proper JPL datum which represents the Java boolean value 'false' +% c.f. jpl_is_false/1 + +jpl_false(@(false)). + +%------------------------------------------------------------------------------ + +% jpl_ground_is_type(+X) :- +% X, known to be ground, is (or at least superficially resembles :-) a JPL type + +jpl_ground_is_type(X) :- + jpl_primitive_type(X), + !. + +jpl_ground_is_type(array(X)) :- + jpl_ground_is_type(X). + +jpl_ground_is_type(class(_,_)). + +jpl_ground_is_type(method(_,_)). + +%------------------------------------------------------------------------------ + +:- dynamic jpl_iref_type_cache/2. + +%------------------------------------------------------------------------------ + +% jpl_is_class(?X) :- +% X is a JPL ref to a java.lang.Class object + +jpl_is_class(X) :- + jpl_is_object(X), + jpl_object_to_type(X, class([java,lang],['Class'])). + +%------------------------------------------------------------------------------ + +% jpl_is_false(?X) :- +% X is the proper JPL datum which represents the Java boolean value 'false'; +% whatever, no further instantiation of X occurs + +jpl_is_false(X) :- + X == @(false). + +%------------------------------------------------------------------------------ + +% jpl_is_fieldID(?X) :- +% X is a proper JPL field ID structure (jfieldID/1); +% applications should not be messing with these (?); +% whatever, no further instantiation of X occurs + +jpl_is_fieldID(jfieldID(X)) :- % NB a var arg may get bound... + integer(X). + +%------------------------------------------------------------------------------ + +% jpl_is_methodID(?X) :- +% X is a proper JPL method ID structure (jmethodID/1); +% applications should not be messing with these (?); +% whatever, no further instantiation of X occurs + +jpl_is_methodID(jmethodID(X)) :- % NB a var arg may get bound... + integer(X). + +%------------------------------------------------------------------------------ + +% jpl_is_null(?X) :- +% X is the proper JPL datum which represents Java's 'null' reference; +% whatever, no further instantiation of X occurs + +jpl_is_null(X) :- + X == @(null). + +%------------------------------------------------------------------------------ + +% jpl_is_object(?X) :- +% X is a proper, plausible JPL object reference; +% NB this checks only syntax, not whether the object exists; +% whatever, no further instantiation of X occurs + +jpl_is_object(X) :- + jpl_is_ref(X), % (syntactically, at least...) + X \== @(null). + +%------------------------------------------------------------------------------ + +% jpl_is_object_type(+T) :- +% T is an object (class or array) type, +% not e.g. a primitive, null or void + +jpl_is_object_type(T) :- + \+ var(T), + jpl_non_var_is_object_type(T). + +%------------------------------------------------------------------------------ + +% jpl_is_ref(?T) :- +% the arbitrary term T is a proper, syntactically plausible JPL reference, +% either to a Java object +% (which may not exist, although a jpl_is_current_ref/1 might be useful) +% or to Java's notional but important 'null' non-object; +% whatever, no further instantiation of X occurs; +% NB to distinguish tags from void/false/true, +% could check initial character(s) or length? or adopt strong/weak scheme... + +jpl_is_ref(@(Y)) :- + atom(Y), % presumably a (garbage-collectable) tag + Y \== void, % not a ref + Y \== false, % not a ref + Y \== true. % not a ref + +%------------------------------------------------------------------------------ + +% jpl_is_true(?X) :- +% X is a proper JPL datum, representing the Java boolean value 'true'; +% whatever, no further instantiation of X occurs + +jpl_is_true(X) :- + X == @(true). + +%------------------------------------------------------------------------------ + +% jpl_is_type(+X) :- + +jpl_is_type(X) :- + ground(X), + jpl_ground_is_type(X). + +%------------------------------------------------------------------------------ + +% jpl_is_void(?X) :- +% X is the proper JPL datum which represents the pseudo Java value 'void' +% (which is returned by jpl_call/4 when invoked on void methods); +% NB you can try passing 'void' back to Java, but it won't ever be interested; +% whatever, no further instantiation of X occurs + +jpl_is_void(X) :- + X == @(void). + +%------------------------------------------------------------------------------ + +jpl_lineage_types_type_to_common_lineage_types(Ts, Tx, Ts0) :- + ( append(_, [Tx|Ts2], Ts) + -> [Tx|Ts2] = Ts0 + ; jpl_type_to_super_type(Tx, Tx2) + -> jpl_lineage_types_type_to_common_lineage_types(Ts, Tx2, Ts0) + ). + +%------------------------------------------------------------------------------ + +jpl_non_var_is_object_type(class(_,_)). + +jpl_non_var_is_object_type(array(_)). + +%------------------------------------------------------------------------------ + +% jpl_null(-X) :- +% X is (by unification) the proper JPL datum which represents the Java reference 'null'; +% c.f. jpl_is_null/1 + +jpl_null(@(null)). + +%------------------------------------------------------------------------------ + +% jpl_object_array_to_list(+ArrayObject, -Values) :- +% Values is a list of JPL values (primitive values or object references) +% representing the respective elements of ArrayObject + +jpl_object_array_to_list(A, Vs) :- + jpl_array_to_length(A, N), + jpl_object_array_to_list_1(A, 0, N, Vs). + +%------------------------------------------------------------------------------ + +% jpl_object_array_to_list_1(+A, +I, +N, -Xs) :- + +jpl_object_array_to_list_1(A, I, N, Xs) :- + ( I == N + -> Xs = [] + ; jGetObjectArrayElement(A, I, X), + Xs = [X|Xs2], + J is I+1, + jpl_object_array_to_list_1(A, J, N, Xs2) + ). + +%------------------------------------------------------------------------------ + +% jpl_object_to_class(+Object, -Class) :- +% Object must be a valid object (should this throw an exception otherwise?); +% Class is a (canonical) reference to the (canonical) class object +% which represents the class of Object; +% NB wot's the point of caching the type if we don't look there first? + +jpl_object_to_class(Obj, C) :- + jGetObjectClass(Obj, C), + jpl_cache_type_of_ref(class([java,lang],['Class']), C). + +%------------------------------------------------------------------------------ + +% jpl_object_to_type(+Object, -Type) :- +% Object must be a proper JPL reference to a Java object +% (i.e. a class or array instance, but not null, void or String); +% Type is the JPL type of that object + +jpl_object_to_type(@(Tag), Type) :- + jpl_tag_to_type(Tag, Type). + +%------------------------------------------------------------------------------ + +jpl_object_type_to_super_type(T, Tx) :- + ( ( T = class(_,_) + ; T = array(_) + ) + -> jpl_type_to_class(T, C), + jpl_class_to_super_class(C, Cx), + Cx \== @(null), + jpl_class_to_type(Cx, Tx) + ). + +%------------------------------------------------------------------------------ + +% jpl_primitive_buffer_to_array(+Type, +Xc, +Bp, +I, +Size, -Vcs) :- +% Bp points to a buffer of (sufficient) Type values; +% Vcs will be unbound on entry, +% and on exit will be a list of Size of them, starting at index I +% (the buffer is indexed from zero) + +jpl_primitive_buffer_to_array(T, Xc, Bp, I, Size, [Vc|Vcs]) :- + jni_fetch_buffer_value(Bp, I, Vc, Xc), + Ix is I+1, + ( Ix < Size + -> jpl_primitive_buffer_to_array(T, Xc, Bp, Ix, Size, Vcs) + ; Vcs = [] + ). + +%------------------------------------------------------------------------------ + +jpl_primitive_type(boolean). +jpl_primitive_type(char). +jpl_primitive_type(byte). +jpl_primitive_type(short). +jpl_primitive_type(int). +jpl_primitive_type(long). +jpl_primitive_type(float). +jpl_primitive_type(double). + +%------------------------------------------------------------------------------ + +% jpl_primitive_type_default_value(-Type, -Value) :- +% each element of any array of (primitive) Type created by jpl_new/3, +% or any instance of (primitive) Type created by jpl_new/3, +% should be initialised to Value (to mimic Java semantics) + +jpl_primitive_type_default_value(boolean, @(false)). +jpl_primitive_type_default_value(char, 0). +jpl_primitive_type_default_value(byte, 0). +jpl_primitive_type_default_value(short, 0). +jpl_primitive_type_default_value(int, 0). +jpl_primitive_type_default_value(long, 0). +jpl_primitive_type_default_value(float, 0.0). +jpl_primitive_type_default_value(double, 0.0). + +%------------------------------------------------------------------------------ + +jpl_primitive_type_super_type(T, Tx) :- + ( jpl_type_fits_type_direct_prim(T, Tx) + ; jpl_type_fits_type_direct_xtra(T, Tx) + ). + +%------------------------------------------------------------------------------ + +% jpl_primitive_type_term_to_value(+Type, +Term, -Val) :- +% Term, after widening iff appropriate, represents an instance of Type; +% Val is the instance of Type which it represents (often the same thing); +% currently used only by jpl_new_1 when creating an "instance" +% of a primitive type (which may be misguided completism - you can't +% do that in Java) + +jpl_primitive_type_term_to_value(Type, Term, Val) :- + ( jpl_primitive_type_term_to_value_1(Type, Term, Val) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_primitive_type_term_to_value_1(+Type, +RawValue, -WidenedValue) :- +% I'm not worried about structure duplication here +% NB this oughta be done in foreign code... + +jpl_primitive_type_term_to_value_1(boolean, @(false), @(false)). + +jpl_primitive_type_term_to_value_1(boolean, @(true), @(true)). + +jpl_primitive_type_term_to_value_1(char, I, I) :- + integer(I), + I >= 0, + I =< 65535. % (2**16)-1. + +jpl_primitive_type_term_to_value_1(byte, I, I) :- + integer(I), + I >= 128, % -(2**7) + I =< 127. % (2**7)-1 + +jpl_primitive_type_term_to_value_1(short, I, I) :- + integer(I), + I >= -32768, % -(2**15) + I =< 32767. % (2**15)-1 + +jpl_primitive_type_term_to_value_1(int, I, I) :- + integer(I), + I >= -2147483648, % -(2**31) + I =< 2147483647. % (2**31)-1 + +jpl_primitive_type_term_to_value_1(long, I, I) :- + integer(I), + I >= -9223372036854775808, % -(2**63) + I =< 9223372036854775807. % (2**63)-1 + +jpl_primitive_type_term_to_value_1(float, I, F) :- + integer(I), + F is float(I). + +jpl_primitive_type_term_to_value_1(float, F, F) :- + float(F). + +jpl_primitive_type_term_to_value_1(double, I, F) :- + integer(I), + F is float(I). + +jpl_primitive_type_term_to_value_1(double, F, F) :- + float(F). + +%------------------------------------------------------------------------------ + +jpl_primitive_type_to_ancestor_types(T, Ts) :- + ( jpl_primitive_type_super_type(T, Ta) + -> Ts = [Ta|Tas], + jpl_primitive_type_to_ancestor_types(Ta, Tas) + ; Ts = [] + ). + +%------------------------------------------------------------------------------ + +jpl_primitive_type_to_super_type(T, Tx) :- + jpl_primitive_type_super_type(T, Tx). + +%------------------------------------------------------------------------------ + +% jpl_ref_to_type(+Ref, -Type) :- +% Ref must be a proper JPL reference (to an object, null or void); +% Type is its type + +jpl_ref_to_type(@(X), T) :- + ( X == null + -> T = null + ; X == void + -> T = void + ; jpl_tag_to_type(X, T) + ). + +%------------------------------------------------------------------------------ + +% jpl_tag_to_type(+Tag, -Type) :- +% Tag must be an (atomic) object tag; +% Type is its type (either from the cache or by reflection); + +jpl_tag_to_type(Tag, Type) :- + jni_tag_to_iref(Tag, Iref), + ( jpl_iref_type_cache(Iref, T) + -> true % T is Tag's type + ; jpl_object_to_class(@(Tag), Cobj), % else get ref to class obj + jpl_class_to_type(Cobj, T), % get type of class it denotes + jpl_assert(jpl_iref_type_cache(Iref,T)) + ), + Type = T. + +%------------------------------------------------------------------------------ + +% jpl_true(-X) :- +% X is (by unification) the proper JPL datum which represents the Java boolean value 'true'; +%cf jpl_is_true/1 + +jpl_true(@(true)). + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type(+TypeX, +TypeY) :- +% TypeX and TypeY must each be proper JPL types; +% this succeeds iff TypeX is assignable to TypeY + +jpl_type_fits_type(Tx, Ty) :- + ( jpl_type_fits_type_1(Tx, Ty) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type_1(+T1, +T2) :- +% it doesn't matter that this leaves choicepoints; it serves only jpl_type_fits_type/2 + +jpl_type_fits_type_1(T, T). + +% vsc: seems to make sense. + +jpl_type_fits_type_1(class(Ps1,Cs1), class(Ps2,Cs2)) :- + jpl_type_to_class(class(Ps1,Cs1), C1), + jpl_type_to_class(class(Ps2,Cs2), C2), + jIsAssignableFrom(C1, C2). + +jpl_type_fits_type_1(array(T1), class(Ps2,Cs2)) :- + jpl_type_to_class(array(T1), C1), + jpl_type_to_class(class(Ps2,Cs2), C2), + jIsAssignableFrom(C1, C2). + +jpl_type_fits_type_1(array(T1), array(T2)) :- + jpl_type_fits_type_1(T1, T2). + +jpl_type_fits_type_1(array(T1), array(T2)) :- + jpl_type_to_class(array(T1), C1), + jpl_type_to_class(array(T2), C2), + jIsAssignableFrom(C1, C2). + +jpl_type_fits_type_1(null, class(_,_)). + +jpl_type_fits_type_1(null, array(_)). + +jpl_type_fits_type_1(T1, T2) :- + jpl_type_fits_type_xprim(T1, T2). + +%------------------------------------------------------------------------------ + +jpl_type_fits_type_direct_prim(float, double). +jpl_type_fits_type_direct_prim(long, float). +jpl_type_fits_type_direct_prim(int, long). +jpl_type_fits_type_direct_prim(char, int). +jpl_type_fits_type_direct_prim(short, int). +jpl_type_fits_type_direct_prim(byte, short). + +%------------------------------------------------------------------------------ + +jpl_type_fits_type_direct_xprim(Tp, Tq) :- + jpl_type_fits_type_direct_prim(Tp, Tq). + +jpl_type_fits_type_direct_xprim(Tp, Tq) :- + jpl_type_fits_type_direct_xtra(Tp, Tq). + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type_direct_xtra(-PseudoType, -ConcreteType) :- +% this predicate defines the direct subtype-supertype relationships +% which involve the intersection pseudo types char_int, char_short and char_byte + +jpl_type_fits_type_direct_xtra(char_int, int). % char_int is a direct subtype of int +jpl_type_fits_type_direct_xtra(char_int, char). % etc. +jpl_type_fits_type_direct_xtra(char_short, short). +jpl_type_fits_type_direct_xtra(char_short, char). +jpl_type_fits_type_direct_xtra(char_byte, byte). +jpl_type_fits_type_direct_xtra(char_byte, char). + +jpl_type_fits_type_direct_xtra(overlong, float). % 6/Oct/2006 experiment + +%------------------------------------------------------------------------------ + +% jpl_type_fits_type_xprim(-Tp, -T) :- +% indeterminate; +% serves only jpl_type_fits_type_1/2 + +jpl_type_fits_type_xprim(Tp, T) :- + jpl_type_fits_type_direct_xprim(Tp, Tq), + ( Tq = T + ; jpl_type_fits_type_xprim(Tq, T) + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_ancestor_types(+T, -Tas) :- +% this does not accommodate the assignability of null, +% but that's OK (?) since "type assignability" and "type ancestry" are not equivalent + +jpl_type_to_ancestor_types(T, Tas) :- + ( ( T = class(_,_) + ; T = array(_) + ) + -> jpl_type_to_class(T, C), + jpl_class_to_ancestor_classes(C, Cas), + jpl_classes_to_types(Cas, Tas) + ; jpl_primitive_type_to_ancestor_types(T, Tas) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_canonical_type(+Type, -CanonicalType) :- +% Type must be a type, not necessarily canonical; +% CanonicalType will be equivalent and canonical + +%eg jpl_type_to_canonical_type(class([],[byte]), byte) + +jpl_type_to_canonical_type(array(T), array(Tc)) :- + !, + jpl_type_to_canonical_type(T, Tc). + +jpl_type_to_canonical_type(class([],[void]), void) :- + !. + +jpl_type_to_canonical_type(class([],[N]), N) :- + jpl_primitive_type(N), + !. + +jpl_type_to_canonical_type(class(Ps,Cs), class(Ps,Cs)) :- + !. + +jpl_type_to_canonical_type(void, void) :- + !. + +jpl_type_to_canonical_type(P, P) :- + jpl_primitive_type(P). + +%------------------------------------------------------------------------------ + +% jpl_type_to_class(+Type, -ClassObject) :- +% incomplete types are now never cached (or otherwise passed around); +% jFindClass throws an exception if FCN can't be found + +%nb if this is public API maybe oughta restore the ground(T) check and throw exception + +jpl_type_to_class(T, @(Tag)) :- + % ground(T), % 9/Nov/2004 removed this spurious (?) check + ( jpl_class_tag_type_cache(ClassTag,T) + -> Tag = ClassTag + ; ( jpl_type_to_findclassname(T, FCN) % peculiar syntax for FindClass() + -> jFindClass(FCN, @(ClassTag)), % which caches type of @ClassTag + % jpl_cache_type_of_ref(T, @(ClassTag)) + jpl_cache_type_of_ref(class([java,lang],['Class']), @(ClassTag)) % 9/Nov/2004 bugfix (?) + ), + jpl_assert(jpl_class_tag_type_cache(ClassTag,T)) + ), + Tag = ClassTag. + +%------------------------------------------------------------------------------ + +% jpl_type_to_nicename(+Type, -NiceName) :- +% Type, which is a class or array type (not sure about the others...), +% is denoted by ClassName in dotted syntax + +%nb is this used? is "nicename" well defined and necessary? +%nb this could use caching if indexing were amenable + +%eg jpl_type_to_nicename(class([java,util],['Date']), 'java.util.Date') +%eg jpl_type_to_nicename(boolean, boolean) + +%cf jpl_type_to_classname/2 + +jpl_type_to_nicename(T, NN) :- + ( jpl_primitive_type( T) + -> NN = T + ; ( phrase(jpl_type_classname_1(T), Cs) + -> atom_codes(CNx, Cs), % green commit to first solution + NN = CNx + ) + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_classname(+Type, -ClassName) :- +% Type, which is a class or array type (not sure about the others...), +% is denoted by ClassName in dotted syntax + +%eg jpl_type_to_classname(class([java,util],['Date']), 'java.util.Date') + +%cf jpl_type_to_nicename/2 + +jpl_type_to_classname(T, CN) :- + ( phrase(jpl_type_classname_1(T), Cs) + -> atom_codes(CNx, Cs), % green commit to first solution + CN = CNx + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_descriptor(+Type, -Descriptor) :- +% Type (denoting any Java type) +% (can also be a JPL method/2 structure (?!)) +% is represented by Descriptor (JVM internal syntax) +% I'd cache this, but I'd prefer more efficient indexing on types (hashed?) + +jpl_type_to_descriptor(T, D) :- + ( phrase(jpl_type_descriptor_1(T), Cs) + -> atom_codes(Dx, Cs), + D = Dx + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_findclassname(+Type, -FindClassName) :- +% FindClassName denotes Type (class or array only) +% in the syntax required peculiarly by FindClass() + +jpl_type_to_findclassname(T, FCN) :- + ( phrase(jpl_type_findclassname(T), Cs) + -> atom_codes(FCNx, Cs), + FCN = FCNx + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_super_type(+Type, -SuperType) :- +% Type oughta be a proper JPL type; +% SuperType is the (at most one) type which it directly implements (if it's a class); +% if Type denotes a class, this works only if that class can be found; +% if Type = array(Type) then I dunno what happens... + +jpl_type_to_super_type(T, Tx) :- + ( jpl_object_type_to_super_type(T, Tx) + -> true + ; jpl_primitive_type_to_super_type(T, Tx) + -> true + ). + +%------------------------------------------------------------------------------ + +% jpl_type_to_preferred_concrete_type( +Type, -ConcreteType) :- +% Type must be a canonical JPL type, +% possibly a pseudo (inferred) type such as char_int or array(char_byte); +% ConcreteType is the preferred concrete (Java-instantiable) type; +% introduced 16/Apr/2005 to fix bug whereby jpl_list_to_array([1,2,3],A) failed +% because the lists's inferred type of array(char_byte) is not Java-instantiable + +jpl_type_to_preferred_concrete_type( T, Tc) :- + ( jpl_type_to_preferred_concrete_type_1( T, TcX) + -> Tc = TcX + ). + +%------------------------------------------------------------------------------ + +jpl_type_to_preferred_concrete_type_1( char_int, int). + +jpl_type_to_preferred_concrete_type_1( char_short, short). + +jpl_type_to_preferred_concrete_type_1( char_byte, byte). + +jpl_type_to_preferred_concrete_type_1( array(T), array(Tc)) :- + jpl_type_to_preferred_concrete_type_1( T, Tc). + +jpl_type_to_preferred_concrete_type_1( T, T). + +%------------------------------------------------------------------------------ + +% jpl_types_fit_type(+Types, +Type) :- +% each member of Types is (independently) (if that means anything) +% assignable to Type +% e.g. for dynamic type check when attempting to assign list of values to array + +jpl_types_fit_type([], _). + +jpl_types_fit_type([T1|T1s], T2) :- + jpl_type_fits_type(T1, T2), + jpl_types_fit_type(T1s, T2). + +%------------------------------------------------------------------------------ + +% jpl_types_fit_types(+Types1, +Types2) :- +% each member type of Types1 "fits" the respective member type of Types2 + +jpl_types_fit_types([], []). + +jpl_types_fit_types([T1|T1s], [T2|T2s]) :- + jpl_type_fits_type(T1, T2), + jpl_types_fit_types(T1s, T2s). + +%------------------------------------------------------------------------------ + +% jpl_value_to_type(+Value, -Type) :- +% Value must be a proper JPL datum other than a ref +% i.e. primitive, String or void; +% it is of (unique most specific) Type, +% which may be one of the pseudo types char_byte, char_short or char_int + +jpl_value_to_type(V, T) :- + ground(V), % critically assumed by jpl_value_to_type_1/2 + ( jpl_value_to_type_1(V, Tv) % 2nd arg must be unbound + -> T = Tv + ). + +%------------------------------------------------------------------------------ + +%% jpl_value_to_type_1(+Value, -Type) is semidet. +% +% Type is the unique most specific JPL type of which Value +% represents an instance; called solely by jpl_value_to_type/2, +% which commits to first solution; +% +% NB some integer values are of JPL-peculiar uniquely most +% specific subtypes, i.e. char_byte, char_short, char_int but all +% are understood by JPL's internal utilities which call this proc +% +% NB we regard float as subtype of double +% +% NB objects and refs always have straightforward types + +jpl_value_to_type_1(@(false), boolean) :- !. +jpl_value_to_type_1(@(true), boolean) :- !. +jpl_value_to_type_1(A, class([java,lang],['String'])) :- % yes it's a "value" + atom(A), !. +jpl_value_to_type_1(I, T) :- + integer(I), !, + ( I >= 0 + -> ( I < 128 + -> T = char_byte + ; I < 32768 -> T = char_short + ; I < 65536 -> T = char_int + ; I < 2147483648 -> T = int + ; I =< 9223372036854775807 -> T = long + ; T = overlong + ) + ; I >= -128 -> T = byte + ; I >= -32768 -> T = short + ; I >= -2147483648 -> T = int + ; I >= -9223372036854775808 -> T = long + ; T = overlong + ). +jpl_value_to_type_1(F, float) :- + float(F). + +%------------------------------------------------------------------------------ + +% jpl_void(-X) :- +% X is (by unification) the proper JPL datum which represents the pseudo Java value 'void'; +% c.f. jpl_is_void/1 + +jpl_void(@(void)). + +%------------------------------------------------------------------------------ + +%type jpl_array_to_length(array, integer) + +% jpl_array_to_length(+ArrayObject, -Length) :- +% must validate ArrayObject before making the JNI call... + +jpl_array_to_length(A, N) :- + ( jpl_ref_to_type(A, array(_)) % can this be done cheaper e.g. in foreign code? + -> jGetArrayLength(A, N) % *must* be array, else undefined (crash?) + ). + +%------------------------------------------------------------------------------ + +%type jpl_array_to_list(array, list(datum)) + +% jpl_array_to_list(+Array, -Elements) :- + +jpl_array_to_list(A, Es) :- + jpl_array_to_length(A, Len), + ( Len > 0 + -> LoBound is 0, + HiBound is Len-1, + jpl_get(A, LoBound-HiBound, Es) + ; Es = [] + ). + +%------------------------------------------------------------------------------ + +%type jpl_datums_to_array(list(datum), array) + +% jpl_datums_to_array(+Ds, -A) :- +% A will be a ref to a new JVM array, +% whose base type is the most specific Java type +% of which each member of Datums is (directly or indirectly) an instance; +% NB this fails (without warning, currently) if: +% Ds is an empty list (no base type can be inferred) +% Ds contains a primitive value and an object or array ref (no common supertype) + +jpl_datums_to_array(Ds, A) :- + ground(Ds), + jpl_datums_to_most_specific_common_ancestor_type(Ds, T), % T may be pseudo e.g. char_byte + jpl_type_to_preferred_concrete_type( T, Tc), % bugfix added 16/Apr/2005 + jpl_new(array(Tc), Ds, A). + +%------------------------------------------------------------------------------ + +%type jpl_datums_to_array(list(datum), type, array) + +% jpl_datums_to_array(+Ds, +Type, -A) :- +% A will be a ref to a new JVM array, +% whose base type is the most specific Java type +% of which each member of Datums is (directly or indirectly) an instance; +% NB this fails (without warning, currently) if: +% Ds is an empty list (no base type can be inferred) +% Ds contains a primitive value and an object or array ref (no common supertype) + +jpl_datums_to_array(Ds, Tc, A) :- + ground(Ds), + ground(Tc), + jpl_new(array(Tc), Ds, A). + +%------------------------------------------------------------------------------ + +%type jpl_enumeration_element(object, datum) + +% jpl_enumeration_element(+Enumeration, -Element) :- +% generates each Element from the Enumeration; +% if the element is a java.lang.String then Element will be an atom; +% if the element is null then Element will (oughta) be null; +% otherwise I reckon it has to be an object ref + +jpl_enumeration_element(En, E) :- + ( jpl_call(En, hasMoreElements, [], @(true)) + -> jpl_call(En, nextElement, [], Ex), + ( E = Ex + ; jpl_enumeration_element(En, E) + ) + ). + +%------------------------------------------------------------------------------ + +%type jpl_enumeration_to_list(object, list(datum)) + +% jpl_enumeration_to_list(+Enumeration, -Elements) :- + +jpl_enumeration_to_list(EN, Es) :- + ( jpl_call(EN, hasMoreElements, [], @(true)) + -> jpl_call(EN, nextElement, [], E), + Es = [E|Es1], + jpl_enumeration_to_list(EN, Es1) + ; Es = [] + ). + +%------------------------------------------------------------------------------ + +%type jpl_hashtable_pair(object, pair(datum,datum)) + +% jpl_hashtable_pair(+HashTable, -KeyValuePair) :- +% generates Key-Value pairs from the given HashTable +% NB String is converted to atom but Integer is presumably returned as an object ref +% (i.e. as elsewhere, no auto unboxing); +%nb this is anachronistic (oughta use the Map interface?) + +jpl_hashtable_pair(HT, K-V) :- + jpl_call(HT, keys, [], Ek), + jpl_enumeration_to_list(Ek, Ks), + member(K, Ks), + jpl_call(HT, get, [K], V). + +%------------------------------------------------------------------------------ + +%type jpl_iterator_element(object, datum) + +% jpl_iterator_element(+Iterator, -Element) :- + +jpl_iterator_element(I, E) :- + ( jpl_call(I, hasNext, [], @(true)) + -> ( jpl_call(I, next, [], E) % surely it's steadfast... + ; jpl_iterator_element(I, E) + ) + ). + +%------------------------------------------------------------------------------ + +%type jpl_list_to_array(list(datum), array) + +% jpl_list_to_array(+Datums, -Array) :- +% Datums is a proper list of JPL datums (values or refs); +% if they have a most specific common supertype, +% Array is an array, of that base type, +% whose respective elements are Datums + +jpl_list_to_array(Ds, A) :- + jpl_datums_to_array(Ds, A). + +%------------------------------------------------------------------------------ + +%type jpl_list_to_array(list(datum), type, array) + +% jpl_list_to_array(+Datums, -Array) :- +% Datums is a proper list of JPL datums (values or refs); +% they must have a common supertype Type, +% Array is an array, of that base Type, +% whose respective elements are Datums + +jpl_list_to_array(Ds, Type, A) :- + jpl_datums_to_array(Ds, Type, A). + +%------------------------------------------------------------------------------ + +%type jpl_terms_to_array(list(term), array) + +% jpl_terms_to_array(+Terms, -Array) :- +% Terms is a proper list of arbitrary terms; +% Array is an array of jpl.Term, +% whose elements represent the respective members of the list + +jpl_terms_to_array(Ts, A) :- + jpl_terms_to_array_1(Ts, Ts2), + jpl_new( array(class([jpl],['Term'])), Ts2, A). + +%------------------------------------------------------------------------------ + +jpl_terms_to_array_1([], []). + +jpl_terms_to_array_1([T|Ts], [{T}|Ts2]) :- + jpl_terms_to_array_1(Ts, Ts2). + +%------------------------------------------------------------------------------ + +%type jpl_map_element(object, pair(datum,datum)) + +% jpl_map_element(+Map, -KeyValue) :- +% Map must be an instance of any implementation of the java.util.Map interface; +% this generates each Key-Value pair from the Map + +jpl_map_element(M, K-V) :- + jpl_call(M, entrySet, [], ES), + jpl_set_element(ES, E), + jpl_call(E, getKey, [], K), + jpl_call(E, getValue, [], V). + +%------------------------------------------------------------------------------ + +%type jpl_set_element(object, datum) + +% jpl_set_element(+Set, -Element) :- + +jpl_set_element(S, E) :- + jpl_call(S, iterator, [], I), + jpl_iterator_element(I, E). + +%------------------------------------------------------------------------------ + +% is_pair(?T) :- +% I define a half-decent "pair" as having a ground key (any val) + +is_pair(Key-_Val) :- + ground(Key). + +%------------------------------------------------------------------------------ + +is_pairs(List) :- + is_list(List), + maplist(is_pair, List). + +%------------------------------------------------------------------------------ + +multimap_to_atom(KVs, A) :- + multimap_to_atom_1(KVs, '', Cz, []), + flatten(Cz, Cs), + atomic_list_concat(Cs, A). + +%------------------------------------------------------------------------------ + +multimap_to_atom_1([], _, Cs, Cs). +multimap_to_atom_1([K-V|KVs], T, Cs1, Cs0) :- + Cs1 = [T,K,' = '|Cs2], + ( is_list(V) + -> ( is_pairs(V) + -> V = V2 + ; findall(N-Ve, nth1(N, V, Ve), V2) + ), + T2 = [' ',T], + Cs2 = ['\n'|Cs2a], + multimap_to_atom_1(V2, T2, Cs2a, Cs3) + ; to_atom(V, AV), + Cs2 = [AV,'\n'|Cs3] + ), + multimap_to_atom_1(KVs, T, Cs3, Cs0). + +%------------------------------------------------------------------------------ + +%% to_atom(+Term, -Atom) +% +% unifies Atom with a printed representation of Term. +% +% @tbd Sort of quoting requirements and use format(codes(Codes), +% ...) + +to_atom(Term, Atom) :- + ( atom(Term) + -> Atom = Term % avoid superfluous quotes + ; term_to_atom(Term, Atom) + ). + +%------------------------------------------------------------------------------ + + /******************************* + * MESSAGES * + *******************************/ + +:- multifile + prolog:error_message/3. + +prolog:error_message(java_exception(Ex)) --> + ( { jpl_call(Ex, toString, [], Msg) + } + -> [ 'Java exception: ~w'-[Msg] ] + ; [ 'Java exception: ~w'-[Ex] ] + ). + + + /******************************* + * PATHS * + *******************************/ + +:- multifile user:file_search_path/2. +:- dynamic user:file_search_path/2. + +:- if(current_prolog_flag(version_data,yap(_,_,_,_))). + +user:file_search_path(jar, library('.')). +:-else. +user:file_search_path(jar, swi(lib)). +:-endif. + +%% add_search_path(+Var, +Value) is det. +% +% Add value to the end of search-path Var. Value is normally a +% directory. Does not change the environment if Dir is already in +% Var. +% +% @param Value Path to add in OS notation. + +add_search_path(Path, Dir) :- + ( getenv(Path, Old) + -> ( current_prolog_flag(windows, true) + -> Sep = (;) + ; Sep = (:) + ), + ( atomic_list_concat(Current, Sep, Old), + memberchk(Dir, Current) + -> true % already present + ; atomic_list_concat([Old, Sep, Dir], New), + setenv(Path, New) + ) + ; setenv(Path, Dir) + ). + +%% search_path_separator(-Sep:atom) +% +% Separator used the the OS in =PATH=, =LD_LIBRARY_PATH=, +% =CLASSPATH=, etc. + +search_path_separator((;)) :- + current_prolog_flag(windows, true), !. +search_path_separator(:). + + /******************************* + * LOAD THE JVM * + *******************************/ + +%% check_java_environment +% +% Verify the Java environment. Preferably we would create, but +% most Unix systems do not allow putenv("LD_LIBRARY_PATH=..." in +% the current process. A suggesting found on the net is to modify +% LD_LIBRARY_PATH right at startup and next execv() yourself, but +% this doesn't work if we want to load Java on demand or if Prolog +% itself is embedded in another application. +% +% So, after reading lots of pages on the web, I decided checking +% the environment and producing a sensible error message is the +% best we can do. +% +% Please not that Java2 doesn't require $CLASSPATH to be set, so +% we do not check for that. + +check_java_environment :- + check_lib(java), + check_lib(jvm). + +check_lib(Name) :- + check_shared_object(Name, File, EnvVar, Absolute), + ( Absolute == (-) + -> ( current_prolog_flag(windows, true) + -> A = '%', Z = '%' + ; A = '$', Z = '' + ), + format(string(Msg), 'Please add directory holding ~w to ~w~w~w', + [ File, A, EnvVar, Z ]), + throw(error(existence_error(library, Name), + context(_, Msg))) + ; true + ). + +%% check_shared_object(+Lib, -File, -EnvVar, -AbsFile) is semidet. +% +% True if AbsFile is existing .so/.dll file for Lib. +% +% @param File Full name of Lib (i.e. libjpl.so or jpl.dll) +% @param EnvVar Search-path for shared objects. + +check_shared_object(Name, File, EnvVar, Absolute) :- + libfile(Name, File), + library_search_path(Path, EnvVar), + ( member(Dir, Path), + atomic_list_concat([Dir, File], /, Absolute), + exists_file(Absolute) + -> true + ; Absolute = (-) + ). + +libfile(Base, File) :- + current_prolog_flag(unix, true), !, + atom_concat(lib, Base, F0), + current_prolog_flag(shared_object_extension, Ext), + file_name_extension(F0, Ext, File). +libfile(Base, File) :- + current_prolog_flag(windows, true), !, + current_prolog_flag(shared_object_extension, Ext), + file_name_extension(Base, Ext, File). + + +%% library_search_path(-Dirs:list, -EnvVar) is det. +% +% Dirs is the list of directories searched for shared +% objects/DLLs. EnvVar is the variable in which the search path os +% stored. + +library_search_path(Path, EnvVar) :- + current_prolog_flag(shared_object_search_path, EnvVar), + search_path_separator(Sep), + ( getenv(EnvVar, Env), + atomic_list_concat(Path, Sep, Env) + -> true + ; Path = [] + ). + + +%% add_jpl_to_classpath +% +% Add jpl.jar to =CLASSPATH= to facilitate callbacks + +add_jpl_to_classpath :- + absolute_file_name(jar('jpl.jar'), + [ access(read) + ], JplJAR), !, + ( getenv('CLASSPATH', Old) + -> true + ; Old = '.' + ), + ( current_prolog_flag(windows, true) + -> Separator = ';' + ; Separator = ':' + ), + atomic_list_concat([JplJAR, Old], Separator, New), + setenv('CLASSPATH', New). + + +%% libjpl(-Spec) is det. +% +% Return the spec for loading the JPL shared object. This shared +% object must be called libjpl.so as the Java System.loadLibrary() +% call used by jpl.jar adds the lib* prefix. + +libjpl(File) :- + ( current_prolog_flag(unix, true) + -> File = foreign(libjpl) + ; File = foreign(jpl) + ). + +%% add_jpl_to_ldpath(+JPL) is det. +% +% Add the directory holding jpl.so to search path for dynamic +% libraries. This is needed for callback from Java. Java appears +% to use its own search and the new value of the variable is +% picked up correctly. + +add_jpl_to_ldpath(JPL) :- + absolute_file_name(JPL, File, + [ file_type(executable), + file_errors(fail) + ]), !, + file_directory_name(File, Dir), + prolog_to_os_filename(Dir, OsDir), + current_prolog_flag(shared_object_search_path, PathVar), + add_search_path(PathVar, OsDir). +add_jpl_to_ldpath(_). + +%% add_java_to_ldpath is det. +% +% Adds the directories holding jvm.dll and java.dll to the %PATH%. +% This appears to work on Windows. Unfortunately most Unix systems +% appear to inspect the content of LD_LIBRARY_PATH only once. + +add_java_to_ldpath :- + current_prolog_flag(windows, true), !, + phrase(java_dirs, Extra), + ( Extra \== [] + -> print_message(informational, extend_ld_path(Extra)), + maplist(win_add_dll_directory, Extra) + ; true + ). +add_java_to_ldpath. + +%% java_dirs// is det. +% +% DCG that produces existing candidate directories holding +% Java related DLLs + +java_dirs --> + % JDK directories + java_dir(jvm, '/jre/bin/client'), + java_dir(jvm, '/jre/bin/server'), + java_dir(java, '/jre/bin'), + % JRE directories + java_dir(jvm, '/bin/client'), + java_dir(jvm, '/bin/server'), + java_dir(java, '/bin'). + +java_dir(DLL, _SubPath) --> + { check_shared_object(DLL, _, _Var, Abs), + Abs \== (-) + }, !. +java_dir(_DLL, SubPath) --> + { java_home(JavaHome), + atom_concat(JavaHome, SubPath, SubDir), + exists_directory(SubDir) + }, !, + [SubDir]. +java_dir(_, _) --> []. + + +%% java_home(-Home) is semidet +% +% Find the home location of Java. +% +% @param Home JAVA home in OS notation + +java_home_win_key( + jre, + 'HKEY_LOCAL_MACHINE/Software/JavaSoft/Java Runtime Environment'). +java_home_win_key( + jdk, + 'HKEY_LOCAL_MACHINE/Software/JavaSoft/Java Development Kit'). + +java_home(Home) :- + getenv('JAVA_HOME', Home), + exists_directory(Home), !. +:- if(current_prolog_flag(windows, true)). +java_home(Home) :- + java_home_win_key(_, Key0), % TBD: user can't choose jre or jdk + catch(win_registry_get_value(Key0, 'CurrentVersion', Version), _, fail), + atomic_list_concat([Key0, Version], /, Key), + win_registry_get_value(Key, 'JavaHome', WinHome), + prolog_to_os_filename(Home, WinHome), + exists_directory(Home), !. +:- else. +java_home(Home) :- + member(Home, [ '/usr/lib/java', + '/usr/local/lib/java' + ]), + exists_directory(Home), !. +:- endif. + +:- dynamic + jvm_ready/0. +:- volatile + jvm_ready/0. + +setup_jvm :- + jvm_ready, !. +setup_jvm :- + add_jpl_to_classpath, + add_java_to_ldpath, + libjpl(JPL), + add_jpl_to_ldpath(JPL), + catch(load_foreign_library(JPL), E, report_java_setup_problem(E)), + assert(jvm_ready). + +report_java_setup_problem(E) :- + print_message(error, E), + check_java_environment. + + /******************************* + * MESSAGES * + *******************************/ + +:- multifile + prolog:message//1. + +prolog:message(extend_ld_path(Dirs)) --> + [ 'Extended DLL search path with'-[] ], + dir_per_line(Dirs). + +dir_per_line([]) --> []. +dir_per_line([H|T]) --> + [ nl, ' ~q'-[H] ], + dir_per_line(T). + +% Initialize JVM + +:- initialization(setup_jvm, now). % must be ready before export diff --git a/packages/jpl/jpl/make.bat b/packages/jpl/jpl/make.bat new file mode 100755 index 000000000..fb132b683 --- /dev/null +++ b/packages/jpl/jpl/make.bat @@ -0,0 +1 @@ +nmake MT=true /f makefile.mak %* diff --git a/packages/jpl/jpl/src/c/README b/packages/jpl/jpl/src/c/README new file mode 100644 index 000000000..b8334f8f7 --- /dev/null +++ b/packages/jpl/jpl/src/c/README @@ -0,0 +1,16 @@ +To recompile jpl.c to jpl.dll (for Windows), +ensure that JAVA_HOME and PL_HOME are appropriately set in your environment, +then run + + .\build.bat + +To recompile jpl.c to libjpl.so (for Linux), +ensure that JAVA_HOME and PL_HOME are appropriately set in your environment, +then run + + ./build.sh + +---- +Paul Singleton (paul.singleton@bcs.org.uk) +March 2004 + diff --git a/packages/jpl/jpl/src/c/build.bat b/packages/jpl/jpl/src/c/build.bat new file mode 100644 index 000000000..fc0a3c88d --- /dev/null +++ b/packages/jpl/jpl/src/c/build.bat @@ -0,0 +1,15 @@ +@echo off + +rem JAVA_HOME must (already) be set to the root dir of a recent Sun Java SDK +rem PL_HOME must (already) be set to the root dir of a recent SWI-Prolog installation + +set DEFINES=/D_REENTRANT /DWIN32 /D_WINDOWS /D__SWI_PROLOG__ /D__SWI_EMBEDDED__ +set JVM_INC=/I "%JAVA_HOME%\include" /I "%JAVA_HOME%\include/win32" +set PL_INC=/I "%PL_HOME%\include" +set JVM_LIB="%JAVA_HOME%\lib\jvm.lib" +set PL_LIB="%PL_HOME%\lib\libpl.lib" +set PTHREAD_LIB="%PL_HOME%\lib/pthreadVC.lib" + +CL.EXE /W3 /nologo /MD /LD %DEFINES% %JVM_INC% %PL_INC% %JVM_LIB% %PL_LIB% %PTHREAD_LIB% jpl.c +pause + diff --git a/packages/jpl/jpl/src/c/hacks.c b/packages/jpl/jpl/src/c/hacks.c new file mode 100644 index 000000000..99d5b0fc6 --- /dev/null +++ b/packages/jpl/jpl/src/c/hacks.c @@ -0,0 +1,73 @@ +/* + %T jni_SetByteArrayElement(+term, +term, +term) + */ +static foreign_t +jni_SetByteArrayElement( + term_t ta1, // +Arg1 + term_t ta2, // +Arg2 + term_t ta3 // +Arg3 + ) + { + jboolean r; // Prolog exit/fail outcome + jbyteArray p1; + int i2; + jbyte p4; + JNIEnv *env; + atom_t a; /* " */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + int i; /* " */ + + if ( !jni_ensure_jvm() ) + { + + + + + return FALSE; + } + r = + JNI_term_to_byte_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jbyte(ta3,p4) + && ( (*env)->SetByteArrayRegion(env,p1,(jsize)i2,1,&p4) , TRUE ); + + return jni_check_exception(env) && r; + + } + +/* + %T jni_SetByteArrayElement(+term, +term, +term) + */ +static foreign_t +jni_SetDoubleArrayElement( + term_t ta1, // +Arg1 + term_t ta2, // +Arg2 + term_t ta3 // +Arg3 + ) + { + jboolean r; // Prolog exit/fail outcome + void *p1; + jint i2; + jdouble p4; + JNIEnv *env; + atom_t a; /* " */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + int i; /* " */ + int64_t i64; + + if ( !jni_ensure_jvm() ) + { + return FALSE; + } + r = + JNI_term_to_double_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jdouble(ta3,p4) + && ( (*env)->SetDoubleArrayRegion(env,(jdoubleArray)p1,(jsize)i2,1,&p4) , TRUE ); + + return jni_check_exception(env) && r; + + } + diff --git a/packages/jpl/jpl/src/c/jpl.c b/packages/jpl/jpl/src/c/jpl.c new file mode 100755 index 000000000..8bd4858de --- /dev/null +++ b/packages/jpl/jpl/src/c/jpl.c @@ -0,0 +1,5806 @@ +/* Part of JPL -- SWI-Prolog/Java interface + + Author: Paul Singleton, Fred Dushin and Jan Wielemaker + E-mail: paul@jbgb.com + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2004, Paul Singleton + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +*/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +this source file (jpl.c) combines my Prolog-calls-Java stuff (mostly +prefixed 'JNI' or 'jni' here) with my adaptation of Fred Dushin's +Java-calls-Prolog stuff (mostly prefixed 'JPL' or 'jpl' here) + +recent fixes: + * using PL_get_pointer(), PL_put_pointer() consistently (?) + * replaced all "Class: jpl_fli_PL" by "Class: jpl_fli_Prolog" + +still to do: + * make it completely thread-safe + (both to multiple Prolog (engine-enabled) threads and to multiple Java threads) + * suss JVM 'abort' and 'exit' handling, and 'vfprintf' redirection + * rationalise initialisation; perhaps support startup from C? + +refactoring (trivial): + * initialise a functor_t for jpl_tidy_iref_type_cache/1 + * initialise a functor_t for -/2 + * initialise a module_t for jpl +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* update this to distinguish releases of this C library: */ +#define JPL_C_LIB_VERSION "3.1.4-alpha" +#define JPL_C_LIB_VERSION_MAJOR 3 +#define JPL_C_LIB_VERSION_MINOR 1 +#define JPL_C_LIB_VERSION_PATCH 4 +#define JPL_C_LIB_VERSION_STATUS "alpha" + +#ifdef DEBUG +#undef DEBUG +#endif +/*#define DEBUG(n, g) ((void)0) */ +#define DEBUG_LEVEL 3 +#define DEBUG(n, g) ( n >= DEBUG_LEVEL ? g : (void)0 ) + +/* disable type-of-ref caching (at least until GC issues are resolved) */ +#define JPL_CACHE_TYPE_OF_REF FALSE + +/*=== includes ===================================================================================== */ + +#if defined(__WINDOWS__) || defined(_WIN32) +/* OS-specific header (SWI-Prolog FLI and Java Invocation API both seem to need this): */ +/* but not if we use the .NET 2.0 C compiler */ +#include +#define SIZEOF_WCHAR_T 2 +#define SIZEOF_LONG 4 +#define SIZEOF_LONG_LONG 8 +#if defined(WIN64) || defined(_WIN64) +#define SIZEOF_VOIDP 8 +#else +#define SIZEOF_VOIDP 4 +#endif +#endif + +/* SWI-Prolog headers: */ +#include +#if _YAP_NOT_INSTALLED_ +#define Sdprintf(...) fprintf( stderr, __VA_ARGS__) +#else +#include +#endif + +/* Java Native Interface and Invocation Interface header: */ +#include + +/* ANSI/ISO C library header (?): */ +#include +#include +#include +#include + +#ifdef HAVE_PTHREAD_H +/* POSIX 'pthreads' headers (initially for JPL's Prolog engine pool, useful for locking generally?): */ +#include +#include +#else +#define pthread_mutex_lock( A) +#define pthread_mutex_unlock( A) +#define pthread_cond_signal( A) +#define pthread_cond_wait( A, B) 0 +#endif + +#include + +#ifndef TRUE +#define TRUE 1 +#endif +#ifndef FALSE +#define FALSE 1 +#endif + +#include "jpl.h" + +/*=== JNI constants ================================================================================ */ + +#define JNI_MIN_JCHAR 0 +#define JNI_MAX_JCHAR 65535 + +#define JNI_MIN_JBYTE -128 +#define JNI_MAX_JBYTE 127 + +#define JNI_MIN_JSHORT -32768 +#define JNI_MAX_JSHORT 32767 + + +#define JNI_XPUT_VOID 0 +#define JNI_XPUT_BOOLEAN 1 +#define JNI_XPUT_BYTE 2 +#define JNI_XPUT_CHAR 3 +#define JNI_XPUT_SHORT 4 +#define JNI_XPUT_INT 5 +#define JNI_XPUT_LONG 6 +#define JNI_XPUT_FLOAT 7 +#define JNI_XPUT_DOUBLE 8 +#define JNI_XPUT_FLOAT_TO_DOUBLE 9 +#define JNI_XPUT_LONG_TO_FLOAT 10 +#define JNI_XPUT_LONG_TO_DOUBLE 11 +#define JNI_XPUT_REF 12 +#define JNI_XPUT_ATOM 13 +#define JNI_XPUT_JVALUEP 14 +#define JNI_XPUT_JVALUE 15 + + +/* JNI "hashed refs" constants */ + +#define JNI_HR_LOAD_FACTOR 0.75 + +/* jni_hr_add() return codes: */ +#define JNI_HR_ADD_FAIL -1 +#define JNI_HR_ADD_NEW 0 +#define JNI_HR_ADD_OLD 1 + + +/*=== JPL constants ================================================================================ */ + +/* legit values for jpl_status_jpl_ini and jpl_status_pvm_ini */ +#define JPL_INIT_RAW 101 +#define JPL_INIT_PVM_MAYBE 102 +#define JPL_INIT_OK 103 +#define JPL_INIT_JPL_FAILED 104 +#define JPL_INIT_PVM_FAILED 105 + +#define JPL_MAX_POOL_ENGINES 10 /* max pooled Prolog engines */ +#define JPL_INITIAL_POOL_ENGINES 1 /* initially created ones */ + + +/*=== JNI Prolog<->Java conversion macros ========================================================== */ + +/* JNI (Prolog-calls-Java) conversion macros; mainly used in jni_{func|void}_{0|1|2|3|4}_plc; */ +/* for re-entrancy, ensure that any variables which they use are declared dynamically */ +/* (e.g. or i.e. are local to the host function); */ +/* beware of evaluating *expressions* passed as actual parameters more than once; */ + +#define JNI_term_to_jboolean(T,JB) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_at_1 \ + ? ( ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_atom(a1,&a) \ + ? ( a==JNI_atom_false \ + ? ( (JB)=0, TRUE) \ + : ( a==JNI_atom_true \ + ? ( (JB)=1, TRUE) \ + : FALSE \ + ) \ + ) \ + : FALSE \ + ) \ + : FALSE \ + ) + +#define JNI_term_to_jchar(T,J) \ + ( PL_get_integer((T),&i) \ + && i >= JNI_MIN_JCHAR \ + && i <= JNI_MAX_JCHAR \ + && ( (J)=(jchar)i, TRUE) \ + ) + +#define JNI_term_to_jbyte(T,J) \ + ( PL_get_integer((T),&i) \ + && i >= JNI_MIN_JBYTE \ + && i <= JNI_MAX_JBYTE \ + && ( (J)=(jbyte)i, TRUE) \ + ) + +#define JNI_term_to_jshort(T,J) \ + ( PL_get_integer((T),&i) \ + && i >= JNI_MIN_JSHORT \ + && i <= JNI_MAX_JSHORT \ + && ( (J)=(jshort)i, TRUE) \ + ) + +/* JW: jint is always 32-bit! */ + +#define JNI_term_to_jint(T,J) \ + ( PL_get_integer((T),&i) \ + && ((J)=i, TRUE) \ + ) + +#define JNI_term_to_non_neg_jint(T,J) \ + ( PL_get_intptr((T),&i) \ + && i >= 0 \ + && ( (J)=(jint)i, TRUE) \ + ) + +#define JNI_term_to_jlong(T,J) \ + ( PL_get_int64((T),&i64) \ + && ( (J)=(jlong)i64, TRUE) \ + ) + +#define JNI_term_to_jfloat(T,J) \ + ( PL_get_float((T),&d) \ + ? ( (J)=(jfloat)d, TRUE) \ + : ( PL_get_int64((T),&i64) \ + && ( (J)=(jfloat)i64, TRUE) \ + ) \ + ) + +#define JNI_term_to_jdouble(T,J) \ + ( PL_get_float((T),&(J)) \ + ? TRUE \ + : ( PL_get_int64((T),&i64) \ + && ( (J)=(jdouble)i64, TRUE) \ + ) \ + ) + +#define JNI_term_to_jfieldID(T,J) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_jfieldID_1 \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_pointer(a1,(void**)&(J)) \ + ) + +#define JNI_term_to_jmethodID(T,J) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_jmethodID_1 \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_pointer(a1,(void**)&(J)) \ + ) + +/* converts: */ +/* atom -> String */ +/* @(Tag) -> obj */ +/* @(null) -> NULL */ +/* (else fails) */ +/* */ +#define JNI_term_to_ref(T,J) \ + ( PL_get_atom((T),&a) \ + ? jni_atom_to_String(env,a,(jobject*)&(J)) \ + : PL_get_functor((T),&fn) \ + && fn==JNI_functor_at_1 \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_atom(a1,&a) \ + && ( a==JNI_atom_null \ + ? ( (J)=0, TRUE) \ + : jni_tag_to_iref(a,(pointer*)&(J)) \ + ) \ + ) + +/* converts: */ +/* atom -> String */ +/* @(Tag) -> obj */ +/* (else fails) */ +/* stricter than JNI_term_to_ref(T,J) */ +/* */ +#define JNI_term_to_jobject(T,J) \ + ( JNI_term_to_ref(T,J) \ + && (J) != 0 \ + ) + +/* for now, these specific test-and-convert macros */ +/* are merely mapped to their nearest ancestor... */ + +#define JNI_term_to_jclass(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_throwable_jclass(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_non_array_jclass(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_throwable_jobject(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_jstring(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_object_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_boolean_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_byte_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_char_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_short_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_int_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_long_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_float_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_double_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_jbuf(T,J,TP) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_jbuf_2 \ + && ( a2=PL_new_term_ref(), \ + PL_get_arg(2,(T),a2) \ + ) \ + && PL_get_atom(a2,&a) \ + && a==(TP) \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_pointer(a1,(void**)&(J)) \ + ) + +#define JNI_term_to_charP(T,J) \ + PL_get_atom_chars((T),&(J)) + +#define JNI_term_to_pointer(T,J) \ + PL_get_pointer((T),(void**)&(J)) + + +/* JNI Java-to-Prolog conversion macros: */ + +#define JNI_unify_void(T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_void \ + ) + +#define JNI_unify_false(T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_false \ + ) + +#define JNI_unify_true(T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_true \ + ) + +#define JNI_jboolean_to_term(J,T) \ + ( (J)==0 \ + ? JNI_unify_false((T)) \ + : JNI_unify_true((T)) \ + ) + +#define JNI_jchar_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jbyte_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jshort_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jint_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jlong_to_term(J,T) \ + PL_unify_int64((T),(int64_t)(J)) + +#define JNI_jfloat_to_term(J,T) \ + PL_unify_float((T),(double)(J)) + +#define JNI_jdouble_to_term(J,T) \ + PL_unify_float((T),(double)(J)) + +/* J can be an *expression* parameter to this macro; */ +/* we must evaluate it exactly once; hence we save its value */ +/* in the variable j, which must be dynamic (e.g. local) */ +/* if this macro is to be re-entrant */ +#define JNI_jobject_to_term(J,T) \ + ( ( j=(J), j==NULL ) \ + ? PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_null \ + ) \ + : ( (*env)->IsInstanceOf(env,j,str_class) \ + ? jni_String_to_atom(env,j,&a) \ + && PL_unify_term((T), \ + PL_ATOM, a \ + ) \ + : jni_object_to_iref(env,j,&i) \ + && jni_iref_to_tag(i,&a) \ + && PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, a \ + ) \ + ) \ + ) + +#define JNI_jfieldID_to_term(J,T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_jfieldID_1, \ + PL_POINTER, (void*)(J) \ + ) + +#define JNI_jmethodID_to_term(J,T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_jmethodID_1, \ + PL_POINTER, (void*)(J) \ + ) + +#define JNI_jbuf_to_term(J,T,TP) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_jbuf_2, \ + PL_POINTER, (void*)(J), \ + PL_ATOM, (TP) \ + ) + +#define JNI_pointer_to_term(J,T) \ + PL_unify_pointer((T),(void*)(J)) + +#define JNI_charP_to_term(J,T) \ + PL_unify_atom_chars((T),(J)) + + +/*=== JNI initialisation macro (typically succeeds cheaply) ======================================== */ + +#define jni_ensure_jvm() ( ( jvm != NULL \ + || jni_create_default_jvm() \ + ) \ + && (env=jni_env()) != NULL \ + ) + + +/*=== JPL initialisation macros (typically succeed cheaply) ======================================== */ + +/* outcomes: */ +/* fail to find jpl.*, jpl.fli.* classes or to convert init args to String[]: exception, FALSE */ +/* JPL is (newly or already) out of RAW state: TRUE */ +#define jpl_ensure_jpl_init(e) ( jpl_status != JPL_INIT_RAW \ + || jpl_ensure_jpl_init_1(e) \ + ) +/* outcomes: */ +/* JPL or PVM init has already failed: FALSE */ +/* JPL or PVM init fails while being necessarily attempted: exception */ +/* JPL is (newly or already) fully initialised: TRUE */ +#define jpl_ensure_pvm_init(e) ( jpl_status == JPL_INIT_OK \ + || jpl_ensure_pvm_init_1(e) \ + ) + + +/*=== types (structs and typedefs) ================================================================= */ + +typedef struct Hr_Entry HrEntry; /* enables circular definition... */ + +struct Hr_Entry { /* a single interned reference */ + jobject obj; /* a JNI global ref */ + int hash; /* identityHashCode(obj) */ + HrEntry *next; /* next entry in this chain, or NULL */ + }; + +typedef struct Hr_Table HrTable; + +struct Hr_Table { + int count; /* current # entries */ + int threshold; /* rehash on add when count==threshold */ + int length; /* # slots in slot array */ + HrEntry **slots; /* pointer to slot array */ + }; + +typedef intptr_t pointer; /* for JPL */ + +/*=== JNI constants: sizes of JNI primitive types ================================================== */ + +int size[16] = { /* NB relies on sequence of JNI_XPUT_* defs */ + 0, + sizeof(jboolean), /* size[JNI_XPUT_BOOLEAN] */ + sizeof(jbyte), /* size[JNI_XPUT_BYTE] */ + sizeof(jchar), /* size[JNI_XPUT_CHAR] */ + sizeof(jshort), /* size[JNI_XPUT_SHORT] */ + sizeof(jint), /* size[JNI_XPUT_INT] */ + sizeof(jlong), /* size[JNI_XPUT_LONG] */ + sizeof(jfloat), /* size[JNI_XPUT_FLOAT] */ + sizeof(jdouble), /* size[JNI_XPUT_DOUBLE] */ + 0, /* n/a - JNI_FLOAT_TO_DOUBLE */ + 0, /* n/a - JNI_LONG_TO_FLOAT */ + 0, /* n/a - JNI_LONG_TO_DOUBLE */ + 0, /* n/a - JNI_REF */ + 0, /* n/a - JNI_ATOM */ + 0, /* n/a - JNI_JVALUEP */ + sizeof(jvalue) /* size[JNI_XPUT_JVALUE] */ + }; + + +/*=== JNI "constants", lazily initialised by jni_init() ============================================ */ + +static atom_t JNI_atom_false; /* false */ +static atom_t JNI_atom_true; /* true */ + +static atom_t JNI_atom_boolean; /* boolean */ +static atom_t JNI_atom_char; /* char */ +static atom_t JNI_atom_byte; /* byte */ +static atom_t JNI_atom_short; /* short */ +static atom_t JNI_atom_int; /* int */ +static atom_t JNI_atom_long; /* long */ +static atom_t JNI_atom_float; /* float */ +static atom_t JNI_atom_double; /* double */ + +static atom_t JNI_atom_null; /* null */ +static atom_t JNI_atom_void; /* void */ + +static functor_t JNI_functor_at_1; /* @(_) */ +static functor_t JNI_functor_jbuf_2; /* jbuf(_,_) */ +static functor_t JNI_functor_jlong_2; /* jlong(_,_) */ +static functor_t JNI_functor_jfieldID_1; /* jfieldID(_) */ +static functor_t JNI_functor_jmethodID_1; /* jmethodID(_) */ +static functor_t JNI_functor_error_2; /* error(_, _) */ +static functor_t JNI_functor_java_exception_1; /* java_exception(_) */ +static functor_t JNI_functor_jpl_error_1; /* jpl_error(_) */ + + +/*=== JNI's static JVM references, lazily initialised by jni_init() ================================ */ + +static jclass c_class; /* java.lang.Class (rename to jClass_c ?) */ +static jmethodID c_getName; /* java.lang.Class' getName() (rename to jClassGetName_m ?) */ +static jclass str_class; /* java.lang.String (this duplicates jString_c below) */ +static jclass term_class; /* jpl.Term */ +static jclass termt_class; /* jpl.fli.term_t */ + +static jclass sys_class; /* java.lang.System (rename to jSystem_c ?) */ +static jmethodID sys_ihc; /* java.lang.System's identityHashCode() (rename to jSystemIdentityHashCode_m ?) */ +static jmethodID term_getTerm; /* jpl.Term's getTerm() */ +static jmethodID term_put; /* jpl.Term's put() */ +static jmethodID term_putTerm; /* jpl.Term's static putTerm(Term,term_t) */ + + +/*=== JPL's reusable global class object refs, initialised by jpl_ensure_jpl_init() ================ */ + +static jclass jString_c; +static jclass jJPLException_c; +static jclass jTermT_c; +static jclass jAtomT_c; +static jclass jFunctorT_c; +static jclass jFidT_c; +static jclass jPredicateT_c; +static jclass jQidT_c; +static jclass jModuleT_c; +static jclass jEngineT_c; + +static jclass jLongHolder_c; +static jclass jPointerHolder_c; +static jclass jIntHolder_c; +static jclass jInt64Holder_c; +static jclass jDoubleHolder_c; +static jclass jStringHolder_c; +static jclass jObjectHolder_c; +static jclass jBooleanHolder_c; + + +/*=== JPL's reusable constant field IDs, set before first use by jpl_ensure_jpl_init() ============= */ + +static jfieldID jLongHolderValue_f; +static jfieldID jPointerHolderValue_f; +static jfieldID jIntHolderValue_f; +static jfieldID jInt64HolderValue_f; +static jfieldID jDoubleHolderValue_f; +static jfieldID jStringHolderValue_f; +static jfieldID jObjectHolderValue_f; +static jfieldID jBooleanHolderValue_f; + + +/*=== JPL's default args for PL_initialise() (NB these are not really good enough) ================= */ + +const char *default_args[] = { "swipl", + "-g", "true", + "-nosignals", + NULL + }; /* *must* have final NULL */ + + +/*=== JNI global state (initialised by jni_create_jvm_c) =========================================== */ + +static JavaVM *jvm = NULL; /* non-null -> JVM successfully loaded & initialised */ +static char *jvm_ia[2] = {"-Xrs", NULL}; +static char **jvm_dia = jvm_ia; /* default JVM init args (after jpl init, until jvm init) */ +static char **jvm_aia = NULL; /* actual JVM init args (after jvm init) */ + + +/*=== JNI global state (hashed global refs) ======================================================== */ + +static HrTable *hr_table = NULL; /* static handle to allocated-on-demand table */ +static int hr_add_count = 0; /* cumulative total of new refs interned */ +static int hr_old_count = 0; /* cumulative total of old refs reused */ +static int hr_del_count = 0; /* cumulative total of dead refs released */ + + +/*=== JPL global state, initialised by jpl_ensure_jpl_init() or jpl_ensure_jvm_init() ============== */ + +static int jpl_status = JPL_INIT_RAW; /* neither JPL nor PVM initialisation has occurred */ +static jobject pvm_dia = NULL; /* default PVM init args (after jpl init, until pvm init) */ +static jobject pvm_aia = NULL; /* actual PVM init args (after pvm init) */ +static PL_engine_t *engines = NULL; /* handles of the pooled Prolog engines */ +static int engines_allocated = 0; /* size of engines array */ +#ifdef HAVE_PTHREAD_H +static pthread_mutex_t engines_mutex = PTHREAD_MUTEX_INITIALIZER; /* for controlling pool access */ +static pthread_cond_t engines_cond = PTHREAD_COND_INITIALIZER; /* for controlling pool access */ + +static pthread_mutex_t jvm_init_mutex = PTHREAD_MUTEX_INITIALIZER; /* for controlling lazy initialisation */ +static pthread_mutex_t pvm_init_mutex = PTHREAD_MUTEX_INITIALIZER; /* for controlling lazy initialisation */ +#endif + + +/*=== common functions ============================================================================= */ + +static JNIEnv* +jni_env(void) /* economically gets a JNIEnv pointer, valid for this thread */ +{ JNIEnv *env; + + switch( (*jvm)->GetEnv(jvm, (void**)&env, JNI_VERSION_1_2) ) + { case JNI_OK: + return env; + case JNI_EDETACHED: + DEBUG(2, Sdprintf( "[JPL: jni_env() calls AttachCurrentThread]\n")); + return (*jvm)->AttachCurrentThread(jvm, (void**)&env, NULL) == 0 ? env : NULL; + default: /* error */ + return NULL; + } +} + + +static char * +jpl_c_lib_version(void) + { + static char v[100]; /* version string */ + static char *vp = NULL; /* set to v at first call */ + + if ( vp != NULL ) /* already set? */ + { + return vp; + } + sprintf( v, "%d.%d.%d-%s", JPL_C_LIB_VERSION_MAJOR, JPL_C_LIB_VERSION_MINOR, JPL_C_LIB_VERSION_PATCH, JPL_C_LIB_VERSION_STATUS); + vp = v; + return vp; + } + + +static foreign_t +jpl_c_lib_version_1_plc( + term_t ta /* -atom: this library's version as an atom, e.g. '3.1.0-alpha' */ + ) + { + + return PL_unify_atom_chars(ta,jpl_c_lib_version()); + } + + +static foreign_t +jpl_c_lib_version_4_plc( + term_t tmajor, /* -integer: major version number */ + term_t tminor, /* -integer: minor version number */ + term_t tpatch, /* -integer: patch version number */ + term_t tstatus /* -atom: status of this version */ + ) + { + + return PL_unify_integer(tmajor,JPL_C_LIB_VERSION_MAJOR) + && PL_unify_integer(tminor,JPL_C_LIB_VERSION_MINOR) + && PL_unify_integer(tpatch,JPL_C_LIB_VERSION_PATCH) + && PL_unify_atom_chars(tstatus,JPL_C_LIB_VERSION_STATUS); + } + + +/*=== JNI function prototypes (to resolve unavoidable forward references) ========================== */ + +static int jni_hr_add(JNIEnv*, jobject, pointer*); +static bool jni_hr_del(JNIEnv*, pointer); + + +/*=== JNI functions (NB first 6 are cited in macros used subsequently) ============================= */ + +static bool +jni_tag_to_iref2(const char *s, pointer *iref) +{ if ( s[0] == 'J' + && s[1] == '#' + && isdigit(s[2]) + && isdigit(s[3]) + && isdigit(s[4]) + && isdigit(s[5]) + && isdigit(s[6]) + && isdigit(s[7]) + && isdigit(s[8]) + && isdigit(s[9]) + && isdigit(s[10]) + && isdigit(s[11]) + && isdigit(s[12]) + && isdigit(s[13]) + && isdigit(s[14]) + && isdigit(s[15]) + && isdigit(s[16]) + && isdigit(s[17]) + && isdigit(s[18]) + && isdigit(s[19]) + && isdigit(s[20]) + && isdigit(s[21])) /* s is like 'J#01234567890123456789' */ + { pointer r; + char *endptr; + + r = strtoul(&s[2], &endptr, 10); + if ( endptr == s+22 ) + { *iref = r; + return 1; + } + } + + return 0; +} + + +static bool +jni_tag_to_iref1( + const char *s, + pointer *iref + ) + { + + if (strlen(s) == 22) + { + return jni_tag_to_iref2(s,iref); + } + else + { + return 0; + } + } + + +/* this now checks that the atom's name resembles a tag (PS 18/Jun/2004) */ +static bool +jni_tag_to_iref( + atom_t a, + pointer *iref + ) + { + + return jni_tag_to_iref1(PL_atom_chars(a), iref); + } + + +#if SIZEOF_LONG == SIZEOF_VOIDP +#define IREF_FMT "J#%020lu" +#define IREF_INTTYPE unsigned long +#elif SIZEOF_LONG_LONG == SIZEOF_VOIDP +#define IREF_FMT "J#%020llu" +#define IREF_INTTYPE unsigned long long +#else +#error "Cannot determine format for irefs" +#endif + +static bool +jni_iref_to_tag( + pointer iref, + atom_t *a + ) + { + char abuf[23]; + + sprintf( abuf, IREF_FMT, (IREF_INTTYPE)iref); /* oughta encapsulate this mapping... */ + *a = PL_new_atom(abuf); + PL_unregister_atom(*a); /* empirically decrement reference count... */ + return TRUE; /* can't fail (?!) */ + } + + +static bool +jni_object_to_iref( + JNIEnv *env, + jobject obj, /* a newly returned JNI local ref */ + pointer *iref /* gets an integerised, canonical, global equivalent */ + ) + { + int r; /* temp for result code */ + + if ( (r=jni_hr_add(env, obj, iref)) == JNI_HR_ADD_NEW ) + { + hr_add_count++; /* obj was novel, has been added to dict */ + return TRUE; + } + else + if ( r == JNI_HR_ADD_OLD ) + { + hr_old_count++; /* obj was already in dict */ + return TRUE; + } + else + { + return FALSE; /* r == JNI_HR_ADD_FAIL, presumably */ + } + } + + +/* retract all jpl_iref_type_cache(Iref,_) facts */ +static bool +jni_tidy_iref_type_cache(pointer iref) +{ term_t goal; + + if ( JPL_CACHE_TYPE_OF_REF ) + { return ( (goal = PL_new_term_ref()) && + PL_unify_term(goal, + PL_FUNCTOR_CHARS, "jpl_tidy_iref_type_cache", 1, + PL_INT, iref) && + PL_call(goal, + PL_new_module(PL_new_atom("jpl"))) + ); + } else + { return TRUE; + } +} + + +/* could merge this into jni_hr_del() ? */ +static bool +jni_free_iref( /* called indirectly from agc hook when a possible iref is unreachable */ + JNIEnv *env, + pointer iref + ) + { + + if ( jni_hr_del(env,iref) ) /* iref matched a hashedref table entry? (in which case, was deleted) */ + { + if ( !jni_tidy_iref_type_cache(iref) ) + { + DEBUG(0, Sdprintf( "[JPL: jni_tidy_iref_type_cache(%p) failed]\n", (void *)iref)); + } + hr_del_count++; + return TRUE; + } + else + { + return FALSE; + } + } + + +/* NB this delivers an atom_t, not a term_t */ +/* returns FALSE if the String arg is NULL */ +static bool + jni_String_to_atom( /* called from JNI_jobject_to_term(J,T) and jpl.fli.Prolog#new_atom() */ + JNIEnv *env, + jobject s, + atom_t *a + ) + { + jsize len = (*env)->GetStringLength(env,s); + const jchar *jcp = (*env)->GetStringChars(env,s,NULL); + + if ( s == NULL ) + { + return FALSE; + } +#if SIZEOF_WCHAR_T == 2 + { + *a = PL_new_atom_wchars(len,jcp); /* easy, huh? (thanks, Jan) */ + } +#else + { + pl_wchar_t *wp; + jsize i; + + if ( (wp=(pl_wchar_t*)malloc(sizeof(pl_wchar_t)*len)) == NULL) { + (*env)->ReleaseStringChars(env,s,jcp); + return FALSE; + } + for ( i=0 ; iReleaseStringChars(env,s,jcp); + return TRUE; + } + + +/* NB this takes an atom_t, not a term_t */ +static bool + jni_atom_to_String( + JNIEnv *env, + atom_t a, + jobject *s + ) + { + size_t len; + pl_wchar_t *wp; + jchar *jcp; + unsigned char *cp; + unsigned int i; + + if ( (cp=(unsigned char*)PL_atom_nchars(a,&len)) != NULL ) /* got 8-bit chars from trad atom */ + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,(jsize)len); + free(jcp); + return TRUE; + } + else if ( (wp=(pl_wchar_t*)PL_atom_wchars(a,&len)) != NULL ) /* got (wide) chars from wide atom */ + { +#if SIZEOF_WCHAR_T == 2 + { + *s = (*env)->NewString(env,wp,(jsize)len); + } +#else + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,len); + free(jcp); + } +#endif + return TRUE; + } + else + { + return FALSE; + } + } + + +/* checks that the term_t is a string and delivers a String representation of it */ +static bool + jni_string_to_String( + JNIEnv *env, + term_t t, /* a term which may or may not be a SWIPL string */ + jobject *s + ) + { + size_t len; + pl_wchar_t *wp; + jchar *jcp; + char *cp; + unsigned int i; + + if ( PL_get_nchars(t,&len,&cp,CVT_ATOM) ) /* got 8-bit chars from string? */ + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,(jsize)len); + free(jcp); + return TRUE; + } + else if ( PL_get_wchars(t,&len,&wp,CVT_STRING) ) /* got (wide) chars from string? */ + { +#if SIZEOF_WCHAR_T == 2 + { + *s = (*env)->NewString(env,wp,(jsize)len); + } +#else + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,len); + free(jcp); + } +#endif + return TRUE; + } + else + { + return FALSE; + } + } + + +/* an FLI wrapper for jni_tag_to_iref() above */ +/* is currently called by jpl_tag_to_type/2, jpl_cache_type_of_object/2 */ +/* jpl_tag_to_type/2 is called by jpl_object_to_type/2, jpl_ref_to_type/2 */ +static foreign_t +jni_tag_to_iref_plc( + term_t tt, /* +atom: a tag */ + term_t ti /* -integer: its corresponding iref */ + ) + { + atom_t a; + pointer iref; + + return PL_get_atom(tt,&a) + && jni_tag_to_iref(a,&iref) + && PL_unify_integer(ti,iref); + } + + +/* this will be hooked to SWI-Prolog's PL_agc_hook, */ +/* and is called just before each redundant atom is expunged from the dict */ +/* NB need to be able to switch this on and off from Prolog... */ +static bool +jni_atom_freed( + atom_t a + ) + { + const char *cp = PL_atom_chars(a); + pointer iref; + char cs[23]; /* was 11 until 24/Apr/2007 */ + JNIEnv *env; + + if ((env = jni_env()) == NULL) + return TRUE; /* oughta log an error, at least the first time... */ + if ( jni_tag_to_iref( a, &iref) ) /* check format and convert digits to int if ok */ + { + sprintf( cs, IREF_FMT, (IREF_INTTYPE)iref); /* reconstruct digits part of tag in cs */ + if ( strcmp(cp,cs) != 0 ) /* original digits != reconstructed digits? */ + { + DEBUG(0, Sdprintf( "[JPL: garbage-collected tag '%s'=%p is bogus (not canonical)]\n", cp, (void *)iref)); + } + else + if ( !jni_free_iref(env,iref) ) /* free it (iff it's in the hashedref table) */ + { + DEBUG(0, Sdprintf( "[JPL: garbage-collected tag '%s' is bogus (not in HashedRefs)]\n", cp)); + } + } + else + { + } + return TRUE; /* means "go ahead and expunge the atom" (we do this regardless) */ + } + + +/*=== "hashed ref" (canonical JNI global reference) support ======================================== */ + +static foreign_t +jni_hr_info_plc( /* implements jni_hr_info/4 */ + term_t t1, /* -integer: # object references currently in hash table */ + term_t t2, /* -integer: total # object references so far added */ + term_t t3, /* -integer: total # object references so far found to be already in table */ + term_t t4 /* -integer: total # object references deleted from table (by atom GC) */ + ) + { + return PL_unify_integer(t1,(hr_table==NULL?0:hr_table->count)) /* 0 was -1 (??) */ + && PL_unify_integer(t2,hr_add_count) + && PL_unify_integer(t3,hr_old_count) + && PL_unify_integer(t4,hr_del_count); + } + + +/* unifies t2 with a Prolog term which represents the contents of the hashtable slot */ +static bool +jni_hr_table_slot( + term_t t2, + HrEntry *slot + ) + { + term_t tp = PL_new_term_ref(); + + if ( slot == NULL ) + { + return PL_unify_nil(t2); + } + else + { + return PL_unify_list(t2,tp,t2) + && PL_unify_term(tp, + PL_FUNCTOR, PL_new_functor(PL_new_atom("-"),2), + PL_INT, slot->hash, + PL_LONG, slot->obj + ) + && jni_hr_table_slot(t2,slot->next) + ; + } + } + + +/* unifies t with a list of hash table slot representations */ +static foreign_t +jni_hr_table_plc( + term_t t + ) + { + term_t t1 = PL_copy_term_ref(t); + term_t t2 = PL_new_term_ref(); + int i; + + for ( i=0 ; ilength ; i++ ) + { + if ( !PL_unify_list(t1,t2,t1) || !jni_hr_table_slot(t2,hr_table->slots[i]) ) + { + return FALSE; + } + } + return PL_unify_nil(t1); + } + + +/* an empty table of length is successfully created, where none was before */ +static bool +jni_hr_create( + int length /* required # slots in table */ + ) + { + int i; /* temp for iterative slot initialisation */ + + if ( hr_table != NULL ) + { + return FALSE; /* table already exists (destroy before recreating) */ + } + if ( length <= 0 ) + { + return FALSE; /* unsuitable length */ + } + if ( (hr_table=(HrTable*)malloc(sizeof(HrTable))) == NULL ) + { + return FALSE; /* malloc failed (out of memory, presumably) */ + } + hr_table->length = length; + hr_table->threshold = (int)(hr_table->length*JNI_HR_LOAD_FACTOR); + if ( (hr_table->slots=(HrEntry**)malloc(length*sizeof(HrEntry*))) == NULL ) + { + return FALSE; /* malloc failed: out of memory, presumably */ + } + for ( i=0 ; ilength ; i++ ) + { + hr_table->slots[i] = NULL; + } + hr_table->count = 0; + return TRUE; + } + + +/* an empty table of some default length is successfully created, where none was before */ +static bool +jni_hr_create_default(void) + { + + return jni_hr_create( 101); + } + + +/* ep must point to a chain of zero or more entries; they are freed */ +static void +jni_hr_free_chain_entries( + HrEntry *ep + ) + { + + if ( ep != NULL ) + { + jni_hr_free_chain_entries( ep->next); + free( ep); + } + } + + +/* table t is emptied */ +static void +jni_hr_free_table_chains( + HrTable *t + ) + { + int index; + + for ( index=0 ; index<(t->length) ; index++ ) + { + jni_hr_free_chain_entries( t->slots[index]); + t->slots[index] = NULL; + } + t->count = 0; + } + + +/* all dynamic space used by the pointed-to table is freed */ +static bool +jni_hr_free_table( + HrTable *t + ) + { + + if ( t == NULL ) + { + return FALSE; /* table does not exist */ + } + else + { + jni_hr_free_table_chains( t); + free( t); + return TRUE; + } + } + + +/* the current table is replaced by an equivalent one with more free space */ +static bool +jni_hr_rehash(void) + { + HrTable *t0; /* old table while building new one from it */ + int i; /* for iterating through slots in old table */ + HrEntry *ep1; /* for iterating through all entries in old table */ + HrEntry *ep2; /* an old table entry being relinked into new table */ + int index; /* slot index in new table of entry being transferred */ + + t0 = hr_table; /* temporarily hold onto former table */ + hr_table = NULL; /* precondition for jni_hr_create */ + if ( !jni_hr_create(2*t0->length+1) ) /* new bigger table in its place */ + { + hr_table = t0; /* replace former table for tidiness */ + return FALSE; /* failed to create replacement table during rehash */ + } + for ( i=0 ; ilength ; i++ ) /* for each slot in *former* table */ + { + for ( ep1=t0->slots[i] ; ep1!=NULL ; ) + { /* for each entry in that slot's chain */ + ep2 = ep1; /* grab this entry */ + ep1 = ep1->next; /* advance to next entry or NULL */ + index = (ep2->hash & 0x7fffffff) % hr_table->length; /* new */ + ep2->next = hr_table->slots[index]; /* relink into new array */ + hr_table->slots[index] = ep2; /* " */ + } + t0->slots[i] = NULL; /* tidy old array for generic freeing later */ + } + hr_table->count = t0->count; /* new table's count is old table's count */ + jni_hr_free_table( t0); /* free all space used by old table (NB no entries) */ + return TRUE; + } + + +static bool + jni_hr_hash( /* renamed in v3.0.4 from jni_object_to_hash (it belongs with this hr stuff) */ + JNIEnv *env, + jobject obj, /* MUST BE a valid non-null reference to a Java object */ + int *hash /* gets obj's System.identityHashCode() */ + ) + { + jobject e; /* for possible (but unlikely?) exception */ + + *hash = (*env)->CallStaticIntMethod(env,sys_class,sys_ihc,obj,obj); + return (e=(*env)->ExceptionOccurred(env))==NULL; + } + + +/* returns */ +/* JNI_HR_ADD_NEW -> referenced object is novel */ +/* JNI_HR_ADD_OLD -> referenced object is already known */ +/* JNI_HR_ADD_FAIL -> something went wrong */ +/* and, in *iref, an integerised canonical global ref to the object */ +static int +jni_hr_add( + JNIEnv *env, + jobject lref, /* new JNI local ref from a regular JNI call */ + pointer *iref /* for integerised canonical global ref */ + ) + { + int hash; /* System.identityHashCode of lref */ + int index; /* lref's slot index, from hash */ + HrEntry *ep; /* temp entry pointer for chain traversal */ + jobject gref; /* iff lref is novel, will hold a global surrogate */ + + if ( hr_table==NULL && !jni_hr_create_default() ) + { + return JNI_HR_ADD_FAIL; /* lazy table creation failed: oughta sort return codes */ + } + if ( !jni_hr_hash(env,lref,&hash) ) /* renamed in v3.0.4 from jni_object_to_hash */ + { + return JNI_HR_ADD_FAIL; /* System.identityHashCode() failed (?) */ + } + index = (hash & 0x7fffffff) % hr_table->length; /* make this a macro? */ + for ( ep=hr_table->slots[index] ; ep!=NULL ; ep=ep->next ) + { + if ( ep->hash==hash ) + { + if ( (*env)->IsSameObject(env,ep->obj,lref) ) + { /* newly referenced object is already interned */ + (*env)->DeleteLocalRef(env,lref); /* free redundant new ref */ + *iref = (pointer)ep->obj; /* old, equivalent (global) ref */ + return JNI_HR_ADD_OLD; + } + } + } + if ( hr_table->count >= hr_table->threshold ) + { + (void)jni_hr_rehash(); /* oughta check for failure, and return it... */ + return jni_hr_add(env,lref,iref); /* try again with new, larger table */ + } + /* referenced object is novel, and we can add it to table */ + if ( (gref=(*env)->NewGlobalRef(env,lref)) == NULL ) /* derive a global ref */ + { + return JNI_HR_ADD_FAIL; + } + (*env)->DeleteLocalRef(env,lref); /* free redundant (local) ref */ + ep = (HrEntry*)malloc(sizeof(HrEntry)); + ep->hash = hash; + ep->obj = gref; + ep->next = hr_table->slots[index]; /* insert at front of chain */ + hr_table->slots[index] = ep; + hr_table->count++; + *iref = (pointer)gref; /* pass back the (new) global ref */ + return JNI_HR_ADD_NEW; /* obj was newly interned, under iref as supplied */ + } + + +/* iref corresponded to an entry in the current HashedRef table; */ +/* now that entry is gone, its space is recovered, counts are adjusted etc. */ +/* called only from jni_free_iref() */ +static bool +jni_hr_del( + JNIEnv *env, + pointer iref /* a possibly spurious canonical global iref */ + ) + { + int index; /* index to a HashedRef table slot */ + HrEntry *ep; /* pointer to a HashedRef table entry */ + HrEntry **epp; /* pointer to ep's handle, in case it needs updating */ + + DEBUG(1, Sdprintf( "[removing possible object reference %p]\n", (void *)iref)); + for ( index=0 ; indexlength ; index++ ) /* for each slot */ + { + for ( epp=&(hr_table->slots[index]), ep=*epp ; ep!=NULL ; epp=&(ep->next), ep=*epp ) + { + if ( (pointer)(ep->obj) == iref ) /* found the sought entry? */ + { + (*env)->DeleteGlobalRef( env, ep->obj); /* free the global object reference */ + *epp = ep->next; /* bypass the entry */ + free( ep); /* free the now-redundant space */ + hr_table->count--; /* adjust table's entry count */ + DEBUG(1, Sdprintf( "[found & removed hashtable entry for object reference %p]\n", (void *)iref)); + return TRUE; /* entry found and removed */ + } + } + } + DEBUG(1, Sdprintf("[JPL: failed to find hashtable entry for (presumably bogus) object reference %p]\n", (void *)iref)); + return FALSE; + } + + +/*=== JNI initialisation =========================================================================== */ + +/* called once: after successful PVM & JVM creation/discovery, before any JNI calls */ +static int +jni_init( void ) + { + jclass lref; /* temporary local ref, replaced by global */ + JNIEnv *env = jni_env(); /* could pass this in, but this is easier here */ + + if (env == NULL) + return -8; + + /* these initialisations require an active PVM: */ + JNI_atom_false = PL_new_atom( "false"); + JNI_atom_true = PL_new_atom( "true"); + + JNI_atom_boolean = PL_new_atom( "boolean"); + JNI_atom_char = PL_new_atom( "char"); + JNI_atom_byte = PL_new_atom( "byte"); + JNI_atom_short = PL_new_atom( "short"); + JNI_atom_int = PL_new_atom( "int"); + JNI_atom_long = PL_new_atom( "long"); + JNI_atom_float = PL_new_atom( "float"); + JNI_atom_double = PL_new_atom( "double"); + + JNI_atom_null = PL_new_atom( "null"); + JNI_atom_void = PL_new_atom( "void"); /* not yet used properly (?) */ + + JNI_functor_at_1 = PL_new_functor( PL_new_atom("@"), 1); + JNI_functor_jbuf_2 = PL_new_functor( PL_new_atom("jbuf"), 2); + JNI_functor_jlong_2 = PL_new_functor( PL_new_atom("jlong"), 2); + JNI_functor_jfieldID_1 = PL_new_functor( PL_new_atom("jfieldID"), 1); + JNI_functor_jmethodID_1 = PL_new_functor( PL_new_atom("jmethodID"), 1); + + JNI_functor_error_2 = PL_new_functor(PL_new_atom("error"), 2); + JNI_functor_java_exception_1 = PL_new_functor( PL_new_atom("java_exception"), 1); + JNI_functor_jpl_error_1 = PL_new_functor( PL_new_atom("jpl_error"), 1); + + (void)PL_agc_hook( (PL_agc_hook_t)jni_atom_freed); /* link atom GC to object GC (cool:-) */ + + /* these initialisations require an active JVM: */ + return ( (lref=(*env)->FindClass(env,"java/lang/Class")) != NULL + && (c_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + + && (lref=(*env)->FindClass(env,"java/lang/String")) != NULL + && (str_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + && (c_getName=(*env)->GetMethodID(env,c_class,"getName","()Ljava/lang/String;")) != NULL + + && (lref=(*env)->FindClass(env,"java/lang/System")) != NULL + && (sys_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + && (sys_ihc=(*env)->GetStaticMethodID(env,sys_class,"identityHashCode","(Ljava/lang/Object;)I")) != NULL + + && (lref=(*env)->FindClass(env,"jpl/Term")) != NULL + && (term_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + && (term_getTerm=(*env)->GetStaticMethodID(env,term_class,"getTerm","(Ljpl/fli/term_t;)Ljpl/Term;")) != NULL + && (term_put=(*env)->GetMethodID(env,term_class,"put","(Ljpl/fli/term_t;)V")) != NULL + && (term_putTerm=(*env)->GetStaticMethodID(env,term_class,"putTerm","(Ljava/lang/Object;Ljpl/fli/term_t;)V")) != NULL + + && (lref=(*env)->FindClass(env,"jpl/fli/term_t")) != NULL + && (termt_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + + ? 0 + : -7 /* NB #define this? */ + ) + ; + } + + +/*=== JNI exception/error processing/support ======================================================= */ + +/* returns a new error(java_exception(@(tag)),msg) to represent a caught Java exception */ +static term_t +jni_new_java_exception(atom_t tag, atom_t msg) +{ term_t e; + + if ( (e=PL_new_term_ref()) && + PL_unify_term(e, + PL_FUNCTOR, JNI_functor_error_2, + PL_FUNCTOR, JNI_functor_java_exception_1, + PL_FUNCTOR, JNI_functor_at_1, + PL_ATOM, tag, + PL_ATOM, msg) ) /* Seems unblanaced!? */ + return e; + + return 0; +} + + +/* returns a new error(jpl_error(@(tag)),msg) to represent an exceptional condition raised within JPL */ +static term_t +jni_new_jpl_error(atom_t tag, atom_t msg) +{ term_t e; + + if ( (e= PL_new_term_ref()) && + PL_unify_term(e, + PL_FUNCTOR, JNI_functor_error_2, + PL_FUNCTOR, JNI_functor_jpl_error_1, + PL_FUNCTOR, JNI_functor_at_1, + PL_ATOM, tag, + PL_ATOM, msg) ) /* Seems unblanced!? */ + return e; + + return 0; +} + + +/* test for a raised exception; clear and report it if found */ +static bool +jni_check_exception( + JNIEnv *env + ) + { + jobject ej; /* the pending Java exception, if any */ + jobject c; /* its class */ + jobject s; /* its class name as a JVM String, for the report */ + term_t ep; /* a newly created Prolog exception */ + pointer i; /* temp for an iref denoting a Java exception */ + atom_t tag; /* temp for a tag denoting a Java exception */ + atom_t msg; /* temp for impl-def comment (classname) within error/2 */ + + if ( (ej=(*env)->ExceptionOccurred(env)) == NULL ) + { + return TRUE; + } + else + { + (*env)->ExceptionClear(env); /* clear "exception-pending" state so we can do JNI calls */ + if ( (c=(*env)->GetObjectClass(env,ej)) != NULL ) /* get class of exception */ + { + if ( (s=(*env)->CallObjectMethod(env,c,c_getName)) != NULL ) /* get name of class */ + { + if ( jni_object_to_iref(env,ej,&i) ) + { + if ( jni_iref_to_tag(i,&tag) ) + { + if ( jni_String_to_atom(env,s,&msg) ) + { + ep = jni_new_java_exception(tag,msg); + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToGetUTFCharsOfNameOfClassOfException"),tag); + } + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToConvertExceptionIrefToTagatom"),JNI_atom_null); + } + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToConvertExceptionObjectToIref"),JNI_atom_null); + } + (*env)->DeleteLocalRef(env,s); + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToGetNameOfClassOfException"),JNI_atom_null); + } + (*env)->DeleteLocalRef(env,c); + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToGetClassOfException"),JNI_atom_null); + } + return PL_raise_exception(ep); + } + } + + +/*=== buffer and method param transput ============================================================= */ + +static foreign_t + jni_byte_buf_length_to_codes_plc( + term_t tbb, /* +integer */ + term_t tlen, /* +integer */ + term_t tcs /* -term */ + ) + { + functor_t fn; + term_t a1; + atom_t a; + term_t a2; + jbyte *bb; + int len; + int i; + term_t tl = PL_copy_term_ref( tcs); + term_t ta = PL_new_term_ref(); + void *ptr; + + if ( !( PL_get_functor(tbb,&fn) + && fn==JNI_functor_jbuf_2 + && ( a2=PL_new_term_ref(), + PL_get_arg(2,tbb,a2) + ) + && PL_get_atom(a2,&a) + && a==JNI_atom_byte + && ( a1=PL_new_term_ref(), + PL_get_arg(1,tbb,a1) + ) + && PL_get_pointer(a1,&ptr) + ) + || !PL_get_integer(tlen,&len) + ) + { + return FALSE; + } + bb = ptr; + + for ( i=0 ; i first) */ + term_t txc, /* +integer: transput code, as Prolog integer, appropriate to this param */ + term_t tt, /* +term: param value as datum (value or ref) */ + term_t tjvp /* +pointer: param buffer (allocated just for this call) */ + ) + { + int n; /* got from tn (see above) */ + int xc; /* got from txc (see above) */ + jvalue *jvp; /* got from tjvp (see above) */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + atom_t a; /* " */ + int i; /* " */ + int64_t i64; /* " */ + double d; /* " */ + + if ( !PL_get_integer(tn,&n) || + !PL_get_integer(txc,&xc) || + !PL_get_pointer(tjvp,(void*)&jvp) ) + { + return FALSE; + } + + switch ( xc ) + { + case JNI_XPUT_BOOLEAN: + return JNI_term_to_jboolean(tt,jvp[n].z); + + case JNI_XPUT_BYTE: + return JNI_term_to_jbyte(tt,jvp[n].b); + + case JNI_XPUT_CHAR: + return JNI_term_to_jchar(tt,jvp[n].c); + + case JNI_XPUT_SHORT: + return JNI_term_to_jshort(tt,jvp[n].s); + + case JNI_XPUT_INT: + return JNI_term_to_jint(tt,jvp[n].i); + + case JNI_XPUT_LONG: + return JNI_term_to_jlong(tt,jvp[n].j); + + case JNI_XPUT_FLOAT: + return JNI_term_to_jfloat(tt,jvp[n].f); + + case JNI_XPUT_DOUBLE: + return JNI_term_to_jdouble(tt,jvp[n].d); + + case JNI_XPUT_REF: + { JNIEnv *env = jni_env(); + + return env == NULL ? FALSE : JNI_term_to_ref(tt,jvp[n].l); /* this macro needs a valid env */ + } + default: + return FALSE; /* unknown or inappropriate JNI_XPUT_* code */ + } + } + + +/* for completeness, allocates zero-length buffers too, while avoiding malloc() problems */ +static foreign_t +jni_alloc_buffer_plc( + term_t txc, /* +integer: transput code */ + term_t tlen, /* +integer: required length (# items) */ + term_t tbp /* -pointer: PL_POINTER to newly allocated buffer */ + ) + { + int xc; + int len; + void *bp; + + return PL_get_integer(txc,&xc) + && ( ( xc>=JNI_XPUT_BOOLEAN && xc<=JNI_XPUT_DOUBLE ) || xc==JNI_XPUT_JVALUE ) + && PL_get_integer(tlen,&len) + && len >= 0 + && (bp=malloc((len==0?1:len)*size[xc])) != NULL /* avoid (unsafe) malloc(0) */ + && ( PL_unify_pointer(tbp,(void*)bp) + ? TRUE + : ( free(bp), FALSE) + ) + ; + } + + +static foreign_t +jni_free_buffer_plc( + term_t tbp /* +integer: PL_POINTER to redundant buffer */ + ) + { + void *bp; + + return PL_get_pointer(tbp,&bp) + && ( free(bp), TRUE); + } + + +static foreign_t +jni_fetch_buffer_value_plc( + term_t tbp, /* +pointer: PL_POINTER to an active buffer from jni_alloc_buffer/3 */ + term_t ti, /* +integer: index into buffer; 0 <= i < length */ + term_t tv, /* -term: required value (@(false), @(true), integer or float) from buffer */ + term_t txc /* +integer: transput code (one of JNI_XPUT_*) */ + ) + { + void *bp; /* buffer address (trusted to be valid) */ + int i; /* buffer index (trusted to be valid) */ + int xc; /* transput code (range-checked by switch statement) */ + + if ( !PL_get_pointer(tbp,&bp) || !PL_get_integer(ti,&i) || !PL_get_integer(txc,&xc) ) + { + return FALSE; + } + + switch ( xc ) /* primitive type only */ + { + case JNI_XPUT_BOOLEAN: + return JNI_jboolean_to_term(((jboolean*)bp)[i],tv); + + case JNI_XPUT_CHAR: + return PL_unify_integer(tv,((jchar*)bp)[i]); + + case JNI_XPUT_BYTE: + return PL_unify_integer(tv,((jbyte*)bp)[i]); + + case JNI_XPUT_SHORT: + return PL_unify_integer(tv,((jshort*)bp)[i]); + + case JNI_XPUT_INT: + return PL_unify_integer(tv,((jint*)bp)[i]); + + case JNI_XPUT_LONG: + return PL_unify_int64(tv,((jlong*)bp)[i]); + + case JNI_XPUT_FLOAT: + return PL_unify_float(tv,((jfloat*)bp)[i]); + + case JNI_XPUT_DOUBLE: + return PL_unify_float(tv,((jdouble*)bp)[i]); + + default: + return FALSE; + } + } + + +static foreign_t +jni_stash_buffer_value_plc( + term_t tbp, /* +integer: PL_POINTER to buffer */ + term_t ti, /* +integer: index into buffer */ + term_t tv, /* +term: @(false), @(true), integer or float */ + term_t txc /* +integer: transput code (one of JNI_XPUT_*) */ + ) + { + void *bp; + int i; + int idx; + int64_t i64; + int xc; + double d; + functor_t fn; + term_t a1; + atom_t a; + + if ( !PL_get_pointer(tbp,&bp) + || !PL_get_integer(ti,&idx) + || !PL_get_integer(txc,&xc) + ) + { + return FALSE; + } + + switch ( xc ) + { + case JNI_XPUT_BOOLEAN: + return JNI_term_to_jboolean(tv,((jboolean*)bp)[idx]); + + case JNI_XPUT_CHAR: + return JNI_term_to_jchar(tv,((jchar*)bp)[idx]); + + case JNI_XPUT_BYTE: + return JNI_term_to_jbyte(tv,((jbyte*)bp)[idx]); + + case JNI_XPUT_SHORT: + return JNI_term_to_jshort(tv,((jshort*)bp)[idx]); + + case JNI_XPUT_INT: + return JNI_term_to_jint(tv,((jint*)bp)[idx]); + + case JNI_XPUT_LONG: + return JNI_term_to_jlong(tv,((jlong*)bp)[idx]); + + case JNI_XPUT_FLOAT: + return JNI_term_to_jfloat(tv,((jfloat*)bp)[idx]); + + case JNI_XPUT_DOUBLE: + return JNI_term_to_jdouble(tv,((jdouble*)bp)[idx]); + + default: + return FALSE; + } + } + + +/*=== JVM initialisation, startup etc. ============================================================= */ + +static int +jni_get_created_jvm_count(void) + { + jint n; + + return ( JNI_GetCreatedJavaVMs(NULL,0,&n) == 0 /* what does the '0' arg mean? */ + ? n + : -1 + ) + ; + } + + +#define MAX_JVM_OPTIONS 100 + +static int +jni_create_jvm_c( + char *classpath + ) + { + JavaVMInitArgs vm_args; + /* char cpopt[10000]; */ + char *cpoptp; + JavaVMOption opt[MAX_JVM_OPTIONS]; + int r; + jint n; + int optn = 0; + JNIEnv *env; + + DEBUG(1, Sdprintf( "[creating JVM with 'java.class.path=%s']\n", classpath)); + vm_args.version = JNI_VERSION_1_2; /* "Java 1.2 please" */ + if ( classpath ) + { + cpoptp = (char *)malloc(strlen(classpath)+20); + strcpy( cpoptp, "-Djava.class.path="); /* was cpopt */ + strcat( cpoptp, classpath); /* oughta check length... */ + vm_args.options = opt; + opt[optn].optionString = cpoptp; /* was cpopt */ + optn++; + } + /* opt[optn++].optionString = "-Djava.compiler=NONE"; */ + /* opt[optn].optionString = "exit"; // I don't understand this yet... */ + /* opt[optn++].extraInfo = jvm_exit; // this function has been moved to jpl_extras.c */ + /* opt[optn].optionString = "abort"; // I don't understand this yet... */ + /* opt[optn++].extraInfo = jvm_abort; // this function has been moved to jpl_extras.c */ + /* opt[optn++].optionString = "-Xcheck:jni"; // extra checking of JNI calls */ +#if __YAP_PROLOG__ + opt[optn++].optionString = "-Xmx512m"; // give java enough space +#if defined(__APPLE__) + // I can't make jpl work with AWT graphics, without creating the extra thread. + opt[optn++].optionString = "-Djava.awt.headless=true"; +#endif + // opt[optn++].optionString = "-XstartOnFirstThread"; +#endif + /* opt[optn++].optionString = "-Xnoclassgc"; // so method/field IDs remain valid (?) */ + /* opt[optn].optionString = "vfprintf"; */ + /* opt[optn++].extraInfo = fprintf; // no O/P, then SEGV */ + /* opt[optn++].extraInfo = xprintf; // one message, then SEGV */ + /* opt[optn++].optionString = "-verbose:jni"; */ + + if ( jvm_dia != NULL ) + { + int i; + + for ( i=0 ; jvm_dia[i]!=NULL ; i++ ) + { + opt[optn++].optionString = jvm_dia[i]; + } + jvm_aia = jvm_dia; + jvm_dia = NULL; + } + + vm_args.nOptions = optn; + /* vm_args.ignoreUnrecognized = TRUE; */ + + return + ( JNI_GetCreatedJavaVMs(&jvm,1,&n) == 0 /* what does the '1' arg mean? */ + && n == 1 + /* && (*jvm)->GetEnv(jvm,(void**)&env,JNI_VERSION_1_2) == JNI_OK */ + && (env = jni_env()) != NULL + ? 2 /* success (JVM already available) */ + : ( (r=JNI_CreateJavaVM(&jvm,(void**)&env,&vm_args)) == 0 + ? 0 /* success (JVM created OK) */ + : ( jvm=NULL, r) /* -ve, i.e. some create error */ + ) + ); + } + + +static foreign_t +jni_get_created_jvm_count_plc( + term_t t1 + ) + { + + return PL_unify_integer(t1,jni_get_created_jvm_count()); + } + + +static int +jni_create_jvm( + char *cp + ) + { + int r1; + int r2; + + DEBUG(1, Sdprintf("[JPL: checking for Java VM...]\n")); + return + ( jvm != NULL + ? 1 /* already initialised */ + : ( (r1=jni_create_jvm_c(cp)) < 0 + ? r1 /* err code from JVM-specific routine */ + : ( (r2=jni_init()) < 0 + ? r2 /* err code from jni_init() */ + : ( r1 == 0 /* success code from JVM-specific routine */ + ? ( DEBUG(0, Sdprintf("[JPL: Java VM created]\n")), r1) + : ( DEBUG(0, Sdprintf("[JPL: Java VM found]\n")), r1) + ) + ) + ) + ); + } + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +JW: Note: recent SWI-Prolog set the environment using Win32 API. We can +only get the proper value using the Win32 API; getenv only returns the +value at startup of Prolog. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +jni_create_default_jvm(void) + { + int r; +#ifdef __WINDOWS__ + char *cp; + DWORD len; + + if ( (len=GetEnvironmentVariable("CLASSPATH", NULL, 0)) > 0 ) + { cp = malloc(len+1); + + GetEnvironmentVariable("CLASSPATH", cp, len+1); + } else + cp = NULL; +#else + char *cp = getenv("CLASSPATH"); +#endif + + DEBUG(0, Sdprintf("jni_create_default_jvm(): cp=%s\n", cp)); + + if ( (r=jni_create_jvm(cp)) < 0 ) + { + Sdprintf("[JPL: failed to create Java VM (error %d)]\n", r); + } + return r >= 0; /* e.g. 2 -> "JVM already available" */ + } + + +static foreign_t +jni_ensure_jvm_plc(void) + { + JNIEnv *env; /* not used but perhaps initialised by the jni_ensure_jvm() macro */ + + return jni_ensure_jvm(); + } + + + +#if __YAP_PROLOG__ +#include "hacks.c" +#endif + +/* NB after any JNI call which clearly indicates success, */ +/* it is unnecessary to check for an exception */ +/* (potential for slight economy here...) */ +static foreign_t +jni_void_0_plc( /* C identifiers distinguished _0_ etc, Prolog name is overloaded */ + term_t tn /* +integer */ + ) + { + int n; /* JNI function index */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() /* ought this either succeed or throw a JPL error? */ + || !PL_get_integer(tn,&n) /* ought this either succeed or throw a Prolog type error? */ + ) + { + return FALSE; + } + + switch ( n ) + { + case 17: + r = ( (*env)->ExceptionClear(env) , TRUE ); /* could just return... */ + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_1_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1 /* +term: Arg1 */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* int i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + /* void *p1; // temp for converted (JVM) arg */ + char *c1; /* " */ + /* int i1; // " */ + /* jlong l1; // " */ + /* double d1; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 18: + r = JNI_term_to_charP(ta1,c1) + && ( (*env)->FatalError(env,(char*)c1) , TRUE ); + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_2_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2 /* +term: Arg2 */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* int i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + /* void *p1; // temp for converted (JVM) arg */ + /* void *p2; // " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* int i1; // " */ + /* int i2; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* double d1; // " */ + /* double d2; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 166: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_char) */ + /* && ( (*env)->ReleaseStringChars(env,(jstring)p1,(jchar*)p2) , TRUE ); */ + /* break; */ + /* case 170: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,c2,JNI_atom_byte) */ + /* && ( (*env)->ReleaseStringUTFChars(env,(jstring)p1,(char*)c2) , TRUE ); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_3_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3 /* +term: Arg3 */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + int i; /* " */ + int64_t i64; /* " */ + double d; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + void *p2; /* " */ + void *p3; /* " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* char *c3; // " */ + /* int i1; // " */ + int i2; /* " */ + int i3; /* " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + jlong l3; /* " */ + /* float f1; // " */ + /* float f2; // " */ + float f3; /* " */ + /* double d1; // " */ + /* double d2; // " */ + double d3; /* " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 63: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && ( (*env)->CallVoidMethodA(env,(jobject)p1,(jmethodID)p2,jvp) , TRUE ); + break; + case 104: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_ref(ta3,p3) + && ( (*env)->SetObjectField(env,(jobject)p1,(jfieldID)p2,(jobject)p3) , TRUE ); + break; + case 105: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jboolean(ta3,i3) + && ( (*env)->SetBooleanField(env,(jobject)p1,(jfieldID)p2,(jboolean)i3) , TRUE ); + break; + case 106: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jbyte(ta3,i3) + && ( (*env)->SetByteField(env,(jobject)p1,(jfieldID)p2,(jbyte)i3) , TRUE ); + break; + case 107: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jchar(ta3,i3) + && ( (*env)->SetCharField(env,(jobject)p1,(jfieldID)p2,(jchar)i3) , TRUE ); + break; + case 108: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jshort(ta3,i3) + && ( (*env)->SetShortField(env,(jobject)p1,(jfieldID)p2,(jshort)i3) , TRUE ); + break; + case 109: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jint(ta3,i3) + && ( (*env)->SetIntField(env,(jobject)p1,(jfieldID)p2,(jint)i3) , TRUE ); + break; + case 110: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jlong(ta3,l3) + && ( (*env)->SetLongField(env,(jobject)p1,(jfieldID)p2,(jlong)l3) , TRUE ); + break; + case 111: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jfloat(ta3,f3) /* f3 was d3 */ + && ( (*env)->SetFloatField(env,(jobject)p1,(jfieldID)p2,(jfloat)f3) , TRUE ); /* f3 was d3 */ + break; + case 112: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jdouble(ta3,d3) + && ( (*env)->SetDoubleField(env,(jobject)p1,(jfieldID)p2,(jdouble)d3) , TRUE ); + break; + case 143: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && ( (*env)->CallStaticVoidMethodA(env,(jclass)p1,(jmethodID)p2,jvp) , TRUE ); + break; + case 154: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_ref(ta3,p3) + && ( (*env)->SetStaticObjectField(env,(jclass)p1,(jfieldID)p2,(jobject)p3) , TRUE ); + break; + case 155: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jboolean(ta3,i3) + && ( (*env)->SetStaticBooleanField(env,(jclass)p1,(jfieldID)p2,(jboolean)i3) , TRUE ); + break; + case 156: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jbyte(ta3,i3) + && ( (*env)->SetStaticByteField(env,(jclass)p1,(jfieldID)p2,(jbyte)i3) , TRUE ); + break; + case 157: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jchar(ta3,i3) + && ( (*env)->SetStaticCharField(env,(jclass)p1,(jfieldID)p2,(jchar)i3) , TRUE ); + break; + case 158: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jshort(ta3,i3) + && ( (*env)->SetStaticShortField(env,(jclass)p1,(jfieldID)p2,(jshort)i3) , TRUE ); + break; + case 159: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jint(ta3,i3) + && ( (*env)->SetStaticIntField(env,(jclass)p1,(jfieldID)p2,(jint)i3) , TRUE ); + break; + case 160: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jlong(ta3,l3) + && ( (*env)->SetStaticLongField(env,(jclass)p1,(jfieldID)p2,(jlong)l3) , TRUE ); + break; + case 161: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jfloat(ta3,f3) /* f3 was d3 */ + && ( (*env)->SetStaticFloatField(env,(jclass)p1,(jfieldID)p2,(jfloat)f3) , TRUE ); /* f3 was d3 */ + break; + case 162: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jdouble(ta3,d3) + && ( (*env)->SetStaticDoubleField(env,(jclass)p1,(jfieldID)p2,(jdouble)d3) , TRUE ); + break; + case 174: + r = JNI_term_to_object_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_ref(ta3,p3) + && ( (*env)->SetObjectArrayElement(env,(jobjectArray)p1,(jsize)i2,(jobject)p3) , TRUE ); + break; + /* case 191: */ + /* r = JNI_term_to_boolean_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_boolean) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseBooleanArrayElements(env,(jbooleanArray)p1,(jboolean*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 192: */ + /* r = JNI_term_to_byte_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_byte) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseByteArrayElements(env,(jbyteArray)p1,(jbyte*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 193: */ + /* r = JNI_term_to_char_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_char) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseCharArrayElements(env,(jcharArray)p1,(jchar*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 194: */ + /* r = JNI_term_to_short_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_short) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseShortArrayElements(env,(jshortArray)p1,(jshort*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 195: */ + /* r = JNI_term_to_int_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_int) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseIntArrayElements(env,(jintArray)p1,(jint*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 196: */ + /* r = JNI_term_to_long_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_long) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseLongArrayElements(env,(jlongArray)p1,(jlong*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 197: */ + /* r = JNI_term_to_float_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_float) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseFloatArrayElements(env,(jfloatArray)p1,(jfloat*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 198: */ + /* r = JNI_term_to_double_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_double) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseDoubleArrayElements(env,(jdoubleArray)p1,(jdouble*)p2,(jint)i3) , TRUE ); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_4_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3, /* +term: Arg3 */ + term_t ta4 /* +term: Arg4 */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + term_t a2; /* " */ + atom_t a; /* " */ + /* char *cp; // " */ + int i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + /* void *p2; // " */ + /* void *p3; // " */ + void *p4; /* " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* char *c3; // " */ + /* char *c4; // " */ + /* int i1; // " */ + int i2; /* " */ + int i3; /* " */ + /* int i4; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* jlong l3; // " */ + /* jlong l4; // " */ + /* double d1; // " */ + /* double d2; // " */ + /* double d3; // " */ + /* double d4; // " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 93: */ + /* r = JNI_term_to_jobject(ta1,p1) */ + /* && JNI_term_to_jclass(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && ( (*env)->CallNonvirtualVoidMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp) , TRUE ); */ + /* break; */ + case 199: + r = JNI_term_to_boolean_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_boolean) + && ( (*env)->GetBooleanArrayRegion(env,(jbooleanArray)p1,(jsize)i2,(jsize)i3,(jboolean*)p4) , TRUE ); + break; + case 200: + r = JNI_term_to_byte_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_byte) + && ( (*env)->GetByteArrayRegion(env,(jbyteArray)p1,(jsize)i2,(jsize)i3,(jbyte*)p4) , TRUE ); + break; + case 201: + r = JNI_term_to_char_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_char) + && ( (*env)->GetCharArrayRegion(env,(jcharArray)p1,(jsize)i2,(jsize)i3,(jchar*)p4) , TRUE ); + break; + case 202: + r = JNI_term_to_short_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_short) + && ( (*env)->GetShortArrayRegion(env,(jshortArray)p1,(jsize)i2,(jsize)i3,(jshort*)p4) , TRUE ); + break; + case 203: + r = JNI_term_to_int_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_int) + && ( (*env)->GetIntArrayRegion(env,(jintArray)p1,(jsize)i2,(jsize)i3,(jint*)p4) , TRUE ); + break; + case 204: + r = JNI_term_to_long_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_long) + && ( (*env)->GetLongArrayRegion(env,(jlongArray)p1,(jsize)i2,(jsize)i3,(jlong*)p4) , TRUE ); + break; + case 205: + r = JNI_term_to_float_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_float) + && ( (*env)->GetFloatArrayRegion(env,(jfloatArray)p1,(jsize)i2,(jsize)i3,(jfloat*)p4) , TRUE ); + break; + case 206: + r = JNI_term_to_double_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_double) + && ( (*env)->GetDoubleArrayRegion(env,(jdoubleArray)p1,(jsize)i2,(jsize)i3,(jdouble*)p4) , TRUE ); + break; + case 207: + r = JNI_term_to_boolean_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_boolean) + && ( (*env)->SetBooleanArrayRegion(env,(jbooleanArray)p1,(jsize)i2,(jsize)i3,(jboolean*)p4) , TRUE ); + break; + case 208: + r = JNI_term_to_byte_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_byte) + && ( (*env)->SetByteArrayRegion(env,(jbyteArray)p1,(jsize)i2,(jsize)i3,(jbyte*)p4) , TRUE ); + break; + case 209: + r = JNI_term_to_char_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_char) + && ( (*env)->SetCharArrayRegion(env,(jcharArray)p1,(jsize)i2,(jsize)i3,(jchar*)p4) , TRUE ); + break; + case 210: + r = JNI_term_to_short_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_short) + && ( (*env)->SetShortArrayRegion(env,(jshortArray)p1,(jsize)i2,(jsize)i3,(jshort*)p4) , TRUE ); + break; + case 211: + r = JNI_term_to_int_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_int) + && ( (*env)->SetIntArrayRegion(env,(jintArray)p1,(jsize)i2,(jsize)i3,(jint*)p4) , TRUE ); + break; + case 212: + r = JNI_term_to_long_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_long) + && ( (*env)->SetLongArrayRegion(env,(jlongArray)p1,(jsize)i2,(jsize)i3,(jlong*)p4) , TRUE ); + break; + case 213: + r = JNI_term_to_float_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_float) + && ( (*env)->SetFloatArrayRegion(env,(jfloatArray)p1,(jsize)i2,(jsize)i3,(jfloat*)p4) , TRUE ); + break; + case 214: + r = JNI_term_to_double_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_double) + && ( (*env)->SetDoubleArrayRegion(env,(jdoubleArray)p1,(jsize)i2,(jsize)i3,(jdouble*)p4) , TRUE ); + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_0_plc( + term_t tn, /* +integer: JNI function index */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* pointer i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 4: */ + /* r = JNI_jint_to_term((*env)->GetVersion(env),tr); */ + /* break; */ + /* case 15: */ + /* r = JNI_jobject_to_term((*env)->ExceptionOccurred(env),tr); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; /* surely NEITHER of these throws an exception! */ + } + + +static foreign_t +jni_func_1_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + pointer i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + jobject j; /* " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + char *c1; /* " */ + int i1; /* " */ + /* jlong l1; // " */ + /* double d1; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 6: + r = JNI_term_to_charP(ta1,c1) + && JNI_jobject_to_term((*env)->FindClass(env,(char*)c1),tr); /* *NOT* Unicode */ + break; + case 10: + r = JNI_term_to_jclass(ta1,p1) + && JNI_jobject_to_term((*env)->GetSuperclass(env,(jclass)p1),tr); + break; + /* case 13: */ + /* r = JNI_term_to_throwable_jobject(ta1,p1) */ + /* && JNI_jint_to_term((*env)->Throw(env,(jthrowable)p1),tr); */ + /* break; */ + /* case 27: */ + /* r = JNI_term_to_non_array_jclass(ta1,p1) */ + /* && JNI_jobject_to_term((*env)->AllocObject(env,(jclass)p1),tr); */ + /* break; */ + case 31: + r = JNI_term_to_jobject(ta1,p1) + && JNI_jobject_to_term((*env)->GetObjectClass(env,(jobject)p1),tr); + break; + /* case 164: // not used */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jint_to_term((*env)->GetStringLength(env,(jstring)p1),tr); */ + /* break; */ + /* case 167: // not used */ + /* r = JNI_term_to_charP(ta1,c1) */ + /* && JNI_jobject_to_term((*env)->NewStringUTF(env,(char*)c1),tr); */ + /* break; */ + /* case 168: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jint_to_term((*env)->GetStringUTFLength(env,(jstring)p1),tr); */ + /* break; */ + case 171: + r = JNI_term_to_jarray(ta1,p1) + && JNI_jint_to_term((*env)->GetArrayLength(env,(jarray)p1),tr); + break; + case 175: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewBooleanArray(env,(jsize)i1),tr); + break; + case 176: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewByteArray(env,(jsize)i1),tr); + break; + case 177: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewCharArray(env,(jsize)i1),tr); + break; + case 178: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewShortArray(env,(jsize)i1),tr); + break; + case 179: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewIntArray(env,(jsize)i1),tr); + break; + case 180: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewLongArray(env,(jsize)i1),tr); + break; + case 181: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewFloatArray(env,(jsize)i1),tr); + break; + case 182: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewDoubleArray(env,(jsize)i1),tr); + break; + /* case 217: */ + /* r = JNI_term_to_jobject(ta1,p1) */ + /* && JNI_jint_to_term((*env)->MonitorEnter(env,(jobject)p1),tr); */ + /* break; */ + /* case 218: */ + /* r = JNI_term_to_jobject(ta1,p1) */ + /* && JNI_jint_to_term((*env)->MonitorExit(env,(jobject)p1),tr); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_2_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + pointer i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + jobject j; /* " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + void *p2; /* " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* int i1; // " */ + int i2; /* " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* double d1; // " */ + /* double d2; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 11: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jclass(ta2,p2) + && JNI_jboolean_to_term((*env)->IsAssignableFrom(env,(jclass)p1,(jclass)p2),tr); + break; + /* case 14: */ + /* r = JNI_term_to_throwable_jclass(ta1,p1) */ + /* && JNI_term_to_charP(ta2,c2) */ + /* && JNI_jint_to_term((*env)->ThrowNew(env,(jclass)p1,(char*)c2),tr); */ + /* break; */ + /* case 24: */ + /* r = JNI_term_to_ref(ta1,p1) */ + /* && JNI_term_to_ref(ta2,p2) */ + /* && JNI_jboolean_to_term((*env)->IsSameObject(env,(jobject)p1,(jobject)p2),tr); */ + /* break; */ + /* case 32: */ + /* r = JNI_term_to_ref(ta1,p1) */ + /* && JNI_term_to_jclass(ta2,p2) */ + /* && JNI_jboolean_to_term((*env)->IsInstanceOf(env,(jobject)p1,(jclass)p2),tr); */ + /* break; */ + case 95: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jobject_to_term((*env)->GetObjectField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 96: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jboolean_to_term((*env)->GetBooleanField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 97: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jbyte_to_term((*env)->GetByteField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 98: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jchar_to_term((*env)->GetCharField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 99: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jshort_to_term((*env)->GetShortField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 100: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jint_to_term((*env)->GetIntField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 101: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jlong_to_term((*env)->GetLongField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 102: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jfloat_to_term((*env)->GetFloatField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 103: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jdouble_to_term((*env)->GetDoubleField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 145: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jobject_to_term((*env)->GetStaticObjectField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 146: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jboolean_to_term((*env)->GetStaticBooleanField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 147: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jbyte_to_term((*env)->GetStaticByteField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 148: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jchar_to_term((*env)->GetStaticCharField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 149: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jshort_to_term((*env)->GetStaticShortField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 150: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jint_to_term((*env)->GetStaticIntField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 151: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jlong_to_term((*env)->GetStaticLongField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 152: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jfloat_to_term((*env)->GetStaticFloatField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 153: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jdouble_to_term((*env)->GetStaticDoubleField(env,(jclass)p1,(jfieldID)p2),tr); + break; + /* case 163: */ + /* r = JNI_term_to_charP(ta1,c1) // oughta be _jcharP, i.e. Unicode */ + /* && JNI_term_to_non_neg_jint(ta2,i2) */ + /* && JNI_jobject_to_term((*env)->NewString(env,(jchar*)c1,(jsize)i2),tr); */ + /* break; */ + /* case 165: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetStringChars(env,(jstring)p1,(jboolean*)&i2),tr,JNI_atom_boolean) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 169: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetStringUTFChars(env,(jstring)p1,(jboolean*)&i2),tr,JNI_atom_byte) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + case 173: + { int i; /* JW: i is long in this function */ + + i2 = 0; /* JW: make compiler happy */ + r = JNI_term_to_object_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2); + } + if ( r ) + r = JNI_jobject_to_term((*env)->GetObjectArrayElement(env,(jobjectArray)p1,(jsize)i2),tr); + break; + /* case 183: */ + /* r = JNI_term_to_boolean_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetBooleanArrayElements(env,(jbooleanArray)p1,(jboolean*)&i2),tr,JNI_atom_boolean) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 184: */ + /* r = JNI_term_to_byte_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetByteArrayElements(env,(jbyteArray)p1,(jboolean*)&i2),tr,JNI_atom_byte) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 185: */ + /* r = JNI_term_to_char_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetCharArrayElements(env,(jcharArray)p1,(jboolean*)&i2),tr,JNI_atom_char) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 186: */ + /* r = JNI_term_to_short_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetShortArrayElements(env,(jshortArray)p1,(jboolean*)&i2),tr,JNI_atom_short) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 187: */ + /* r = JNI_term_to_int_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetIntArrayElements(env,(jintArray)p1,(jboolean*)&i2),tr,JNI_atom_int) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 188: */ + /* r = JNI_term_to_long_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetLongArrayElements(env,(jlongArray)p1,(jboolean*)&i2),tr,JNI_atom_long) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 189: */ + /* r = JNI_term_to_float_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetFloatArrayElements(env,(jfloatArray)p1,(jboolean*)&i2),tr,JNI_atom_float) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 190: */ + /* r = JNI_term_to_double_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetDoubleArrayElements(env,(jdoubleArray)p1,(jboolean*)&i2),tr,JNI_atom_double) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_3_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3, /* +term: Arg3 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + pointer i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + jobject j; /* " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + void *p2; /* " */ + void *p3; /* " */ + /* char *c1; // " */ + char *c2; /* " */ + char *c3; /* " */ + int i1; /* " */ + /* int i2; // " */ + /* int i3; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* jlong l3; // " */ + /* double d1; // " */ + /* double d2; // " */ + /* double d3; // " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 30: + r = JNI_term_to_non_array_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jobject_to_term((*env)->NewObjectA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 33: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jmethodID_to_term((*env)->GetMethodID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 36: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jobject_to_term((*env)->CallObjectMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 39: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jboolean_to_term((*env)->CallBooleanMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 42: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jbyte_to_term((*env)->CallByteMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 45: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jchar_to_term((*env)->CallCharMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 48: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jshort_to_term((*env)->CallShortMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 51: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jint_to_term((*env)->CallIntMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 54: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jlong_to_term((*env)->CallLongMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 57: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jfloat_to_term((*env)->CallFloatMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 60: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jdouble_to_term((*env)->CallDoubleMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 94: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jfieldID_to_term((*env)->GetFieldID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 113: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jmethodID_to_term((*env)->GetStaticMethodID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 116: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jobject_to_term((*env)->CallStaticObjectMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 119: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jboolean_to_term((*env)->CallStaticBooleanMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 122: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jbyte_to_term((*env)->CallStaticByteMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 125: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jchar_to_term((*env)->CallStaticCharMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 128: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jshort_to_term((*env)->CallStaticShortMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 131: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jint_to_term((*env)->CallStaticIntMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 134: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jlong_to_term((*env)->CallStaticLongMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 137: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jfloat_to_term((*env)->CallStaticFloatMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 140: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jdouble_to_term((*env)->CallStaticDoubleMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 144: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jfieldID_to_term((*env)->GetStaticFieldID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 172: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_term_to_jclass(ta2,p2) + && JNI_term_to_ref(ta3,p3) + && JNI_jobject_to_term((*env)->NewObjectArray(env,(jsize)i1,(jclass)p2,(jobject)p3),tr); + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_4_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3, /* +term: Arg3 */ + term_t ta4, /* +term: Arg4 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* pointer i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + /* void *p1; // temp for converted (JVM) arg */ + /* void *p2; // " */ + /* void *p3; // " */ + /* void *p4; // " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* char *c3; // " */ + /* char *c4; // " */ + /* int i1; // " */ + /* int i2; // " */ + /* int i3; // " */ + /* int i4; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* jlong l3; // " */ + /* jlong l4; // " */ + /* double d1; // " */ + /* double d2; // " */ + /* double d3; // " */ + /* double d4; // " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 5: */ + /* r = JNI_term_to_charP(ta1,c1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jbuf(ta3,p3,JNI_atom_byte) */ + /* && JNI_term_to_jint(ta4,i4) */ + /* && JNI_jobject_to_term((*env)->DefineClass(env,(char*)c1,(jobject)p2,(jbyte*)p3,(jsize)i4),tr); */ + /* break; */ + /* case 66: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jobject_to_term((*env)->CallNonvirtualObjectMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 69: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jboolean_to_term((*env)->CallNonvirtualBooleanMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 72: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jbyte_to_term((*env)->CallNonvirtualByteMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 75: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jchar_to_term((*env)->CallNonvirtualCharMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 78: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jshort_to_term((*env)->CallNonvirtualShortMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 81: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jint_to_term((*env)->CallNonvirtualIntMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 84: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jlong_to_term((*env)->CallNonvirtualLongMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 87: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jfloat_to_term((*env)->CallNonvirtualFloatMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 90: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jdouble_to_term((*env)->CallNonvirtualDoubleMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +/*=== JPL functions ================================================================================ */ + +static int + create_pool_engines(void); + +static int +jpl_num_initial_default_args(void) /* used only once, by jpl_do_jpl_init() */ + { + int i; + + for ( i=0 ; default_args[i]!=NULL ; i++ ) + { + } + return i; + } + + +/* outcomes: */ +/* fail to find jpl.*, jpl.fli.* classes or to convert init args to String[]: exception, FALSE */ +/* all OK: TRUE */ +static bool +jpl_do_jpl_init( /* to be called once only, after PL init, before any JPL calls */ + JNIEnv *env + ) + { + jclass tc; /* temporary class ref */ + jobject ta; /* temporary array ref */ + char *msg; /* error message for exceptions thrown here */ + int i; /* loop counter */ + jobject to; /* temporary (String) object ref */ + + if ( jpl_status != JPL_INIT_RAW ) /* jpl init already attempted? (shouldn't happen) */ + { + DEBUG(1, Sdprintf( "[JPL: jpl_do_jpl_init() called AGAIN (skipping...)]\n")); + return TRUE; + } + + /* prerequisites for setting initial default args into String[] pvm_dia: */ + if ( (tc=(*env)->FindClass(env,"java/lang/String")) == NULL + || (jString_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (ta=(*env)->NewObjectArray(env,jpl_num_initial_default_args(),jString_c,NULL)) == NULL + || (pvm_dia=(*env)->NewGlobalRef(env,ta)) == NULL + || ( (*env)->DeleteLocalRef(env,ta), FALSE) + ) + { + msg = "jpl_do_jpl_init(): failed to find java.lang.String or create String[] pvm_dia"; + goto err; + } + + /* copy the initial default args into String[] pvm_dia: */ + for ( i=0 ; default_args[i]!=NULL ; i++ ) + { + if ( (to=(*env)->NewStringUTF(env,default_args[i])) == NULL ) + { + msg = "jpl_do_jpl_init(): failed to convert an initial default arg to a String"; + goto err; + } + (*env)->SetObjectArrayElement(env,pvm_dia,i,to); /* any errors/exceptions to be handled here? */ + } + + if ( (tc=(*env)->FindClass(env,"jpl/JPLException")) == NULL + || (jJPLException_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/term_t")) == NULL + || (jTermT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/atom_t")) == NULL + || (jAtomT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/functor_t")) == NULL + || (jFunctorT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/fid_t")) == NULL + || (jFidT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/predicate_t")) == NULL + || (jPredicateT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/qid_t")) == NULL + || (jQidT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/module_t")) == NULL + || (jModuleT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/engine_t")) == NULL + || (jEngineT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/LongHolder")) == NULL + || (jLongHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/PointerHolder")) == NULL + || (jPointerHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/IntHolder")) == NULL + || (jIntHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/Int64Holder")) == NULL + || (jInt64Holder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/DoubleHolder")) == NULL + || (jDoubleHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/StringHolder")) == NULL + || (jStringHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/ObjectHolder")) == NULL + || (jObjectHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/BooleanHolder")) == NULL + || (jBooleanHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (jLongHolderValue_f=(*env)->GetFieldID(env,jLongHolder_c,"value","J")) == NULL + + || (jPointerHolderValue_f=(*env)->GetFieldID(env,jPointerHolder_c,"value","J")) == NULL + + || (jIntHolderValue_f=(*env)->GetFieldID(env,jIntHolder_c,"value","I")) == NULL + + || (jInt64HolderValue_f=(*env)->GetFieldID(env,jInt64Holder_c,"value","J")) == NULL + + || (jDoubleHolderValue_f=(*env)->GetFieldID(env,jDoubleHolder_c,"value","D")) == NULL + + || (jStringHolderValue_f=(*env)->GetFieldID(env,jStringHolder_c,"value","Ljava/lang/String;")) == NULL + + || (jObjectHolderValue_f=(*env)->GetFieldID(env,jObjectHolder_c,"value","Ljava/lang/Object;")) == NULL + + || (jBooleanHolderValue_f=(*env)->GetFieldID(env,jBooleanHolder_c,"value","Z")) == NULL + ) + { + msg = "jpl_do_jpl_init(): failed to find jpl.* or jpl.fli.* classes"; + goto err; + } + + DEBUG(1, Sdprintf( "[jpl_do_jpl_init() sets jpl_status = JPL_INIT_PVM_MAYBE, returns TRUE]\n")); + jpl_status = JPL_INIT_PVM_MAYBE; + return TRUE; + +err: + jpl_status = JPL_INIT_JPL_FAILED; + (*env)->ThrowNew(env,jJPLException_c,msg); + return FALSE; + } + + +/* prerequisite: */ +/* called only from jpl_test_pvm_init() and jpl_do_pvm_init() */ +/* outcomes: */ +/* error setting up post-PVM-init JPL state: throws exception, sets status = PVM_FAILED, returns FALSE */ +/* OK: sets status = OK, returns TRUE */ +static bool +jpl_post_pvm_init( + JNIEnv *env, + int argc, + char **argv + ) + { + char *msg; + jobject ta; + int i; + + /* Prolog VM is already initialised (by us or by other party) */ + /* retire default init args and set up actual init args: */ + pvm_dia = NULL; /* probably oughta delete (global) ref to former args... */ + if ( (ta=(*env)->NewObjectArray(env,argc,jString_c,NULL)) == NULL + || (pvm_aia=(*env)->NewGlobalRef(env,ta)) == NULL + || ( (*env)->DeleteLocalRef(env,ta), FALSE) + ) + { + msg = "jpl_post_pvm_init(): failed to copy actual init args"; + goto err; + } + for ( i=0 ; iNewStringUTF(env,argv[i]); + if ( to == NULL ) + { + msg = "jpl_post_pvm_init(): failed to convert actual PL init arg to String"; + goto err; + } + (*env)->SetObjectArrayElement(env,pvm_aia,i,to); + } + + if ( create_pool_engines() != 0 ) + { + msg = "jpl_post_pvm_init(): failed to create Prolog engine pool"; + goto err; + } + + jpl_status = JPL_INIT_OK; + return TRUE; + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + jpl_status = JPL_INIT_PVM_FAILED; + return FALSE; + } + + +/* prerequisite: jpl_status != JPL_INIT_RAW */ +/* outcomes: */ +/* PVM is not (already) initialised -> FALSE */ +/* PVM is (already) initialised -> TRUE */ +/* error setting up post-PVM-init JPL state -> exception */ +static bool +jpl_test_pvm_init( + JNIEnv *env + ) + { + char *msg; + int argc; + char **argv; + /* jobject ta; */ + /* int i; */ + + if ( jpl_status == JPL_INIT_RAW ) + { + msg = "jpl_test_pvm_init(): called while jpl_status == JPL_INIT_RAW"; + goto err; + } + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl_test_pvm_init(): initialisation has already failed"; + goto err; + } + + if ( jpl_status == JPL_INIT_OK ) + { + return TRUE; + } + + if ( jpl_status == JPL_INIT_PVM_MAYBE ) + { + /* we test this each time (if not already initialised) in case other foreign code inits the PVM: */ + if ( !PL_is_initialised(&argc,&argv) ) /* PVM not ready? */ + { + /* jpl_status remains = JPL_INIT_PVM_MAYBE */ + DEBUG(1, Sdprintf( "[pl_test_pvm_init(): PL is not yet initialised: returning FALSE]\n")); + return FALSE; /* already-active Prolog VM not found (NB not an exceptional condition) */ + } + else + { + DEBUG(1, Sdprintf( "[pl_test_pvm_init(): PL is already initialised: proceeding to jpl_post_pvm_init()]\n")); + return jpl_post_pvm_init(env,argc,argv); /* TRUE, FALSE or exception */ + } + } + + msg = "jpl_test_pvm_init(): unknown jpl_status value"; + goto err; + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + jpl_status = JPL_INIT_PVM_FAILED; + return FALSE; + } + + +/* prerequisite: */ +/* jpl_status == JPL_INIT_PVM_MAYBE */ +/* outcomes: */ +/* successful PVM initialisation and subsequent JPL state setup -> TRUE */ +/* any error -> exception */ +static bool +jpl_do_pvm_init( + JNIEnv *env + ) + { + char *msg; + int argc; + char **argv; + int i; + jstring arg; + char *cp; + + /* redundant prerequisites check: */ + if ( jpl_status != JPL_INIT_PVM_MAYBE ) + { + msg = "jpl_do_pvm_init(): called while jpl_status != JPL_INIT_PVM_MAYBE"; + goto err; + } + + /* copy current default init args into suitable form for PL_initialise(): */ + if ( pvm_dia == NULL ) + { + msg = "jpl_do_pvm_init(): pvm_dia == NULL"; + goto err; + } + argc = (*env)->GetArrayLength(env,pvm_dia); + if ( argc <= 0 ) + { + msg = "jpl_do_pvm_init(): there are fewer than 1 default init args"; + goto err; + } + if ( (argv=(char**)malloc((argc+1)*sizeof(char*))) == NULL ) + { + msg = "jpl_do_pvm_init(): malloc() failed for argv"; + goto err; + } + for ( i=0 ; iGetObjectArrayElement(env,pvm_dia,i); + cp = (char*)(*env)->GetStringUTFChars(env,arg,0); + argv[i] = (char*)malloc(strlen(cp)+1); + strcpy( argv[i], cp); + DEBUG(1, Sdprintf( " argv[%d] = %s\n", i, argv[i])); + (*env)->ReleaseStringUTFChars( env, arg, cp); + } + DEBUG(1, Sdprintf( " argv[%d] = NULL\n", argc)); + argv[argc] = NULL; + if ( !PL_initialise(argc,(char**)argv) ) /* NB not (const char**) */ + { + msg = "jpl_do_pvm_init(): PL_initialise() failed"; + goto err; + } + /* *don't* free argv (must exist for lifetime of Prolog VM) */ + + return jpl_post_pvm_init(env,argc,argv); /* TRUE, FALSE or exception */ + +err: + jpl_status = JPL_INIT_PVM_FAILED; + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +static bool + jpl_ensure_jpl_init_1( + JNIEnv *env + ) + { + bool r; + + pthread_mutex_lock( &jvm_init_mutex); + r = jpl_do_jpl_init(env); + pthread_mutex_unlock( &jvm_init_mutex); + return r; + } + + +static bool + jpl_ensure_pvm_init_1( + JNIEnv *env + ) + { + bool r; + + pthread_mutex_lock( &pvm_init_mutex); + if ( !jpl_ensure_jpl_init(env) ) + return FALSE; + r = jpl_test_pvm_init(env) || jpl_do_pvm_init(env); + pthread_mutex_unlock( &pvm_init_mutex); + return r; + } + + +/*=== initialisation-related native Java methods of jpl.fli.Prolog ================================= */ + +/* + * Class: jpl_fli_Prolog + * Method: get_default_init_args + * Signature: ()[Ljava/lang/String; + */ +/* if not yet init then return default init args as String[] */ +/* if already init then return NULL */ +/* if already failed to init then throw an exception */ +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1default_1init_1args( + JNIEnv *env, + jclass jProlog + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init(env) ) /* lazily do "local" initialisations iff necessary */ + return FALSE; + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.set_default_init_args(): initialisation has already failed"; + goto err; + } + + return ( jpl_test_pvm_init(env) /* if Prolog VM is initialised */ + ? NULL /* then default init args are no longer defined */ + : pvm_dia /* else here they are */ + ) + ; +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: set_default_init_args + * Signature: ([Ljava/lang/String;)Z + */ +/* if the given jargs are null then throw an exception */ +/* if already failed to init then throw an exception */ +/* if not yet init then set default init args from jargs and return TRUE */ +/* if already init then return FALSE */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_set_1default_1init_1args( + JNIEnv *env, + jclass jProlog, + jobject jargs /* oughta be proper array, perhaps zero-length */ + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init(env) ) /* lazily do "local" initialisations iff necessary */ + return FALSE; + + if ( jargs == NULL ) /* improper call */ + { + msg = "jpl.fli.Prolog.set_default_init_args() called with NULL arg"; + goto err; + } + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.set_default_init_args(): initialisation has already failed"; + goto err; + } + + if ( jpl_test_pvm_init(env) ) /* if Prolog VM is initialised */ + { + return FALSE; /* unable to set default init args (too late: PVM is already initialised) */ + } + else + { + pvm_dia = NULL; /* probably oughta delete (global) (?) ref of former args... */ + pvm_dia = (*env)->NewGlobalRef(env,jargs); + return TRUE; /* OK: default init args set to those provided */ + } + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_actual_init_args + * Signature: ()[Ljava/lang/String; + */ +/* if not yet init then return null */ +/* if already init then return actual init args as String[] */ +/* if already failed to init then throw an exception */ +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1actual_1init_1args( + JNIEnv *env, + jclass jProlog + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init( env) ) /* lazily do "local" initialisations iff necessary */ + return NULL; + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.get_actual_init_args(): initialisation has already failed"; + goto err; + } + + return ( jpl_test_pvm_init(env) /* check PL_initialise() and update local state as appropriate */ + ? pvm_aia /* here they are */ + : NULL /* PVM not (yet) initialised */ + ); + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return NULL; + } + + +/* + * Class: jpl_fli_Prolog + * Method: initialise + * Signature: ()Z + */ +/* if already init then return FALSE */ +/* if already failed to init then throw an exception */ +/* else attempt to init and if success then return TRUE else throw an exception */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_initialise( + JNIEnv *env, + jclass jProlog + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init( env) ) /* lazily do "local" initialisations iff necessary */ + return FALSE; + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.initialise(): initialisation has already failed"; + goto err; + } + + if ( jpl_test_pvm_init(env) ) + { + return FALSE; /* PVM is already initialised */ + } + else + { + jpl_do_pvm_init( env); + return jpl_test_pvm_init(env); + } + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: halt + * Signature: (I)V + */ +JNIEXPORT void JNICALL +Java_jpl_fli_Prolog_halt( + JNIEnv *env, + jclass jProlog, + jint jstatus + ) + { + + (void)jpl_ensure_pvm_init(env); + PL_halt( (int)jstatus); + } + + +/*=== JPL utility functions ======================================================================== */ + +/*----------------------------------------------------------------------- + * getLongValue + * + * Retrieves the value in a jpl.fli.LongHolder (or subclass) instance + * + * @param env Java environment + * @param jlong_holder the LongHolder class instance, or null + * @param lv address to write the retrieved (long) value + * @return success? (the LongHolder was not null) + *---------------------------------------------------------------------*/ +static bool +getLongValue( + JNIEnv *env, + jobject jlong_holder, + jlong *lv + ) + { + + if ( jlong_holder == NULL ) + { + *lv = 0L; + return FALSE; + } + else /* Java compilation ensures it's a jpl.fli.LongHolder instance */ + { + *lv = (*env)->GetLongField(env,jlong_holder,jLongHolderValue_f); + return TRUE; + } + } + + +static bool +getUIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + uintptr_t *iv + ) + { jlong lv; /* Java long is 64 bits */ + + *iv = 0; + if ( getLongValue(env, jlong_holder, &lv) ) + { +#if SIZEOF_VOIDP == 4 + if ( lv >= 0xffffffffLL ) + return FALSE; /* What to do? */ +#endif + *iv = (uintptr_t)lv; + return TRUE; + } + else + { + return FALSE; + } + } + + +static bool +getIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + intptr_t *iv + ) + { jlong lv; /* Java long is 64 bits */ + + *iv = 0; + if ( getLongValue(env, jlong_holder, &lv) ) + { +#if SIZEOF_VOIDP == 4 + if ( lv >= 0xffffffffLL ) + return FALSE; /* What to do? */ +#endif + *iv = (uintptr_t)lv; + return TRUE; + } + else + { + return FALSE; + } + } + +static inline bool +getAtomTValue( + JNIEnv *env, + jobject jlong_holder, + atom_t *iv + ) { + return getUIntPtrValue( env, jlong_holder, iv); +} + + +static inline bool +getFunctorTValue( + JNIEnv *env, + jobject jlong_holder, + functor_t *iv + ) { + return getUIntPtrValue( env, jlong_holder, iv); +} + + +static inline bool +getTermTValue( + JNIEnv *env, + jobject jlong_holder, + term_t *iv + ) { +#if __YAP_PROLOG__ + return getIntPtrValue( env, jlong_holder, iv); +#else + return getUIntPtrValue( env, jlong_holder, iv); +#endif +} + + +/*----------------------------------------------------------------------- + * getPointerValue + * + * Retrieves the value in a jpl.fli.PointerHolder instance + * + * @param env Java environment + * @param jpointer_holder the PointerHolder class instance, or null + * @param pv address to write the retrieved (pointer) value + * @return success? (the PointerHolder was not null) + *---------------------------------------------------------------------*/ +static bool +getPointerValue( /* sets pv to jpointer_holder's .value_ (and succeeds), else sets it to NULL (and fails) */ + JNIEnv *env, + jobject jpointer_holder, + pointer *pv + ) + { + + if ( jpointer_holder == NULL ) + { + *pv = (pointer)NULL; + return FALSE; + } + else /* Java compilation ensures it's a jpl.fli.PointerHolder instance */ + { + *pv = (pointer)(*env)->GetLongField(env,jpointer_holder,jPointerHolderValue_f); + return TRUE; + } + } + + +/*----------------------------------------------------------------------- + * setPointerValue + * + * Sets the value in a jpl.fli.Pointer class instance (unless it's null) + * to the supplied value (maybe 0L) + * + * @param env Java environment + * @param jpointer_holder the PointerHolder class instance, or null + * @param pv the new (pointer) value + *---------------------------------------------------------------------*/ +static bool +setPointerValue( + JNIEnv *env, + jobject jpointer_holder, + pointer pv + ) + { + + return jpointer_holder != NULL + && ( (*env)->SetLongField(env,jpointer_holder,jPointerHolderValue_f,(long)pv), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * setIntValue + * + * Sets the value in a Java IntHolder class instance (unless it's null) + * to the supplied value + * + * @param env Java environment + * @param jint_holder the IntHolder class instance, or null + * @param iv the new (int) value + *---------------------------------------------------------------------*/ +static bool +setIntValue( + JNIEnv *env, + jobject jint_holder, + jint iv + ) + { + + return jint_holder != NULL + && ( (*env)->SetIntField(env,jint_holder,jIntHolderValue_f,iv), + TRUE + ) + ; + } + + +#if 0 +/*----------------------------------------------------------------------- + * setInt64Value + * + * Sets the value in a Java Int64Holder class instance (unless it's null) + * to the supplied value + * + * @param env Java environment + * @param jint64_holder the Int64Holder class instance, or null + * @param iv the new (int64_t) value + *---------------------------------------------------------------------*/ +static bool + setInt64Value( + JNIEnv *env, + jobject jint64_holder, + int64_t i64v + ) + { + + return jint64_holder != NULL + && ( (*env)->SetLongField(env,jint64_holder,jInt64HolderValue_f,i64v), + TRUE + ) + ; + } +#endif + + +/*----------------------------------------------------------------------- + * setLongValue + * + * Sets the value in a Java LongHolder class instance (unless it's null) + * to the supplied Java long value + * + * @param env Java environment + * @param jlong_holder the LongHolder class instance, or null + * @param lv the new (Java long) value + *---------------------------------------------------------------------*/ +static bool +setLongValue( + JNIEnv *env, + jobject jlong_holder, + jlong lv + ) + { + + return jlong_holder != NULL + && ( (*env)->SetLongField(env,jlong_holder,jLongHolderValue_f,lv), + TRUE + ) + ; + } + + +static bool +setUIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + uintptr_t iv + ) + { jlong lv; + +#if SIZEOF_VOIDP == 4 + uint64_t i64 = iv; /* unsigned 32->64 */ + lv = (jlong)i64; +#else + lv = iv; +#endif + + return setLongValue(env, jlong_holder, lv); + } + +static bool +setIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + intptr_t iv + ) + { jlong lv; + +#if SIZEOF_VOIDP == 4 + int64_t i64 = iv; /* signed 32->64 */ + lv = (jlong)i64; +#else + lv = iv; +#endif + + return setLongValue(env, jlong_holder, lv); + } + + +static inline bool +setTermTValue( + JNIEnv *env, + jobject jlong_holder, + term_t iv + ) { +#if __YAP_PROLOG__ + return setIntPtrValue( env, jlong_holder, iv); +#else + return setUIntPtrValue( env, jlong_holder, iv); +#endif +} + +/*----------------------------------------------------------------------- + * setDoubleValue + * + * Sets the value in a Java DoubleHolder class instance (unless it's null) + * to the supplied value + * + * @param env Java environment + * @param jdouble_holder the DoubleHolder class instance, or null + * @param dv the new (double) value + *---------------------------------------------------------------------*/ +static bool +setDoubleValue( + JNIEnv *env, + jobject jdouble_holder, + jdouble dv + ) + { + + return jdouble_holder != NULL + && ( (*env)->SetDoubleField(env,jdouble_holder,jDoubleHolderValue_f,dv), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * setStringValue + * + * Sets the value in a Java StringHolder class instance (unless it's null) + * to the supplied value (maybe null) + * + * @param env Java environment + * @param jstring_holder the StringHolder class instance, or null + * @param sv the new (jstring) value + *---------------------------------------------------------------------*/ +static bool +setStringValue( + JNIEnv *env, + jobject jstring_holder, + jstring sv + ) + { + + return jstring_holder != NULL + && ( (*env)->SetObjectField(env,jstring_holder,jStringHolderValue_f,sv), + TRUE + ) + ; + } + + +#if 0 +/*----------------------------------------------------------------------- + * setObjectValue + * + * Sets the value in a Java ObjectHolder class instance (unless it's null) + * to the supplied value (maybe null) + * + * @param env Java environment + * @param jobject_holder the ObjectHolder class instance, or null + * @param ref the new (jobject) value + *---------------------------------------------------------------------*/ +static bool +setObjectValue( + JNIEnv *env, + jobject jobject_holder, + jobject ref + ) + { + + return jobject_holder != NULL + && ( (*env)->SetObjectField(env,jobject_holder,jObjectHolderValue_f,ref), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * setBooleanValue + * + * Sets the .value field of a Java BooleanHolder class instance (unless it's null) + * to the supplied jboolean value + * + * @param env Java environment + * @param jboolean_holder the BooleanHolder class instance, or null + * @param jb the new (jboolean) value + *---------------------------------------------------------------------*/ +static bool +setBooleanValue( + JNIEnv *env, + jobject jboolean_holder, + jboolean jb + ) + { + + return jboolean_holder != NULL + && ( (*env)->SetBooleanField(env,jboolean_holder,jBooleanHolderValue_f,jb), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * updateAtomValue + * + * Updates the value in a Java atom_t class instance (unless it's null) + * to the supplied value (maybe 0L); unregisters and registers old and new + * atom references as appropriate. NB atom_t extends LongHolder. + * + * @param env Java environment + * @param jatom_holder the atom_t class instance, or null + * @param atom2 the new atom reference + *---------------------------------------------------------------------*/ +static bool +updateAtomValue( + JNIEnv *env, + jobject jatom_holder, + atom_t atom2 /* new value (perhaps 0L (?)) */ + ) + { + atom_t atom1; /* old value (perhaps 0L (?)) */ + + if ( jatom_holder == NULL ) + { + return FALSE; + } + else + { + atom1 = (atom_t)(*env)->GetLongField(env,jatom_holder,jLongHolderValue_f); + if ( atom1 != 0L ) + { + PL_unregister_atom( atom1); + } + (*env)->SetLongField(env,jatom_holder,jLongHolderValue_f,(long)atom2); + if ( atom2 != 0L ) + { + PL_register_atom( atom2); + } + return TRUE; + } + } +#endif + +/*=== Java-wrapped SWI-Prolog FLI functions ======================================================== */ + +static int current_pool_engine_handle(PL_engine_t *e); +static int current_pool_engine(void); + + +/* + * Class: jpl_fli_Prolog + * Method: action_abort + * Signature: ()I + */ +JNIEXPORT int JNICALL + Java_jpl_fli_Prolog_action_1abort( + JNIEnv *env, + jclass jProlog + ) + { + + if ( jpl_ensure_pvm_init(env) ) + { + return PL_action(PL_ACTION_ABORT); + } + else + { + return -2; /* oughta throw exception? */ + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: atom_chars + * Signature: (Ljpl/fli/atom_t;)Ljava/lang/String; + */ +JNIEXPORT jstring JNICALL /* the local ref goes out of scope, */ + Java_jpl_fli_Prolog_atom_1chars( /* but the string itself doesn't */ + JNIEnv *env, + jclass jProlog, + jobject jatom + ) + { + atom_t atom; + jstring lref; + + return ( jpl_ensure_pvm_init(env) + && getAtomTValue(env,jatom,&atom) /* checks jatom != null */ + && jni_atom_to_String(env,atom,&lref) + ? lref + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: attach_engine + * Signature: (Ljpl/fli/engine_t;)I + */ +JNIEXPORT int JNICALL + Java_jpl_fli_Prolog_attach_1engine( + JNIEnv *env, + jclass jProlog, + jobject jengine + ) + { + PL_engine_t engine; + int rc; + + if ( !jpl_ensure_pvm_init(env) ) + { + return -2; /* libpl could not be initialised (oughta throw exception) */ + } + + rc = current_pool_engine_handle(&engine); + DEBUG(0, Sdprintf( "attach_engine(): current_engine=%p, thread_self=%d, pool_id=%d\n", engine, PL_thread_self(), rc)); + + if ( !getPointerValue(env,jengine,(pointer*)&engine) ) /* checks jengine isn't null */ + { + return -3; /* null engine holder */ + } + + DEBUG(0, Sdprintf( "attach_engine(): new_engine=%p\n", engine)); + + if ( (rc=PL_set_engine(engine,NULL)) == PL_ENGINE_SET ) + { + return 0; /* OK */ + } + else + { + return -1; /* bad engine status: oughta throw exception */ + } + + } + + +/* + * Class: jpl_fli_Prolog + * Method: close_query + * Signature: (Ljpl/fli/qid_t;)V + */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_close_1query( + JNIEnv *env, + jclass jProlog, + jobject jqid + ) + { + qid_t qid; + + DEBUG(1, Sdprintf( ">close_query(env=%lu,jProlog=%lu,jquid=%lu)...\n", (long)env, (long)jProlog, (long)jqid)); + if ( jpl_ensure_pvm_init(env) + && getUIntPtrValue(env,jqid,(uintptr_t *)&qid) /* checks that jqid != NULL */ + ) + { + PL_close_query( qid); /* void */ + DEBUG(1, Sdprintf( " ok: PL_close_query(%lu)\n", (long)qid)); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: compare + * Signature: (Ljpl/fli/term_t;Ljpl/fli/term_t;)I + */ +JNIEXPORT jint JNICALL /* returns -1, 0 or 1 (or -2 for error) */ + Java_jpl_fli_Prolog_compare( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ) + { + term_t term1; + term_t term2; + + DEBUG(1, Sdprintf( ">compare(term1=%lu,term2=%lu)\n", (long)jterm1, (long)jterm2)); + if ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm1,&term1) /* checks jterm1 isn't null */ + && getTermTValue(env,jterm2,&term2) /* checks jterm2 isn't null */ + ) + { + DEBUG(1, Sdprintf( "> PL_compare( %lu, %lu)", term1, term2)); + return PL_compare(term1,term2); /* returns -1, 0 or 1 */ + } + else + { + return -2; /* oughta throw an exception... */ + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: cons_functor_v + * Signature: (Ljpl/fli/term_t;Ljpl/fli/functor_t;Ljpl/fli/term_t;)V + */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_cons_1functor_1v( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jfunctor, + jobject jterm0 + ) + { + term_t term; + functor_t functor; + term_t term0; + + if ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm,&term) /* checks that jterm isn't null */ + && getFunctorTValue(env,jfunctor,&functor) /* checks that jfunctor isn't null */ + && getTermTValue(env,jterm0,&term0) /* checks that jterm0 isn't null */ + ) + { + return PL_cons_functor_v( term, functor, term0); + } + return TRUE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: copy_term_ref + * Signature: (Ljpl/fli/term_t;)Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_copy_1term_1ref( + JNIEnv *env, + jclass jProlog, + jobject jfrom + ) + { + jobject rval; + term_t term; + term_t term2; + + return ( jpl_ensure_pvm_init(env) + /* && jfrom != NULL // redundant: getLongValue checks this */ + && getTermTValue(env,jfrom,&term) /* SWI RM implies must be non-null */ + && (rval=(*env)->AllocObject(env,jTermT_c)) != NULL + && ( (term2=PL_copy_term_ref(term)) , TRUE ) /* SWI RM -> always succeeds */ + && setTermTValue(env,rval,term2) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: current_engine + * Signature: ()Ljpl/fli/engine_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_current_1engine( + JNIEnv *env, + jclass jProlog + ) + { + PL_engine_t engine; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && PL_thread_self() != -1 + && ( current_pool_engine_handle(&engine) , TRUE ) + && (rval=(*env)->AllocObject(env,jEngineT_c)) != NULL + && setPointerValue(env,rval,(pointer)engine) + ? rval + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: current_engine_is_pool + * Signature: ()Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_current_1engine_1is_1pool( + JNIEnv *env, + jclass jProlog + ) + { + + if ( jpl_ensure_pvm_init(env) ) + { + return current_pool_engine() >= 0; + } + else + { + return FALSE; /* libpl could not be initialised: oughta throw exception */ + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: exception + * Signature: (Ljpl/fli/qid_t;)Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_exception( + JNIEnv *env, + jclass jProlog, + jobject jqid + ) + { + qid_t qid; + term_t term; + jobject term_t; /* return value */ + + DEBUG(1, Sdprintf( ">exception(jqid=%lu)\n", (long)jqid)); + return ( jpl_ensure_pvm_init(env) + && ( DEBUG(1, Sdprintf( " ok: jpl_ensure_pvm_init(env)\n")), TRUE ) + /* && jqid != NULL // redundant */ + && ( DEBUG(1, Sdprintf( " ok: jqid != NULL\n")), TRUE ) + && getUIntPtrValue(env,jqid,(uintptr_t *)&qid) /* checks that jqid isn't null */ + && ( DEBUG(1, Sdprintf( " ok: getUIntPtrValue(env,jqid,&qid)\n")), TRUE ) + && ( (term=PL_exception(qid)) , TRUE ) /* we'll build a term_t object regardless */ + && ( DEBUG(1, Sdprintf(" ok: ( (term=PL_exception(qid)), TRUE)\n")), TRUE ) + && (term_t=(*env)->AllocObject(env,jTermT_c)) != NULL + && ( DEBUG(1, Sdprintf( " ok: (term_t=(*env)->AllocObject(env,jTermT_c)) != NULL\n")), TRUE ) + && setTermTValue(env,term_t,term) + && ( DEBUG(1, Sdprintf( " ok: setTermTValue(env,term_t,term)\n")), TRUE ) + ? ( + DEBUG(1, Sdprintf(" =%lu\n",(long)term_t)), + term_t + ) + : NULL /* oughta diagnose failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_arg + * Signature: (ILjpl/fli/term_t;Ljpl/fli/term_t;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1arg( + JNIEnv *env, + jclass jProlog, + jint jindex, + jobject jterm, + jobject jarg + ) + { + term_t term; + term_t arg; + + return jpl_ensure_pvm_init(env) + && jarg != NULL /* don't proceed if this holder is null */ + && getTermTValue(env,jterm,&term) /* checks that jterm isn't null */ + && ( arg=PL_new_term_ref() , TRUE ) /* Fred used jarg's original term ref (?) */ + && PL_get_arg(jindex,term,arg) + && setUIntPtrValue(env,jarg,arg) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_atom_chars + * Signature: (Ljpl/fli/term_t;Ljpl/fli/StringHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1atom_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ) + { + term_t term; + atom_t a; + jstring string; + + return jpl_ensure_pvm_init(env) + && jstring_holder != NULL /* don't call PL_get_atom_chars if this is null */ + && getTermTValue(env,jterm,&term) /* confirms that jterm != NULL */ + && PL_get_atom(term,&a) /* confirms that term is an atom */ + && jni_atom_to_String(env,a,&string) /* Unicode-aware */ + && setStringValue(env,jstring_holder,string) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_c_lib_version + * Signature: ()Ljava/lang/String; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_get_1c_1lib_1version( + JNIEnv *env, + jclass jProlog + ) + { + + return (*env)->NewStringUTF(env,JPL_C_LIB_VERSION); /* JPL_C_LIB_VERSION is always Latin-1 */ + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_float + * Signature: (Ljpl/fli/term_t;Ljpl/fli/DoubleHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1float( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jdouble_holder + ) + { + term_t term; + double d; + + return jpl_ensure_pvm_init(env) + && jdouble_holder != NULL + && getTermTValue(env,jterm,&term) /* confirms that jterm isn't null */ + && PL_get_float(term,&d) + && setDoubleValue(env,jdouble_holder,d) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_integer + * Signature: (Ljpl/fli/term_t;Ljpl/fli/Int64Holder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1integer( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jint64_holder + ) + { + term_t term; + int64_t i64; + + return jpl_ensure_pvm_init(env) + && jint64_holder != NULL + && getTermTValue(env,jterm,&term) /* confirms that jterm isn't null */ + && PL_get_int64(term,&i64) + && setLongValue(env,jint64_holder,i64) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_name_arity + * Signature: (Ljpl/fli/term_t;Ljpl/fli/StringHolder;Ljpl/fli/IntHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1name_1arity( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jname_holder, /* we trust this is a StringHolder */ + jobject jarity_holder /* we trust this is an IntHolder */ + ) + { + term_t term; + atom_t atom; + jstring jname; + int arity; + + return jpl_ensure_pvm_init(env) + && jname_holder != NULL /* don't proceed if this holder is null */ + && jarity_holder != NULL /* don't proceed if this holder is null */ + && getTermTValue(env,jterm,&term) /* confirms that jterm isn't null */ + && PL_get_name_arity(term,&atom,&arity) /* proceed to register transient atom ref */ + && jni_atom_to_String(env,atom,&jname) /* Unicode-aware */ + && setStringValue(env,jname_holder,jname) /* stash String ref in holder */ + && setIntValue(env,jarity_holder,arity) /* stash arity value in holder */ + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_string_chars + * Signature: (Ljpl/fli/term_t;Ljpl/fli/StringHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1string_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ) + { + term_t term; + jstring string; + + return jpl_ensure_pvm_init(env) + && jstring_holder != NULL + && getTermTValue(env,jterm,&term) /* checks that jterm != NULL */ + && jni_string_to_String(env,term,&string) /* */ + && setStringValue(env,jstring_holder,string) /* ...when sent straight back to JVM */ + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_atom + * Signature: (Ljava/lang/String;)Ljpl/fli/atom_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1atom( + JNIEnv *env, + jclass jProlog, + jstring jname + ) + { + atom_t atom; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && jname != NULL + && jni_String_to_atom(env,jname,&atom) + && (rval=(*env)->AllocObject(env,jAtomT_c)) != NULL /* doesn't call any constructor */ + && setUIntPtrValue(env,rval,atom) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_functor + * Signature: (Ljpl/fli/atom_t;I)Ljpl/fli/functor_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1functor( + JNIEnv *env, + jclass jProlog, + jobject jatom, /* read-only */ + jint jarity + ) + { + term_t atom; + functor_t functor; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && jarity >= 0 + && getTermTValue(env,jatom,&atom) /* checks jatom isn't null */ + && (rval=(*env)->AllocObject(env,jFunctorT_c)) != NULL + && (functor=PL_new_functor(atom,(int)jarity)) != 0L + && setUIntPtrValue(env,rval,functor) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_module + * Signature: (Ljpl/fli/atom_t;)Ljpl/fli/module_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1module( + JNIEnv *env, + jclass jProlog, + jobject jatom + ) + { + atom_t atom; + module_t module; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && getAtomTValue(env,jatom,&atom) /* checks that jatom isn't null */ + && ( (module=PL_new_module(atom)) , TRUE ) + && (rval=(*env)->AllocObject(env,jModuleT_c)) != NULL + && setPointerValue(env,rval,(pointer)module) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_term_ref + * Signature: ()Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1ref( + JNIEnv *env, + jclass jProlog + ) + { + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && (rval=(*env)->AllocObject(env,jTermT_c)) != NULL + && setUIntPtrValue(env,rval,PL_new_term_ref()) + ? rval + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_term_refs + * Signature: (I)Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1refs( + JNIEnv *env, + jclass jProlog, + jint jn + ) + { + jobject rval; + term_t trefs; + + DEBUG(1, Sdprintf( ">new_term_refs(env=%lu,jProlog=%lu,jn=%lu)...\n", (long)env, (long)jProlog, (long)jn)); + + return ( jpl_ensure_pvm_init(env) + && jn >= 0 /* I hope PL_new_term_refs(0) is defined [ISSUE] */ + && (rval=(*env)->AllocObject(env,jTermT_c)) != NULL + && ( trefs=PL_new_term_refs((int)jn), TRUE ) + && setUIntPtrValue(env,rval,trefs) + && ( DEBUG(1, Sdprintf(" ok: stashed trefs=%ld into new term_t object\n",(long)trefs)), TRUE ) + ? rval + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: next_solution + * Signature: (Ljpl/fli/qid_t;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_next_1solution( + JNIEnv *env, + jclass jProlog, + jobject jqid /* read */ + ) + { + qid_t qid; + int rval; /* for boolean return value */ + + DEBUG(1, Sdprintf( ">next_solution(env=%lu,jProlog=%lu,jqid=%lu)...\n", (long)env, (long)jProlog, (long)jqid)); + return jpl_ensure_pvm_init(env) + && getUIntPtrValue(env,jqid,(uintptr_t *)&qid) /* checks that jqid isn't null */ + && ( DEBUG(1, Sdprintf( " ok: getUIntPtrValue(env,jqid,&qid(%lu))\n",(long)qid)), TRUE ) + && ( rval=PL_next_solution(qid), TRUE ) /* can call this until it returns FALSE */ + && ( DEBUG(1, Sdprintf( " ok: PL_next_solution(qid=%lu)=%u\n",(long)qid,rval)), TRUE ) + && ( + DEBUG(1, Sdprintf(" =%lu\n",(long)rval)), + rval + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: object_to_tag + * Signature: (Ljava/lang/Object;)Ljava/lang/String; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_object_1to_1tag( + JNIEnv *env, + jclass jProlog, + jobject jobj + ) + { + intptr_t iref; + char abuf[23]; + + /* empirically, unless the two 'ensure' macros are called in this order, */ + /* will crash if this is the first native method called */ + + /* Sdprintf("entered object_to_tag...\n"); */ + + if ( !jpl_ensure_pvm_init(env) ) { + /* Sdprintf("jpl_ensure_pvm_init() failed\n"); */ + return NULL; + } + /* Sdprintf("jpl_ensure_pvm_init() ok\n"); */ + + if ( !jni_ensure_jvm() ) { + /* Sdprintf("jni_ensure_jvm() failed\n"); */ + return NULL; + } + /* Sdprintf("jni_ensure_jvm() ok\n"); */ + + if ( jobj!=NULL && jni_object_to_iref(env,jobj,&iref) ) { + /* Sdprintf("jni_object_to_iref() done\n"); */ + sprintf( abuf, IREF_FMT, (IREF_INTTYPE)iref); /* oughta encapsulate this mapping... */ + /* Sdprintf("sprintf() done\n"); */ + return (*env)->NewStringUTF(env,abuf); /* a tag is always Latin-1 */ + } else { + return NULL; + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: open_query + * Signature: (Ljpl/fli/module_t;ILjpl/fli/predicate_t;Ljpl/fli/term_t;)Ljpl/fli/qid_t; + */ +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_open_1query( + JNIEnv *env, + jclass jProlog, + jobject jmodule, /* read */ + jint jflags, /* read */ + jobject jpredicate, /* read */ + jobject jterm0 /* read */ + ) + { + module_t module; + predicate_t predicate; + term_t term0; + qid_t qid; + jobject jqid; /* for returned new QidT object */ + + DEBUG(1, Sdprintf( ">open_query(env=%lu,jProlog=%lu,jmodule=%lu,jflags=%lu,jpredicate=%lu,jterm0=%lu)...\n", + (long)env, (long)jProlog, (long)jmodule, (long)jflags, (long)jpredicate, (long)jterm0)); + return ( jpl_ensure_pvm_init(env) + && ( getPointerValue(env,jmodule,(pointer*)&module) , TRUE ) /* NULL module is OK below... */ + && ( DEBUG(1, Sdprintf(" ok: getPointerValue(env,jmodule=%lu,&(pointer)module=%lu)\n",(long)jmodule,(long)module)), TRUE ) + && getPointerValue(env,jpredicate,(pointer*)&predicate) /* checks that jpredicate != NULL */ + && ( DEBUG(1, Sdprintf(" ok: getPointerValue(env,jpredicate=%lu,&(pointer)predicate=%lu)\n",(long)jpredicate,(long)predicate)), TRUE ) + && getTermTValue(env,jterm0,&term0) /* jterm0!=NULL */ + && ( (qid=PL_open_query(module,jflags,predicate,term0)) , TRUE ) /* NULL module is OK (?) [ISSUE] */ + && ( DEBUG(1, Sdprintf(" ok: PL_open_query(module=%lu,jflags=%u,predicate=%lu,term0=%lu)=%lu\n",(long)module,jflags,(long)predicate,(long)term0,(long)qid)), TRUE ) + && (jqid=(*env)->AllocObject(env,jQidT_c)) != NULL + && ( DEBUG(1, Sdprintf(" ok: AllocObject(env,jQidT_c)=%lu\n",(long)jqid)), TRUE ) + && setUIntPtrValue(env,jqid,(uintptr_t)qid) + && ( DEBUG(1, Sdprintf(" ok: setUIntPtrValue(env,%lu,%lu)\n",(long)jqid,(long)qid)), TRUE ) + && ( DEBUG(1, Sdprintf("[open_query module = %s]\n", (module==NULL?"(null)":PL_atom_chars(PL_module_name(module))))), TRUE ) + ? ( + DEBUG(1, Sdprintf(" =%lu\n",(long)jqid)), + jqid + ) + : NULL /* oughta diagnose failure? raise JPL exception? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: predicate + * Signature: (Ljava/lang/String;ILjava/lang/String;)Ljpl/fli/predicate_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_predicate( + JNIEnv *env, + jclass jProlog, + jstring jname, /* ought not be null */ + jint jarity, /* oughta be >= 0 */ + jstring jmodule /* may be null */ + ) + { + atom_t pname; /* the predicate's name, as an atom */ + atom_t mname; /* the predicate's module's name, as an atom */ + functor_t func; /* the predicate's functor */ + module_t mod; /* the predicate's module */ + predicate_t predicate; + jobject rval; + + DEBUG(1, Sdprintf(">predicate(env=%lu,jProlog=%lu,jname=%lu,jarity=%lu,jmodule=%lu)...\n", + (long)env, (long)jProlog, (long)jname, (long)jarity, (long)jmodule)); + return ( jpl_ensure_pvm_init(env) + && jni_String_to_atom(env,jname,&pname) /* checks that jname isn't NULL */ + && jarity >= 0 + && ( func=PL_new_functor(pname,jarity) , TRUE ) /* "cannot fail" */ + && ( jmodule != NULL + ? jni_String_to_atom(env,jmodule,&mname) /* checks that jmodule isn't NULL */ + : ( mname=(atom_t)NULL , TRUE ) + ) + && ( mod=PL_new_module(mname) , TRUE) + && ( predicate=PL_pred(func,mod) , TRUE ) + && (rval=(*env)->AllocObject(env,jPredicateT_c)) != NULL + && setPointerValue(env,rval,(pointer)predicate) + ? ( + DEBUG(1, Sdprintf("[predicate() module=%s\n",(jmodule==NULL?"(null)":PL_atom_chars(mname)))), + rval + ) + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: put_float + * Signature: (Ljpl/fli/term_t;D)V + */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1float(JNIEnv *env, + jclass jProlog, + jobject jterm, + jdouble jf) +{ term_t term; + + if ( jpl_ensure_pvm_init(env) && + getTermTValue(env,jterm,&term) ) + { return PL_put_float(term, jf); + } + + return FALSE; +} + + +/* + * Class: jpl_fli_Prolog + * Method: put_integer + * Signature: (Ljpl/fli/term_t;J)V + */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1integer(JNIEnv *env, + jclass jProlog, + jobject jterm, + jlong ji) +{ term_t term; + + if ( jpl_ensure_pvm_init(env) && + getTermTValue(env, jterm, &term) ) + { return PL_put_int64( term, ji); + } + + return FALSE; +} + + +/* + * Class: jpl_fli_Prolog + * Method: put_term + * Signature: (Ljpl/fli/term_t;Ljpl/fli/term_t;)V + */ +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1term( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ) + { + term_t term1; + term_t term2; + + if ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm1,&term1) /* checks that jterm1 isn't null */ + && getTermTValue(env,jterm2,&term2) /* checks that jterm2 isn't null */ + ) + { + PL_put_term( term1, term2); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: put_jref + * Signature: (Ljpl/fli/term_t;Ljava/lang/Object;)V + */ +/* added 29/1/2007 PS to support restored but now deprecated jpl.JRef for Rick Moynihan */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_put_1jref( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jref + ) + { + term_t term; + jobject j; // temp for JNI_jobject_to_term(+,-) + atom_t a; // " + intptr_t i; // " + + if ( jpl_ensure_pvm_init(env) + && jni_ensure_jvm() + && getTermTValue(env,jterm,&term) // checks that jterm isn't null + ) + { + JNI_jobject_to_term(jref,term); // assumes term is var; OK if jref == null + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: tag_to_object + * Signature: (Ljava/lang/String;)Ljava/lang/Object; + */ +/* added 29/5/2008 PS to support alternative to deprecated jpl.JRef */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_tag_1to_1object( + JNIEnv *env, + jclass jProlog, + jstring tag + ) + { + jobject jobj; + + if ( jni_ensure_jvm() + && (*env)->GetStringLength(env,tag) == 22 + ) + { + jni_tag_to_iref2((char*)(*env)->GetStringUTFChars(env,tag,0), (pointer *)&jobj); + return jobj; + } + return 0; + } + + +/* + * Class: jpl_fli_Prolog + * Method: is_tag + * Signature: (Ljava/lang/String;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_is_1tag( + JNIEnv *env, + jclass jProlog, + jstring tag + ) + { + jobject jobj; + + if ( jni_ensure_jvm() + && (*env)->GetStringLength(env,tag) == 22 + ) + { + jni_tag_to_iref2((char*)(*env)->GetStringUTFChars(env,tag,0), (pointer *)&jobj); + return jobj != 0; + } + + return 0; + } + + +/* + * Class: jpl_fli_Prolog + * Method: put_variable + * Signature: (Ljpl/fli/term_t;)V + */ +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1variable( + JNIEnv *env, + jclass jProlog, + jobject jterm + ) + { + term_t term; + + if ( jpl_ensure_pvm_init(env) /* may throw exception but cannot fail */ + && getTermTValue(env,jterm,&term) /* checks that jterm isn't null */ + ) + { + PL_put_variable(term); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: term_type + * Signature: (Ljpl/fli/term_t;)I + */ +JNIEXPORT jint JNICALL + Java_jpl_fli_Prolog_term_1type( + JNIEnv *env, + jclass jProlog, + jobject jterm + ) + { + term_t term; + + return ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm,&term) /* checks jterm isn't null */ + ? PL_term_type(term) + : -1 /* i.e. when jterm is null */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: unregister_atom + * Signature: (Ljpl/fli/atom_t;)V + */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_unregister_1atom( + JNIEnv *env, + jclass jProlog, + jobject jatom + ) + { + atom_t atom; + + DEBUG(1, Sdprintf( ">unregister_atom(env=%lu,jProlog=%lu,jatom=%lu)...\n", (long)env, (long)jProlog, (long)jatom)); + + if ( jpl_ensure_pvm_init(env) + && getAtomTValue(env,jatom,&atom) /* checks that jatom isn't null */ + ) + { + PL_unregister_atom( atom); /* void */ + DEBUG(1, Sdprintf( " ok: PL_unregister_atom(%lu)\n", (long)atom)); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: open_foreign_frame + * Signature: ()Ljpl/fli/fid_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_open_1foreign_1frame( + JNIEnv *env, + jclass jProlog + ) + { + jobject rval; + + if ( jpl_ensure_pvm_init(env) + && (rval=(*env)->AllocObject(env,jFidT_c)) != NULL // get a new fid_t object + && setUIntPtrValue(env,rval,PL_open_foreign_frame()) // open a frame only if alloc succeeds + ) + { + return rval; + } + else + { + return NULL; + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: discard_foreign_frame + * Signature: (Ljpl/fli/fid_t;)V + */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_discard_1foreign_1frame( + JNIEnv *env, + jclass jProlog, + jobject jfid + ) + { + fid_t fid; + + if ( jpl_ensure_pvm_init(env) + && getUIntPtrValue(env,jfid,&fid) // checks that jfid isn't null + ) + { + PL_discard_foreign_frame(fid); + } + } + + +/*=== JPL's Prolog engine pool and thread management =============================================== */ + +/* + * Class: jpl_fli_Prolog + * Method: thread_self + * Signature: ()I + */ +JNIEXPORT jint JNICALL +Java_jpl_fli_Prolog_thread_1self( + JNIEnv *env, + jclass jProlog + ) + { + + if ( jpl_ensure_pvm_init(env) ) + { + return PL_thread_self(); + } + else + { + return -2; + } + } + + +static int +create_pool_engines() + { + int i; + + DEBUG(1, Sdprintf( "JPL creating engine pool:\n")); + if ( (engines=malloc(sizeof(PL_engine_t)*JPL_MAX_POOL_ENGINES)) == NULL ) + { + return -1; /* malloc failed */ + } + engines_allocated = JPL_MAX_POOL_ENGINES; + memset(engines, 0, sizeof(PL_engine_t)*engines_allocated); + + DEBUG(1, Sdprintf( "JPL stashing default engine as [0]\n")); + PL_set_engine( PL_ENGINE_CURRENT, &engines[0]); + + DEBUG(1, Sdprintf( "JPL detaching default engine\n")); + /* PL_set_engine( NULL, NULL); */ + + for ( i=1 ; iAllocObject(env,jEngineT_c)) != NULL + && setPointerValue(env,rval,(pointer)engines[i]) + ? rval + : NULL + ); + } + if ( rc != PL_ENGINE_INUSE ) + { + DEBUG(1, Sdprintf( "JPL PL_set_engine fails with %d\n", rc)); + pthread_mutex_unlock( &engines_mutex); + return NULL; /* bad engine status: oughta throw exception */ + } + } + + for ( i=0 ; i 0 ) + { DEBUG(1, Sdprintf("JPL releasing engine[%d]=%p\n", i, e)); + PL_set_engine(NULL, NULL); + pthread_cond_signal(&engines_cond); /* alert waiters */ + } + return i; + } + else + { + return -2; + } + } + + +static foreign_t + jni_term_to_jref_plc( + term_t tref1, /* +term: AnyPrologTerm */ + term_t tref2 /* -term: JRef to a jpl.Term instance which represents that term */ + ) + { + jobject term1; + atom_t a; /* " */ + intptr_t i; /* " */ + jobject j; /* " */ + JNIEnv *env; + + return jni_ensure_jvm() /* untypically... */ + && jpl_ensure_pvm_init(env) /* ...this requires both inits */ + && (term1=(*env)->AllocObject(env,termt_class)) != NULL + && setUIntPtrValue(env,term1,tref1) /* requires jLongHolderValue_f to be initialised */ + && JNI_jobject_to_term((*env)->CallStaticObjectMethod(env,term_class,term_getTerm,term1),tref2) + && jni_check_exception(env); + } + + +/* serves jni_jref_to_term_plc() */ +static bool + jni_jobject_to_term_byval( + JNIEnv *env, + jobject jobj, /* this must be an instance of one of jpl.Term's subclasses */ + term_t term /* a Prolog term, as represented by jobj, is *put* into this term ref */ + ) + { + jobject termt; /* a temporary instance of jpl.fli.term_t (i.e. a "term holder") */ + + return /* jni_ensure_jvm() && jpl_ensure_pvm_init(env) && */ + (termt=(*env)->AllocObject(env,termt_class)) != NULL + && setUIntPtrValue(env,termt,term) /* requires jLongHolderValue_f to be initialised */ + && ( (*env)->CallStaticVoidMethod(env,term_class,term_putTerm,jobj,termt) , TRUE ) + && jni_check_exception(env) + ; + } + + +/* if the first arg is a jref i.e. @(Tag) which refers to a jpl.Term instance, */ +/* then the 2nd arg will be matched with a corresponding newly constructed term */ +static foreign_t + jni_jref_to_term_plc( + term_t jref, /* +term: JRef to a jpl.Term instance */ + term_t termIn /* -term: term as represented by the JRef */ + ) + { + functor_t fn; + term_t arg = PL_new_term_ref(); + atom_t a; + intptr_t iterm; + jobject jterm; + term_t term = PL_new_term_ref(); /* jni_jobject_to_term_byval() will *put* the constructed term in here */ + JNIEnv *env; + + return jni_ensure_jvm() /* untypically... */ + && jpl_ensure_pvm_init(env) /* ...this requires both inits */ + && PL_get_functor(jref,&fn) + && fn==JNI_functor_at_1 + && PL_get_arg(1,jref,arg) + && PL_get_atom(arg,&a) + && jni_tag_to_iref(a,&iterm) + && (jterm = (jobject)iterm) + && jni_jobject_to_term_byval(env,jterm,term) /* NB a bogus Tag could crash this... */ + && PL_unify( termIn, term) /* attempt to unify the 2nd arg with the newly constructed term */ + ; + } + + +static bool + jni_get_default_jvm_opts_1( + term_t args, + int i, + char **jvm_xia + ) + { + term_t tp = PL_new_term_ref(); + + if ( jvm_xia[i] == NULL ) + { + return PL_unify_nil(args); + } + else + { + return PL_unify_list(args,tp,args) + && PL_unify_term(tp, + PL_ATOM, PL_new_atom(jvm_xia[i]) + ) + && jni_get_default_jvm_opts_1(args,i+1,jvm_xia) + ; + } + } + + +static foreign_t + jni_get_jvm_opts( + term_t args, /* -list(atom): the current default JVM initialisation options */ + char **jvm_xia + ) + { + + if ( jvm_xia==NULL ) + { + return FALSE; + } + else + { + return jni_get_default_jvm_opts_1(args,0,jvm_xia); + } + } + + +static foreign_t + jni_set_default_jvm_opts_plc( + term_t tn, /* +integer: the qty of options */ + term_t args /* +list(atom): the current default JVM initialisation options */ + ) + { + int n; + int i; + term_t head; + term_t list; + char *s; + + if ( jvm_dia == NULL ) /* presumably, JVM is already started, so default options cannot now be set */ + { + return FALSE; + } + if ( !PL_get_integer(tn,&n) ) /* arg is not an integer (shouldn't happen: our code passes length of list */ + { + return FALSE; + } + if ( jvm_dia == jvm_ia ) /* jvm_dia still points to the built-in (non-malloc-ed) default default opts */ + { + DEBUG(1, Sdprintf("JPL not freeing original (static) JVM opts; replacing with malloc-ed [%d+1]\n", n)); + jvm_dia = (char**)malloc((n+1)*sizeof(char**)); + } + else + { + DEBUG(1, Sdprintf("JPL has malloc-ed JVM opt[?] (of malloc-ed strings)\n")); + for ( i = 0; jvm_dia[i] != NULL && i < 100; i++ ) /* a malloc-ed array always has NULL in its last element */ + { + DEBUG(1, Sdprintf("JPL freeing malloc-ed JVM opt '%s'\n", jvm_dia[i])); + free(jvm_dia[i]); /* a malloc-ed array's elements always point to malloc-ed strings, which we should free */ + } + if ( n != i ) /* we need an array of a different length */ + { + DEBUG(1, Sdprintf("JPL needs different qty JVM opts so freeing old [%d] and malloc-ing new [%d]\n", i, n)); + free(jvm_dia); + jvm_dia = (char**)malloc((n+1)*sizeof(char**)); + } + else + { + DEBUG(1, Sdprintf("JPL needs [%d] JVM opts as before\n", n)); + } + } + head = PL_new_term_ref(); /* variable for the elements */ + list = PL_copy_term_ref(args); /* copy as we need to write */ + for ( i = 0; PL_get_list(list,head,list); i++ ) + { + if ( PL_get_atom_chars(head,&s) ) + { + DEBUG(1, Sdprintf("JPL malloc-ing space for '%s'\n", s)); + jvm_dia[i] = (char*)malloc(strlen(s)+1); + strcpy(jvm_dia[i],s); + } + else + { + return FALSE; + } + } + jvm_dia[i] = NULL; /* stash a sentinel */ + return PL_get_nil(list); /* succeed iff list is proper */ + } + + +static foreign_t + jni_get_default_jvm_opts_plc( + term_t args /* -list(atom): the current default JVM initialisation options */ + ) + { + + return jni_get_jvm_opts(args,jvm_dia); + } + + +static foreign_t + jni_get_actual_jvm_opts_plc( + term_t args /* -list(atom): the actual JVM initialisation options */ + ) + { + + return jni_get_jvm_opts(args,jvm_aia); + } + + +/*=== FLI metadata ================================================================================= */ + +static + PL_extension predspecs[] = + { { "jni_get_created_jvm_count", 1, jni_get_created_jvm_count_plc, 0 }, + { "jni_ensure_jvm", 0, jni_ensure_jvm_plc, 0 }, + { "jni_tag_to_iref", 2, jni_tag_to_iref_plc, 0 }, + { "jni_hr_info", 4, jni_hr_info_plc, 0 }, + { "jni_hr_table", 1, jni_hr_table_plc, 0 }, + { "jni_byte_buf_length_to_codes", 3, jni_byte_buf_length_to_codes_plc, 0 }, + { "jni_param_put", 4, jni_param_put_plc, 0 }, + { "jni_alloc_buffer", 3, jni_alloc_buffer_plc, 0 }, + { "jni_free_buffer", 1, jni_free_buffer_plc, 0 }, +#ifdef __YAP_PROLOG__ + { "jni_SetByteArrayElement", 3, jni_SetByteArrayElement, 0 }, + { "jni_SetDoubleArrayElement", 3, jni_SetDoubleArrayElement, 0 }, +#endif + { "jni_fetch_buffer_value", 4, jni_fetch_buffer_value_plc, 0 }, + { "jni_stash_buffer_value", 4, jni_stash_buffer_value_plc, 0 }, + { "jni_void", 1, jni_void_0_plc, 0 }, + { "jni_void", 2, jni_void_1_plc, 0 }, + { "jni_void", 3, jni_void_2_plc, 0 }, + { "jni_void", 4, jni_void_3_plc, 0 }, + { "jni_void", 5, jni_void_4_plc, 0 }, + { "jni_func", 2, jni_func_0_plc, 0 }, + { "jni_func", 3, jni_func_1_plc, 0 }, + { "jni_func", 4, jni_func_2_plc, 0 }, + { "jni_func", 5, jni_func_3_plc, 0 }, + { "jni_func", 6, jni_func_4_plc, 0 }, + { "jpl_c_lib_version", 1, jpl_c_lib_version_1_plc, 0 }, + { "jpl_c_lib_version", 4, jpl_c_lib_version_4_plc, 0 }, + { "jni_term_to_jref", 2, jni_term_to_jref_plc, 0 }, + { "jni_jref_to_term", 2, jni_jref_to_term_plc, 0 }, + { "jni_get_default_jvm_opts", 1, jni_get_default_jvm_opts_plc, 0 }, + { "jni_set_default_jvm_opts", 2, jni_set_default_jvm_opts_plc, 0 }, + { "jni_get_actual_jvm_opts", 1, jni_get_actual_jvm_opts_plc, 0 }, + { NULL, 0, NULL, 0 } + }; + + +install_t + install(void) + { + PL_register_extensions( predspecs); + } + +/*=== end of jpl.c ================================================================================= */ diff --git a/packages/jpl/jpl/src/c/jpl.h b/packages/jpl/jpl/src/c/jpl.h new file mode 100644 index 000000000..98fe27284 --- /dev/null +++ b/packages/jpl/jpl/src/c/jpl.h @@ -0,0 +1,340 @@ +/* Part of JPL -- SWI-Prolog/Java interface + + Author: Paul Singleton, Fred Dushin and Jan Wielemaker + E-mail: paul@jbgb.com + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2004, Paul Singleton + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +*/ + +install_t install(void); +JNIEXPORT int JNICALL Java_jpl_fli_Prolog_action_1abort( JNIEnv *env, jclass jProlog); +JNIEXPORT jstring JNICALL Java_jpl_fli_Prolog_atom_1chars( JNIEnv *env, jclass jProlog, jobject jatom); + +JNIEXPORT int JNICALL + Java_jpl_fli_Prolog_attach_1engine( + JNIEnv *env, + jclass jProlog, + jobject jengine + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_attach_1pool_1engine( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_close_1query( + JNIEnv *env, + jclass jProlog, + jobject jqid + ); + +JNIEXPORT jint JNICALL /* returns -1, 0 or 1 (or -2 for error) */ + Java_jpl_fli_Prolog_compare( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_cons_1functor_1v( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jfunctor, + jobject jterm0 + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_copy_1term_1ref( + JNIEnv *env, + jclass jProlog, + jobject jfrom + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_current_1engine_1is_1pool( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_current_1engine( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_discard_1foreign_1frame( + JNIEnv *env, + jclass jProlog, + jobject jfid + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_exception( + JNIEnv *env, + jclass jProlog, + jobject jqid + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1actual_1init_1args( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1arg( + JNIEnv *env, + jclass jProlog, + jint jindex, + jobject jterm, + jobject jarg + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1atom_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_get_1c_1lib_1version( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1default_1init_1args( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1float( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jdouble_holder + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1integer( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jint64_holder + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1name_1arity( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jname_holder, /* we trust this is a StringHolder */ + jobject jarity_holder /* we trust this is an IntHolder */ + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1string_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ); + +JNIEXPORT void JNICALL +Java_jpl_fli_Prolog_halt( + JNIEnv *env, + jclass jProlog, + jint jstatus + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_initialise( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_is_1tag( + JNIEnv *env, + jclass jProlog, + jstring tag + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1atom( + JNIEnv *env, + jclass jProlog, + jstring jname + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1functor( + JNIEnv *env, + jclass jProlog, + jobject jatom, /* read-only */ + jint jarity + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1module( + JNIEnv *env, + jclass jProlog, + jobject jatom + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1ref( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1refs( + JNIEnv *env, + jclass jProlog, + jint jn + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_next_1solution( + JNIEnv *env, + jclass jProlog, + jobject jqid /* read */ + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_object_1to_1tag( + JNIEnv *env, + jclass jProlog, + jobject jobj + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_open_1foreign_1frame( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_open_1query( + JNIEnv *env, + jclass jProlog, + jobject jmodule, /* read */ + jint jflags, /* read */ + jobject jpredicate, /* read */ + jobject jterm0 /* read */ + ); + +JNIEXPORT int JNICALL +Java_jpl_fli_Prolog_pool_1engine_1id( + JNIEnv *env, + jclass jProlog, + jobject jengine + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_predicate( + JNIEnv *env, + jclass jProlog, + jstring jname, /* ought not be null */ + jint jarity, /* oughta be >= 0 */ + jstring jmodule /* may be null */ + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1float(JNIEnv *env, + jclass jProlog, + jobject jterm, + jdouble jf); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1integer(JNIEnv *env, + jclass jProlog, + jobject jterm, + jlong ji); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_put_1jref( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jref + ); + +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1term( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ); + +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1variable( + JNIEnv *env, + jclass jProlog, + jobject jterm + ); + +JNIEXPORT int JNICALL +Java_jpl_fli_Prolog_release_1pool_1engine( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_set_1default_1init_1args( + JNIEnv *env, + jclass jProlog, + jobject jargs /* oughta be proper array, perhaps zero-length */ + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_tag_1to_1object( + JNIEnv *env, + jclass jProlog, + jstring tag + ); + +JNIEXPORT jint JNICALL + Java_jpl_fli_Prolog_term_1type( + JNIEnv *env, + jclass jProlog, + jobject jterm + ); + +JNIEXPORT jint JNICALL +Java_jpl_fli_Prolog_thread_1self( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_unregister_1atom( + JNIEnv *env, + jclass jProlog, + jobject jatom + ); + diff --git a/packages/jpl/jpl/src/java/.cvsignore b/packages/jpl/jpl/src/java/.cvsignore new file mode 100644 index 000000000..5beafe7ed --- /dev/null +++ b/packages/jpl/jpl/src/java/.cvsignore @@ -0,0 +1,3 @@ +Makefile +.classpath +.project \ No newline at end of file diff --git a/packages/jpl/jpl/src/java/CMakeFiles/CMakeDirectoryInformation.cmake b/packages/jpl/jpl/src/java/CMakeFiles/CMakeDirectoryInformation.cmake new file mode 100644 index 000000000..bab203dbc --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/CMakeDirectoryInformation.cmake @@ -0,0 +1,16 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Relative path conversion top directories. +set(CMAKE_RELATIVE_PATH_TOP_SOURCE "/Users/vsc/git/yap-6.3") +set(CMAKE_RELATIVE_PATH_TOP_BINARY "/Users/vsc/git/yap-6.3") + +# Force unix paths in dependencies. +set(CMAKE_FORCE_UNIX_PATHS 1) + + +# The C and CXX include file regular expressions for this directory. +set(CMAKE_C_INCLUDE_REGEX_SCAN "^.*$") +set(CMAKE_C_INCLUDE_REGEX_COMPLAIN "^$") +set(CMAKE_CXX_INCLUDE_REGEX_SCAN ${CMAKE_C_INCLUDE_REGEX_SCAN}) +set(CMAKE_CXX_INCLUDE_REGEX_COMPLAIN ${CMAKE_C_INCLUDE_REGEX_COMPLAIN}) diff --git a/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/DependInfo.cmake b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/DependInfo.cmake new file mode 100644 index 000000000..86c3d8af6 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/DependInfo.cmake @@ -0,0 +1,8 @@ +# The set of languages for which implicit dependencies are needed: +set(CMAKE_DEPENDS_LANGUAGES + ) +# The set of files for implicit dependencies of each language: + +# Targets to which this target links. +set(CMAKE_TARGET_LINKED_INFO_FILES + ) diff --git a/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/build.make b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/build.make new file mode 100644 index 000000000..9449fb182 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/build.make @@ -0,0 +1,122 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Delete rule output on recipe failure. +.DELETE_ON_ERROR: + + +#============================================================================= +# Special targets provided by cmake. + +# Disable implicit rules so canonical targets will work. +.SUFFIXES: + + +# Remove some rules from gmake that .SUFFIXES does not remove. +SUFFIXES = + +.SUFFIXES: .hpux_make_needs_suffix_list + + +# Suppress display of executed commands. +$(VERBOSE).SILENT: + + +# A target that is always out of date. +cmake_force: + +.PHONY : cmake_force + +#============================================================================= +# Set environment variables for the build. + +# The shell in which to execute make rules. +SHELL = /bin/sh + +# The CMake executable. +CMAKE_COMMAND = /usr/local/Cellar/cmake/3.3.2/bin/cmake + +# The command to remove a file. +RM = /usr/local/Cellar/cmake/3.3.2/bin/cmake -E remove -f + +# Escaping for special characters. +EQUALS = = + +# The top-level source directory on which CMake was run. +CMAKE_SOURCE_DIR = /Users/vsc/git/yap-6.3 + +# The top-level build directory on which CMake was run. +CMAKE_BINARY_DIR = /Users/vsc/git/yap-6.3 + +# Utility rule file for jpl. + +# Include the progress variables for this target. +include packages/jpl/src/java/CMakeFiles/jpl.dir/progress.make + +packages/jpl/src/java/CMakeFiles/jpl: packages/jpl/src/java/jpl.jar + + +packages/jpl/src/java/jpl.jar: packages/jpl/src/java/CMakeFiles/jpl.dir/java_class_filelist + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --blue --bold --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_1) "Creating Java archive jpl.jar" + cd /Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir && /Library/Java/JavaVirtualMachines/jdk1.8.0_40.jdk/Contents/Home/bin/jar -cf /Users/vsc/git/yap-6.3/packages/jpl/src/java/jpl.jar @java_class_filelist + cd /Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir && /usr/local/Cellar/cmake/3.3.2/bin/cmake -D_JAVA_TARGET_DIR=/Users/vsc/git/yap-6.3/packages/jpl/src/java -D_JAVA_TARGET_OUTPUT_NAME=jpl.jar -D_JAVA_TARGET_OUTPUT_LINK= -P /usr/local/Cellar/cmake/3.3.2/share/cmake/Modules/UseJavaSymlinks.cmake + +packages/jpl/src/java/CMakeFiles/jpl.dir/java_class_filelist: packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --blue --bold --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_2) "Generating CMakeFiles/jpl.dir/java_class_filelist" + cd /Users/vsc/git/yap-6.3/packages/jpl/src/java && /usr/local/Cellar/cmake/3.3.2/bin/cmake -DCMAKE_JAVA_CLASS_OUTPUT_PATH=/Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir -DCMAKE_JAR_CLASSES_PREFIX="" -P /usr/local/Cellar/cmake/3.3.2/share/cmake/Modules/UseJavaClassFilelist.cmake + +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Atom.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Compound.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Float.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Integer.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/JRef.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/JPLException.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/JPL.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/PrologException.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Query.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Term.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Util.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Variable.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/Version.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/atom_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/BooleanHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/DoubleHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/engine_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/fid_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/functor_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/IntHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/Int64Holder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/LongHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/module_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/ObjectHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/PointerHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/predicate_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/Prolog.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/qid_t.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/StringHolder.java +packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl: packages/jpl/src/java/jpl/fli/term_t.java + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --blue --bold --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_3) "Building Java objects for jpl.jar" + cd /Users/vsc/git/yap-6.3/packages/jpl/src/java && /Library/Java/JavaVirtualMachines/jdk1.8.0_40.jdk/Contents/Home/bin/javac -classpath :/Users/vsc/git/yap-6.3/packages/jpl/src/java:/Users/vsc/git/yap-6.3/packages/jpl/src/java -d /Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir @/Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir/java_sources + cd /Users/vsc/git/yap-6.3/packages/jpl/src/java && /usr/local/Cellar/cmake/3.3.2/bin/cmake -E touch /Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl + +jpl: packages/jpl/src/java/CMakeFiles/jpl +jpl: packages/jpl/src/java/jpl.jar +jpl: packages/jpl/src/java/CMakeFiles/jpl.dir/java_class_filelist +jpl: packages/jpl/src/java/CMakeFiles/jpl.dir/java_compiled_jpl +jpl: packages/jpl/src/java/CMakeFiles/jpl.dir/build.make + +.PHONY : jpl + +# Rule to build all files generated by this target. +packages/jpl/src/java/CMakeFiles/jpl.dir/build: jpl + +.PHONY : packages/jpl/src/java/CMakeFiles/jpl.dir/build + +packages/jpl/src/java/CMakeFiles/jpl.dir/clean: + cd /Users/vsc/git/yap-6.3/packages/jpl/src/java && $(CMAKE_COMMAND) -P CMakeFiles/jpl.dir/cmake_clean.cmake +.PHONY : packages/jpl/src/java/CMakeFiles/jpl.dir/clean + +packages/jpl/src/java/CMakeFiles/jpl.dir/depend: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -E cmake_depends "Unix Makefiles" /Users/vsc/git/yap-6.3 /Users/vsc/git/yap-6.3/packages/jpl/src/java /Users/vsc/git/yap-6.3 /Users/vsc/git/yap-6.3/packages/jpl/src/java /Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/jpl.dir/DependInfo.cmake --color=$(COLOR) +.PHONY : packages/jpl/src/java/CMakeFiles/jpl.dir/depend + diff --git a/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/cmake_clean.cmake b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/cmake_clean.cmake new file mode 100644 index 000000000..6ec452461 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/cmake_clean.cmake @@ -0,0 +1,11 @@ +file(REMOVE_RECURSE + "CMakeFiles/jpl" + "jpl.jar" + "CMakeFiles/jpl.dir/java_class_filelist" + "CMakeFiles/jpl.dir/java_compiled_jpl" +) + +# Per-language clean rules from dependency scanning. +foreach(lang ) + include(CMakeFiles/jpl.dir/cmake_clean_${lang}.cmake OPTIONAL) +endforeach() diff --git a/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/java_sources b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/java_sources new file mode 100644 index 000000000..09a4ca803 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/java_sources @@ -0,0 +1,30 @@ +"jpl/Atom.java" +"jpl/Compound.java" +"jpl/Float.java" +"jpl/Integer.java" +"jpl/JRef.java" +"jpl/JPLException.java" +"jpl/JPL.java" +"jpl/PrologException.java" +"jpl/Query.java" +"jpl/Term.java" +"jpl/Util.java" +"jpl/Variable.java" +"jpl/Version.java" +"jpl/fli/atom_t.java" +"jpl/fli/BooleanHolder.java" +"jpl/fli/DoubleHolder.java" +"jpl/fli/engine_t.java" +"jpl/fli/fid_t.java" +"jpl/fli/functor_t.java" +"jpl/fli/IntHolder.java" +"jpl/fli/Int64Holder.java" +"jpl/fli/LongHolder.java" +"jpl/fli/module_t.java" +"jpl/fli/ObjectHolder.java" +"jpl/fli/PointerHolder.java" +"jpl/fli/predicate_t.java" +"jpl/fli/Prolog.java" +"jpl/fli/qid_t.java" +"jpl/fli/StringHolder.java" +"jpl/fli/term_t.java" \ No newline at end of file diff --git a/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/progress.make b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/progress.make new file mode 100644 index 000000000..7aeb50ddf --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/jpl.dir/progress.make @@ -0,0 +1,4 @@ +CMAKE_PROGRESS_1 = 29 +CMAKE_PROGRESS_2 = +CMAKE_PROGRESS_3 = 30 + diff --git a/packages/jpl/jpl/src/java/CMakeFiles/progress.marks b/packages/jpl/jpl/src/java/CMakeFiles/progress.marks new file mode 100644 index 000000000..0cfbf0888 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeFiles/progress.marks @@ -0,0 +1 @@ +2 diff --git a/packages/jpl/jpl/src/java/CMakeLists.txt b/packages/jpl/jpl/src/java/CMakeLists.txt new file mode 100644 index 000000000..428b779d6 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeLists.txt @@ -0,0 +1,84 @@ +include ( UseJava) + +# add_jar(target_name +# [SOURCES] source1 [source2 ...] [resource1 ...] +# [INCLUDE_JARS jar1 [jar2 ...]] +# [ENTRY_POINT entry] +# [VERSION version] +# [OUTPUT_NAME name] +# [OUTPUT_DIR dir] +# ) +# +# This command creates a .jar. It compiles the given +# source files (source) and adds the given resource files (resource) to +# the jar file. If only resource files are given then just a jar file +# is created. The list of include jars are added to the classpath when +# compiling the java sources and also to the dependencies of the target. +# INCLUDE_JARS also accepts other target names created by add_jar. For +# backwards compatibility, jar files listed as sources are ignored (as +# they have been since the first version of this module). +# +# The default OUTPUT_DIR can also be changed by setting the variable +# CMAKE_JAVA_TARGET_OUTPUT_DIR. +# + + set (CLS + jpl/Atom.java + jpl/Compound.java + jpl/Float.java + jpl/Integer.java + jpl/JRef.java + jpl/JPLException.java + jpl/JPL.java + jpl/PrologException.java + jpl/Query.java + jpl/Term.java + jpl/Util.java + jpl/Variable.java + jpl/Version.java + ) + +set (FLI + jpl/fli/atom_t.java + jpl/fli/BooleanHolder.java + jpl/fli/DoubleHolder.java + jpl/fli/engine_t.java + jpl/fli/fid_t.java + jpl/fli/functor_t.java + jpl/fli/IntHolder.java + jpl/fli/Int64Holder.java + jpl/fli/LongHolder.java + jpl/fli/module_t.java + jpl/fli/ObjectHolder.java + jpl/fli/PointerHolder.java + jpl/fli/predicate_t.java + jpl/fli/Prolog.java + jpl/fli/qid_t.java + jpl/fli/StringHolder.java + jpl/fli/term_t.java + ) + +set (TEST + jpl/test/Family.java + jpl/test/FetchBigTree.java + jpl/test/FetchLongList.java + jpl/test/Ga2.java + jpl/test/Ga.java + jpl/test/Garbo.java + jpl/test/Masstest.java + jpl/test/MaxObjects.java + jpl/test/ShadowA.java + jpl/test/ShadowB.java + jpl/test/SyntaxError.java + jpl/test/Test.java + jpl/test/TestJUnit.java + jpl/test/TestOLD.java + ) + +set ( JPLJAVA ${CLS} ${FLI} ) + +add_jar(jpl + SOURCES ${JPLJAVA} + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}) + +install_jar(jpl ${libpl} ) diff --git a/packages/jpl/jpl/src/java/CMakeLists.txt~ b/packages/jpl/jpl/src/java/CMakeLists.txt~ new file mode 100644 index 000000000..1e94f1670 --- /dev/null +++ b/packages/jpl/jpl/src/java/CMakeLists.txt~ @@ -0,0 +1,134 @@ +#CHECK: JavaLibs + +set (JPL_SOURCES + src/c/jpl.c) + +macro_optional_find_package(Java ON) +macro_optional_find_package(Java COMPONENTS Runtime) +macro_optional_find_package(Java COMPONENTS Development) +macro_log_feature (JAVA_FOUND "Java" + "Use Java System" + "http://www.java.org" FALSE) +if (JAVA_FOUND) + # Java_JAVA_EXECUTABLE = the full path to the Java runtime + # Java_JAVAC_EXECUTABLE = the full path to the Java compiler + # Java_JAVAH_EXECUTABLE = the full path to the Java header generator + # Java_JAVADOC_EXECUTABLE = the full path to the Java documention generator + # Java_JAR_EXECUTABLE = the full path to the Java archiver + # Java_VERSION_STRING = Version of java found, eg. 1.6.0_12 + # Java_VERSION_MAJOR = The major version of the package found. + # Java_VERSION_MINOR = The minor version of the package found. + # Java_VERSION_PATCH = The patch version of the package found. + # Java_VERSION_TWEAK = The tweak version of the package found (after '_') + # Java_VERSION = This is set to: $major.$minor.$patch(.$tweak) + # JAVA_LIBRARIES - path to the java library + # JAVA_INCLUDE_PATH - path to where Java.h is found (deprecated) + # JAVA_INCLUDE_DIRS - path to where Java.h is found + # JAVA_DEBUG_LIBRARIES - path to the debug library (deprecated) + # JAVALIBS_VERSION_STRING - version of the Java libs found (since CMake 2.8.8) + # + # + # + # The Java_ADDITIONAL_VERSIONS variable can be used to specify a list + # of version numbers that should be taken into account when searching + # for Java. You need to set this variable before calling + # find_package(JavaLibs). + # + find_package( UseJava) + + # add_jar(target_name + # [SOURCES] source1 [source2 ...] [resource1 ...] + # [INCLUDE_JARS jar1 [jar2 ...]] + # [ENTRY_POINT entry] + # [VERSION version] + # [OUTPUT_NAME name] + # [OUTPUT_DIR dir] + # ) + # + # This command creates a .jar. It compiles the given + # source files (source) and adds the given resource files (resource) to + # the jar file. If only resource files are given then just a jar file + # is created. The list of include jars are added to the classpath when + # compiling the java sources and also to the dependencies of the target. + # INCLUDE_JARS also accepts other target names created by add_jar. For + # backwards compatibility, jar files listed as sources are ignored (as + # they have been since the first version of this module). + # + # The default OUTPUT_DIR can also be changed by setting the variable + # CMAKE_JAVA_TARGET_OUTPUT_DIR. + # + add_library (jpl SHARED ${JPL_Sources}) + + add_subdirectory (src/java) + + set (CLS + jpl/Atom.java + jpl/Compound.java + jpl/Float.java + jpl/Integer.java + jpl/JRef.java + jpl/JPLException.java + jpl/JPL.java + jpl/PrologException.java + jpl/Query.java + jpl/Term.java + jpl/Util.java + jpl/Variable.java + jpl/Version.java + ) + +set (FLI + jpl/fli/atom_t.java + jpl/fli/BooleanHolder.java + jpl/fli/DoubleHolder.java + jpl/fli/engine_t.java + jpl/fli/fid_t.java + jpl/fli/functor_t.java + jpl/fli/IntHolder.java + jpl/fli/Int64Holder.java + jpl/fli/LongHolder.java + jpl/fli/module_t.java + jpl/fli/ObjectHolder.java + jpl/fli/PointerHolder.java + jpl/fli/predicate_t.java + jpl/fli/Prolog.java + jpl/fli/qid_t.java + jpl/fli/StringHolder.java + jpl/fli/term_t.java + ) + +set (TEST + jpl/test/Family.java + jpl/test/FetchBigTree.java + jpl/test/FetchLongList.java + jpl/test/Ga2.java + jpl/test/Ga.java + jpl/test/Garbo.java + jpl/test/Masstest.java + jpl/test/MaxObjects.java + jpl/test/ShadowA.java + jpl/test/ShadowB.java + jpl/test/SyntaxError.java + jpl/test/Test.java + jpl/test/TestJUnit.java + jpl/test/TestOLD.java + ) + +set ( JPLJAVA ${CLS} ${FLI} ) + +add_jar(jpl + SOURCES ${JPLJAVA}) + +target_link_libraries(java libYap ${JAVA_LIBRARIES}) + + +install(TARGETS java + LIBRARY DESTINATION ${dlls} + ) + + install(FILES jpl.pl + DESTINATION ${libpl} + ) + + +endif (JAVALIBS_FOUND) diff --git a/packages/jpl/jpl/src/java/Makefile b/packages/jpl/jpl/src/java/Makefile new file mode 100644 index 000000000..45dc9fd6a --- /dev/null +++ b/packages/jpl/jpl/src/java/Makefile @@ -0,0 +1,198 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Default target executed when no arguments are given to make. +default_target: all + +.PHONY : default_target + +# Allow only one "make -f Makefile2" at a time, but pass parallelism. +.NOTPARALLEL: + + +#============================================================================= +# Special targets provided by cmake. + +# Disable implicit rules so canonical targets will work. +.SUFFIXES: + + +# Remove some rules from gmake that .SUFFIXES does not remove. +SUFFIXES = + +.SUFFIXES: .hpux_make_needs_suffix_list + + +# Suppress display of executed commands. +$(VERBOSE).SILENT: + + +# A target that is always out of date. +cmake_force: + +.PHONY : cmake_force + +#============================================================================= +# Set environment variables for the build. + +# The shell in which to execute make rules. +SHELL = /bin/sh + +# The CMake executable. +CMAKE_COMMAND = /usr/local/Cellar/cmake/3.3.2/bin/cmake + +# The command to remove a file. +RM = /usr/local/Cellar/cmake/3.3.2/bin/cmake -E remove -f + +# Escaping for special characters. +EQUALS = = + +# The top-level source directory on which CMake was run. +CMAKE_SOURCE_DIR = /Users/vsc/git/yap-6.3 + +# The top-level build directory on which CMake was run. +CMAKE_BINARY_DIR = /Users/vsc/git/yap-6.3 + +#============================================================================= +# Targets provided globally by CMake. + +# Special rule for the target edit_cache +edit_cache: + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake cache editor..." + /usr/local/Cellar/cmake/3.3.1/bin/ccmake -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) +.PHONY : edit_cache + +# Special rule for the target edit_cache +edit_cache/fast: edit_cache + +.PHONY : edit_cache/fast + +# Special rule for the target rebuild_cache +rebuild_cache: + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake to regenerate build system..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) +.PHONY : rebuild_cache + +# Special rule for the target rebuild_cache +rebuild_cache/fast: rebuild_cache + +.PHONY : rebuild_cache/fast + +# Special rule for the target list_install_components +list_install_components: + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Available install components are: \"Unspecified\"" +.PHONY : list_install_components + +# Special rule for the target list_install_components +list_install_components/fast: list_install_components + +.PHONY : list_install_components/fast + +# Special rule for the target install +install: preinstall + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -P cmake_install.cmake +.PHONY : install + +# Special rule for the target install +install/fast: preinstall/fast + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -P cmake_install.cmake +.PHONY : install/fast + +# Special rule for the target install/strip +install/strip: preinstall + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing the project stripped..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -DCMAKE_INSTALL_DO_STRIP=1 -P cmake_install.cmake +.PHONY : install/strip + +# Special rule for the target install/strip +install/strip/fast: install/strip + +.PHONY : install/strip/fast + +# Special rule for the target install/local +install/local: preinstall + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing only the local directory..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -DCMAKE_INSTALL_LOCAL_ONLY=1 -P cmake_install.cmake +.PHONY : install/local + +# Special rule for the target install/local +install/local/fast: install/local + +.PHONY : install/local/fast + +# The main all target +all: cmake_check_build_system + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -E cmake_progress_start /Users/vsc/git/yap-6.3/CMakeFiles /Users/vsc/git/yap-6.3/packages/jpl/src/java/CMakeFiles/progress.marks + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/jpl/src/java/all + $(CMAKE_COMMAND) -E cmake_progress_start /Users/vsc/git/yap-6.3/CMakeFiles 0 +.PHONY : all + +# The main clean target +clean: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/jpl/src/java/clean +.PHONY : clean + +# The main clean target +clean/fast: clean + +.PHONY : clean/fast + +# Prepare targets for installation. +preinstall: all + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/jpl/src/java/preinstall +.PHONY : preinstall + +# Prepare targets for installation. +preinstall/fast: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/jpl/src/java/preinstall +.PHONY : preinstall/fast + +# clear depends +depend: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 1 +.PHONY : depend + +# Convenience name for target. +packages/jpl/src/java/CMakeFiles/jpl.dir/rule: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/jpl/src/java/CMakeFiles/jpl.dir/rule +.PHONY : packages/jpl/src/java/CMakeFiles/jpl.dir/rule + +# Convenience name for target. +jpl: packages/jpl/src/java/CMakeFiles/jpl.dir/rule + +.PHONY : jpl + +# fast build rule for target. +jpl/fast: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f packages/jpl/src/java/CMakeFiles/jpl.dir/build.make packages/jpl/src/java/CMakeFiles/jpl.dir/build +.PHONY : jpl/fast + +# Help Target +help: + @echo "The following are some of the valid targets for this Makefile:" + @echo "... all (the default if no target is provided)" + @echo "... clean" + @echo "... depend" + @echo "... edit_cache" + @echo "... rebuild_cache" + @echo "... list_install_components" + @echo "... install" + @echo "... install/strip" + @echo "... install/local" + @echo "... jpl" +.PHONY : help + + + +#============================================================================= +# Special targets to cleanup operation of make. + +# Special rule to run CMake to check the build system integrity. +# No rule that depends on this can have commands that come from listfiles +# because they might be regenerated. +cmake_check_build_system: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 0 +.PHONY : cmake_check_build_system + diff --git a/packages/jpl/jpl/src/java/Makefile.in b/packages/jpl/jpl/src/java/Makefile.in new file mode 100755 index 000000000..e4486096c --- /dev/null +++ b/packages/jpl/jpl/src/java/Makefile.in @@ -0,0 +1,99 @@ +################################################################ +# Build jpl.jar +################################################################ + +.SUFFIXES: .java .class + +ifeq (@PROLOG_SYSTEM@,yap) +srcdir=@srcdir@ +else +srcdir=. +endif + +JAVAC=@JAVAC@ +JAVACFLAGS=@JAVACFLAGS@ -d . +JAR=@JAR@ +JUNIT=@JUNIT@ +JAVADOC=@JAVADOC@ +JPLJAR=../../jpl.jar +TSTJAR=../../jpltest.jar +JPLDOC=../../docs/java_api/javadoc + +CLS= jpl/Atom.java \ + jpl/Compound.java \ + jpl/Float.java \ + jpl/Integer.java \ + jpl/JRef.java \ + jpl/JPLException.java \ + jpl/JPL.java \ + jpl/PrologException.java \ + jpl/Query.java \ + jpl/Term.java \ + jpl/Util.java \ + jpl/Variable.java \ + jpl/Version.java + +FLI= jpl/fli/atom_t.java \ + jpl/fli/BooleanHolder.java \ + jpl/fli/DoubleHolder.java \ + jpl/fli/engine_t.java \ + jpl/fli/fid_t.java \ + jpl/fli/functor_t.java \ + jpl/fli/IntHolder.java \ + jpl/fli/Int64Holder.java \ + jpl/fli/LongHolder.java \ + jpl/fli/module_t.java \ + jpl/fli/ObjectHolder.java \ + jpl/fli/PointerHolder.java \ + jpl/fli/predicate_t.java \ + jpl/fli/Prolog.java \ + jpl/fli/qid_t.java \ + jpl/fli/StringHolder.java \ + jpl/fli/term_t.java + +TEST= jpl/test/Family.java \ + jpl/test/FetchBigTree.java \ + jpl/test/FetchLongList.java \ + jpl/test/Ga2.java \ + jpl/test/Ga.java \ + jpl/test/Garbo.java \ + jpl/test/Masstest.java \ + jpl/test/MaxObjects.java \ + jpl/test/ShadowA.java \ + jpl/test/ShadowB.java \ + jpl/test/SyntaxError.java \ + jpl/test/Test.java \ + jpl/test/TestJUnit.java \ + jpl/test/TestOLD.java + +JPLJAVA=$(CLS) $(FLI) +TSTJAVA=$(TEST) + +all: $(JPLJAR) $(TSTJAR) $(JPLDOC) + +jpl_jar: $(JPLJAR) +test_jar: $(TSTJAR) +jpl_doc: $(JPLDOC) + +$(JPLJAR): $(addprefix $(srcdir)/, $(JPLJAVA)) + "$(JAVAC)" $(JAVACFLAGS) $(addprefix $(srcdir)/, $(JPLJAVA)) + "$(JAR)" cf $(JPLJAR) $(foreach basename,$(JPLJAVA:.java=),$(basename).class $(subst $$,\$$,$(wildcard $(basename)$$*.class))) + +ifneq ($(JUNIT),) +$(TSTJAR): $(JPLJAR) $(addprefix $(srcdir)/, $(TSTJAVA)) + "$(JAVAC)" $(JAVACFLAGS) -classpath $(JPLJAR):$(JUNIT) $(addprefix $(srcdir)/, $(TSTJAVA)) + "$(JAR)" cf $(TSTJAR) $(TSTJAVA:.java=.class) +else +$(TSTJAR):: +endif + +$(JPLDOC): $(addprefix $(srcdir)/, $(JPLJAVA)) + "$(JAVADOC)" -public -d $(JPLDOC) $(addprefix $(srcdir)/, $(JPLJAVA)) + +clean:: + rm -f *~ jpl/*.class jpl/test/*.class jpl/fli/*.class + +distclean: clean + rm -f $(JPLJAR) $(TSTJAR) Makefile + rm -rf $(JPLDOC) + diff --git a/packages/jpl/jpl/src/java/Makefile.mak b/packages/jpl/jpl/src/java/Makefile.mak new file mode 100644 index 000000000..820b6d3f5 --- /dev/null +++ b/packages/jpl/jpl/src/java/Makefile.mak @@ -0,0 +1,91 @@ +################################################################ +# Build jpl.jar +################################################################ + +.SUFFIXES: .java .class + +!include ..\..\..\..\src\rules.mk +JAVAC="$(JAVA_HOME)\bin\javac" +JAR="$(JAVA_HOME)\bin\jar" +JAVADOC="$(JAVA_HOME)\bin\javadoc" +JPLJAR=..\..\jpl.jar +TSTJAR=..\..\jpltest.jar +JPLDOC=..\..\docs\java_api\javadoc + +CLS= jpl\Atom.java \ + jpl\Compound.java \ + jpl\Float.java \ + jpl\Integer.java \ + jpl\JRef.java \ + jpl\JPLException.java \ + jpl\JPL.java \ + jpl\PrologException.java \ + jpl\Query.java \ + jpl\Term.java \ + jpl\Util.java \ + jpl\Variable.java \ + jpl\Version.java + +FLI= jpl\fli\atom_t.java \ + jpl\fli\BooleanHolder.java \ + jpl\fli\DoubleHolder.java \ + jpl\fli\engine_t.java \ + jpl\fli\fid_t.java \ + jpl\fli\functor_t.java \ + jpl\fli\IntHolder.java \ + jpl\fli\Int64Holder.java \ + jpl\fli\LongHolder.java \ + jpl\fli\module_t.java \ + jpl\fli\ObjectHolder.java \ + jpl\fli\PointerHolder.java \ + jpl\fli\predicate_t.java \ + jpl\fli\Prolog.java \ + jpl\fli\qid_t.java \ + jpl\fli\StringHolder.java \ + jpl\fli\term_t.java + +TEST= jpl\test\CelsiusConverter.java \ + jpl\test\Family.java \ + jpl\test\FetchBigTree.java \ + jpl\test\FetchLongList.java \ + jpl\test\Ga2.java \ + jpl\test\Ga.java \ + jpl\test\Garbo.java \ + jpl\test\Masstest.java \ + jpl\test\MaxObjects.java \ + jpl\test\ShadowA.java \ + jpl\test\ShadowB.java \ + jpl\test\SyntaxError.java \ + jpl\test\Test.java \ + jpl\test\TestJUnit.java \ + jpl\test\TestOLD.java + +JPLJAVA=$(CLS) $(FLI) +TSTJAVA=$(TEST) + +all: $(JPLJAR) $(TSTJAR) $(JPLDOC) + +$(JPLJAR): $(JPLJAVA) + $(JAVAC) -source 1.4 -target 1.4 $(JPLJAVA) + $(JAR) cf $(JPLJAR) $(JPLJAVA:.java=.class) + +$(TSTJAR): $(JPLJAR) $(TSTJAVA) + $(JAVAC) -source 1.4 -target 1.4 -classpath "$(JPLJAR);$(JUNIT)" $(TSTJAVA) + $(JAR) cf $(TSTJAR) $(TSTJAVA:.java=.class) + +$(JPLDOC): $(JPLJAVA) + $(JAVADOC) -public -d $(JPLDOC) $(JPLJAVA) + +clean:: + if exist jpl\*.class del jpl\*.class + if exist jpl\fli\*.class del jpl\fli\*.class + if exist jpl\test\*.class del jpl\test\*.class + if exist jpl\util\*.class del jpl\util\*.class + if exist *~ del *~ + +distclean: clean + if exist $(JPLJAR) del $(JPLJAR) + if exist $(TSTJAR) del $(TSTJAR) + if exist $(JPLDOC) rmdir /s /q $(JPLDOC) + + diff --git a/packages/jpl/jpl/src/java/cmake_install.cmake b/packages/jpl/jpl/src/java/cmake_install.cmake new file mode 100644 index 000000000..9ee9f7ca4 --- /dev/null +++ b/packages/jpl/jpl/src/java/cmake_install.cmake @@ -0,0 +1,41 @@ +# Install script for directory: /Users/vsc/git/yap-6.3/packages/jpl/src/java + +# Set the install prefix +if(NOT DEFINED CMAKE_INSTALL_PREFIX) + set(CMAKE_INSTALL_PREFIX "/usr/local") +endif() +string(REGEX REPLACE "/$" "" CMAKE_INSTALL_PREFIX "${CMAKE_INSTALL_PREFIX}") + +# Set the install configuration name. +if(NOT DEFINED CMAKE_INSTALL_CONFIG_NAME) + if(BUILD_TYPE) + string(REGEX REPLACE "^[^A-Za-z0-9_]+" "" + CMAKE_INSTALL_CONFIG_NAME "${BUILD_TYPE}") + else() + set(CMAKE_INSTALL_CONFIG_NAME "Debug") + endif() + message(STATUS "Install configuration: \"${CMAKE_INSTALL_CONFIG_NAME}\"") +endif() + +# Set the component getting installed. +if(NOT CMAKE_INSTALL_COMPONENT) + if(COMPONENT) + message(STATUS "Install component: \"${COMPONENT}\"") + set(CMAKE_INSTALL_COMPONENT "${COMPONENT}") + else() + set(CMAKE_INSTALL_COMPONENT) + endif() +endif() + +if(NOT CMAKE_INSTALL_COMPONENT OR "${CMAKE_INSTALL_COMPONENT}" STREQUAL "Unspecified") + list(APPEND CMAKE_ABSOLUTE_DESTINATION_FILES + "/usr/local/share/Yap/jpl.jar") + if(CMAKE_WARN_ON_ABSOLUTE_INSTALL_DESTINATION) + message(WARNING "ABSOLUTE path INSTALL DESTINATION : ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() + if(CMAKE_ERROR_ON_ABSOLUTE_INSTALL_DESTINATION) + message(FATAL_ERROR "ABSOLUTE path INSTALL DESTINATION forbidden (by caller): ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() +file(INSTALL DESTINATION "/usr/local/share/Yap" TYPE FILE FILES "/Users/vsc/git/yap-6.3/packages/jpl/src/java/jpl.jar") +endif() + diff --git a/packages/jpl/jpl/src/java/jpl/.cvsignore b/packages/jpl/jpl/src/java/jpl/.cvsignore new file mode 100644 index 000000000..20e215408 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/.cvsignore @@ -0,0 +1,2 @@ +*.class +Makefile diff --git a/packages/jpl/jpl/src/java/jpl/Atom.java b/packages/jpl/jpl/src/java/jpl/Atom.java new file mode 100644 index 000000000..bb4a88d03 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Atom.java @@ -0,0 +1,169 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// Author: Paul Singleton paul@jbgb.com +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; + +import jpl.fli.Prolog; +import jpl.fli.StringHolder; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Atom +/** + * Atom is a specialised Compound with zero arguments, representing a Prolog atom with the same name. + * An Atom is constructed with a String parameter (its name, unquoted), which cannot thereafter be changed. + * 
    Atom a = new Atom("hello");
    + * An Atom can be used (and re-used) as an argument of Compound Terms. + * Two Atom instances are equal (by equals()) iff they have equal names. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + */ +public class Atom extends Compound { + + //==================================================================/ + // Attributes (none) + //==================================================================/ + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * @param name the Atom's name (unquoted) + */ + public Atom(String name) { + super(name); + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + // these are all inherited from Compound + + public final int type() { + return Prolog.ATOM; + } + + /** + * returns the name of the type of this term, as "Atom" + * + * @return the name of the type of this term, as "Atom" + */ + public String typeName() { // overrides same in jpl.Term + return "Atom"; + } + + public Object jrefToObject() { + throw new JPLException("Atom.jrefToObject: term is not a JRef"); + } +//==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * Returns a debug-friendly String representation of an Atom. + * + * @return a debug-friendly String representation of an Atom + * @deprecated + */ + public String debugString() { + return "(Atom " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + // (this is done with the put() method inherited from Compound) + + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + + /** + * Converts a Prolog term (as a term_t), which is known to be an atom, to a new jpl.Atom. + * This is only called from Term.getTerm(), + * and just creates a new Atom object initialised with the atom's name. + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + * @param term The Prolog term to be converted + * @return A new Atom instance + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + StringHolder holder = new StringHolder(); + Prolog.get_atom_chars(term, holder); // ignore return val; assume success... + + return new Atom(holder.value); + } + + /** + * Converts a Prolog term (as a term_t), which is known to be a SWI-Prolog string, to a new jpl.Atom, + * by creating a new Atom object initialised with the string's value. + * JPL users should avoid SWI-Prolog's non-ISO strings, but in some obscure + * circumstances they are returned unavoidably, so we have to handle them + * (and this is how). + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + * @param term The term_t to convert + * @return A new Atom instance + */ + protected static Term getString(Map vars_to_Vars, term_t term) { + StringHolder holder = new StringHolder(); + Prolog.get_string_chars(term, holder); // ignore return val; assume success... + return new Atom(holder.value); + } + + //==================================================================/ + // Computing substitutions + //==================================================================/ + + // (done with the inherited Compound.getSubst() method) + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/Compound.java b/packages/jpl/jpl/src/java/jpl/Compound.java new file mode 100644 index 000000000..c3d00cb8f --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Compound.java @@ -0,0 +1,419 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; + +import jpl.fli.IntHolder; +import jpl.fli.Prolog; +import jpl.fli.StringHolder; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Compound +/** + * A Compound represents a structured term, + * comprising a functor and arguments (Terms). + * Atom is a subclass of Compound, whose instances have zero arguments. + * Direct instances of Compound must have one or more arguments + * (it is an error to attempt to construct a Compound with zero args; + * a JPLException will be thrown). + * For example, this Java expression yields + * a representation of the term f(a): + * 
    + * new Compound( "f", new Term[] { new Atom("a") } )
+ *
    + * Note the use of the "anonymous array" notation to denote the arguments + * (an anonymous array of Term). + *
    + * Alternatively, construct the Term from Prolog source syntax: + * 
    + * Util.textToTerm("f(a)")
+ *
    + * The arity of a Compound is the quantity of its arguments. + * Once constructed, neither the name nor the arity of a Compound can be altered. + * An argument of a Compound can be replaced with the setArg() method. + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Atom + */ +public class Compound extends Term { + //==================================================================/ + // Attributes + //==================================================================/ + /** + * the name of this Compound + */ + protected final String name; + /** + * the arguments of this Compound + */ + protected final Term[] args; + //==================================================================/ + // Constructors + //==================================================================/ + /** + * Creates a Compound with name but no args (i.e. an Atom). + * This condsructor is protected (from illegal public use) and is used + * only by Atom, which inherits it. + * + * @param name the name of this Compound + * @param args the arguments of this Compound + */ + protected Compound(String name) { + if (name == null) { + throw new JPLException("jpl.Atom: cannot construct with null name"); + } + this.name = name; + this.args = new Term[] {}; + } + /** + * Creates a Compound with name and args. + * + * @param name the name of this Compound + * @param args the (one or more) arguments of this Compound + */ + public Compound(String name, Term[] args) { + if (name == null) { + throw new JPLException("jpl.Compound: cannot construct with null name"); + } + if (args == null) { + throw new JPLException("jpl.Compound: cannot construct with null args"); + } + if (args.length == 0) { + throw new JPLException("jpl.Compound: cannot construct with zero args"); + } + this.name = name; + this.args = args; + } + /** + * Creates a Compound with name and arity. + * This constructor, along with the setArg method, serves the new, native Prolog-term-to-Java-term routine, + * and is public only so as to be accessible via JNI: it is not intended for general use. + * + * @param name the name of this Compound + * @param arity the arity of this Compound + */ + public Compound(String name, int arity) { + if (name == null) { + throw new JPLException("jpl.Compound: cannot construct with null name"); + } + if (arity < 0) { + throw new JPLException("jpl.Compound: cannot construct with negative arity"); + } + this.name = name; + this.args = new Term[arity]; + } + //==================================================================/ + // Methods (common) + //==================================================================/ + /** + * Returns the ith argument (counting from 1) of this Compound; + * throws an ArrayIndexOutOfBoundsException if i is inappropriate. + * + * @return the ith argument (counting from 1) of this Compound + */ + public final Term arg(int i) { + return args[i - 1]; + } + /** + * Tests whether this Compound's functor has (String) 'name' and 'arity'. + * + * @return whether this Compound's functor has (String) 'name' and 'arity' + */ + public final boolean hasFunctor(String name, int arity) { + return name.equals(this.name) && arity == args.length; // BUGFIX: was just name.equals(name) + } + /** + * whether this Term is a 'jboolean' structure denoting Java's false, i.e. @(false) + * + * @return whether this Term is a 'jboolean' structure denoting Java's false, i.e. @(false) + */ + public boolean isJFalse() { + return hasFunctor("@", 1) && arg(1).hasFunctor("false", 0); + } + /** + * whether this Term is a 'jboolean' structure denoting Java's true, i.e. @(fatruelse) + * + * @return whether this Term is a 'jboolean' structure denoting Java's true, i.e. @(fatruelse) + */ + public boolean isJTrue() { + return hasFunctor("@", 1) && arg(1).hasFunctor("true", 0); + } + /** + * whether this Term is a 'jnull' structure, i.e. @(null) + * + * @return whether this Term is a 'jnull' structure, i.e. @(null) + */ + public boolean isJNull() { + return hasFunctor("@", 1) && arg(1).hasFunctor("null", 0); + } + /** + * whether this Term is a 'jvoid' structure, i.e. @(void) + * + * @return whether this Term is a 'jvoid' structure, i.e. @(void) + */ + public boolean isJVoid() { + return hasFunctor("@", 1) && arg(1).hasFunctor("void", 0); + } + /** + * whether this Term is a 'jobject' structure, i.e. @(Tag) + * + * @return whether this Term is a 'jobject' structure, i.e. @(Tag) + */ + public boolean isJObject() { + return hasFunctor("@", 1) && arg(1).isAtom() && JPL.isTag(arg(1).name()); + } + /** + * whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + * + * @return whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + */ + public boolean isJRef() { + return isJObject() || isJNull(); + } + public Object jrefToObject() { + if (this.isJObject()) { + return Prolog.tag_to_object(arg(1).name()); + } else if (this.isJNull()) { + return null; + } else { + throw new JPLException("Term.jrefToObject: term is not a JRef"); + } + } + /** + * Returns the name (unquoted) of this Compound. + * + * @return the name (unquoted) of this Compound + */ + public final String name() { + return name; + } + /** + * Returns the arity (1+) of this Compound. + * + * @return the arity (1+) of this Compound + */ + public final int arity() { + return args.length; + } + /** + * Returns a prefix functional representation of a Compound of the form name(arg1,...), + * where 'name' is quoted iff necessary (to be valid Prolog soutce text) + * and each argument is represented according to its toString() method. + * + * @return string representation of an Compound + */ + public String toString() { + return quotedName() + (args.length > 0 ? "(" + Term.toString(args) + ")" : ""); + } + /** + * Two Compounds are equal if they are identical (same object) or their names and arities are equal and their + * respective arguments are equal. + * + * @param obj the Object to compare (not necessarily another Compound) + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return (this == obj || (obj instanceof Compound && name.equals(((Compound) obj).name) && Term.terms_equals(args, ((Compound) obj).args))); + } + /** + * returns the type of this term, as jpl.fli.Prolog.COMPOUND + * + * @return the type of this term, as jpl.fli.Prolog.COMPOUND + */ + public int type() { + return Prolog.COMPOUND; + } + /** + * returns the name of the type of this term, as "Compound" + * + * @return the name of the type of this term, as "Compound" + */ + public String typeName(){ + return "Compound"; + } + /** + * Sets the i-th (from 1) arg of this Compound to the given Term instance. + * This method, along with the Compound(name,arity) constructor, serves the new, native Prolog-term-to-Java-term routine, + * and is public only so as to be accessible via JNI: it is not intended for general use. + * + * @param i the index (1+) of the arg to be set + * @param arg the Term which is to become the i-th (from 1) arg of this Compound + */ + public void setArg(int i, Term arg) { + if (i <= 0) { + throw new JPLException("jpl.Compound#setArg: bad (non-positive) argument index"); + } + if (i > args.length) { + throw new JPLException("jpl.Compound#setArg: bad (out-of-range) argument index"); + } + if (arg == null) { + throw new JPLException("jpl.Compound#setArg: bad (null) argument"); + } + args[i - 1] = arg; + } + //==================================================================/ + // Methods (protected) + //==================================================================/ + /** + * Returns a quoted (iff necessary) form of the Atom's name, as understood by Prolog read/1 + * (I suspect that there are more efficient ways of doing this) + * + * @return a quoted form of the Atom's name, as understood by Prolog read/1 + */ + protected String quotedName() { + return ((Atom) + (new Query + (new + Compound("with_output_to", + new Term[] { + new Compound("atom", + new Term[] { + new Variable("S") + } + ), + new Compound("writeq", + new Term[] { + new Atom(this.name) + } + ) + } + ) + + ) + ).oneSolution().get("S")).name; + } + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + /** + * Returns the arguments of this Compound (1..arity) of this Compound as an array[0..arity-1] of Term. + * + * @return the arguments (1..arity) of this Compound as an array[0..arity-1] of Term + * @deprecated + */ + public final Term[] args() { + return args; + } + /** + * Returns the ith argument (counting from 0) of this Compound. + * + * @return the ith argument (counting from 0) of this Compound + * @deprecated + */ + public final Term arg0(int i) { + return args[i]; + } + /** + * Returns a debug-friendly representation of a Compound. + * + * @return a debug-friendly representation of a Compound + * @deprecated + */ + public String debugString() { + return "(Compound " + name + " " + Term.debugString(args) + ")"; + } + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + /** + * To put a Compound in a term, we create a sequence of term_t + * references from the Term.terms_to_term_ts() method, and then + * use the Prolog.cons_functor_v() method to create a Prolog compound + * term. + * + * @param varnames_to_vars A Map from variable names to Prolog variables + * @param term A (previously created) term_t which is to be + * set to a Prolog term corresponding to the Term subtype + * (Atom, Variable, Compound, etc.) on which the method is invoked. + */ + protected final void put(Map varnames_to_vars, term_t term) { + Prolog.cons_functor_v(term, Prolog.new_functor(Prolog.new_atom(name), args.length), Term.putTerms(varnames_to_vars, args)); + } + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + /** + * Converts the Prolog term in term_t (known to be a compound) to a JPL Compound. + * In this case, we create a list of Terms by calling Term.getTerm for each + * term_t reference we get from Prolog.get_arg + * (Not sure why we couldn't get a sequence from there, but...). + * + * @param varnames_to_vars A Map from variable names to Prolog variables + * @param term The Prolog term to convert + * @return A new Compound + */ + protected static Term getTerm1(Map varnames_to_vars, term_t term) { + // ObjectHolder jthing_holder = new ObjectHolder(); + StringHolder name_holder = new StringHolder(); + IntHolder arity_holder = new IntHolder(); + Prolog.get_name_arity(term, name_holder, arity_holder); // assume it succeeds + Term args[] = new Term[arity_holder.value]; + for (int i = 1; i <= arity_holder.value; i++) { + term_t termi = Prolog.new_term_ref(); + Prolog.get_arg(i, term, termi); + args[i - 1] = Term.getTerm(varnames_to_vars, termi); + } + return new Compound(name_holder.value, args); + } + //==================================================================/ + // Computing Substitutions + //==================================================================/ + /** + * Nothing needs to be done except to pass the buck to this Compound's args. + * + * @param varnames_to_Terms A Map from variable names to JPL Terms + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + Term.getSubsts(varnames_to_Terms, vars_to_Vars, args); + } + public boolean hasFunctor(int value, int arity) { + return false; + } + public boolean hasFunctor(double value, int arity) { + return false; + } +} +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/Float.java b/packages/jpl/jpl/src/java/jpl/Float.java new file mode 100644 index 000000000..db6b2824f --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Float.java @@ -0,0 +1,298 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; + +import jpl.fli.DoubleHolder; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Float +/** + * Float is a specialised Term with a double field, representing a Prolog 64-bit ISO/IEC floating point value. + * Once constructed, a Float's value cannot be altered. + * 
    + * Float f = new Float( 3.14159265 );
+ *
    + * A Float can be used (and re-used) in Compound Terms. + * Two Float instances are equal (by .equals()) iff their (double) values are equal. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + */ +public class Float extends Term { + + //==================================================================/ + // Attributes + //==================================================================/ + + /** + * the Float's immutable value + */ + protected final double value; + + //==================================================================/ + // Constructors and Initialization + //==================================================================/ + + /** + * This constructor creates a Float with the supplied + * (double) value. + * + * @param value this Float's value + */ + public Float(double value) { + this.value = value; + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + /** + * throws a JPLException (arg(int) is defined only for Compound and Atom) + * + * @return the ith argument (counting from 1) of this Float (never) + */ + public final Term arg(int i) { + throw new JPLException("jpl.Float#arg(int) is undefined"); + } + + /** + * The (nonexistent) args of this Float + * + * @return the (nonexistent) args of this Float + */ + public Term[] args() { + return new Term[] {}; + } + + /** + * Tests whether this Float's functor has (String) 'name' and 'arity' (never) + * + * @return whether this Float's functor has (String) 'name' and 'arity' (never) + */ + public final boolean hasFunctor(String name, int arity) { + return false; + } + + /** + * Tests whether this Float's functor has (int) 'name' and 'arity' (never) + * + * @return whether this Float's functor has (int) 'name' and 'arity' (never) + */ + public final boolean hasFunctor(int val, int arity) { + return false; + } + + /** + * Tests whether this Float's functor has (double) 'name' and 'arity' + * + * @return whether this Float's functor has (double) 'name' and 'arity' + */ + public final boolean hasFunctor(double val, int arity) { + return val == this.value && arity == 0; + } + + /** + * throws a JPLException (name() is defined only for Compound, Atom and Variable) + * + * @return the name of this Float (never) + */ + public final String name() { + throw new JPLException("jpl.Float#name() is undefined"); + } + + /** + * Returns the arity (0) of this Float + * + * @return the arity (0) of this Float + */ + public final int arity() { + return 0; + } + + /** + * returns the (double) value of this Float, converted to an int + * + * @return the (double) value of this Float, converted to an int + */ + public final int intValue() { + return (new Double(value)).intValue(); + } + + /** + * returns the (double) value of this Float, converted to a long + * + * @return the (double) value of this Float, converted to a long + */ + public final long longValue() { + return (new Double(value)).longValue(); + } + + /** + * returns the (double) value of this Float, converted to a float + * + * @return the (double) value of this Float, converted to a float + */ + public final float floatValue() { + return (new Double(value)).floatValue(); + } + + /** + * returns the (double) value of this Float + * + * @return the (double) value of this Float + */ + public final double doubleValue() { + return this.value; + } + + public final int type() { + return Prolog.FLOAT; + } + + public String typeName(){ + return "Float"; + } + + /** + * Returns a Prolog source text representation of this Float + * + * @return a Prolog source text representation of this Float + */ + public String toString() { + return "" + value + ""; + } + + /** + * Two Floats are equal if they are the same object, or their values are equal + * + * @param obj The Object to compare + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return this == obj || (obj instanceof Float && value == ((Float) obj).value); + } + + public Object jrefToObject() { + throw new JPLException("Float.jrefToObject: term is not a JRef"); + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * The immutable value of this jpl.Float object, as a Java double + * + * @return the Float's value + * @deprecated + */ + public double value() { + return value; + } + + /** + * Returns a debug-friendly String representation of this Float + * + * @return a debug-friendly String representation of this Float + * @deprecated + */ + public String debugString() { + return "(Float " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + /** + * To convert a JPL Float to a Prolog term, we put its value field into the + * term_t as a float. + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (previously created) term_t which is to be + * set to a Prolog float corresponding to this Float's value + */ + protected final void put(Map varnames_to_vars, term_t term) { + Prolog.put_float(term, value); + } + + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + + /** + * Converts a Prolog term (known to be a float) to a JPL Float. + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + * @param term The Prolog term (a float) to convert + * @return A new Float instance + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + DoubleHolder double_holder = new DoubleHolder(); + + Prolog.get_float(term, double_holder); // assume it succeeds... + return new jpl.Float(double_holder.value); + } + + //==================================================================/ + // Computing Substitutions + //==================================================================/ + + /** + * Nothing needs to be done if the Term is an Atom, Integer or (as in this case) a Float + * + * @param varnames_to_Terms A Map from variable names to JPL Terms + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/Integer.java b/packages/jpl/jpl/src/java/jpl/Integer.java new file mode 100644 index 000000000..615c675db --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Integer.java @@ -0,0 +1,299 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; +import jpl.fli.Int64Holder; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Integer +/** + * Integer is a specialised Term with a long field, representing a Prolog integer value. + * 
    + * Integer i = new Integer(1024);
+ *
    + * Once constructed, the value of an Integer instance cannot be altered. + * An Integer can be used (and re-used) as an argument of Compounds. + * Beware confusing jpl.Integer with java.lang.Integer. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + */ +public class Integer extends Term { + + //==================================================================/ + // Attributes + //==================================================================/ + + /** + * the Integer's immutable long value + */ + protected final long value; + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * @param value This Integer's (long) value + */ + public Integer(long value) { + this.value = value; + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + /** + * The (nonexistent) ano-th arg of this Integer + * + * @return the (nonexistent) ano-th arg of this Integer + */ + public Term arg(int ano) { + throw new JPLException("jpl." + this.typeName() + ".arg() is undefined"); + } + + /** + * The (nonexistent) args of this Integer + * + * @return the (nonexistent) args of this Integer + */ + public Term[] args() { + return new Term[] { + }; + } + + /** + * Tests whether this Integer's functor has (int) 'name' and 'arity' (c.f. functor/3) + * + * @return whether this Integer's functor has (int) 'name' and 'arity' + */ + public final boolean hasFunctor(int val, int arity) { + return val == this.value && arity == 0; + } + + /** + * Tests whether this Integer's functor has (String) 'name' and 'arity' (c.f. functor/3) + * + * @return whether this Integer's functor has (String) 'name' and 'arity' + */ + public boolean hasFunctor(String name, int arity) { + return false; + } + + /** + * Tests whether this Integer's functor has (double) 'name' and 'arity' (c.f. functor/3) + * + * @return whether this Integer's functor has (double) 'name' and 'arity' + */ + public boolean hasFunctor(double value, int arity) { + return false; + } + + /** + * throws a JPLException (name() is defined only for Compound, Atom and Variable) + * + * @return the name of this Integer (never) + */ + public final String name() { + throw new JPLException("jpl.Integer#name() is undefined"); + } + + /** + * Returns the arity (0) of this jpl.Integer (c.f. functor/3) + * + * @return the arity (0) of this jpl.Integer + */ + public final int arity() { + return 0; + } + + /** + * Returns the value of this Integer as an int if possible, else throws a JPLException + * + * @throws JPLException if the value of this Integer is too great to be represented as a Java int + * @return the int value of this Integer + */ + public final int intValue() { + if (value < java.lang.Integer.MIN_VALUE || value > java.lang.Integer.MAX_VALUE) { + throw new JPLException("cannot represent Integer value as an int"); + } else { + return (int) value; + } + } + + /** + * Returns the value of this Integer as a long + * + * @return the value of this Integer as a long + */ + public final long longValue() { + return value; + } + + /** + * Returns the value of this Integer converted to a float + * + * @return the value of this Integer converted to a float + */ + public final float floatValue() { + return (new java.lang.Long(value)).floatValue(); // safe but inefficient... + } + + /** + * Returns the value of this Integer converted to a double + * + * @return the value of this Integer converted to a double + */ + public final double doubleValue() { + return (new java.lang.Long(value)).doubleValue(); // safe but inefficient... + } + + public final int type() { + return Prolog.INTEGER; + } + + public String typeName(){ + return "Integer"; + } + + /** + * Returns a Prolog source text representation of this Integer's value + * + * @return a Prolog source text representation of this Integer's value + */ + public String toString() { + return "" + value; // hopefully invokes Integer.toString() or equivalent + } + + /** + * Two Integer instances are equal if they are the same object, or if their values are equal + * + * @param obj The Object to compare (not necessarily an Integer) + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return this == obj || (obj instanceof Integer && value == ((Integer) obj).value); + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * Returns the int value of this jpl.Integer + * + * @return the Integer's value + * @deprecated + */ + public final int value() { + return (int) value; + } + + /** + * Returns a debug-friendly representation of this Integer's value + * + * @return a debug-friendly representation of this Integer's value + * @deprecated + */ + public String debugString() { + return "(Integer " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + /** + * To convert an Integer into a Prolog term, we put its value into the term_t. + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (previously created) term_t which is to be + * set to a Prolog integer + */ + protected final void put(Map varnames_to_vars, term_t term) { + Prolog.put_integer(term, value); + } + + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + + /** + * Converts a Prolog term (known to be an integer) to a new Integer instance. + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + * @param term The Prolog term (an integer) which is to be converted + * @return A new Integer instance + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + Int64Holder int64_holder = new Int64Holder(); + + Prolog.get_integer(term, int64_holder); // assume it succeeds... + return new jpl.Integer(int64_holder.value); + } + + //==================================================================/ + // Computing Substitutions + //==================================================================/ + + /** + * Nothing needs to be done if the Term is an Atom, Integer or Float + * + * @param varnames_to_Terms A Map from variable names to Terms. + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + } + + public Object jrefToObject() { + throw new JPLException("Integer.jrefToObject(): term is not a jref"); + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/JPL.java b/packages/jpl/jpl/src/java/jpl/JPL.java new file mode 100644 index 000000000..8ea6c5d35 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/JPL.java @@ -0,0 +1,243 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.io.File; +import jpl.fli.Prolog; + +//----------------------------------------------------------------------/ +// JPL +/** + * The jpl.JPL class contains methods which allow (i) inspection and alteration + * of the "default" initialisation arguments (ii) explicit initialisation + * (iii) discovery of whether the Prolog engine is already initialised, + * and if so, with what arguments. + * The Prolog engine must be initialized + * before any queries are made, but this will happen automatically + * (upon the first call to a Prolog FLI routine) if it has not already + * been done explicitly. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public class JPL { + protected static final boolean DEBUG = false; + // + public static final Term JFALSE = new Compound("@", new Term[] {new Atom("false")}); + public static final Term JTRUE = new Compound("@", new Term[] {new Atom("true")}); + public static final Term JNULL = new Compound("@", new Term[] {new Atom("null")}); + public static final Term JVOID = new Compound("@", new Term[] {new Atom("void")}); + + protected static boolean modeDontTellMe = true; + + private static String nativeLibraryName = "jpl"; + private static String nativeLibraryDir = null; + private static String nativeLibraryPath = null; + public static String setNativeLibraryName(String newName) { + if (newName == null) { + throw new NullPointerException("newName cannot be null"); + } else { + String oldName = nativeLibraryName; + nativeLibraryName = newName; + return oldName; + } + } + public static String setNativeLibraryDir(String newDir) { + String oldDir = nativeLibraryDir; + nativeLibraryDir = newDir; + return oldDir; + } + public static String setNativeLibraryPath(String newPath) { + String oldPath = nativeLibraryPath; + nativeLibraryPath = newPath; + return oldPath; + } + public static void loadNativeLibrary() { + if (nativeLibraryPath != null) { + System.load((new File(nativeLibraryPath)).getAbsolutePath()); + } else if (nativeLibraryDir != null) { + System.load((new File(nativeLibraryDir, System.mapLibraryName(nativeLibraryName))).getAbsolutePath()); + } else { + System.loadLibrary(nativeLibraryName); // as resolved somewhere on system property 'java.library.path' + } + } + // setDTMMode + /** + * Sets the global "dont-tell-me" mode (default value: true). + * When 'true', bindings will *not* be returned for any variable (in a Query's goal) + * whose name begins with an underscore character (except for "anonymous" variables, + * i.e. those whose name comprises just the underscore character, whose bindings are never returned). + * When 'false', bindings are returned for *all* variables except anonymous ones; + * this mode may be useful when traditional top-level interpreter behaviour is wanted, + * e.g. in a Java-based Prolog IDE or debugger. + * This method should be regarded as experimental, and may subsequently be deprecated + * in favour of some more general mechanism for setting options, perhaps per-Query and + * per-call as well as globally. + * + * @param dtm new "dont-tell-me" mode value + */ + public static void setDTMMode( boolean dtm){ + modeDontTellMe = dtm; + } + + // getDefaultInitArgs + /** + * Returns, in an array of String, the sequence of command-line + * arguments that would be used if the Prolog engine were to be initialised now. + * Returns null if the Prolog VM has already been initialised (in which + * case the default init args are irrelevant and the actual init args are of interest) + * + * @see jpl.JPL#getActualInitArgs + * @return current default initialisation arguments, or null if already initialised + */ + public static String[] getDefaultInitArgs() { + return Prolog.get_default_init_args(); + } + + // setDefaultInitArgs + /** + * Specifies, in an array of String, the sequence of command-line + * arguments that should be used if the Prolog engine is subsequently initialised. + * + * @param args new default initialization arguments + */ + public static void setDefaultInitArgs(String[] args) { + Prolog.set_default_init_args(args); + } + + // getActualInitArgs + /** + * Returns, in an array of String, the sequence of command-line + * arguments that were actually used when the Prolog engine was formerly initialised. + * + * This method returns null if the Prolog engine has not yet been initialised, + * and thus may be used to test this condition. + * + * @return actual initialization arguments + */ + public static String[] getActualInitArgs() { + return Prolog.get_actual_init_args(); + } + + // init + /** + * Initializes the Prolog engine, using the String argument + * parameters passed. This method need be called only if you want to both + * (i) initialise the Prolog engine with parameters other than the default ones + * and (ii) force initialisation to occur + * (rather than allow it to occur automatically at the first query). + * For parameter options, consult your local + * Prolog documentation. The parameter values are passed directly + * to initialization routines for the Prolog environment. + * + * This method must be called before making any queries. + * + * @param args Initialization parameter list + */ + public static boolean init(String[] args) { + return Prolog.set_default_init_args(args) && init(); + } + + // init + /** + * Initialises the Prolog engine using the current default initialisation parameters, + * and returns 'true' (or 'false' if already initialised). + */ + public static boolean init() { + return Prolog.initialise(); + } + + // isTag(String) + /** + * whether the String arg is a plausible tag, e.g. "J#0123456789". + */ + public static boolean isTag(String s) { + return s.length()==22 && s.charAt(0)=='J' && s.charAt(1)=='#' && Character.isDigit(s.charAt(2)) && Character.isDigit(s.charAt(3)) && Character.isDigit(s.charAt(4)) && Character.isDigit(s.charAt(5)) && Character.isDigit(s.charAt(6)) && Character.isDigit(s.charAt(7)) && Character.isDigit(s.charAt(8)) && Character.isDigit(s.charAt(9)) && Character.isDigit(s.charAt(10)) && Character.isDigit(s.charAt(11)) && Character.isDigit(s.charAt(12)) && Character.isDigit(s.charAt(13)) && Character.isDigit(s.charAt(14)) && Character.isDigit(s.charAt(15)) && Character.isDigit(s.charAt(16)) && Character.isDigit(s.charAt(17)) && Character.isDigit(s.charAt(18)) && Character.isDigit(s.charAt(19)) && Character.isDigit(s.charAt(20)) && Character.isDigit(s.charAt(21)); + } + + // newJRef(Object) + /** + * returns a new Term instance which represents the given object + */ + public static Term newJRef(Object obj) { + return new Compound( "@", new Term[]{new Atom(Prolog.object_to_tag(obj))}); + } + + // halt + /** + * Terminates the Prolog session. + * + * Note. This method calls the FLI halt() method with a + * status of 0, but the halt method currently is a no-op in SWI. + * @deprecated + */ + public static void halt() { + Prolog.halt(0); + } + + // a static reference to the current Version + private static final Version version_ = new Version(); + + // version + /** + * Returns (as a Version) an identification of this version of JPL. + * @return the running version of JPL. + */ + public static Version version() { + return version_; + } + + // version_string + /** + * Returns a String (eg "3.0.0-alpha") identifying this version of JPL. + * @return a String (eg "3.0.0-alpha") identifying this version of JPL. + */ + public static String version_string() { + return version_.major + "." + version_.minor + "." + version_.patch + "-" + version_.status; + } + + public static void main(String[] args) { + System.out.println(version_string()); + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/JPLException.java b/packages/jpl/jpl/src/java/jpl/JPLException.java new file mode 100644 index 000000000..7782516ee --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/JPLException.java @@ -0,0 +1,63 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +//----------------------------------------------------------------------/ +// JPLException +/** + * This is the base class for exceptions thrown by JPL's Java-calls-Prolog interface. + * Such exceptions represent errors and exceptional conditions within the interface code itself; + * see jpl.PrologException for the way Prolog exceptions are returned to calling Java code. + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public class JPLException extends RuntimeException { + private static final long serialVersionUID = 1L; + + public JPLException() { + super(); + } + + public JPLException(String s) { + super(s); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/JRef.java b/packages/jpl/jpl/src/java/jpl/JRef.java new file mode 100644 index 000000000..3f7f52559 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/JRef.java @@ -0,0 +1,215 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// JRef +/** + * JRef is a specialised Term with an Object field, representing JPL's Prolog references to Java objects (or to null). + * 
    + * JRef r = new JRef( non_String_object_or_null );
+ *
    + * A JRef can be used (and re-used) in Compound Terms. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + * + * @deprecated + */ +public class JRef extends Term { + + //==================================================================/ + // Attributes + //==================================================================/ + + /** + * the JRef's value (a non-String Object or null) + */ + protected final Object ref; + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * This constructor creates a JRef, initialized with the supplied + * non-String object (or null). + * + * @param ref this JRef's value (a non-String object, or null) + */ + public JRef(Object ref) { + if (ref instanceof String) { + throw new JPLException("a JRef cannot have a String value (String maps to atom)"); + } else { + this.ref = ref; + } + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + public Term arg(int ano) { + return (ano == 1 ? new Atom(jpl.fli.Prolog.object_to_tag(ref)) : null); + } + + /** + * Returns a Prolog source text representation of this JRef + * + * @return a Prolog source text representation of this JRef + */ + public String toString() { + return "" + ref + ""; // WRONG + } + + /** + * Two JRefs are equal if their references are identical (?) + * + * @param obj The Object to compare + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return this == obj || (obj instanceof JRef && ref == ((JRef) obj).ref); + } + + public final int type() { + return Prolog.JREF; + } + + public String typeName(){ + return "JRef"; + } + + //==================================================================/ + // Methods (peculiar) + //==================================================================/ + + /** + * The non-String object (or null) which this jpl.JRef represents + * + * @return the non-String object (or null) which this jpl.JRef represents + */ + public Object ref() { + return ref; + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * The (nonexistent) args of this JRef + * + * @return the (nonexistent) args of this JRef + * @deprecated + */ + public Term[] args() { + return new Term[] { + }; + } + + /** + * Returns a debug-friendly representation of this JRef + * + * @return a debug-friendly representation of this JRef + * @deprecated + */ + public String debugString() { + return "(JRef " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + /** + * To convert a JRef to a term, we put its Object field (.value) into the + * term_t as a JPL ref (i.e. @/1) structure. + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (newly created) term_t which is to be + * set to a Prolog 'ref' (i.e. @/1) structure denoting the + * .value of this JRef instance + */ + protected final void put(Map varnames_to_vars, term_t term) { + + Prolog.put_jref(term, ref); + } + + //==================================================================/ + // Computing Substitutions + //==================================================================/ + + /** + * Nothing needs to be done if the Term is an Atom, Integer, Float or JRef + * + * @param varnames_to_Terms A Map from variable names to Terms. + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + } + + public boolean hasFunctor(String name, int arity) { + return name != null && name.equals("@") && arity == 1; + } + + public boolean hasFunctor(int value, int arity) { + return false; + } + + public boolean hasFunctor(double value, int arity) { + return false; + } + + public Object jrefToObject() { + return ref; + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/PrologException.java b/packages/jpl/jpl/src/java/jpl/PrologException.java new file mode 100644 index 000000000..d990923b7 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/PrologException.java @@ -0,0 +1,75 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +//----------------------------------------------------------------------/ +// PrologException +/** + * PrologException instances wrap Prolog exceptions thrown (either by a Prolog engine or by user code) + * in the course of finding a solution to a Query. See JPLException for the handling of errors within the JPL Java-calls-Prolog interface. + * + * This class allows Java code which uses JPL's Java-calls-Prolog API to handle + * Prolog exceptions, which is in general necessary for hybrid Java+Prolog programming. + * + * Use the term() accessor to obtain a Term representation of the term that was + * thrown from within Prolog. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public final class PrologException extends JPLException { + private static final long serialVersionUID = 1L; + private Term term_ = null; + + protected PrologException(Term term) { + super("PrologException: " + term.toString()); + + this.term_ = term; + } + + /** + * @return a reference to the Term thrown by the call to throw/1 + */ + public Term term() { + return this.term_; + } +} diff --git a/packages/jpl/jpl/src/java/jpl/Query.java b/packages/jpl/jpl/src/java/jpl/Query.java new file mode 100644 index 000000000..75fea1ec6 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Query.java @@ -0,0 +1,873 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Enumeration; +import java.util.Hashtable; +import java.util.Map; +import java.util.Vector; +import jpl.fli.*; + +//----------------------------------------------------------------------/ +// Query +/** + * A Query instance is created by an application in order to query the Prolog database + * (or to invoke a built-in predicate). + * It is initialised with a + * Compound (or Atom) denoting the goal which is to be called, and also contains assorted private state + * relating to solutions. In some future version, it may contain details of the module + * in which the goal is to be called. + * A Query is either open or closed: when closed, it has no connection to the Prolog system; + * when open, it is linked to an active goal within a Prolog engine. + * The Query class implements the Enumeration interface, + * through which one can obtain successive solutions. The Enumeration + * hasMoreElements() method returns true if the call or redo succeeded (otherwise + * false), and if the call or redo did succeed, the nextElement() method returns + * a Hashtable representing variable bindings; the elements in the + * Hashtable are Terms, indexed by the (String) names of the Variables with which they are associated. + * For example, if p(a) and p(b) are facts in the Prolog + * database, then the following is equivalent to printing all + * the solutions to the Prolog query p(X): + * 
    + * Variable X = new Variable("X");
+ * Term arg[] = { X };
+ * Query    q = new Query("p", arg);
+ * 
+ * while (q.hasMoreElements()){
+ *     Term bound_to_x = ((Hashtable) q.nextElement()).get("X");
+ *     System.out.println(bound_to_x);
+ * }
+ *
    + * Make sure to close the Query (using the close() method) if you do not need + * any further solutions which it may have. + * It is safe (although redundant) to close a Query whose solutions are already exhausted, + * or which is already closed. + * + * To obtain just one solution from a Query, use the oneSolution() method. + * + * To obtain all solutions, use the allSolutions() method. + * + * To obtain at most N solutions, use the nSolutions() method. + * + * To determine merely whether the Query is provable, + * use the hasSolution() method + * (i.e. has at least one solution). + * + * + * Copyright (C) 2007 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class Query implements Enumeration { + //==================================================================/ + // Attributes + //==================================================================/ + private static Map m = new Hashtable(); // maps (engine_t) engine handle to (Query) topmost query + /** + * the Compound (hence perhaps an Atom, but not Integer, Float or Variable) corresponding to the goal of this Query + */ + protected final Compound goal_; // set by all initialisers + protected final String hostModule = "user"; // until revised constructors allow this to be specified + protected final String contextModule = "user"; // until revised constructors allow this to be specified + /** + * @deprecated Use .goal().name() instead. + * @return the name of this Query's goal (redundant, deprecated) + */ + public final String name() { + return goal_.name(); // it can only be a Compound or Atom + } + /** + * @deprecated Use .goal().args() instead. + * @return the arguments of this Query's goal (redundant, deprecated) + */ + public final Term[] args() { + return goal_.args(); + } + /** + * Returns the Compound (hence perhaps an Atom) which is the goal of this Query + * @return a Term representing the goal of this Query + */ + public final Compound goal() { + return goal_; + } + //==================================================================/ + // Constructors and Initialization + //==================================================================/ + //------------------------------------------------------------------/ + // Query + /** + * This constructor creates a Query whose goal is the specified Term. + * The Query is initially closed. + * NB Creating an instance of the Query class does not + * result in a call to a Prolog engine. + * NB The goal can be a Compound or an Atom (Atom extends Compound), but cannot be an instance + * of jpl.Float, jpl.Integer or jpl.Variable. + * @param t the goal of this Query + */ + public Query(Term t) { // formerly insisted (confusingly) on a Compound (or Atom) + this.goal_ = Query1(t); + } + private Compound Query1(Term t) { + if (t instanceof Compound) { + return (Compound) t; + } else if (t instanceof Integer) { + throw new JPLException("a Query's goal must be an Atom or Compound (not an Integer)"); + } else if (t instanceof Float) { + throw new JPLException("a Query's goal must be an Atom or Compound (not a Float)"); + } else if (t instanceof Variable) { + throw new JPLException("a Query's goal must be an Atom or Compound (not a Variable)"); + } else { + throw new JPLException("a Query's goal must be an Atom or Compound"); + } + } + // Query + /** + * If text denotes an atom, this constructor is shorthand for + * new Query(new Compound(name,args)), + * but if text denotes a term containing N query (?) symbols + * and there are N args, each query is replaced by its corresponding arg + * to provide the new Query's goal. + * + * @param text the name of the principal functor of this Query's goal + * @param args the arguments of this Query's goal + */ + public Query(String text, Term[] args) { + this(Query1(text, args)); + } + // convenience case for a single arg + public Query(String text, Term arg) { + this(Query1(text, new Term[] { arg })); + } + private static Term Query1(String text, Term[] args) { + Term t = Util.textToTerm(text); + if (t instanceof Atom) { + return new Compound(text, args); + } else { + return t.putParams(args); + } + } + // Query + /** + * This constructor builds a Query from the given Prolog source text. + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text the Prolog source text of this Query + */ + public Query(String text) { + this(Util.textToTerm(text)); + } + //==================================================================/ + // Making Prolog Queries + //==================================================================/ + /** + * These variables are used and set across the hasMoreElements + * and nextElement Enumeration interface implementation + */ + private boolean open = false; + // the following state variables are used and defined only if this query is open: + // private boolean called = false; // open/get/close vs. hasMoreSolutions/nextSolution + private engine_t engine = null; // handle of attached Prolog engine iff open, else null + private Query subQuery = null; // the open Query (if any) on top of which this open Query is stacked, else null + private predicate_t predicate = null; // handle of this Query's predicate iff open, else undefined + private fid_t fid = null; // id of current Prolog foreign frame iff open, else null + private term_t term0 = null; // term refs of this Query's args iff open, else undefined + private qid_t qid = null; // id of current Prolog query iff open, else null + // + /** + * isOpen() returns true iff the query is open. + * @return true if the query is open, otherwise false. + */ + public synchronized final boolean isOpen() { + return open; + } + //------------------------------------------------------------------/ + // hasMoreSolutions + /** + * This method returns true if JPL was able to initiate a "call" of this + * Query within a Prolog engine. It is designed to be used + * with the nextSolution() method to retrieve one or + * more substitutions in the form of Hashtables. To iterate through + * all the solutions to a Query, for example, one might write + * 
    +	 * Query q = // obtain Query reference
+	 * while (q.hasMoreSolutions()) {
+	 *     Hashtable solution = q.nextSolution();
+	 *     // process solution...
+	 * }
+	 *
    + * To ensure thread-safety, you should wrap sequential calls to + * this method in a synchronized block, using the static + * lock method to obtain the monitor. + * 
    +	 * Query q = // obtain Query reference
+	 * synchronized ( jpl.Query.lock() ){
+	 *     while ( q.hasMoreElements() ){
+	 *          Hashtable solution = q.nextSolution();
+	 *          // process solution...
+	 *     }
+	 * }
+	 *
    + * + * @return true if the Prolog query succeeds; otherwise false. + */ + public synchronized final boolean hasMoreSolutions() { + if (!open) { + open(); + } + return get1(); + } + //------------------------------------------------------------------/ + // open + /** + * This method returns true if JPL was able to initiate a "call" of this + * Query within the Prolog engine. It is designed to be used + * with the getSolution() and close() methods to retrieve one or + * more substitutions in the form of Hashtables. + * 
    +	 * Query q = // obtain Query reference
+	 * Hashtable soln;
+	 * q.open();
+	 * while ((soln = q.getSolution()) != null) {
+	 *      // process solution...
+	 * }
+	 *
    + * + * If this method is called on an already-open Query, + * or if the query cannot be set up for whatever reason, + * then a JPLException will be thrown. + */ + public synchronized final void open() { + if (open) { + throw new JPLException("Query is already open"); + } + // int self = Prolog.thread_self(); + // System.out.println("JPL thread_self()=" + self); + if (Prolog.thread_self() == -1) { // this Java thread has no attached Prolog engine? + engine = Prolog.attach_pool_engine(); // may block for a while, or fail + // System.out.println("JPL attaching engine[" + engine.value + "] for " + this.hashCode() + ":" + this.toString()); + } else { // this Java thread has an attached engine + engine = Prolog.current_engine(); + // System.out.println("JPL reusing engine[" + engine.value + "] for " + this.hashCode() + ":" + this.toString()); + } + if (m.containsKey(new Long(engine.value))) { + subQuery = (Query) m.get(new Long(engine.value)); // get this engine's previous topmost query + // System.out.println("JPL reusing engine[" + engine.value + "] pushing " + subQuery.hashCode() + ":" + subQuery.toString()); + } else { + subQuery = null; + } + m.put(new Long(engine.value), this); // update this engine's topmost query + // + // here, we must check for a module prefis, e.g. jpl:jpl_modifier_bit(volatile,T) + String module; + Term goal; + if (goal_.hasFunctor(":", 2)) { + if (goal_.arg(1).isAtom()) { + module = goal_.arg(1).name(); + } else if (goal_.arg(1).isVariable()) { + throw new PrologException(Util.textParamsToTerm("error(instantiation_error,?)", new Term[] { goal_ })); + } else { + throw new PrologException(Util.textParamsToTerm("error(type_error(atom,?),?)", new Term[] { goal_.arg(1), goal_ })); + } + goal = goal_.arg(2); + } else { + module = contextModule; + goal = goal_; + } + predicate = Prolog.predicate(goal.name(), goal.arity(), module); // was hostModule + fid = Prolog.open_foreign_frame(); + Map varnames_to_vars = new Hashtable(); + term0 = Term.putTerms(varnames_to_vars, goal.args()); + // THINKS: invert varnames_to_Vars and use it when getting substitutions? + qid = Prolog.open_query(Prolog.new_module(Prolog.new_atom(contextModule)), Prolog.Q_CATCH_EXCEPTION, predicate, term0); + open = true; + // called = false; + } + private final boolean get1() { // try to get the next solution; if none, close the query; + if (Prolog.next_solution(qid)) { + // called = true; // OK to call get2() + return true; + } else { + // if failure was due to throw/1, build exception term and throw it + term_t exception_term_t = Prolog.exception(qid); + if (exception_term_t.value != 0L) { + Term exception_term = Term.getTerm(new Hashtable(), exception_term_t); + close(); + throw new PrologException(exception_term); + } else { + close(); + return false; + } + } + } + //------------------------------------------------------------------/ + // getSolution + /** + * This method returns a java.util.Hashtable, which represents + * a set of bindings from the names of query variables to terms within the solution. + * + * For example, if a Query has an occurrence of a jpl.Variable, + * say, named "X", one can obtain the Term bound to "X" in the solution + * by looking up "X" in the Hashtable. + * 
    +	 * Variable x = new Variable("X");
+	 * Query q = // obtain Query reference (with x in the Term array)
+	 * while (q.hasMoreSolutions()) {
+	 *     Hashtable solution = q.nextSolution();
+	 *     // make t the Term bound to "X" in the solution
+	 *     Term t = (Term) solution.get("X");
+	 *     // ...
+	 * }
+	 *
    + * Programmers should obey the following rules when using this method. + * + *
  • The nextSolution() method should only be called after the + * hasMoreSolutions() method returns true; otherwise a JPLException + * will be raised, indicating that the Query is no longer open. + *
  • The nextSolution() and hasMoreSolutions() should be called + * in the same thread of execution, for a given Query + * instance. + *
    • + * + * This method will throw a JPLException if Query is not open. + * + * @return A Hashtable representing a substitution, or null + */ + public synchronized final Hashtable getSolution() { + // oughta check: thread has query's engine + if (!open) { + throw new JPLException("Query is not open"); + } else if (get1()) { + return get2(); + } else { + return null; + } + } + public synchronized final Hashtable getSubstWithNameVars() { + // oughta check: thread has query's engine + if (!open) { + throw new JPLException("Query is not open"); + } else if (get1()) { + return get2WithNameVars(); + } else { + return null; + } + } + //------------------------------------------------------------------/ + // nextSolution + /** + * This method returns a java.util.Hashtable, which represents + * a binding from the names of query variables to terms within the solution. + * + * For example, if a Query has an occurrence of a jpl.Variable, + * say, named "X", one can obtain the Term bound to "X" in the solution + * by looking up "X" in the Hashtable. + * 
    +	 * Variable x = new Variable("X");
+	 * Query q = // obtain Query reference (with x in the Term array)
+	 * while (q.hasMoreSolutions()) {
+	 *     Hashtable solution = q.nextSolution();
+	 *     // make t the Term bound to "X" in the solution
+	 *     Term t = (Term) solution.get("X");
+	 *     // ...
+	 * }
+	 *
    + * Programmers should obey the following rules when using this method. + * + *
  • The nextSolution() method should only be called after the + * hasMoreSolutions() method returns true; otherwise a JPLException + * will be raised, indicating that the Query is no longer open. + *
  • The nextSolution() and hasMoreSolutions() should be called + * in the same thread of execution, for a given Query + * instance. + *
    • + * + * This method will throw a JPLException if Query is not open. + * + * @return A Hashtable representing a substitution. + */ + public synchronized final Hashtable nextSolution() { + return get2(); + } + private final Hashtable get2() { + if (!open) { + throw new JPLException("Query is not open"); + } else { + Hashtable substitution = new Hashtable(); + // NB I reckon computeSubstitutions needn't be in Term (but where else?) + Term.getSubsts(substitution, new Hashtable(), goal_.args); + return substitution; + } + } + // assumes that Query's last arg is a Variable which will be bound to a [Name=Var,..] dict + private final Hashtable get2WithNameVars() { + if (!open) { + throw new JPLException("Query is not open"); + } else { + Term[] args = goal_.args; // for slight convenience below + Term argNV = args[args.length - 1]; // the Query's last arg + String nameNV = ((Variable) argNV).name; // its name + // get the [Name=Var,..] dict from the last arg + Map varnames_to_Terms1 = new Hashtable(); + Map vars_to_Vars1 = new Hashtable(); + args[args.length - 1].getSubst(varnames_to_Terms1, vars_to_Vars1); + Hashtable varnames_to_Terms2 = new Hashtable(); + Term nvs = (Term) varnames_to_Terms1.get(nameNV); + Map vars_to_Vars2 = Util.namevarsToMap(nvs); + for (int i = 0; i < args.length - 1; ++i) { + args[i].getSubst(varnames_to_Terms2, vars_to_Vars2); + } + return varnames_to_Terms2; + } + } + //------------------------------------------------------------------/ + // hasMoreElements + /** + * This method implements part of the java.util.Enumeration + * interface. It is a wrapper for hasMoreSolutions. + * + * @return true if the Prolog query yields a (or another) solution, else false. + */ + public synchronized final boolean hasMoreElements() { + return hasMoreSolutions(); + } + //------------------------------------------------------------------/ + // nextElement + /** + * This method implements part of the java.util.Enumeration + * interface. It is a wrapper for nextSolution. + * + * + * @return A Hashtable representing a substitution. + */ + public synchronized final Object nextElement() { + return nextSolution(); + } + public synchronized final void rewind() { + close(); + } + /** + * This method can be used to close an open query before its solutions are exhausted. + * It is called automatically when solutions are exhausted, i.e. when hasMoreSolutions() fails. + * Calling close() on an already closed Query is harmless (has no effect). + * + * Here is one way to get the first three solutions to a Query: + * 
    +	 * Query q = new Query(predicate, args);
+	 * Hashtable sub1 = (Hashtable) q.nextSolution();
+	 * Hashtable sub2 = (Hashtable) q.nextSolution();
+	 * Hashtable sub3 = (Hashtable) q.nextSolution();
+	 * q.close();
+	 *
    + */ + public synchronized final void close() { + if (!open) { + return; // it is not an error to attempt to close a closed Query + } + if (Prolog.thread_self() == -1) { + throw new JPLException("no engine is attached to this thread"); + } + if (Prolog.current_engine().value != engine.value) { + throw new JPLException("this Query's engine is not that which is attached to this thread"); + } + Query topmost = (Query) m.get(new Long(engine.value)); + if (topmost != this) { + throw new JPLException("this Query (" + this.hashCode() + ":" + this.toString() + ") is not topmost (" + topmost.hashCode() + ":" + topmost.toString() + ") within its engine[" + + engine.value + "]"); + } + Prolog.close_query(qid); + qid = null; // for tidiness + jpl.fli.Prolog.discard_foreign_frame(fid); + fid = null; // for tidiness + m.remove(new Long(engine.value)); + if (subQuery == null) { // only Query open in this engine? + if (Prolog.current_engine_is_pool()) { // this (Query's) engine is from the pool? + Prolog.release_pool_engine(); + // System.out.println("JPL releasing engine[" + engine.value + "]"); + } else { + // System.out.println("JPL leaving engine[" + engine.value + "]"); + } + } else { + m.put(new Long(engine.value), subQuery); + // System.out.println("JPL retaining engine[" + engine.value + "] popping subQuery(" + subQuery.hashCode() + ":" + subQuery.toString() + ")"); + } + open = false; // this Query is now closed + engine = null; // this Query, being closed, is no longer associated with any Prolog engine + subQuery = null; // this Query, being closed, is not stacked upon any other Query + } + /** + * calls the Query's goal to exhaustion + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * NB in JPL 1.0.1, this method (inconsistently) returned null when a Query had no solutions; + * in JPL 2.x onwards it returns an empty array (thus the length of the array is, in every case, + * the quantity of solutions). + * NB in JPL 1.0.1, bindings were keyed (awkwardly) by Variable instances; + * in JPL 2.x onwards they are keyed by the (String) names of variables, + * which is consistent with the Term type being just a concrete syntax for terms (and hence queries). + */ + public synchronized final Hashtable[] allSolutions() { + if (open) { + throw new JPLException("Query is already open"); + } else { + // get a vector of solutions: + Vector v = new Vector(); + while (hasMoreSolutions()) { + v.addElement(nextSolution()); + } + // turn the vector into an array: + Hashtable solutions[] = new Hashtable[v.size()]; // 0 solutions -> Hashtable[0] + v.copyInto(solutions); + return solutions; + } + } + /** + * This static method creates a Query whose goal is the given Term, + * calls it to exhaustion, + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * Throws JPLException if goal is neither a jpl.Atom nor a jpl.Compound. + * + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * + * @param goal the goal of this Query + */ + public static final Hashtable[] allSolutions(Term goal) { + return (new Query(goal)).allSolutions(); + } + /** + * This static method creates a Query from the given Prolog source text fragment, + * calls it to exhaustion, + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * + * @param text a Prolog source text fragment denoting a goal + */ + public static final Hashtable[] allSolutions(String text) { + return (new Query(text)).allSolutions(); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols and there are N accompanying Term params, + * this static method replaces each questionmark symbol by its respective param, + * calls the resulting goal to exhaustion, + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of the goal and params are the args; + * the resulting goal is then called as above. + * This letter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final Hashtable[] allSolutions(String text, Term[] params) { + return (new Query(text, params)).allSolutions(); + } + /** + * calls the Query's goal to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * @return an array of Hashtables (possibly none), each of which is a solution + * (in the order in which they were found) of the Query; at most 'n' solutions will be found and returned. + * NB in JPL 1.0.1, this method (inconsistently) returned null when a Query had no solutions; + * in JPL 2.x onwards it returns an empty array (thus the length of the array is, in every case, + * the quantity of solutions). + * NB in JPL 1.0.1, bindings were keyed (awkwardly) by Variable instances; + * in JPL 2.x onwards they are keyed by the (String) names of variables, + * which is consistent with the Term type being just a concrete syntax for terms (and hence queries). + */ + public synchronized final Hashtable[] nSolutions(long n) { + if (open) { + throw new JPLException("Query is already open"); + } else { + // get a vector of solutions: + Vector v = new Vector(); + for (long i = 0; i++ < n && hasMoreSolutions();) { + v.addElement(nextSolution()); + } + // turn the vector into an array: + Hashtable solutions[] = new Hashtable[v.size()]; // 0 solutions -> Hashtable[0] + v.copyInto(solutions); + return solutions; + } + } + /** + * This static method creates a Query whose goal is the given Term, + * calls it to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * Throws JPLException if goal is neither a jpl.Atom nor a jpl.Compound. + * + * @param goal the goal of this Query + */ + public static final Hashtable[] nSolutions(Term goal, long n) { + return (new Query(goal)).nSolutions(n); + } + /** + * This static method creates a Query from the given Prolog source text fragment, + * calls it to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text a Prolog source text fragment denoting a goal + */ + public static final Hashtable[] nSolutions(String text, long n) { + return (new Query(text)).nSolutions(n); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols and there are N accompanying params, + * this static method replaces each questionmark symbol by its respective param, + * calls the resulting goal to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of the goal and params are the args; + * the resulting goal is then called as above. + * This latter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final Hashtable[] nSolutions(String text, Term[] params, long n) { + return (new Query(text, params)).nSolutions(n); + } + /** + * Returns the first solution, if any, as a (possibly empty) Hashtable of variablename-to-term bindings, else null. + * + * This method will throw a JPLException if this Query is already open (and the Query will remain open as before). + * Otherwise, upon return, the Query will be closed. + * @return the first solution, if the query has one, as a (possibly empty) Hashtable. + * If the return value is null, this means that the Query has no solutions. + */ + public synchronized final Hashtable oneSolution() { + if (open) { + throw new JPLException("Query is already open"); + } else { + Hashtable solution; + if (hasMoreSolutions()) { + solution = nextSolution(); + close(); // safe, whether or not this is the only solution + } else { + solution = null; + } + return solution; + } + } + /** + * This static method creates a Query (whose goal is the specified Term) + * and calls it at most once, returning the first solution, if there is one, as a (possibly empty) Hashtable, else null. + * The goal can be a jpl.Atom or a jpl.Compound, but cannot be an instance + * of jpl.Float, jpl.Integer or jpl.Variable. + * + * @param goal the goal of this Query + */ + public static final Hashtable oneSolution(Term goal) { + return (new Query(goal)).oneSolution(); + } + /** + * This static method creates a Query from the given Prolog source text fragment, + * and calls it at most once, returning the first solution, if there is one, as a (possibly empty) Hashtable, else null. + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text a Prolog source text fragment denoting a goal + */ + public static final Hashtable oneSolution(String text) { + return (new Query(text)).oneSolution(); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols + * and there are N params, each questionmark symbol is replaced by its respective param + * to provide the goal of this query: + * the resulting goal is then called (at most once) and the first solution, if there is one, is returned as a (possibly empty) Hashtable, else null. + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of the goal and params are the args; + * the resulting goal is then called as above. + * This latter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final Hashtable oneSolution(String text, Term[] params) { + return (new Query(text, params)).oneSolution(); + } + /** + * This method will attempt to call this Query's goal within an available Prolog engine. + * @return the provability of the Query, i.e. 'true' if it has at least + * one solution, 'false' if the call fails without finding a solution. + * + * Only the first solution (if there is one) will be found; + * any bindings will be discarded, and the Query will be closed. + * This method will throw a JPLException if this Query is already open. + * + * @deprecated Use .hasSolution() instead. + */ + public synchronized final boolean query() { + return oneSolution() != null; + } + /** + * This method will attempt to call this Query's goal within an available Prolog engine. + * @return the provability of the Query, i.e. 'true' if it has at least + * one solution, 'false' if the call fails without finding a solution. + * + * Only the first solution (if there is one) will be found; + * any bindings will be discarded, and the Query will be closed. + * This method will throw a JPLException if this Query is already open. + */ + public synchronized final boolean hasSolution() { + return oneSolution() != null; + } + /** + * This static method creates a Query (whose goal is the specified Term) + * and calls it at most once, returning true if a solution was found, else false. + * The goal can be a jpl.Atom or a jpl.Compound, but cannot be an instance + * of jpl.Float, jpl.Integer or jpl.Variable. + * + * @param goal the goal of this Query + */ + public static final boolean hasSolution(Term goal) { + return (new Query(goal)).hasSolution(); + } + /** + * This static method creates a Query from the given Prolog source text + * and calls it at most once, returning true if a solution was found, else false. + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text the goal of this Query, as Prolog source text + */ + public static final boolean hasSolution(String text) { + return (new Query(text)).hasSolution(); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols + * and there are N params, each questionmark symbol is replaced by its corresponding arg + * to provide the new Query's goal: the resulting Query is called as described above. + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of its goal and args are its args; + * it then calls this goal (at most once) and returns true if a solution was found, else false. + * This latter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final boolean hasSolution(String text, Term[] params) { + return (new Query(text, params)).hasSolution(); + } + // + // this method doesn't work, but is intended to be called from another thread, + // to abort a Query which is open and possibly currently executing nextSolution() or similar + public final int abort() { + if (open) { + (new Thread(new Runnable() { + public void run() { + try { + int rc1 = Prolog.attach_engine(engine); + System.out.println("q.abort(): attach_engine() returns " + rc1); + int rc2 = Prolog.action_abort(); + System.out.println("q.abort(): action_abort() returns " + rc2); + // int rc3 = Prolog.release_pool_engine(); + // System.out.println("q.abort(): release_pool_engine() returns " + rc3); + } catch (Exception e) { + } + } + })).start(); // call the query in a separate thread + /* + int rc0a = Prolog.pool_engine_id(this.engine); + System.out.println("q.abort(): this.engine has id=" + rc0a); + + engine_t e = Prolog.current_engine(); + System.out.println("q.abort(): " + (e == null ? "no current engine" : "current engine id=" + Prolog.pool_engine_id(e))); + + int rc0b = Prolog.release_pool_engine(); + System.err.println("q.abort(): release_pool_engine() returns " + rc0b); + + engine_t e2 = Prolog.current_engine(); + System.out.println("q.abort(): " + (e == null ? "no current engine" : "current engine id=" + Prolog.pool_engine_id(e2))); + + int rc1 = Prolog.attach_engine(this.engine); + System.out.println("q.abort(): attach_engine() returns " + rc1); + + engine_t e3 = Prolog.current_engine(); + System.out.println("q.abort(): " + (e == null ? "no current engine" : "current engine id=" + Prolog.pool_engine_id(e3))); + + int rc2 = Prolog.action_abort(); + System.out.println("q.abort(): action_abort() returns " + rc2); + + int rc3 = Prolog.release_pool_engine(); + System.out.println("q.abort(): release_pool_engine() returns " + rc3); + + int rc4 = Prolog.attach_engine(e); + System.out.println("q.abort(): attach_engine() returns " + rc4); + */ + return 0; + } else { + System.out.println("q.abort(): query is not open"); + return -1; + } + } + //==================================================================/ + // misc + //==================================================================/ + /** + * Returns a crude String representation of a Query. + * + * @return a crude String representation of a Query + */ + public String toString() { + return goal_.name + "( " + Term.toString(goal_.args) + " )"; + } + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + /** + * Returns a debug-friendly representation of a Query + * + * @return a debug-friendly representation of a Query + * @deprecated + */ + public String debugString() { + return "(Query " + goal_.name + " " + Term.debugString(goal_.args) + ")"; + } +} diff --git a/packages/jpl/jpl/src/java/jpl/Term.java b/packages/jpl/jpl/src/java/jpl/Term.java new file mode 100644 index 000000000..46bc7fa67 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Term.java @@ -0,0 +1,768 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Hashtable; +import java.util.Iterator; +import java.util.Map; +import jpl.fli.DoubleHolder; +import jpl.fli.Int64Holder; +import jpl.fli.IntHolder; +import jpl.fli.Prolog; +import jpl.fli.StringHolder; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Term +/** + * Term is the abstract base class for + * Compound, Atom, Variable, Integer and Float, which comprise a Java-oriented concrete syntax for Prolog. + * You cannot create instances of Term directly; rather, you should create + * instances of Term's concrete subclasses. + * Alternatively, use textToTerm() to construct a Term from its conventional + * Prolog source text representation. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public abstract class Term { + //==================================================================/ + // Attributes + //==================================================================/ + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * This default constructor is provided in order for subclasses + * to be able to define their own default constructors. + */ + protected Term() { + } + + //==================================================================/ + // Methods (abstract, common) + //==================================================================/ + + /** + * returns the ano-th (1+) argument of a (Compound) Term + * throws a JPLException for any other subclass + * + * @return the ano-th argument of a (Compound) Term + */ + public abstract Term arg(int ano); + + /** + * returns, as a Term[], the arguments of a Compound + * returns an empty Term[] from an Atom, Integer or Float + * throws a JPLException from a Variable + * + * @return the arguments of a Compound as a Term[ + */ + public abstract Term[] args(); + + /** + * Tests whether this Term's functor has (String) 'name' and 'arity' + * Returns false if called inappropriately + * + * @return whether this Term's functor has (String) 'name' and 'arity' + */ + public abstract boolean hasFunctor(String name, int arity); + + /** + * Tests whether this Term's functor has (int) 'name' and 'arity' + * Returns false if called inappropriately + * + * @return whether this Term's functor has (int) 'name' and 'arity' + */ + public abstract boolean hasFunctor(int value, int arity); + /** + * Tests whether this Term's functor has (double) 'name' and 'arity' + * Returns false if called inappropriately + * + * @return whether this Term's functor has (double) 'name' and 'arity' + */ + public abstract boolean hasFunctor(double value, int arity); + + /** + * returns, as a String, the name of a Compound, Atom or Variable + * throws a JPLException from an Integer or Float + * + * @return the name of a Compound, Atom or Variable + */ + public String name() { + throw new JPLException("jpl." + this.typeName() + ".name() is undefined"); + }; + + /** + * returns, as an int, the arity of a Compound, Atom, Integer or Float + * throws a JPLException from a Variable + * + * @return the arity of a Compound, Atom, Integer or Float + */ + public int arity() { + throw new JPLException("jpl." + this.typeName() + ".arity() is undefined"); + }; + + /** + * returns the value (as an int) of an Integer or Float + * throws a JPLException from a Compound, Atom or Variable + * + * @return the value (as an int) of an Integer or Float + */ + public int intValue() { + throw new JPLException("jpl." + this.typeName() + ".intValue() is undefined"); + } + /** + * returns the value (as a long) of an Integer or Float + * throws a JPLException from a Compound, Atom or Variable + * + * @return the value (as a long) of an Integer or Float + */ + public long longValue() { + throw new JPLException("jpl." + this.typeName() + ".longValue() is undefined"); + } + /** + * returns the value (as a float) of an Integer or Float + * throws a JPLException from a Compound, Atom or Variable + * + * @return the value (as a float) of an Integer or Float + */ + public float floatValue() { + throw new JPLException("jpl." + this.typeName() + ".floatValue() is undefined"); + } + + /** + * returns the value (as a double) of an Integer or Float + * throws a JPLException from any other subclass + * + * @return the value (as an double) of an Integer or Float + */ + public double doubleValue() { + throw new JPLException("jpl." + this.typeName() + ".doubleValue() is undefined"); + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + /** + * returns the type of this term, as one of jpl.fli.Prolog.COMPOUND, .ATOM, .VARIABLE, .INTEGER, .FLOAT etc + * + * @return the type of this term, as one of jpl.fli.Prolog.COMPOUND, .ATOM, .VARIABLE, .INTEGER, .FLOAT etc + */ + public abstract int type(); + + /** + * returns the name of the type of this term, as one of "Compound", "Atom", "Variable", "Integer", "Float" etc + * + * @return the name of the type of this term, as one of "Compound", "Atom", "Variable", "Integer", "Float" etc + */ + public abstract String typeName(); + + /** + * whether this Term represents an atom + * + * @return whether this Term represents an atom + */ + public boolean isAtom() { + return this instanceof Atom; + } + + /** + * whether this Term represents a compound term + * + * @return whether this Term represents a compound atom + */ + public boolean isCompound() { + return this instanceof Compound; + } + + /** + * whether this Term represents an atom + * + * @return whether this Term represents an atom + */ + public boolean isFloat() { + return this instanceof Float; + } + + /** + * whether this Term represents an atom + * + * @return whether this Term represents an atom + */ + public boolean isInteger() { + return this instanceof Integer; + } + + /** + * whether this Term is a variable + * + * @return whether this Term is a variable + */ + public boolean isVariable() { + return this instanceof Variable; + } + + /** + * whether this Term is a 'jfalse' structure, i.e. @(false) + * + * @return whether this Term is a 'jfalse' structure, i.e. @(false) + */ + public boolean isJFalse() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jtrue' structure, i.e. @(true) + * + * @return whether this Term is a 'jtrue' structure, i.e. @(true) + */ + public boolean isJTrue() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jnull' structure, i.e. @(null) + * + * @return whether this Term is a 'jnull' structure, i.e. @(null) + */ + public boolean isJNull() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jvoid' structure, i.e. @(void) + * + * @return whether this Term is a 'jvoid' structure, i.e. @(void) + */ + public boolean isJVoid() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jobject' structure, i.e. @(Tag) + * + * @return whether this Term is a 'jobject' structure, i.e. @(Tag) + */ + public boolean isJObject() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + * + * @return whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + */ + public boolean isJRef() { + return false; // overridden in Compound, where it might sometimes be true + } + + public abstract Object jrefToObject(); + + // objectToJRef(Object) + /** + * returns a new Term instance which represents the given object + */ + public static Term objectToJRef(Object obj) { + return new Compound( "@", new Term[]{new Atom(Prolog.object_to_tag(obj))}); + } + + public Term putParams(Term[] ps) { + IntHolder next = new IntHolder(); + next.value = 0; + Term t2 = this.putParams1(next, ps); + if (next.value != ps.length) { + throw new JPLException("Term.putParams: more actual params than formal"); + } + return t2; + } + + public Term putParams(Term plist) { + Term[] ps = plist.toTermArray(); + return putParams(ps); + } + + protected Term putParams1(IntHolder next, Term[] ps) { + switch (this.type()) { + case Prolog.COMPOUND : + return new Compound(this.name(), putParams2(this.args(), next, ps)); + case Prolog.ATOM : + if (this.name().equals("?")) { + if (next.value >= ps.length) { + throw new JPLException("Term.putParams: fewer actual params than formal params"); + } + return ps[next.value++]; + } // else drop through to default + default : + return this; + } + } + + static protected Term[] putParams2(Term[] ts, IntHolder next, Term[] ps) { + int n = ts.length; + Term[] ts2 = new Term[n]; + for (int i = 0; i < n; i++) { + ts2[i] = ts[i].putParams1(next, ps); + } + return ts2; + } + + /** + * the length of this list, iff it is one, else an exception is thrown + * + * @throws JPLException + * @return the length (as an int) of this list, iff it is one + */ + public int listLength() { + if (this.hasFunctor(".", 2)) { + return 1 + this.arg(2).listLength(); + } else if (this.hasFunctor("[]", 0)) { + return 0; + } else { + throw new JPLException("Term.listLength: term is not a list"); + } + } + + /** returns an array of terms which are the successive members of this list, if it is a list, else throws an exception + * + * @throws JPLException + * @return an array of terms which are the successive members of this list, if it is a list + */ + public Term[] toTermArray() { + try { + int len = this.listLength(); + Term[] ts = new Term[len]; + Term t = this; + + for (int i = 0; i < len; i++) { + ts[i] = t.arg(1); + t = t.arg(2); + } + return ts; + } catch (JPLException e) { + throw new JPLException("Term.toTermArray: term is not a proper list"); + } + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * Returns a debug-friendly representation of a Term + * + * @return a debug-friendly representation of a Term + * @deprecated + */ + public abstract String debugString(); + + /** + * Returns a debug-friendly representation of a list of Terms + * + * @return a debug-friendly representation of a list of Terms + * @deprecated + */ + public static String debugString(Term arg[]) { + String s = "["; + + for (int i = 0; i < arg.length; ++i) { + s += arg[i].debugString(); + if (i != arg.length - 1) { + s += ", "; + } + } + return s + "]"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + // + // To convert a Term to a term_t, we need to traverse the Term + // structure and build a corresponding Prolog term_t object. + // There are some issues: + // + // - Prolog term_ts rely on the *consecutive* nature of term_t + // references. In particular, to build a compound structure + // in the Prolog FLI, one must *first* determine the arity of the + // compound, create a *sequence* of term_t references, and then + // put atoms, functors, etc. into those term references. We + // do this in these methods by first determining the arity of the + // Compound, and then by "put"-ing a type into a term_t. + // The "put" method is implemented differently in each of Term's + // five subclasses. + // + // - What if we are trying to make a term_t from a Term, but the + // Term has multiple instances of the same Variable? We want + // to ensure that _one_ Prolog variable will be created, or else + // queries will give incorrect answers. We thus pass a Hashtable + // (var_table) through these methods. The table contains term_t + // instances, keyed on Variable instances. + //==================================================================/ + + public void put( term_t term){ + put( new Hashtable(), term); + } + /** + * Cache the reference to the Prolog term_t here. + * + * @param varnames_to_vars A Map from variable names to JPL Variables. + * @param term A (previously created) term_t which is to be + * put with a Prolog term-type appropriate to the Term type + * (e.g., Atom, Variable, Compound, etc.) on which the method is + * invoked.) + */ + protected abstract void put(Map varnames_to_vars, term_t term); + + /** + * This static method converts an array of Terms to a *consecutive* + * sequence of term_t objects. Note that the first term_t object + * returned is a term_t class (structure); the succeeding term_t + * objects are consecutive references obtained by incrementing the + * *value* field of the term_t. + * + * @param varnames_to_vars Map from variable names to JPL Variables. + * @param args An array of jpl.Term references. + * @return consecutive term_t references (first of which is + * a structure) + */ + protected static term_t putTerms(Map varnames_to_vars, Term[] args) { + + // first create a sequence of term_ts. The 0th term_t + // will be a jpl.fli.term_t. Successive Prolog term_t + // references will reside in the Prolog engine, and + // can be obtained by term0.value+i. + // + term_t term0 = Prolog.new_term_refs(args.length); + + // for each new term reference, construct a Prolog term + // by putting an appropriate Prolog type into the reference. + // + long ith_term_t = term0.value; + for (int i = 0; i < args.length; ++i, ++ith_term_t) { + term_t term = new term_t(); + term.value = ith_term_t; + args[i].put(varnames_to_vars, term); // each subclass defines its own put() + } + + return term0; + } + + // experiment: for jni_jobject_to_term_byval/2 in jpl.c + public static void putTerm( Object obj, term_t termref){ + if (obj instanceof Term){ + ((Term)obj).put(termref); + } else { + throw new JPLException("not a Term"); + } + } + + //==================================================================/ + // Converting Prolog terms to JPL Terms + // + // Converting back from term_ts to Terms is simple, since + // the (simplified) Term representation is canonical (there is only one + // correct structure for any given Prolog term). + // + // One problem concerns variable bindings. We illustrate + // with several examples. First, consider the Prolog fact + // + // p( f(X,X)). + // + // And the query + // + // ?- p( Y). + // + // A solution should be + // + // y = f(X,X) + // + // and indeed, if this query is run, the term_t to which Y will + // be unified is a compound, f(X,X). The problem is, how do + // we know, in converting the term_ts to Terms in the compound f/2 + // whether we should create one Variable or two? This begs the + // question, how do we _identify_ Variables in JPL? The answer + // to the latter question is, by reference; two Variable (Java) + // references refer to the same variable iff they are, in memory, + // the same Variable object. That is, they satisfy the Java == relation. + // (Note that this condition is _not_ true of the other Term types.) + // + // Given this design decision, therefore, we should create a + // single Variable instance and a Compound instance whose two arg + // values refer to the same Variable object. We therefore need to keep + // track, in converting a term_t to a Term (in particular, in + // converting a term_t whose type is variable to a Variable), of + // which Variables have been created. We do this by using the vars + // Hashtable, which gets passed recursively though the from_term_t + // methods; this table holds the Variable instances that have been + // created, keyed by the unique and internal-to-Prolog string + // representation of the variable (I'm not sure about this...). + //==================================================================/ + + /** + * This method calls from_term_t on each term in the n consecutive term_ts. + * A temporary jpl.term_t "holder" (byref) structure must be created + * in order to extract type information from the Prolog engine. + * + * @param vars_to_Vars A Map from Prolog variables to jpl.Variable instances + * @param n The number of consecutive term_ts + * @param term0 The 0th term_t (structure); subsequent + * term_ts are not structures. + * @return An array of converted Terms + */ + /* + protected static Term[] from_term_ts(Map vars_to_Vars, int n, term_t term0) { + + // create an (uninitialised) array of n Term references + Term[] terms = new Term[n]; + + // for each term_t (from 0...n-1), create a term_t + // (temporary) structure and dispatch the translation + // to a Term to the static from_term_t method of the Term + // class. This will perform (Prolog) type analysis on the + // term_t and call the appropriate static method to create + // a Term of the right type (e.g., Atom, Variable, List, etc.) + // + long ith_term_t = term0.value; + for (int i = 0; i < n; ++i, ++ith_term_t) { + term_t term = new term_t(); + term.value = ith_term_t; + + terms[i] = Term.from_term_t(vars_to_Vars, term); + } + + return terms; + } + */ + + /** + * We discover the Prolog type of the term, then forward the + * call to the appropriate subclass + * + * @param vars A Map from Prolog variables to jpl.Variable instances + * @param term The Prolog term (in a term_t holder) to convert + * @return The converted Term subtype instance. + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + int type = Prolog.term_type(term); + + switch (type) { + case Prolog.VARIABLE : + return Variable.getTerm(vars_to_Vars, term); + case Prolog.ATOM : + return Atom.getTerm(vars_to_Vars, term); + case Prolog.STRING : + return Atom.getString(vars_to_Vars, term); + case Prolog.INTEGER : + return Integer.getTerm(vars_to_Vars, term); + case Prolog.FLOAT : + return Float.getTerm(vars_to_Vars, term); + case Prolog.COMPOUND : + return Compound.getTerm(vars_to_Vars, term); + default : + // should never happen... + throw new JPLException("Term.from_term_t: unknown term type=" + type); + } + } + + protected static Term getTerm(Map vars_to_Vars, term_t term) { + StringHolder hString; + IntHolder hInt; + Int64Holder hInt64; + // int type = Prolog.term_type(term); + switch (Prolog.term_type(term)) { + case Prolog.VARIABLE: + for (Iterator i = vars_to_Vars.keySet().iterator(); i.hasNext();) { + term_t varX = (term_t) i.next(); // a previously seen Prolog variable + if (Prolog.compare(varX, term) == 0) { // identical Prolog variables? + return (Term) vars_to_Vars.get(varX); // return the associated JPL Variable + } + } + // otherwise, the Prolog variable in term has not been seen before + Variable Var = new Variable(); // allocate a new (sequentially named) Variable to represent it + Var.term_ = term; // this should become redundant... + vars_to_Vars.put(term, Var); // use Hashtable(var,null), but only need set(var) + return Var; + case Prolog.ATOM: // return Atom.getTerm(vars_to_Vars, term); + hString = new StringHolder(); + Prolog.get_atom_chars(term, hString); // ignore return val; assume success... + return new Atom(hString.value); + case Prolog.STRING: // return Atom.getString(vars_to_Vars, term); + hString = new StringHolder(); + Prolog.get_string_chars(term, hString); // ignore return val; assume success... + return new Atom(hString.value); + case Prolog.INTEGER: // return Integer.getTerm(vars_to_Vars, term); + hInt64 = new Int64Holder(); + Prolog.get_integer(term, hInt64); // assume it succeeds... + return new jpl.Integer(hInt64.value); + case Prolog.FLOAT: // return Float.getTerm(vars_to_Vars, term); + DoubleHolder hFloatValue = new DoubleHolder(); + Prolog.get_float(term, hFloatValue); // assume it succeeds... + return new jpl.Float(hFloatValue.value); + case Prolog.COMPOUND: // return Compound.getTerm(vars_to_Vars, term); + hString = new StringHolder(); + hInt = new IntHolder(); + Prolog.get_name_arity(term, hString, hInt); // assume it succeeds + Term args[] = new Term[hInt.value]; + // term_t term1 = Prolog.new_term_refs(hArity.value); + for (int i = 1; i <= hInt.value; i++) { + term_t termi = Prolog.new_term_ref(); + Prolog.get_arg(i, term, termi); + args[i - 1] = Term.getTerm(vars_to_Vars, termi); + } + return new Compound(hString.value, args); + default: + // should never happen... + throw new JPLException("Term.from_term_t: unknown term type=" + Prolog.term_type(term)); + } + } + + protected static Term getTerm( term_t term){ + return getTerm( new Hashtable(), term); + } + + //==================================================================/ + // Computing Substitutions + // + // Once a solution has been found, the Prolog term_t references + // will have been instantiated and will refer to new terms. To compute + // a substitution, we traverse the (original) Term structure, looking + // at the term_t reference in the Term. The only case we really care + // about is if the (original) Term is a Variable; if so, the term_t + // back in the Prolog engine may be instantiated (non Variable parts + // of the original Term cannot change or become uninstantiated). In + // this case, we can store this term in a Hashtable, keyed by the + // Variable with which the term was unified. + //==================================================================/ + + //------------------------------------------------------------------/ + // getSubst + /** + * This method computes a substitution from a Term. The bindings + * Hashtable stores Terms, keyed by Variables. Thus, a + * substitution is as it is in mathematical logic, a sequence + * of the form \sigma = {t_0/x_0, ..., t_n/x_n}. Once the + * substitution is computed, the substitution should satisfy + * + * \sigma T = t + * + * where T is the Term from which the substitution is computed, + * and t is the term_t which results from the Prolog query. + * + * A second Hashtable, vars, is required; this table holds + * the Variables that occur (thus far) in the unified term. + * The Variable instances in this table are guaranteed to be + * unique and are keyed on Strings which are Prolog internal + * representations of the variables. + * + * @param bindings table holding Term substitutions, keyed on + * Variables. + * @param vars A Hashtable holding the Variables that occur + * thus far in the term; keyed by internal (Prolog) string rep. + */ + protected abstract void getSubst(Map varnames_to_Terms, Map vars_to_Vars); + + //------------------------------------------------------------------/ + // getSubsts + /** + * Just calls computeSubstitution for each Term in the array. + * + * @param varnames_to_Terms a Map from variable names to Terms + * @param vars_to_Vars a Map from Prolog variables to JPL Variables + * @param arg a list of Terms + */ + protected static void getSubsts(Map varnames_to_Terms, Map vars_to_Vars, Term[] args) { + for (int i = 0; i < args.length; ++i) { + args[i].getSubst(varnames_to_Terms, vars_to_Vars); + } + } + + //------------------------------------------------------------------/ + // terms_equals + /** + * This method is used (by Compound.equals) to determine the Terms in two Term arrays + * are pairwise equal, where two Terms are equal if they satisfy + * the equals predicate (defined differently in each Term subclass). + * + * @param t1 an array of Terms + * @param t2 another array of Terms + * @return true if all of the Terms in the (same-length) arrays are pairwise equal + */ + protected static boolean terms_equals(Term[] t1, Term[] t2) { + if (t1.length != t2.length) { + return false; + } + + for (int i = 0; i < t1.length; ++i) { + if (!t1[i].equals(t2[i])) { + return false; + } + } + return true; + } + + //------------------------------------------------------------------/ + // toString + /** + * Converts a list of Terms to a String. + * + * @param args An array of Terms to convert + * @return String representation of a list of Terms + */ + public static String toString(Term[] args) { + String s = ""; + + for (int i = 0; i < args.length; ++i) { + s += args[i].toString(); + if (i != args.length - 1) { + s += ", "; + } + } + + return s; + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/Util.java b/packages/jpl/jpl/src/java/jpl/Util.java new file mode 100644 index 000000000..aedd69a3c --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Util.java @@ -0,0 +1,281 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Hashtable; +import java.util.Map; + +//----------------------------------------------------------------------/ +// Util +/** + * This class provides a bunch of static utility methods for the JPL + * High-Level Interface. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public final class Util { + //------------------------------------------------------------------/ + // termArrayToList + /** + * Converts an array of Terms to a JPL representation of a Prolog list of terms + * whose members correspond to the respective array elements. + * + * @param terms An array of Term + * @return Term a list of the array elements + */ + public static Term termArrayToList(Term[] terms) { + Term list = new Atom("[]"); + + for (int i = terms.length - 1; i >= 0; --i) { + list = new Compound(".", new Term[] { terms[i], list }); + } + return list; + } + + /** + * Converts a solution hashtable to an array of Terms. + * + * @param varnames_to_Terms A Map from variable names to Terms + * @return Term[] An array of the Terms to which successive variables are bound + */ + public static Term[] bindingsToTermArray(Map varnames_to_Terms) { + Term[] ts = new Term[varnames_to_Terms.size()]; + + for (java.util.Iterator i = varnames_to_Terms.keySet().iterator(); i.hasNext();) { + Variable k = (Variable) i.next(); + ts[k.index] = (Term) (varnames_to_Terms.get(k)); + } + return ts; + } + + //------------------------------------------------------------------/ + // toString + /** + * Converts a substitution, in the form of a Map from variable names to Terms, to a String. + * + * @param varnames_to_Terms A Map from variable names to Terms. + * @return String A String representation of the variable bindings + */ + public static String toString(Map varnames_to_Terms) { + if (varnames_to_Terms == null) { + return "[no solution]"; + } + java.util.Iterator varnames = varnames_to_Terms.keySet().iterator(); + + String s = "Bindings: "; + while (varnames.hasNext()) { + String varname = (String) varnames.next(); + s += varname + "=" + varnames_to_Terms.get(varname).toString() + "; "; + } + return s; + } + + //------------------------------------------------------------------/ + // namevarsToMap + /** + * Converts a (JPL) list of Name=Var pairs (as yielded by atom_to_term/3) + * to a Map from Prolog variables (necessarily in term_t holders) to named JPL Variables + * + * @param nvs A JPL list of Name=Var pairs (as yielded by atom_to_term/3) + * @return Map A Map from Prolog variables (necessarily in term_t holders) to named JPL Variables + */ + public static Map namevarsToMap(Term nvs) { + + try { + Map vars_to_Vars = new Hashtable(); + + /* + while (nvs.hasFunctor(".", 2) && ((Compound) nvs).arg(1).hasFunctor("=", 2)) { + Atom name = (Atom) ((Compound) ((Compound) nvs).arg(1)).arg(1); // get the Name of the =/2 pair + Variable var = (Variable) ((Compound) ((Compound) nvs).arg(1)).arg(2); // get the Var of the =/2 pair + + vars_to_Vars.put(var.term_, new Variable(name.name())); // map the Prolog variable to a new, named Variable + nvs = ((Compound) nvs).arg(2); // advance to next list cell + } + */ + while (nvs.hasFunctor(".", 2) && nvs.arg(1).hasFunctor("=", 2)) { + // the cast to Variable is necessary to access the (protected) .term_ field + vars_to_Vars.put(((Variable)nvs.arg(1).arg(2)).term_, new Variable(nvs.arg(1).arg(1).name())); // map the Prolog variable to a new, named Variable + nvs = nvs.arg(2); // advance to next list cell + } + + // maybe oughta check that nvs is [] ? + return vars_to_Vars; + } catch (java.lang.ClassCastException e) { // nvs is not of the expected structure + return null; + } + } + + //------------------------------------------------------------------/ + // textToTerm + /** + * Converts a Prolog source text to a corresponding JPL Term + * (in which each Variable has the appropriate name from the source text). + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text A Prolog source text denoting a term + * @return Term a JPL Term equivalent to the given source text + */ + public static Term textToTerm(String text) { + // it might be better to use PL_chars_to_term() + Query q = new Query(new Compound("atom_to_term", new Term[] { new Atom(text), new Variable("Term"), new Variable("NVdict")})); + q.open(); + Map s = q.getSubstWithNameVars(); + if (s != null) { + q.close(); + return (Term) s.get("Term"); + } else { + return null; + } + } + // + // textParamsToTerm + /** + * Converts a Prolog source text to a corresponding JPL Term (in which each Variable has the appropriate name from the source text), replacing successive occurrences of ? in the text by the + * corresponding element of Term[] params. (New in JPL 3.0.4) + * + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text + * A Prolog source text denoting a term + * @return Term a JPL Term equivalent to the given source text + */ + public static Term textParamsToTerm(String text, Term[] params) { + return Util.textToTerm(text).putParams(params); + } + // + /** + * Converts an array of String to a corresponding JPL list + * + * @param a + * An array of String objects + * @return Term a JPL list corresponding to the given String array + */ + public static Term stringArrayToList(String[] a) { + Term list = new Atom("[]"); + for (int i = a.length - 1; i >= 0; i--) { + list = new Compound(".", new Term[]{new Atom(a[i]), list}); + } + return list; + } + // + /** + * Converts an array of int to a corresponding JPL list + * + * @param a + * An array of int values + * @return Term a JPL list corresponding to the given int array + */ + public static Term intArrayToList(int[] a) { + Term list = new Atom("[]"); + for (int i = a.length - 1; i >= 0; i--) { + list = new Compound(".", new Term[]{new jpl.Integer(a[i]), list}); + } + return list; + } + // + /** + * Converts an array of arrays of int to a corresponding JPL list of lists + * + * @param a + * An array of arrays of int values + * @return Term a JPL list of lists corresponding to the given int array of arrays + */ + public static Term intArrayArrayToList(int[][] a) { + Term list = new Atom("[]"); + for (int i = a.length - 1; i >= 0; i--) { + list = new Compound(".", new Term[]{intArrayToList(a[i]), list}); + } + return list; + } + public static int listToLength(Term t) { + int length = 0; + Term head = t; + while (head.hasFunctor(".", 2)) { + length++; + head = head.arg(2); + } + return (head.hasFunctor("[]", 0) ? length : -1); + } + /** converts a proper list to an array of terms, else throws an exception + * + * @throws JPLException + * @return an array of terms whose successive elements are the corresponding members of the list (if it is a list) + */ + public static Term[] listToTermArray(Term t) { + try { + int len = t.listLength(); + Term[] ts = new Term[len]; + + for (int i = 0; i < len; i++) { + ts[i] = t.arg(1); + t = t.arg(2); + } + return ts; + } catch (JPLException e) { + throw new JPLException("Util.listToTermArray: term is not a proper list"); + } + } + + public static String[] atomListToStringArray( Term t){ + int n = listToLength(t); + String[] a; + if ( n<0){ + return null; + } else { + a = new String[n]; + } + int i = 0; + Term head = t; + while ( head.hasFunctor(".", 2)){ + Term x = head.arg(1); + if ( x.isAtom()){ + a[i++]=x.name(); + } else { + return null; + } + head = head.arg(2); + } + return (head.hasFunctor("[]", 0) ? a : null ); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/Variable.java b/packages/jpl/jpl/src/java/jpl/Variable.java new file mode 100644 index 000000000..6d14b8ad4 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Variable.java @@ -0,0 +1,299 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Iterator; +import java.util.Map; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Variable +/** + * This class supports Java representations of Prolog variables. + * + * A jpl.Variable instance is equivalent to a variable in a fragment of Prolog source text: + * it is *not* a "live" variable within a Prolog stack or heap. + * A corresponding Prolog variable is created only upon opening + * a Query whose goal refers to a Variable (and then only temporarily). + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class Variable extends Term { + //==================================================================/ + // Attributes + //==================================================================/ + private static long n = 0; // the integral part of the next automatic variable name to be allocated + public final String name; // the name of this Variable + protected transient term_t term_ = null; // defined between Query.open() and Query.get2() + protected transient int index; // only used by (redundant?) + //==================================================================/ + // Constructors + //==================================================================/ + /** + * Create a new Variable with 'name' (which must not be null or ""), + * and may one day be constrained to comply with traditional Prolog syntax. + * + * @param name the source name of this Variable + */ + public Variable(String name) { + if (name == null) { + throw new JPLException("constructor jpl.Variable(name): name cannot be null"); + } + if (!isValidName(name)) { + throw new JPLException("constructor jpl.Variable(name): name cannot be empty String"); + } + this.name = name; + } + /** + * Create a new Variable with new sequential name of the form "_261". + * + */ + public Variable() { + this.name = "_" + Long.toString(n++); // e.g. _0, _1 etc. + } + //==================================================================/ + // Methods (common) + //==================================================================/ + /** + * The (nonexistent) args of this Variable + * @throws JPLException + * + * @return the (nonexistent) args of this Variable (never) + */ + public Term[] args() { + throw new JPLException("jpl.Variable#args(): call is improper"); + } + public boolean hasFunctor(String name, int arity) { + throw new JPLException("jpl.Variable#hasFunctor(): term is not sufficiently instantiated"); + } + public boolean hasFunctor(int value, int arity) { + throw new JPLException("jpl.Variable#hasFunctor(): term is not sufficiently instantiated"); + } + public boolean hasFunctor(double value, int arity) { + throw new JPLException("jpl.Variable#hasFunctor(): term is not sufficiently instantiated"); + } + public Object jrefToObject() { + throw new JPLException("jpl.Variable#jrefToObject(): term is not a jref"); + } + /** + * returns the lexical name of this Variable + * + * @return the lexical name of this Variable + */ + public final String name() { + return this.name; + } + /** + * returns the type of this subclass of Term, i.e. Prolog.VARIABLE + * + * @return the type of this subclass of Term, i.e. Prolog.VARIABLE + */ + public final int type() { + return Prolog.VARIABLE; + } + /** + * returns the typeName of this subclass of Term, i.e. "Variable" + * + * @return the typeName of this subclass of Term, i.e. "Variable" + */ + public String typeName() { + return "Variable"; + } + /** + * Returns a Prolog source text representation of this Variable + * + * @return a Prolog source text representation of this Variable + */ + public String toString() { + return this.name; + } + /** + * A Variable is equal to another if their names are the same and they are not anonymous. + * + * @param obj The Object to compare. + * @return true if the Object is a Variable and the above condition apply. + */ + public final boolean equals(Object obj) { + return obj instanceof Variable && !this.name.equals("_") && this.name.equals(((Variable) obj).name); + } + + /** + * throws a JPLException (arg(int) is defined only for Compound and Atom) + * + * @return the ith argument (counting from 1) of this Variable (never) + */ + public final Term arg(int i) { + throw new JPLException("jpl.Variable#arg(int) is undefined"); + } + +//==================================================================/ + // Methods (private) + //==================================================================/ + /** + * Tests the lexical validity of s as a variable's name + * + * @return the lexical validity of s as a variable's name + * @deprecated + */ + private boolean isValidName(String s) { + if (s == null) { + throw new java.lang.NullPointerException(); // JPL won't call it this way + } + int len = s.length(); + if (len == 0) { + throw new JPLException("invalid variable name"); + } + char c = s.charAt(0); + if (!(c == '_' || c >= 'A' && c <= 'Z')) { + return false; + } + for (int i = 1; i < len; i++) { + c = s.charAt(i); + if (!(c == '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' || c >= '0' && c <= '9')) { + return false; + } + } + return true; + } + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + /** + * Returns a debug-friendly String representation of an Atom. + * + * @return a debug-friendly String representation of an Atom + * @deprecated + */ + public String debugString() { + return "(Variable " + toString() + ")"; + } + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + /** + * To put a Variable, we must check whether a (non-anonymous) variable with the same name + * has already been put in the Term. If one has, then the corresponding Prolog variable has + * been stashed in the varnames_to_vars Map, keyed by the Variable name, so we can look + * it up and reuse it (this way, the sharing of variables in the Prolog term + * reflects the sharing of Variable names in the Term. + * Otherwise, if this Variable name has not + * already been seen in the Term, then we put a new Prolog variable and add it into the Map + * (keyed by this Variable name). + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (previously created) term_t which is to be + * set to a (new or reused) Prolog variable. + */ + protected final void put(Map varnames_to_vars, term_t term) { + term_t var; + // if this var is anonymous or as yet unseen, put a new Prolog variable + if (this.name.equals("_") || (var = (term_t) varnames_to_vars.get(this.name)) == null) { + this.term_ = term; + this.index = varnames_to_vars.size(); // i.e. first var in is #0 etc. + Prolog.put_variable(term); + if (!this.name.equals("_")) { + varnames_to_vars.put(this.name, term); + } + } else { + this.term_ = var; + Prolog.put_term(term, var); + } + } + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + /** + * Converts a term_t (known to refer to a Prolog variable) to a Variable. + * If the variable has already been seen (and hence converted), + * return its corresponding Variable from the map, + * else create a new Variable, stash it in the map (keyed by the Prolog variable), + * and return it. + * + * @param vars_to_Vars a map from Prolog to JPL variables + * @param var The term_t (known to be a variable) to convert + * @return A new or reused Variable + */ + protected static Term getTerm1(Map vars_to_Vars, term_t var) { + for (Iterator i = vars_to_Vars.keySet().iterator(); i.hasNext();) { + term_t varX = (term_t) i.next(); // a previously seen Prolog variable + if (Prolog.compare(varX, var) == 0) { // identical Prolog variables? + return (Term) vars_to_Vars.get(varX); // return the associated JPL Variable + } + } + // otherwise, the Prolog variable in term has not been seen before + Variable Var = new Variable(); // allocate a new (sequentially named) Variable to represent it + Var.term_ = var; // this should become redundant... + vars_to_Vars.put(var, Var); // use Hashtable(var,null), but only need set(var) + return Var; + } + //==================================================================/ + // Computing Substitutions + //==================================================================/ + /** + * If this Variable instance is not an anonymous or (in dont-tell-me mode) a dont-tell-me variable, and its binding is not already in the varnames_to_Terms Map, + * put the result of converting the term_t to which this variable + * has been unified to a Term in the Map, keyed on this Variable's name. + * + * @param varnames_to_Terms A Map of bindings from variable names to JPL Terms. + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + // NB a Variable.name cannot be "" i.e. of 0 length + // if (!(this.name.charAt(0) == '_') && varnames_to_Terms.get(this.name) == null) { + if (tellThem() && varnames_to_Terms.get(this.name) == null) { + varnames_to_Terms.put(this.name, Term.getTerm(vars_to_Vars, this.term_)); + } + } + // whether, according to prevailing policy and theis Variable's name, + // any binding should be returned + // (yes, unless it's anonymous or we're in dont-tell-me mode and its a dont-tell-me variable) + private final boolean tellThem() { + return !(this.name.equals("_") || jpl.JPL.modeDontTellMe && this.name.charAt(0) == '_'); + // return !this.name.equals("_"); + } +} +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/Version.java b/packages/jpl/jpl/src/java/jpl/Version.java new file mode 100644 index 000000000..e5347bc83 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/Version.java @@ -0,0 +1,9 @@ +// $Id$ +package jpl; + +class Version { + public final int major = 3; + public final int minor = 1; + public final int patch = 4; + public final String status = "alpha"; +} diff --git a/packages/jpl/jpl/src/java/jpl/fli/.cvsignore b/packages/jpl/jpl/src/java/jpl/fli/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/src/java/jpl/fli/BooleanHolder.java b/packages/jpl/jpl/src/java/jpl/fli/BooleanHolder.java new file mode 100644 index 000000000..77c7cda09 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/BooleanHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// BooleanHolder +/** + * A BooleanHolder is merely a Holder class for a boolean value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class BooleanHolder +{ + public boolean value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/DoubleHolder.java b/packages/jpl/jpl/src/java/jpl/fli/DoubleHolder.java new file mode 100644 index 000000000..620726d7b --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/DoubleHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// DoubleHolder +/** + * A DoubleHolder is merely a Holder class for a double value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class DoubleHolder +{ + public double value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/Int64Holder.java b/packages/jpl/jpl/src/java/jpl/fli/Int64Holder.java new file mode 100644 index 000000000..f39624b6e --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/Int64Holder.java @@ -0,0 +1,34 @@ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +//Int64Holder +/** +* An Int64Holder is merely a Holder class for an int64 value. +* +* +* Copyright (C) 2005 Paul Singleton +* +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Library Public License +* as published by the Free Software Foundation; either version 2 +* of the License, or (at your option) any later version. +* +* This library 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 Library Public License for more details. +* +* @author Paul Singleton paul@jbgb.com +* @version $Revision$ +*/ +//Implementation notes: +// +//----------------------------------------------------------------------/ +public class Int64Holder +{ + public long value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/IntHolder.java b/packages/jpl/jpl/src/java/jpl/fli/IntHolder.java new file mode 100644 index 000000000..8a0b40fb9 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/IntHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// IntHolder +/** + * An IntHolder is merely a Holder class for an Int value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class IntHolder +{ + public int value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/LongHolder.java b/packages/jpl/jpl/src/java/jpl/fli/LongHolder.java new file mode 100644 index 000000000..8d8dbaaaf --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/LongHolder.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + +//----------------------------------------------------------------------/ +// LongHolder +/** + * A Long Holder merely holds a long value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class LongHolder { + public long value = 0L; + + public boolean equals(LongHolder lh) { + return lh.value == this.value; + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/ObjectHolder.java b/packages/jpl/jpl/src/java/jpl/fli/ObjectHolder.java new file mode 100644 index 000000000..1d83c0b53 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/ObjectHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// ObjectHolder +/** + * A ObjectHolder is merely a Holder class for an Object reference (or null). + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class ObjectHolder +{ + public Object value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/PointerHolder.java b/packages/jpl/jpl/src/java/jpl/fli/PointerHolder.java new file mode 100644 index 000000000..b4f3e488f --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/PointerHolder.java @@ -0,0 +1,63 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// PointerHolder +/** + * A PointerHolder is a trivial extension of a LongHolder. This is sort of + * a no-no in Java, as the long value stored herein is sometimes a + * machine address. (Don't tell Sun.) + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// There could be issues in the future with signedness, since Java +// does not have an unsigned type; make sure not to do any arithmetic +// with the stored value. +//----------------------------------------------------------------------/ +public class PointerHolder extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/Prolog.java b/packages/jpl/jpl/src/java/jpl/fli/Prolog.java new file mode 100644 index 000000000..ea4812ac4 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/Prolog.java @@ -0,0 +1,246 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + +import jpl.JPL; + + +//----------------------------------------------------------------------/ +// Prolog +/** + * This class consists only of constants (static finals) and static + * native methods. The constants and methods defined herein are in + * (almost) strict 1-1 correspondence with the functions in the Prolog + * FLI by the same name (except without the PL_, SQ_, etc. prefixes). + * + * See the file jpl.c for the native (ANSI C) implementations of these + * methods. Refer to your local Prolog FLI documentations for the meanings + * of these methods, and observe the following: + * + * + *
  • The types and signatures of the following methods are almost + * in 1-1 correspondence with the Prolog FLI. The Prolog types + * term_t, atom_t, functor_t, etc. are mirrored in this package with + * classes by the same name, making the C and Java uses of these + * interfaces similar.
    • + *
  • As term_t, functor_t, etc. types are Java classes, they are + * passed to these methods by value; however, calling these + * methods on such class instances does have side effects. In general, + * the value fields of these instances will be modified, in much the + * same way the term_t, functor_t, etc. Prolog instances would be + * modified.
    • + *
  • The exceptions to this rule occur when maintaining the same + * signature would be impossible, e.g., when the Prolog FLI functions + * require pointers; in this case, the signatures have been + * modified to take *Holder classes (Int, Double, String, etc.), + * to indicate a call by reference parameter. + *
  • Functions which take variable-length argument lists in C + * take arrays in Java; from Java 1.1 onwards, anonymous arrays + * can be used e.g. Term[] { new Atom("a"), new Atom ("b") } + *
    • + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public final class Prolog { + static { + // System.loadLibrary("jpl"); + JPL.loadNativeLibrary(); + } + + /* term types */ + public static final int VARIABLE = 1; + public static final int ATOM = 2; + public static final int INTEGER = 3; + public static final int FLOAT = 4; + public static final int STRING = 5; + public static final int COMPOUND = 6; + + public static final int JBOOLEAN = 101; + public static final int JREF = 102; + public static final int JVOID = 103; + + /** + * @deprecated use Prolog.COMPOUND + */ + public static final int TERM = 6; + + public static final int succeed = 1; + public static final int fail = 0; + + /* query flags */ + public static final int Q_NORMAL = 0x02; + public static final int Q_NODEBUG = 0x04; + public static final int Q_CATCH_EXCEPTION = 0x08; + public static final int Q_PASS_EXCEPTION = 0x10; + + /* conversion flags */ + public static final int CVT_ATOM = 0x0001; + public static final int CVT_STRING = 0x0002; + public static final int CVT_LIST = 0x0004; + public static final int CVT_INTEGER = 0x0008; + public static final int CVT_FLOAT = 0x0010; + public static final int CVT_VARIABLE = 0x0020; + public static final int CVT_NUMBER = (CVT_INTEGER | CVT_FLOAT); + public static final int CVT_ATOMIC = (CVT_NUMBER | CVT_ATOM | CVT_STRING); + public static final int CVT_ALL = 0x00ff; + public static final int BUF_DISCARDABLE = 0x0000; + public static final int BUF_RING = 0x0100; + public static final int BUF_MALLOC = 0x0200; + + /* new, for revised term_t-to-Variable stuff */ + public static native int compare(term_t t1, term_t t2); // returns -1, 0 or 1 + + /* Creating and destroying term-refs */ + public static native term_t new_term_ref(); + public static native term_t new_term_refs(int n); + public static native term_t copy_term_ref(term_t from); // NOT USED + + /* Constants */ + public static native atom_t new_atom(String s); + public static native String atom_chars(atom_t a); + public static native functor_t new_functor(atom_t f, int a); + + public static native void unregister_atom(atom_t a); // called from atom_t's finalize() + + /* Get Java-values from Prolog terms */ + public static native boolean get_atom_chars(term_t t, StringHolder a); + public static native boolean get_string_chars(term_t t, StringHolder s); + public static native boolean get_integer(term_t t, Int64Holder i); + public static native boolean get_float(term_t t, DoubleHolder d); + public static native boolean get_name_arity(term_t t, StringHolder name, IntHolder arity); + public static native boolean get_arg(int index, term_t t, term_t a); + + public static native String object_to_tag(Object obj); + public static native Object tag_to_object(String tag); // 29/May/2008 + public static native boolean is_tag(String tag); // 30/May/2008 + + /* Verify types */ + public static native int term_type(term_t t); + + /* Assign to term-references */ + public static native void put_variable(term_t t); + public static native void put_integer(term_t t, long i); + public static native void put_float(term_t t, double f); + public static native void put_term(term_t t1, term_t t2); + public static native void put_jref(term_t t, Object ref); + + /* ... */ + public static native void cons_functor_v(term_t h, functor_t fd, term_t a0); + + // predicates: + public static native predicate_t predicate(String name, int arity, String module); + + // querying (general): + public static native qid_t open_query(module_t m, int flags, predicate_t pred, term_t t0); + public static native boolean next_solution(qid_t qid); + public static native void close_query(qid_t qid); + + // modules: + public static native module_t new_module(atom_t name); + + // exceptions: + public static native term_t exception(qid_t qid); + + // initialisation: + public static native String[] get_default_init_args(); + public static native boolean set_default_init_args(String argv[]); + public static native boolean initialise(); + public static native String[] get_actual_init_args(); + public static native void halt(int status); + + // thread & engine management: + public static native int thread_self(); + public static native engine_t attach_pool_engine(); + public static native int release_pool_engine(); + public static native engine_t current_engine(); + public static native boolean current_engine_is_pool(); + public static native int attach_engine(engine_t e); + + // misc. + public static native String get_c_lib_version(); + + // not yet working: + public static native int action_abort(); + + // revived 17/Jun/2008: + public static native fid_t open_foreign_frame(); + public static native void discard_foreign_frame(fid_t cid); + + // not used: + // public static native void reset_term_refs(term_t r); + // public static native atom_t functor_name(functor_t f); + // public static native int functor_arity(functor_t f); + // public static native boolean get_atom(term_t t, atom_t a); + // public static native boolean get_pointer(term_t t, PointerHolder ptr); + // public static native boolean get_functor(term_t t, functor_t f); + // public static native boolean get_module(term_t t, module_t module); + // public static native boolean get_jref(term_t t, ObjectHolder obj); + // public static native boolean get_jboolean(term_t t, BooleanHolder b); + // public static native boolean get_jpl_term(term_t t, ObjectHolder obj); // withdrawn 17/Oct/2004 + // public static native boolean is_variable(term_t t); + // public static native boolean is_atom(term_t t); + // public static native boolean is_integer(term_t t); + // public static native boolean is_float(term_t t); + // public static native boolean is_compound(term_t t); + // public static native boolean is_functor(term_t t, functor_t f); + // public static native boolean is_atomic(term_t t); + // public static native boolean is_number(term_t t); + // public static native void put_atom(term_t t, atom_t a); + // public static native void put_pointer(term_t t, PointerHolder ptr); + // public static native void put_functor(term_t t, functor_t functor); + // public static native void put_jboolean(term_t t, boolean b); + // public static native void put_jvoid(term_t t); + // public static native void cons_list(term_t l, term_t h, term_t t); + // public static native int unify(term_t t1, term_t t2); + // public static native predicate_t pred(functor_t f, module_t m); + // public static native int predicate_info(predicate_t pred, atom_t name, IntHolder arity, module_t module); + // public static native void cut_query(qid_t qid); + // public static native boolean call(term_t t, module_t m); + // public static native boolean call_predicate(module_t m, int debug, predicate_t pred, term_t t0); + // public static native void close_foreign_frame(fid_t cid); // NOT USED + // public static native void discard_foreign_frame(fid_t cid); // NOT USED + // public static native module_t context(); + // public static native atom_t module_name(module_t module); + // public static native int strip_module(term_t in, module_t m, term_t out); + // public static native int pool_engine_id(engine_t e); +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/StringHolder.java b/packages/jpl/jpl/src/java/jpl/fli/StringHolder.java new file mode 100644 index 000000000..eef50ddaf --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/StringHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// StringHolder +/** + * A StringHolder is merely a Holder class for a String value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class StringHolder +{ + public String value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/atom_t.java b/packages/jpl/jpl/src/java/jpl/fli/atom_t.java new file mode 100644 index 000000000..83bb94bff --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/atom_t.java @@ -0,0 +1,82 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// atom_t +/** + * An atom_t is a specialised LongHolder which decrements its atom's + * reference count when garbage-collected (finalized). + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class atom_t +extends LongHolder +{ + //------------------------------------------------------------------/ + // toString + /** + * The String representation of an atom_t is just the atom's name. + * + * @return atom's name + */ + // Implementation notes: + // + //------------------------------------------------------------------/ + public String + toString() + { + return Prolog.atom_chars( this ); + } + + protected void finalize() throws Throwable { + + super.finalize(); + Prolog.unregister_atom( this); + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/engine_t.java b/packages/jpl/jpl/src/java/jpl/fli/engine_t.java new file mode 100644 index 000000000..ab996b581 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/engine_t.java @@ -0,0 +1,56 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + +//----------------------------------------------------------------------/ +// engine_t +/** + * A engine_t holds a reference to a Prolog engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: Note that a engine_t is not a term, +// consistent with the treatment in the Prolog FLI. +//----------------------------------------------------------------------/ +public class engine_t extends LongHolder { +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/fid_t.java b/packages/jpl/jpl/src/java/jpl/fli/fid_t.java new file mode 100644 index 000000000..4cfb83730 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/fid_t.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// fid_t +/** + * An fid_t holds the value of a frame id in the Prolog Engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class fid_t +extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/functor_t.java b/packages/jpl/jpl/src/java/jpl/fli/functor_t.java new file mode 100644 index 000000000..7cee09c49 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/functor_t.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// functor_t +/** + * A functor_t holds a reference to a Prolog functor_t in the + * Prolog engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: Note that a functor_t is not a term, +// consistent with the treatment in the Prolog FLI. +//----------------------------------------------------------------------/ +public class functor_t +extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/module_t.java b/packages/jpl/jpl/src/java/jpl/fli/module_t.java new file mode 100644 index 000000000..e13f0d6f0 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/module_t.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// module_t +/** + * A module_t is a PointerHolder type which holds a reference to a Prolog + * module_t reference. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class module_t +extends PointerHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/predicate_t.java b/packages/jpl/jpl/src/java/jpl/fli/predicate_t.java new file mode 100644 index 000000000..d65327d69 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/predicate_t.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// predicate_t +/** + * A predicate_t is a PointerHolder class whose value is a reference to a + * Prolog predicate_t. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class predicate_t +extends PointerHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/qid_t.java b/packages/jpl/jpl/src/java/jpl/fli/qid_t.java new file mode 100644 index 000000000..7e663404d --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/qid_t.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// qid_t +/** + * A qid_t holds a reference to a Prolog qid_t. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class qid_t +extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/fli/term_t.java b/packages/jpl/jpl/src/java/jpl/fli/term_t.java new file mode 100644 index 000000000..ef23f862b --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/fli/term_t.java @@ -0,0 +1,133 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// term_t +/** + * A term_t is a simple class which mirrors the term_t type in + * the Prolog FLI. All it really does is hold a term reference, + * which is an internal representation of a term in the Prolog + * Engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class term_t +extends LongHolder +{ + public static final long UNASSIGNED = -1L; + + public + term_t() + { + value = UNASSIGNED; + } + + //------------------------------------------------------------------/ + // toString + /** + * This static method converts a term_t, which is assumed to contain + * a reference to a *consecutive* list of term_t references to a + * String representation of a list of terms, in this case, a comma + * separated list. + * + * @param n the number of consecutive term_ts + * @param term0 a term_t whose value is the 0th term_t. + */ + // Implementation notes: + // + //------------------------------------------------------------------/ + public static String + toString( int n, term_t term0 ) + { + String s = ""; + int i; + long ith_term_t; + + for ( i = 0, ith_term_t = term0.value; i < n; ++i, ++ith_term_t ){ + term_t term = new term_t(); + term.value = ith_term_t; + s += term.toString(); + + if ( i != n - 1 ){ + s += ", "; + } + } + + return s; + } + + + //------------------------------------------------------------------/ + // equals + /** + * Instances of term_ts are stored in Term objects (see jpl.Term), + * and these term_ts are in some cases stored in Hashtables. + * Supplying this predicate provides the right behavior in Hashtable + * lookup (see the rules for Hashtable lookup in java.util). + * + * Note. Two term_ts are *not* equal if their values have not + * been assigned. (Since Prolog FLI term_ts are unsigned values and + * the UNASSIGNED value is -1, this should work). + * + * @param obj the Object to comapre. + * @return true if the supplied object is a term_t instances + * and the long values are the same + */ + // Implementation notes: + // + //------------------------------------------------------------------/ + public boolean + equals( Object obj ) + { + return + (obj instanceof term_t) && + this.value == ((term_t)obj).value && + this.value != UNASSIGNED; + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/jpl/src/java/jpl/test/.cvsignore b/packages/jpl/jpl/src/java/jpl/test/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/src/java/jpl/test/CelsiusConverter.java b/packages/jpl/jpl/src/java/jpl/test/CelsiusConverter.java new file mode 100644 index 000000000..74248498c --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/CelsiusConverter.java @@ -0,0 +1,78 @@ +package jpl.test; + +/** + * CelsiusConverter.java is a 1.4 application that + * demonstrates the use of JButton, JTextField and + * JLabel. It requires no other files. + */ +import java.awt.*; +import java.awt.event.*; +import javax.swing.*; + +public class CelsiusConverter implements ActionListener { + JFrame converterFrame; + JPanel converterPanel; + JTextField tempCelsius; + JLabel celsiusLabel, fahrenheitLabel; + JButton convertTemp; + public CelsiusConverter() { // initially locate the window at top-left of desktop + this(0, 0); + } + public CelsiusConverter(int left, int top) { // initially locate the window at top-left of desktop + // create and set up the window + converterFrame = new JFrame("Convert Celsius to Fahrenheit"); + converterFrame.setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE); + converterFrame.setSize(new Dimension(120, 40)); + converterFrame.setLocation(left, top); + // create and set up the panel + converterPanel = new JPanel(new GridLayout(2, 2)); + // create widgets + tempCelsius = new JTextField(2); + celsiusLabel = new JLabel("Celsius", SwingConstants.LEFT); + celsiusLabel.setBorder(BorderFactory.createEmptyBorder(5, 5, 5, 5)); + // + convertTemp = new JButton("Convert"); + fahrenheitLabel = new JLabel("Fahrenheit", SwingConstants.LEFT); + // listen to events from the Convert button + convertTemp.addActionListener(this); + // add the widgets to the container + converterPanel.add(tempCelsius); + converterPanel.add(celsiusLabel); + converterPanel.add(convertTemp); + converterPanel.add(fahrenheitLabel); + fahrenheitLabel.setBorder(BorderFactory.createEmptyBorder(5, 5, 5, 5)); + converterFrame.getRootPane().setDefaultButton(convertTemp); // make "convert" the window's default button + // add the panel to the window + converterFrame.getContentPane().add(converterPanel, BorderLayout.CENTER); + // display the window + converterFrame.pack(); + converterFrame.setVisible(true); + } + public void actionPerformed(ActionEvent event) { + // parse degrees Celsius as a double + double tC = (Double.parseDouble(tempCelsius.getText())); + // + // convert to Fahrenheit (in Java) + // int tempFahr = (int) (tC * 1.8 + 32); + // + // convert to Fahrenheit (in Prolog, via JPL) + int tempFahr = ((jpl.Float) jpl.Query.oneSolution("TF is ? * 1.8 + 32", new jpl.Term[] {new jpl.Float(tC)}).get("TF")).intValue(); + // + // display the result + fahrenheitLabel.setText(tempFahr + " Fahrenheit"); + } + public static void spawnGUI(final int left, final int top) { + // schedule a job for the event-dispatching thread: create and show an instance of this application at (left,top) + javax.swing.SwingUtilities.invokeLater(new Runnable() { + int x = left; + int y = top; + public void run() { + new CelsiusConverter(x, y); // can we be sure this won't be garbage collected? + } + }); + } + public static void main(String[] args) { + // just for fun, we ask Prolog to start five instances of this class (at stepped offsets from top-left of display) + jpl.Query.allSolutions("between(1, 5, N), X is 10*N, Y is 20*N, jpl_call('jpl.test.CelsiusConverter', spawnGUI, [X,Y], _)"); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/Family.java b/packages/jpl/jpl/src/java/jpl/test/Family.java new file mode 100644 index 000000000..714feba14 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/Family.java @@ -0,0 +1,96 @@ +package jpl.test; +import jpl.Atom; +import jpl.Query; +import jpl.Term; +import jpl.Variable; + +public class Family extends Thread { + + int id; // client thread id + private static final int delay = 0; + + Family(int i) { + this.id = i; + } + + public static void main(String argv[]) { + + Query q1 = new Query("consult", new Term[] { new Atom("jpl/test/family.pl")}); + System.err.println("consult " + (q1.hasSolution() ? "succeeded" : "failed")); + + for (int i = 0; i < 20; i++) { + System.out.println("spawning client[" + i + "]"); + new Family(i).start(); + } + + } + + public void run() { + java.util.Hashtable solution; + Variable X = new Variable("X"); + + //-------------------------------------------------- + + Query q2 = new Query("child_of", new Term[] { new Atom("joe"), new Atom("ralf")}); + + System.err.println("child_of(joe,ralf) is " + (q2.hasSolution() ? "provable" : "not provable")); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + Query q3 = new Query("descendent_of", new Term[] { new Atom("steve"), new Atom("ralf")}); + + System.err.println("descendent_of(steve,ralf) is " + (q3.hasSolution() ? "provable" : "not provable")); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + Query q4 = new Query("descendent_of", new Term[] { X, new Atom("ralf")}); + + solution = q4.oneSolution(); + + System.err.println("first solution of descendent_of(X, ralf)"); + System.err.println("X = " + solution.get(X.name)); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + java.util.Hashtable[] solutions = q4.allSolutions(); + + System.err.println("all solutions of descendent_of(X, ralf)"); + for (int i = 0; i < solutions.length; i++) { + System.err.println("X = " + solutions[i].get(X.name)); + } + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + System.err.println("each solution of descendent_of(X, ralf)"); + while (q4.hasMoreSolutions()) { + solution = q4.nextSolution(); + System.err.println("X = " + solution.get(X.name)); + } + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + Variable Y = new Variable("Y"); + + Query q5 = new Query("descendent_of", new Term[] { X, Y }); + + System.err.println(id + ": each solution of descendent_of(X, Y)"); + while (q5.hasMoreSolutions()) { + solution = q5.nextSolution(); + System.err.println(id + ": X = " + solution.get(X.name) + ", Y = " + solution.get(Y.name)); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + } + + } + +} diff --git a/packages/jpl/jpl/src/java/jpl/test/FetchBigTree.java b/packages/jpl/jpl/src/java/jpl/test/FetchBigTree.java new file mode 100644 index 000000000..0983453a7 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/FetchBigTree.java @@ -0,0 +1,18 @@ +package jpl.test; + +import jpl.Query; +import jpl.Term; + +public class FetchBigTree { + public static void main(String[] args) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + (new Query("consult('jpl/test/test.pl')")).oneSolution(); + Term t = (Term)((new Query("p(18,T)")).oneSolution().get("T")); + int i = 1; + while ( t.hasFunctor("a", 2)){ + t = t.arg(2); + i = i+1; + } + System.err.println("got a tree of " + i+" generations"); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/FetchLongList.java b/packages/jpl/jpl/src/java/jpl/test/FetchLongList.java new file mode 100644 index 000000000..76a84ae4f --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/FetchLongList.java @@ -0,0 +1,17 @@ +package jpl.test; + +import jpl.Query; +import jpl.Term; + +public class FetchLongList { + public static void main(String[] args) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + Term t = (Term)((new Query("findall(foo(N,bar),between(1,2308,N),L)")).oneSolution().get("L")); + int i = 0; + while ( t.hasFunctor(".", 2)){ + t = t.arg(2); + i = i+1; + } + System.err.println("got a list of " + i+" members"); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/Ga.java b/packages/jpl/jpl/src/java/jpl/test/Ga.java new file mode 100644 index 000000000..53f2b6c7e --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/Ga.java @@ -0,0 +1,23 @@ +package jpl.test; + +import jpl.Query; + +public class Ga { + public static void main(String argv[]) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + // (new Query("loadall(jpl_test:jr)")).hasSolution(); + // System.err.println("jr " + ((new Query("jr")).hasSolution() ? "succeeded" : "failed")); + // System.err.println( "something " + (new Query("statistics(atoms,X)")).oneSolution().get("X")); + // Query.hasSolution("statistics"); + // (new Query("x")).hasSolution(); + // (new Query("statistics,x")).hasSolution(); + // (new Query(new Atom("statistics"))).hasSolution(); + // Query.hasSolution("write(hello),nl"); + // Query.hasSolution("write(hello),nl"); + + // (new Query("nl")).hasSolution(); + (new Query("nl,nl")).hasSolution(); + + // (new Query("user:nl")).hasSolution(); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/Ga2.java b/packages/jpl/jpl/src/java/jpl/test/Ga2.java new file mode 100644 index 000000000..64c32a5c7 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/Ga2.java @@ -0,0 +1,10 @@ +package jpl.test; + +import jpl.Query; + +public class Ga2 { + public static void main(String argv[]) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + (new Query("current_prolog_flag(K,V),write(K-V),nl,fail")).oneSolution(); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/Garbo.java b/packages/jpl/jpl/src/java/jpl/test/Garbo.java new file mode 100644 index 000000000..0d1216945 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/Garbo.java @@ -0,0 +1,19 @@ +package jpl.test; + +public class Garbo { + public static int created = 0; + public static int destroyed = 0; + // + public final int i; + public Garbo( ) { + this.i = created++; + } + protected void finalize() throws Throwable { + try { + destroyed++; + // System.out.println("gced["+i+"]"); + } finally { + super.finalize(); + } + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/JPLTest.java b/packages/jpl/jpl/src/java/jpl/test/JPLTest.java new file mode 100644 index 000000000..3907b7a64 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/JPLTest.java @@ -0,0 +1,93 @@ +/* + * JPLTest.java + * JUnit based test + * + * Created on 13 February 2006, 11:31 + */ +package jpl.test; + +import java.util.concurrent.CountDownLatch; +import java.util.concurrent.TimeUnit; +import java.util.logging.Logger; +import junit.framework.*; +import jpl.*; + +/** + * + * @author rick + */ +public class JPLTest extends TestCase { + // private static final Logger logger = Logger.getLogger(JPLTest.class.getName()); + private CountDownLatch latch; + public JPLTest(String testName) { + super(testName); + } + protected void setUp() throws Exception { + /* + * Prolog file can be an empty file. The JVM seems to crash with a + * SIGSEGV if you don't consult a file prior to interacting with JPL. + + final String prologFile = "jpl/test/test.pl"; // was "/home/rick/temp/test.pl"; + System.out.println("prolog file is: " + prologFile); + String qString = "consult('" + prologFile + "')"; + System.out.println("about to: " + qString); + Query query = new Query(qString); + System.out.println("Generated Query: " + query); + if (!query.hasSolution()) { + System.out.println(qString + " failed"); + fail("Failed to consult prolog file."); + } + + (new Query("true")).hasSolution(); + */ + } + public void testThreadedAdds() { + latch = new CountDownLatch(4); + final AddWithThreads[] addTasks = { new AddWithThreads("a", latch), new AddWithThreads("b", latch), new AddWithThreads("c", latch), new AddWithThreads("d", latch) }; + // System.out.println("Starting threads..."); + for (int i = 0; i < addTasks.length; i++) { + addTasks[i].start(); + } + try { + // System.out.println("Latch is waiting"); + assertTrue("Timed out waiting for action to execute", latch.await(20, TimeUnit.SECONDS)); + // System.out.println("Latch has been flipped"); + } catch (final InterruptedException e) { + fail("Waiting thread was interrupted: " + e); + } + for (int i = 0; i < AddWithThreads.REPS; i++) { + for (int j = 0; j < addTasks.length; j++) { + Query query = new Query(addTasks[j].getNamespace() + "(test('" + i + "'))"); + // System.out.println("query: " + query); + boolean ret = query.hasMoreElements(); + query.close(); + } + } + } +} + +class AddWithThreads extends Thread { + private final CountDownLatch latch; + private final String namespace; + private static final Logger logger = Logger.getLogger(JPLTest.class.getName()); + public static final int REPS = 2000; // was 200 + public AddWithThreads(final String namespace, final CountDownLatch latch) { + this.latch = latch; + this.namespace = namespace; + setName("namespace" + namespace); //set thread name for debugging + } + public String getNamespace() { + return namespace; + } + public void run() { + for (int i = 0; i < REPS; i++) { + // System.out.println("Asserting test('" + i + "')"); + Query queryA = new Query("assert(" + namespace + "(test('" + i + "')))"); + Thread.yield(); + // System.out.println("adding query: " + queryA); + boolean retA = queryA.hasMoreElements(); + queryA.close(); + } + latch.countDown(); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/Masstest.java b/packages/jpl/jpl/src/java/jpl/test/Masstest.java new file mode 100644 index 000000000..59ccafc57 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/Masstest.java @@ -0,0 +1,42 @@ +package jpl.test; + +import jpl.Query; +import jpl.fli.Prolog; + +public class Masstest extends Thread { + public static void main(String[] args) { + // String[] dia = Prolog.get_default_init_args(); + // String s = "default init args: "; + // for (int i = 0; i < dia.length; i++) { + // s += " " + dia[i]; + // } + // System.out.println(s); + // + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "none", "-g", "true", "-q" }); + // empirically, needs this at least: + // Prolog.set_default_init_args(new String[] { "libpl.dll" }); + // Prolog.set_default_init_args(new String[] { "pl" }); + // + // (new Query("assert(diagnose_declaration(_,_,_,[not,a,real,error]))")).hasSolution(); + // + int STUDENTSNUMBER = 5; + Masstest[] threads = new Masstest[STUDENTSNUMBER]; + for (int i = 0; i < STUDENTSNUMBER; i++) { + threads[i] = new Masstest(); + threads[i].start(); + } + } + public void predQuery() { + String st = "diagnose_declaration(1,[(sp, 'prefix', [('arg1', '+', 'list', 'Liste1'), ('arg2', '+', 'list', 'Liste2')])], DecMap, ErrorList)"; + Query stQuery = new Query(st); + String errString = stQuery.oneSolution().get("ErrorList").toString(); + System.out.println("errString=" + errString); + } + public void run() { + try { + predQuery(); + } catch (Exception e) { + System.err.println("ERROR: " + e); + } + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/MaxObjects.java b/packages/jpl/jpl/src/java/jpl/test/MaxObjects.java new file mode 100644 index 000000000..16bcf92c7 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/MaxObjects.java @@ -0,0 +1,4 @@ +package jpl.test; + +public class MaxObjects { +} diff --git a/packages/jpl/jpl/src/java/jpl/test/ShadowA.java b/packages/jpl/jpl/src/java/jpl/test/ShadowA.java new file mode 100644 index 000000000..c537ae15c --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/ShadowA.java @@ -0,0 +1,13 @@ +/* + * Created on 22-Nov-2004 + * + * TODO To change the template for this generated file go to + * Window - Preferences - Java - Code Style - Code Templates + */ +package jpl.test; + + +public class ShadowA { + public int shadow = -1; + public static int fieldStaticInt; +} \ No newline at end of file diff --git a/packages/jpl/jpl/src/java/jpl/test/ShadowB.java b/packages/jpl/jpl/src/java/jpl/test/ShadowB.java new file mode 100644 index 000000000..37c1a8637 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/ShadowB.java @@ -0,0 +1,16 @@ +/* + * Created on 22-Nov-2004 + * + * TODO To change the template for this generated file go to + * Window - Preferences - Java - Code Style - Code Templates + */ +package jpl.test; + + +public class ShadowB extends ShadowA { + public String shadow; + public ShadowB(String s) { + shadow = s; + } + public static int fieldStaticInt; +} \ No newline at end of file diff --git a/packages/jpl/jpl/src/java/jpl/test/SyntaxError.java b/packages/jpl/jpl/src/java/jpl/test/SyntaxError.java new file mode 100644 index 000000000..c224b6510 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/SyntaxError.java @@ -0,0 +1,10 @@ +package jpl.test; + +import jpl.Query; + +public class SyntaxError { + public static void main(String argv[]) { + Query q = new Query("syntax)error"); + System.err.println(q.hasSolution() ? "yes" : "no"); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/Test.java b/packages/jpl/jpl/src/java/jpl/test/Test.java new file mode 100644 index 000000000..746f4eaab --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/Test.java @@ -0,0 +1,287 @@ +package jpl.test; + +import jpl.Compound; +import jpl.Query; +import jpl.Term; + +// This class contains members which support those tests which are performed from Prolog. +// See also TestJUnit +public class Test { + public Test() { + } + public Test(Term t) { + this.termFromConstructor = t; + } + public Term termFromConstructor; + // + public static boolean fieldStaticBoolean; + public static final boolean fieldStaticBoolean1 = false; + public static final boolean fieldStaticBoolean2 = true; + // + public static char fieldStaticChar; + public static final char fieldStaticChar1 = '\u0000'; + public static final char fieldStaticChar2 = '\uFFFF'; + // + public static byte fieldStaticByte; + public static final byte fieldStaticByte1 = -(1 << 7); + public static final byte fieldStaticByte2 = -1; + public static final byte fieldStaticByte3 = 0; + public static final byte fieldStaticByte4 = 1; + public static final byte fieldStaticByte5 = (1 << 7) - 1; + // + public static short fieldStaticShort; + public static final short fieldStaticShort1 = -(1 << 15); + public static final short fieldStaticShort2 = -(1 << 7); + public static final short fieldStaticShort3 = -1; + public static final short fieldStaticShort4 = 0; + public static final short fieldStaticShort5 = 1; + public static final short fieldStaticShort6 = (1 << 7) - 1; + public static final short fieldStaticShort7 = (1 << 15) - 1; + // + public static int fieldStaticInt; + public static final int fieldStaticInt1 = -(1 << 31); + public static final int fieldStaticInt2 = -(1 << 15); + public static final int fieldStaticInt3 = -(1 << 7); + public static final int fieldStaticInt4 = -1; + public static final int fieldStaticInt5 = 0; + public static final int fieldStaticInt6 = 1; + public static final int fieldStaticInt7 = (1 << 7) - 1; + public static final int fieldStaticInt8 = (1 << 15) - 1; + public static final int fieldStaticInt9 = (1 << 31) - 1; + // + public static long fieldStaticLong; + public static final long fieldStaticLong1 = -(1 << 63); + public static final long fieldStaticLong2 = -(1 << 31); + public static final long fieldStaticLong3 = -(1 << 15); + public static final long fieldStaticLong4 = -(1 << 7); + public static final long fieldStaticLong5 = -1; + public static final long fieldStaticLong6 = 0; + public static final long fieldStaticLong7 = 1; + public static final long fieldStaticLong8 = (1 << 7) - 1; + public static final long fieldStaticLong9 = (1 << 15) - 1; + public static final long fieldStaticLong10 = (1 << 31) - 1; + public static final long fieldStaticLong11 = (1 << 63) - 1; + // + public static float fieldStaticFloat; + public static final float fieldStaticFloat1 = 12345.6789F; + public static final float fieldStaticFloat2 = 3.4e+38F; // nearly MAX_VALUE + public static final float fieldStaticFloat3 = 1.4e-45F; // nearly MIN_VALUE + public static final float fieldStaticFloat4 = 0.0F; + public static final float fieldStaticFloat5 = java.lang.Float.MIN_VALUE; + public static final float fieldStaticFloat6 = java.lang.Float.MAX_VALUE; + public static final float fieldStaticFloat7 = java.lang.Float.NEGATIVE_INFINITY; + public static final float fieldStaticFloat8 = java.lang.Float.POSITIVE_INFINITY; + public static final float fieldStaticFloat9 = java.lang.Float.NaN; + // + public static double fieldStaticDouble; + public static final double fieldStaticDouble1 = 12345.6789D; + public static final double fieldStaticDouble2 = 2.3456789e+100D; + public static final double fieldStaticDouble3 = 3.456789e-100D; + public static final double fieldStaticDouble4 = 0.0D; + public static final double fieldStaticDouble5 = Double.MIN_VALUE; + public static final double fieldStaticDouble6 = Double.MAX_VALUE; + public static final double fieldStaticDouble7 = Double.NEGATIVE_INFINITY; + public static final double fieldStaticDouble8 = Double.POSITIVE_INFINITY; + public static final double fieldStaticDouble9 = Double.NaN; + // + public static Object[] fieldStaticObjectArray; // can assign e.g. String[] + public static long[] fieldStaticLongArray; // cannot assign e.g. int[] + // + public static long fac(long n) { // complements jpl:jpl_test_fac(+integer,-integer) + if (n == 1) { + return 1; + } else if (n > 1) { + // return n * ((Integer) new Query(new Compound("jpl_test_fac", new Term[] { new Integer(n - 1), new Variable("F") })).oneSolution().get("F")).intValue(); + return n * ((jpl.Integer) Query.oneSolution("jpl_test_fac(?,F)", new Term[] {new jpl.Integer(n-1)}).get("F")).longValue(); + } else { + return 0; + } + } + static void packageMethod() { // not callable via JPL + return; + } + public static void publicMethod() { + return; + } + protected static void protectedMethod() { // not callable via JPL + return; + } + private static void privateMethod() { // not callable via JPL + return; + } + public boolean fieldInstanceBoolean; + public final boolean fieldInstanceBoolean1 = false; + public final boolean fieldInstanceBoolean2 = true; + public byte fieldInstanceByte; + public final byte fieldInstanceByte1 = -(1 << 7); + public final byte fieldInstanceByte2 = -1; + public final byte fieldInstanceByte3 = 0; + public final byte fieldInstanceByte4 = 1; + public final byte fieldInstanceByte5 = (1 << 7) - 1; + public char fieldInstanceChar; + public final char fieldInstanceChar1 = '\u0000'; + public final char fieldInstanceChar2 = '\uFFFF'; + public double fieldInstanceDouble; + public final double fieldInstanceDouble1 = 12345.6789D; + public final double fieldInstanceDouble2 = 2.3456789e+100D; + public final double fieldInstanceDouble3 = 3.456789e-100D; + public final double fieldInstanceDouble4 = 0.0D; + public final double fieldInstanceDouble5 = Double.MIN_VALUE; + public final double fieldInstanceDouble6 = Double.MAX_VALUE; + public final double fieldInstanceDouble7 = Double.NEGATIVE_INFINITY; + public final double fieldInstanceDouble8 = Double.POSITIVE_INFINITY; + public final double fieldInstanceDouble9 = Double.NaN; + public float fieldInstanceFloat; + public final float fieldInstanceFloat1 = 12345.6789F; + public final float fieldInstanceFloat2 = 3.4e+38F; + public final float fieldInstanceFloat3 = 1.4e-45F; + public final float fieldInstanceFloat4 = 0.0F; + public final float fieldInstanceFloat5 = java.lang.Float.MIN_VALUE; + public final float fieldInstanceFloat6 = java.lang.Float.MAX_VALUE; + public final float fieldInstanceFloat7 = java.lang.Float.NEGATIVE_INFINITY; + public final float fieldInstanceFloat8 = java.lang.Float.POSITIVE_INFINITY; + public final float fieldInstanceFloat9 = java.lang.Float.NaN; + public int fieldInstanceInt; + public final int fieldInstanceInt1 = -(1 << 31); + public final int fieldInstanceInt2 = -(1 << 15); + public final int fieldInstanceInt3 = -(1 << 7); + public final int fieldInstanceInt4 = -1; + public final int fieldInstanceInt5 = 0; + public final int fieldInstanceInt6 = 1; + public final int fieldInstanceInt7 = (1 << 7) - 1; + public final int fieldInstanceInt8 = (1 << 15) - 1; + public final int fieldInstanceInt9 = (1 << 31) - 1; + public long fieldInstanceLong; + public final long fieldInstanceLong1 = -(1 << 63); + public final long fieldInstanceLong10 = (1 << 31) - 1; + public final long fieldInstanceLong11 = (1 << 63) - 1; + public final long fieldInstanceLong2 = -(1 << 31); + public final long fieldInstanceLong3 = -(1 << 15); + public final long fieldInstanceLong4 = -(1 << 7); + public final long fieldInstanceLong5 = -1; + public final long fieldInstanceLong6 = 0; + public final long fieldInstanceLong7 = 1; + public final long fieldInstanceLong8 = (1 << 7) - 1; + public final long fieldInstanceLong9 = (1 << 15) - 1; + public short fieldInstanceShort; + public final short fieldInstanceShort1 = -(1 << 15); + public final short fieldInstanceShort2 = -(1 << 7); + public final short fieldInstanceShort3 = -1; + public final short fieldInstanceShort4 = 0; + public final short fieldInstanceShort5 = 1; + public final short fieldInstanceShort6 = (1 << 7) - 1; + public final short fieldInstanceShort7 = (1 << 15) - 1; + // + public Term term; // obsolete + public static Term staticTerm; + public Term instanceTerm; + // + // for testing accessibility of non-public fields: + static boolean fieldPackageStaticBoolean; + protected static boolean fieldProtectedStaticBoolean; + private static boolean fieldPrivateStaticBoolean; + // + // for testing update of final field: + public static final int fieldStaticFinalInt = 7; + // + // for testing passing general terms in from Prolog: + public static Term fieldStaticTerm; + public Term fieldInstanceTerm; + public static boolean methodStaticTerm(Term t) { + return t != null; + } + public boolean methodInstanceTerm(Term t) { + return t != null; + } + public static Term methodStaticEchoTerm(Term t) { + return t; + } + public static boolean methodStaticEchoBoolean(boolean v) { + return v; + } + public static char methodStaticEchoChar(char v) { + return v; + } + public static byte methodStaticEchoByte(byte v) { + return v; + } + public static short methodStaticEchoShort(short v) { + return v; + } + public static int methodStaticEchoInt(int v) { + return v; + } + public static long methodStaticEchoLong(long v) { + return v; + } + public static float methodStaticEchoFloat(float v) { + return v; + } + public static double methodStaticEchoDouble(double v) { + return v; + } + public Term methodInstanceTermEcho(Term t) { + return t; + } + public static boolean methodStaticTermIsJNull(Term t) { + return t.hasFunctor("@", 1) && t.arg(1).hasFunctor("null", 0); + } + public boolean methodInstanceTermIsJNull(Term t) { + return t.hasFunctor("@", 1) && t.arg(1).hasFunctor("null", 0); + } + public static void hello() { + System.out.println("hello"); + } + public static boolean[] newArrayBooleanFromValue(boolean v) { + boolean[] a = new boolean[1]; + a[0] = v; + return a; + } + public static byte[] newArrayByteFromValue(byte v) { + byte[] a = new byte[1]; + a[0] = v; + return a; + } + public static char[] newArrayCharFromValue(char v) { + char[] a = new char[1]; + a[0] = v; + return a; + } + public static short[] newArrayShortFromValue(short v) { + short[] a = new short[1]; + a[0] = v; + return a; + } + public static int[] newArrayIntFromValue(int v) { + int[] a = new int[1]; + a[0] = v; + return a; + } + public static long[] newArrayLongFromValue(long v) { + long[] a = new long[1]; + a[0] = v; + return a; + } + public static float[] newArrayFloatFromValue(float v) { + float[] a = new float[1]; + a[0] = v; + return a; + } + public static double[] newArrayDoubleFromValue(double v) { + double[] a = new double[1]; + a[0] = v; + return a; + } + public static String methodStaticArray(long[] a) { + return "long[]"; + } + public static String methodStaticArray(int[] a) { + return "int[]"; + } + public static String methodStaticArray(short[] a) { + return "short[]"; + } + public static Term wrapTerm(Term in) { // for dmiles 11/Jul/2008 + return new Compound("javaWrap", new Term[] {in}); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/test/TestJUnit.java b/packages/jpl/jpl/src/java/jpl/test/TestJUnit.java new file mode 100644 index 000000000..bda291eeb --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/TestJUnit.java @@ -0,0 +1,680 @@ +// Created on 25-Jul-2004 +package jpl.test; + +import java.util.Map; + +import jpl.Atom; +import jpl.Compound; +import jpl.Integer; +import jpl.JPL; +import jpl.PrologException; +import jpl.Query; +import jpl.Term; +import jpl.Util; +import jpl.Variable; +import jpl.fli.Prolog; +import junit.framework.TestCase; +import junit.framework.TestSuite; + +// This class defines all the tests which are run from Java. +// It needs junit.framework.TestCase and junit.framework.TestSuite, which are not supplied with JPL. +public class TestJUnit extends TestCase { + public static long fac(long n) { // complements jpl:jpl_test_fac(+integer,-integer) + if (n == 1) { + return 1; + } else if (n > 1) { + return n * ((jpl.Integer) Query.oneSolution("jpl_test_fac(?,F)", new Term[] { new jpl.Integer(n - 1) }).get("F")).longValue(); + } else { + return 0; + } + } + public TestJUnit(String name) { + super(name); + } + public static junit.framework.Test suite() { + return new TestSuite(TestJUnit.class); + } + public static void main(String args[]) { + junit.textui.TestRunner.run(suite()); + } + protected void setUp() { + // initialization code + String startup = System.getenv("SWIPL_BOOT_FILE"); + if ( startup == null ) { + startup = "../../src/swipl.prc"; + } + Prolog.set_default_init_args(new String[] { "swipl.dll", "-x", startup, "-f", "none", "-g", "true", "-q", "--home=../.." }); + assertTrue((new Query("consult(test_jpl)")).hasSolution()); + assertTrue((new Query("use_module(library(jpl))")).hasSolution()); + } + protected void tearDown() { + // cleanup code + } + // + public void testMasstest() { + assertTrue((new Query("assert(diagnose_declaration(_,_,_,[not,a,real,error]))")).hasSolution()); + } + public void testSameLibVersions1() { + String java_lib_version = JPL.version_string(); + String c_lib_version = jpl.fli.Prolog.get_c_lib_version(); + assertTrue("java_lib_version(" + java_lib_version + ") is same as c_lib_version(" + c_lib_version + ")", java_lib_version.equals(c_lib_version)); + } + public void testSameLibVersions2() { + String java_lib_version = JPL.version_string(); + String pl_lib_version = ((Term) (new Query(new Compound("jpl_pl_lib_version", new Term[] { new Variable("V") })).oneSolution().get("V"))).name(); + assertTrue("java_lib_version(" + java_lib_version + ") is same as pl_lib_version(" + pl_lib_version + ")", java_lib_version.equals(pl_lib_version)); + } + public void testAtomName1() { + String name = "fred"; + Atom a = new Atom(name); + assertEquals("an Atom's name is that with which it was created", a.name(), name); + } + public void testAtomName2() { + String name = "ha ha"; + Atom a = new Atom(name); + assertEquals("an Atom's name is that with which it was created", a.name(), name); + } + public void testAtomName3() { + String name = "3"; + Atom a = new Atom(name); + assertEquals("an Atom's name is that with which it was created", a.name(), name); + } + public void testAtomToString1() { + String name = "fred"; + String toString = "fred"; + Atom a = new Atom(name); + assertEquals("an Atom's .toString() value is quoted iff appropriate", a.toString(), toString); + } + public void testAtomToString2() { + String name = "ha ha"; + String toString = "'ha ha'"; + Atom a = new Atom(name); + assertEquals("an Atom's .toString() value is quoted iff appropriate", a.toString(), toString); + } + public void testAtomToString3() { + String name = "3"; + String toString = "'3'"; + Atom a = new Atom(name); + assertEquals("an Atom's .toString() value is quoted iff appropriate", a.toString(), toString); + } + public void testAtomArity() { + Atom a = new Atom("willy"); + assertEquals("an Atom has arity zero", a.arity(), 0); + } + public void testAtomEquality1() { + String name = "fred"; + Atom a1 = new Atom(name); + Atom a2 = new Atom(name); + assertEquals("two Atoms created with the same name are equal", a1, a2); + } + public void testAtomIdentity() { // how could this fail?! + String name = "fred"; + Atom a1 = new Atom(name); + Atom a2 = new Atom(name); + assertNotSame("two Atoms created with the same name are not identical", a1, a2); + } + public void testAtomHasFunctorNameZero() { + String name = "sam"; + Atom a = new Atom(name); + assertTrue(a.hasFunctor(name, 0)); + } + public void testAtomHasFunctorWrongName() { + assertFalse("an Atom does not have a functor whose name is other than that with which the Atom was created", new Atom("wally").hasFunctor("poo", 0)); + } + public void testAtomHasFunctorWrongArity() { + String name = "ted"; + assertFalse("an Atom does not have a functor whose arity is other than zero", new Atom(name).hasFunctor(name, 1)); + } + public void testVariableBinding1() { + Term lhs = new Compound("p", new Term[] { new Variable("X"), new Variable("Y") }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + Map soln = new Query(goal).oneSolution(); + assertTrue("two variables with different names can bind to distinct atoms", soln != null && ((Term) soln.get("X")).name().equals("a") && ((Term) soln.get("Y")).name().equals("b")); + } + public void testVariableBinding2() { + Term lhs = new Compound("p", new Term[] { new Variable("X"), new Variable("X") }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertFalse("two distinct Variables with same name cannot unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testVariableBinding3() { + Variable X = new Variable("X"); + Term lhs = new Compound("p", new Term[] { X, X }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertFalse("two occurrences of same named Variable cannot unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testVariableBinding4() { + Term lhs = new Compound("p", new Term[] { new Variable("_"), new Variable("_") }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertTrue("two distinct anonymous Variables can unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testVariableBinding5() { + Variable Anon = new Variable("_"); + Term lhs = new Compound("p", new Term[] { Anon, Anon }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertTrue("two occurrences of same anonymous Variable can unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testAtomEquality2() { + Atom a = new Atom("a"); + assertTrue("two occurrences of same Atom are equal by .equals()", a.equals(a)); + } + public void testAtomEquality3() { + assertTrue("two distinct Atoms with same names are equal by .equals()", (new Atom("a")).equals(new Atom("a"))); + } + public void testTextToTerm1() { + String text = "fred(B,p(A),[A,B,C])"; + Term t = Util.textToTerm(text); + assertTrue("Util.textToTerm() converts \"fred(B,p(A),[A,B,C])\" to a corresponding Term", t.hasFunctor("fred", 3) && t.arg(1).isVariable() && t.arg(1).name().equals("B") + && t.arg(2).hasFunctor("p", 1) && t.arg(2).arg(1).isVariable() && t.arg(2).arg(1).name().equals("A")); + } + public void testArrayToList1() { + Term l2 = Util.termArrayToList(new Term[] { new Atom("a"), new Atom("b"), new Atom("c"), new Atom("d"), new Atom("e") }); + Query q9 = new Query(new Compound("append", new Term[] { new Variable("Xs"), new Variable("Ys"), l2 })); + assertTrue("append(Xs,Ys,[a,b,c,d,e]) has 6 solutions", q9.allSolutions().length == 6); + } + public void testArrayToList2() { + String goal = "append(Xs,Ys,[a,b,c,d,e])"; + assertTrue(goal + " has 6 solutions", Query.allSolutions(goal).length == 6); + } + public void testLength1() { + Query q5 = new Query(new Compound("length", new Term[] { new Variable("Zs"), new jpl.Integer(2) })); + Term zs = (Term) (q5.oneSolution().get("Zs")); + assertTrue("length(Zs,2) binds Zs to a list of two distinct variables " + zs.toString(), zs.hasFunctor(".", 2) && zs.arg(1).isVariable() && zs.arg(2).hasFunctor(".", 2) + && zs.arg(2).arg(1).isVariable() && zs.arg(2).arg(2).hasFunctor("[]", 0) && !zs.arg(1).name().equals(zs.arg(2).arg(1).name())); + } + public void testGenerate1() { // we chickened out of verifying each solution :-) + String goal = "append(Xs,Ys,[_,_,_,_,_])"; + assertTrue(goal + " has 6 solutions", Query.allSolutions(goal).length == 6); + } + public void testPrologException1() { + try { + new Query("p(]"); // writes junk to stderr and enters debugger unless flag debug_on_error = false + } catch (PrologException e) { + assertTrue("new Query(\"p(]\") throws a PrologException " + e.toString(), true); + return; + } + fail("new Query(\"p(]\") oughta throw a PrologException"); + } + public void testAtom1() { + assertTrue("new Atom(\"3 3\")" + (new Atom("3 3")).toString(), true); + } + public void testTextToTerm2() { + String text1 = "fred(?,2,?)"; + String text2 = "[first(x,y),A]"; + Term plist = Util.textToTerm(text2); + Term[] ps = plist.toTermArray(); + Term t = Util.textToTerm(text1).putParams(ps); + assertTrue("fred(?,2,?) .putParams( [first(x,y),A] )", t.hasFunctor("fred", 3) && t.arg(1).hasFunctor("first", 2) && t.arg(1).arg(1).hasFunctor("x", 0) && t.arg(1).arg(2).hasFunctor("y", 0) + && t.arg(2).hasFunctor(2, 0) && t.arg(3).isVariable() && t.arg(3).name().equals("A")); + } + public void testDontTellMeMode1() { + final Query q = new Query("setof(_M,current_module(_M),_Ms),length(_Ms,N)"); + JPL.setDTMMode(true); + assertTrue("in dont-tell-me mode, setof(_M,current_module(_M),_Ms),length(_Ms,N) returns binding for just one variable", q.oneSolution().keySet().size() == 1); + } + public void testDontTellMeMode2() { + final Query q = new Query("setof(_M,current_module(_M),_Ms),length(_Ms,N)"); + JPL.setDTMMode(false); + assertTrue("not in dont-tell-me mode, setof(_M,current_module(_M),_Ms),length(_Ms,N) returns binding for three variables", q.oneSolution().keySet().size() == 3); + } + public void testModulePrefix1() { + assertTrue(Query.hasSolution("call(user:true)")); + } + private void testMutualRecursion(int n, long f) { // f is the expected result for fac(n) + try { + assertEquals("mutual recursive Java<->Prolog factorial: fac(" + n + ") = " + f, fac(n), f); + } catch (Exception e) { + fail("fac(" + n + ") threw " + e); + } + } + public void testMutualRecursion1() { + testMutualRecursion(1, 1); + } + public void testMutualRecursion2() { + testMutualRecursion(2, 2); + } + public void testMutualRecursion3() { + testMutualRecursion(3, 6); + } + public void testMutualRecursion10() { + testMutualRecursion(10, 3628800); + } + public void testIsJNull1() { + Term t = (Term) (new Query("X = @(null)")).oneSolution().get("X"); + assertTrue("@(null) . isJNull() succeeds", t.isJNull()); + } + public void testIsJNull2() { + Term t = (Term) (new Query("X = @(3)")).oneSolution().get("X"); + assertFalse("@(3) . isJNull() fails", t.isJNull()); + } + public void testIsJNull3() { + Term t = (Term) (new Query("X = _")).oneSolution().get("X"); + assertFalse("_ . isJNull() fails", t.isJNull()); + } + public void testIsJNull4() { + Term t = (Term) (new Query("X = @(true)")).oneSolution().get("X"); + assertFalse("@(true) . isJNull() fails", t.isJNull()); + } + public void testIsJNull5() { + Term t = (Term) (new Query("X = @(false)")).oneSolution().get("X"); + assertFalse("@(false) . isJNull() fails", t.isJNull()); + } + public void testIsJTrue1() { + Term t = (Term) (new Query("X = @(true)")).oneSolution().get("X"); + assertTrue("@(true) . isJTrue() succeeds", t.isJTrue()); + } + public void testIsJTrue2() { + Term t = (Term) (new Query("X = @(3)")).oneSolution().get("X"); + assertFalse("@(3) . isJTrue() fails", t.isJTrue()); + } + public void testIsJTrue3() { + Term t = (Term) (new Query("X = _")).oneSolution().get("X"); + assertFalse("_ . isJTrue() fails", t.isJTrue()); + } + public void testIsJTrue4() { + Term t = (Term) (new Query("X = @(false)")).oneSolution().get("X"); + assertFalse("@(false) . isJTrue() fails", t.isJTrue()); + } + public void testIsJVoid1() { + Term t = (Term) (new Query("X = @(void)")).oneSolution().get("X"); + assertTrue("@(void) . isJVoid() succeeds", t.isJVoid()); + } + public void testIsJVoid2() { + Term t = (Term) (new Query("X = @(3)")).oneSolution().get("X"); + assertFalse("@(3) . isJVoid() fails", t.isJVoid()); + } + public void testIsJVoid3() { + Term t = (Term) (new Query("X = _")).oneSolution().get("X"); + assertFalse("_ . isJVoid() fails", t.isJVoid()); + } + public void testTypeName1() { + assertEquals("Y = foo binds Y to an Atom", ((Term) Query.oneSolution("Y = foo").get("Y")).typeName(), "Atom"); + } + public void testTypeName2() { + assertEquals("Y = 3.14159 binds Y to a Float", ((Term) Query.oneSolution("Y = 3.14159").get("Y")).typeName(), "Float"); + } + public void testTypeName4() { + assertEquals("Y = 6 binds Y to an Integer", ((Term) Query.oneSolution("Y = 6").get("Y")).typeName(), "Integer"); + } + public void testTypeName5() { + assertEquals("Y = _ binds Y to a Variable", ((Term) Query.oneSolution("Y = _").get("Y")).typeName(), "Variable"); + } + public void testTypeName3() { + assertEquals("Y = f(x) binds Y to a Compound", ((Term) Query.oneSolution("Y = f(x)").get("Y")).typeName(), "Compound"); + } + public void testGoalWithModulePrefix1() { + String goal = "jpl:jpl_modifier_bit(volatile,I)"; + assertTrue(goal + " binds I to an integer", ((Term) Query.oneSolution(goal).get("I")).isInteger()); + } + public void testGoalWithModulePrefix2() { + String goal = "user:length([],0)"; + assertTrue(goal + " succeeds", Query.hasSolution(goal)); + } + public void testGoalWithModulePrefix3() { + try { + (new Query("3:length([],0)")).hasSolution(); + // shouldn't get to here + fail("(new Query(\"3:length([],0)\")).hasSolution() didn't throw exception"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("type_error", 2) && e.term().arg(1).arg(1).hasFunctor("atom", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"3:length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"3:length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + public void testGoalWithModulePrefix4() { + try { + (new Query("_:length([],0)")).hasSolution(); + // shouldn't get to here + fail("bad (unbound) module prefix"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("instantiation_error", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"_:length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"_:length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + public void testGoalWithModulePrefix5() { + try { + (new Query("f(x):length([],0)")).hasSolution(); + // shouldn't get to here + fail("bad (compound) module prefix"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("type_error", 2) && e.term().arg(1).arg(1).hasFunctor("atom", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + public void testGoalWithModulePrefix6() { + try { + (new Query("no_such_module:no_such_predicate(0)")).hasSolution(); + // shouldn't get to here + fail("bad (nonexistent) module prefix"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("existence_error", 2) && e.term().arg(1).arg(1).hasFunctor("procedure", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + // public void testFetchCyclicTerm(){ + // assertTrue((new Query("X=f(X)")).hasSolution()); + // } + public void testFetchLongList0() { + assertTrue((new Query("findall(foo(N),between(0,10,N),L)")).hasSolution()); + } + public void testFetchLongList1() { + assertTrue((new Query("findall(foo(N),between(0,100,N),L)")).hasSolution()); + } + public void testFetchLongList2() { + assertTrue((new Query("findall(foo(N),between(0,1000,N),L)")).hasSolution()); + } + public void testFetchLongList2c() { + assertTrue((new Query("findall(foo(N),between(0,1023,N),L)")).hasSolution()); + } + //public void testFetchLongList2a() { /* leads to stack overflow */ + // assertTrue((new Query("findall(foo(N),between(0,2000,N),L)")).hasSolution()); + //} + // public void testFetchLongList2b() { + // assertTrue((new Query("findall(foo(N),between(0,3000,N),L)")).hasSolution()); + // } + // public void testFetchLongList3() { + // assertTrue((new Query("findall(foo(N),between(0,10000,N),L)")).hasSolution()); + // } + public void testUnicode0() { + assertTrue(Query.hasSolution("atom_codes(?,[32])", new Term[] { new Atom(" ") })); + } + public void testUnicode0a() { + assertTrue(Query.hasSolution("atom_codes(?,[32])", new Term[] { new Atom("\u0020") })); + } + public void testUnicode0b() { + assertTrue(Query.hasSolution("atom_codes(?,[0])", new Term[] { new Atom("\u0000") })); + } + public void testUnicode0c() { + assertTrue(Query.hasSolution("atom_codes(?,[1])", new Term[] { new Atom("\u0001") })); + } + public void testUnicode0d() { + assertTrue(Query.hasSolution("atom_codes(?,[127])", new Term[] { new Atom("\u007F") })); + } + public void testUnicode0e() { + assertTrue(Query.hasSolution("atom_codes(?,[128])", new Term[] { new Atom("\u0080") })); + } + public void testUnicode0f() { + assertTrue(Query.hasSolution("atom_codes(?,[255])", new Term[] { new Atom("\u00FF") })); + } + public void testUnicode0g() { + assertTrue(Query.hasSolution("atom_codes(?,[256])", new Term[] { new Atom("\u0100") })); + } + public void testUnicode1() { + assertTrue(Query.hasSolution("atom_codes(?,[0,127,128,255])", new Term[] { new Atom("\u0000\u007F\u0080\u00FF") })); + } + public void testUnicode2() { + assertTrue(Query.hasSolution("atom_codes(?,[256,32767,32768,65535])", new Term[] { new Atom("\u0100\u7FFF\u8000\uFFFF") })); + } + public void testStringXput1() { + Term a = (Term) (Query.oneSolution("string_concat(foo,bar,S)").get("S")); + assertTrue(a.name().equals("foobar")); + } + public void testStringXput2() { + String s1 = "\u0000\u007F\u0080\u00FF"; + String s2 = "\u0100\u7FFF\u8000\uFFFF"; + String s = s1 + s2; + Term a1 = new Atom(s1); + Term a2 = new Atom(s2); + Term a = (Term) (Query.oneSolution("string_concat(?,?,S)", new Term[] { a1, a2 }).get("S")); + assertEquals(a.name(), s); + } + // public void testMaxInteger1(){ + // assertEquals(((Term)(Query.oneSolution("current_prolog_flag(max_integer,I)").get("I"))).longValue(), java.lang.Long.MAX_VALUE); // i.e. 9223372036854775807L + // } + // public void testSingleton1() { + // assertTrue(Query.hasSolution("style_check(-singleton),consult('test_singleton.pl')")); + // } + public void testStaticQueryInvalidSourceText2() { + String goal = "p(]"; + try { + Query.hasSolution(goal); + } catch (jpl.PrologException e) { + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("syntax_error", 1) && e.term().arg(1).arg(1).hasFunctor("cannot_start_term", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("Query.hasSolution(" + goal + ") threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("Query.hasSolution(" + goal + ") threw wrong class of exception: " + e); + } + } + public void testStaticQueryInvalidSourceText1() { + String goal = "bad goal"; + try { + Query.hasSolution(goal); + } catch (jpl.PrologException e) { + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("syntax_error", 1) && e.term().arg(1).arg(1).hasFunctor("operator_expected", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("Query.hasSolution(" + goal + ") threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("Query.hasSolution(" + goal + ") threw wrong class of exception: " + e); + } + } + public void testStaticQueryNSolutions1() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + int n = 5; + assertTrue("Query.nSolutions(" + goal + ", " + n + ") returns " + n + " solutions", Query.nSolutions(goal, n).length == n); + } + public void testStaticQueryNSolutions2() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + int n = 0; + assertTrue("Query.nSolutions(" + goal + ", " + n + ") returns " + n + " solutions", Query.nSolutions(goal, n).length == n); + } + public void testStaticQueryNSolutions3() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + int n = 20; + assertTrue("Query.nSolutions(" + goal + ", " + n + ") returns 10 solutions", Query.nSolutions(goal, n).length == 10); + } + public void testStaticQueryAllSolutions1() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + assertTrue("Query.allSolutions(" + goal + ") returns 10 solutions", Query.allSolutions(goal).length == 10); + } + public void testStaticQueryHasSolution1() { + String goal = "memberchk(13, [?,?,?])"; + Term[] params = new Term[] { new Integer(12), new Integer(13), new Integer(14) }; + assertTrue(Query.hasSolution(goal, params)); + } + public void testStaticQueryHasSolution2() { + String goal = "memberchk(23, [?,?,?])"; + Term[] params = new Term[] { new Integer(12), new Integer(13), new Integer(14) }; + assertFalse(Query.hasSolution(goal, params)); + } + public void testUtilListToTermArray1() { + String goal = "T = [a,b,c]"; + Term list = (Term) Query.oneSolution(goal).get("T"); + Term[] array = Util.listToTermArray(list); + assertTrue(array[2].isAtom() && array[2].name().equals("c")); + } + public void testTermToTermArray1() { + String goal = "T = [a,b,c]"; + Term list = (Term) Query.oneSolution(goal).get("T"); + Term[] array = list.toTermArray(); + assertTrue(array[2].isAtom() && array[2].name().equals("c")); + } + public void testJRef1() { + // System.out.println("java.library.path=" + System.getProperties().get("java.library.path")); + // System.out.println("jpl.c version = " + jpl.fli.Prolog.get_c_lib_version()); + int i = 76543; + Integer I = new Integer(i); + Query q = new Query("jpl_call(?,intValue,[],I2)", new Term[] { Term.objectToJRef(I) }); + Term I2 = (Term) q.oneSolution().get("I2"); + assertTrue(I2.isInteger() && I2.intValue() == i); + } + public void testBerhhard1() { + assertTrue(Query.allSolutions( "consult(library('lists'))" ).length == 1); + } + public void testJRef2() { + int i = 76543; + Integer I = new Integer(i); + Query q = new Query("jpl_call(?,intValue,[],I2)", jpl.JPL.newJRef(I)); + Term I2 = (Term) q.oneSolution().get("I2"); + assertTrue(I2.isInteger() && I2.intValue() == i); + } + public void testJRef3() { + StringBuffer sb = new StringBuffer(); + Query.oneSolution("jpl_call(?,append,['xyz'],_)", new Term[] {JPL.newJRef(sb)}); + assertTrue(sb.toString().equals("xyz")); + } + public void testJRef4() { + Term jrefSB = (Term) Query.oneSolution("jpl_new('java.lang.StringBuffer',['abc'],SB)").get("SB"); + assertTrue(jrefSB.isJRef() && ((StringBuffer) jrefSB.jrefToObject()).toString().equals("abc")); + } + public void testJRef5() { + String token = "foobar345"; + Term a = (Term) (Query.oneSolution("jpl_new('java.lang.StringBuffer',[?],A)", new Term[] {new Atom(token)}).get("A")); + assertTrue(((java.lang.StringBuffer) (a.jrefToObject())).toString().equals(token)); + } + public void testRef6() { + Term nullJRef = new Compound("@", new Term[] {new Atom("null")}); + Object nullObject = nullJRef.jrefToObject(); + assertNull("@(null) .jrefToObject() yields null", nullObject); + } + public void testRef7() { + Term badJRef = new Compound("@", new Term[] {new Atom("foobar")}); + try { + badJRef.jrefToObject(); + // shouldn't get to here + fail("@(foobar) .jrefToObject() shoulda thrown JPLException"); + } catch (jpl.JPLException e) { + // correct exception class, but is it correct in detail? + if (e.getMessage().endsWith("term is not a JRef")) { + // OK: an appropriate exception was thrown + } else { + fail("@(foobar) .jrefToObject() threw incorrect JPLException: " + e); + } + } catch (Exception e) { + fail("@(foobar) .jrefToObject() threw wrong class of exception: " + e); + } + } + public void testForeignFrame1() { + int ls1 = ((Term) (Query.oneSolution("statistics(localused,LS)").get("LS"))).intValue(); + int ls2 = ((Term) (Query.oneSolution("statistics(localused,LS)").get("LS"))).intValue(); + assertTrue("local stack size unchanged after query", ls1 == ls2); + } + public void testOpenGetClose1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while ((soln = q.getSolution()) != null) { + sb.append(((Atom) soln.get("C")).name()); + } + q.close(); + assertEquals("prolog", sb.toString()); + } + public void testOpenGetClose2() { + Query q = new Query("dummy"); // we're not going to open this... + try { + q.getSolution(); // but mistakenly try to get a solution from it... + } catch (jpl.JPLException e) { // correct exception class, but is it correct in detail? + if (e.getMessage().endsWith("Query is not open")) { // ...which should throw a JPLException like this + // OK: an appropriate exception was thrown + } else { + fail("jpl.Query#getSolution() threw incorrect JPLException: " + e); + } + } catch (Exception e) { + fail("jpl.Query#getSolution() threw wrong class of exception: " + e); + } + } + public void testOpen1() { + Query q = new Query("dummy"); + assertTrue("a newly created query is not open", !q.isOpen()); + } + public void testOpen2() { + Query q = new Query("fail"); + q.open(); + assertTrue("a newly opened query which has no solutions is open", q.isOpen()); + } + public void testGetSolution1() { + Query q = new Query("fail"); + q.open(); + q.getSolution(); + assertTrue("an opened query on which getSolution has failed once is closed", !q.isOpen()); + } + public void testGetSolution2() { + Query q = new Query("fail"); // this query has no solutions + q.open(); // this opens the query + q.getSolution(); // this finds no solution, and closes the query + try { + q.getSolution(); // this call is invalid, as the query is closed + // shouldn't get to here + fail("jpl.Query#getSolution() shoulda thrown JPLException"); + } catch (jpl.JPLException e) { // correct exception class, but is it correct in detail? + if (e.getMessage().endsWith("Query is not open")) { // ...which should throw a JPLException like this + // OK: an appropriate exception was thrown + } else { + fail("jpl.Query#getSolution() threw incorrect JPLException: " + e); + } + } catch (Exception e) { + fail("jpl.Query#getSolution() threw wrong class of exception: " + e); + } + } + public void testHasMoreSolutions1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while (q.hasMoreSolutions()) { + soln = q.nextSolution(); + sb.append(((Atom) soln.get("C")).name()); + } + q.close(); + assertEquals("Query#hasMoreSolutions() + Query#nextSolution() work as intended", "prolog", sb.toString()); + } + public void testHasMoreElements1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while (q.hasMoreElements()) { + soln = (Map) q.nextElement(); + sb.append(((Atom) soln.get("C")).name()); + } + q.close(); + assertEquals("Query#hasMoreElements() + Query#nextElement() work as intended", "prolog", sb.toString()); + } + public void testStackedQueries1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while ((soln = q.getSolution()) != null) { + Atom a = (Atom) soln.get("C"); + if (Query.hasSolution("memberchk(?, [l,o,r])", new Term[] {a})) { // this query opens and closes while an earlier query is still open + sb.append(((Atom) soln.get("C")).name()); + } + } + assertTrue(!q.isOpen()); // q will have been closed by the final getSolution() + assertEquals("rolo", sb.toString()); + } + +} diff --git a/packages/jpl/jpl/src/java/jpl/test/TestOLD.java b/packages/jpl/jpl/src/java/jpl/test/TestOLD.java new file mode 100644 index 000000000..496fb3800 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/TestOLD.java @@ -0,0 +1,142 @@ +package jpl.test; + +import java.util.Map; +import jpl.Atom; +import jpl.Compound; +import jpl.Integer; +import jpl.JPL; +import jpl.PrologException; +import jpl.Query; +import jpl.Term; +import jpl.Util; +import jpl.Variable; +import jpl.fli.Prolog; + +// This class is nearly obsolete; most of its tests have been migrated to TestJUnit. +public class TestOLD { + private static void test10() { + System.err.println("test10:"); + System.err.println(" java_lib_version = " + JPL.version_string()); + System.err.println(" c_lib_version = " + jpl.fli.Prolog.get_c_lib_version()); + System.err.println(" pl_lib_version = " + new Query(new Compound("jpl_pl_lib_version", new Term[] { new Variable("V") })).oneSolution().get("V")); + System.err.println(" java.version = " + System.getProperty("java.version")); + System.err.println(" os.name = " + System.getProperty("os.name")); + System.err.println(" os.arch = " + System.getProperty("os.arch")); + System.err.println(" os.version = " + System.getProperty("os.version")); + System.err.println(); + } + private static void test10j() { + Term l2 = Util.termArrayToList(new Term[] { new Atom("a"), new Atom("b"), new Atom("c"), new Atom("d"), new Atom("e") }); + Query q9 = new Query(new Compound("append", new Term[] { new Variable("Xs"), new Variable("Ys"), l2 })); + Map[] s9s = q9.allSolutions(); + System.err.println("test10j:"); + for (int i = 0; i < s9s.length; i++) { + System.err.println(" append(Xs,Ys,[a,b,c,d,e]) -> " + Util.toString(s9s[i])); + } + System.err.println(); + } + private static void test10k() { + String[] args = jpl.fli.Prolog.get_default_init_args(); + String which; + String s = ""; + System.err.println("test10k:"); + if (args == null) { + args = jpl.fli.Prolog.get_actual_init_args(); + which = "actual"; + } else { + which = "default"; + } + for (int i = 0; i < args.length; i++) { + s = s + args[i] + " "; + } + System.err.println(" " + which + "_init_args = " + s + '\n'); + } + private static void test10l() { + Query q5 = new Query(new Compound("length", new Term[] { new Variable("Zs"), new jpl.Integer(5) })); + Map s5 = q5.oneSolution(); + System.err.println("test10l:"); + System.err.println(" length(Zs,5)"); + System.err.println(" " + Util.toString(s5)); + System.err.println(" Zs = " + (Term) s5.get("Zs")); + System.err.println(); + } + private static void test10m() { + String text = "append(Xs,Ys,[_,_,_,_,_])"; + Query q = new Query(text); + Map[] ss = q.allSolutions(); + System.err.println("test10m:"); + System.err.println(" all solutions of " + text); + for (int i = 0; i < ss.length; i++) { + System.err.println(" " + Util.toString(ss[i])); + } + System.err.println(); + } + private static void test10o() { + System.err.println("test10o:"); + Term l2b = Util.termArrayToList(new Term[] { new Variable("A"), new Variable("B"), new Variable("C"), new Variable("D"), new Variable("E") }); + Query q9b = new Query(new Compound("append", new Term[] { new Variable("Xs"), new Variable("Ys"), l2b })); + Map[] s9bs = q9b.allSolutions(); + for (int i = 0; i < s9bs.length; i++) { + System.err.println(" append(Xs,Ys,[A,B,C,D,E]) -> " + Util.toString(s9bs[i])); + } + System.err.println(); + } + private static void test10q() { + System.err.println("test10q:"); + System.err.println((new Compound("Bad Name", new Term[] { new Atom("3 3") })).toString()); + System.err.println(); + } + private static void test10s() { + final Query q = new Query("jpl_slow_goal"); // 10 successive sleep(1) + System.err.println("test10s:"); + Thread t = new Thread(new Runnable() { + public void run() { + try { + System.err.println("q.hasSolution() ... "); + System.err.println(q.hasSolution() ? "finished" : "failed"); + } catch (Exception e) { + System.err.println("q.hasSolution() threw " + e); + } + } + }); + t.start(); // call the query in a separate thread + System.err.println("pausing for 2 secs..."); + try { + Thread.sleep(2000); + } catch (InterruptedException e) { + ; + } // wait a coupla seconds for it to get started + // (new Query("set_prolog_flag(abort_with_exception, true)")).hasSolution(); + System.err.println("calling q.abort()..."); + q.abort(); + System.err.println(); + } + public static void main(String argv[]) { + Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "none", "-g", "set_prolog_flag(debug_on_error,false)", "-q" }); + System.err.println("tag = " + Prolog.object_to_tag(new Query("hello"))); + test10k(); + test10(); + // test10h(); + // test10i(); + test10j(); + test10k(); + test10l(); + test10m(); + // test10n(); + test10o(); + //test10p(); + test10q(); + // test10r(); + // test10s(); + // test10t(); + // test10u(); + // test10v(); + String s = new String("" + '\0' + '\377'); + System.err.println("s.length = " + s.length()); + for (int i = 0; i < s.length(); i++) { + System.err.print((new Integer(s.charAt(i))).toString() + " "); + } + System.err.println(); + System.err.println(new Query("atom_codes(A,[127,128,255,0])").oneSolution().toString()); + } +} \ No newline at end of file diff --git a/packages/jpl/jpl/src/java/jpl/test/family.pl b/packages/jpl/jpl/src/java/jpl/test/family.pl new file mode 100644 index 000000000..95203f0ff --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/family.pl @@ -0,0 +1,25 @@ +% a simple database for Family.java + +:- if(current_prolog_flag(dialect, yap)). +sleep(T) :- unix(sleep(T)). +:- endif. + +child_of( joe, ralf ). +child_of( mary, joe ). +child_of( steve, joe ). + +descendent_of( X, Y ) :- + child_of( X, Y ). +descendent_of( X, Y ) :- + child_of( Z, Y ), + descendent_of( X, Z ). + +p( A, B) :- + ( q( A, B) + -> write( 'OK'-q(A,B)), nl + ; write( 'FAIL'-q(A,B)), nl + ). + +q( 3, 4). + +r( 5, 5). diff --git a/packages/jpl/jpl/src/java/jpl/test/test.pl b/packages/jpl/jpl/src/java/jpl/test/test.pl new file mode 100644 index 000000000..8a9e6bd01 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/test/test.pl @@ -0,0 +1,9 @@ +p( N, T) :- + ( N > 1 + -> Nx is N-1, + p( Nx, Tx), + T = a(Tx,Tx) + ; N == 1 + -> T = a + ). + diff --git a/packages/jpl/jpl/src/java/jpl/util/.cvsignore b/packages/jpl/jpl/src/java/jpl/util/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/jpl/src/java/jpl/util/Getenv.java b/packages/jpl/jpl/src/java/jpl/util/Getenv.java new file mode 100644 index 000000000..2c6f57181 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/Getenv.java @@ -0,0 +1,53 @@ +package jpl.util; + +import java.io.BufferedReader; +import java.io.InputStream; +import java.io.InputStreamReader; + +public class Getenv + { + + public static void main(String args[]) + { + + try { + getenv(); + } + catch (java.io.IOException e) { } + } + + public static void getenv() + throws java.io.IOException, java.io.UnsupportedEncodingException + { + Runtime rt = Runtime.getRuntime(); + + String a[] = new String[3]; + a[0] = "CMD"; + a[1] = "/C"; + a[2] = "SET"; + + Process p = rt.exec(a); + + InputStream is = p.getInputStream(); + + InputStreamReader isr = new InputStreamReader(is,"UTF8"); + + BufferedReader br = new BufferedReader(isr); + + getenv1(br); + } + + static void getenv1(BufferedReader br) + throws java.io.IOException + { + + String s = br.readLine(); + + if ( s != null ) + { + System.out.println(s); + getenv1(br); + } + } + } + diff --git a/packages/jpl/jpl/src/java/jpl/util/HashedRefs.java b/packages/jpl/jpl/src/java/jpl/util/HashedRefs.java new file mode 100644 index 000000000..d6eefffae --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/HashedRefs.java @@ -0,0 +1,138 @@ +package jpl.util; + + +/** + * HashedRefs collision list. + */ +class HashedRefsEntry { + int hash; + Object obj; + public int iref; + public HashedRefsEntry next; +} + + +public +class HashedRefs { + /** + * The hash table data. + */ + public transient HashedRefsEntry table[]; + + /** + * The total number of entries in the hash table. + */ + private transient int count; + + /** + * Rehashes the table when count exceeds this threshold. + */ + private int threshold; + + /** + * The load factor for the hashtable. + */ + private float loadFactor; + + public HashedRefs(int initialCapacity, float loadFactor) { + if ((initialCapacity <= 0) || (loadFactor <= 0.0)) { + throw new IllegalArgumentException(); + } + this.loadFactor = loadFactor; + table = new HashedRefsEntry[initialCapacity]; + threshold = (int)(initialCapacity * loadFactor); + } + + public HashedRefs(int initialCapacity) { + this(initialCapacity, 0.75f); + } + + public HashedRefs() { + this(101, 0.75f); + } + + public int size() { + return count; + } + + protected void rehash() { + int oldCapacity = table.length; + HashedRefsEntry oldTable[] = table; + + int newCapacity = oldCapacity * 2 + 1; + HashedRefsEntry newTable[] = new HashedRefsEntry[newCapacity]; + + threshold = (int)(newCapacity * loadFactor); + table = newTable; + + for (int i = oldCapacity ; i-- > 0 ;) { + for (HashedRefsEntry old = oldTable[i] ; old != null ; ) { + HashedRefsEntry e = old; + old = old.next; + + int index = (e.hash & 0x7FFFFFFF) % newCapacity; + e.next = newTable[index]; + newTable[index] = e; + } + } + } + + public synchronized int add(Object obj, int iref) { + // Make sure the object reference is not null + if (obj == null) { + throw new NullPointerException(); + } + + // check whether object is already in the hashtable... + HashedRefsEntry tab[] = table; + int hash = java.lang.System.identityHashCode(obj); + int index = (hash & 0x7FFFFFFF) % tab.length; + for (HashedRefsEntry e = tab[index] ; e != null ; e = e.next) { + if ((e.hash == hash) && (e.obj == obj)) { + return e.iref; // existing global reference to this object + } + } + + if (count >= threshold) { + // Rehash the table if the threshold is exceeded + rehash(); + return add(obj, iref); + } + + // create a new entry... + HashedRefsEntry e = new HashedRefsEntry(); + e.hash = hash; + e.obj = obj; + e.iref = iref; + e.next = tab[index]; + tab[index] = e; + count++; + return 0; // indicates this reference has been added + } + + public synchronized boolean del(Object obj) { + HashedRefsEntry tab[] = table; + int hash = java.lang.System.identityHashCode(obj); + int index = (hash & 0x7FFFFFFF) % tab.length; + for (HashedRefsEntry e = tab[index], prev = null ; e != null ; prev = e, e = e.next) { + if ((e.hash == hash) && (e.obj == obj)) { + if (prev != null) { + prev.next = e.next; + } else { + tab[index] = e.next; + } + count--; + return true; + } + } + return false; + } + + public synchronized void clear() { + HashedRefsEntry tab[] = table; + for (int index = tab.length; --index >= 0; ) + tab[index] = null; + count = 0; + } + +} diff --git a/packages/jpl/jpl/src/java/jpl/util/Mod.java b/packages/jpl/jpl/src/java/jpl/util/Mod.java new file mode 100644 index 000000000..572e2bb2b --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/Mod.java @@ -0,0 +1,16 @@ +package jpl.util; + +public class Mod + { + public static void main(String args[]) + { + + System.out.println( " 17 % 5 = " + ( 17 % 5)); + System.out.println( " 17 % -5 = " + ( 17 % -5)); + System.out.println( "-17 % 5 = " + (-17 % 5)); + System.out.println( "-17 % -5 = " + (-17 % -5)); + while (true) + ; + } + } + diff --git a/packages/jpl/jpl/src/java/jpl/util/Overload.java b/packages/jpl/jpl/src/java/jpl/util/Overload.java new file mode 100644 index 000000000..bdc3014ad --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/Overload.java @@ -0,0 +1,11 @@ +package jpl.util; + +public class Overload { + static void m1(int a1, long a2) { + } + static void m1(long a1, int a2) { + } + public static void main(String[] args) { + m1((long) 0, 0); + } +} diff --git a/packages/jpl/jpl/src/java/jpl/util/Overload2.java b/packages/jpl/jpl/src/java/jpl/util/Overload2.java new file mode 100644 index 000000000..c741b40a5 --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/Overload2.java @@ -0,0 +1,13 @@ +package jpl.util; + +public class Overload2 + { + // experiment (why not read the language reference?) + public static int fred; + public static int fred() + { + return fred; + } + } + + diff --git a/packages/jpl/jpl/src/java/jpl/util/PopupMenuDemo.java b/packages/jpl/jpl/src/java/jpl/util/PopupMenuDemo.java new file mode 100644 index 000000000..3b8d0534a --- /dev/null +++ b/packages/jpl/jpl/src/java/jpl/util/PopupMenuDemo.java @@ -0,0 +1,137 @@ +package jpl.util; + +import java.awt.Point; +import java.awt.event.ActionEvent; +import java.awt.event.ActionListener; +import javax.swing.JFrame; +import javax.swing.JMenu; +import javax.swing.JMenuItem; +import javax.swing.JPopupMenu; + + +/* + * Adapted from a Swing Connection demo + * see pcm's jpl_demo:jpl_popup_demo/0 + */ +public class PopupMenuDemo extends JFrame + implements ActionListener { + private static final long serialVersionUID = 1L; + // JTextArea output; + public JPopupMenu popup; + JMenuItem source; + int mi; + + public PopupMenuDemo() { + + // Add regular components to the window, using the default BorderLayout. + // output = new JTextArea(5, 30); + // output.setEditable(false); + // getContentPane().add(new JScrollPane(output), BorderLayout.CENTER); + } + +/* JPopupMenu + +- JMenuItem + +- JMenuItem + +- JMenu ----- JPopupMenu + | +- JMenuItem + | +- JMenuItem + +- JMenuItem + +- JMenuItem + */ + public boolean search(JPopupMenu p) { + Object[] mes = p.getSubElements(); // array of JMenuItem or JMenu (see diagram) + int i; + + for ( i=0 ; i current_prolog_flag( max_integer, V1) + ; V1 is 2**63-1 + ), + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoDouble, [V1], V2). + +test( + method_static_echo_float_1, + [ setup(( + V1 = 1.5 + )), + true(( + V1 == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + method_static_echo_float_2, + [ setup(( + V1 is 2, + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + method_static_echo_float_3, + [ setup(( + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V1) + ; V1 is 2**63-1 % was 2**99 + ), + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + method_static_echo_float_4, + [ blocked('we do not yet widen unbounded integers to floats or doubles'), + setup(( + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V1) + ; V1 is 2**99 % an unbounded integer + ), + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + new_abstract_class_1, + [ setup(( + Classname = 'java.util.Dictionary' + )), + throws( + error( + type_error(concrete_class,Classname), + context(jpl_new/3,_) + ) + ) + ] +) :- + jpl_new( Classname, [], _). + +test( + new_array_boolean_from_val_1, + [ setup(( + jpl_false( V) + )), + true(( + V == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', newArrayBooleanFromValue, [V], A), + jpl_get( A, 0, V2). + +test( + new_array_double_from_val_1, + [ setup(( + V is 1.5 + )), + true(( + V == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', newArrayDoubleFromValue, [V], A), + jpl_get( A, 0, V2). + +test( + new_array_float_from_val_1, + [ setup(( + V is 1.5 + )), + true(( + V == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', newArrayFloatFromValue, [V], A), + jpl_get( A, 0, V2). + +test( + new_interface_1, + [ setup(( + Classname = 'java.util.Enumeration' + )), + throws( + error( + type_error(concrete_class,Classname), + context(jpl_new/3,_) + ) + ) + ] +) :- + jpl_new( Classname, [], _). + +test( + new_param_cyclic_term_1, + [ setup(( + T = f(T) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_new/3,_) + ) + ) + ] +) :- + jpl_new( 'jpl.test.Test', [{T}], _). + +test( + prolog_calls_java_calls_prolog_1, + [ true(( + V == @(true) + )) + ] +) :- + jpl_new( 'jpl.Query', ['4 is 2+2'], Q), + jpl_call( Q, hasSolution, [], V). + +test( + set_array_element_cyclic_term_1, + [ setup(( + T = f(T), + jpl_new( array(class([jpl,test],['Test'])), 5, A) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 0, {T}). + +test( + set_array_elements_bad_type_1, + [ setup(( + jpl_new( array(byte), 3, A) + )), + throws( + error( + type_error(array(byte),[128]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 0, 128). + +test( + set_array_length_1, + [ setup(( + jpl_new( array(byte), 6, A) + )), + throws( + error( + permission_error(modify,final_field,length), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, length, 13). + +test( + set_field_bad_field_spec_1, + [ setup(( + BadFieldName = 3.7 + )), + throws( + error( + type_error(field_name,BadFieldName), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', BadFieldName, a). + +test( + set_field_instance_cyclic_term_1, + [ setup(( + T = f(T), + jpl_new( 'jpl.test.Test', [], Test) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( Test, instanceTerm, {T}). + +test( + set_field_long_array_1, + [ setup(( + jpl_new( array(long), [1,2,3], LongArray) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticLongArray, LongArray). + +test( + set_field_long_array_2, + [ setup(( + jpl_new( array(int), [1,2,3], IntArray) + )), + throws( + error( + type_error('[J',IntArray), % NB '[J' is *not* how the type was specified in the failing goal + context( + jpl_set/3, + 'the value is not assignable to the named field of the class' + ) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticLongArray, IntArray). + +test( + set_field_object_array_1, + [ setup(( + jpl_new( 'java.util.Date', [], Date), + jpl_new( array(class([java,lang],['Object'])), [Date,Date], ObjArray) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticObjectArray, ObjArray). + +test( + set_field_static_bad_type_1, + [ setup(( + BadVal = 27 + )), + throws( + error( + type_error(boolean,BadVal), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, BadVal). + +test( + set_field_static_boolean_1, + [ setup(( + jpl_true( V) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, V). + +test( + set_field_static_boolean_2, + [ setup(( + jpl_false( V) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, V). + +test( + set_field_static_boolean_bad_1, + [ setup(( + BadVal = foo(bar) + )), + throws( + error( + type_error(field_value,BadVal), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, BadVal). + +test( + set_field_static_cyclic_term_1, + [ setup(( + T = f(T) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', staticTerm, {T}). + +test( + set_field_static_final_int_1, + [ setup(( + FieldName = fieldStaticFinalInt, + Value = 6 + )), + throws( + error( + permission_error(modify,final_field,FieldName), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', FieldName, Value). + +test( + set_field_static_shadow_1, + [ blocked('we do not yet resolve same-named shadowed fields') + ] +) :- + jpl_set( 'jpl.test.ShadowB', fieldStaticInt, 3). + +test( + set_field_static_term_1, + [ setup(( + T1 = foo(bar,33), + T2 = bar(77,bing) + )), + true(( + T1 == T1a, + T2 == T2a + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T1}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T1a}), + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T2}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T2a}). + +test( + set_field_static_term_2, + [ setup(( + T1 = foo(bar,33), + T2 = bar(77,bing) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T1}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T1}), + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T2}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T2}). + +test( + set_get_array_element_boolean_1, + [ setup(( + jpl_new( array(boolean), 3, A), + V = @(false) + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_boolean_2, + [ setup(( + jpl_new( array(boolean), 3, A), + V = @(true) + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_boolean_3, + [ setup(( + jpl_new( array(boolean), 3, A), + V = bogus + )), + throws( + error( + type_error(array(boolean),[V]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 2, V). + +test( + set_get_array_element_byte_1, + [ setup(( + jpl_new( array(byte), 3, A), + V = 33 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_byte_2, + [ setup(( + jpl_new( array(byte), 3, A), + V = 128 + )), + throws( + error( + type_error(array(byte),[V]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 2, V). + +test( + set_get_array_element_char_1, + [ setup(( + jpl_new( array(char), 3, A), + V = 65535 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_double_1, + [ setup(( + jpl_new( array(double), 3, A), + V = 2.5 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_float_1, + [ setup(( + jpl_new( array(float), 3, A), + V = 7.5 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_float_2, + [ setup(( + jpl_new( array(float), 3, A), + V is 2, + VrX is float(V) + )), + true(( + VrX == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_float_3, + [ setup(( + jpl_new( array(float), 3, A), + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, Imax) + ; Imax is 2**63-1 + ), + VrX is float(Imax) + )), + true(( + VrX == Vr + )) + ] +) :- + jpl_set( A, 2, Imax), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_long_1, + [ setup(( + jpl_new( array(long), 3, A), + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V) + ; V is 2**63-1 + ) + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_long_2, + [ setup(( + jpl_new( array(long), 3, A), + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V) + ; V is 2**63 + ) + )), + throws( + error( + type_error(array(long),[V]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 2, V). + +test( + set_get_array_elements_boolean_1, + [ setup(( + jpl_new( array(boolean), 3, A), + Vf = @(false), + Vt = @(true) + )), + true(( + Vf+Vt+Vf == Vr0+Vr1+Vr2 + )) + ] +) :- + jpl_set( A, 0, Vf), + jpl_set( A, 1, Vt), + jpl_set( A, 2, Vf), + jpl_get( A, 0, Vr0), + jpl_get( A, 1, Vr1), + jpl_get( A, 2, Vr2). + +test( + set_get_field_static_long_1, + [ setup(( + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V) + ; V is 2**63-1 + ) + )), + true(( + V == V2 + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticLong, V), + jpl_get( 'jpl.test.Test', fieldStaticLong, V2). + +test( + set_non_accessible_field_1, + [ throws( + error( + existence_error(field,gagaga), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', gagaga, 4). + +test( + terms_to_array_1, + [] +) :- + jpl_terms_to_array( [foo(bar)], A), + jpl_object_to_type( A, array(class([jpl],['Term']))), + jpl_get( A, length, 1), + jpl_get( A, 0, T), + jpl_call( T, toString, [], 'foo(bar)'). + +test( + throw_java_exception_1, + [ blocked('part of the error term is nondeterministic: we need to match with _'), + throws( + error( + java_exception(@(_)), + 'java.lang.NumberFormatException' + ) + ) + ] +) :- + jpl_call( 'java.lang.Integer', decode, [q], _). + +test( + versions_1, + [ true(( + Vpl == Vc, + Vc == Vjava + )) + ] +) :- + jpl_pl_lib_version(Vpl), + jpl_c_lib_version(Vc), + jpl_call( 'jpl.JPL', version_string, [], Vjava). + +% JW: Mutual recursion check. Moved from jpl.pl to here. As the +% callback is in module user, we define it there. + +user:jpl_test_fac( N, F) :- + ( N == 1 + -> F = 1 + ; N > 1 + -> N2 is N-1, + jpl_call( 'jpl.test.Test', fac, [N2], F2), % call its Java counterpart, which does vice versa + F is N*F2 + ; F = 0 + ). + +test(fac10, + [ true(N==3628800) + ]) :- + user:jpl_test_fac(10, N). + +test(threads1, + [ true(( + thread_create(jpl_call('java.lang.System', currentTimeMillis, [], _), ThreadId, []), + thread_join(ThreadId, true) + )) + ] +) :- + jpl_call('java.lang.System', currentTimeMillis, [], _). + +test(threads2, true(X==true)) :- + jpl_call('java.lang.System', currentTimeMillis, [], _), + thread_create(jpl_call('java.lang.System', currentTimeMillis, [], _), ThreadId, []), + thread_join(ThreadId, X). + +test(threads3, + [ true(( + length(Ss, 1000), + sort(Ss, [true]) + )) + ] +) :- + jpl_call('java.lang.System', currentTimeMillis, [], _), + findall( + Status, + ( between(1, 1000, _), + thread_create(jpl_call('java.lang.System', currentTimeMillis, [], _), ThreadId, []), + thread_join(ThreadId, Status) + ), + Ss + ). + +test(jref1, + [ true(( + Term1 \== Term2, + Term1 =@= Term2 + )) + ] +) :- + length(Term1, 5), + jpl:jni_term_to_jref(Term1, JRef), + jpl:jni_jref_to_term(JRef, Term2). + +:- end_tests(jpl). diff --git a/packages/jpl/jpl/test_singleton.pl b/packages/jpl/jpl/test_singleton.pl new file mode 100644 index 000000000..c3d06fae2 --- /dev/null +++ b/packages/jpl/jpl/test_singleton.pl @@ -0,0 +1,4 @@ +% serves testSingleton1() in jpl.test.TestJUnit + +t(A). + diff --git a/packages/jpl/jpl/testenv b/packages/jpl/jpl/testenv new file mode 100755 index 000000000..d92418817 --- /dev/null +++ b/packages/jpl/jpl/testenv @@ -0,0 +1,30 @@ +#!/bin/sh + +# Verify the environment is safe for building this package. + +findexe() +{ oldifs="$IFS" + IFS=: + for d in $PATH; do + if [ -x $d/$1 ]; then + IFS="$oldifs" + return 0 + fi + done + IFS="$oldifs" + return 1 +} + +# We should also check various other things: +# +# * javac is from SUN SDK or IBM java +# * javac has same wordsize as Prolog (both 32 or 64 bits) +# * linking libpl.a in a shared object is possible. +# +# How to do this in a portable way? Can we use plld? + +if findexe javac; then + exit 0 +else + exit 1 +fi diff --git a/packages/jpl/jpl/web/README.txt b/packages/jpl/jpl/web/README.txt new file mode 100644 index 000000000..ee2954f6a --- /dev/null +++ b/packages/jpl/jpl/web/README.txt @@ -0,0 +1,21 @@ +JPL + is a simple Servlet 2.2 (or later) web application + containing its own copy of jpl.jar and a couple of + servlets which call SWI-Prolog (see JPL/WEB-INF/classes) + +JPL.war + is JPL in the form of a "web archive" + +To deploy under Tomcat, copy either JPL or JPL.war into +Tomcat's webapps folder and restart Tomcat. + +Then visit the application's default ("welcome") page, e.g. + + http://localhost:8080/JPL + +with a web browser. + +---- +Paul Singleton +February 2004 + diff --git a/packages/jpl/jpl/web/jpl.war b/packages/jpl/jpl/web/jpl.war new file mode 100644 index 000000000..3489e228c Binary files /dev/null and b/packages/jpl/jpl/web/jpl.war differ diff --git a/packages/jpl/jpl/web/jpl/build_WAR.bat b/packages/jpl/jpl/web/jpl/build_WAR.bat new file mode 100644 index 000000000..245864104 --- /dev/null +++ b/packages/jpl/jpl/web/jpl/build_WAR.bat @@ -0,0 +1,3 @@ +jar cf ..\JPL.war WEB-INF *.html +@pause + diff --git a/packages/jpl/jpl/web/jpl/index.html b/packages/jpl/jpl/web/jpl/index.html new file mode 100644 index 000000000..5d231b31b --- /dev/null +++ b/packages/jpl/jpl/web/jpl/index.html @@ -0,0 +1,20 @@ + + + welcome page for various HTTP <-> JPL <-> Prolog servlet demos + + +

    JPL servlet examples

    +

    + To invoke the JPLServletByref servlet with a couple of HTTP parameters, click + servlet/JPLServletByref?first=1st&second=2nd +

    +

    + To invoke the JPLServletByval servlet with a couple of HTTP parameters, click + servlet/JPLServletByval?first=1st&second=2nd +

    +
    +
    Paul Singleton
    +
    February 2004
    + + + diff --git a/packages/jpl/make.bat b/packages/jpl/make.bat new file mode 100755 index 000000000..fb132b683 --- /dev/null +++ b/packages/jpl/make.bat @@ -0,0 +1 @@ +nmake MT=true /f makefile.mak %* diff --git a/packages/jpl/src/c/README b/packages/jpl/src/c/README new file mode 100644 index 000000000..b8334f8f7 --- /dev/null +++ b/packages/jpl/src/c/README @@ -0,0 +1,16 @@ +To recompile jpl.c to jpl.dll (for Windows), +ensure that JAVA_HOME and PL_HOME are appropriately set in your environment, +then run + + .\build.bat + +To recompile jpl.c to libjpl.so (for Linux), +ensure that JAVA_HOME and PL_HOME are appropriately set in your environment, +then run + + ./build.sh + +---- +Paul Singleton (paul.singleton@bcs.org.uk) +March 2004 + diff --git a/packages/jpl/src/c/build.bat b/packages/jpl/src/c/build.bat new file mode 100644 index 000000000..fc0a3c88d --- /dev/null +++ b/packages/jpl/src/c/build.bat @@ -0,0 +1,15 @@ +@echo off + +rem JAVA_HOME must (already) be set to the root dir of a recent Sun Java SDK +rem PL_HOME must (already) be set to the root dir of a recent SWI-Prolog installation + +set DEFINES=/D_REENTRANT /DWIN32 /D_WINDOWS /D__SWI_PROLOG__ /D__SWI_EMBEDDED__ +set JVM_INC=/I "%JAVA_HOME%\include" /I "%JAVA_HOME%\include/win32" +set PL_INC=/I "%PL_HOME%\include" +set JVM_LIB="%JAVA_HOME%\lib\jvm.lib" +set PL_LIB="%PL_HOME%\lib\libpl.lib" +set PTHREAD_LIB="%PL_HOME%\lib/pthreadVC.lib" + +CL.EXE /W3 /nologo /MD /LD %DEFINES% %JVM_INC% %PL_INC% %JVM_LIB% %PL_LIB% %PTHREAD_LIB% jpl.c +pause + diff --git a/packages/jpl/src/c/hacks.c b/packages/jpl/src/c/hacks.c new file mode 100644 index 000000000..99d5b0fc6 --- /dev/null +++ b/packages/jpl/src/c/hacks.c @@ -0,0 +1,73 @@ +/* + %T jni_SetByteArrayElement(+term, +term, +term) + */ +static foreign_t +jni_SetByteArrayElement( + term_t ta1, // +Arg1 + term_t ta2, // +Arg2 + term_t ta3 // +Arg3 + ) + { + jboolean r; // Prolog exit/fail outcome + jbyteArray p1; + int i2; + jbyte p4; + JNIEnv *env; + atom_t a; /* " */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + int i; /* " */ + + if ( !jni_ensure_jvm() ) + { + + + + + return FALSE; + } + r = + JNI_term_to_byte_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jbyte(ta3,p4) + && ( (*env)->SetByteArrayRegion(env,p1,(jsize)i2,1,&p4) , TRUE ); + + return jni_check_exception(env) && r; + + } + +/* + %T jni_SetByteArrayElement(+term, +term, +term) + */ +static foreign_t +jni_SetDoubleArrayElement( + term_t ta1, // +Arg1 + term_t ta2, // +Arg2 + term_t ta3 // +Arg3 + ) + { + jboolean r; // Prolog exit/fail outcome + void *p1; + jint i2; + jdouble p4; + JNIEnv *env; + atom_t a; /* " */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + int i; /* " */ + int64_t i64; + + if ( !jni_ensure_jvm() ) + { + return FALSE; + } + r = + JNI_term_to_double_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jdouble(ta3,p4) + && ( (*env)->SetDoubleArrayRegion(env,(jdoubleArray)p1,(jsize)i2,1,&p4) , TRUE ); + + return jni_check_exception(env) && r; + + } + diff --git a/packages/jpl/src/c/jpl.c b/packages/jpl/src/c/jpl.c new file mode 100755 index 000000000..e7501f4ad --- /dev/null +++ b/packages/jpl/src/c/jpl.c @@ -0,0 +1,5803 @@ +/* Part of JPL -- SWI-Prolog/Java interface + + Author: Paul Singleton, Fred Dushin and Jan Wielemaker + E-mail: paul@jbgb.com + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2004, Paul Singleton + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +*/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +this source file (jpl.c) combines my Prolog-calls-Java stuff (mostly +prefixed 'JNI' or 'jni' here) with my adaptation of Fred Dushin's +Java-calls-Prolog stuff (mostly prefixed 'JPL' or 'jpl' here) + +recent fixes: + * using PL_get_pointer(), PL_put_pointer() consistently (?) + * replaced all "Class: jpl_fli_PL" by "Class: jpl_fli_Prolog" + +still to do: + * make it completely thread-safe + (both to multiple Prolog (engine-enabled) threads and to multiple Java threads) + * suss JVM 'abort' and 'exit' handling, and 'vfprintf' redirection + * rationalise initialisation; perhaps support startup from C? + +refactoring (trivial): + * initialise a functor_t for jpl_tidy_iref_type_cache/1 + * initialise a functor_t for -/2 + * initialise a module_t for jpl +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* update this to distinguish releases of this C library: */ +#define JPL_C_LIB_VERSION "3.1.4-alpha" +#define JPL_C_LIB_VERSION_MAJOR 3 +#define JPL_C_LIB_VERSION_MINOR 1 +#define JPL_C_LIB_VERSION_PATCH 4 +#define JPL_C_LIB_VERSION_STATUS "alpha" + +/*#define DEBUG(n, g) ((void)0) */ +#define DEBUG_LEVEL 3 +#define DEBUG(n, g) ( n >= DEBUG_LEVEL ? g : (void)0 ) + +/* disable type-of-ref caching (at least until GC issues are resolved) */ +#define JPL_CACHE_TYPE_OF_REF FALSE + +/*=== includes ===================================================================================== */ + +#if defined(__WINDOWS__) || defined(_WIN32) +/* OS-specific header (SWI-Prolog FLI and Java Invocation API both seem to need this): */ +/* but not if we use the .NET 2.0 C compiler */ +#include +#define SIZEOF_WCHAR_T 2 +#define SIZEOF_LONG 4 +#define SIZEOF_LONG_LONG 8 +#if defined(WIN64) || defined(_WIN64) +#define SIZEOF_VOIDP 8 +#else +#define SIZEOF_VOIDP 4 +#endif +#endif + +/* SWI-Prolog headers: */ +#include +#if _YAP_NOT_INSTALLED_ +#define Sdprintf(...) fprintf( stderr, __VA_ARGS__) +#else +#include +#endif + +/* Java Native Interface and Invocation Interface header: */ +#include + +/* ANSI/ISO C library header (?): */ +#include +#include +#include +#include + +#ifdef HAVE_PTHREAD_H +/* POSIX 'pthreads' headers (initially for JPL's Prolog engine pool, useful for locking generally?): */ +#include +#include +#else +#define pthread_mutex_lock( A) +#define pthread_mutex_unlock( A) +#define pthread_cond_signal( A) +#define pthread_cond_wait( A, B) 0 +#endif + +#include + +#ifndef TRUE +#define TRUE 1 +#endif +#ifndef FALSE +#define FALSE 1 +#endif + +#include "jpl.h" + +/*=== JNI constants ================================================================================ */ + +#define JNI_MIN_JCHAR 0 +#define JNI_MAX_JCHAR 65535 + +#define JNI_MIN_JBYTE -128 +#define JNI_MAX_JBYTE 127 + +#define JNI_MIN_JSHORT -32768 +#define JNI_MAX_JSHORT 32767 + + +#define JNI_XPUT_VOID 0 +#define JNI_XPUT_BOOLEAN 1 +#define JNI_XPUT_BYTE 2 +#define JNI_XPUT_CHAR 3 +#define JNI_XPUT_SHORT 4 +#define JNI_XPUT_INT 5 +#define JNI_XPUT_LONG 6 +#define JNI_XPUT_FLOAT 7 +#define JNI_XPUT_DOUBLE 8 +#define JNI_XPUT_FLOAT_TO_DOUBLE 9 +#define JNI_XPUT_LONG_TO_FLOAT 10 +#define JNI_XPUT_LONG_TO_DOUBLE 11 +#define JNI_XPUT_REF 12 +#define JNI_XPUT_ATOM 13 +#define JNI_XPUT_JVALUEP 14 +#define JNI_XPUT_JVALUE 15 + + +/* JNI "hashed refs" constants */ + +#define JNI_HR_LOAD_FACTOR 0.75 + +/* jni_hr_add() return codes: */ +#define JNI_HR_ADD_FAIL -1 +#define JNI_HR_ADD_NEW 0 +#define JNI_HR_ADD_OLD 1 + + +/*=== JPL constants ================================================================================ */ + +/* legit values for jpl_status_jpl_ini and jpl_status_pvm_ini */ +#define JPL_INIT_RAW 101 +#define JPL_INIT_PVM_MAYBE 102 +#define JPL_INIT_OK 103 +#define JPL_INIT_JPL_FAILED 104 +#define JPL_INIT_PVM_FAILED 105 + +#define JPL_MAX_POOL_ENGINES 10 /* max pooled Prolog engines */ +#define JPL_INITIAL_POOL_ENGINES 1 /* initially created ones */ + + +/*=== JNI Prolog<->Java conversion macros ========================================================== */ + +/* JNI (Prolog-calls-Java) conversion macros; mainly used in jni_{func|void}_{0|1|2|3|4}_plc; */ +/* for re-entrancy, ensure that any variables which they use are declared dynamically */ +/* (e.g. or i.e. are local to the host function); */ +/* beware of evaluating *expressions* passed as actual parameters more than once; */ + +#define JNI_term_to_jboolean(T,JB) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_at_1 \ + ? ( ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_atom(a1,&a) \ + ? ( a==JNI_atom_false \ + ? ( (JB)=0, TRUE) \ + : ( a==JNI_atom_true \ + ? ( (JB)=1, TRUE) \ + : FALSE \ + ) \ + ) \ + : FALSE \ + ) \ + : FALSE \ + ) + +#define JNI_term_to_jchar(T,J) \ + ( PL_get_integer((T),&i) \ + && i >= JNI_MIN_JCHAR \ + && i <= JNI_MAX_JCHAR \ + && ( (J)=(jchar)i, TRUE) \ + ) + +#define JNI_term_to_jbyte(T,J) \ + ( PL_get_integer((T),&i) \ + && i >= JNI_MIN_JBYTE \ + && i <= JNI_MAX_JBYTE \ + && ( (J)=(jbyte)i, TRUE) \ + ) + +#define JNI_term_to_jshort(T,J) \ + ( PL_get_integer((T),&i) \ + && i >= JNI_MIN_JSHORT \ + && i <= JNI_MAX_JSHORT \ + && ( (J)=(jshort)i, TRUE) \ + ) + +/* JW: jint is always 32-bit! */ + +#define JNI_term_to_jint(T,J) \ + ( PL_get_integer((T),&i) \ + && ((J)=i, TRUE) \ + ) + +#define JNI_term_to_non_neg_jint(T,J) \ + ( PL_get_intptr((T),&i) \ + && i >= 0 \ + && ( (J)=(jint)i, TRUE) \ + ) + +#define JNI_term_to_jlong(T,J) \ + ( PL_get_int64((T),&i64) \ + && ( (J)=(jlong)i64, TRUE) \ + ) + +#define JNI_term_to_jfloat(T,J) \ + ( PL_get_float((T),&d) \ + ? ( (J)=(jfloat)d, TRUE) \ + : ( PL_get_int64((T),&i64) \ + && ( (J)=(jfloat)i64, TRUE) \ + ) \ + ) + +#define JNI_term_to_jdouble(T,J) \ + ( PL_get_float((T),&(J)) \ + ? TRUE \ + : ( PL_get_int64((T),&i64) \ + && ( (J)=(jdouble)i64, TRUE) \ + ) \ + ) + +#define JNI_term_to_jfieldID(T,J) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_jfieldID_1 \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_pointer(a1,(void**)&(J)) \ + ) + +#define JNI_term_to_jmethodID(T,J) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_jmethodID_1 \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_pointer(a1,(void**)&(J)) \ + ) + +/* converts: */ +/* atom -> String */ +/* @(Tag) -> obj */ +/* @(null) -> NULL */ +/* (else fails) */ +/* */ +#define JNI_term_to_ref(T,J) \ + ( PL_get_atom((T),&a) \ + ? jni_atom_to_String(env,a,(jobject*)&(J)) \ + : PL_get_functor((T),&fn) \ + && fn==JNI_functor_at_1 \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_atom(a1,&a) \ + && ( a==JNI_atom_null \ + ? ( (J)=0, TRUE) \ + : jni_tag_to_iref(a,(pointer*)&(J)) \ + ) \ + ) + +/* converts: */ +/* atom -> String */ +/* @(Tag) -> obj */ +/* (else fails) */ +/* stricter than JNI_term_to_ref(T,J) */ +/* */ +#define JNI_term_to_jobject(T,J) \ + ( JNI_term_to_ref(T,J) \ + && (J) != 0 \ + ) + +/* for now, these specific test-and-convert macros */ +/* are merely mapped to their nearest ancestor... */ + +#define JNI_term_to_jclass(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_throwable_jclass(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_non_array_jclass(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_throwable_jobject(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_jstring(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_object_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_boolean_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_byte_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_char_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_short_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_int_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_long_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_float_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_double_jarray(T,J) JNI_term_to_jobject(T,J) + +#define JNI_term_to_jbuf(T,J,TP) \ + ( PL_get_functor((T),&fn) \ + && fn==JNI_functor_jbuf_2 \ + && ( a2=PL_new_term_ref(), \ + PL_get_arg(2,(T),a2) \ + ) \ + && PL_get_atom(a2,&a) \ + && a==(TP) \ + && ( a1=PL_new_term_ref(), \ + PL_get_arg(1,(T),a1) \ + ) \ + && PL_get_pointer(a1,(void**)&(J)) \ + ) + +#define JNI_term_to_charP(T,J) \ + PL_get_atom_chars((T),&(J)) + +#define JNI_term_to_pointer(T,J) \ + PL_get_pointer((T),(void**)&(J)) + + +/* JNI Java-to-Prolog conversion macros: */ + +#define JNI_unify_void(T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_void \ + ) + +#define JNI_unify_false(T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_false \ + ) + +#define JNI_unify_true(T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_true \ + ) + +#define JNI_jboolean_to_term(J,T) \ + ( (J)==0 \ + ? JNI_unify_false((T)) \ + : JNI_unify_true((T)) \ + ) + +#define JNI_jchar_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jbyte_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jshort_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jint_to_term(J,T) \ + PL_unify_integer((T),(int)(J)) + +#define JNI_jlong_to_term(J,T) \ + PL_unify_int64((T),(int64_t)(J)) + +#define JNI_jfloat_to_term(J,T) \ + PL_unify_float((T),(double)(J)) + +#define JNI_jdouble_to_term(J,T) \ + PL_unify_float((T),(double)(J)) + +/* J can be an *expression* parameter to this macro; */ +/* we must evaluate it exactly once; hence we save its value */ +/* in the variable j, which must be dynamic (e.g. local) */ +/* if this macro is to be re-entrant */ +#define JNI_jobject_to_term(J,T) \ + ( ( j=(J), j==NULL ) \ + ? PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, JNI_atom_null \ + ) \ + : ( (*env)->IsInstanceOf(env,j,str_class) \ + ? jni_String_to_atom(env,j,&a) \ + && PL_unify_term((T), \ + PL_ATOM, a \ + ) \ + : jni_object_to_iref(env,j,&i) \ + && jni_iref_to_tag(i,&a) \ + && PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_at_1, \ + PL_ATOM, a \ + ) \ + ) \ + ) + +#define JNI_jfieldID_to_term(J,T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_jfieldID_1, \ + PL_POINTER, (void*)(J) \ + ) + +#define JNI_jmethodID_to_term(J,T) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_jmethodID_1, \ + PL_POINTER, (void*)(J) \ + ) + +#define JNI_jbuf_to_term(J,T,TP) \ + PL_unify_term((T), \ + PL_FUNCTOR, JNI_functor_jbuf_2, \ + PL_POINTER, (void*)(J), \ + PL_ATOM, (TP) \ + ) + +#define JNI_pointer_to_term(J,T) \ + PL_unify_pointer((T),(void*)(J)) + +#define JNI_charP_to_term(J,T) \ + PL_unify_atom_chars((T),(J)) + + +/*=== JNI initialisation macro (typically succeeds cheaply) ======================================== */ + +#define jni_ensure_jvm() ( ( jvm != NULL \ + || jni_create_default_jvm() \ + ) \ + && (env=jni_env()) != NULL \ + ) + + +/*=== JPL initialisation macros (typically succeed cheaply) ======================================== */ + +/* outcomes: */ +/* fail to find jpl.*, jpl.fli.* classes or to convert init args to String[]: exception, FALSE */ +/* JPL is (newly or already) out of RAW state: TRUE */ +#define jpl_ensure_jpl_init(e) ( jpl_status != JPL_INIT_RAW \ + || jpl_ensure_jpl_init_1(e) \ + ) +/* outcomes: */ +/* JPL or PVM init has already failed: FALSE */ +/* JPL or PVM init fails while being necessarily attempted: exception */ +/* JPL is (newly or already) fully initialised: TRUE */ +#define jpl_ensure_pvm_init(e) ( jpl_status == JPL_INIT_OK \ + || jpl_ensure_pvm_init_1(e) \ + ) + + +/*=== types (structs and typedefs) ================================================================= */ + +typedef struct Hr_Entry HrEntry; /* enables circular definition... */ + +struct Hr_Entry { /* a single interned reference */ + jobject obj; /* a JNI global ref */ + int hash; /* identityHashCode(obj) */ + HrEntry *next; /* next entry in this chain, or NULL */ + }; + +typedef struct Hr_Table HrTable; + +struct Hr_Table { + int count; /* current # entries */ + int threshold; /* rehash on add when count==threshold */ + int length; /* # slots in slot array */ + HrEntry **slots; /* pointer to slot array */ + }; + +typedef intptr_t pointer; /* for JPL */ + +/*=== JNI constants: sizes of JNI primitive types ================================================== */ + +int size[16] = { /* NB relies on sequence of JNI_XPUT_* defs */ + 0, + sizeof(jboolean), /* size[JNI_XPUT_BOOLEAN] */ + sizeof(jbyte), /* size[JNI_XPUT_BYTE] */ + sizeof(jchar), /* size[JNI_XPUT_CHAR] */ + sizeof(jshort), /* size[JNI_XPUT_SHORT] */ + sizeof(jint), /* size[JNI_XPUT_INT] */ + sizeof(jlong), /* size[JNI_XPUT_LONG] */ + sizeof(jfloat), /* size[JNI_XPUT_FLOAT] */ + sizeof(jdouble), /* size[JNI_XPUT_DOUBLE] */ + 0, /* n/a - JNI_FLOAT_TO_DOUBLE */ + 0, /* n/a - JNI_LONG_TO_FLOAT */ + 0, /* n/a - JNI_LONG_TO_DOUBLE */ + 0, /* n/a - JNI_REF */ + 0, /* n/a - JNI_ATOM */ + 0, /* n/a - JNI_JVALUEP */ + sizeof(jvalue) /* size[JNI_XPUT_JVALUE] */ + }; + + +/*=== JNI "constants", lazily initialised by jni_init() ============================================ */ + +static atom_t JNI_atom_false; /* false */ +static atom_t JNI_atom_true; /* true */ + +static atom_t JNI_atom_boolean; /* boolean */ +static atom_t JNI_atom_char; /* char */ +static atom_t JNI_atom_byte; /* byte */ +static atom_t JNI_atom_short; /* short */ +static atom_t JNI_atom_int; /* int */ +static atom_t JNI_atom_long; /* long */ +static atom_t JNI_atom_float; /* float */ +static atom_t JNI_atom_double; /* double */ + +static atom_t JNI_atom_null; /* null */ +static atom_t JNI_atom_void; /* void */ + +static functor_t JNI_functor_at_1; /* @(_) */ +static functor_t JNI_functor_jbuf_2; /* jbuf(_,_) */ +static functor_t JNI_functor_jlong_2; /* jlong(_,_) */ +static functor_t JNI_functor_jfieldID_1; /* jfieldID(_) */ +static functor_t JNI_functor_jmethodID_1; /* jmethodID(_) */ +static functor_t JNI_functor_error_2; /* error(_, _) */ +static functor_t JNI_functor_java_exception_1; /* java_exception(_) */ +static functor_t JNI_functor_jpl_error_1; /* jpl_error(_) */ + + +/*=== JNI's static JVM references, lazily initialised by jni_init() ================================ */ + +static jclass c_class; /* java.lang.Class (rename to jClass_c ?) */ +static jmethodID c_getName; /* java.lang.Class' getName() (rename to jClassGetName_m ?) */ +static jclass str_class; /* java.lang.String (this duplicates jString_c below) */ +static jclass term_class; /* jpl.Term */ +static jclass termt_class; /* jpl.fli.term_t */ + +static jclass sys_class; /* java.lang.System (rename to jSystem_c ?) */ +static jmethodID sys_ihc; /* java.lang.System's identityHashCode() (rename to jSystemIdentityHashCode_m ?) */ +static jmethodID term_getTerm; /* jpl.Term's getTerm() */ +static jmethodID term_put; /* jpl.Term's put() */ +static jmethodID term_putTerm; /* jpl.Term's static putTerm(Term,term_t) */ + + +/*=== JPL's reusable global class object refs, initialised by jpl_ensure_jpl_init() ================ */ + +static jclass jString_c; +static jclass jJPLException_c; +static jclass jTermT_c; +static jclass jAtomT_c; +static jclass jFunctorT_c; +static jclass jFidT_c; +static jclass jPredicateT_c; +static jclass jQidT_c; +static jclass jModuleT_c; +static jclass jEngineT_c; + +static jclass jLongHolder_c; +static jclass jPointerHolder_c; +static jclass jIntHolder_c; +static jclass jInt64Holder_c; +static jclass jDoubleHolder_c; +static jclass jStringHolder_c; +static jclass jObjectHolder_c; +static jclass jBooleanHolder_c; + + +/*=== JPL's reusable constant field IDs, set before first use by jpl_ensure_jpl_init() ============= */ + +static jfieldID jLongHolderValue_f; +static jfieldID jPointerHolderValue_f; +static jfieldID jIntHolderValue_f; +static jfieldID jInt64HolderValue_f; +static jfieldID jDoubleHolderValue_f; +static jfieldID jStringHolderValue_f; +static jfieldID jObjectHolderValue_f; +static jfieldID jBooleanHolderValue_f; + + +/*=== JPL's default args for PL_initialise() (NB these are not really good enough) ================= */ + +const char *default_args[] = { "swipl", + "-g", "true", + "-nosignals", + NULL + }; /* *must* have final NULL */ + + +/*=== JNI global state (initialised by jni_create_jvm_c) =========================================== */ + +static JavaVM *jvm = NULL; /* non-null -> JVM successfully loaded & initialised */ +static char *jvm_ia[2] = {"-Xrs", NULL}; +static char **jvm_dia = jvm_ia; /* default JVM init args (after jpl init, until jvm init) */ +static char **jvm_aia = NULL; /* actual JVM init args (after jvm init) */ + + +/*=== JNI global state (hashed global refs) ======================================================== */ + +static HrTable *hr_table = NULL; /* static handle to allocated-on-demand table */ +static int hr_add_count = 0; /* cumulative total of new refs interned */ +static int hr_old_count = 0; /* cumulative total of old refs reused */ +static int hr_del_count = 0; /* cumulative total of dead refs released */ + + +/*=== JPL global state, initialised by jpl_ensure_jpl_init() or jpl_ensure_jvm_init() ============== */ + +static int jpl_status = JPL_INIT_RAW; /* neither JPL nor PVM initialisation has occurred */ +static jobject pvm_dia = NULL; /* default PVM init args (after jpl init, until pvm init) */ +static jobject pvm_aia = NULL; /* actual PVM init args (after pvm init) */ +static PL_engine_t *engines = NULL; /* handles of the pooled Prolog engines */ +static int engines_allocated = 0; /* size of engines array */ +#ifdef HAVE_PTHREAD_H +static pthread_mutex_t engines_mutex = PTHREAD_MUTEX_INITIALIZER; /* for controlling pool access */ +static pthread_cond_t engines_cond = PTHREAD_COND_INITIALIZER; /* for controlling pool access */ + +static pthread_mutex_t jvm_init_mutex = PTHREAD_MUTEX_INITIALIZER; /* for controlling lazy initialisation */ +static pthread_mutex_t pvm_init_mutex = PTHREAD_MUTEX_INITIALIZER; /* for controlling lazy initialisation */ +#endif + + +/*=== common functions ============================================================================= */ + +static JNIEnv* +jni_env(void) /* economically gets a JNIEnv pointer, valid for this thread */ +{ JNIEnv *env; + + switch( (*jvm)->GetEnv(jvm, (void**)&env, JNI_VERSION_1_2) ) + { case JNI_OK: + return env; + case JNI_EDETACHED: + DEBUG(2, Sdprintf( "[JPL: jni_env() calls AttachCurrentThread]\n")); + return (*jvm)->AttachCurrentThread(jvm, (void**)&env, NULL) == 0 ? env : NULL; + default: /* error */ + return NULL; + } +} + + +static char * +jpl_c_lib_version(void) + { + static char v[100]; /* version string */ + static char *vp = NULL; /* set to v at first call */ + + if ( vp != NULL ) /* already set? */ + { + return vp; + } + sprintf( v, "%d.%d.%d-%s", JPL_C_LIB_VERSION_MAJOR, JPL_C_LIB_VERSION_MINOR, JPL_C_LIB_VERSION_PATCH, JPL_C_LIB_VERSION_STATUS); + vp = v; + return vp; + } + + +static foreign_t +jpl_c_lib_version_1_plc( + term_t ta /* -atom: this library's version as an atom, e.g. '3.1.0-alpha' */ + ) + { + + return PL_unify_atom_chars(ta,jpl_c_lib_version()); + } + + +static foreign_t +jpl_c_lib_version_4_plc( + term_t tmajor, /* -integer: major version number */ + term_t tminor, /* -integer: minor version number */ + term_t tpatch, /* -integer: patch version number */ + term_t tstatus /* -atom: status of this version */ + ) + { + + return PL_unify_integer(tmajor,JPL_C_LIB_VERSION_MAJOR) + && PL_unify_integer(tminor,JPL_C_LIB_VERSION_MINOR) + && PL_unify_integer(tpatch,JPL_C_LIB_VERSION_PATCH) + && PL_unify_atom_chars(tstatus,JPL_C_LIB_VERSION_STATUS); + } + + +/*=== JNI function prototypes (to resolve unavoidable forward references) ========================== */ + +static int jni_hr_add(JNIEnv*, jobject, pointer*); +static bool jni_hr_del(JNIEnv*, pointer); + + +/*=== JNI functions (NB first 6 are cited in macros used subsequently) ============================= */ + +static bool +jni_tag_to_iref2(const char *s, pointer *iref) +{ if ( s[0] == 'J' + && s[1] == '#' + && isdigit(s[2]) + && isdigit(s[3]) + && isdigit(s[4]) + && isdigit(s[5]) + && isdigit(s[6]) + && isdigit(s[7]) + && isdigit(s[8]) + && isdigit(s[9]) + && isdigit(s[10]) + && isdigit(s[11]) + && isdigit(s[12]) + && isdigit(s[13]) + && isdigit(s[14]) + && isdigit(s[15]) + && isdigit(s[16]) + && isdigit(s[17]) + && isdigit(s[18]) + && isdigit(s[19]) + && isdigit(s[20]) + && isdigit(s[21])) /* s is like 'J#01234567890123456789' */ + { pointer r; + char *endptr; + + r = strtoul(&s[2], &endptr, 10); + if ( endptr == s+22 ) + { *iref = r; + return 1; + } + } + + return 0; +} + + +static bool +jni_tag_to_iref1( + const char *s, + pointer *iref + ) + { + + if (strlen(s) == 22) + { + return jni_tag_to_iref2(s,iref); + } + else + { + return 0; + } + } + + +/* this now checks that the atom's name resembles a tag (PS 18/Jun/2004) */ +static bool +jni_tag_to_iref( + atom_t a, + pointer *iref + ) + { + + return jni_tag_to_iref1(PL_atom_chars(a), iref); + } + + +#if SIZEOF_LONG == SIZEOF_VOIDP +#define IREF_FMT "J#%020lu" +#define IREF_INTTYPE unsigned long +#elif SIZEOF_LONG_LONG == SIZEOF_VOIDP +#define IREF_FMT "J#%020llu" +#define IREF_INTTYPE unsigned long long +#else +#error "Cannot determine format for irefs" +#endif + +static bool +jni_iref_to_tag( + pointer iref, + atom_t *a + ) + { + char abuf[23]; + + sprintf( abuf, IREF_FMT, (IREF_INTTYPE)iref); /* oughta encapsulate this mapping... */ + *a = PL_new_atom(abuf); + PL_unregister_atom(*a); /* empirically decrement reference count... */ + return TRUE; /* can't fail (?!) */ + } + + +static bool +jni_object_to_iref( + JNIEnv *env, + jobject obj, /* a newly returned JNI local ref */ + pointer *iref /* gets an integerised, canonical, global equivalent */ + ) + { + int r; /* temp for result code */ + + if ( (r=jni_hr_add(env, obj, iref)) == JNI_HR_ADD_NEW ) + { + hr_add_count++; /* obj was novel, has been added to dict */ + return TRUE; + } + else + if ( r == JNI_HR_ADD_OLD ) + { + hr_old_count++; /* obj was already in dict */ + return TRUE; + } + else + { + return FALSE; /* r == JNI_HR_ADD_FAIL, presumably */ + } + } + + +/* retract all jpl_iref_type_cache(Iref,_) facts */ +static bool +jni_tidy_iref_type_cache(pointer iref) +{ term_t goal; + + if ( JPL_CACHE_TYPE_OF_REF ) + { return ( (goal = PL_new_term_ref()) && + PL_unify_term(goal, + PL_FUNCTOR_CHARS, "jpl_tidy_iref_type_cache", 1, + PL_INT, iref) && + PL_call(goal, + PL_new_module(PL_new_atom("jpl"))) + ); + } else + { return TRUE; + } +} + + +/* could merge this into jni_hr_del() ? */ +static bool +jni_free_iref( /* called indirectly from agc hook when a possible iref is unreachable */ + JNIEnv *env, + pointer iref + ) + { + + if ( jni_hr_del(env,iref) ) /* iref matched a hashedref table entry? (in which case, was deleted) */ + { + if ( !jni_tidy_iref_type_cache(iref) ) + { + DEBUG(0, Sdprintf( "[JPL: jni_tidy_iref_type_cache(%u) failed]\n", iref)); + } + hr_del_count++; + return TRUE; + } + else + { + return FALSE; + } + } + + +/* NB this delivers an atom_t, not a term_t */ +/* returns FALSE if the String arg is NULL */ +static bool + jni_String_to_atom( /* called from JNI_jobject_to_term(J,T) and jpl.fli.Prolog#new_atom() */ + JNIEnv *env, + jobject s, + atom_t *a + ) + { + jsize len = (*env)->GetStringLength(env,s); + const jchar *jcp = (*env)->GetStringChars(env,s,NULL); + + if ( s == NULL ) + { + return FALSE; + } +#if SIZEOF_WCHAR_T == 2 + { + *a = PL_new_atom_wchars(len,jcp); /* easy, huh? (thanks, Jan) */ + } +#else + { + pl_wchar_t *wp; + jsize i; + + if ( (wp=(pl_wchar_t*)malloc(sizeof(pl_wchar_t)*len)) == NULL) { + (*env)->ReleaseStringChars(env,s,jcp); + return FALSE; + } + for ( i=0 ; iReleaseStringChars(env,s,jcp); + return TRUE; + } + + +/* NB this takes an atom_t, not a term_t */ +static bool + jni_atom_to_String( + JNIEnv *env, + atom_t a, + jobject *s + ) + { + size_t len; + pl_wchar_t *wp; + jchar *jcp; + unsigned char *cp; + unsigned int i; + + if ( (cp=(unsigned char*)PL_atom_nchars(a,&len)) != NULL ) /* got 8-bit chars from trad atom */ + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,(jsize)len); + free(jcp); + return TRUE; + } + else if ( (wp=(pl_wchar_t*)PL_atom_wchars(a,&len)) != NULL ) /* got (wide) chars from wide atom */ + { +#if SIZEOF_WCHAR_T == 2 + { + *s = (*env)->NewString(env,wp,(jsize)len); + } +#else + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,len); + free(jcp); + } +#endif + return TRUE; + } + else + { + return FALSE; + } + } + + +/* checks that the term_t is a string and delivers a String representation of it */ +static bool + jni_string_to_String( + JNIEnv *env, + term_t t, /* a term which may or may not be a SWIPL string */ + jobject *s + ) + { + size_t len; + pl_wchar_t *wp; + jchar *jcp; + char *cp; + unsigned int i; + + if ( PL_get_nchars(t,&len,&cp,CVT_ATOM) ) /* got 8-bit chars from string? */ + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,(jsize)len); + free(jcp); + return TRUE; + } + else if ( PL_get_wchars(t,&len,&wp,CVT_STRING) ) /* got (wide) chars from string? */ + { +#if SIZEOF_WCHAR_T == 2 + { + *s = (*env)->NewString(env,wp,(jsize)len); + } +#else + { + jcp = (jchar*)malloc(sizeof(jchar)*len); + for ( i=0 ; iNewString(env,jcp,len); + free(jcp); + } +#endif + return TRUE; + } + else + { + return FALSE; + } + } + + +/* an FLI wrapper for jni_tag_to_iref() above */ +/* is currently called by jpl_tag_to_type/2, jpl_cache_type_of_object/2 */ +/* jpl_tag_to_type/2 is called by jpl_object_to_type/2, jpl_ref_to_type/2 */ +static foreign_t +jni_tag_to_iref_plc( + term_t tt, /* +atom: a tag */ + term_t ti /* -integer: its corresponding iref */ + ) + { + atom_t a; + pointer iref; + + return PL_get_atom(tt,&a) + && jni_tag_to_iref(a,&iref) + && PL_unify_integer(ti,iref); + } + + +/* this will be hooked to SWI-Prolog's PL_agc_hook, */ +/* and is called just before each redundant atom is expunged from the dict */ +/* NB need to be able to switch this on and off from Prolog... */ +static bool +jni_atom_freed( + atom_t a + ) + { + const char *cp = PL_atom_chars(a); + pointer iref; + char cs[23]; /* was 11 until 24/Apr/2007 */ + JNIEnv *env; + + if ((env = jni_env()) == NULL) + return TRUE; /* oughta log an error, at least the first time... */ + if ( jni_tag_to_iref( a, &iref) ) /* check format and convert digits to int if ok */ + { + sprintf( cs, IREF_FMT, (IREF_INTTYPE)iref); /* reconstruct digits part of tag in cs */ + if ( strcmp(cp,cs) != 0 ) /* original digits != reconstructed digits? */ + { + DEBUG(0, Sdprintf( "[JPL: garbage-collected tag '%s'=%u is bogus (not canonical)]\n", cp, iref)); + } + else + if ( !jni_free_iref(env,iref) ) /* free it (iff it's in the hashedref table) */ + { + DEBUG(0, Sdprintf( "[JPL: garbage-collected tag '%s' is bogus (not in HashedRefs)]\n", cp)); + } + } + else + { + } + return TRUE; /* means "go ahead and expunge the atom" (we do this regardless) */ + } + + +/*=== "hashed ref" (canonical JNI global reference) support ======================================== */ + +static foreign_t +jni_hr_info_plc( /* implements jni_hr_info/4 */ + term_t t1, /* -integer: # object references currently in hash table */ + term_t t2, /* -integer: total # object references so far added */ + term_t t3, /* -integer: total # object references so far found to be already in table */ + term_t t4 /* -integer: total # object references deleted from table (by atom GC) */ + ) + { + return PL_unify_integer(t1,(hr_table==NULL?0:hr_table->count)) /* 0 was -1 (??) */ + && PL_unify_integer(t2,hr_add_count) + && PL_unify_integer(t3,hr_old_count) + && PL_unify_integer(t4,hr_del_count); + } + + +/* unifies t2 with a Prolog term which represents the contents of the hashtable slot */ +static bool +jni_hr_table_slot( + term_t t2, + HrEntry *slot + ) + { + term_t tp = PL_new_term_ref(); + + if ( slot == NULL ) + { + return PL_unify_nil(t2); + } + else + { + return PL_unify_list(t2,tp,t2) + && PL_unify_term(tp, + PL_FUNCTOR, PL_new_functor(PL_new_atom("-"),2), + PL_INT, slot->hash, + PL_LONG, slot->obj + ) + && jni_hr_table_slot(t2,slot->next) + ; + } + } + + +/* unifies t with a list of hash table slot representations */ +static foreign_t +jni_hr_table_plc( + term_t t + ) + { + term_t t1 = PL_copy_term_ref(t); + term_t t2 = PL_new_term_ref(); + int i; + + for ( i=0 ; ilength ; i++ ) + { + if ( !PL_unify_list(t1,t2,t1) || !jni_hr_table_slot(t2,hr_table->slots[i]) ) + { + return FALSE; + } + } + return PL_unify_nil(t1); + } + + +/* an empty table of length is successfully created, where none was before */ +static bool +jni_hr_create( + int length /* required # slots in table */ + ) + { + int i; /* temp for iterative slot initialisation */ + + if ( hr_table != NULL ) + { + return FALSE; /* table already exists (destroy before recreating) */ + } + if ( length <= 0 ) + { + return FALSE; /* unsuitable length */ + } + if ( (hr_table=(HrTable*)malloc(sizeof(HrTable))) == NULL ) + { + return FALSE; /* malloc failed (out of memory, presumably) */ + } + hr_table->length = length; + hr_table->threshold = (int)(hr_table->length*JNI_HR_LOAD_FACTOR); + if ( (hr_table->slots=(HrEntry**)malloc(length*sizeof(HrEntry*))) == NULL ) + { + return FALSE; /* malloc failed: out of memory, presumably */ + } + for ( i=0 ; ilength ; i++ ) + { + hr_table->slots[i] = NULL; + } + hr_table->count = 0; + return TRUE; + } + + +/* an empty table of some default length is successfully created, where none was before */ +static bool +jni_hr_create_default(void) + { + + return jni_hr_create( 101); + } + + +/* ep must point to a chain of zero or more entries; they are freed */ +static void +jni_hr_free_chain_entries( + HrEntry *ep + ) + { + + if ( ep != NULL ) + { + jni_hr_free_chain_entries( ep->next); + free( ep); + } + } + + +/* table t is emptied */ +static void +jni_hr_free_table_chains( + HrTable *t + ) + { + int index; + + for ( index=0 ; index<(t->length) ; index++ ) + { + jni_hr_free_chain_entries( t->slots[index]); + t->slots[index] = NULL; + } + t->count = 0; + } + + +/* all dynamic space used by the pointed-to table is freed */ +static bool +jni_hr_free_table( + HrTable *t + ) + { + + if ( t == NULL ) + { + return FALSE; /* table does not exist */ + } + else + { + jni_hr_free_table_chains( t); + free( t); + return TRUE; + } + } + + +/* the current table is replaced by an equivalent one with more free space */ +static bool +jni_hr_rehash(void) + { + HrTable *t0; /* old table while building new one from it */ + int i; /* for iterating through slots in old table */ + HrEntry *ep1; /* for iterating through all entries in old table */ + HrEntry *ep2; /* an old table entry being relinked into new table */ + int index; /* slot index in new table of entry being transferred */ + + t0 = hr_table; /* temporarily hold onto former table */ + hr_table = NULL; /* precondition for jni_hr_create */ + if ( !jni_hr_create(2*t0->length+1) ) /* new bigger table in its place */ + { + hr_table = t0; /* replace former table for tidiness */ + return FALSE; /* failed to create replacement table during rehash */ + } + for ( i=0 ; ilength ; i++ ) /* for each slot in *former* table */ + { + for ( ep1=t0->slots[i] ; ep1!=NULL ; ) + { /* for each entry in that slot's chain */ + ep2 = ep1; /* grab this entry */ + ep1 = ep1->next; /* advance to next entry or NULL */ + index = (ep2->hash & 0x7fffffff) % hr_table->length; /* new */ + ep2->next = hr_table->slots[index]; /* relink into new array */ + hr_table->slots[index] = ep2; /* " */ + } + t0->slots[i] = NULL; /* tidy old array for generic freeing later */ + } + hr_table->count = t0->count; /* new table's count is old table's count */ + jni_hr_free_table( t0); /* free all space used by old table (NB no entries) */ + return TRUE; + } + + +static bool + jni_hr_hash( /* renamed in v3.0.4 from jni_object_to_hash (it belongs with this hr stuff) */ + JNIEnv *env, + jobject obj, /* MUST BE a valid non-null reference to a Java object */ + int *hash /* gets obj's System.identityHashCode() */ + ) + { + jobject e; /* for possible (but unlikely?) exception */ + + *hash = (*env)->CallStaticIntMethod(env,sys_class,sys_ihc,obj,obj); + return (e=(*env)->ExceptionOccurred(env))==NULL; + } + + +/* returns */ +/* JNI_HR_ADD_NEW -> referenced object is novel */ +/* JNI_HR_ADD_OLD -> referenced object is already known */ +/* JNI_HR_ADD_FAIL -> something went wrong */ +/* and, in *iref, an integerised canonical global ref to the object */ +static int +jni_hr_add( + JNIEnv *env, + jobject lref, /* new JNI local ref from a regular JNI call */ + pointer *iref /* for integerised canonical global ref */ + ) + { + int hash; /* System.identityHashCode of lref */ + int index; /* lref's slot index, from hash */ + HrEntry *ep; /* temp entry pointer for chain traversal */ + jobject gref; /* iff lref is novel, will hold a global surrogate */ + + if ( hr_table==NULL && !jni_hr_create_default() ) + { + return JNI_HR_ADD_FAIL; /* lazy table creation failed: oughta sort return codes */ + } + if ( !jni_hr_hash(env,lref,&hash) ) /* renamed in v3.0.4 from jni_object_to_hash */ + { + return JNI_HR_ADD_FAIL; /* System.identityHashCode() failed (?) */ + } + index = (hash & 0x7fffffff) % hr_table->length; /* make this a macro? */ + for ( ep=hr_table->slots[index] ; ep!=NULL ; ep=ep->next ) + { + if ( ep->hash==hash ) + { + if ( (*env)->IsSameObject(env,ep->obj,lref) ) + { /* newly referenced object is already interned */ + (*env)->DeleteLocalRef(env,lref); /* free redundant new ref */ + *iref = (pointer)ep->obj; /* old, equivalent (global) ref */ + return JNI_HR_ADD_OLD; + } + } + } + if ( hr_table->count >= hr_table->threshold ) + { + (void)jni_hr_rehash(); /* oughta check for failure, and return it... */ + return jni_hr_add(env,lref,iref); /* try again with new, larger table */ + } + /* referenced object is novel, and we can add it to table */ + if ( (gref=(*env)->NewGlobalRef(env,lref)) == NULL ) /* derive a global ref */ + { + return JNI_HR_ADD_FAIL; + } + (*env)->DeleteLocalRef(env,lref); /* free redundant (local) ref */ + ep = (HrEntry*)malloc(sizeof(HrEntry)); + ep->hash = hash; + ep->obj = gref; + ep->next = hr_table->slots[index]; /* insert at front of chain */ + hr_table->slots[index] = ep; + hr_table->count++; + *iref = (pointer)gref; /* pass back the (new) global ref */ + return JNI_HR_ADD_NEW; /* obj was newly interned, under iref as supplied */ + } + + +/* iref corresponded to an entry in the current HashedRef table; */ +/* now that entry is gone, its space is recovered, counts are adjusted etc. */ +/* called only from jni_free_iref() */ +static bool +jni_hr_del( + JNIEnv *env, + pointer iref /* a possibly spurious canonical global iref */ + ) + { + int index; /* index to a HashedRef table slot */ + HrEntry *ep; /* pointer to a HashedRef table entry */ + HrEntry **epp; /* pointer to ep's handle, in case it needs updating */ + + DEBUG(1, Sdprintf( "[removing possible object reference %u]\n", iref)); + for ( index=0 ; indexlength ; index++ ) /* for each slot */ + { + for ( epp=&(hr_table->slots[index]), ep=*epp ; ep!=NULL ; epp=&(ep->next), ep=*epp ) + { + if ( (pointer)(ep->obj) == iref ) /* found the sought entry? */ + { + (*env)->DeleteGlobalRef( env, ep->obj); /* free the global object reference */ + *epp = ep->next; /* bypass the entry */ + free( ep); /* free the now-redundant space */ + hr_table->count--; /* adjust table's entry count */ + DEBUG(1, Sdprintf( "[found & removed hashtable entry for object reference %u]\n", iref)); + return TRUE; /* entry found and removed */ + } + } + } + DEBUG(1, Sdprintf("[JPL: failed to find hashtable entry for (presumably bogus) object reference %u]\n", iref)); + return FALSE; + } + + +/*=== JNI initialisation =========================================================================== */ + +/* called once: after successful PVM & JVM creation/discovery, before any JNI calls */ +static int +jni_init( void ) + { + jclass lref; /* temporary local ref, replaced by global */ + JNIEnv *env = jni_env(); /* could pass this in, but this is easier here */ + + if (env == NULL) + return -8; + + /* these initialisations require an active PVM: */ + JNI_atom_false = PL_new_atom( "false"); + JNI_atom_true = PL_new_atom( "true"); + + JNI_atom_boolean = PL_new_atom( "boolean"); + JNI_atom_char = PL_new_atom( "char"); + JNI_atom_byte = PL_new_atom( "byte"); + JNI_atom_short = PL_new_atom( "short"); + JNI_atom_int = PL_new_atom( "int"); + JNI_atom_long = PL_new_atom( "long"); + JNI_atom_float = PL_new_atom( "float"); + JNI_atom_double = PL_new_atom( "double"); + + JNI_atom_null = PL_new_atom( "null"); + JNI_atom_void = PL_new_atom( "void"); /* not yet used properly (?) */ + + JNI_functor_at_1 = PL_new_functor( PL_new_atom("@"), 1); + JNI_functor_jbuf_2 = PL_new_functor( PL_new_atom("jbuf"), 2); + JNI_functor_jlong_2 = PL_new_functor( PL_new_atom("jlong"), 2); + JNI_functor_jfieldID_1 = PL_new_functor( PL_new_atom("jfieldID"), 1); + JNI_functor_jmethodID_1 = PL_new_functor( PL_new_atom("jmethodID"), 1); + + JNI_functor_error_2 = PL_new_functor(PL_new_atom("error"), 2); + JNI_functor_java_exception_1 = PL_new_functor( PL_new_atom("java_exception"), 1); + JNI_functor_jpl_error_1 = PL_new_functor( PL_new_atom("jpl_error"), 1); + + (void)PL_agc_hook( (PL_agc_hook_t)jni_atom_freed); /* link atom GC to object GC (cool:-) */ + + /* these initialisations require an active JVM: */ + return ( (lref=(*env)->FindClass(env,"java/lang/Class")) != NULL + && (c_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + + && (lref=(*env)->FindClass(env,"java/lang/String")) != NULL + && (str_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + && (c_getName=(*env)->GetMethodID(env,c_class,"getName","()Ljava/lang/String;")) != NULL + + && (lref=(*env)->FindClass(env,"java/lang/System")) != NULL + && (sys_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + && (sys_ihc=(*env)->GetStaticMethodID(env,sys_class,"identityHashCode","(Ljava/lang/Object;)I")) != NULL + + && (lref=(*env)->FindClass(env,"jpl/Term")) != NULL + && (term_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + && (term_getTerm=(*env)->GetStaticMethodID(env,term_class,"getTerm","(Ljpl/fli/term_t;)Ljpl/Term;")) != NULL + && (term_put=(*env)->GetMethodID(env,term_class,"put","(Ljpl/fli/term_t;)V")) != NULL + && (term_putTerm=(*env)->GetStaticMethodID(env,term_class,"putTerm","(Ljava/lang/Object;Ljpl/fli/term_t;)V")) != NULL + + && (lref=(*env)->FindClass(env,"jpl/fli/term_t")) != NULL + && (termt_class=(*env)->NewGlobalRef(env,lref)) != NULL + && ( (*env)->DeleteLocalRef(env,lref), TRUE) + + ? 0 + : -7 /* NB #define this? */ + ) + ; + } + + +/*=== JNI exception/error processing/support ======================================================= */ + +/* returns a new error(java_exception(@(tag)),msg) to represent a caught Java exception */ +static term_t +jni_new_java_exception(atom_t tag, atom_t msg) +{ term_t e; + + if ( (e=PL_new_term_ref()) && + PL_unify_term(e, + PL_FUNCTOR, JNI_functor_error_2, + PL_FUNCTOR, JNI_functor_java_exception_1, + PL_FUNCTOR, JNI_functor_at_1, + PL_ATOM, tag, + PL_ATOM, msg) ) /* Seems unblanaced!? */ + return e; + + return 0; +} + + +/* returns a new error(jpl_error(@(tag)),msg) to represent an exceptional condition raised within JPL */ +static term_t +jni_new_jpl_error(atom_t tag, atom_t msg) +{ term_t e; + + if ( (e= PL_new_term_ref()) && + PL_unify_term(e, + PL_FUNCTOR, JNI_functor_error_2, + PL_FUNCTOR, JNI_functor_jpl_error_1, + PL_FUNCTOR, JNI_functor_at_1, + PL_ATOM, tag, + PL_ATOM, msg) ) /* Seems unblanced!? */ + return e; + + return 0; +} + + +/* test for a raised exception; clear and report it if found */ +static bool +jni_check_exception( + JNIEnv *env + ) + { + jobject ej; /* the pending Java exception, if any */ + jobject c; /* its class */ + jobject s; /* its class name as a JVM String, for the report */ + term_t ep; /* a newly created Prolog exception */ + pointer i; /* temp for an iref denoting a Java exception */ + atom_t tag; /* temp for a tag denoting a Java exception */ + atom_t msg; /* temp for impl-def comment (classname) within error/2 */ + + if ( (ej=(*env)->ExceptionOccurred(env)) == NULL ) + { + return TRUE; + } + else + { + (*env)->ExceptionClear(env); /* clear "exception-pending" state so we can do JNI calls */ + if ( (c=(*env)->GetObjectClass(env,ej)) != NULL ) /* get class of exception */ + { + if ( (s=(*env)->CallObjectMethod(env,c,c_getName)) != NULL ) /* get name of class */ + { + if ( jni_object_to_iref(env,ej,&i) ) + { + if ( jni_iref_to_tag(i,&tag) ) + { + if ( jni_String_to_atom(env,s,&msg) ) + { + ep = jni_new_java_exception(tag,msg); + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToGetUTFCharsOfNameOfClassOfException"),tag); + } + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToConvertExceptionIrefToTagatom"),JNI_atom_null); + } + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToConvertExceptionObjectToIref"),JNI_atom_null); + } + (*env)->DeleteLocalRef(env,s); + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToGetNameOfClassOfException"),JNI_atom_null); + } + (*env)->DeleteLocalRef(env,c); + } + else + { + ep = jni_new_jpl_error(PL_new_atom("FailedToGetClassOfException"),JNI_atom_null); + } + return PL_raise_exception(ep); + } + } + + +/*=== buffer and method param transput ============================================================= */ + +static foreign_t + jni_byte_buf_length_to_codes_plc( + term_t tbb, /* +integer */ + term_t tlen, /* +integer */ + term_t tcs /* -term */ + ) + { + functor_t fn; + term_t a1; + atom_t a; + term_t a2; + jbyte *bb; + int len; + int i; + term_t tl = PL_copy_term_ref( tcs); + term_t ta = PL_new_term_ref(); + void *ptr; + + if ( !( PL_get_functor(tbb,&fn) + && fn==JNI_functor_jbuf_2 + && ( a2=PL_new_term_ref(), + PL_get_arg(2,tbb,a2) + ) + && PL_get_atom(a2,&a) + && a==JNI_atom_byte + && ( a1=PL_new_term_ref(), + PL_get_arg(1,tbb,a1) + ) + && PL_get_pointer(a1,&ptr) + ) + || !PL_get_integer(tlen,&len) + ) + { + return FALSE; + } + bb = ptr; + + for ( i=0 ; i first) */ + term_t txc, /* +integer: transput code, as Prolog integer, appropriate to this param */ + term_t tt, /* +term: param value as datum (value or ref) */ + term_t tjvp /* +pointer: param buffer (allocated just for this call) */ + ) + { + int n; /* got from tn (see above) */ + int xc; /* got from txc (see above) */ + jvalue *jvp; /* got from tjvp (see above) */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + atom_t a; /* " */ + int i; /* " */ + int64_t i64; /* " */ + double d; /* " */ + + if ( !PL_get_integer(tn,&n) || + !PL_get_integer(txc,&xc) || + !PL_get_pointer(tjvp,(void*)&jvp) ) + { + return FALSE; + } + + switch ( xc ) + { + case JNI_XPUT_BOOLEAN: + return JNI_term_to_jboolean(tt,jvp[n].z); + + case JNI_XPUT_BYTE: + return JNI_term_to_jbyte(tt,jvp[n].b); + + case JNI_XPUT_CHAR: + return JNI_term_to_jchar(tt,jvp[n].c); + + case JNI_XPUT_SHORT: + return JNI_term_to_jshort(tt,jvp[n].s); + + case JNI_XPUT_INT: + return JNI_term_to_jint(tt,jvp[n].i); + + case JNI_XPUT_LONG: + return JNI_term_to_jlong(tt,jvp[n].j); + + case JNI_XPUT_FLOAT: + return JNI_term_to_jfloat(tt,jvp[n].f); + + case JNI_XPUT_DOUBLE: + return JNI_term_to_jdouble(tt,jvp[n].d); + + case JNI_XPUT_REF: + { JNIEnv *env = jni_env(); + + return env == NULL ? FALSE : JNI_term_to_ref(tt,jvp[n].l); /* this macro needs a valid env */ + } + default: + return FALSE; /* unknown or inappropriate JNI_XPUT_* code */ + } + } + + +/* for completeness, allocates zero-length buffers too, while avoiding malloc() problems */ +static foreign_t +jni_alloc_buffer_plc( + term_t txc, /* +integer: transput code */ + term_t tlen, /* +integer: required length (# items) */ + term_t tbp /* -pointer: PL_POINTER to newly allocated buffer */ + ) + { + int xc; + int len; + void *bp; + + return PL_get_integer(txc,&xc) + && ( ( xc>=JNI_XPUT_BOOLEAN && xc<=JNI_XPUT_DOUBLE ) || xc==JNI_XPUT_JVALUE ) + && PL_get_integer(tlen,&len) + && len >= 0 + && (bp=malloc((len==0?1:len)*size[xc])) != NULL /* avoid (unsafe) malloc(0) */ + && ( PL_unify_pointer(tbp,(void*)bp) + ? TRUE + : ( free(bp), FALSE) + ) + ; + } + + +static foreign_t +jni_free_buffer_plc( + term_t tbp /* +integer: PL_POINTER to redundant buffer */ + ) + { + void *bp; + + return PL_get_pointer(tbp,&bp) + && ( free(bp), TRUE); + } + + +static foreign_t +jni_fetch_buffer_value_plc( + term_t tbp, /* +pointer: PL_POINTER to an active buffer from jni_alloc_buffer/3 */ + term_t ti, /* +integer: index into buffer; 0 <= i < length */ + term_t tv, /* -term: required value (@(false), @(true), integer or float) from buffer */ + term_t txc /* +integer: transput code (one of JNI_XPUT_*) */ + ) + { + void *bp; /* buffer address (trusted to be valid) */ + int i; /* buffer index (trusted to be valid) */ + int xc; /* transput code (range-checked by switch statement) */ + + if ( !PL_get_pointer(tbp,&bp) || !PL_get_integer(ti,&i) || !PL_get_integer(txc,&xc) ) + { + return FALSE; + } + + switch ( xc ) /* primitive type only */ + { + case JNI_XPUT_BOOLEAN: + return JNI_jboolean_to_term(((jboolean*)bp)[i],tv); + + case JNI_XPUT_CHAR: + return PL_unify_integer(tv,((jchar*)bp)[i]); + + case JNI_XPUT_BYTE: + return PL_unify_integer(tv,((jbyte*)bp)[i]); + + case JNI_XPUT_SHORT: + return PL_unify_integer(tv,((jshort*)bp)[i]); + + case JNI_XPUT_INT: + return PL_unify_integer(tv,((jint*)bp)[i]); + + case JNI_XPUT_LONG: + return PL_unify_int64(tv,((jlong*)bp)[i]); + + case JNI_XPUT_FLOAT: + return PL_unify_float(tv,((jfloat*)bp)[i]); + + case JNI_XPUT_DOUBLE: + return PL_unify_float(tv,((jdouble*)bp)[i]); + + default: + return FALSE; + } + } + + +static foreign_t +jni_stash_buffer_value_plc( + term_t tbp, /* +integer: PL_POINTER to buffer */ + term_t ti, /* +integer: index into buffer */ + term_t tv, /* +term: @(false), @(true), integer or float */ + term_t txc /* +integer: transput code (one of JNI_XPUT_*) */ + ) + { + void *bp; + int i; + int idx; + int64_t i64; + int xc; + double d; + functor_t fn; + term_t a1; + atom_t a; + + if ( !PL_get_pointer(tbp,&bp) + || !PL_get_integer(ti,&idx) + || !PL_get_integer(txc,&xc) + ) + { + return FALSE; + } + + switch ( xc ) + { + case JNI_XPUT_BOOLEAN: + return JNI_term_to_jboolean(tv,((jboolean*)bp)[idx]); + + case JNI_XPUT_CHAR: + return JNI_term_to_jchar(tv,((jchar*)bp)[idx]); + + case JNI_XPUT_BYTE: + return JNI_term_to_jbyte(tv,((jbyte*)bp)[idx]); + + case JNI_XPUT_SHORT: + return JNI_term_to_jshort(tv,((jshort*)bp)[idx]); + + case JNI_XPUT_INT: + return JNI_term_to_jint(tv,((jint*)bp)[idx]); + + case JNI_XPUT_LONG: + return JNI_term_to_jlong(tv,((jlong*)bp)[idx]); + + case JNI_XPUT_FLOAT: + return JNI_term_to_jfloat(tv,((jfloat*)bp)[idx]); + + case JNI_XPUT_DOUBLE: + return JNI_term_to_jdouble(tv,((jdouble*)bp)[idx]); + + default: + return FALSE; + } + } + + +/*=== JVM initialisation, startup etc. ============================================================= */ + +static int +jni_get_created_jvm_count(void) + { + jint n; + + return ( JNI_GetCreatedJavaVMs(NULL,0,&n) == 0 /* what does the '0' arg mean? */ + ? n + : -1 + ) + ; + } + + +#define MAX_JVM_OPTIONS 100 + +static int +jni_create_jvm_c( + char *classpath + ) + { + JavaVMInitArgs vm_args; + /* char cpopt[10000]; */ + char *cpoptp; + JavaVMOption opt[MAX_JVM_OPTIONS]; + int r; + jint n; + int optn = 0; + JNIEnv *env; + + DEBUG(1, Sdprintf( "[creating JVM with 'java.class.path=%s']\n", classpath)); + vm_args.version = JNI_VERSION_1_2; /* "Java 1.2 please" */ + if ( classpath ) + { + cpoptp = (char *)malloc(strlen(classpath)+20); + strcpy( cpoptp, "-Djava.class.path="); /* was cpopt */ + strcat( cpoptp, classpath); /* oughta check length... */ + vm_args.options = opt; + opt[optn].optionString = cpoptp; /* was cpopt */ + optn++; + } + /* opt[optn++].optionString = "-Djava.compiler=NONE"; */ + /* opt[optn].optionString = "exit"; // I don't understand this yet... */ + /* opt[optn++].extraInfo = jvm_exit; // this function has been moved to jpl_extras.c */ + /* opt[optn].optionString = "abort"; // I don't understand this yet... */ + /* opt[optn++].extraInfo = jvm_abort; // this function has been moved to jpl_extras.c */ + /* opt[optn++].optionString = "-Xcheck:jni"; // extra checking of JNI calls */ +#if __YAP_PROLOG__ + opt[optn++].optionString = "-Xmx512m"; // give java enough space +#if defined(__APPLE__) + // I can't make jpl work with AWT graphics, without creating the extra thread. + opt[optn++].optionString = "-Djava.awt.headless=true"; +#endif + // opt[optn++].optionString = "-XstartOnFirstThread"; +#endif + /* opt[optn++].optionString = "-Xnoclassgc"; // so method/field IDs remain valid (?) */ + /* opt[optn].optionString = "vfprintf"; */ + /* opt[optn++].extraInfo = fprintf; // no O/P, then SEGV */ + /* opt[optn++].extraInfo = xprintf; // one message, then SEGV */ + /* opt[optn++].optionString = "-verbose:jni"; */ + + if ( jvm_dia != NULL ) + { + int i; + + for ( i=0 ; jvm_dia[i]!=NULL ; i++ ) + { + opt[optn++].optionString = jvm_dia[i]; + } + jvm_aia = jvm_dia; + jvm_dia = NULL; + } + + vm_args.nOptions = optn; + /* vm_args.ignoreUnrecognized = TRUE; */ + + return + ( JNI_GetCreatedJavaVMs(&jvm,1,&n) == 0 /* what does the '1' arg mean? */ + && n == 1 + /* && (*jvm)->GetEnv(jvm,(void**)&env,JNI_VERSION_1_2) == JNI_OK */ + && (env = jni_env()) != NULL + ? 2 /* success (JVM already available) */ + : ( (r=JNI_CreateJavaVM(&jvm,(void**)&env,&vm_args)) == 0 + ? 0 /* success (JVM created OK) */ + : ( jvm=NULL, r) /* -ve, i.e. some create error */ + ) + ); + } + + +static foreign_t +jni_get_created_jvm_count_plc( + term_t t1 + ) + { + + return PL_unify_integer(t1,jni_get_created_jvm_count()); + } + + +static int +jni_create_jvm( + char *cp + ) + { + int r1; + int r2; + + DEBUG(1, Sdprintf("[JPL: checking for Java VM...]\n")); + return + ( jvm != NULL + ? 1 /* already initialised */ + : ( (r1=jni_create_jvm_c(cp)) < 0 + ? r1 /* err code from JVM-specific routine */ + : ( (r2=jni_init()) < 0 + ? r2 /* err code from jni_init() */ + : ( r1 == 0 /* success code from JVM-specific routine */ + ? ( DEBUG(0, Sdprintf("[JPL: Java VM created]\n")), r1) + : ( DEBUG(0, Sdprintf("[JPL: Java VM found]\n")), r1) + ) + ) + ) + ); + } + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +JW: Note: recent SWI-Prolog set the environment using Win32 API. We can +only get the proper value using the Win32 API; getenv only returns the +value at startup of Prolog. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +jni_create_default_jvm(void) + { + int r; +#ifdef __WINDOWS__ + char *cp; + DWORD len; + + if ( (len=GetEnvironmentVariable("CLASSPATH", NULL, 0)) > 0 ) + { cp = malloc(len+1); + + GetEnvironmentVariable("CLASSPATH", cp, len+1); + } else + cp = NULL; +#else + char *cp = getenv("CLASSPATH"); +#endif + + DEBUG(0, Sdprintf("jni_create_default_jvm(): cp=%s\n", cp)); + + if ( (r=jni_create_jvm(cp)) < 0 ) + { + Sdprintf("[JPL: failed to create Java VM (error %d)]\n", r); + } + return r >= 0; /* e.g. 2 -> "JVM already available" */ + } + + +static foreign_t +jni_ensure_jvm_plc(void) + { + JNIEnv *env; /* not used but perhaps initialised by the jni_ensure_jvm() macro */ + + return jni_ensure_jvm(); + } + + + +#if __YAP_PROLOG__ +#include "hacks.c" +#endif + +/* NB after any JNI call which clearly indicates success, */ +/* it is unnecessary to check for an exception */ +/* (potential for slight economy here...) */ +static foreign_t +jni_void_0_plc( /* C identifiers distinguished _0_ etc, Prolog name is overloaded */ + term_t tn /* +integer */ + ) + { + int n; /* JNI function index */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() /* ought this either succeed or throw a JPL error? */ + || !PL_get_integer(tn,&n) /* ought this either succeed or throw a Prolog type error? */ + ) + { + return FALSE; + } + + switch ( n ) + { + case 17: + r = ( (*env)->ExceptionClear(env) , TRUE ); /* could just return... */ + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_1_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1 /* +term: Arg1 */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* int i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + /* void *p1; // temp for converted (JVM) arg */ + char *c1; /* " */ + /* int i1; // " */ + /* jlong l1; // " */ + /* double d1; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 18: + r = JNI_term_to_charP(ta1,c1) + && ( (*env)->FatalError(env,(char*)c1) , TRUE ); + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_2_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2 /* +term: Arg2 */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* int i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + /* void *p1; // temp for converted (JVM) arg */ + /* void *p2; // " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* int i1; // " */ + /* int i2; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* double d1; // " */ + /* double d2; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 166: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_char) */ + /* && ( (*env)->ReleaseStringChars(env,(jstring)p1,(jchar*)p2) , TRUE ); */ + /* break; */ + /* case 170: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,c2,JNI_atom_byte) */ + /* && ( (*env)->ReleaseStringUTFChars(env,(jstring)p1,(char*)c2) , TRUE ); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_3_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3 /* +term: Arg3 */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + int i; /* " */ + int64_t i64; /* " */ + double d; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + void *p2; /* " */ + void *p3; /* " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* char *c3; // " */ + /* int i1; // " */ + int i2; /* " */ + int i3; /* " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + jlong l3; /* " */ + /* float f1; // " */ + /* float f2; // " */ + float f3; /* " */ + /* double d1; // " */ + /* double d2; // " */ + double d3; /* " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 63: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && ( (*env)->CallVoidMethodA(env,(jobject)p1,(jmethodID)p2,jvp) , TRUE ); + break; + case 104: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_ref(ta3,p3) + && ( (*env)->SetObjectField(env,(jobject)p1,(jfieldID)p2,(jobject)p3) , TRUE ); + break; + case 105: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jboolean(ta3,i3) + && ( (*env)->SetBooleanField(env,(jobject)p1,(jfieldID)p2,(jboolean)i3) , TRUE ); + break; + case 106: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jbyte(ta3,i3) + && ( (*env)->SetByteField(env,(jobject)p1,(jfieldID)p2,(jbyte)i3) , TRUE ); + break; + case 107: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jchar(ta3,i3) + && ( (*env)->SetCharField(env,(jobject)p1,(jfieldID)p2,(jchar)i3) , TRUE ); + break; + case 108: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jshort(ta3,i3) + && ( (*env)->SetShortField(env,(jobject)p1,(jfieldID)p2,(jshort)i3) , TRUE ); + break; + case 109: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jint(ta3,i3) + && ( (*env)->SetIntField(env,(jobject)p1,(jfieldID)p2,(jint)i3) , TRUE ); + break; + case 110: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jlong(ta3,l3) + && ( (*env)->SetLongField(env,(jobject)p1,(jfieldID)p2,(jlong)l3) , TRUE ); + break; + case 111: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jfloat(ta3,f3) /* f3 was d3 */ + && ( (*env)->SetFloatField(env,(jobject)p1,(jfieldID)p2,(jfloat)f3) , TRUE ); /* f3 was d3 */ + break; + case 112: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jdouble(ta3,d3) + && ( (*env)->SetDoubleField(env,(jobject)p1,(jfieldID)p2,(jdouble)d3) , TRUE ); + break; + case 143: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && ( (*env)->CallStaticVoidMethodA(env,(jclass)p1,(jmethodID)p2,jvp) , TRUE ); + break; + case 154: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_ref(ta3,p3) + && ( (*env)->SetStaticObjectField(env,(jclass)p1,(jfieldID)p2,(jobject)p3) , TRUE ); + break; + case 155: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jboolean(ta3,i3) + && ( (*env)->SetStaticBooleanField(env,(jclass)p1,(jfieldID)p2,(jboolean)i3) , TRUE ); + break; + case 156: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jbyte(ta3,i3) + && ( (*env)->SetStaticByteField(env,(jclass)p1,(jfieldID)p2,(jbyte)i3) , TRUE ); + break; + case 157: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jchar(ta3,i3) + && ( (*env)->SetStaticCharField(env,(jclass)p1,(jfieldID)p2,(jchar)i3) , TRUE ); + break; + case 158: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jshort(ta3,i3) + && ( (*env)->SetStaticShortField(env,(jclass)p1,(jfieldID)p2,(jshort)i3) , TRUE ); + break; + case 159: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jint(ta3,i3) + && ( (*env)->SetStaticIntField(env,(jclass)p1,(jfieldID)p2,(jint)i3) , TRUE ); + break; + case 160: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jlong(ta3,l3) + && ( (*env)->SetStaticLongField(env,(jclass)p1,(jfieldID)p2,(jlong)l3) , TRUE ); + break; + case 161: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jfloat(ta3,f3) /* f3 was d3 */ + && ( (*env)->SetStaticFloatField(env,(jclass)p1,(jfieldID)p2,(jfloat)f3) , TRUE ); /* f3 was d3 */ + break; + case 162: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_term_to_jdouble(ta3,d3) + && ( (*env)->SetStaticDoubleField(env,(jclass)p1,(jfieldID)p2,(jdouble)d3) , TRUE ); + break; + case 174: + r = JNI_term_to_object_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_ref(ta3,p3) + && ( (*env)->SetObjectArrayElement(env,(jobjectArray)p1,(jsize)i2,(jobject)p3) , TRUE ); + break; + /* case 191: */ + /* r = JNI_term_to_boolean_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_boolean) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseBooleanArrayElements(env,(jbooleanArray)p1,(jboolean*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 192: */ + /* r = JNI_term_to_byte_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_byte) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseByteArrayElements(env,(jbyteArray)p1,(jbyte*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 193: */ + /* r = JNI_term_to_char_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_char) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseCharArrayElements(env,(jcharArray)p1,(jchar*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 194: */ + /* r = JNI_term_to_short_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_short) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseShortArrayElements(env,(jshortArray)p1,(jshort*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 195: */ + /* r = JNI_term_to_int_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_int) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseIntArrayElements(env,(jintArray)p1,(jint*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 196: */ + /* r = JNI_term_to_long_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_long) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseLongArrayElements(env,(jlongArray)p1,(jlong*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 197: */ + /* r = JNI_term_to_float_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_float) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseFloatArrayElements(env,(jfloatArray)p1,(jfloat*)p2,(jint)i3) , TRUE ); */ + /* break; */ + /* case 198: */ + /* r = JNI_term_to_double_jarray(ta1,p1) */ + /* && JNI_term_to_jbuf(ta2,p2,JNI_atom_double) */ + /* && JNI_term_to_jint(ta3,i3) */ + /* && ( (*env)->ReleaseDoubleArrayElements(env,(jdoubleArray)p1,(jdouble*)p2,(jint)i3) , TRUE ); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_void_4_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3, /* +term: Arg3 */ + term_t ta4 /* +term: Arg4 */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + term_t a2; /* " */ + atom_t a; /* " */ + /* char *cp; // " */ + int i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + /* void *p2; // " */ + /* void *p3; // " */ + void *p4; /* " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* char *c3; // " */ + /* char *c4; // " */ + /* int i1; // " */ + int i2; /* " */ + int i3; /* " */ + /* int i4; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* jlong l3; // " */ + /* jlong l4; // " */ + /* double d1; // " */ + /* double d2; // " */ + /* double d3; // " */ + /* double d4; // " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 93: */ + /* r = JNI_term_to_jobject(ta1,p1) */ + /* && JNI_term_to_jclass(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && ( (*env)->CallNonvirtualVoidMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp) , TRUE ); */ + /* break; */ + case 199: + r = JNI_term_to_boolean_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_boolean) + && ( (*env)->GetBooleanArrayRegion(env,(jbooleanArray)p1,(jsize)i2,(jsize)i3,(jboolean*)p4) , TRUE ); + break; + case 200: + r = JNI_term_to_byte_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_byte) + && ( (*env)->GetByteArrayRegion(env,(jbyteArray)p1,(jsize)i2,(jsize)i3,(jbyte*)p4) , TRUE ); + break; + case 201: + r = JNI_term_to_char_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_char) + && ( (*env)->GetCharArrayRegion(env,(jcharArray)p1,(jsize)i2,(jsize)i3,(jchar*)p4) , TRUE ); + break; + case 202: + r = JNI_term_to_short_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_short) + && ( (*env)->GetShortArrayRegion(env,(jshortArray)p1,(jsize)i2,(jsize)i3,(jshort*)p4) , TRUE ); + break; + case 203: + r = JNI_term_to_int_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_int) + && ( (*env)->GetIntArrayRegion(env,(jintArray)p1,(jsize)i2,(jsize)i3,(jint*)p4) , TRUE ); + break; + case 204: + r = JNI_term_to_long_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_long) + && ( (*env)->GetLongArrayRegion(env,(jlongArray)p1,(jsize)i2,(jsize)i3,(jlong*)p4) , TRUE ); + break; + case 205: + r = JNI_term_to_float_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_float) + && ( (*env)->GetFloatArrayRegion(env,(jfloatArray)p1,(jsize)i2,(jsize)i3,(jfloat*)p4) , TRUE ); + break; + case 206: + r = JNI_term_to_double_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_double) + && ( (*env)->GetDoubleArrayRegion(env,(jdoubleArray)p1,(jsize)i2,(jsize)i3,(jdouble*)p4) , TRUE ); + break; + case 207: + r = JNI_term_to_boolean_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_boolean) + && ( (*env)->SetBooleanArrayRegion(env,(jbooleanArray)p1,(jsize)i2,(jsize)i3,(jboolean*)p4) , TRUE ); + break; + case 208: + r = JNI_term_to_byte_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_byte) + && ( (*env)->SetByteArrayRegion(env,(jbyteArray)p1,(jsize)i2,(jsize)i3,(jbyte*)p4) , TRUE ); + break; + case 209: + r = JNI_term_to_char_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_char) + && ( (*env)->SetCharArrayRegion(env,(jcharArray)p1,(jsize)i2,(jsize)i3,(jchar*)p4) , TRUE ); + break; + case 210: + r = JNI_term_to_short_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_short) + && ( (*env)->SetShortArrayRegion(env,(jshortArray)p1,(jsize)i2,(jsize)i3,(jshort*)p4) , TRUE ); + break; + case 211: + r = JNI_term_to_int_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_int) + && ( (*env)->SetIntArrayRegion(env,(jintArray)p1,(jsize)i2,(jsize)i3,(jint*)p4) , TRUE ); + break; + case 212: + r = JNI_term_to_long_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_long) + && ( (*env)->SetLongArrayRegion(env,(jlongArray)p1,(jsize)i2,(jsize)i3,(jlong*)p4) , TRUE ); + break; + case 213: + r = JNI_term_to_float_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_float) + && ( (*env)->SetFloatArrayRegion(env,(jfloatArray)p1,(jsize)i2,(jsize)i3,(jfloat*)p4) , TRUE ); + break; + case 214: + r = JNI_term_to_double_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2) + && JNI_term_to_jint(ta3,i3) + && JNI_term_to_jbuf(ta4,p4,JNI_atom_double) + && ( (*env)->SetDoubleArrayRegion(env,(jdoubleArray)p1,(jsize)i2,(jsize)i3,(jdouble*)p4) , TRUE ); + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_0_plc( + term_t tn, /* +integer: JNI function index */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* pointer i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 4: */ + /* r = JNI_jint_to_term((*env)->GetVersion(env),tr); */ + /* break; */ + /* case 15: */ + /* r = JNI_jobject_to_term((*env)->ExceptionOccurred(env),tr); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; /* surely NEITHER of these throws an exception! */ + } + + +static foreign_t +jni_func_1_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + pointer i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + jobject j; /* " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + char *c1; /* " */ + int i1; /* " */ + /* jlong l1; // " */ + /* double d1; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 6: + r = JNI_term_to_charP(ta1,c1) + && JNI_jobject_to_term((*env)->FindClass(env,(char*)c1),tr); /* *NOT* Unicode */ + break; + case 10: + r = JNI_term_to_jclass(ta1,p1) + && JNI_jobject_to_term((*env)->GetSuperclass(env,(jclass)p1),tr); + break; + /* case 13: */ + /* r = JNI_term_to_throwable_jobject(ta1,p1) */ + /* && JNI_jint_to_term((*env)->Throw(env,(jthrowable)p1),tr); */ + /* break; */ + /* case 27: */ + /* r = JNI_term_to_non_array_jclass(ta1,p1) */ + /* && JNI_jobject_to_term((*env)->AllocObject(env,(jclass)p1),tr); */ + /* break; */ + case 31: + r = JNI_term_to_jobject(ta1,p1) + && JNI_jobject_to_term((*env)->GetObjectClass(env,(jobject)p1),tr); + break; + /* case 164: // not used */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jint_to_term((*env)->GetStringLength(env,(jstring)p1),tr); */ + /* break; */ + /* case 167: // not used */ + /* r = JNI_term_to_charP(ta1,c1) */ + /* && JNI_jobject_to_term((*env)->NewStringUTF(env,(char*)c1),tr); */ + /* break; */ + /* case 168: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jint_to_term((*env)->GetStringUTFLength(env,(jstring)p1),tr); */ + /* break; */ + case 171: + r = JNI_term_to_jarray(ta1,p1) + && JNI_jint_to_term((*env)->GetArrayLength(env,(jarray)p1),tr); + break; + case 175: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewBooleanArray(env,(jsize)i1),tr); + break; + case 176: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewByteArray(env,(jsize)i1),tr); + break; + case 177: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewCharArray(env,(jsize)i1),tr); + break; + case 178: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewShortArray(env,(jsize)i1),tr); + break; + case 179: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewIntArray(env,(jsize)i1),tr); + break; + case 180: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewLongArray(env,(jsize)i1),tr); + break; + case 181: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewFloatArray(env,(jsize)i1),tr); + break; + case 182: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_jobject_to_term((*env)->NewDoubleArray(env,(jsize)i1),tr); + break; + /* case 217: */ + /* r = JNI_term_to_jobject(ta1,p1) */ + /* && JNI_jint_to_term((*env)->MonitorEnter(env,(jobject)p1),tr); */ + /* break; */ + /* case 218: */ + /* r = JNI_term_to_jobject(ta1,p1) */ + /* && JNI_jint_to_term((*env)->MonitorExit(env,(jobject)p1),tr); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_2_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + pointer i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + jobject j; /* " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + void *p2; /* " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* int i1; // " */ + int i2; /* " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* double d1; // " */ + /* double d2; // " */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 11: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jclass(ta2,p2) + && JNI_jboolean_to_term((*env)->IsAssignableFrom(env,(jclass)p1,(jclass)p2),tr); + break; + /* case 14: */ + /* r = JNI_term_to_throwable_jclass(ta1,p1) */ + /* && JNI_term_to_charP(ta2,c2) */ + /* && JNI_jint_to_term((*env)->ThrowNew(env,(jclass)p1,(char*)c2),tr); */ + /* break; */ + /* case 24: */ + /* r = JNI_term_to_ref(ta1,p1) */ + /* && JNI_term_to_ref(ta2,p2) */ + /* && JNI_jboolean_to_term((*env)->IsSameObject(env,(jobject)p1,(jobject)p2),tr); */ + /* break; */ + /* case 32: */ + /* r = JNI_term_to_ref(ta1,p1) */ + /* && JNI_term_to_jclass(ta2,p2) */ + /* && JNI_jboolean_to_term((*env)->IsInstanceOf(env,(jobject)p1,(jclass)p2),tr); */ + /* break; */ + case 95: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jobject_to_term((*env)->GetObjectField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 96: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jboolean_to_term((*env)->GetBooleanField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 97: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jbyte_to_term((*env)->GetByteField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 98: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jchar_to_term((*env)->GetCharField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 99: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jshort_to_term((*env)->GetShortField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 100: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jint_to_term((*env)->GetIntField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 101: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jlong_to_term((*env)->GetLongField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 102: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jfloat_to_term((*env)->GetFloatField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 103: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jdouble_to_term((*env)->GetDoubleField(env,(jobject)p1,(jfieldID)p2),tr); + break; + case 145: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jobject_to_term((*env)->GetStaticObjectField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 146: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jboolean_to_term((*env)->GetStaticBooleanField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 147: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jbyte_to_term((*env)->GetStaticByteField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 148: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jchar_to_term((*env)->GetStaticCharField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 149: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jshort_to_term((*env)->GetStaticShortField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 150: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jint_to_term((*env)->GetStaticIntField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 151: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jlong_to_term((*env)->GetStaticLongField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 152: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jfloat_to_term((*env)->GetStaticFloatField(env,(jclass)p1,(jfieldID)p2),tr); + break; + case 153: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jfieldID(ta2,p2) + && JNI_jdouble_to_term((*env)->GetStaticDoubleField(env,(jclass)p1,(jfieldID)p2),tr); + break; + /* case 163: */ + /* r = JNI_term_to_charP(ta1,c1) // oughta be _jcharP, i.e. Unicode */ + /* && JNI_term_to_non_neg_jint(ta2,i2) */ + /* && JNI_jobject_to_term((*env)->NewString(env,(jchar*)c1,(jsize)i2),tr); */ + /* break; */ + /* case 165: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetStringChars(env,(jstring)p1,(jboolean*)&i2),tr,JNI_atom_boolean) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 169: */ + /* r = JNI_term_to_jstring(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetStringUTFChars(env,(jstring)p1,(jboolean*)&i2),tr,JNI_atom_byte) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + case 173: + { int i; /* JW: i is long in this function */ + + i2 = 0; /* JW: make compiler happy */ + r = JNI_term_to_object_jarray(ta1,p1) + && JNI_term_to_jint(ta2,i2); + } + if ( r ) + r = JNI_jobject_to_term((*env)->GetObjectArrayElement(env,(jobjectArray)p1,(jsize)i2),tr); + break; + /* case 183: */ + /* r = JNI_term_to_boolean_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetBooleanArrayElements(env,(jbooleanArray)p1,(jboolean*)&i2),tr,JNI_atom_boolean) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 184: */ + /* r = JNI_term_to_byte_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetByteArrayElements(env,(jbyteArray)p1,(jboolean*)&i2),tr,JNI_atom_byte) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 185: */ + /* r = JNI_term_to_char_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetCharArrayElements(env,(jcharArray)p1,(jboolean*)&i2),tr,JNI_atom_char) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 186: */ + /* r = JNI_term_to_short_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetShortArrayElements(env,(jshortArray)p1,(jboolean*)&i2),tr,JNI_atom_short) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 187: */ + /* r = JNI_term_to_int_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetIntArrayElements(env,(jintArray)p1,(jboolean*)&i2),tr,JNI_atom_int) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 188: */ + /* r = JNI_term_to_long_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetLongArrayElements(env,(jlongArray)p1,(jboolean*)&i2),tr,JNI_atom_long) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 189: */ + /* r = JNI_term_to_float_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetFloatArrayElements(env,(jfloatArray)p1,(jboolean*)&i2),tr,JNI_atom_float) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + /* case 190: */ + /* r = JNI_term_to_double_jarray(ta1,p1) */ + /* && JNI_jbuf_to_term((*env)->GetDoubleArrayElements(env,(jdoubleArray)p1,(jboolean*)&i2),tr,JNI_atom_double) */ + /* && JNI_jboolean_to_term(i2,ta2); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_3_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3, /* +term: Arg3 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + functor_t fn; /* temp for conversion macros */ + term_t a1; /* " */ + /* term_t a2; // " */ + atom_t a; /* " */ + /* char *cp; // " */ + pointer i; /* " */ + /* int xhi; // " */ + /* int xlo; // " */ + jobject j; /* " */ + /* jlong jl; // " */ + void *p1; /* temp for converted (JVM) arg */ + void *p2; /* " */ + void *p3; /* " */ + /* char *c1; // " */ + char *c2; /* " */ + char *c3; /* " */ + int i1; /* " */ + /* int i2; // " */ + /* int i3; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* jlong l3; // " */ + /* double d1; // " */ + /* double d2; // " */ + /* double d3; // " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + case 30: + r = JNI_term_to_non_array_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jobject_to_term((*env)->NewObjectA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 33: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jmethodID_to_term((*env)->GetMethodID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 36: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jobject_to_term((*env)->CallObjectMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 39: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jboolean_to_term((*env)->CallBooleanMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 42: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jbyte_to_term((*env)->CallByteMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 45: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jchar_to_term((*env)->CallCharMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 48: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jshort_to_term((*env)->CallShortMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 51: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jint_to_term((*env)->CallIntMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 54: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jlong_to_term((*env)->CallLongMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 57: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jfloat_to_term((*env)->CallFloatMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 60: + r = JNI_term_to_jobject(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jdouble_to_term((*env)->CallDoubleMethodA(env,(jobject)p1,(jmethodID)p2,jvp),tr); + break; + case 94: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jfieldID_to_term((*env)->GetFieldID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 113: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jmethodID_to_term((*env)->GetStaticMethodID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 116: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jobject_to_term((*env)->CallStaticObjectMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 119: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jboolean_to_term((*env)->CallStaticBooleanMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 122: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jbyte_to_term((*env)->CallStaticByteMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 125: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jchar_to_term((*env)->CallStaticCharMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 128: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jshort_to_term((*env)->CallStaticShortMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 131: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jint_to_term((*env)->CallStaticIntMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 134: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jlong_to_term((*env)->CallStaticLongMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 137: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jfloat_to_term((*env)->CallStaticFloatMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 140: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_jmethodID(ta2,p2) + && JNI_term_to_pointer(ta3,jvp) + && JNI_jdouble_to_term((*env)->CallStaticDoubleMethodA(env,(jclass)p1,(jmethodID)p2,jvp),tr); + break; + case 144: + r = JNI_term_to_jclass(ta1,p1) + && JNI_term_to_charP(ta2,c2) + && JNI_term_to_charP(ta3,c3) + && JNI_jfieldID_to_term((*env)->GetStaticFieldID(env,(jclass)p1,(char*)c2,(char*)c3),tr); + break; + case 172: + r = JNI_term_to_non_neg_jint(ta1,i1) + && JNI_term_to_jclass(ta2,p2) + && JNI_term_to_ref(ta3,p3) + && JNI_jobject_to_term((*env)->NewObjectArray(env,(jsize)i1,(jclass)p2,(jobject)p3),tr); + break; + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +static foreign_t +jni_func_4_plc( + term_t tn, /* +integer: JNI function index */ + term_t ta1, /* +term: Arg1 */ + term_t ta2, /* +term: Arg2 */ + term_t ta3, /* +term: Arg3 */ + term_t ta4, /* +term: Arg4 */ + term_t tr /* -term: Result */ + ) + { + int n; /* JNI function index */ + /* functor_t fn; // temp for conversion macros */ + /* term_t a1; // " */ + /* term_t a2; // " */ + /* atom_t a; // " */ + /* char *cp; // " */ + /* pointer i; // " */ + /* int xhi; // " */ + /* int xlo; // " */ + /* jobject j; // " */ + /* jlong jl; // " */ + /* void *p1; // temp for converted (JVM) arg */ + /* void *p2; // " */ + /* void *p3; // " */ + /* void *p4; // " */ + /* char *c1; // " */ + /* char *c2; // " */ + /* char *c3; // " */ + /* char *c4; // " */ + /* int i1; // " */ + /* int i2; // " */ + /* int i3; // " */ + /* int i4; // " */ + /* jlong l1; // " */ + /* jlong l2; // " */ + /* jlong l3; // " */ + /* jlong l4; // " */ + /* double d1; // " */ + /* double d2; // " */ + /* double d3; // " */ + /* double d4; // " */ + jvalue *jvp = NULL; /* if this is given a buffer, it will be freed after the call */ + jboolean r; /* Prolog exit/fail outcome */ + JNIEnv *env; + + if ( !jni_ensure_jvm() + || !PL_get_integer(tn,&n) + ) + { + return FALSE; + } + + switch ( n ) + { + /* case 5: */ + /* r = JNI_term_to_charP(ta1,c1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jbuf(ta3,p3,JNI_atom_byte) */ + /* && JNI_term_to_jint(ta4,i4) */ + /* && JNI_jobject_to_term((*env)->DefineClass(env,(char*)c1,(jobject)p2,(jbyte*)p3,(jsize)i4),tr); */ + /* break; */ + /* case 66: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jobject_to_term((*env)->CallNonvirtualObjectMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 69: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jboolean_to_term((*env)->CallNonvirtualBooleanMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 72: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jbyte_to_term((*env)->CallNonvirtualByteMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 75: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jchar_to_term((*env)->CallNonvirtualCharMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 78: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jshort_to_term((*env)->CallNonvirtualShortMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 81: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jint_to_term((*env)->CallNonvirtualIntMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 84: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jlong_to_term((*env)->CallNonvirtualLongMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 87: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jfloat_to_term((*env)->CallNonvirtualFloatMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + /* case 90: */ + /* r = JNI_term_to_jclass(ta1,p1) */ + /* && JNI_term_to_jobject(ta2,p2) */ + /* && JNI_term_to_jmethodID(ta3,p3) */ + /* && JNI_term_to_pointer(ta4,jvp) */ + /* && JNI_jdouble_to_term((*env)->CallNonvirtualDoubleMethodA(env,(jobject)p1,(jclass)p2,(jmethodID)p3,jvp),tr); */ + /* break; */ + default: + return FALSE; /* oughta throw exception (design-time error :-) */ + break; + } + + if ( jvp != NULL ) + { + free( jvp); + } + + return jni_check_exception(env) && r; + } + + +/*=== JPL functions ================================================================================ */ + +static int + create_pool_engines(void); + +static int +jpl_num_initial_default_args(void) /* used only once, by jpl_do_jpl_init() */ + { + int i; + + for ( i=0 ; default_args[i]!=NULL ; i++ ) + { + } + return i; + } + + +/* outcomes: */ +/* fail to find jpl.*, jpl.fli.* classes or to convert init args to String[]: exception, FALSE */ +/* all OK: TRUE */ +static bool +jpl_do_jpl_init( /* to be called once only, after PL init, before any JPL calls */ + JNIEnv *env + ) + { + jclass tc; /* temporary class ref */ + jobject ta; /* temporary array ref */ + char *msg; /* error message for exceptions thrown here */ + int i; /* loop counter */ + jobject to; /* temporary (String) object ref */ + + if ( jpl_status != JPL_INIT_RAW ) /* jpl init already attempted? (shouldn't happen) */ + { + DEBUG(1, Sdprintf( "[JPL: jpl_do_jpl_init() called AGAIN (skipping...)]\n")); + return TRUE; + } + + /* prerequisites for setting initial default args into String[] pvm_dia: */ + if ( (tc=(*env)->FindClass(env,"java/lang/String")) == NULL + || (jString_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (ta=(*env)->NewObjectArray(env,jpl_num_initial_default_args(),jString_c,NULL)) == NULL + || (pvm_dia=(*env)->NewGlobalRef(env,ta)) == NULL + || ( (*env)->DeleteLocalRef(env,ta), FALSE) + ) + { + msg = "jpl_do_jpl_init(): failed to find java.lang.String or create String[] pvm_dia"; + goto err; + } + + /* copy the initial default args into String[] pvm_dia: */ + for ( i=0 ; default_args[i]!=NULL ; i++ ) + { + if ( (to=(*env)->NewStringUTF(env,default_args[i])) == NULL ) + { + msg = "jpl_do_jpl_init(): failed to convert an initial default arg to a String"; + goto err; + } + (*env)->SetObjectArrayElement(env,pvm_dia,i,to); /* any errors/exceptions to be handled here? */ + } + + if ( (tc=(*env)->FindClass(env,"jpl/JPLException")) == NULL + || (jJPLException_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/term_t")) == NULL + || (jTermT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/atom_t")) == NULL + || (jAtomT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/functor_t")) == NULL + || (jFunctorT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/fid_t")) == NULL + || (jFidT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/predicate_t")) == NULL + || (jPredicateT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/qid_t")) == NULL + || (jQidT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/module_t")) == NULL + || (jModuleT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/engine_t")) == NULL + || (jEngineT_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/LongHolder")) == NULL + || (jLongHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/PointerHolder")) == NULL + || (jPointerHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/IntHolder")) == NULL + || (jIntHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/Int64Holder")) == NULL + || (jInt64Holder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/DoubleHolder")) == NULL + || (jDoubleHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/StringHolder")) == NULL + || (jStringHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/ObjectHolder")) == NULL + || (jObjectHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (tc=(*env)->FindClass(env,"jpl/fli/BooleanHolder")) == NULL + || (jBooleanHolder_c=(*env)->NewGlobalRef(env,tc)) == NULL + || ( (*env)->DeleteLocalRef(env,tc), FALSE) + + || (jLongHolderValue_f=(*env)->GetFieldID(env,jLongHolder_c,"value","J")) == NULL + + || (jPointerHolderValue_f=(*env)->GetFieldID(env,jPointerHolder_c,"value","J")) == NULL + + || (jIntHolderValue_f=(*env)->GetFieldID(env,jIntHolder_c,"value","I")) == NULL + + || (jInt64HolderValue_f=(*env)->GetFieldID(env,jInt64Holder_c,"value","J")) == NULL + + || (jDoubleHolderValue_f=(*env)->GetFieldID(env,jDoubleHolder_c,"value","D")) == NULL + + || (jStringHolderValue_f=(*env)->GetFieldID(env,jStringHolder_c,"value","Ljava/lang/String;")) == NULL + + || (jObjectHolderValue_f=(*env)->GetFieldID(env,jObjectHolder_c,"value","Ljava/lang/Object;")) == NULL + + || (jBooleanHolderValue_f=(*env)->GetFieldID(env,jBooleanHolder_c,"value","Z")) == NULL + ) + { + msg = "jpl_do_jpl_init(): failed to find jpl.* or jpl.fli.* classes"; + goto err; + } + + DEBUG(1, Sdprintf( "[jpl_do_jpl_init() sets jpl_status = JPL_INIT_PVM_MAYBE, returns TRUE]\n")); + jpl_status = JPL_INIT_PVM_MAYBE; + return TRUE; + +err: + jpl_status = JPL_INIT_JPL_FAILED; + (*env)->ThrowNew(env,jJPLException_c,msg); + return FALSE; + } + + +/* prerequisite: */ +/* called only from jpl_test_pvm_init() and jpl_do_pvm_init() */ +/* outcomes: */ +/* error setting up post-PVM-init JPL state: throws exception, sets status = PVM_FAILED, returns FALSE */ +/* OK: sets status = OK, returns TRUE */ +static bool +jpl_post_pvm_init( + JNIEnv *env, + int argc, + char **argv + ) + { + char *msg; + jobject ta; + int i; + + /* Prolog VM is already initialised (by us or by other party) */ + /* retire default init args and set up actual init args: */ + pvm_dia = NULL; /* probably oughta delete (global) ref to former args... */ + if ( (ta=(*env)->NewObjectArray(env,argc,jString_c,NULL)) == NULL + || (pvm_aia=(*env)->NewGlobalRef(env,ta)) == NULL + || ( (*env)->DeleteLocalRef(env,ta), FALSE) + ) + { + msg = "jpl_post_pvm_init(): failed to copy actual init args"; + goto err; + } + for ( i=0 ; iNewStringUTF(env,argv[i]); + if ( to == NULL ) + { + msg = "jpl_post_pvm_init(): failed to convert actual PL init arg to String"; + goto err; + } + (*env)->SetObjectArrayElement(env,pvm_aia,i,to); + } + + if ( create_pool_engines() != 0 ) + { + msg = "jpl_post_pvm_init(): failed to create Prolog engine pool"; + goto err; + } + + jpl_status = JPL_INIT_OK; + return TRUE; + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + jpl_status = JPL_INIT_PVM_FAILED; + return FALSE; + } + + +/* prerequisite: jpl_status != JPL_INIT_RAW */ +/* outcomes: */ +/* PVM is not (already) initialised -> FALSE */ +/* PVM is (already) initialised -> TRUE */ +/* error setting up post-PVM-init JPL state -> exception */ +static bool +jpl_test_pvm_init( + JNIEnv *env + ) + { + char *msg; + int argc; + char **argv; + /* jobject ta; */ + /* int i; */ + + if ( jpl_status == JPL_INIT_RAW ) + { + msg = "jpl_test_pvm_init(): called while jpl_status == JPL_INIT_RAW"; + goto err; + } + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl_test_pvm_init(): initialisation has already failed"; + goto err; + } + + if ( jpl_status == JPL_INIT_OK ) + { + return TRUE; + } + + if ( jpl_status == JPL_INIT_PVM_MAYBE ) + { + /* we test this each time (if not already initialised) in case other foreign code inits the PVM: */ + if ( !PL_is_initialised(&argc,&argv) ) /* PVM not ready? */ + { + /* jpl_status remains = JPL_INIT_PVM_MAYBE */ + DEBUG(1, Sdprintf( "[pl_test_pvm_init(): PL is not yet initialised: returning FALSE]\n")); + return FALSE; /* already-active Prolog VM not found (NB not an exceptional condition) */ + } + else + { + DEBUG(1, Sdprintf( "[pl_test_pvm_init(): PL is already initialised: proceeding to jpl_post_pvm_init()]\n")); + return jpl_post_pvm_init(env,argc,argv); /* TRUE, FALSE or exception */ + } + } + + msg = "jpl_test_pvm_init(): unknown jpl_status value"; + goto err; + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + jpl_status = JPL_INIT_PVM_FAILED; + return FALSE; + } + + +/* prerequisite: */ +/* jpl_status == JPL_INIT_PVM_MAYBE */ +/* outcomes: */ +/* successful PVM initialisation and subsequent JPL state setup -> TRUE */ +/* any error -> exception */ +static bool +jpl_do_pvm_init( + JNIEnv *env + ) + { + char *msg; + int argc; + char **argv; + int i; + jstring arg; + char *cp; + + /* redundant prerequisites check: */ + if ( jpl_status != JPL_INIT_PVM_MAYBE ) + { + msg = "jpl_do_pvm_init(): called while jpl_status != JPL_INIT_PVM_MAYBE"; + goto err; + } + + /* copy current default init args into suitable form for PL_initialise(): */ + if ( pvm_dia == NULL ) + { + msg = "jpl_do_pvm_init(): pvm_dia == NULL"; + goto err; + } + argc = (*env)->GetArrayLength(env,pvm_dia); + if ( argc <= 0 ) + { + msg = "jpl_do_pvm_init(): there are fewer than 1 default init args"; + goto err; + } + if ( (argv=(char**)malloc((argc+1)*sizeof(char*))) == NULL ) + { + msg = "jpl_do_pvm_init(): malloc() failed for argv"; + goto err; + } + for ( i=0 ; iGetObjectArrayElement(env,pvm_dia,i); + cp = (char*)(*env)->GetStringUTFChars(env,arg,0); + argv[i] = (char*)malloc(strlen(cp)+1); + strcpy( argv[i], cp); + DEBUG(1, Sdprintf( " argv[%d] = %s\n", i, argv[i])); + (*env)->ReleaseStringUTFChars( env, arg, cp); + } + DEBUG(1, Sdprintf( " argv[%d] = NULL\n", argc)); + argv[argc] = NULL; + if ( !PL_initialise(argc,(char**)argv) ) /* NB not (const char**) */ + { + msg = "jpl_do_pvm_init(): PL_initialise() failed"; + goto err; + } + /* *don't* free argv (must exist for lifetime of Prolog VM) */ + + return jpl_post_pvm_init(env,argc,argv); /* TRUE, FALSE or exception */ + +err: + jpl_status = JPL_INIT_PVM_FAILED; + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +static bool + jpl_ensure_jpl_init_1( + JNIEnv *env + ) + { + bool r; + + pthread_mutex_lock( &jvm_init_mutex); + r = jpl_do_jpl_init(env); + pthread_mutex_unlock( &jvm_init_mutex); + return r; + } + + +static bool + jpl_ensure_pvm_init_1( + JNIEnv *env + ) + { + bool r; + + pthread_mutex_lock( &pvm_init_mutex); + if ( !jpl_ensure_jpl_init(env) ) + return FALSE; + r = jpl_test_pvm_init(env) || jpl_do_pvm_init(env); + pthread_mutex_unlock( &pvm_init_mutex); + return r; + } + + +/*=== initialisation-related native Java methods of jpl.fli.Prolog ================================= */ + +/* + * Class: jpl_fli_Prolog + * Method: get_default_init_args + * Signature: ()[Ljava/lang/String; + */ +/* if not yet init then return default init args as String[] */ +/* if already init then return NULL */ +/* if already failed to init then throw an exception */ +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1default_1init_1args( + JNIEnv *env, + jclass jProlog + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init(env) ) /* lazily do "local" initialisations iff necessary */ + return FALSE; + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.set_default_init_args(): initialisation has already failed"; + goto err; + } + + return ( jpl_test_pvm_init(env) /* if Prolog VM is initialised */ + ? NULL /* then default init args are no longer defined */ + : pvm_dia /* else here they are */ + ) + ; +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: set_default_init_args + * Signature: ([Ljava/lang/String;)Z + */ +/* if the given jargs are null then throw an exception */ +/* if already failed to init then throw an exception */ +/* if not yet init then set default init args from jargs and return TRUE */ +/* if already init then return FALSE */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_set_1default_1init_1args( + JNIEnv *env, + jclass jProlog, + jobject jargs /* oughta be proper array, perhaps zero-length */ + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init(env) ) /* lazily do "local" initialisations iff necessary */ + return FALSE; + + if ( jargs == NULL ) /* improper call */ + { + msg = "jpl.fli.Prolog.set_default_init_args() called with NULL arg"; + goto err; + } + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.set_default_init_args(): initialisation has already failed"; + goto err; + } + + if ( jpl_test_pvm_init(env) ) /* if Prolog VM is initialised */ + { + return FALSE; /* unable to set default init args (too late: PVM is already initialised) */ + } + else + { + pvm_dia = NULL; /* probably oughta delete (global) (?) ref of former args... */ + pvm_dia = (*env)->NewGlobalRef(env,jargs); + return TRUE; /* OK: default init args set to those provided */ + } + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_actual_init_args + * Signature: ()[Ljava/lang/String; + */ +/* if not yet init then return null */ +/* if already init then return actual init args as String[] */ +/* if already failed to init then throw an exception */ +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1actual_1init_1args( + JNIEnv *env, + jclass jProlog + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init( env) ) /* lazily do "local" initialisations iff necessary */ + return NULL; + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.get_actual_init_args(): initialisation has already failed"; + goto err; + } + + return ( jpl_test_pvm_init(env) /* check PL_initialise() and update local state as appropriate */ + ? pvm_aia /* here they are */ + : NULL /* PVM not (yet) initialised */ + ); + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return NULL; + } + + +/* + * Class: jpl_fli_Prolog + * Method: initialise + * Signature: ()Z + */ +/* if already init then return FALSE */ +/* if already failed to init then throw an exception */ +/* else attempt to init and if success then return TRUE else throw an exception */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_initialise( + JNIEnv *env, + jclass jProlog + ) + { + char *msg; + + if ( !jpl_ensure_jpl_init( env) ) /* lazily do "local" initialisations iff necessary */ + return FALSE; + + if ( jpl_status==JPL_INIT_JPL_FAILED || jpl_status==JPL_INIT_PVM_FAILED ) + { + msg = "jpl.fli.Prolog.initialise(): initialisation has already failed"; + goto err; + } + + if ( jpl_test_pvm_init(env) ) + { + return FALSE; /* PVM is already initialised */ + } + else + { + jpl_do_pvm_init( env); + return jpl_test_pvm_init(env); + } + +err: + (*env)->ThrowNew( env, jJPLException_c, msg); + return FALSE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: halt + * Signature: (I)V + */ +JNIEXPORT void JNICALL +Java_jpl_fli_Prolog_halt( + JNIEnv *env, + jclass jProlog, + jint jstatus + ) + { + + (void)jpl_ensure_pvm_init(env); + PL_halt( (int)jstatus); + } + + +/*=== JPL utility functions ======================================================================== */ + +/*----------------------------------------------------------------------- + * getLongValue + * + * Retrieves the value in a jpl.fli.LongHolder (or subclass) instance + * + * @param env Java environment + * @param jlong_holder the LongHolder class instance, or null + * @param lv address to write the retrieved (long) value + * @return success? (the LongHolder was not null) + *---------------------------------------------------------------------*/ +static bool +getLongValue( + JNIEnv *env, + jobject jlong_holder, + jlong *lv + ) + { + + if ( jlong_holder == NULL ) + { + *lv = 0L; + return FALSE; + } + else /* Java compilation ensures it's a jpl.fli.LongHolder instance */ + { + *lv = (*env)->GetLongField(env,jlong_holder,jLongHolderValue_f); + return TRUE; + } + } + + +static bool +getUIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + uintptr_t *iv + ) + { jlong lv; /* Java long is 64 bits */ + + *iv = 0; + if ( getLongValue(env, jlong_holder, &lv) ) + { +#if SIZEOF_VOIDP == 4 + if ( lv >= 0xffffffffLL ) + return FALSE; /* What to do? */ +#endif + *iv = (uintptr_t)lv; + return TRUE; + } + else + { + return FALSE; + } + } + + +static bool +getIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + intptr_t *iv + ) + { jlong lv; /* Java long is 64 bits */ + + *iv = 0; + if ( getLongValue(env, jlong_holder, &lv) ) + { +#if SIZEOF_VOIDP == 4 + if ( lv >= 0xffffffffLL ) + return FALSE; /* What to do? */ +#endif + *iv = (uintptr_t)lv; + return TRUE; + } + else + { + return FALSE; + } + } + +static inline bool +getAtomTValue( + JNIEnv *env, + jobject jlong_holder, + atom_t *iv + ) { + return getUIntPtrValue( env, jlong_holder, iv); +} + + +static inline bool +getFunctorTValue( + JNIEnv *env, + jobject jlong_holder, + functor_t *iv + ) { + return getUIntPtrValue( env, jlong_holder, iv); +} + + +static inline bool +getTermTValue( + JNIEnv *env, + jobject jlong_holder, + term_t *iv + ) { +#if __YAP_PROLOG__ + return getIntPtrValue( env, jlong_holder, iv); +#else + return getUIntPtrValue( env, jlong_holder, iv); +#endif +} + + +/*----------------------------------------------------------------------- + * getPointerValue + * + * Retrieves the value in a jpl.fli.PointerHolder instance + * + * @param env Java environment + * @param jpointer_holder the PointerHolder class instance, or null + * @param pv address to write the retrieved (pointer) value + * @return success? (the PointerHolder was not null) + *---------------------------------------------------------------------*/ +static bool +getPointerValue( /* sets pv to jpointer_holder's .value_ (and succeeds), else sets it to NULL (and fails) */ + JNIEnv *env, + jobject jpointer_holder, + pointer *pv + ) + { + + if ( jpointer_holder == NULL ) + { + *pv = (pointer)NULL; + return FALSE; + } + else /* Java compilation ensures it's a jpl.fli.PointerHolder instance */ + { + *pv = (pointer)(*env)->GetLongField(env,jpointer_holder,jPointerHolderValue_f); + return TRUE; + } + } + + +/*----------------------------------------------------------------------- + * setPointerValue + * + * Sets the value in a jpl.fli.Pointer class instance (unless it's null) + * to the supplied value (maybe 0L) + * + * @param env Java environment + * @param jpointer_holder the PointerHolder class instance, or null + * @param pv the new (pointer) value + *---------------------------------------------------------------------*/ +static bool +setPointerValue( + JNIEnv *env, + jobject jpointer_holder, + pointer pv + ) + { + + return jpointer_holder != NULL + && ( (*env)->SetLongField(env,jpointer_holder,jPointerHolderValue_f,(long)pv), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * setIntValue + * + * Sets the value in a Java IntHolder class instance (unless it's null) + * to the supplied value + * + * @param env Java environment + * @param jint_holder the IntHolder class instance, or null + * @param iv the new (int) value + *---------------------------------------------------------------------*/ +static bool +setIntValue( + JNIEnv *env, + jobject jint_holder, + jint iv + ) + { + + return jint_holder != NULL + && ( (*env)->SetIntField(env,jint_holder,jIntHolderValue_f,iv), + TRUE + ) + ; + } + + +#if 0 +/*----------------------------------------------------------------------- + * setInt64Value + * + * Sets the value in a Java Int64Holder class instance (unless it's null) + * to the supplied value + * + * @param env Java environment + * @param jint64_holder the Int64Holder class instance, or null + * @param iv the new (int64_t) value + *---------------------------------------------------------------------*/ +static bool + setInt64Value( + JNIEnv *env, + jobject jint64_holder, + int64_t i64v + ) + { + + return jint64_holder != NULL + && ( (*env)->SetLongField(env,jint64_holder,jInt64HolderValue_f,i64v), + TRUE + ) + ; + } +#endif + + +/*----------------------------------------------------------------------- + * setLongValue + * + * Sets the value in a Java LongHolder class instance (unless it's null) + * to the supplied Java long value + * + * @param env Java environment + * @param jlong_holder the LongHolder class instance, or null + * @param lv the new (Java long) value + *---------------------------------------------------------------------*/ +static bool +setLongValue( + JNIEnv *env, + jobject jlong_holder, + jlong lv + ) + { + + return jlong_holder != NULL + && ( (*env)->SetLongField(env,jlong_holder,jLongHolderValue_f,lv), + TRUE + ) + ; + } + + +static bool +setUIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + uintptr_t iv + ) + { jlong lv; + +#if SIZEOF_VOIDP == 4 + uint64_t i64 = iv; /* unsigned 32->64 */ + lv = (jlong)i64; +#else + lv = iv; +#endif + + return setLongValue(env, jlong_holder, lv); + } + +static bool +setIntPtrValue( + JNIEnv *env, + jobject jlong_holder, + intptr_t iv + ) + { jlong lv; + +#if SIZEOF_VOIDP == 4 + int64_t i64 = iv; /* signed 32->64 */ + lv = (jlong)i64; +#else + lv = iv; +#endif + + return setLongValue(env, jlong_holder, lv); + } + + +static inline bool +setTermTValue( + JNIEnv *env, + jobject jlong_holder, + term_t iv + ) { +#if __YAP_PROLOG__ + return setIntPtrValue( env, jlong_holder, iv); +#else + return setUIntPtrValue( env, jlong_holder, iv); +#endif +} + +/*----------------------------------------------------------------------- + * setDoubleValue + * + * Sets the value in a Java DoubleHolder class instance (unless it's null) + * to the supplied value + * + * @param env Java environment + * @param jdouble_holder the DoubleHolder class instance, or null + * @param dv the new (double) value + *---------------------------------------------------------------------*/ +static bool +setDoubleValue( + JNIEnv *env, + jobject jdouble_holder, + jdouble dv + ) + { + + return jdouble_holder != NULL + && ( (*env)->SetDoubleField(env,jdouble_holder,jDoubleHolderValue_f,dv), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * setStringValue + * + * Sets the value in a Java StringHolder class instance (unless it's null) + * to the supplied value (maybe null) + * + * @param env Java environment + * @param jstring_holder the StringHolder class instance, or null + * @param sv the new (jstring) value + *---------------------------------------------------------------------*/ +static bool +setStringValue( + JNIEnv *env, + jobject jstring_holder, + jstring sv + ) + { + + return jstring_holder != NULL + && ( (*env)->SetObjectField(env,jstring_holder,jStringHolderValue_f,sv), + TRUE + ) + ; + } + + +#if 0 +/*----------------------------------------------------------------------- + * setObjectValue + * + * Sets the value in a Java ObjectHolder class instance (unless it's null) + * to the supplied value (maybe null) + * + * @param env Java environment + * @param jobject_holder the ObjectHolder class instance, or null + * @param ref the new (jobject) value + *---------------------------------------------------------------------*/ +static bool +setObjectValue( + JNIEnv *env, + jobject jobject_holder, + jobject ref + ) + { + + return jobject_holder != NULL + && ( (*env)->SetObjectField(env,jobject_holder,jObjectHolderValue_f,ref), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * setBooleanValue + * + * Sets the .value field of a Java BooleanHolder class instance (unless it's null) + * to the supplied jboolean value + * + * @param env Java environment + * @param jboolean_holder the BooleanHolder class instance, or null + * @param jb the new (jboolean) value + *---------------------------------------------------------------------*/ +static bool +setBooleanValue( + JNIEnv *env, + jobject jboolean_holder, + jboolean jb + ) + { + + return jboolean_holder != NULL + && ( (*env)->SetBooleanField(env,jboolean_holder,jBooleanHolderValue_f,jb), + TRUE + ) + ; + } + + +/*----------------------------------------------------------------------- + * updateAtomValue + * + * Updates the value in a Java atom_t class instance (unless it's null) + * to the supplied value (maybe 0L); unregisters and registers old and new + * atom references as appropriate. NB atom_t extends LongHolder. + * + * @param env Java environment + * @param jatom_holder the atom_t class instance, or null + * @param atom2 the new atom reference + *---------------------------------------------------------------------*/ +static bool +updateAtomValue( + JNIEnv *env, + jobject jatom_holder, + atom_t atom2 /* new value (perhaps 0L (?)) */ + ) + { + atom_t atom1; /* old value (perhaps 0L (?)) */ + + if ( jatom_holder == NULL ) + { + return FALSE; + } + else + { + atom1 = (atom_t)(*env)->GetLongField(env,jatom_holder,jLongHolderValue_f); + if ( atom1 != 0L ) + { + PL_unregister_atom( atom1); + } + (*env)->SetLongField(env,jatom_holder,jLongHolderValue_f,(long)atom2); + if ( atom2 != 0L ) + { + PL_register_atom( atom2); + } + return TRUE; + } + } +#endif + +/*=== Java-wrapped SWI-Prolog FLI functions ======================================================== */ + +static int current_pool_engine_handle(PL_engine_t *e); +static int current_pool_engine(void); + + +/* + * Class: jpl_fli_Prolog + * Method: action_abort + * Signature: ()I + */ +JNIEXPORT int JNICALL + Java_jpl_fli_Prolog_action_1abort( + JNIEnv *env, + jclass jProlog + ) + { + + if ( jpl_ensure_pvm_init(env) ) + { + return PL_action(PL_ACTION_ABORT); + } + else + { + return -2; /* oughta throw exception? */ + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: atom_chars + * Signature: (Ljpl/fli/atom_t;)Ljava/lang/String; + */ +JNIEXPORT jstring JNICALL /* the local ref goes out of scope, */ + Java_jpl_fli_Prolog_atom_1chars( /* but the string itself doesn't */ + JNIEnv *env, + jclass jProlog, + jobject jatom + ) + { + atom_t atom; + jstring lref; + + return ( jpl_ensure_pvm_init(env) + && getAtomTValue(env,jatom,&atom) /* checks jatom != null */ + && jni_atom_to_String(env,atom,&lref) + ? lref + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: attach_engine + * Signature: (Ljpl/fli/engine_t;)I + */ +JNIEXPORT int JNICALL + Java_jpl_fli_Prolog_attach_1engine( + JNIEnv *env, + jclass jProlog, + jobject jengine + ) + { + PL_engine_t engine; + int rc; + + if ( !jpl_ensure_pvm_init(env) ) + { + return -2; /* libpl could not be initialised (oughta throw exception) */ + } + + rc = current_pool_engine_handle(&engine); + DEBUG(0, Sdprintf( "attach_engine(): current_engine=%p, thread_self=%d, pool_id=%d\n", engine, PL_thread_self(), rc)); + + if ( !getPointerValue(env,jengine,(pointer*)&engine) ) /* checks jengine isn't null */ + { + return -3; /* null engine holder */ + } + + DEBUG(0, Sdprintf( "attach_engine(): new_engine=%p\n", engine)); + + if ( (rc=PL_set_engine(engine,NULL)) == PL_ENGINE_SET ) + { + return 0; /* OK */ + } + else + { + return -1; /* bad engine status: oughta throw exception */ + } + + } + + +/* + * Class: jpl_fli_Prolog + * Method: close_query + * Signature: (Ljpl/fli/qid_t;)V + */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_close_1query( + JNIEnv *env, + jclass jProlog, + jobject jqid + ) + { + qid_t qid; + + DEBUG(1, Sdprintf( ">close_query(env=%lu,jProlog=%lu,jquid=%u)...\n", (long)env, (long)jProlog, (long)jqid)); + if ( jpl_ensure_pvm_init(env) + && getUIntPtrValue(env,jqid,(uintptr_t *)&qid) /* checks that jqid != NULL */ + ) + { + PL_close_query( qid); /* void */ + DEBUG(1, Sdprintf( " ok: PL_close_query(%lu)\n", (long)qid)); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: compare + * Signature: (Ljpl/fli/term_t;Ljpl/fli/term_t;)I + */ +JNIEXPORT jint JNICALL /* returns -1, 0 or 1 (or -2 for error) */ + Java_jpl_fli_Prolog_compare( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ) + { + term_t term1; + term_t term2; + + DEBUG(1, Sdprintf( ">compare(term1=%lu,term2=%lu)\n", (long)jterm1, (long)jterm2)); + if ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm1,&term1) /* checks jterm1 isn't null */ + && getTermTValue(env,jterm2,&term2) /* checks jterm2 isn't null */ + ) + { + DEBUG(1, Sdprintf( "> PL_compare( %u, %u)", term1, term2)); + return PL_compare(term1,term2); /* returns -1, 0 or 1 */ + } + else + { + return -2; /* oughta throw an exception... */ + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: cons_functor_v + * Signature: (Ljpl/fli/term_t;Ljpl/fli/functor_t;Ljpl/fli/term_t;)V + */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_cons_1functor_1v( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jfunctor, + jobject jterm0 + ) + { + term_t term; + functor_t functor; + term_t term0; + + if ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm,&term) /* checks that jterm isn't null */ + && getFunctorTValue(env,jfunctor,&functor) /* checks that jfunctor isn't null */ + && getTermTValue(env,jterm0,&term0) /* checks that jterm0 isn't null */ + ) + { + return PL_cons_functor_v( term, functor, term0); + } + return TRUE; + } + + +/* + * Class: jpl_fli_Prolog + * Method: copy_term_ref + * Signature: (Ljpl/fli/term_t;)Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_copy_1term_1ref( + JNIEnv *env, + jclass jProlog, + jobject jfrom + ) + { + jobject rval; + term_t term; + term_t term2; + + return ( jpl_ensure_pvm_init(env) + /* && jfrom != NULL // redundant: getLongValue checks this */ + && getTermTValue(env,jfrom,&term) /* SWI RM implies must be non-null */ + && (rval=(*env)->AllocObject(env,jTermT_c)) != NULL + && ( (term2=PL_copy_term_ref(term)) , TRUE ) /* SWI RM -> always succeeds */ + && setTermTValue(env,rval,term2) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: current_engine + * Signature: ()Ljpl/fli/engine_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_current_1engine( + JNIEnv *env, + jclass jProlog + ) + { + PL_engine_t engine; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && PL_thread_self() != -1 + && ( current_pool_engine_handle(&engine) , TRUE ) + && (rval=(*env)->AllocObject(env,jEngineT_c)) != NULL + && setPointerValue(env,rval,(pointer)engine) + ? rval + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: current_engine_is_pool + * Signature: ()Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_current_1engine_1is_1pool( + JNIEnv *env, + jclass jProlog + ) + { + + if ( jpl_ensure_pvm_init(env) ) + { + return current_pool_engine() >= 0; + } + else + { + return FALSE; /* libpl could not be initialised: oughta throw exception */ + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: exception + * Signature: (Ljpl/fli/qid_t;)Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_exception( + JNIEnv *env, + jclass jProlog, + jobject jqid + ) + { + qid_t qid; + term_t term; + jobject term_t; /* return value */ + + DEBUG(1, Sdprintf( ">exception(jqid=%lu)\n", (long)jqid)); + return ( jpl_ensure_pvm_init(env) + && ( DEBUG(1, Sdprintf( " ok: jpl_ensure_pvm_init(env)\n")), TRUE ) + /* && jqid != NULL // redundant */ + && ( DEBUG(1, Sdprintf( " ok: jqid != NULL\n")), TRUE ) + && getUIntPtrValue(env,jqid,(uintptr_t *)&qid) /* checks that jqid isn't null */ + && ( DEBUG(1, Sdprintf( " ok: getUIntPtrValue(env,jqid,&qid)\n")), TRUE ) + && ( (term=PL_exception(qid)) , TRUE ) /* we'll build a term_t object regardless */ + && ( DEBUG(1, Sdprintf(" ok: ( (term=PL_exception(qid)), TRUE)\n")), TRUE ) + && (term_t=(*env)->AllocObject(env,jTermT_c)) != NULL + && ( DEBUG(1, Sdprintf( " ok: (term_t=(*env)->AllocObject(env,jTermT_c)) != NULL\n")), TRUE ) + && setTermTValue(env,term_t,term) + && ( DEBUG(1, Sdprintf( " ok: setTermTValue(env,term_t,term)\n")), TRUE ) + ? ( + DEBUG(1, Sdprintf(" =%lu\n",(long)term_t)), + term_t + ) + : NULL /* oughta diagnose failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_arg + * Signature: (ILjpl/fli/term_t;Ljpl/fli/term_t;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1arg( + JNIEnv *env, + jclass jProlog, + jint jindex, + jobject jterm, + jobject jarg + ) + { + term_t term; + term_t arg; + + return jpl_ensure_pvm_init(env) + && jarg != NULL /* don't proceed if this holder is null */ + && getTermTValue(env,jterm,&term) /* checks that jterm isn't null */ + && ( arg=PL_new_term_ref() , TRUE ) /* Fred used jarg's original term ref (?) */ + && PL_get_arg(jindex,term,arg) + && setUIntPtrValue(env,jarg,arg) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_atom_chars + * Signature: (Ljpl/fli/term_t;Ljpl/fli/StringHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1atom_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ) + { + term_t term; + atom_t a; + jstring string; + + return jpl_ensure_pvm_init(env) + && jstring_holder != NULL /* don't call PL_get_atom_chars if this is null */ + && getTermTValue(env,jterm,&term) /* confirms that jterm != NULL */ + && PL_get_atom(term,&a) /* confirms that term is an atom */ + && jni_atom_to_String(env,a,&string) /* Unicode-aware */ + && setStringValue(env,jstring_holder,string) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_c_lib_version + * Signature: ()Ljava/lang/String; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_get_1c_1lib_1version( + JNIEnv *env, + jclass jProlog + ) + { + + return (*env)->NewStringUTF(env,JPL_C_LIB_VERSION); /* JPL_C_LIB_VERSION is always Latin-1 */ + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_float + * Signature: (Ljpl/fli/term_t;Ljpl/fli/DoubleHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1float( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jdouble_holder + ) + { + term_t term; + double d; + + return jpl_ensure_pvm_init(env) + && jdouble_holder != NULL + && getTermTValue(env,jterm,&term) /* confirms that jterm isn't null */ + && PL_get_float(term,&d) + && setDoubleValue(env,jdouble_holder,d) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_integer + * Signature: (Ljpl/fli/term_t;Ljpl/fli/Int64Holder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1integer( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jint64_holder + ) + { + term_t term; + int64_t i64; + + return jpl_ensure_pvm_init(env) + && jint64_holder != NULL + && getTermTValue(env,jterm,&term) /* confirms that jterm isn't null */ + && PL_get_int64(term,&i64) + && setLongValue(env,jint64_holder,i64) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_name_arity + * Signature: (Ljpl/fli/term_t;Ljpl/fli/StringHolder;Ljpl/fli/IntHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1name_1arity( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jname_holder, /* we trust this is a StringHolder */ + jobject jarity_holder /* we trust this is an IntHolder */ + ) + { + term_t term; + atom_t atom; + jstring jname; + int arity; + + return jpl_ensure_pvm_init(env) + && jname_holder != NULL /* don't proceed if this holder is null */ + && jarity_holder != NULL /* don't proceed if this holder is null */ + && getTermTValue(env,jterm,&term) /* confirms that jterm isn't null */ + && PL_get_name_arity(term,&atom,&arity) /* proceed to register transient atom ref */ + && jni_atom_to_String(env,atom,&jname) /* Unicode-aware */ + && setStringValue(env,jname_holder,jname) /* stash String ref in holder */ + && setIntValue(env,jarity_holder,arity) /* stash arity value in holder */ + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: get_string_chars + * Signature: (Ljpl/fli/term_t;Ljpl/fli/StringHolder;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1string_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ) + { + term_t term; + jstring string; + + return jpl_ensure_pvm_init(env) + && jstring_holder != NULL + && getTermTValue(env,jterm,&term) /* checks that jterm != NULL */ + && jni_string_to_String(env,term,&string) /* */ + && setStringValue(env,jstring_holder,string) /* ...when sent straight back to JVM */ + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_atom + * Signature: (Ljava/lang/String;)Ljpl/fli/atom_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1atom( + JNIEnv *env, + jclass jProlog, + jstring jname + ) + { + atom_t atom; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && jname != NULL + && jni_String_to_atom(env,jname,&atom) + && (rval=(*env)->AllocObject(env,jAtomT_c)) != NULL /* doesn't call any constructor */ + && setUIntPtrValue(env,rval,atom) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_functor + * Signature: (Ljpl/fli/atom_t;I)Ljpl/fli/functor_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1functor( + JNIEnv *env, + jclass jProlog, + jobject jatom, /* read-only */ + jint jarity + ) + { + term_t atom; + functor_t functor; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && jarity >= 0 + && getTermTValue(env,jatom,&atom) /* checks jatom isn't null */ + && (rval=(*env)->AllocObject(env,jFunctorT_c)) != NULL + && (functor=PL_new_functor(atom,(int)jarity)) != 0L + && setUIntPtrValue(env,rval,functor) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_module + * Signature: (Ljpl/fli/atom_t;)Ljpl/fli/module_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1module( + JNIEnv *env, + jclass jProlog, + jobject jatom + ) + { + atom_t atom; + module_t module; + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && getAtomTValue(env,jatom,&atom) /* checks that jatom isn't null */ + && ( (module=PL_new_module(atom)) , TRUE ) + && (rval=(*env)->AllocObject(env,jModuleT_c)) != NULL + && setPointerValue(env,rval,(pointer)module) + ? rval + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_term_ref + * Signature: ()Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1ref( + JNIEnv *env, + jclass jProlog + ) + { + jobject rval; + + return ( jpl_ensure_pvm_init(env) + && (rval=(*env)->AllocObject(env,jTermT_c)) != NULL + && setUIntPtrValue(env,rval,PL_new_term_ref()) + ? rval + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: new_term_refs + * Signature: (I)Ljpl/fli/term_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1refs( + JNIEnv *env, + jclass jProlog, + jint jn + ) + { + jobject rval; + term_t trefs; + + DEBUG(1, Sdprintf( ">new_term_refs(env=%lu,jProlog=%lu,jn=%lu)...\n", (long)env, (long)jProlog, (long)jn)); + + return ( jpl_ensure_pvm_init(env) + && jn >= 0 /* I hope PL_new_term_refs(0) is defined [ISSUE] */ + && (rval=(*env)->AllocObject(env,jTermT_c)) != NULL + && ( trefs=PL_new_term_refs((int)jn), TRUE ) + && setUIntPtrValue(env,rval,trefs) + && ( DEBUG(1, Sdprintf(" ok: stashed trefs=%ld into new term_t object\n",(long)trefs)), TRUE ) + ? rval + : NULL + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: next_solution + * Signature: (Ljpl/fli/qid_t;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_next_1solution( + JNIEnv *env, + jclass jProlog, + jobject jqid /* read */ + ) + { + qid_t qid; + int rval; /* for boolean return value */ + + DEBUG(1, Sdprintf( ">next_solution(env=%lu,jProlog=%lu,jqid=%lu)...\n", (long)env, (long)jProlog, (long)jqid)); + return jpl_ensure_pvm_init(env) + && getUIntPtrValue(env,jqid,(uintptr_t *)&qid) /* checks that jqid isn't null */ + && ( DEBUG(1, Sdprintf( " ok: getUIntPtrValue(env,jqid,&qid(%lu))\n",(long)qid)), TRUE ) + && ( rval=PL_next_solution(qid), TRUE ) /* can call this until it returns FALSE */ + && ( DEBUG(1, Sdprintf( " ok: PL_next_solution(qid=%lu)=%u\n",(long)qid,rval)), TRUE ) + && ( + DEBUG(1, Sdprintf(" =%lu\n",(long)rval)), + rval + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: object_to_tag + * Signature: (Ljava/lang/Object;)Ljava/lang/String; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_object_1to_1tag( + JNIEnv *env, + jclass jProlog, + jobject jobj + ) + { + intptr_t iref; + char abuf[23]; + + /* empirically, unless the two 'ensure' macros are called in this order, */ + /* will crash if this is the first native method called */ + + /* Sdprintf("entered object_to_tag...\n"); */ + + if ( !jpl_ensure_pvm_init(env) ) { + /* Sdprintf("jpl_ensure_pvm_init() failed\n"); */ + return NULL; + } + /* Sdprintf("jpl_ensure_pvm_init() ok\n"); */ + + if ( !jni_ensure_jvm() ) { + /* Sdprintf("jni_ensure_jvm() failed\n"); */ + return NULL; + } + /* Sdprintf("jni_ensure_jvm() ok\n"); */ + + if ( jobj!=NULL && jni_object_to_iref(env,jobj,&iref) ) { + /* Sdprintf("jni_object_to_iref() done\n"); */ + sprintf( abuf, IREF_FMT, (IREF_INTTYPE)iref); /* oughta encapsulate this mapping... */ + /* Sdprintf("sprintf() done\n"); */ + return (*env)->NewStringUTF(env,abuf); /* a tag is always Latin-1 */ + } else { + return NULL; + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: open_query + * Signature: (Ljpl/fli/module_t;ILjpl/fli/predicate_t;Ljpl/fli/term_t;)Ljpl/fli/qid_t; + */ +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_open_1query( + JNIEnv *env, + jclass jProlog, + jobject jmodule, /* read */ + jint jflags, /* read */ + jobject jpredicate, /* read */ + jobject jterm0 /* read */ + ) + { + module_t module; + predicate_t predicate; + term_t term0; + qid_t qid; + jobject jqid; /* for returned new QidT object */ + + DEBUG(1, Sdprintf( ">open_query(env=%lu,jProlog=%lu,jmodule=%lu,jflags=%lu,jpredicate=%lu,jterm0=%lu)...\n", + (long)env, (long)jProlog, (long)jmodule, (long)jflags, (long)jpredicate, (long)jterm0)); + return ( jpl_ensure_pvm_init(env) + && ( getPointerValue(env,jmodule,(pointer*)&module) , TRUE ) /* NULL module is OK below... */ + && ( DEBUG(1, Sdprintf(" ok: getPointerValue(env,jmodule=%lu,&(pointer)module=%lu)\n",(long)jmodule,(long)module)), TRUE ) + && getPointerValue(env,jpredicate,(pointer*)&predicate) /* checks that jpredicate != NULL */ + && ( DEBUG(1, Sdprintf(" ok: getPointerValue(env,jpredicate=%lu,&(pointer)predicate=%lu)\n",(long)jpredicate,(long)predicate)), TRUE ) + && getTermTValue(env,jterm0,&term0) /* jterm0!=NULL */ + && ( (qid=PL_open_query(module,jflags,predicate,term0)) , TRUE ) /* NULL module is OK (?) [ISSUE] */ + && ( DEBUG(1, Sdprintf(" ok: PL_open_query(module=%lu,jflags=%u,predicate=%lu,term0=%lu)=%lu\n",(long)module,jflags,(long)predicate,(long)term0,(long)qid)), TRUE ) + && (jqid=(*env)->AllocObject(env,jQidT_c)) != NULL + && ( DEBUG(1, Sdprintf(" ok: AllocObject(env,jQidT_c)=%lu\n",(long)jqid)), TRUE ) + && setUIntPtrValue(env,jqid,(uintptr_t)qid) + && ( DEBUG(1, Sdprintf(" ok: setUIntPtrValue(env,%lu,%lu)\n",(long)jqid,(long)qid)), TRUE ) + && ( DEBUG(1, Sdprintf("[open_query module = %s]\n", (module==NULL?"(null)":PL_atom_chars(PL_module_name(module))))), TRUE ) + ? ( + DEBUG(1, Sdprintf(" =%lu\n",(long)jqid)), + jqid + ) + : NULL /* oughta diagnose failure? raise JPL exception? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: predicate + * Signature: (Ljava/lang/String;ILjava/lang/String;)Ljpl/fli/predicate_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_predicate( + JNIEnv *env, + jclass jProlog, + jstring jname, /* ought not be null */ + jint jarity, /* oughta be >= 0 */ + jstring jmodule /* may be null */ + ) + { + atom_t pname; /* the predicate's name, as an atom */ + atom_t mname; /* the predicate's module's name, as an atom */ + functor_t func; /* the predicate's functor */ + module_t mod; /* the predicate's module */ + predicate_t predicate; + jobject rval; + + DEBUG(1, Sdprintf(">predicate(env=%lu,jProlog=%lu,jname=%lu,jarity=%lu,jmodule=%lu)...\n", + (long)env, (long)jProlog, (long)jname, (long)jarity, (long)jmodule)); + return ( jpl_ensure_pvm_init(env) + && jni_String_to_atom(env,jname,&pname) /* checks that jname isn't NULL */ + && jarity >= 0 + && ( func=PL_new_functor(pname,jarity) , TRUE ) /* "cannot fail" */ + && ( jmodule != NULL + ? jni_String_to_atom(env,jmodule,&mname) /* checks that jmodule isn't NULL */ + : ( mname=(atom_t)NULL , TRUE ) + ) + && ( mod=PL_new_module(mname) , TRUE) + && ( predicate=PL_pred(func,mod) , TRUE ) + && (rval=(*env)->AllocObject(env,jPredicateT_c)) != NULL + && setPointerValue(env,rval,(pointer)predicate) + ? ( + DEBUG(1, Sdprintf("[predicate() module=%s\n",(jmodule==NULL?"(null)":PL_atom_chars(mname)))), + rval + ) + : NULL /* oughta warn of failure? */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: put_float + * Signature: (Ljpl/fli/term_t;D)V + */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1float(JNIEnv *env, + jclass jProlog, + jobject jterm, + jdouble jf) +{ term_t term; + + if ( jpl_ensure_pvm_init(env) && + getTermTValue(env,jterm,&term) ) + { return PL_put_float(term, jf); + } + + return FALSE; +} + + +/* + * Class: jpl_fli_Prolog + * Method: put_integer + * Signature: (Ljpl/fli/term_t;J)V + */ +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1integer(JNIEnv *env, + jclass jProlog, + jobject jterm, + jlong ji) +{ term_t term; + + if ( jpl_ensure_pvm_init(env) && + getTermTValue(env, jterm, &term) ) + { return PL_put_int64( term, ji); + } + + return FALSE; +} + + +/* + * Class: jpl_fli_Prolog + * Method: put_term + * Signature: (Ljpl/fli/term_t;Ljpl/fli/term_t;)V + */ +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1term( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ) + { + term_t term1; + term_t term2; + + if ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm1,&term1) /* checks that jterm1 isn't null */ + && getTermTValue(env,jterm2,&term2) /* checks that jterm2 isn't null */ + ) + { + PL_put_term( term1, term2); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: put_jref + * Signature: (Ljpl/fli/term_t;Ljava/lang/Object;)V + */ +/* added 29/1/2007 PS to support restored but now deprecated jpl.JRef for Rick Moynihan */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_put_1jref( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jref + ) + { + term_t term; + jobject j; // temp for JNI_jobject_to_term(+,-) + atom_t a; // " + intptr_t i; // " + + if ( jpl_ensure_pvm_init(env) + && jni_ensure_jvm() + && getTermTValue(env,jterm,&term) // checks that jterm isn't null + ) + { + JNI_jobject_to_term(jref,term); // assumes term is var; OK if jref == null + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: tag_to_object + * Signature: (Ljava/lang/String;)Ljava/lang/Object; + */ +/* added 29/5/2008 PS to support alternative to deprecated jpl.JRef */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_tag_1to_1object( + JNIEnv *env, + jclass jProlog, + jstring tag + ) + { + jobject jobj; + + if ( jni_ensure_jvm() + && (*env)->GetStringLength(env,tag) == 22 + ) + { + jni_tag_to_iref2((char*)(*env)->GetStringUTFChars(env,tag,0), (pointer *)&jobj); + return jobj; + } + return 0; + } + + +/* + * Class: jpl_fli_Prolog + * Method: is_tag + * Signature: (Ljava/lang/String;)Z + */ +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_is_1tag( + JNIEnv *env, + jclass jProlog, + jstring tag + ) + { + jobject jobj; + + if ( jni_ensure_jvm() + && (*env)->GetStringLength(env,tag) == 22 + ) + { + jni_tag_to_iref2((char*)(*env)->GetStringUTFChars(env,tag,0), (pointer *)&jobj); + return jobj != 0; + } + + return 0; + } + + +/* + * Class: jpl_fli_Prolog + * Method: put_variable + * Signature: (Ljpl/fli/term_t;)V + */ +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1variable( + JNIEnv *env, + jclass jProlog, + jobject jterm + ) + { + term_t term; + + if ( jpl_ensure_pvm_init(env) /* may throw exception but cannot fail */ + && getTermTValue(env,jterm,&term) /* checks that jterm isn't null */ + ) + { + PL_put_variable(term); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: term_type + * Signature: (Ljpl/fli/term_t;)I + */ +JNIEXPORT jint JNICALL + Java_jpl_fli_Prolog_term_1type( + JNIEnv *env, + jclass jProlog, + jobject jterm + ) + { + term_t term; + + return ( jpl_ensure_pvm_init(env) + && getTermTValue(env,jterm,&term) /* checks jterm isn't null */ + ? PL_term_type(term) + : -1 /* i.e. when jterm is null */ + ) + ; + } + + +/* + * Class: jpl_fli_Prolog + * Method: unregister_atom + * Signature: (Ljpl/fli/atom_t;)V + */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_unregister_1atom( + JNIEnv *env, + jclass jProlog, + jobject jatom + ) + { + atom_t atom; + + DEBUG(1, Sdprintf( ">unregister_atom(env=%lu,jProlog=%lu,jatom=%u)...\n", (long)env, (long)jProlog, (long)jatom)); + + if ( jpl_ensure_pvm_init(env) + && getAtomTValue(env,jatom,&atom) /* checks that jatom isn't null */ + ) + { + PL_unregister_atom( atom); /* void */ + DEBUG(1, Sdprintf( " ok: PL_unregister_atom(%lu)\n", (long)atom)); + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: open_foreign_frame + * Signature: ()Ljpl/fli/fid_t; + */ +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_open_1foreign_1frame( + JNIEnv *env, + jclass jProlog + ) + { + jobject rval; + + if ( jpl_ensure_pvm_init(env) + && (rval=(*env)->AllocObject(env,jFidT_c)) != NULL // get a new fid_t object + && setUIntPtrValue(env,rval,PL_open_foreign_frame()) // open a frame only if alloc succeeds + ) + { + return rval; + } + else + { + return NULL; + } + } + + +/* + * Class: jpl_fli_Prolog + * Method: discard_foreign_frame + * Signature: (Ljpl/fli/fid_t;)V + */ +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_discard_1foreign_1frame( + JNIEnv *env, + jclass jProlog, + jobject jfid + ) + { + fid_t fid; + + if ( jpl_ensure_pvm_init(env) + && getUIntPtrValue(env,jfid,&fid) // checks that jfid isn't null + ) + { + PL_discard_foreign_frame(fid); + } + } + + +/*=== JPL's Prolog engine pool and thread management =============================================== */ + +/* + * Class: jpl_fli_Prolog + * Method: thread_self + * Signature: ()I + */ +JNIEXPORT jint JNICALL +Java_jpl_fli_Prolog_thread_1self( + JNIEnv *env, + jclass jProlog + ) + { + + if ( jpl_ensure_pvm_init(env) ) + { + return PL_thread_self(); + } + else + { + return -2; + } + } + + +static int +create_pool_engines() + { + int i; + + DEBUG(1, Sdprintf( "JPL creating engine pool:\n")); + if ( (engines=malloc(sizeof(PL_engine_t)*JPL_MAX_POOL_ENGINES)) == NULL ) + { + return -1; /* malloc failed */ + } + engines_allocated = JPL_MAX_POOL_ENGINES; + memset(engines, 0, sizeof(PL_engine_t)*engines_allocated); + + DEBUG(1, Sdprintf( "JPL stashing default engine as [0]\n")); + PL_set_engine( PL_ENGINE_CURRENT, &engines[0]); + + DEBUG(1, Sdprintf( "JPL detaching default engine\n")); + /* PL_set_engine( NULL, NULL); */ + + for ( i=1 ; iAllocObject(env,jEngineT_c)) != NULL + && setPointerValue(env,rval,(pointer)engines[i]) + ? rval + : NULL + ); + } + if ( rc != PL_ENGINE_INUSE ) + { + DEBUG(1, Sdprintf( "JPL PL_set_engine fails with %d\n", rc)); + pthread_mutex_unlock( &engines_mutex); + return NULL; /* bad engine status: oughta throw exception */ + } + } + + for ( i=0 ; i 0 ) + { DEBUG(1, Sdprintf("JPL releasing engine[%d]=%p\n", i, e)); + PL_set_engine(NULL, NULL); + pthread_cond_signal(&engines_cond); /* alert waiters */ + } + return i; + } + else + { + return -2; + } + } + + +static foreign_t + jni_term_to_jref_plc( + term_t tref1, /* +term: AnyPrologTerm */ + term_t tref2 /* -term: JRef to a jpl.Term instance which represents that term */ + ) + { + jobject term1; + atom_t a; /* " */ + intptr_t i; /* " */ + jobject j; /* " */ + JNIEnv *env; + + return jni_ensure_jvm() /* untypically... */ + && jpl_ensure_pvm_init(env) /* ...this requires both inits */ + && (term1=(*env)->AllocObject(env,termt_class)) != NULL + && setUIntPtrValue(env,term1,tref1) /* requires jLongHolderValue_f to be initialised */ + && JNI_jobject_to_term((*env)->CallStaticObjectMethod(env,term_class,term_getTerm,term1),tref2) + && jni_check_exception(env); + } + + +/* serves jni_jref_to_term_plc() */ +static bool + jni_jobject_to_term_byval( + JNIEnv *env, + jobject jobj, /* this must be an instance of one of jpl.Term's subclasses */ + term_t term /* a Prolog term, as represented by jobj, is *put* into this term ref */ + ) + { + jobject termt; /* a temporary instance of jpl.fli.term_t (i.e. a "term holder") */ + + return /* jni_ensure_jvm() && jpl_ensure_pvm_init(env) && */ + (termt=(*env)->AllocObject(env,termt_class)) != NULL + && setUIntPtrValue(env,termt,term) /* requires jLongHolderValue_f to be initialised */ + && ( (*env)->CallStaticVoidMethod(env,term_class,term_putTerm,jobj,termt) , TRUE ) + && jni_check_exception(env) + ; + } + + +/* if the first arg is a jref i.e. @(Tag) which refers to a jpl.Term instance, */ +/* then the 2nd arg will be matched with a corresponding newly constructed term */ +static foreign_t + jni_jref_to_term_plc( + term_t jref, /* +term: JRef to a jpl.Term instance */ + term_t termIn /* -term: term as represented by the JRef */ + ) + { + functor_t fn; + term_t arg = PL_new_term_ref(); + atom_t a; + intptr_t iterm; + jobject jterm; + term_t term = PL_new_term_ref(); /* jni_jobject_to_term_byval() will *put* the constructed term in here */ + JNIEnv *env; + + return jni_ensure_jvm() /* untypically... */ + && jpl_ensure_pvm_init(env) /* ...this requires both inits */ + && PL_get_functor(jref,&fn) + && fn==JNI_functor_at_1 + && PL_get_arg(1,jref,arg) + && PL_get_atom(arg,&a) + && jni_tag_to_iref(a,&iterm) + && (jterm = (jobject)iterm) + && jni_jobject_to_term_byval(env,jterm,term) /* NB a bogus Tag could crash this... */ + && PL_unify( termIn, term) /* attempt to unify the 2nd arg with the newly constructed term */ + ; + } + + +static bool + jni_get_default_jvm_opts_1( + term_t args, + int i, + char **jvm_xia + ) + { + term_t tp = PL_new_term_ref(); + + if ( jvm_xia[i] == NULL ) + { + return PL_unify_nil(args); + } + else + { + return PL_unify_list(args,tp,args) + && PL_unify_term(tp, + PL_ATOM, PL_new_atom(jvm_xia[i]) + ) + && jni_get_default_jvm_opts_1(args,i+1,jvm_xia) + ; + } + } + + +static foreign_t + jni_get_jvm_opts( + term_t args, /* -list(atom): the current default JVM initialisation options */ + char **jvm_xia + ) + { + + if ( jvm_xia==NULL ) + { + return FALSE; + } + else + { + return jni_get_default_jvm_opts_1(args,0,jvm_xia); + } + } + + +static foreign_t + jni_set_default_jvm_opts_plc( + term_t tn, /* +integer: the qty of options */ + term_t args /* +list(atom): the current default JVM initialisation options */ + ) + { + int n; + int i; + term_t head; + term_t list; + char *s; + + if ( jvm_dia == NULL ) /* presumably, JVM is already started, so default options cannot now be set */ + { + return FALSE; + } + if ( !PL_get_integer(tn,&n) ) /* arg is not an integer (shouldn't happen: our code passes length of list */ + { + return FALSE; + } + if ( jvm_dia == jvm_ia ) /* jvm_dia still points to the built-in (non-malloc-ed) default default opts */ + { + DEBUG(1, Sdprintf("JPL not freeing original (static) JVM opts; replacing with malloc-ed [%d+1]\n", n)); + jvm_dia = (char**)malloc((n+1)*sizeof(char**)); + } + else + { + DEBUG(1, Sdprintf("JPL has malloc-ed JVM opt[?] (of malloc-ed strings)\n")); + for ( i = 0; jvm_dia[i] != NULL && i < 100; i++ ) /* a malloc-ed array always has NULL in its last element */ + { + DEBUG(1, Sdprintf("JPL freeing malloc-ed JVM opt '%s'\n", jvm_dia[i])); + free(jvm_dia[i]); /* a malloc-ed array's elements always point to malloc-ed strings, which we should free */ + } + if ( n != i ) /* we need an array of a different length */ + { + DEBUG(1, Sdprintf("JPL needs different qty JVM opts so freeing old [%d] and malloc-ing new [%d]\n", i, n)); + free(jvm_dia); + jvm_dia = (char**)malloc((n+1)*sizeof(char**)); + } + else + { + DEBUG(1, Sdprintf("JPL needs [%d] JVM opts as before\n")); + } + } + head = PL_new_term_ref(); /* variable for the elements */ + list = PL_copy_term_ref(args); /* copy as we need to write */ + for ( i = 0; PL_get_list(list,head,list); i++ ) + { + if ( PL_get_atom_chars(head,&s) ) + { + DEBUG(1, Sdprintf("JPL malloc-ing space for '%s'\n", s)); + jvm_dia[i] = (char*)malloc(strlen(s)+1); + strcpy(jvm_dia[i],s); + } + else + { + return FALSE; + } + } + jvm_dia[i] = NULL; /* stash a sentinel */ + return PL_get_nil(list); /* succeed iff list is proper */ + } + + +static foreign_t + jni_get_default_jvm_opts_plc( + term_t args /* -list(atom): the current default JVM initialisation options */ + ) + { + + return jni_get_jvm_opts(args,jvm_dia); + } + + +static foreign_t + jni_get_actual_jvm_opts_plc( + term_t args /* -list(atom): the actual JVM initialisation options */ + ) + { + + return jni_get_jvm_opts(args,jvm_aia); + } + + +/*=== FLI metadata ================================================================================= */ + +static + PL_extension predspecs[] = + { { "jni_get_created_jvm_count", 1, jni_get_created_jvm_count_plc, 0 }, + { "jni_ensure_jvm", 0, jni_ensure_jvm_plc, 0 }, + { "jni_tag_to_iref", 2, jni_tag_to_iref_plc, 0 }, + { "jni_hr_info", 4, jni_hr_info_plc, 0 }, + { "jni_hr_table", 1, jni_hr_table_plc, 0 }, + { "jni_byte_buf_length_to_codes", 3, jni_byte_buf_length_to_codes_plc, 0 }, + { "jni_param_put", 4, jni_param_put_plc, 0 }, + { "jni_alloc_buffer", 3, jni_alloc_buffer_plc, 0 }, + { "jni_free_buffer", 1, jni_free_buffer_plc, 0 }, +#ifdef __YAP_PROLOG__ + { "jni_SetByteArrayElement", 3, jni_SetByteArrayElement, 0 }, + { "jni_SetDoubleArrayElement", 3, jni_SetDoubleArrayElement, 0 }, +#endif + { "jni_fetch_buffer_value", 4, jni_fetch_buffer_value_plc, 0 }, + { "jni_stash_buffer_value", 4, jni_stash_buffer_value_plc, 0 }, + { "jni_void", 1, jni_void_0_plc, 0 }, + { "jni_void", 2, jni_void_1_plc, 0 }, + { "jni_void", 3, jni_void_2_plc, 0 }, + { "jni_void", 4, jni_void_3_plc, 0 }, + { "jni_void", 5, jni_void_4_plc, 0 }, + { "jni_func", 2, jni_func_0_plc, 0 }, + { "jni_func", 3, jni_func_1_plc, 0 }, + { "jni_func", 4, jni_func_2_plc, 0 }, + { "jni_func", 5, jni_func_3_plc, 0 }, + { "jni_func", 6, jni_func_4_plc, 0 }, + { "jpl_c_lib_version", 1, jpl_c_lib_version_1_plc, 0 }, + { "jpl_c_lib_version", 4, jpl_c_lib_version_4_plc, 0 }, + { "jni_term_to_jref", 2, jni_term_to_jref_plc, 0 }, + { "jni_jref_to_term", 2, jni_jref_to_term_plc, 0 }, + { "jni_get_default_jvm_opts", 1, jni_get_default_jvm_opts_plc, 0 }, + { "jni_set_default_jvm_opts", 2, jni_set_default_jvm_opts_plc, 0 }, + { "jni_get_actual_jvm_opts", 1, jni_get_actual_jvm_opts_plc, 0 }, + { NULL, 0, NULL, 0 } + }; + + +install_t + install(void) + { + PL_register_extensions( predspecs); + } + +/*=== end of jpl.c ================================================================================= */ diff --git a/packages/jpl/src/c/jpl.h b/packages/jpl/src/c/jpl.h new file mode 100644 index 000000000..98fe27284 --- /dev/null +++ b/packages/jpl/src/c/jpl.h @@ -0,0 +1,340 @@ +/* Part of JPL -- SWI-Prolog/Java interface + + Author: Paul Singleton, Fred Dushin and Jan Wielemaker + E-mail: paul@jbgb.com + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2004, Paul Singleton + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +*/ + +install_t install(void); +JNIEXPORT int JNICALL Java_jpl_fli_Prolog_action_1abort( JNIEnv *env, jclass jProlog); +JNIEXPORT jstring JNICALL Java_jpl_fli_Prolog_atom_1chars( JNIEnv *env, jclass jProlog, jobject jatom); + +JNIEXPORT int JNICALL + Java_jpl_fli_Prolog_attach_1engine( + JNIEnv *env, + jclass jProlog, + jobject jengine + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_attach_1pool_1engine( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_close_1query( + JNIEnv *env, + jclass jProlog, + jobject jqid + ); + +JNIEXPORT jint JNICALL /* returns -1, 0 or 1 (or -2 for error) */ + Java_jpl_fli_Prolog_compare( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_cons_1functor_1v( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jfunctor, + jobject jterm0 + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_copy_1term_1ref( + JNIEnv *env, + jclass jProlog, + jobject jfrom + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_current_1engine_1is_1pool( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_current_1engine( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_discard_1foreign_1frame( + JNIEnv *env, + jclass jProlog, + jobject jfid + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_exception( + JNIEnv *env, + jclass jProlog, + jobject jqid + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1actual_1init_1args( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1arg( + JNIEnv *env, + jclass jProlog, + jint jindex, + jobject jterm, + jobject jarg + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1atom_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_get_1c_1lib_1version( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_get_1default_1init_1args( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1float( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jdouble_holder + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1integer( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jint64_holder + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1name_1arity( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jname_holder, /* we trust this is a StringHolder */ + jobject jarity_holder /* we trust this is an IntHolder */ + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_get_1string_1chars( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jstring_holder + ); + +JNIEXPORT void JNICALL +Java_jpl_fli_Prolog_halt( + JNIEnv *env, + jclass jProlog, + jint jstatus + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_initialise( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_is_1tag( + JNIEnv *env, + jclass jProlog, + jstring tag + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1atom( + JNIEnv *env, + jclass jProlog, + jstring jname + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1functor( + JNIEnv *env, + jclass jProlog, + jobject jatom, /* read-only */ + jint jarity + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1module( + JNIEnv *env, + jclass jProlog, + jobject jatom + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1ref( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_new_1term_1refs( + JNIEnv *env, + jclass jProlog, + jint jn + ); + +JNIEXPORT jboolean JNICALL + Java_jpl_fli_Prolog_next_1solution( + JNIEnv *env, + jclass jProlog, + jobject jqid /* read */ + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_object_1to_1tag( + JNIEnv *env, + jclass jProlog, + jobject jobj + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_open_1foreign_1frame( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jobject JNICALL +Java_jpl_fli_Prolog_open_1query( + JNIEnv *env, + jclass jProlog, + jobject jmodule, /* read */ + jint jflags, /* read */ + jobject jpredicate, /* read */ + jobject jterm0 /* read */ + ); + +JNIEXPORT int JNICALL +Java_jpl_fli_Prolog_pool_1engine_1id( + JNIEnv *env, + jclass jProlog, + jobject jengine + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_predicate( + JNIEnv *env, + jclass jProlog, + jstring jname, /* ought not be null */ + jint jarity, /* oughta be >= 0 */ + jstring jmodule /* may be null */ + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1float(JNIEnv *env, + jclass jProlog, + jobject jterm, + jdouble jf); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_put_1integer(JNIEnv *env, + jclass jProlog, + jobject jterm, + jlong ji); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_put_1jref( + JNIEnv *env, + jclass jProlog, + jobject jterm, + jobject jref + ); + +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1term( + JNIEnv *env, + jclass jProlog, + jobject jterm1, + jobject jterm2 + ); + +JNIEXPORT void JNICALL /* maybe oughta return jboolean (false iff given object is null) */ + Java_jpl_fli_Prolog_put_1variable( + JNIEnv *env, + jclass jProlog, + jobject jterm + ); + +JNIEXPORT int JNICALL +Java_jpl_fli_Prolog_release_1pool_1engine( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT jboolean JNICALL +Java_jpl_fli_Prolog_set_1default_1init_1args( + JNIEnv *env, + jclass jProlog, + jobject jargs /* oughta be proper array, perhaps zero-length */ + ); + +JNIEXPORT jobject JNICALL + Java_jpl_fli_Prolog_tag_1to_1object( + JNIEnv *env, + jclass jProlog, + jstring tag + ); + +JNIEXPORT jint JNICALL + Java_jpl_fli_Prolog_term_1type( + JNIEnv *env, + jclass jProlog, + jobject jterm + ); + +JNIEXPORT jint JNICALL +Java_jpl_fli_Prolog_thread_1self( + JNIEnv *env, + jclass jProlog + ); + +JNIEXPORT void JNICALL + Java_jpl_fli_Prolog_unregister_1atom( + JNIEnv *env, + jclass jProlog, + jobject jatom + ); + diff --git a/packages/jpl/src/java/Makefile.in b/packages/jpl/src/java/Makefile.in new file mode 100755 index 000000000..e4486096c --- /dev/null +++ b/packages/jpl/src/java/Makefile.in @@ -0,0 +1,99 @@ +################################################################ +# Build jpl.jar +################################################################ + +.SUFFIXES: .java .class + +ifeq (@PROLOG_SYSTEM@,yap) +srcdir=@srcdir@ +else +srcdir=. +endif + +JAVAC=@JAVAC@ +JAVACFLAGS=@JAVACFLAGS@ -d . +JAR=@JAR@ +JUNIT=@JUNIT@ +JAVADOC=@JAVADOC@ +JPLJAR=../../jpl.jar +TSTJAR=../../jpltest.jar +JPLDOC=../../docs/java_api/javadoc + +CLS= jpl/Atom.java \ + jpl/Compound.java \ + jpl/Float.java \ + jpl/Integer.java \ + jpl/JRef.java \ + jpl/JPLException.java \ + jpl/JPL.java \ + jpl/PrologException.java \ + jpl/Query.java \ + jpl/Term.java \ + jpl/Util.java \ + jpl/Variable.java \ + jpl/Version.java + +FLI= jpl/fli/atom_t.java \ + jpl/fli/BooleanHolder.java \ + jpl/fli/DoubleHolder.java \ + jpl/fli/engine_t.java \ + jpl/fli/fid_t.java \ + jpl/fli/functor_t.java \ + jpl/fli/IntHolder.java \ + jpl/fli/Int64Holder.java \ + jpl/fli/LongHolder.java \ + jpl/fli/module_t.java \ + jpl/fli/ObjectHolder.java \ + jpl/fli/PointerHolder.java \ + jpl/fli/predicate_t.java \ + jpl/fli/Prolog.java \ + jpl/fli/qid_t.java \ + jpl/fli/StringHolder.java \ + jpl/fli/term_t.java + +TEST= jpl/test/Family.java \ + jpl/test/FetchBigTree.java \ + jpl/test/FetchLongList.java \ + jpl/test/Ga2.java \ + jpl/test/Ga.java \ + jpl/test/Garbo.java \ + jpl/test/Masstest.java \ + jpl/test/MaxObjects.java \ + jpl/test/ShadowA.java \ + jpl/test/ShadowB.java \ + jpl/test/SyntaxError.java \ + jpl/test/Test.java \ + jpl/test/TestJUnit.java \ + jpl/test/TestOLD.java + +JPLJAVA=$(CLS) $(FLI) +TSTJAVA=$(TEST) + +all: $(JPLJAR) $(TSTJAR) $(JPLDOC) + +jpl_jar: $(JPLJAR) +test_jar: $(TSTJAR) +jpl_doc: $(JPLDOC) + +$(JPLJAR): $(addprefix $(srcdir)/, $(JPLJAVA)) + "$(JAVAC)" $(JAVACFLAGS) $(addprefix $(srcdir)/, $(JPLJAVA)) + "$(JAR)" cf $(JPLJAR) $(foreach basename,$(JPLJAVA:.java=),$(basename).class $(subst $$,\$$,$(wildcard $(basename)$$*.class))) + +ifneq ($(JUNIT),) +$(TSTJAR): $(JPLJAR) $(addprefix $(srcdir)/, $(TSTJAVA)) + "$(JAVAC)" $(JAVACFLAGS) -classpath $(JPLJAR):$(JUNIT) $(addprefix $(srcdir)/, $(TSTJAVA)) + "$(JAR)" cf $(TSTJAR) $(TSTJAVA:.java=.class) +else +$(TSTJAR):: +endif + +$(JPLDOC): $(addprefix $(srcdir)/, $(JPLJAVA)) + "$(JAVADOC)" -public -d $(JPLDOC) $(addprefix $(srcdir)/, $(JPLJAVA)) + +clean:: + rm -f *~ jpl/*.class jpl/test/*.class jpl/fli/*.class + +distclean: clean + rm -f $(JPLJAR) $(TSTJAR) Makefile + rm -rf $(JPLDOC) + diff --git a/packages/jpl/src/java/Makefile.mak b/packages/jpl/src/java/Makefile.mak new file mode 100644 index 000000000..820b6d3f5 --- /dev/null +++ b/packages/jpl/src/java/Makefile.mak @@ -0,0 +1,91 @@ +################################################################ +# Build jpl.jar +################################################################ + +.SUFFIXES: .java .class + +!include ..\..\..\..\src\rules.mk +JAVAC="$(JAVA_HOME)\bin\javac" +JAR="$(JAVA_HOME)\bin\jar" +JAVADOC="$(JAVA_HOME)\bin\javadoc" +JPLJAR=..\..\jpl.jar +TSTJAR=..\..\jpltest.jar +JPLDOC=..\..\docs\java_api\javadoc + +CLS= jpl\Atom.java \ + jpl\Compound.java \ + jpl\Float.java \ + jpl\Integer.java \ + jpl\JRef.java \ + jpl\JPLException.java \ + jpl\JPL.java \ + jpl\PrologException.java \ + jpl\Query.java \ + jpl\Term.java \ + jpl\Util.java \ + jpl\Variable.java \ + jpl\Version.java + +FLI= jpl\fli\atom_t.java \ + jpl\fli\BooleanHolder.java \ + jpl\fli\DoubleHolder.java \ + jpl\fli\engine_t.java \ + jpl\fli\fid_t.java \ + jpl\fli\functor_t.java \ + jpl\fli\IntHolder.java \ + jpl\fli\Int64Holder.java \ + jpl\fli\LongHolder.java \ + jpl\fli\module_t.java \ + jpl\fli\ObjectHolder.java \ + jpl\fli\PointerHolder.java \ + jpl\fli\predicate_t.java \ + jpl\fli\Prolog.java \ + jpl\fli\qid_t.java \ + jpl\fli\StringHolder.java \ + jpl\fli\term_t.java + +TEST= jpl\test\CelsiusConverter.java \ + jpl\test\Family.java \ + jpl\test\FetchBigTree.java \ + jpl\test\FetchLongList.java \ + jpl\test\Ga2.java \ + jpl\test\Ga.java \ + jpl\test\Garbo.java \ + jpl\test\Masstest.java \ + jpl\test\MaxObjects.java \ + jpl\test\ShadowA.java \ + jpl\test\ShadowB.java \ + jpl\test\SyntaxError.java \ + jpl\test\Test.java \ + jpl\test\TestJUnit.java \ + jpl\test\TestOLD.java + +JPLJAVA=$(CLS) $(FLI) +TSTJAVA=$(TEST) + +all: $(JPLJAR) $(TSTJAR) $(JPLDOC) + +$(JPLJAR): $(JPLJAVA) + $(JAVAC) -source 1.4 -target 1.4 $(JPLJAVA) + $(JAR) cf $(JPLJAR) $(JPLJAVA:.java=.class) + +$(TSTJAR): $(JPLJAR) $(TSTJAVA) + $(JAVAC) -source 1.4 -target 1.4 -classpath "$(JPLJAR);$(JUNIT)" $(TSTJAVA) + $(JAR) cf $(TSTJAR) $(TSTJAVA:.java=.class) + +$(JPLDOC): $(JPLJAVA) + $(JAVADOC) -public -d $(JPLDOC) $(JPLJAVA) + +clean:: + if exist jpl\*.class del jpl\*.class + if exist jpl\fli\*.class del jpl\fli\*.class + if exist jpl\test\*.class del jpl\test\*.class + if exist jpl\util\*.class del jpl\util\*.class + if exist *~ del *~ + +distclean: clean + if exist $(JPLJAR) del $(JPLJAR) + if exist $(TSTJAR) del $(TSTJAR) + if exist $(JPLDOC) rmdir /s /q $(JPLDOC) + + diff --git a/packages/jpl/src/java/jpl/.cvsignore b/packages/jpl/src/java/jpl/.cvsignore new file mode 100644 index 000000000..20e215408 --- /dev/null +++ b/packages/jpl/src/java/jpl/.cvsignore @@ -0,0 +1,2 @@ +*.class +Makefile diff --git a/packages/jpl/src/java/jpl/Atom.java b/packages/jpl/src/java/jpl/Atom.java new file mode 100644 index 000000000..bb4a88d03 --- /dev/null +++ b/packages/jpl/src/java/jpl/Atom.java @@ -0,0 +1,169 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// Author: Paul Singleton paul@jbgb.com +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; + +import jpl.fli.Prolog; +import jpl.fli.StringHolder; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Atom +/** + * Atom is a specialised Compound with zero arguments, representing a Prolog atom with the same name. + * An Atom is constructed with a String parameter (its name, unquoted), which cannot thereafter be changed. + * 
    Atom a = new Atom("hello");
    + * An Atom can be used (and re-used) as an argument of Compound Terms. + * Two Atom instances are equal (by equals()) iff they have equal names. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + */ +public class Atom extends Compound { + + //==================================================================/ + // Attributes (none) + //==================================================================/ + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * @param name the Atom's name (unquoted) + */ + public Atom(String name) { + super(name); + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + // these are all inherited from Compound + + public final int type() { + return Prolog.ATOM; + } + + /** + * returns the name of the type of this term, as "Atom" + * + * @return the name of the type of this term, as "Atom" + */ + public String typeName() { // overrides same in jpl.Term + return "Atom"; + } + + public Object jrefToObject() { + throw new JPLException("Atom.jrefToObject: term is not a JRef"); + } +//==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * Returns a debug-friendly String representation of an Atom. + * + * @return a debug-friendly String representation of an Atom + * @deprecated + */ + public String debugString() { + return "(Atom " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + // (this is done with the put() method inherited from Compound) + + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + + /** + * Converts a Prolog term (as a term_t), which is known to be an atom, to a new jpl.Atom. + * This is only called from Term.getTerm(), + * and just creates a new Atom object initialised with the atom's name. + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + * @param term The Prolog term to be converted + * @return A new Atom instance + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + StringHolder holder = new StringHolder(); + Prolog.get_atom_chars(term, holder); // ignore return val; assume success... + + return new Atom(holder.value); + } + + /** + * Converts a Prolog term (as a term_t), which is known to be a SWI-Prolog string, to a new jpl.Atom, + * by creating a new Atom object initialised with the string's value. + * JPL users should avoid SWI-Prolog's non-ISO strings, but in some obscure + * circumstances they are returned unavoidably, so we have to handle them + * (and this is how). + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + * @param term The term_t to convert + * @return A new Atom instance + */ + protected static Term getString(Map vars_to_Vars, term_t term) { + StringHolder holder = new StringHolder(); + Prolog.get_string_chars(term, holder); // ignore return val; assume success... + return new Atom(holder.value); + } + + //==================================================================/ + // Computing substitutions + //==================================================================/ + + // (done with the inherited Compound.getSubst() method) + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/Compound.java b/packages/jpl/src/java/jpl/Compound.java new file mode 100644 index 000000000..c3d00cb8f --- /dev/null +++ b/packages/jpl/src/java/jpl/Compound.java @@ -0,0 +1,419 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; + +import jpl.fli.IntHolder; +import jpl.fli.Prolog; +import jpl.fli.StringHolder; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Compound +/** + * A Compound represents a structured term, + * comprising a functor and arguments (Terms). + * Atom is a subclass of Compound, whose instances have zero arguments. + * Direct instances of Compound must have one or more arguments + * (it is an error to attempt to construct a Compound with zero args; + * a JPLException will be thrown). + * For example, this Java expression yields + * a representation of the term f(a): + * 
    + * new Compound( "f", new Term[] { new Atom("a") } )
+ *
    + * Note the use of the "anonymous array" notation to denote the arguments + * (an anonymous array of Term). + *
    + * Alternatively, construct the Term from Prolog source syntax: + * 
    + * Util.textToTerm("f(a)")
+ *
    + * The arity of a Compound is the quantity of its arguments. + * Once constructed, neither the name nor the arity of a Compound can be altered. + * An argument of a Compound can be replaced with the setArg() method. + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Atom + */ +public class Compound extends Term { + //==================================================================/ + // Attributes + //==================================================================/ + /** + * the name of this Compound + */ + protected final String name; + /** + * the arguments of this Compound + */ + protected final Term[] args; + //==================================================================/ + // Constructors + //==================================================================/ + /** + * Creates a Compound with name but no args (i.e. an Atom). + * This condsructor is protected (from illegal public use) and is used + * only by Atom, which inherits it. + * + * @param name the name of this Compound + * @param args the arguments of this Compound + */ + protected Compound(String name) { + if (name == null) { + throw new JPLException("jpl.Atom: cannot construct with null name"); + } + this.name = name; + this.args = new Term[] {}; + } + /** + * Creates a Compound with name and args. + * + * @param name the name of this Compound + * @param args the (one or more) arguments of this Compound + */ + public Compound(String name, Term[] args) { + if (name == null) { + throw new JPLException("jpl.Compound: cannot construct with null name"); + } + if (args == null) { + throw new JPLException("jpl.Compound: cannot construct with null args"); + } + if (args.length == 0) { + throw new JPLException("jpl.Compound: cannot construct with zero args"); + } + this.name = name; + this.args = args; + } + /** + * Creates a Compound with name and arity. + * This constructor, along with the setArg method, serves the new, native Prolog-term-to-Java-term routine, + * and is public only so as to be accessible via JNI: it is not intended for general use. + * + * @param name the name of this Compound + * @param arity the arity of this Compound + */ + public Compound(String name, int arity) { + if (name == null) { + throw new JPLException("jpl.Compound: cannot construct with null name"); + } + if (arity < 0) { + throw new JPLException("jpl.Compound: cannot construct with negative arity"); + } + this.name = name; + this.args = new Term[arity]; + } + //==================================================================/ + // Methods (common) + //==================================================================/ + /** + * Returns the ith argument (counting from 1) of this Compound; + * throws an ArrayIndexOutOfBoundsException if i is inappropriate. + * + * @return the ith argument (counting from 1) of this Compound + */ + public final Term arg(int i) { + return args[i - 1]; + } + /** + * Tests whether this Compound's functor has (String) 'name' and 'arity'. + * + * @return whether this Compound's functor has (String) 'name' and 'arity' + */ + public final boolean hasFunctor(String name, int arity) { + return name.equals(this.name) && arity == args.length; // BUGFIX: was just name.equals(name) + } + /** + * whether this Term is a 'jboolean' structure denoting Java's false, i.e. @(false) + * + * @return whether this Term is a 'jboolean' structure denoting Java's false, i.e. @(false) + */ + public boolean isJFalse() { + return hasFunctor("@", 1) && arg(1).hasFunctor("false", 0); + } + /** + * whether this Term is a 'jboolean' structure denoting Java's true, i.e. @(fatruelse) + * + * @return whether this Term is a 'jboolean' structure denoting Java's true, i.e. @(fatruelse) + */ + public boolean isJTrue() { + return hasFunctor("@", 1) && arg(1).hasFunctor("true", 0); + } + /** + * whether this Term is a 'jnull' structure, i.e. @(null) + * + * @return whether this Term is a 'jnull' structure, i.e. @(null) + */ + public boolean isJNull() { + return hasFunctor("@", 1) && arg(1).hasFunctor("null", 0); + } + /** + * whether this Term is a 'jvoid' structure, i.e. @(void) + * + * @return whether this Term is a 'jvoid' structure, i.e. @(void) + */ + public boolean isJVoid() { + return hasFunctor("@", 1) && arg(1).hasFunctor("void", 0); + } + /** + * whether this Term is a 'jobject' structure, i.e. @(Tag) + * + * @return whether this Term is a 'jobject' structure, i.e. @(Tag) + */ + public boolean isJObject() { + return hasFunctor("@", 1) && arg(1).isAtom() && JPL.isTag(arg(1).name()); + } + /** + * whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + * + * @return whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + */ + public boolean isJRef() { + return isJObject() || isJNull(); + } + public Object jrefToObject() { + if (this.isJObject()) { + return Prolog.tag_to_object(arg(1).name()); + } else if (this.isJNull()) { + return null; + } else { + throw new JPLException("Term.jrefToObject: term is not a JRef"); + } + } + /** + * Returns the name (unquoted) of this Compound. + * + * @return the name (unquoted) of this Compound + */ + public final String name() { + return name; + } + /** + * Returns the arity (1+) of this Compound. + * + * @return the arity (1+) of this Compound + */ + public final int arity() { + return args.length; + } + /** + * Returns a prefix functional representation of a Compound of the form name(arg1,...), + * where 'name' is quoted iff necessary (to be valid Prolog soutce text) + * and each argument is represented according to its toString() method. + * + * @return string representation of an Compound + */ + public String toString() { + return quotedName() + (args.length > 0 ? "(" + Term.toString(args) + ")" : ""); + } + /** + * Two Compounds are equal if they are identical (same object) or their names and arities are equal and their + * respective arguments are equal. + * + * @param obj the Object to compare (not necessarily another Compound) + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return (this == obj || (obj instanceof Compound && name.equals(((Compound) obj).name) && Term.terms_equals(args, ((Compound) obj).args))); + } + /** + * returns the type of this term, as jpl.fli.Prolog.COMPOUND + * + * @return the type of this term, as jpl.fli.Prolog.COMPOUND + */ + public int type() { + return Prolog.COMPOUND; + } + /** + * returns the name of the type of this term, as "Compound" + * + * @return the name of the type of this term, as "Compound" + */ + public String typeName(){ + return "Compound"; + } + /** + * Sets the i-th (from 1) arg of this Compound to the given Term instance. + * This method, along with the Compound(name,arity) constructor, serves the new, native Prolog-term-to-Java-term routine, + * and is public only so as to be accessible via JNI: it is not intended for general use. + * + * @param i the index (1+) of the arg to be set + * @param arg the Term which is to become the i-th (from 1) arg of this Compound + */ + public void setArg(int i, Term arg) { + if (i <= 0) { + throw new JPLException("jpl.Compound#setArg: bad (non-positive) argument index"); + } + if (i > args.length) { + throw new JPLException("jpl.Compound#setArg: bad (out-of-range) argument index"); + } + if (arg == null) { + throw new JPLException("jpl.Compound#setArg: bad (null) argument"); + } + args[i - 1] = arg; + } + //==================================================================/ + // Methods (protected) + //==================================================================/ + /** + * Returns a quoted (iff necessary) form of the Atom's name, as understood by Prolog read/1 + * (I suspect that there are more efficient ways of doing this) + * + * @return a quoted form of the Atom's name, as understood by Prolog read/1 + */ + protected String quotedName() { + return ((Atom) + (new Query + (new + Compound("with_output_to", + new Term[] { + new Compound("atom", + new Term[] { + new Variable("S") + } + ), + new Compound("writeq", + new Term[] { + new Atom(this.name) + } + ) + } + ) + + ) + ).oneSolution().get("S")).name; + } + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + /** + * Returns the arguments of this Compound (1..arity) of this Compound as an array[0..arity-1] of Term. + * + * @return the arguments (1..arity) of this Compound as an array[0..arity-1] of Term + * @deprecated + */ + public final Term[] args() { + return args; + } + /** + * Returns the ith argument (counting from 0) of this Compound. + * + * @return the ith argument (counting from 0) of this Compound + * @deprecated + */ + public final Term arg0(int i) { + return args[i]; + } + /** + * Returns a debug-friendly representation of a Compound. + * + * @return a debug-friendly representation of a Compound + * @deprecated + */ + public String debugString() { + return "(Compound " + name + " " + Term.debugString(args) + ")"; + } + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + /** + * To put a Compound in a term, we create a sequence of term_t + * references from the Term.terms_to_term_ts() method, and then + * use the Prolog.cons_functor_v() method to create a Prolog compound + * term. + * + * @param varnames_to_vars A Map from variable names to Prolog variables + * @param term A (previously created) term_t which is to be + * set to a Prolog term corresponding to the Term subtype + * (Atom, Variable, Compound, etc.) on which the method is invoked. + */ + protected final void put(Map varnames_to_vars, term_t term) { + Prolog.cons_functor_v(term, Prolog.new_functor(Prolog.new_atom(name), args.length), Term.putTerms(varnames_to_vars, args)); + } + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + /** + * Converts the Prolog term in term_t (known to be a compound) to a JPL Compound. + * In this case, we create a list of Terms by calling Term.getTerm for each + * term_t reference we get from Prolog.get_arg + * (Not sure why we couldn't get a sequence from there, but...). + * + * @param varnames_to_vars A Map from variable names to Prolog variables + * @param term The Prolog term to convert + * @return A new Compound + */ + protected static Term getTerm1(Map varnames_to_vars, term_t term) { + // ObjectHolder jthing_holder = new ObjectHolder(); + StringHolder name_holder = new StringHolder(); + IntHolder arity_holder = new IntHolder(); + Prolog.get_name_arity(term, name_holder, arity_holder); // assume it succeeds + Term args[] = new Term[arity_holder.value]; + for (int i = 1; i <= arity_holder.value; i++) { + term_t termi = Prolog.new_term_ref(); + Prolog.get_arg(i, term, termi); + args[i - 1] = Term.getTerm(varnames_to_vars, termi); + } + return new Compound(name_holder.value, args); + } + //==================================================================/ + // Computing Substitutions + //==================================================================/ + /** + * Nothing needs to be done except to pass the buck to this Compound's args. + * + * @param varnames_to_Terms A Map from variable names to JPL Terms + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + Term.getSubsts(varnames_to_Terms, vars_to_Vars, args); + } + public boolean hasFunctor(int value, int arity) { + return false; + } + public boolean hasFunctor(double value, int arity) { + return false; + } +} +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/Float.java b/packages/jpl/src/java/jpl/Float.java new file mode 100644 index 000000000..db6b2824f --- /dev/null +++ b/packages/jpl/src/java/jpl/Float.java @@ -0,0 +1,298 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; + +import jpl.fli.DoubleHolder; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Float +/** + * Float is a specialised Term with a double field, representing a Prolog 64-bit ISO/IEC floating point value. + * Once constructed, a Float's value cannot be altered. + * 
    + * Float f = new Float( 3.14159265 );
+ *
    + * A Float can be used (and re-used) in Compound Terms. + * Two Float instances are equal (by .equals()) iff their (double) values are equal. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + */ +public class Float extends Term { + + //==================================================================/ + // Attributes + //==================================================================/ + + /** + * the Float's immutable value + */ + protected final double value; + + //==================================================================/ + // Constructors and Initialization + //==================================================================/ + + /** + * This constructor creates a Float with the supplied + * (double) value. + * + * @param value this Float's value + */ + public Float(double value) { + this.value = value; + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + /** + * throws a JPLException (arg(int) is defined only for Compound and Atom) + * + * @return the ith argument (counting from 1) of this Float (never) + */ + public final Term arg(int i) { + throw new JPLException("jpl.Float#arg(int) is undefined"); + } + + /** + * The (nonexistent) args of this Float + * + * @return the (nonexistent) args of this Float + */ + public Term[] args() { + return new Term[] {}; + } + + /** + * Tests whether this Float's functor has (String) 'name' and 'arity' (never) + * + * @return whether this Float's functor has (String) 'name' and 'arity' (never) + */ + public final boolean hasFunctor(String name, int arity) { + return false; + } + + /** + * Tests whether this Float's functor has (int) 'name' and 'arity' (never) + * + * @return whether this Float's functor has (int) 'name' and 'arity' (never) + */ + public final boolean hasFunctor(int val, int arity) { + return false; + } + + /** + * Tests whether this Float's functor has (double) 'name' and 'arity' + * + * @return whether this Float's functor has (double) 'name' and 'arity' + */ + public final boolean hasFunctor(double val, int arity) { + return val == this.value && arity == 0; + } + + /** + * throws a JPLException (name() is defined only for Compound, Atom and Variable) + * + * @return the name of this Float (never) + */ + public final String name() { + throw new JPLException("jpl.Float#name() is undefined"); + } + + /** + * Returns the arity (0) of this Float + * + * @return the arity (0) of this Float + */ + public final int arity() { + return 0; + } + + /** + * returns the (double) value of this Float, converted to an int + * + * @return the (double) value of this Float, converted to an int + */ + public final int intValue() { + return (new Double(value)).intValue(); + } + + /** + * returns the (double) value of this Float, converted to a long + * + * @return the (double) value of this Float, converted to a long + */ + public final long longValue() { + return (new Double(value)).longValue(); + } + + /** + * returns the (double) value of this Float, converted to a float + * + * @return the (double) value of this Float, converted to a float + */ + public final float floatValue() { + return (new Double(value)).floatValue(); + } + + /** + * returns the (double) value of this Float + * + * @return the (double) value of this Float + */ + public final double doubleValue() { + return this.value; + } + + public final int type() { + return Prolog.FLOAT; + } + + public String typeName(){ + return "Float"; + } + + /** + * Returns a Prolog source text representation of this Float + * + * @return a Prolog source text representation of this Float + */ + public String toString() { + return "" + value + ""; + } + + /** + * Two Floats are equal if they are the same object, or their values are equal + * + * @param obj The Object to compare + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return this == obj || (obj instanceof Float && value == ((Float) obj).value); + } + + public Object jrefToObject() { + throw new JPLException("Float.jrefToObject: term is not a JRef"); + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * The immutable value of this jpl.Float object, as a Java double + * + * @return the Float's value + * @deprecated + */ + public double value() { + return value; + } + + /** + * Returns a debug-friendly String representation of this Float + * + * @return a debug-friendly String representation of this Float + * @deprecated + */ + public String debugString() { + return "(Float " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + /** + * To convert a JPL Float to a Prolog term, we put its value field into the + * term_t as a float. + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (previously created) term_t which is to be + * set to a Prolog float corresponding to this Float's value + */ + protected final void put(Map varnames_to_vars, term_t term) { + Prolog.put_float(term, value); + } + + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + + /** + * Converts a Prolog term (known to be a float) to a JPL Float. + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + * @param term The Prolog term (a float) to convert + * @return A new Float instance + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + DoubleHolder double_holder = new DoubleHolder(); + + Prolog.get_float(term, double_holder); // assume it succeeds... + return new jpl.Float(double_holder.value); + } + + //==================================================================/ + // Computing Substitutions + //==================================================================/ + + /** + * Nothing needs to be done if the Term is an Atom, Integer or (as in this case) a Float + * + * @param varnames_to_Terms A Map from variable names to JPL Terms + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/Integer.java b/packages/jpl/src/java/jpl/Integer.java new file mode 100644 index 000000000..615c675db --- /dev/null +++ b/packages/jpl/src/java/jpl/Integer.java @@ -0,0 +1,299 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; +import jpl.fli.Int64Holder; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Integer +/** + * Integer is a specialised Term with a long field, representing a Prolog integer value. + * 
    + * Integer i = new Integer(1024);
+ *
    + * Once constructed, the value of an Integer instance cannot be altered. + * An Integer can be used (and re-used) as an argument of Compounds. + * Beware confusing jpl.Integer with java.lang.Integer. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + */ +public class Integer extends Term { + + //==================================================================/ + // Attributes + //==================================================================/ + + /** + * the Integer's immutable long value + */ + protected final long value; + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * @param value This Integer's (long) value + */ + public Integer(long value) { + this.value = value; + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + /** + * The (nonexistent) ano-th arg of this Integer + * + * @return the (nonexistent) ano-th arg of this Integer + */ + public Term arg(int ano) { + throw new JPLException("jpl." + this.typeName() + ".arg() is undefined"); + } + + /** + * The (nonexistent) args of this Integer + * + * @return the (nonexistent) args of this Integer + */ + public Term[] args() { + return new Term[] { + }; + } + + /** + * Tests whether this Integer's functor has (int) 'name' and 'arity' (c.f. functor/3) + * + * @return whether this Integer's functor has (int) 'name' and 'arity' + */ + public final boolean hasFunctor(int val, int arity) { + return val == this.value && arity == 0; + } + + /** + * Tests whether this Integer's functor has (String) 'name' and 'arity' (c.f. functor/3) + * + * @return whether this Integer's functor has (String) 'name' and 'arity' + */ + public boolean hasFunctor(String name, int arity) { + return false; + } + + /** + * Tests whether this Integer's functor has (double) 'name' and 'arity' (c.f. functor/3) + * + * @return whether this Integer's functor has (double) 'name' and 'arity' + */ + public boolean hasFunctor(double value, int arity) { + return false; + } + + /** + * throws a JPLException (name() is defined only for Compound, Atom and Variable) + * + * @return the name of this Integer (never) + */ + public final String name() { + throw new JPLException("jpl.Integer#name() is undefined"); + } + + /** + * Returns the arity (0) of this jpl.Integer (c.f. functor/3) + * + * @return the arity (0) of this jpl.Integer + */ + public final int arity() { + return 0; + } + + /** + * Returns the value of this Integer as an int if possible, else throws a JPLException + * + * @throws JPLException if the value of this Integer is too great to be represented as a Java int + * @return the int value of this Integer + */ + public final int intValue() { + if (value < java.lang.Integer.MIN_VALUE || value > java.lang.Integer.MAX_VALUE) { + throw new JPLException("cannot represent Integer value as an int"); + } else { + return (int) value; + } + } + + /** + * Returns the value of this Integer as a long + * + * @return the value of this Integer as a long + */ + public final long longValue() { + return value; + } + + /** + * Returns the value of this Integer converted to a float + * + * @return the value of this Integer converted to a float + */ + public final float floatValue() { + return (new java.lang.Long(value)).floatValue(); // safe but inefficient... + } + + /** + * Returns the value of this Integer converted to a double + * + * @return the value of this Integer converted to a double + */ + public final double doubleValue() { + return (new java.lang.Long(value)).doubleValue(); // safe but inefficient... + } + + public final int type() { + return Prolog.INTEGER; + } + + public String typeName(){ + return "Integer"; + } + + /** + * Returns a Prolog source text representation of this Integer's value + * + * @return a Prolog source text representation of this Integer's value + */ + public String toString() { + return "" + value; // hopefully invokes Integer.toString() or equivalent + } + + /** + * Two Integer instances are equal if they are the same object, or if their values are equal + * + * @param obj The Object to compare (not necessarily an Integer) + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return this == obj || (obj instanceof Integer && value == ((Integer) obj).value); + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * Returns the int value of this jpl.Integer + * + * @return the Integer's value + * @deprecated + */ + public final int value() { + return (int) value; + } + + /** + * Returns a debug-friendly representation of this Integer's value + * + * @return a debug-friendly representation of this Integer's value + * @deprecated + */ + public String debugString() { + return "(Integer " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + /** + * To convert an Integer into a Prolog term, we put its value into the term_t. + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (previously created) term_t which is to be + * set to a Prolog integer + */ + protected final void put(Map varnames_to_vars, term_t term) { + Prolog.put_integer(term, value); + } + + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + + /** + * Converts a Prolog term (known to be an integer) to a new Integer instance. + * + * @param vars_to_Vars A Map from Prolog variables to JPL Variables + * @param term The Prolog term (an integer) which is to be converted + * @return A new Integer instance + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + Int64Holder int64_holder = new Int64Holder(); + + Prolog.get_integer(term, int64_holder); // assume it succeeds... + return new jpl.Integer(int64_holder.value); + } + + //==================================================================/ + // Computing Substitutions + //==================================================================/ + + /** + * Nothing needs to be done if the Term is an Atom, Integer or Float + * + * @param varnames_to_Terms A Map from variable names to Terms. + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + } + + public Object jrefToObject() { + throw new JPLException("Integer.jrefToObject(): term is not a jref"); + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/JPL.java b/packages/jpl/src/java/jpl/JPL.java new file mode 100644 index 000000000..8ea6c5d35 --- /dev/null +++ b/packages/jpl/src/java/jpl/JPL.java @@ -0,0 +1,243 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.io.File; +import jpl.fli.Prolog; + +//----------------------------------------------------------------------/ +// JPL +/** + * The jpl.JPL class contains methods which allow (i) inspection and alteration + * of the "default" initialisation arguments (ii) explicit initialisation + * (iii) discovery of whether the Prolog engine is already initialised, + * and if so, with what arguments. + * The Prolog engine must be initialized + * before any queries are made, but this will happen automatically + * (upon the first call to a Prolog FLI routine) if it has not already + * been done explicitly. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public class JPL { + protected static final boolean DEBUG = false; + // + public static final Term JFALSE = new Compound("@", new Term[] {new Atom("false")}); + public static final Term JTRUE = new Compound("@", new Term[] {new Atom("true")}); + public static final Term JNULL = new Compound("@", new Term[] {new Atom("null")}); + public static final Term JVOID = new Compound("@", new Term[] {new Atom("void")}); + + protected static boolean modeDontTellMe = true; + + private static String nativeLibraryName = "jpl"; + private static String nativeLibraryDir = null; + private static String nativeLibraryPath = null; + public static String setNativeLibraryName(String newName) { + if (newName == null) { + throw new NullPointerException("newName cannot be null"); + } else { + String oldName = nativeLibraryName; + nativeLibraryName = newName; + return oldName; + } + } + public static String setNativeLibraryDir(String newDir) { + String oldDir = nativeLibraryDir; + nativeLibraryDir = newDir; + return oldDir; + } + public static String setNativeLibraryPath(String newPath) { + String oldPath = nativeLibraryPath; + nativeLibraryPath = newPath; + return oldPath; + } + public static void loadNativeLibrary() { + if (nativeLibraryPath != null) { + System.load((new File(nativeLibraryPath)).getAbsolutePath()); + } else if (nativeLibraryDir != null) { + System.load((new File(nativeLibraryDir, System.mapLibraryName(nativeLibraryName))).getAbsolutePath()); + } else { + System.loadLibrary(nativeLibraryName); // as resolved somewhere on system property 'java.library.path' + } + } + // setDTMMode + /** + * Sets the global "dont-tell-me" mode (default value: true). + * When 'true', bindings will *not* be returned for any variable (in a Query's goal) + * whose name begins with an underscore character (except for "anonymous" variables, + * i.e. those whose name comprises just the underscore character, whose bindings are never returned). + * When 'false', bindings are returned for *all* variables except anonymous ones; + * this mode may be useful when traditional top-level interpreter behaviour is wanted, + * e.g. in a Java-based Prolog IDE or debugger. + * This method should be regarded as experimental, and may subsequently be deprecated + * in favour of some more general mechanism for setting options, perhaps per-Query and + * per-call as well as globally. + * + * @param dtm new "dont-tell-me" mode value + */ + public static void setDTMMode( boolean dtm){ + modeDontTellMe = dtm; + } + + // getDefaultInitArgs + /** + * Returns, in an array of String, the sequence of command-line + * arguments that would be used if the Prolog engine were to be initialised now. + * Returns null if the Prolog VM has already been initialised (in which + * case the default init args are irrelevant and the actual init args are of interest) + * + * @see jpl.JPL#getActualInitArgs + * @return current default initialisation arguments, or null if already initialised + */ + public static String[] getDefaultInitArgs() { + return Prolog.get_default_init_args(); + } + + // setDefaultInitArgs + /** + * Specifies, in an array of String, the sequence of command-line + * arguments that should be used if the Prolog engine is subsequently initialised. + * + * @param args new default initialization arguments + */ + public static void setDefaultInitArgs(String[] args) { + Prolog.set_default_init_args(args); + } + + // getActualInitArgs + /** + * Returns, in an array of String, the sequence of command-line + * arguments that were actually used when the Prolog engine was formerly initialised. + * + * This method returns null if the Prolog engine has not yet been initialised, + * and thus may be used to test this condition. + * + * @return actual initialization arguments + */ + public static String[] getActualInitArgs() { + return Prolog.get_actual_init_args(); + } + + // init + /** + * Initializes the Prolog engine, using the String argument + * parameters passed. This method need be called only if you want to both + * (i) initialise the Prolog engine with parameters other than the default ones + * and (ii) force initialisation to occur + * (rather than allow it to occur automatically at the first query). + * For parameter options, consult your local + * Prolog documentation. The parameter values are passed directly + * to initialization routines for the Prolog environment. + * + * This method must be called before making any queries. + * + * @param args Initialization parameter list + */ + public static boolean init(String[] args) { + return Prolog.set_default_init_args(args) && init(); + } + + // init + /** + * Initialises the Prolog engine using the current default initialisation parameters, + * and returns 'true' (or 'false' if already initialised). + */ + public static boolean init() { + return Prolog.initialise(); + } + + // isTag(String) + /** + * whether the String arg is a plausible tag, e.g. "J#0123456789". + */ + public static boolean isTag(String s) { + return s.length()==22 && s.charAt(0)=='J' && s.charAt(1)=='#' && Character.isDigit(s.charAt(2)) && Character.isDigit(s.charAt(3)) && Character.isDigit(s.charAt(4)) && Character.isDigit(s.charAt(5)) && Character.isDigit(s.charAt(6)) && Character.isDigit(s.charAt(7)) && Character.isDigit(s.charAt(8)) && Character.isDigit(s.charAt(9)) && Character.isDigit(s.charAt(10)) && Character.isDigit(s.charAt(11)) && Character.isDigit(s.charAt(12)) && Character.isDigit(s.charAt(13)) && Character.isDigit(s.charAt(14)) && Character.isDigit(s.charAt(15)) && Character.isDigit(s.charAt(16)) && Character.isDigit(s.charAt(17)) && Character.isDigit(s.charAt(18)) && Character.isDigit(s.charAt(19)) && Character.isDigit(s.charAt(20)) && Character.isDigit(s.charAt(21)); + } + + // newJRef(Object) + /** + * returns a new Term instance which represents the given object + */ + public static Term newJRef(Object obj) { + return new Compound( "@", new Term[]{new Atom(Prolog.object_to_tag(obj))}); + } + + // halt + /** + * Terminates the Prolog session. + * + * Note. This method calls the FLI halt() method with a + * status of 0, but the halt method currently is a no-op in SWI. + * @deprecated + */ + public static void halt() { + Prolog.halt(0); + } + + // a static reference to the current Version + private static final Version version_ = new Version(); + + // version + /** + * Returns (as a Version) an identification of this version of JPL. + * @return the running version of JPL. + */ + public static Version version() { + return version_; + } + + // version_string + /** + * Returns a String (eg "3.0.0-alpha") identifying this version of JPL. + * @return a String (eg "3.0.0-alpha") identifying this version of JPL. + */ + public static String version_string() { + return version_.major + "." + version_.minor + "." + version_.patch + "-" + version_.status; + } + + public static void main(String[] args) { + System.out.println(version_string()); + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/JPLException.java b/packages/jpl/src/java/jpl/JPLException.java new file mode 100644 index 000000000..7782516ee --- /dev/null +++ b/packages/jpl/src/java/jpl/JPLException.java @@ -0,0 +1,63 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +//----------------------------------------------------------------------/ +// JPLException +/** + * This is the base class for exceptions thrown by JPL's Java-calls-Prolog interface. + * Such exceptions represent errors and exceptional conditions within the interface code itself; + * see jpl.PrologException for the way Prolog exceptions are returned to calling Java code. + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public class JPLException extends RuntimeException { + private static final long serialVersionUID = 1L; + + public JPLException() { + super(); + } + + public JPLException(String s) { + super(s); + } +} diff --git a/packages/jpl/src/java/jpl/JRef.java b/packages/jpl/src/java/jpl/JRef.java new file mode 100644 index 000000000..3f7f52559 --- /dev/null +++ b/packages/jpl/src/java/jpl/JRef.java @@ -0,0 +1,215 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Map; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// JRef +/** + * JRef is a specialised Term with an Object field, representing JPL's Prolog references to Java objects (or to null). + * 
    + * JRef r = new JRef( non_String_object_or_null );
+ *
    + * A JRef can be used (and re-used) in Compound Terms. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + * @see jpl.Term + * @see jpl.Compound + * + * @deprecated + */ +public class JRef extends Term { + + //==================================================================/ + // Attributes + //==================================================================/ + + /** + * the JRef's value (a non-String Object or null) + */ + protected final Object ref; + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * This constructor creates a JRef, initialized with the supplied + * non-String object (or null). + * + * @param ref this JRef's value (a non-String object, or null) + */ + public JRef(Object ref) { + if (ref instanceof String) { + throw new JPLException("a JRef cannot have a String value (String maps to atom)"); + } else { + this.ref = ref; + } + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + public Term arg(int ano) { + return (ano == 1 ? new Atom(jpl.fli.Prolog.object_to_tag(ref)) : null); + } + + /** + * Returns a Prolog source text representation of this JRef + * + * @return a Prolog source text representation of this JRef + */ + public String toString() { + return "" + ref + ""; // WRONG + } + + /** + * Two JRefs are equal if their references are identical (?) + * + * @param obj The Object to compare + * @return true if the Object satisfies the above condition + */ + public final boolean equals(Object obj) { + return this == obj || (obj instanceof JRef && ref == ((JRef) obj).ref); + } + + public final int type() { + return Prolog.JREF; + } + + public String typeName(){ + return "JRef"; + } + + //==================================================================/ + // Methods (peculiar) + //==================================================================/ + + /** + * The non-String object (or null) which this jpl.JRef represents + * + * @return the non-String object (or null) which this jpl.JRef represents + */ + public Object ref() { + return ref; + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * The (nonexistent) args of this JRef + * + * @return the (nonexistent) args of this JRef + * @deprecated + */ + public Term[] args() { + return new Term[] { + }; + } + + /** + * Returns a debug-friendly representation of this JRef + * + * @return a debug-friendly representation of this JRef + * @deprecated + */ + public String debugString() { + return "(JRef " + toString() + ")"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + + /** + * To convert a JRef to a term, we put its Object field (.value) into the + * term_t as a JPL ref (i.e. @/1) structure. + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (newly created) term_t which is to be + * set to a Prolog 'ref' (i.e. @/1) structure denoting the + * .value of this JRef instance + */ + protected final void put(Map varnames_to_vars, term_t term) { + + Prolog.put_jref(term, ref); + } + + //==================================================================/ + // Computing Substitutions + //==================================================================/ + + /** + * Nothing needs to be done if the Term is an Atom, Integer, Float or JRef + * + * @param varnames_to_Terms A Map from variable names to Terms. + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + } + + public boolean hasFunctor(String name, int arity) { + return name != null && name.equals("@") && arity == 1; + } + + public boolean hasFunctor(int value, int arity) { + return false; + } + + public boolean hasFunctor(double value, int arity) { + return false; + } + + public Object jrefToObject() { + return ref; + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/PrologException.java b/packages/jpl/src/java/jpl/PrologException.java new file mode 100644 index 000000000..d990923b7 --- /dev/null +++ b/packages/jpl/src/java/jpl/PrologException.java @@ -0,0 +1,75 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +//----------------------------------------------------------------------/ +// PrologException +/** + * PrologException instances wrap Prolog exceptions thrown (either by a Prolog engine or by user code) + * in the course of finding a solution to a Query. See JPLException for the handling of errors within the JPL Java-calls-Prolog interface. + * + * This class allows Java code which uses JPL's Java-calls-Prolog API to handle + * Prolog exceptions, which is in general necessary for hybrid Java+Prolog programming. + * + * Use the term() accessor to obtain a Term representation of the term that was + * thrown from within Prolog. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public final class PrologException extends JPLException { + private static final long serialVersionUID = 1L; + private Term term_ = null; + + protected PrologException(Term term) { + super("PrologException: " + term.toString()); + + this.term_ = term; + } + + /** + * @return a reference to the Term thrown by the call to throw/1 + */ + public Term term() { + return this.term_; + } +} diff --git a/packages/jpl/src/java/jpl/Query.java b/packages/jpl/src/java/jpl/Query.java new file mode 100644 index 000000000..75fea1ec6 --- /dev/null +++ b/packages/jpl/src/java/jpl/Query.java @@ -0,0 +1,873 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Enumeration; +import java.util.Hashtable; +import java.util.Map; +import java.util.Vector; +import jpl.fli.*; + +//----------------------------------------------------------------------/ +// Query +/** + * A Query instance is created by an application in order to query the Prolog database + * (or to invoke a built-in predicate). + * It is initialised with a + * Compound (or Atom) denoting the goal which is to be called, and also contains assorted private state + * relating to solutions. In some future version, it may contain details of the module + * in which the goal is to be called. + * A Query is either open or closed: when closed, it has no connection to the Prolog system; + * when open, it is linked to an active goal within a Prolog engine. + * The Query class implements the Enumeration interface, + * through which one can obtain successive solutions. The Enumeration + * hasMoreElements() method returns true if the call or redo succeeded (otherwise + * false), and if the call or redo did succeed, the nextElement() method returns + * a Hashtable representing variable bindings; the elements in the + * Hashtable are Terms, indexed by the (String) names of the Variables with which they are associated. + * For example, if p(a) and p(b) are facts in the Prolog + * database, then the following is equivalent to printing all + * the solutions to the Prolog query p(X): + * 
    + * Variable X = new Variable("X");
+ * Term arg[] = { X };
+ * Query    q = new Query("p", arg);
+ * 
+ * while (q.hasMoreElements()){
+ *     Term bound_to_x = ((Hashtable) q.nextElement()).get("X");
+ *     System.out.println(bound_to_x);
+ * }
+ *
    + * Make sure to close the Query (using the close() method) if you do not need + * any further solutions which it may have. + * It is safe (although redundant) to close a Query whose solutions are already exhausted, + * or which is already closed. + * + * To obtain just one solution from a Query, use the oneSolution() method. + * + * To obtain all solutions, use the allSolutions() method. + * + * To obtain at most N solutions, use the nSolutions() method. + * + * To determine merely whether the Query is provable, + * use the hasSolution() method + * (i.e. has at least one solution). + * + * + * Copyright (C) 2007 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class Query implements Enumeration { + //==================================================================/ + // Attributes + //==================================================================/ + private static Map m = new Hashtable(); // maps (engine_t) engine handle to (Query) topmost query + /** + * the Compound (hence perhaps an Atom, but not Integer, Float or Variable) corresponding to the goal of this Query + */ + protected final Compound goal_; // set by all initialisers + protected final String hostModule = "user"; // until revised constructors allow this to be specified + protected final String contextModule = "user"; // until revised constructors allow this to be specified + /** + * @deprecated Use .goal().name() instead. + * @return the name of this Query's goal (redundant, deprecated) + */ + public final String name() { + return goal_.name(); // it can only be a Compound or Atom + } + /** + * @deprecated Use .goal().args() instead. + * @return the arguments of this Query's goal (redundant, deprecated) + */ + public final Term[] args() { + return goal_.args(); + } + /** + * Returns the Compound (hence perhaps an Atom) which is the goal of this Query + * @return a Term representing the goal of this Query + */ + public final Compound goal() { + return goal_; + } + //==================================================================/ + // Constructors and Initialization + //==================================================================/ + //------------------------------------------------------------------/ + // Query + /** + * This constructor creates a Query whose goal is the specified Term. + * The Query is initially closed. + * NB Creating an instance of the Query class does not + * result in a call to a Prolog engine. + * NB The goal can be a Compound or an Atom (Atom extends Compound), but cannot be an instance + * of jpl.Float, jpl.Integer or jpl.Variable. + * @param t the goal of this Query + */ + public Query(Term t) { // formerly insisted (confusingly) on a Compound (or Atom) + this.goal_ = Query1(t); + } + private Compound Query1(Term t) { + if (t instanceof Compound) { + return (Compound) t; + } else if (t instanceof Integer) { + throw new JPLException("a Query's goal must be an Atom or Compound (not an Integer)"); + } else if (t instanceof Float) { + throw new JPLException("a Query's goal must be an Atom or Compound (not a Float)"); + } else if (t instanceof Variable) { + throw new JPLException("a Query's goal must be an Atom or Compound (not a Variable)"); + } else { + throw new JPLException("a Query's goal must be an Atom or Compound"); + } + } + // Query + /** + * If text denotes an atom, this constructor is shorthand for + * new Query(new Compound(name,args)), + * but if text denotes a term containing N query (?) symbols + * and there are N args, each query is replaced by its corresponding arg + * to provide the new Query's goal. + * + * @param text the name of the principal functor of this Query's goal + * @param args the arguments of this Query's goal + */ + public Query(String text, Term[] args) { + this(Query1(text, args)); + } + // convenience case for a single arg + public Query(String text, Term arg) { + this(Query1(text, new Term[] { arg })); + } + private static Term Query1(String text, Term[] args) { + Term t = Util.textToTerm(text); + if (t instanceof Atom) { + return new Compound(text, args); + } else { + return t.putParams(args); + } + } + // Query + /** + * This constructor builds a Query from the given Prolog source text. + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text the Prolog source text of this Query + */ + public Query(String text) { + this(Util.textToTerm(text)); + } + //==================================================================/ + // Making Prolog Queries + //==================================================================/ + /** + * These variables are used and set across the hasMoreElements + * and nextElement Enumeration interface implementation + */ + private boolean open = false; + // the following state variables are used and defined only if this query is open: + // private boolean called = false; // open/get/close vs. hasMoreSolutions/nextSolution + private engine_t engine = null; // handle of attached Prolog engine iff open, else null + private Query subQuery = null; // the open Query (if any) on top of which this open Query is stacked, else null + private predicate_t predicate = null; // handle of this Query's predicate iff open, else undefined + private fid_t fid = null; // id of current Prolog foreign frame iff open, else null + private term_t term0 = null; // term refs of this Query's args iff open, else undefined + private qid_t qid = null; // id of current Prolog query iff open, else null + // + /** + * isOpen() returns true iff the query is open. + * @return true if the query is open, otherwise false. + */ + public synchronized final boolean isOpen() { + return open; + } + //------------------------------------------------------------------/ + // hasMoreSolutions + /** + * This method returns true if JPL was able to initiate a "call" of this + * Query within a Prolog engine. It is designed to be used + * with the nextSolution() method to retrieve one or + * more substitutions in the form of Hashtables. To iterate through + * all the solutions to a Query, for example, one might write + * 
    +	 * Query q = // obtain Query reference
+	 * while (q.hasMoreSolutions()) {
+	 *     Hashtable solution = q.nextSolution();
+	 *     // process solution...
+	 * }
+	 *
    + * To ensure thread-safety, you should wrap sequential calls to + * this method in a synchronized block, using the static + * lock method to obtain the monitor. + * 
    +	 * Query q = // obtain Query reference
+	 * synchronized ( jpl.Query.lock() ){
+	 *     while ( q.hasMoreElements() ){
+	 *          Hashtable solution = q.nextSolution();
+	 *          // process solution...
+	 *     }
+	 * }
+	 *
    + * + * @return true if the Prolog query succeeds; otherwise false. + */ + public synchronized final boolean hasMoreSolutions() { + if (!open) { + open(); + } + return get1(); + } + //------------------------------------------------------------------/ + // open + /** + * This method returns true if JPL was able to initiate a "call" of this + * Query within the Prolog engine. It is designed to be used + * with the getSolution() and close() methods to retrieve one or + * more substitutions in the form of Hashtables. + * 
    +	 * Query q = // obtain Query reference
+	 * Hashtable soln;
+	 * q.open();
+	 * while ((soln = q.getSolution()) != null) {
+	 *      // process solution...
+	 * }
+	 *
    + * + * If this method is called on an already-open Query, + * or if the query cannot be set up for whatever reason, + * then a JPLException will be thrown. + */ + public synchronized final void open() { + if (open) { + throw new JPLException("Query is already open"); + } + // int self = Prolog.thread_self(); + // System.out.println("JPL thread_self()=" + self); + if (Prolog.thread_self() == -1) { // this Java thread has no attached Prolog engine? + engine = Prolog.attach_pool_engine(); // may block for a while, or fail + // System.out.println("JPL attaching engine[" + engine.value + "] for " + this.hashCode() + ":" + this.toString()); + } else { // this Java thread has an attached engine + engine = Prolog.current_engine(); + // System.out.println("JPL reusing engine[" + engine.value + "] for " + this.hashCode() + ":" + this.toString()); + } + if (m.containsKey(new Long(engine.value))) { + subQuery = (Query) m.get(new Long(engine.value)); // get this engine's previous topmost query + // System.out.println("JPL reusing engine[" + engine.value + "] pushing " + subQuery.hashCode() + ":" + subQuery.toString()); + } else { + subQuery = null; + } + m.put(new Long(engine.value), this); // update this engine's topmost query + // + // here, we must check for a module prefis, e.g. jpl:jpl_modifier_bit(volatile,T) + String module; + Term goal; + if (goal_.hasFunctor(":", 2)) { + if (goal_.arg(1).isAtom()) { + module = goal_.arg(1).name(); + } else if (goal_.arg(1).isVariable()) { + throw new PrologException(Util.textParamsToTerm("error(instantiation_error,?)", new Term[] { goal_ })); + } else { + throw new PrologException(Util.textParamsToTerm("error(type_error(atom,?),?)", new Term[] { goal_.arg(1), goal_ })); + } + goal = goal_.arg(2); + } else { + module = contextModule; + goal = goal_; + } + predicate = Prolog.predicate(goal.name(), goal.arity(), module); // was hostModule + fid = Prolog.open_foreign_frame(); + Map varnames_to_vars = new Hashtable(); + term0 = Term.putTerms(varnames_to_vars, goal.args()); + // THINKS: invert varnames_to_Vars and use it when getting substitutions? + qid = Prolog.open_query(Prolog.new_module(Prolog.new_atom(contextModule)), Prolog.Q_CATCH_EXCEPTION, predicate, term0); + open = true; + // called = false; + } + private final boolean get1() { // try to get the next solution; if none, close the query; + if (Prolog.next_solution(qid)) { + // called = true; // OK to call get2() + return true; + } else { + // if failure was due to throw/1, build exception term and throw it + term_t exception_term_t = Prolog.exception(qid); + if (exception_term_t.value != 0L) { + Term exception_term = Term.getTerm(new Hashtable(), exception_term_t); + close(); + throw new PrologException(exception_term); + } else { + close(); + return false; + } + } + } + //------------------------------------------------------------------/ + // getSolution + /** + * This method returns a java.util.Hashtable, which represents + * a set of bindings from the names of query variables to terms within the solution. + * + * For example, if a Query has an occurrence of a jpl.Variable, + * say, named "X", one can obtain the Term bound to "X" in the solution + * by looking up "X" in the Hashtable. + * 
    +	 * Variable x = new Variable("X");
+	 * Query q = // obtain Query reference (with x in the Term array)
+	 * while (q.hasMoreSolutions()) {
+	 *     Hashtable solution = q.nextSolution();
+	 *     // make t the Term bound to "X" in the solution
+	 *     Term t = (Term) solution.get("X");
+	 *     // ...
+	 * }
+	 *
    + * Programmers should obey the following rules when using this method. + * + *
  • The nextSolution() method should only be called after the + * hasMoreSolutions() method returns true; otherwise a JPLException + * will be raised, indicating that the Query is no longer open. + *
  • The nextSolution() and hasMoreSolutions() should be called + * in the same thread of execution, for a given Query + * instance. + *
    • + * + * This method will throw a JPLException if Query is not open. + * + * @return A Hashtable representing a substitution, or null + */ + public synchronized final Hashtable getSolution() { + // oughta check: thread has query's engine + if (!open) { + throw new JPLException("Query is not open"); + } else if (get1()) { + return get2(); + } else { + return null; + } + } + public synchronized final Hashtable getSubstWithNameVars() { + // oughta check: thread has query's engine + if (!open) { + throw new JPLException("Query is not open"); + } else if (get1()) { + return get2WithNameVars(); + } else { + return null; + } + } + //------------------------------------------------------------------/ + // nextSolution + /** + * This method returns a java.util.Hashtable, which represents + * a binding from the names of query variables to terms within the solution. + * + * For example, if a Query has an occurrence of a jpl.Variable, + * say, named "X", one can obtain the Term bound to "X" in the solution + * by looking up "X" in the Hashtable. + * 
    +	 * Variable x = new Variable("X");
+	 * Query q = // obtain Query reference (with x in the Term array)
+	 * while (q.hasMoreSolutions()) {
+	 *     Hashtable solution = q.nextSolution();
+	 *     // make t the Term bound to "X" in the solution
+	 *     Term t = (Term) solution.get("X");
+	 *     // ...
+	 * }
+	 *
    + * Programmers should obey the following rules when using this method. + * + *
  • The nextSolution() method should only be called after the + * hasMoreSolutions() method returns true; otherwise a JPLException + * will be raised, indicating that the Query is no longer open. + *
  • The nextSolution() and hasMoreSolutions() should be called + * in the same thread of execution, for a given Query + * instance. + *
    • + * + * This method will throw a JPLException if Query is not open. + * + * @return A Hashtable representing a substitution. + */ + public synchronized final Hashtable nextSolution() { + return get2(); + } + private final Hashtable get2() { + if (!open) { + throw new JPLException("Query is not open"); + } else { + Hashtable substitution = new Hashtable(); + // NB I reckon computeSubstitutions needn't be in Term (but where else?) + Term.getSubsts(substitution, new Hashtable(), goal_.args); + return substitution; + } + } + // assumes that Query's last arg is a Variable which will be bound to a [Name=Var,..] dict + private final Hashtable get2WithNameVars() { + if (!open) { + throw new JPLException("Query is not open"); + } else { + Term[] args = goal_.args; // for slight convenience below + Term argNV = args[args.length - 1]; // the Query's last arg + String nameNV = ((Variable) argNV).name; // its name + // get the [Name=Var,..] dict from the last arg + Map varnames_to_Terms1 = new Hashtable(); + Map vars_to_Vars1 = new Hashtable(); + args[args.length - 1].getSubst(varnames_to_Terms1, vars_to_Vars1); + Hashtable varnames_to_Terms2 = new Hashtable(); + Term nvs = (Term) varnames_to_Terms1.get(nameNV); + Map vars_to_Vars2 = Util.namevarsToMap(nvs); + for (int i = 0; i < args.length - 1; ++i) { + args[i].getSubst(varnames_to_Terms2, vars_to_Vars2); + } + return varnames_to_Terms2; + } + } + //------------------------------------------------------------------/ + // hasMoreElements + /** + * This method implements part of the java.util.Enumeration + * interface. It is a wrapper for hasMoreSolutions. + * + * @return true if the Prolog query yields a (or another) solution, else false. + */ + public synchronized final boolean hasMoreElements() { + return hasMoreSolutions(); + } + //------------------------------------------------------------------/ + // nextElement + /** + * This method implements part of the java.util.Enumeration + * interface. It is a wrapper for nextSolution. + * + * + * @return A Hashtable representing a substitution. + */ + public synchronized final Object nextElement() { + return nextSolution(); + } + public synchronized final void rewind() { + close(); + } + /** + * This method can be used to close an open query before its solutions are exhausted. + * It is called automatically when solutions are exhausted, i.e. when hasMoreSolutions() fails. + * Calling close() on an already closed Query is harmless (has no effect). + * + * Here is one way to get the first three solutions to a Query: + * 
    +	 * Query q = new Query(predicate, args);
+	 * Hashtable sub1 = (Hashtable) q.nextSolution();
+	 * Hashtable sub2 = (Hashtable) q.nextSolution();
+	 * Hashtable sub3 = (Hashtable) q.nextSolution();
+	 * q.close();
+	 *
    + */ + public synchronized final void close() { + if (!open) { + return; // it is not an error to attempt to close a closed Query + } + if (Prolog.thread_self() == -1) { + throw new JPLException("no engine is attached to this thread"); + } + if (Prolog.current_engine().value != engine.value) { + throw new JPLException("this Query's engine is not that which is attached to this thread"); + } + Query topmost = (Query) m.get(new Long(engine.value)); + if (topmost != this) { + throw new JPLException("this Query (" + this.hashCode() + ":" + this.toString() + ") is not topmost (" + topmost.hashCode() + ":" + topmost.toString() + ") within its engine[" + + engine.value + "]"); + } + Prolog.close_query(qid); + qid = null; // for tidiness + jpl.fli.Prolog.discard_foreign_frame(fid); + fid = null; // for tidiness + m.remove(new Long(engine.value)); + if (subQuery == null) { // only Query open in this engine? + if (Prolog.current_engine_is_pool()) { // this (Query's) engine is from the pool? + Prolog.release_pool_engine(); + // System.out.println("JPL releasing engine[" + engine.value + "]"); + } else { + // System.out.println("JPL leaving engine[" + engine.value + "]"); + } + } else { + m.put(new Long(engine.value), subQuery); + // System.out.println("JPL retaining engine[" + engine.value + "] popping subQuery(" + subQuery.hashCode() + ":" + subQuery.toString() + ")"); + } + open = false; // this Query is now closed + engine = null; // this Query, being closed, is no longer associated with any Prolog engine + subQuery = null; // this Query, being closed, is not stacked upon any other Query + } + /** + * calls the Query's goal to exhaustion + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * NB in JPL 1.0.1, this method (inconsistently) returned null when a Query had no solutions; + * in JPL 2.x onwards it returns an empty array (thus the length of the array is, in every case, + * the quantity of solutions). + * NB in JPL 1.0.1, bindings were keyed (awkwardly) by Variable instances; + * in JPL 2.x onwards they are keyed by the (String) names of variables, + * which is consistent with the Term type being just a concrete syntax for terms (and hence queries). + */ + public synchronized final Hashtable[] allSolutions() { + if (open) { + throw new JPLException("Query is already open"); + } else { + // get a vector of solutions: + Vector v = new Vector(); + while (hasMoreSolutions()) { + v.addElement(nextSolution()); + } + // turn the vector into an array: + Hashtable solutions[] = new Hashtable[v.size()]; // 0 solutions -> Hashtable[0] + v.copyInto(solutions); + return solutions; + } + } + /** + * This static method creates a Query whose goal is the given Term, + * calls it to exhaustion, + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * Throws JPLException if goal is neither a jpl.Atom nor a jpl.Compound. + * + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * + * @param goal the goal of this Query + */ + public static final Hashtable[] allSolutions(Term goal) { + return (new Query(goal)).allSolutions(); + } + /** + * This static method creates a Query from the given Prolog source text fragment, + * calls it to exhaustion, + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * + * @param text a Prolog source text fragment denoting a goal + */ + public static final Hashtable[] allSolutions(String text) { + return (new Query(text)).allSolutions(); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols and there are N accompanying Term params, + * this static method replaces each questionmark symbol by its respective param, + * calls the resulting goal to exhaustion, + * and returns an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found). + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of the goal and params are the args; + * the resulting goal is then called as above. + * This letter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @return an array of zero or more Hashtables of zero or more variablename-to-term bindings (each Hashtable represents a solution, in the order in which they were found) + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final Hashtable[] allSolutions(String text, Term[] params) { + return (new Query(text, params)).allSolutions(); + } + /** + * calls the Query's goal to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * @return an array of Hashtables (possibly none), each of which is a solution + * (in the order in which they were found) of the Query; at most 'n' solutions will be found and returned. + * NB in JPL 1.0.1, this method (inconsistently) returned null when a Query had no solutions; + * in JPL 2.x onwards it returns an empty array (thus the length of the array is, in every case, + * the quantity of solutions). + * NB in JPL 1.0.1, bindings were keyed (awkwardly) by Variable instances; + * in JPL 2.x onwards they are keyed by the (String) names of variables, + * which is consistent with the Term type being just a concrete syntax for terms (and hence queries). + */ + public synchronized final Hashtable[] nSolutions(long n) { + if (open) { + throw new JPLException("Query is already open"); + } else { + // get a vector of solutions: + Vector v = new Vector(); + for (long i = 0; i++ < n && hasMoreSolutions();) { + v.addElement(nextSolution()); + } + // turn the vector into an array: + Hashtable solutions[] = new Hashtable[v.size()]; // 0 solutions -> Hashtable[0] + v.copyInto(solutions); + return solutions; + } + } + /** + * This static method creates a Query whose goal is the given Term, + * calls it to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * Throws JPLException if goal is neither a jpl.Atom nor a jpl.Compound. + * + * @param goal the goal of this Query + */ + public static final Hashtable[] nSolutions(Term goal, long n) { + return (new Query(goal)).nSolutions(n); + } + /** + * This static method creates a Query from the given Prolog source text fragment, + * calls it to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text a Prolog source text fragment denoting a goal + */ + public static final Hashtable[] nSolutions(String text, long n) { + return (new Query(text)).nSolutions(n); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols and there are N accompanying params, + * this static method replaces each questionmark symbol by its respective param, + * calls the resulting goal to exhaustion or until N solutions are found, whichever is sooner, + * and returns an array containing (as possibly empty Hashtables of variablename-to-term bindings) every found solution (in the order in which they were found). + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of the goal and params are the args; + * the resulting goal is then called as above. + * This latter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final Hashtable[] nSolutions(String text, Term[] params, long n) { + return (new Query(text, params)).nSolutions(n); + } + /** + * Returns the first solution, if any, as a (possibly empty) Hashtable of variablename-to-term bindings, else null. + * + * This method will throw a JPLException if this Query is already open (and the Query will remain open as before). + * Otherwise, upon return, the Query will be closed. + * @return the first solution, if the query has one, as a (possibly empty) Hashtable. + * If the return value is null, this means that the Query has no solutions. + */ + public synchronized final Hashtable oneSolution() { + if (open) { + throw new JPLException("Query is already open"); + } else { + Hashtable solution; + if (hasMoreSolutions()) { + solution = nextSolution(); + close(); // safe, whether or not this is the only solution + } else { + solution = null; + } + return solution; + } + } + /** + * This static method creates a Query (whose goal is the specified Term) + * and calls it at most once, returning the first solution, if there is one, as a (possibly empty) Hashtable, else null. + * The goal can be a jpl.Atom or a jpl.Compound, but cannot be an instance + * of jpl.Float, jpl.Integer or jpl.Variable. + * + * @param goal the goal of this Query + */ + public static final Hashtable oneSolution(Term goal) { + return (new Query(goal)).oneSolution(); + } + /** + * This static method creates a Query from the given Prolog source text fragment, + * and calls it at most once, returning the first solution, if there is one, as a (possibly empty) Hashtable, else null. + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text a Prolog source text fragment denoting a goal + */ + public static final Hashtable oneSolution(String text) { + return (new Query(text)).oneSolution(); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols + * and there are N params, each questionmark symbol is replaced by its respective param + * to provide the goal of this query: + * the resulting goal is then called (at most once) and the first solution, if there is one, is returned as a (possibly empty) Hashtable, else null. + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of the goal and params are the args; + * the resulting goal is then called as above. + * This latter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final Hashtable oneSolution(String text, Term[] params) { + return (new Query(text, params)).oneSolution(); + } + /** + * This method will attempt to call this Query's goal within an available Prolog engine. + * @return the provability of the Query, i.e. 'true' if it has at least + * one solution, 'false' if the call fails without finding a solution. + * + * Only the first solution (if there is one) will be found; + * any bindings will be discarded, and the Query will be closed. + * This method will throw a JPLException if this Query is already open. + * + * @deprecated Use .hasSolution() instead. + */ + public synchronized final boolean query() { + return oneSolution() != null; + } + /** + * This method will attempt to call this Query's goal within an available Prolog engine. + * @return the provability of the Query, i.e. 'true' if it has at least + * one solution, 'false' if the call fails without finding a solution. + * + * Only the first solution (if there is one) will be found; + * any bindings will be discarded, and the Query will be closed. + * This method will throw a JPLException if this Query is already open. + */ + public synchronized final boolean hasSolution() { + return oneSolution() != null; + } + /** + * This static method creates a Query (whose goal is the specified Term) + * and calls it at most once, returning true if a solution was found, else false. + * The goal can be a jpl.Atom or a jpl.Compound, but cannot be an instance + * of jpl.Float, jpl.Integer or jpl.Variable. + * + * @param goal the goal of this Query + */ + public static final boolean hasSolution(Term goal) { + return (new Query(goal)).hasSolution(); + } + /** + * This static method creates a Query from the given Prolog source text + * and calls it at most once, returning true if a solution was found, else false. + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text the goal of this Query, as Prolog source text + */ + public static final boolean hasSolution(String text) { + return (new Query(text)).hasSolution(); + } + /** + * If text denotes (in traditional Prolog source syntax) a term containing N questionmark (?) symbols + * and there are N params, each questionmark symbol is replaced by its corresponding arg + * to provide the new Query's goal: the resulting Query is called as described above. + * + * Otherwise, if text denotes an atom, this static method creates a Query + * where text is the name of its goal and args are its args; + * it then calls this goal (at most once) and returns true if a solution was found, else false. + * This latter mode is redundant, deprecated (informally), and retained only for backward compatibility. + * + * @param text the Prolog source text of a goal, in which questionmarks are regarded as substitutible parameters + * @param params terms to be substituted for the respective questionmarks in the query text + */ + public static final boolean hasSolution(String text, Term[] params) { + return (new Query(text, params)).hasSolution(); + } + // + // this method doesn't work, but is intended to be called from another thread, + // to abort a Query which is open and possibly currently executing nextSolution() or similar + public final int abort() { + if (open) { + (new Thread(new Runnable() { + public void run() { + try { + int rc1 = Prolog.attach_engine(engine); + System.out.println("q.abort(): attach_engine() returns " + rc1); + int rc2 = Prolog.action_abort(); + System.out.println("q.abort(): action_abort() returns " + rc2); + // int rc3 = Prolog.release_pool_engine(); + // System.out.println("q.abort(): release_pool_engine() returns " + rc3); + } catch (Exception e) { + } + } + })).start(); // call the query in a separate thread + /* + int rc0a = Prolog.pool_engine_id(this.engine); + System.out.println("q.abort(): this.engine has id=" + rc0a); + + engine_t e = Prolog.current_engine(); + System.out.println("q.abort(): " + (e == null ? "no current engine" : "current engine id=" + Prolog.pool_engine_id(e))); + + int rc0b = Prolog.release_pool_engine(); + System.err.println("q.abort(): release_pool_engine() returns " + rc0b); + + engine_t e2 = Prolog.current_engine(); + System.out.println("q.abort(): " + (e == null ? "no current engine" : "current engine id=" + Prolog.pool_engine_id(e2))); + + int rc1 = Prolog.attach_engine(this.engine); + System.out.println("q.abort(): attach_engine() returns " + rc1); + + engine_t e3 = Prolog.current_engine(); + System.out.println("q.abort(): " + (e == null ? "no current engine" : "current engine id=" + Prolog.pool_engine_id(e3))); + + int rc2 = Prolog.action_abort(); + System.out.println("q.abort(): action_abort() returns " + rc2); + + int rc3 = Prolog.release_pool_engine(); + System.out.println("q.abort(): release_pool_engine() returns " + rc3); + + int rc4 = Prolog.attach_engine(e); + System.out.println("q.abort(): attach_engine() returns " + rc4); + */ + return 0; + } else { + System.out.println("q.abort(): query is not open"); + return -1; + } + } + //==================================================================/ + // misc + //==================================================================/ + /** + * Returns a crude String representation of a Query. + * + * @return a crude String representation of a Query + */ + public String toString() { + return goal_.name + "( " + Term.toString(goal_.args) + " )"; + } + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + /** + * Returns a debug-friendly representation of a Query + * + * @return a debug-friendly representation of a Query + * @deprecated + */ + public String debugString() { + return "(Query " + goal_.name + " " + Term.debugString(goal_.args) + ")"; + } +} diff --git a/packages/jpl/src/java/jpl/Term.java b/packages/jpl/src/java/jpl/Term.java new file mode 100644 index 000000000..46bc7fa67 --- /dev/null +++ b/packages/jpl/src/java/jpl/Term.java @@ -0,0 +1,768 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Hashtable; +import java.util.Iterator; +import java.util.Map; +import jpl.fli.DoubleHolder; +import jpl.fli.Int64Holder; +import jpl.fli.IntHolder; +import jpl.fli.Prolog; +import jpl.fli.StringHolder; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Term +/** + * Term is the abstract base class for + * Compound, Atom, Variable, Integer and Float, which comprise a Java-oriented concrete syntax for Prolog. + * You cannot create instances of Term directly; rather, you should create + * instances of Term's concrete subclasses. + * Alternatively, use textToTerm() to construct a Term from its conventional + * Prolog source text representation. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public abstract class Term { + //==================================================================/ + // Attributes + //==================================================================/ + + //==================================================================/ + // Constructors + //==================================================================/ + + /** + * This default constructor is provided in order for subclasses + * to be able to define their own default constructors. + */ + protected Term() { + } + + //==================================================================/ + // Methods (abstract, common) + //==================================================================/ + + /** + * returns the ano-th (1+) argument of a (Compound) Term + * throws a JPLException for any other subclass + * + * @return the ano-th argument of a (Compound) Term + */ + public abstract Term arg(int ano); + + /** + * returns, as a Term[], the arguments of a Compound + * returns an empty Term[] from an Atom, Integer or Float + * throws a JPLException from a Variable + * + * @return the arguments of a Compound as a Term[ + */ + public abstract Term[] args(); + + /** + * Tests whether this Term's functor has (String) 'name' and 'arity' + * Returns false if called inappropriately + * + * @return whether this Term's functor has (String) 'name' and 'arity' + */ + public abstract boolean hasFunctor(String name, int arity); + + /** + * Tests whether this Term's functor has (int) 'name' and 'arity' + * Returns false if called inappropriately + * + * @return whether this Term's functor has (int) 'name' and 'arity' + */ + public abstract boolean hasFunctor(int value, int arity); + /** + * Tests whether this Term's functor has (double) 'name' and 'arity' + * Returns false if called inappropriately + * + * @return whether this Term's functor has (double) 'name' and 'arity' + */ + public abstract boolean hasFunctor(double value, int arity); + + /** + * returns, as a String, the name of a Compound, Atom or Variable + * throws a JPLException from an Integer or Float + * + * @return the name of a Compound, Atom or Variable + */ + public String name() { + throw new JPLException("jpl." + this.typeName() + ".name() is undefined"); + }; + + /** + * returns, as an int, the arity of a Compound, Atom, Integer or Float + * throws a JPLException from a Variable + * + * @return the arity of a Compound, Atom, Integer or Float + */ + public int arity() { + throw new JPLException("jpl." + this.typeName() + ".arity() is undefined"); + }; + + /** + * returns the value (as an int) of an Integer or Float + * throws a JPLException from a Compound, Atom or Variable + * + * @return the value (as an int) of an Integer or Float + */ + public int intValue() { + throw new JPLException("jpl." + this.typeName() + ".intValue() is undefined"); + } + /** + * returns the value (as a long) of an Integer or Float + * throws a JPLException from a Compound, Atom or Variable + * + * @return the value (as a long) of an Integer or Float + */ + public long longValue() { + throw new JPLException("jpl." + this.typeName() + ".longValue() is undefined"); + } + /** + * returns the value (as a float) of an Integer or Float + * throws a JPLException from a Compound, Atom or Variable + * + * @return the value (as a float) of an Integer or Float + */ + public float floatValue() { + throw new JPLException("jpl." + this.typeName() + ".floatValue() is undefined"); + } + + /** + * returns the value (as a double) of an Integer or Float + * throws a JPLException from any other subclass + * + * @return the value (as an double) of an Integer or Float + */ + public double doubleValue() { + throw new JPLException("jpl." + this.typeName() + ".doubleValue() is undefined"); + } + + //==================================================================/ + // Methods (common) + //==================================================================/ + + /** + * returns the type of this term, as one of jpl.fli.Prolog.COMPOUND, .ATOM, .VARIABLE, .INTEGER, .FLOAT etc + * + * @return the type of this term, as one of jpl.fli.Prolog.COMPOUND, .ATOM, .VARIABLE, .INTEGER, .FLOAT etc + */ + public abstract int type(); + + /** + * returns the name of the type of this term, as one of "Compound", "Atom", "Variable", "Integer", "Float" etc + * + * @return the name of the type of this term, as one of "Compound", "Atom", "Variable", "Integer", "Float" etc + */ + public abstract String typeName(); + + /** + * whether this Term represents an atom + * + * @return whether this Term represents an atom + */ + public boolean isAtom() { + return this instanceof Atom; + } + + /** + * whether this Term represents a compound term + * + * @return whether this Term represents a compound atom + */ + public boolean isCompound() { + return this instanceof Compound; + } + + /** + * whether this Term represents an atom + * + * @return whether this Term represents an atom + */ + public boolean isFloat() { + return this instanceof Float; + } + + /** + * whether this Term represents an atom + * + * @return whether this Term represents an atom + */ + public boolean isInteger() { + return this instanceof Integer; + } + + /** + * whether this Term is a variable + * + * @return whether this Term is a variable + */ + public boolean isVariable() { + return this instanceof Variable; + } + + /** + * whether this Term is a 'jfalse' structure, i.e. @(false) + * + * @return whether this Term is a 'jfalse' structure, i.e. @(false) + */ + public boolean isJFalse() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jtrue' structure, i.e. @(true) + * + * @return whether this Term is a 'jtrue' structure, i.e. @(true) + */ + public boolean isJTrue() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jnull' structure, i.e. @(null) + * + * @return whether this Term is a 'jnull' structure, i.e. @(null) + */ + public boolean isJNull() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jvoid' structure, i.e. @(void) + * + * @return whether this Term is a 'jvoid' structure, i.e. @(void) + */ + public boolean isJVoid() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jobject' structure, i.e. @(Tag) + * + * @return whether this Term is a 'jobject' structure, i.e. @(Tag) + */ + public boolean isJObject() { + return false; // overridden in Compound, where it might sometimes be true + } + + /** + * whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + * + * @return whether this Term is a 'jref' structure, i.e. @(Tag) or @(null) + */ + public boolean isJRef() { + return false; // overridden in Compound, where it might sometimes be true + } + + public abstract Object jrefToObject(); + + // objectToJRef(Object) + /** + * returns a new Term instance which represents the given object + */ + public static Term objectToJRef(Object obj) { + return new Compound( "@", new Term[]{new Atom(Prolog.object_to_tag(obj))}); + } + + public Term putParams(Term[] ps) { + IntHolder next = new IntHolder(); + next.value = 0; + Term t2 = this.putParams1(next, ps); + if (next.value != ps.length) { + throw new JPLException("Term.putParams: more actual params than formal"); + } + return t2; + } + + public Term putParams(Term plist) { + Term[] ps = plist.toTermArray(); + return putParams(ps); + } + + protected Term putParams1(IntHolder next, Term[] ps) { + switch (this.type()) { + case Prolog.COMPOUND : + return new Compound(this.name(), putParams2(this.args(), next, ps)); + case Prolog.ATOM : + if (this.name().equals("?")) { + if (next.value >= ps.length) { + throw new JPLException("Term.putParams: fewer actual params than formal params"); + } + return ps[next.value++]; + } // else drop through to default + default : + return this; + } + } + + static protected Term[] putParams2(Term[] ts, IntHolder next, Term[] ps) { + int n = ts.length; + Term[] ts2 = new Term[n]; + for (int i = 0; i < n; i++) { + ts2[i] = ts[i].putParams1(next, ps); + } + return ts2; + } + + /** + * the length of this list, iff it is one, else an exception is thrown + * + * @throws JPLException + * @return the length (as an int) of this list, iff it is one + */ + public int listLength() { + if (this.hasFunctor(".", 2)) { + return 1 + this.arg(2).listLength(); + } else if (this.hasFunctor("[]", 0)) { + return 0; + } else { + throw new JPLException("Term.listLength: term is not a list"); + } + } + + /** returns an array of terms which are the successive members of this list, if it is a list, else throws an exception + * + * @throws JPLException + * @return an array of terms which are the successive members of this list, if it is a list + */ + public Term[] toTermArray() { + try { + int len = this.listLength(); + Term[] ts = new Term[len]; + Term t = this; + + for (int i = 0; i < len; i++) { + ts[i] = t.arg(1); + t = t.arg(2); + } + return ts; + } catch (JPLException e) { + throw new JPLException("Term.toTermArray: term is not a proper list"); + } + } + + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + + /** + * Returns a debug-friendly representation of a Term + * + * @return a debug-friendly representation of a Term + * @deprecated + */ + public abstract String debugString(); + + /** + * Returns a debug-friendly representation of a list of Terms + * + * @return a debug-friendly representation of a list of Terms + * @deprecated + */ + public static String debugString(Term arg[]) { + String s = "["; + + for (int i = 0; i < arg.length; ++i) { + s += arg[i].debugString(); + if (i != arg.length - 1) { + s += ", "; + } + } + return s + "]"; + } + + //==================================================================/ + // Converting JPL Terms to Prolog terms + // + // To convert a Term to a term_t, we need to traverse the Term + // structure and build a corresponding Prolog term_t object. + // There are some issues: + // + // - Prolog term_ts rely on the *consecutive* nature of term_t + // references. In particular, to build a compound structure + // in the Prolog FLI, one must *first* determine the arity of the + // compound, create a *sequence* of term_t references, and then + // put atoms, functors, etc. into those term references. We + // do this in these methods by first determining the arity of the + // Compound, and then by "put"-ing a type into a term_t. + // The "put" method is implemented differently in each of Term's + // five subclasses. + // + // - What if we are trying to make a term_t from a Term, but the + // Term has multiple instances of the same Variable? We want + // to ensure that _one_ Prolog variable will be created, or else + // queries will give incorrect answers. We thus pass a Hashtable + // (var_table) through these methods. The table contains term_t + // instances, keyed on Variable instances. + //==================================================================/ + + public void put( term_t term){ + put( new Hashtable(), term); + } + /** + * Cache the reference to the Prolog term_t here. + * + * @param varnames_to_vars A Map from variable names to JPL Variables. + * @param term A (previously created) term_t which is to be + * put with a Prolog term-type appropriate to the Term type + * (e.g., Atom, Variable, Compound, etc.) on which the method is + * invoked.) + */ + protected abstract void put(Map varnames_to_vars, term_t term); + + /** + * This static method converts an array of Terms to a *consecutive* + * sequence of term_t objects. Note that the first term_t object + * returned is a term_t class (structure); the succeeding term_t + * objects are consecutive references obtained by incrementing the + * *value* field of the term_t. + * + * @param varnames_to_vars Map from variable names to JPL Variables. + * @param args An array of jpl.Term references. + * @return consecutive term_t references (first of which is + * a structure) + */ + protected static term_t putTerms(Map varnames_to_vars, Term[] args) { + + // first create a sequence of term_ts. The 0th term_t + // will be a jpl.fli.term_t. Successive Prolog term_t + // references will reside in the Prolog engine, and + // can be obtained by term0.value+i. + // + term_t term0 = Prolog.new_term_refs(args.length); + + // for each new term reference, construct a Prolog term + // by putting an appropriate Prolog type into the reference. + // + long ith_term_t = term0.value; + for (int i = 0; i < args.length; ++i, ++ith_term_t) { + term_t term = new term_t(); + term.value = ith_term_t; + args[i].put(varnames_to_vars, term); // each subclass defines its own put() + } + + return term0; + } + + // experiment: for jni_jobject_to_term_byval/2 in jpl.c + public static void putTerm( Object obj, term_t termref){ + if (obj instanceof Term){ + ((Term)obj).put(termref); + } else { + throw new JPLException("not a Term"); + } + } + + //==================================================================/ + // Converting Prolog terms to JPL Terms + // + // Converting back from term_ts to Terms is simple, since + // the (simplified) Term representation is canonical (there is only one + // correct structure for any given Prolog term). + // + // One problem concerns variable bindings. We illustrate + // with several examples. First, consider the Prolog fact + // + // p( f(X,X)). + // + // And the query + // + // ?- p( Y). + // + // A solution should be + // + // y = f(X,X) + // + // and indeed, if this query is run, the term_t to which Y will + // be unified is a compound, f(X,X). The problem is, how do + // we know, in converting the term_ts to Terms in the compound f/2 + // whether we should create one Variable or two? This begs the + // question, how do we _identify_ Variables in JPL? The answer + // to the latter question is, by reference; two Variable (Java) + // references refer to the same variable iff they are, in memory, + // the same Variable object. That is, they satisfy the Java == relation. + // (Note that this condition is _not_ true of the other Term types.) + // + // Given this design decision, therefore, we should create a + // single Variable instance and a Compound instance whose two arg + // values refer to the same Variable object. We therefore need to keep + // track, in converting a term_t to a Term (in particular, in + // converting a term_t whose type is variable to a Variable), of + // which Variables have been created. We do this by using the vars + // Hashtable, which gets passed recursively though the from_term_t + // methods; this table holds the Variable instances that have been + // created, keyed by the unique and internal-to-Prolog string + // representation of the variable (I'm not sure about this...). + //==================================================================/ + + /** + * This method calls from_term_t on each term in the n consecutive term_ts. + * A temporary jpl.term_t "holder" (byref) structure must be created + * in order to extract type information from the Prolog engine. + * + * @param vars_to_Vars A Map from Prolog variables to jpl.Variable instances + * @param n The number of consecutive term_ts + * @param term0 The 0th term_t (structure); subsequent + * term_ts are not structures. + * @return An array of converted Terms + */ + /* + protected static Term[] from_term_ts(Map vars_to_Vars, int n, term_t term0) { + + // create an (uninitialised) array of n Term references + Term[] terms = new Term[n]; + + // for each term_t (from 0...n-1), create a term_t + // (temporary) structure and dispatch the translation + // to a Term to the static from_term_t method of the Term + // class. This will perform (Prolog) type analysis on the + // term_t and call the appropriate static method to create + // a Term of the right type (e.g., Atom, Variable, List, etc.) + // + long ith_term_t = term0.value; + for (int i = 0; i < n; ++i, ++ith_term_t) { + term_t term = new term_t(); + term.value = ith_term_t; + + terms[i] = Term.from_term_t(vars_to_Vars, term); + } + + return terms; + } + */ + + /** + * We discover the Prolog type of the term, then forward the + * call to the appropriate subclass + * + * @param vars A Map from Prolog variables to jpl.Variable instances + * @param term The Prolog term (in a term_t holder) to convert + * @return The converted Term subtype instance. + */ + protected static Term getTerm1(Map vars_to_Vars, term_t term) { + int type = Prolog.term_type(term); + + switch (type) { + case Prolog.VARIABLE : + return Variable.getTerm(vars_to_Vars, term); + case Prolog.ATOM : + return Atom.getTerm(vars_to_Vars, term); + case Prolog.STRING : + return Atom.getString(vars_to_Vars, term); + case Prolog.INTEGER : + return Integer.getTerm(vars_to_Vars, term); + case Prolog.FLOAT : + return Float.getTerm(vars_to_Vars, term); + case Prolog.COMPOUND : + return Compound.getTerm(vars_to_Vars, term); + default : + // should never happen... + throw new JPLException("Term.from_term_t: unknown term type=" + type); + } + } + + protected static Term getTerm(Map vars_to_Vars, term_t term) { + StringHolder hString; + IntHolder hInt; + Int64Holder hInt64; + // int type = Prolog.term_type(term); + switch (Prolog.term_type(term)) { + case Prolog.VARIABLE: + for (Iterator i = vars_to_Vars.keySet().iterator(); i.hasNext();) { + term_t varX = (term_t) i.next(); // a previously seen Prolog variable + if (Prolog.compare(varX, term) == 0) { // identical Prolog variables? + return (Term) vars_to_Vars.get(varX); // return the associated JPL Variable + } + } + // otherwise, the Prolog variable in term has not been seen before + Variable Var = new Variable(); // allocate a new (sequentially named) Variable to represent it + Var.term_ = term; // this should become redundant... + vars_to_Vars.put(term, Var); // use Hashtable(var,null), but only need set(var) + return Var; + case Prolog.ATOM: // return Atom.getTerm(vars_to_Vars, term); + hString = new StringHolder(); + Prolog.get_atom_chars(term, hString); // ignore return val; assume success... + return new Atom(hString.value); + case Prolog.STRING: // return Atom.getString(vars_to_Vars, term); + hString = new StringHolder(); + Prolog.get_string_chars(term, hString); // ignore return val; assume success... + return new Atom(hString.value); + case Prolog.INTEGER: // return Integer.getTerm(vars_to_Vars, term); + hInt64 = new Int64Holder(); + Prolog.get_integer(term, hInt64); // assume it succeeds... + return new jpl.Integer(hInt64.value); + case Prolog.FLOAT: // return Float.getTerm(vars_to_Vars, term); + DoubleHolder hFloatValue = new DoubleHolder(); + Prolog.get_float(term, hFloatValue); // assume it succeeds... + return new jpl.Float(hFloatValue.value); + case Prolog.COMPOUND: // return Compound.getTerm(vars_to_Vars, term); + hString = new StringHolder(); + hInt = new IntHolder(); + Prolog.get_name_arity(term, hString, hInt); // assume it succeeds + Term args[] = new Term[hInt.value]; + // term_t term1 = Prolog.new_term_refs(hArity.value); + for (int i = 1; i <= hInt.value; i++) { + term_t termi = Prolog.new_term_ref(); + Prolog.get_arg(i, term, termi); + args[i - 1] = Term.getTerm(vars_to_Vars, termi); + } + return new Compound(hString.value, args); + default: + // should never happen... + throw new JPLException("Term.from_term_t: unknown term type=" + Prolog.term_type(term)); + } + } + + protected static Term getTerm( term_t term){ + return getTerm( new Hashtable(), term); + } + + //==================================================================/ + // Computing Substitutions + // + // Once a solution has been found, the Prolog term_t references + // will have been instantiated and will refer to new terms. To compute + // a substitution, we traverse the (original) Term structure, looking + // at the term_t reference in the Term. The only case we really care + // about is if the (original) Term is a Variable; if so, the term_t + // back in the Prolog engine may be instantiated (non Variable parts + // of the original Term cannot change or become uninstantiated). In + // this case, we can store this term in a Hashtable, keyed by the + // Variable with which the term was unified. + //==================================================================/ + + //------------------------------------------------------------------/ + // getSubst + /** + * This method computes a substitution from a Term. The bindings + * Hashtable stores Terms, keyed by Variables. Thus, a + * substitution is as it is in mathematical logic, a sequence + * of the form \sigma = {t_0/x_0, ..., t_n/x_n}. Once the + * substitution is computed, the substitution should satisfy + * + * \sigma T = t + * + * where T is the Term from which the substitution is computed, + * and t is the term_t which results from the Prolog query. + * + * A second Hashtable, vars, is required; this table holds + * the Variables that occur (thus far) in the unified term. + * The Variable instances in this table are guaranteed to be + * unique and are keyed on Strings which are Prolog internal + * representations of the variables. + * + * @param bindings table holding Term substitutions, keyed on + * Variables. + * @param vars A Hashtable holding the Variables that occur + * thus far in the term; keyed by internal (Prolog) string rep. + */ + protected abstract void getSubst(Map varnames_to_Terms, Map vars_to_Vars); + + //------------------------------------------------------------------/ + // getSubsts + /** + * Just calls computeSubstitution for each Term in the array. + * + * @param varnames_to_Terms a Map from variable names to Terms + * @param vars_to_Vars a Map from Prolog variables to JPL Variables + * @param arg a list of Terms + */ + protected static void getSubsts(Map varnames_to_Terms, Map vars_to_Vars, Term[] args) { + for (int i = 0; i < args.length; ++i) { + args[i].getSubst(varnames_to_Terms, vars_to_Vars); + } + } + + //------------------------------------------------------------------/ + // terms_equals + /** + * This method is used (by Compound.equals) to determine the Terms in two Term arrays + * are pairwise equal, where two Terms are equal if they satisfy + * the equals predicate (defined differently in each Term subclass). + * + * @param t1 an array of Terms + * @param t2 another array of Terms + * @return true if all of the Terms in the (same-length) arrays are pairwise equal + */ + protected static boolean terms_equals(Term[] t1, Term[] t2) { + if (t1.length != t2.length) { + return false; + } + + for (int i = 0; i < t1.length; ++i) { + if (!t1[i].equals(t2[i])) { + return false; + } + } + return true; + } + + //------------------------------------------------------------------/ + // toString + /** + * Converts a list of Terms to a String. + * + * @param args An array of Terms to convert + * @return String representation of a list of Terms + */ + public static String toString(Term[] args) { + String s = ""; + + for (int i = 0; i < args.length; ++i) { + s += args[i].toString(); + if (i != args.length - 1) { + s += ", "; + } + } + + return s; + } + +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/Util.java b/packages/jpl/src/java/jpl/Util.java new file mode 100644 index 000000000..aedd69a3c --- /dev/null +++ b/packages/jpl/src/java/jpl/Util.java @@ -0,0 +1,281 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Hashtable; +import java.util.Map; + +//----------------------------------------------------------------------/ +// Util +/** + * This class provides a bunch of static utility methods for the JPL + * High-Level Interface. + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public final class Util { + //------------------------------------------------------------------/ + // termArrayToList + /** + * Converts an array of Terms to a JPL representation of a Prolog list of terms + * whose members correspond to the respective array elements. + * + * @param terms An array of Term + * @return Term a list of the array elements + */ + public static Term termArrayToList(Term[] terms) { + Term list = new Atom("[]"); + + for (int i = terms.length - 1; i >= 0; --i) { + list = new Compound(".", new Term[] { terms[i], list }); + } + return list; + } + + /** + * Converts a solution hashtable to an array of Terms. + * + * @param varnames_to_Terms A Map from variable names to Terms + * @return Term[] An array of the Terms to which successive variables are bound + */ + public static Term[] bindingsToTermArray(Map varnames_to_Terms) { + Term[] ts = new Term[varnames_to_Terms.size()]; + + for (java.util.Iterator i = varnames_to_Terms.keySet().iterator(); i.hasNext();) { + Variable k = (Variable) i.next(); + ts[k.index] = (Term) (varnames_to_Terms.get(k)); + } + return ts; + } + + //------------------------------------------------------------------/ + // toString + /** + * Converts a substitution, in the form of a Map from variable names to Terms, to a String. + * + * @param varnames_to_Terms A Map from variable names to Terms. + * @return String A String representation of the variable bindings + */ + public static String toString(Map varnames_to_Terms) { + if (varnames_to_Terms == null) { + return "[no solution]"; + } + java.util.Iterator varnames = varnames_to_Terms.keySet().iterator(); + + String s = "Bindings: "; + while (varnames.hasNext()) { + String varname = (String) varnames.next(); + s += varname + "=" + varnames_to_Terms.get(varname).toString() + "; "; + } + return s; + } + + //------------------------------------------------------------------/ + // namevarsToMap + /** + * Converts a (JPL) list of Name=Var pairs (as yielded by atom_to_term/3) + * to a Map from Prolog variables (necessarily in term_t holders) to named JPL Variables + * + * @param nvs A JPL list of Name=Var pairs (as yielded by atom_to_term/3) + * @return Map A Map from Prolog variables (necessarily in term_t holders) to named JPL Variables + */ + public static Map namevarsToMap(Term nvs) { + + try { + Map vars_to_Vars = new Hashtable(); + + /* + while (nvs.hasFunctor(".", 2) && ((Compound) nvs).arg(1).hasFunctor("=", 2)) { + Atom name = (Atom) ((Compound) ((Compound) nvs).arg(1)).arg(1); // get the Name of the =/2 pair + Variable var = (Variable) ((Compound) ((Compound) nvs).arg(1)).arg(2); // get the Var of the =/2 pair + + vars_to_Vars.put(var.term_, new Variable(name.name())); // map the Prolog variable to a new, named Variable + nvs = ((Compound) nvs).arg(2); // advance to next list cell + } + */ + while (nvs.hasFunctor(".", 2) && nvs.arg(1).hasFunctor("=", 2)) { + // the cast to Variable is necessary to access the (protected) .term_ field + vars_to_Vars.put(((Variable)nvs.arg(1).arg(2)).term_, new Variable(nvs.arg(1).arg(1).name())); // map the Prolog variable to a new, named Variable + nvs = nvs.arg(2); // advance to next list cell + } + + // maybe oughta check that nvs is [] ? + return vars_to_Vars; + } catch (java.lang.ClassCastException e) { // nvs is not of the expected structure + return null; + } + } + + //------------------------------------------------------------------/ + // textToTerm + /** + * Converts a Prolog source text to a corresponding JPL Term + * (in which each Variable has the appropriate name from the source text). + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text A Prolog source text denoting a term + * @return Term a JPL Term equivalent to the given source text + */ + public static Term textToTerm(String text) { + // it might be better to use PL_chars_to_term() + Query q = new Query(new Compound("atom_to_term", new Term[] { new Atom(text), new Variable("Term"), new Variable("NVdict")})); + q.open(); + Map s = q.getSubstWithNameVars(); + if (s != null) { + q.close(); + return (Term) s.get("Term"); + } else { + return null; + } + } + // + // textParamsToTerm + /** + * Converts a Prolog source text to a corresponding JPL Term (in which each Variable has the appropriate name from the source text), replacing successive occurrences of ? in the text by the + * corresponding element of Term[] params. (New in JPL 3.0.4) + * + * Throws PrologException containing error(syntax_error(_),_) if text is invalid. + * + * @param text + * A Prolog source text denoting a term + * @return Term a JPL Term equivalent to the given source text + */ + public static Term textParamsToTerm(String text, Term[] params) { + return Util.textToTerm(text).putParams(params); + } + // + /** + * Converts an array of String to a corresponding JPL list + * + * @param a + * An array of String objects + * @return Term a JPL list corresponding to the given String array + */ + public static Term stringArrayToList(String[] a) { + Term list = new Atom("[]"); + for (int i = a.length - 1; i >= 0; i--) { + list = new Compound(".", new Term[]{new Atom(a[i]), list}); + } + return list; + } + // + /** + * Converts an array of int to a corresponding JPL list + * + * @param a + * An array of int values + * @return Term a JPL list corresponding to the given int array + */ + public static Term intArrayToList(int[] a) { + Term list = new Atom("[]"); + for (int i = a.length - 1; i >= 0; i--) { + list = new Compound(".", new Term[]{new jpl.Integer(a[i]), list}); + } + return list; + } + // + /** + * Converts an array of arrays of int to a corresponding JPL list of lists + * + * @param a + * An array of arrays of int values + * @return Term a JPL list of lists corresponding to the given int array of arrays + */ + public static Term intArrayArrayToList(int[][] a) { + Term list = new Atom("[]"); + for (int i = a.length - 1; i >= 0; i--) { + list = new Compound(".", new Term[]{intArrayToList(a[i]), list}); + } + return list; + } + public static int listToLength(Term t) { + int length = 0; + Term head = t; + while (head.hasFunctor(".", 2)) { + length++; + head = head.arg(2); + } + return (head.hasFunctor("[]", 0) ? length : -1); + } + /** converts a proper list to an array of terms, else throws an exception + * + * @throws JPLException + * @return an array of terms whose successive elements are the corresponding members of the list (if it is a list) + */ + public static Term[] listToTermArray(Term t) { + try { + int len = t.listLength(); + Term[] ts = new Term[len]; + + for (int i = 0; i < len; i++) { + ts[i] = t.arg(1); + t = t.arg(2); + } + return ts; + } catch (JPLException e) { + throw new JPLException("Util.listToTermArray: term is not a proper list"); + } + } + + public static String[] atomListToStringArray( Term t){ + int n = listToLength(t); + String[] a; + if ( n<0){ + return null; + } else { + a = new String[n]; + } + int i = 0; + Term head = t; + while ( head.hasFunctor(".", 2)){ + Term x = head.arg(1); + if ( x.isAtom()){ + a[i++]=x.name(); + } else { + return null; + } + head = head.arg(2); + } + return (head.hasFunctor("[]", 0) ? a : null ); + } +} diff --git a/packages/jpl/src/java/jpl/Variable.java b/packages/jpl/src/java/jpl/Variable.java new file mode 100644 index 000000000..6d14b8ad4 --- /dev/null +++ b/packages/jpl/src/java/jpl/Variable.java @@ -0,0 +1,299 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 2004 Paul Singleton +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl; + +import java.util.Iterator; +import java.util.Map; +import jpl.fli.Prolog; +import jpl.fli.term_t; + +//----------------------------------------------------------------------/ +// Variable +/** + * This class supports Java representations of Prolog variables. + * + * A jpl.Variable instance is equivalent to a variable in a fragment of Prolog source text: + * it is *not* a "live" variable within a Prolog stack or heap. + * A corresponding Prolog variable is created only upon opening + * a Query whose goal refers to a Variable (and then only temporarily). + * + * + * Copyright (C) 2004 Paul Singleton + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class Variable extends Term { + //==================================================================/ + // Attributes + //==================================================================/ + private static long n = 0; // the integral part of the next automatic variable name to be allocated + public final String name; // the name of this Variable + protected transient term_t term_ = null; // defined between Query.open() and Query.get2() + protected transient int index; // only used by (redundant?) + //==================================================================/ + // Constructors + //==================================================================/ + /** + * Create a new Variable with 'name' (which must not be null or ""), + * and may one day be constrained to comply with traditional Prolog syntax. + * + * @param name the source name of this Variable + */ + public Variable(String name) { + if (name == null) { + throw new JPLException("constructor jpl.Variable(name): name cannot be null"); + } + if (!isValidName(name)) { + throw new JPLException("constructor jpl.Variable(name): name cannot be empty String"); + } + this.name = name; + } + /** + * Create a new Variable with new sequential name of the form "_261". + * + */ + public Variable() { + this.name = "_" + Long.toString(n++); // e.g. _0, _1 etc. + } + //==================================================================/ + // Methods (common) + //==================================================================/ + /** + * The (nonexistent) args of this Variable + * @throws JPLException + * + * @return the (nonexistent) args of this Variable (never) + */ + public Term[] args() { + throw new JPLException("jpl.Variable#args(): call is improper"); + } + public boolean hasFunctor(String name, int arity) { + throw new JPLException("jpl.Variable#hasFunctor(): term is not sufficiently instantiated"); + } + public boolean hasFunctor(int value, int arity) { + throw new JPLException("jpl.Variable#hasFunctor(): term is not sufficiently instantiated"); + } + public boolean hasFunctor(double value, int arity) { + throw new JPLException("jpl.Variable#hasFunctor(): term is not sufficiently instantiated"); + } + public Object jrefToObject() { + throw new JPLException("jpl.Variable#jrefToObject(): term is not a jref"); + } + /** + * returns the lexical name of this Variable + * + * @return the lexical name of this Variable + */ + public final String name() { + return this.name; + } + /** + * returns the type of this subclass of Term, i.e. Prolog.VARIABLE + * + * @return the type of this subclass of Term, i.e. Prolog.VARIABLE + */ + public final int type() { + return Prolog.VARIABLE; + } + /** + * returns the typeName of this subclass of Term, i.e. "Variable" + * + * @return the typeName of this subclass of Term, i.e. "Variable" + */ + public String typeName() { + return "Variable"; + } + /** + * Returns a Prolog source text representation of this Variable + * + * @return a Prolog source text representation of this Variable + */ + public String toString() { + return this.name; + } + /** + * A Variable is equal to another if their names are the same and they are not anonymous. + * + * @param obj The Object to compare. + * @return true if the Object is a Variable and the above condition apply. + */ + public final boolean equals(Object obj) { + return obj instanceof Variable && !this.name.equals("_") && this.name.equals(((Variable) obj).name); + } + + /** + * throws a JPLException (arg(int) is defined only for Compound and Atom) + * + * @return the ith argument (counting from 1) of this Variable (never) + */ + public final Term arg(int i) { + throw new JPLException("jpl.Variable#arg(int) is undefined"); + } + +//==================================================================/ + // Methods (private) + //==================================================================/ + /** + * Tests the lexical validity of s as a variable's name + * + * @return the lexical validity of s as a variable's name + * @deprecated + */ + private boolean isValidName(String s) { + if (s == null) { + throw new java.lang.NullPointerException(); // JPL won't call it this way + } + int len = s.length(); + if (len == 0) { + throw new JPLException("invalid variable name"); + } + char c = s.charAt(0); + if (!(c == '_' || c >= 'A' && c <= 'Z')) { + return false; + } + for (int i = 1; i < len; i++) { + c = s.charAt(i); + if (!(c == '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' || c >= '0' && c <= '9')) { + return false; + } + } + return true; + } + //==================================================================/ + // Methods (deprecated) + //==================================================================/ + /** + * Returns a debug-friendly String representation of an Atom. + * + * @return a debug-friendly String representation of an Atom + * @deprecated + */ + public String debugString() { + return "(Variable " + toString() + ")"; + } + //==================================================================/ + // Converting JPL Terms to Prolog terms + //==================================================================/ + /** + * To put a Variable, we must check whether a (non-anonymous) variable with the same name + * has already been put in the Term. If one has, then the corresponding Prolog variable has + * been stashed in the varnames_to_vars Map, keyed by the Variable name, so we can look + * it up and reuse it (this way, the sharing of variables in the Prolog term + * reflects the sharing of Variable names in the Term. + * Otherwise, if this Variable name has not + * already been seen in the Term, then we put a new Prolog variable and add it into the Map + * (keyed by this Variable name). + * + * @param varnames_to_vars A Map from variable names to Prolog variables. + * @param term A (previously created) term_t which is to be + * set to a (new or reused) Prolog variable. + */ + protected final void put(Map varnames_to_vars, term_t term) { + term_t var; + // if this var is anonymous or as yet unseen, put a new Prolog variable + if (this.name.equals("_") || (var = (term_t) varnames_to_vars.get(this.name)) == null) { + this.term_ = term; + this.index = varnames_to_vars.size(); // i.e. first var in is #0 etc. + Prolog.put_variable(term); + if (!this.name.equals("_")) { + varnames_to_vars.put(this.name, term); + } + } else { + this.term_ = var; + Prolog.put_term(term, var); + } + } + //==================================================================/ + // Converting Prolog terms to JPL Terms + //==================================================================/ + /** + * Converts a term_t (known to refer to a Prolog variable) to a Variable. + * If the variable has already been seen (and hence converted), + * return its corresponding Variable from the map, + * else create a new Variable, stash it in the map (keyed by the Prolog variable), + * and return it. + * + * @param vars_to_Vars a map from Prolog to JPL variables + * @param var The term_t (known to be a variable) to convert + * @return A new or reused Variable + */ + protected static Term getTerm1(Map vars_to_Vars, term_t var) { + for (Iterator i = vars_to_Vars.keySet().iterator(); i.hasNext();) { + term_t varX = (term_t) i.next(); // a previously seen Prolog variable + if (Prolog.compare(varX, var) == 0) { // identical Prolog variables? + return (Term) vars_to_Vars.get(varX); // return the associated JPL Variable + } + } + // otherwise, the Prolog variable in term has not been seen before + Variable Var = new Variable(); // allocate a new (sequentially named) Variable to represent it + Var.term_ = var; // this should become redundant... + vars_to_Vars.put(var, Var); // use Hashtable(var,null), but only need set(var) + return Var; + } + //==================================================================/ + // Computing Substitutions + //==================================================================/ + /** + * If this Variable instance is not an anonymous or (in dont-tell-me mode) a dont-tell-me variable, and its binding is not already in the varnames_to_Terms Map, + * put the result of converting the term_t to which this variable + * has been unified to a Term in the Map, keyed on this Variable's name. + * + * @param varnames_to_Terms A Map of bindings from variable names to JPL Terms. + * @param vars_to_Vars A Map from Prolog variables to JPL Variables. + */ + protected final void getSubst(Map varnames_to_Terms, Map vars_to_Vars) { + // NB a Variable.name cannot be "" i.e. of 0 length + // if (!(this.name.charAt(0) == '_') && varnames_to_Terms.get(this.name) == null) { + if (tellThem() && varnames_to_Terms.get(this.name) == null) { + varnames_to_Terms.put(this.name, Term.getTerm(vars_to_Vars, this.term_)); + } + } + // whether, according to prevailing policy and theis Variable's name, + // any binding should be returned + // (yes, unless it's anonymous or we're in dont-tell-me mode and its a dont-tell-me variable) + private final boolean tellThem() { + return !(this.name.equals("_") || jpl.JPL.modeDontTellMe && this.name.charAt(0) == '_'); + // return !this.name.equals("_"); + } +} +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/Version.java b/packages/jpl/src/java/jpl/Version.java new file mode 100644 index 000000000..e5347bc83 --- /dev/null +++ b/packages/jpl/src/java/jpl/Version.java @@ -0,0 +1,9 @@ +// $Id$ +package jpl; + +class Version { + public final int major = 3; + public final int minor = 1; + public final int patch = 4; + public final String status = "alpha"; +} diff --git a/packages/jpl/src/java/jpl/fli/.cvsignore b/packages/jpl/src/java/jpl/fli/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/src/java/jpl/fli/BooleanHolder.java b/packages/jpl/src/java/jpl/fli/BooleanHolder.java new file mode 100644 index 000000000..77c7cda09 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/BooleanHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// BooleanHolder +/** + * A BooleanHolder is merely a Holder class for a boolean value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class BooleanHolder +{ + public boolean value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/DoubleHolder.java b/packages/jpl/src/java/jpl/fli/DoubleHolder.java new file mode 100644 index 000000000..620726d7b --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/DoubleHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// DoubleHolder +/** + * A DoubleHolder is merely a Holder class for a double value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class DoubleHolder +{ + public double value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/Int64Holder.java b/packages/jpl/src/java/jpl/fli/Int64Holder.java new file mode 100644 index 000000000..f39624b6e --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/Int64Holder.java @@ -0,0 +1,34 @@ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +//Int64Holder +/** +* An Int64Holder is merely a Holder class for an int64 value. +* +* +* Copyright (C) 2005 Paul Singleton +* +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Library Public License +* as published by the Free Software Foundation; either version 2 +* of the License, or (at your option) any later version. +* +* This library 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 Library Public License for more details. +* +* @author Paul Singleton paul@jbgb.com +* @version $Revision$ +*/ +//Implementation notes: +// +//----------------------------------------------------------------------/ +public class Int64Holder +{ + public long value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/IntHolder.java b/packages/jpl/src/java/jpl/fli/IntHolder.java new file mode 100644 index 000000000..8a0b40fb9 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/IntHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// IntHolder +/** + * An IntHolder is merely a Holder class for an Int value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class IntHolder +{ + public int value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/LongHolder.java b/packages/jpl/src/java/jpl/fli/LongHolder.java new file mode 100644 index 000000000..8d8dbaaaf --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/LongHolder.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + +//----------------------------------------------------------------------/ +// LongHolder +/** + * A Long Holder merely holds a long value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class LongHolder { + public long value = 0L; + + public boolean equals(LongHolder lh) { + return lh.value == this.value; + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/ObjectHolder.java b/packages/jpl/src/java/jpl/fli/ObjectHolder.java new file mode 100644 index 000000000..1d83c0b53 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/ObjectHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// ObjectHolder +/** + * A ObjectHolder is merely a Holder class for an Object reference (or null). + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class ObjectHolder +{ + public Object value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/PointerHolder.java b/packages/jpl/src/java/jpl/fli/PointerHolder.java new file mode 100644 index 000000000..b4f3e488f --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/PointerHolder.java @@ -0,0 +1,63 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// PointerHolder +/** + * A PointerHolder is a trivial extension of a LongHolder. This is sort of + * a no-no in Java, as the long value stored herein is sometimes a + * machine address. (Don't tell Sun.) + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// There could be issues in the future with signedness, since Java +// does not have an unsigned type; make sure not to do any arithmetic +// with the stored value. +//----------------------------------------------------------------------/ +public class PointerHolder extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/Prolog.java b/packages/jpl/src/java/jpl/fli/Prolog.java new file mode 100644 index 000000000..ea4812ac4 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/Prolog.java @@ -0,0 +1,246 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + +import jpl.JPL; + + +//----------------------------------------------------------------------/ +// Prolog +/** + * This class consists only of constants (static finals) and static + * native methods. The constants and methods defined herein are in + * (almost) strict 1-1 correspondence with the functions in the Prolog + * FLI by the same name (except without the PL_, SQ_, etc. prefixes). + * + * See the file jpl.c for the native (ANSI C) implementations of these + * methods. Refer to your local Prolog FLI documentations for the meanings + * of these methods, and observe the following: + * + * + *
  • The types and signatures of the following methods are almost + * in 1-1 correspondence with the Prolog FLI. The Prolog types + * term_t, atom_t, functor_t, etc. are mirrored in this package with + * classes by the same name, making the C and Java uses of these + * interfaces similar.
    • + *
  • As term_t, functor_t, etc. types are Java classes, they are + * passed to these methods by value; however, calling these + * methods on such class instances does have side effects. In general, + * the value fields of these instances will be modified, in much the + * same way the term_t, functor_t, etc. Prolog instances would be + * modified.
    • + *
  • The exceptions to this rule occur when maintaining the same + * signature would be impossible, e.g., when the Prolog FLI functions + * require pointers; in this case, the signatures have been + * modified to take *Holder classes (Int, Double, String, etc.), + * to indicate a call by reference parameter. + *
  • Functions which take variable-length argument lists in C + * take arrays in Java; from Java 1.1 onwards, anonymous arrays + * can be used e.g. Term[] { new Atom("a"), new Atom ("b") } + *
    • + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +public final class Prolog { + static { + // System.loadLibrary("jpl"); + JPL.loadNativeLibrary(); + } + + /* term types */ + public static final int VARIABLE = 1; + public static final int ATOM = 2; + public static final int INTEGER = 3; + public static final int FLOAT = 4; + public static final int STRING = 5; + public static final int COMPOUND = 6; + + public static final int JBOOLEAN = 101; + public static final int JREF = 102; + public static final int JVOID = 103; + + /** + * @deprecated use Prolog.COMPOUND + */ + public static final int TERM = 6; + + public static final int succeed = 1; + public static final int fail = 0; + + /* query flags */ + public static final int Q_NORMAL = 0x02; + public static final int Q_NODEBUG = 0x04; + public static final int Q_CATCH_EXCEPTION = 0x08; + public static final int Q_PASS_EXCEPTION = 0x10; + + /* conversion flags */ + public static final int CVT_ATOM = 0x0001; + public static final int CVT_STRING = 0x0002; + public static final int CVT_LIST = 0x0004; + public static final int CVT_INTEGER = 0x0008; + public static final int CVT_FLOAT = 0x0010; + public static final int CVT_VARIABLE = 0x0020; + public static final int CVT_NUMBER = (CVT_INTEGER | CVT_FLOAT); + public static final int CVT_ATOMIC = (CVT_NUMBER | CVT_ATOM | CVT_STRING); + public static final int CVT_ALL = 0x00ff; + public static final int BUF_DISCARDABLE = 0x0000; + public static final int BUF_RING = 0x0100; + public static final int BUF_MALLOC = 0x0200; + + /* new, for revised term_t-to-Variable stuff */ + public static native int compare(term_t t1, term_t t2); // returns -1, 0 or 1 + + /* Creating and destroying term-refs */ + public static native term_t new_term_ref(); + public static native term_t new_term_refs(int n); + public static native term_t copy_term_ref(term_t from); // NOT USED + + /* Constants */ + public static native atom_t new_atom(String s); + public static native String atom_chars(atom_t a); + public static native functor_t new_functor(atom_t f, int a); + + public static native void unregister_atom(atom_t a); // called from atom_t's finalize() + + /* Get Java-values from Prolog terms */ + public static native boolean get_atom_chars(term_t t, StringHolder a); + public static native boolean get_string_chars(term_t t, StringHolder s); + public static native boolean get_integer(term_t t, Int64Holder i); + public static native boolean get_float(term_t t, DoubleHolder d); + public static native boolean get_name_arity(term_t t, StringHolder name, IntHolder arity); + public static native boolean get_arg(int index, term_t t, term_t a); + + public static native String object_to_tag(Object obj); + public static native Object tag_to_object(String tag); // 29/May/2008 + public static native boolean is_tag(String tag); // 30/May/2008 + + /* Verify types */ + public static native int term_type(term_t t); + + /* Assign to term-references */ + public static native void put_variable(term_t t); + public static native void put_integer(term_t t, long i); + public static native void put_float(term_t t, double f); + public static native void put_term(term_t t1, term_t t2); + public static native void put_jref(term_t t, Object ref); + + /* ... */ + public static native void cons_functor_v(term_t h, functor_t fd, term_t a0); + + // predicates: + public static native predicate_t predicate(String name, int arity, String module); + + // querying (general): + public static native qid_t open_query(module_t m, int flags, predicate_t pred, term_t t0); + public static native boolean next_solution(qid_t qid); + public static native void close_query(qid_t qid); + + // modules: + public static native module_t new_module(atom_t name); + + // exceptions: + public static native term_t exception(qid_t qid); + + // initialisation: + public static native String[] get_default_init_args(); + public static native boolean set_default_init_args(String argv[]); + public static native boolean initialise(); + public static native String[] get_actual_init_args(); + public static native void halt(int status); + + // thread & engine management: + public static native int thread_self(); + public static native engine_t attach_pool_engine(); + public static native int release_pool_engine(); + public static native engine_t current_engine(); + public static native boolean current_engine_is_pool(); + public static native int attach_engine(engine_t e); + + // misc. + public static native String get_c_lib_version(); + + // not yet working: + public static native int action_abort(); + + // revived 17/Jun/2008: + public static native fid_t open_foreign_frame(); + public static native void discard_foreign_frame(fid_t cid); + + // not used: + // public static native void reset_term_refs(term_t r); + // public static native atom_t functor_name(functor_t f); + // public static native int functor_arity(functor_t f); + // public static native boolean get_atom(term_t t, atom_t a); + // public static native boolean get_pointer(term_t t, PointerHolder ptr); + // public static native boolean get_functor(term_t t, functor_t f); + // public static native boolean get_module(term_t t, module_t module); + // public static native boolean get_jref(term_t t, ObjectHolder obj); + // public static native boolean get_jboolean(term_t t, BooleanHolder b); + // public static native boolean get_jpl_term(term_t t, ObjectHolder obj); // withdrawn 17/Oct/2004 + // public static native boolean is_variable(term_t t); + // public static native boolean is_atom(term_t t); + // public static native boolean is_integer(term_t t); + // public static native boolean is_float(term_t t); + // public static native boolean is_compound(term_t t); + // public static native boolean is_functor(term_t t, functor_t f); + // public static native boolean is_atomic(term_t t); + // public static native boolean is_number(term_t t); + // public static native void put_atom(term_t t, atom_t a); + // public static native void put_pointer(term_t t, PointerHolder ptr); + // public static native void put_functor(term_t t, functor_t functor); + // public static native void put_jboolean(term_t t, boolean b); + // public static native void put_jvoid(term_t t); + // public static native void cons_list(term_t l, term_t h, term_t t); + // public static native int unify(term_t t1, term_t t2); + // public static native predicate_t pred(functor_t f, module_t m); + // public static native int predicate_info(predicate_t pred, atom_t name, IntHolder arity, module_t module); + // public static native void cut_query(qid_t qid); + // public static native boolean call(term_t t, module_t m); + // public static native boolean call_predicate(module_t m, int debug, predicate_t pred, term_t t0); + // public static native void close_foreign_frame(fid_t cid); // NOT USED + // public static native void discard_foreign_frame(fid_t cid); // NOT USED + // public static native module_t context(); + // public static native atom_t module_name(module_t module); + // public static native int strip_module(term_t in, module_t m, term_t out); + // public static native int pool_engine_id(engine_t e); +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/StringHolder.java b/packages/jpl/src/java/jpl/fli/StringHolder.java new file mode 100644 index 000000000..eef50ddaf --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/StringHolder.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// StringHolder +/** + * A StringHolder is merely a Holder class for a String value. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class StringHolder +{ + public String value; +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/atom_t.java b/packages/jpl/src/java/jpl/fli/atom_t.java new file mode 100644 index 000000000..83bb94bff --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/atom_t.java @@ -0,0 +1,82 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// atom_t +/** + * An atom_t is a specialised LongHolder which decrements its atom's + * reference count when garbage-collected (finalized). + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class atom_t +extends LongHolder +{ + //------------------------------------------------------------------/ + // toString + /** + * The String representation of an atom_t is just the atom's name. + * + * @return atom's name + */ + // Implementation notes: + // + //------------------------------------------------------------------/ + public String + toString() + { + return Prolog.atom_chars( this ); + } + + protected void finalize() throws Throwable { + + super.finalize(); + Prolog.unregister_atom( this); + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/engine_t.java b/packages/jpl/src/java/jpl/fli/engine_t.java new file mode 100644 index 000000000..ab996b581 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/engine_t.java @@ -0,0 +1,56 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + +//----------------------------------------------------------------------/ +// engine_t +/** + * A engine_t holds a reference to a Prolog engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: Note that a engine_t is not a term, +// consistent with the treatment in the Prolog FLI. +//----------------------------------------------------------------------/ +public class engine_t extends LongHolder { +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/fid_t.java b/packages/jpl/src/java/jpl/fli/fid_t.java new file mode 100644 index 000000000..4cfb83730 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/fid_t.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// fid_t +/** + * An fid_t holds the value of a frame id in the Prolog Engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class fid_t +extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/functor_t.java b/packages/jpl/src/java/jpl/fli/functor_t.java new file mode 100644 index 000000000..7cee09c49 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/functor_t.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// functor_t +/** + * A functor_t holds a reference to a Prolog functor_t in the + * Prolog engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: Note that a functor_t is not a term, +// consistent with the treatment in the Prolog FLI. +//----------------------------------------------------------------------/ +public class functor_t +extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/module_t.java b/packages/jpl/src/java/jpl/fli/module_t.java new file mode 100644 index 000000000..e13f0d6f0 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/module_t.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// module_t +/** + * A module_t is a PointerHolder type which holds a reference to a Prolog + * module_t reference. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class module_t +extends PointerHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/predicate_t.java b/packages/jpl/src/java/jpl/fli/predicate_t.java new file mode 100644 index 000000000..d65327d69 --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/predicate_t.java @@ -0,0 +1,61 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// predicate_t +/** + * A predicate_t is a PointerHolder class whose value is a reference to a + * Prolog predicate_t. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class predicate_t +extends PointerHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/qid_t.java b/packages/jpl/src/java/jpl/fli/qid_t.java new file mode 100644 index 000000000..7e663404d --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/qid_t.java @@ -0,0 +1,60 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// qid_t +/** + * A qid_t holds a reference to a Prolog qid_t. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class qid_t +extends LongHolder +{ +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/fli/term_t.java b/packages/jpl/src/java/jpl/fli/term_t.java new file mode 100644 index 000000000..ef23f862b --- /dev/null +++ b/packages/jpl/src/java/jpl/fli/term_t.java @@ -0,0 +1,133 @@ +//tabstop=4 +//*****************************************************************************/ +// Project: jpl +// +// File: $Id$ +// Date: $Date$ +// Author: Fred Dushin fadushin@syr.edu +// +// +// Description: +// +// +// ------------------------------------------------------------------------- +// Copyright (c) 1998 Fred Dushin +// All rights reserved. +// +// This library is free software; you can redistribute it and/or +// modify it under the terms of the GNU Library Public License +// as published by the Free Software Foundation; either version 2 +// of the License, or (at your option) any later version. +// +// This library 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 Library Public License for more details. +//*****************************************************************************/ +package jpl.fli; + + + +//----------------------------------------------------------------------/ +// term_t +/** + * A term_t is a simple class which mirrors the term_t type in + * the Prolog FLI. All it really does is hold a term reference, + * which is an internal representation of a term in the Prolog + * Engine. + * + * + * Copyright (C) 1998 Fred Dushin + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This library 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 Library Public License for more details. + * + * @author Fred Dushin fadushin@syr.edu + * @version $Revision$ + */ +// Implementation notes: +// +//----------------------------------------------------------------------/ +public class term_t +extends LongHolder +{ + public static final long UNASSIGNED = -1L; + + public + term_t() + { + value = UNASSIGNED; + } + + //------------------------------------------------------------------/ + // toString + /** + * This static method converts a term_t, which is assumed to contain + * a reference to a *consecutive* list of term_t references to a + * String representation of a list of terms, in this case, a comma + * separated list. + * + * @param n the number of consecutive term_ts + * @param term0 a term_t whose value is the 0th term_t. + */ + // Implementation notes: + // + //------------------------------------------------------------------/ + public static String + toString( int n, term_t term0 ) + { + String s = ""; + int i; + long ith_term_t; + + for ( i = 0, ith_term_t = term0.value; i < n; ++i, ++ith_term_t ){ + term_t term = new term_t(); + term.value = ith_term_t; + s += term.toString(); + + if ( i != n - 1 ){ + s += ", "; + } + } + + return s; + } + + + //------------------------------------------------------------------/ + // equals + /** + * Instances of term_ts are stored in Term objects (see jpl.Term), + * and these term_ts are in some cases stored in Hashtables. + * Supplying this predicate provides the right behavior in Hashtable + * lookup (see the rules for Hashtable lookup in java.util). + * + * Note. Two term_ts are *not* equal if their values have not + * been assigned. (Since Prolog FLI term_ts are unsigned values and + * the UNASSIGNED value is -1, this should work). + * + * @param obj the Object to comapre. + * @return true if the supplied object is a term_t instances + * and the long values are the same + */ + // Implementation notes: + // + //------------------------------------------------------------------/ + public boolean + equals( Object obj ) + { + return + (obj instanceof term_t) && + this.value == ((term_t)obj).value && + this.value != UNASSIGNED; + } +} + +//345678901234567890123456789012346578901234567890123456789012345678901234567890 diff --git a/packages/jpl/src/java/jpl/test/.cvsignore b/packages/jpl/src/java/jpl/test/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/src/java/jpl/test/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/src/java/jpl/test/CelsiusConverter.java b/packages/jpl/src/java/jpl/test/CelsiusConverter.java new file mode 100644 index 000000000..74248498c --- /dev/null +++ b/packages/jpl/src/java/jpl/test/CelsiusConverter.java @@ -0,0 +1,78 @@ +package jpl.test; + +/** + * CelsiusConverter.java is a 1.4 application that + * demonstrates the use of JButton, JTextField and + * JLabel. It requires no other files. + */ +import java.awt.*; +import java.awt.event.*; +import javax.swing.*; + +public class CelsiusConverter implements ActionListener { + JFrame converterFrame; + JPanel converterPanel; + JTextField tempCelsius; + JLabel celsiusLabel, fahrenheitLabel; + JButton convertTemp; + public CelsiusConverter() { // initially locate the window at top-left of desktop + this(0, 0); + } + public CelsiusConverter(int left, int top) { // initially locate the window at top-left of desktop + // create and set up the window + converterFrame = new JFrame("Convert Celsius to Fahrenheit"); + converterFrame.setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE); + converterFrame.setSize(new Dimension(120, 40)); + converterFrame.setLocation(left, top); + // create and set up the panel + converterPanel = new JPanel(new GridLayout(2, 2)); + // create widgets + tempCelsius = new JTextField(2); + celsiusLabel = new JLabel("Celsius", SwingConstants.LEFT); + celsiusLabel.setBorder(BorderFactory.createEmptyBorder(5, 5, 5, 5)); + // + convertTemp = new JButton("Convert"); + fahrenheitLabel = new JLabel("Fahrenheit", SwingConstants.LEFT); + // listen to events from the Convert button + convertTemp.addActionListener(this); + // add the widgets to the container + converterPanel.add(tempCelsius); + converterPanel.add(celsiusLabel); + converterPanel.add(convertTemp); + converterPanel.add(fahrenheitLabel); + fahrenheitLabel.setBorder(BorderFactory.createEmptyBorder(5, 5, 5, 5)); + converterFrame.getRootPane().setDefaultButton(convertTemp); // make "convert" the window's default button + // add the panel to the window + converterFrame.getContentPane().add(converterPanel, BorderLayout.CENTER); + // display the window + converterFrame.pack(); + converterFrame.setVisible(true); + } + public void actionPerformed(ActionEvent event) { + // parse degrees Celsius as a double + double tC = (Double.parseDouble(tempCelsius.getText())); + // + // convert to Fahrenheit (in Java) + // int tempFahr = (int) (tC * 1.8 + 32); + // + // convert to Fahrenheit (in Prolog, via JPL) + int tempFahr = ((jpl.Float) jpl.Query.oneSolution("TF is ? * 1.8 + 32", new jpl.Term[] {new jpl.Float(tC)}).get("TF")).intValue(); + // + // display the result + fahrenheitLabel.setText(tempFahr + " Fahrenheit"); + } + public static void spawnGUI(final int left, final int top) { + // schedule a job for the event-dispatching thread: create and show an instance of this application at (left,top) + javax.swing.SwingUtilities.invokeLater(new Runnable() { + int x = left; + int y = top; + public void run() { + new CelsiusConverter(x, y); // can we be sure this won't be garbage collected? + } + }); + } + public static void main(String[] args) { + // just for fun, we ask Prolog to start five instances of this class (at stepped offsets from top-left of display) + jpl.Query.allSolutions("between(1, 5, N), X is 10*N, Y is 20*N, jpl_call('jpl.test.CelsiusConverter', spawnGUI, [X,Y], _)"); + } +} diff --git a/packages/jpl/src/java/jpl/test/Family.java b/packages/jpl/src/java/jpl/test/Family.java new file mode 100644 index 000000000..714feba14 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/Family.java @@ -0,0 +1,96 @@ +package jpl.test; +import jpl.Atom; +import jpl.Query; +import jpl.Term; +import jpl.Variable; + +public class Family extends Thread { + + int id; // client thread id + private static final int delay = 0; + + Family(int i) { + this.id = i; + } + + public static void main(String argv[]) { + + Query q1 = new Query("consult", new Term[] { new Atom("jpl/test/family.pl")}); + System.err.println("consult " + (q1.hasSolution() ? "succeeded" : "failed")); + + for (int i = 0; i < 20; i++) { + System.out.println("spawning client[" + i + "]"); + new Family(i).start(); + } + + } + + public void run() { + java.util.Hashtable solution; + Variable X = new Variable("X"); + + //-------------------------------------------------- + + Query q2 = new Query("child_of", new Term[] { new Atom("joe"), new Atom("ralf")}); + + System.err.println("child_of(joe,ralf) is " + (q2.hasSolution() ? "provable" : "not provable")); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + Query q3 = new Query("descendent_of", new Term[] { new Atom("steve"), new Atom("ralf")}); + + System.err.println("descendent_of(steve,ralf) is " + (q3.hasSolution() ? "provable" : "not provable")); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + Query q4 = new Query("descendent_of", new Term[] { X, new Atom("ralf")}); + + solution = q4.oneSolution(); + + System.err.println("first solution of descendent_of(X, ralf)"); + System.err.println("X = " + solution.get(X.name)); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + java.util.Hashtable[] solutions = q4.allSolutions(); + + System.err.println("all solutions of descendent_of(X, ralf)"); + for (int i = 0; i < solutions.length; i++) { + System.err.println("X = " + solutions[i].get(X.name)); + } + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + System.err.println("each solution of descendent_of(X, ralf)"); + while (q4.hasMoreSolutions()) { + solution = q4.nextSolution(); + System.err.println("X = " + solution.get(X.name)); + } + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + + //-------------------------------------------------- + + Variable Y = new Variable("Y"); + + Query q5 = new Query("descendent_of", new Term[] { X, Y }); + + System.err.println(id + ": each solution of descendent_of(X, Y)"); + while (q5.hasMoreSolutions()) { + solution = q5.nextSolution(); + System.err.println(id + ": X = " + solution.get(X.name) + ", Y = " + solution.get(Y.name)); + + new Query("sleep", new Term[] { new jpl.Integer(delay)}).hasSolution(); + } + + } + +} diff --git a/packages/jpl/src/java/jpl/test/FetchBigTree.java b/packages/jpl/src/java/jpl/test/FetchBigTree.java new file mode 100644 index 000000000..0983453a7 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/FetchBigTree.java @@ -0,0 +1,18 @@ +package jpl.test; + +import jpl.Query; +import jpl.Term; + +public class FetchBigTree { + public static void main(String[] args) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + (new Query("consult('jpl/test/test.pl')")).oneSolution(); + Term t = (Term)((new Query("p(18,T)")).oneSolution().get("T")); + int i = 1; + while ( t.hasFunctor("a", 2)){ + t = t.arg(2); + i = i+1; + } + System.err.println("got a tree of " + i+" generations"); + } +} diff --git a/packages/jpl/src/java/jpl/test/FetchLongList.java b/packages/jpl/src/java/jpl/test/FetchLongList.java new file mode 100644 index 000000000..76a84ae4f --- /dev/null +++ b/packages/jpl/src/java/jpl/test/FetchLongList.java @@ -0,0 +1,17 @@ +package jpl.test; + +import jpl.Query; +import jpl.Term; + +public class FetchLongList { + public static void main(String[] args) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + Term t = (Term)((new Query("findall(foo(N,bar),between(1,2308,N),L)")).oneSolution().get("L")); + int i = 0; + while ( t.hasFunctor(".", 2)){ + t = t.arg(2); + i = i+1; + } + System.err.println("got a list of " + i+" members"); + } +} diff --git a/packages/jpl/src/java/jpl/test/Ga.java b/packages/jpl/src/java/jpl/test/Ga.java new file mode 100644 index 000000000..53f2b6c7e --- /dev/null +++ b/packages/jpl/src/java/jpl/test/Ga.java @@ -0,0 +1,23 @@ +package jpl.test; + +import jpl.Query; + +public class Ga { + public static void main(String argv[]) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + // (new Query("loadall(jpl_test:jr)")).hasSolution(); + // System.err.println("jr " + ((new Query("jr")).hasSolution() ? "succeeded" : "failed")); + // System.err.println( "something " + (new Query("statistics(atoms,X)")).oneSolution().get("X")); + // Query.hasSolution("statistics"); + // (new Query("x")).hasSolution(); + // (new Query("statistics,x")).hasSolution(); + // (new Query(new Atom("statistics"))).hasSolution(); + // Query.hasSolution("write(hello),nl"); + // Query.hasSolution("write(hello),nl"); + + // (new Query("nl")).hasSolution(); + (new Query("nl,nl")).hasSolution(); + + // (new Query("user:nl")).hasSolution(); + } +} diff --git a/packages/jpl/src/java/jpl/test/Ga2.java b/packages/jpl/src/java/jpl/test/Ga2.java new file mode 100644 index 000000000..64c32a5c7 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/Ga2.java @@ -0,0 +1,10 @@ +package jpl.test; + +import jpl.Query; + +public class Ga2 { + public static void main(String argv[]) { + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "D:/pcm/bin/pcm.ini", "-g", "pcm_2000" }); + (new Query("current_prolog_flag(K,V),write(K-V),nl,fail")).oneSolution(); + } +} diff --git a/packages/jpl/src/java/jpl/test/Garbo.java b/packages/jpl/src/java/jpl/test/Garbo.java new file mode 100644 index 000000000..0d1216945 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/Garbo.java @@ -0,0 +1,19 @@ +package jpl.test; + +public class Garbo { + public static int created = 0; + public static int destroyed = 0; + // + public final int i; + public Garbo( ) { + this.i = created++; + } + protected void finalize() throws Throwable { + try { + destroyed++; + // System.out.println("gced["+i+"]"); + } finally { + super.finalize(); + } + } +} diff --git a/packages/jpl/src/java/jpl/test/JPLTest.java b/packages/jpl/src/java/jpl/test/JPLTest.java new file mode 100644 index 000000000..3907b7a64 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/JPLTest.java @@ -0,0 +1,93 @@ +/* + * JPLTest.java + * JUnit based test + * + * Created on 13 February 2006, 11:31 + */ +package jpl.test; + +import java.util.concurrent.CountDownLatch; +import java.util.concurrent.TimeUnit; +import java.util.logging.Logger; +import junit.framework.*; +import jpl.*; + +/** + * + * @author rick + */ +public class JPLTest extends TestCase { + // private static final Logger logger = Logger.getLogger(JPLTest.class.getName()); + private CountDownLatch latch; + public JPLTest(String testName) { + super(testName); + } + protected void setUp() throws Exception { + /* + * Prolog file can be an empty file. The JVM seems to crash with a + * SIGSEGV if you don't consult a file prior to interacting with JPL. + + final String prologFile = "jpl/test/test.pl"; // was "/home/rick/temp/test.pl"; + System.out.println("prolog file is: " + prologFile); + String qString = "consult('" + prologFile + "')"; + System.out.println("about to: " + qString); + Query query = new Query(qString); + System.out.println("Generated Query: " + query); + if (!query.hasSolution()) { + System.out.println(qString + " failed"); + fail("Failed to consult prolog file."); + } + + (new Query("true")).hasSolution(); + */ + } + public void testThreadedAdds() { + latch = new CountDownLatch(4); + final AddWithThreads[] addTasks = { new AddWithThreads("a", latch), new AddWithThreads("b", latch), new AddWithThreads("c", latch), new AddWithThreads("d", latch) }; + // System.out.println("Starting threads..."); + for (int i = 0; i < addTasks.length; i++) { + addTasks[i].start(); + } + try { + // System.out.println("Latch is waiting"); + assertTrue("Timed out waiting for action to execute", latch.await(20, TimeUnit.SECONDS)); + // System.out.println("Latch has been flipped"); + } catch (final InterruptedException e) { + fail("Waiting thread was interrupted: " + e); + } + for (int i = 0; i < AddWithThreads.REPS; i++) { + for (int j = 0; j < addTasks.length; j++) { + Query query = new Query(addTasks[j].getNamespace() + "(test('" + i + "'))"); + // System.out.println("query: " + query); + boolean ret = query.hasMoreElements(); + query.close(); + } + } + } +} + +class AddWithThreads extends Thread { + private final CountDownLatch latch; + private final String namespace; + private static final Logger logger = Logger.getLogger(JPLTest.class.getName()); + public static final int REPS = 2000; // was 200 + public AddWithThreads(final String namespace, final CountDownLatch latch) { + this.latch = latch; + this.namespace = namespace; + setName("namespace" + namespace); //set thread name for debugging + } + public String getNamespace() { + return namespace; + } + public void run() { + for (int i = 0; i < REPS; i++) { + // System.out.println("Asserting test('" + i + "')"); + Query queryA = new Query("assert(" + namespace + "(test('" + i + "')))"); + Thread.yield(); + // System.out.println("adding query: " + queryA); + boolean retA = queryA.hasMoreElements(); + queryA.close(); + } + latch.countDown(); + } +} diff --git a/packages/jpl/src/java/jpl/test/Masstest.java b/packages/jpl/src/java/jpl/test/Masstest.java new file mode 100644 index 000000000..59ccafc57 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/Masstest.java @@ -0,0 +1,42 @@ +package jpl.test; + +import jpl.Query; +import jpl.fli.Prolog; + +public class Masstest extends Thread { + public static void main(String[] args) { + // String[] dia = Prolog.get_default_init_args(); + // String s = "default init args: "; + // for (int i = 0; i < dia.length; i++) { + // s += " " + dia[i]; + // } + // System.out.println(s); + // + // Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "none", "-g", "true", "-q" }); + // empirically, needs this at least: + // Prolog.set_default_init_args(new String[] { "libpl.dll" }); + // Prolog.set_default_init_args(new String[] { "pl" }); + // + // (new Query("assert(diagnose_declaration(_,_,_,[not,a,real,error]))")).hasSolution(); + // + int STUDENTSNUMBER = 5; + Masstest[] threads = new Masstest[STUDENTSNUMBER]; + for (int i = 0; i < STUDENTSNUMBER; i++) { + threads[i] = new Masstest(); + threads[i].start(); + } + } + public void predQuery() { + String st = "diagnose_declaration(1,[(sp, 'prefix', [('arg1', '+', 'list', 'Liste1'), ('arg2', '+', 'list', 'Liste2')])], DecMap, ErrorList)"; + Query stQuery = new Query(st); + String errString = stQuery.oneSolution().get("ErrorList").toString(); + System.out.println("errString=" + errString); + } + public void run() { + try { + predQuery(); + } catch (Exception e) { + System.err.println("ERROR: " + e); + } + } +} diff --git a/packages/jpl/src/java/jpl/test/MaxObjects.java b/packages/jpl/src/java/jpl/test/MaxObjects.java new file mode 100644 index 000000000..16bcf92c7 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/MaxObjects.java @@ -0,0 +1,4 @@ +package jpl.test; + +public class MaxObjects { +} diff --git a/packages/jpl/src/java/jpl/test/ShadowA.java b/packages/jpl/src/java/jpl/test/ShadowA.java new file mode 100644 index 000000000..c537ae15c --- /dev/null +++ b/packages/jpl/src/java/jpl/test/ShadowA.java @@ -0,0 +1,13 @@ +/* + * Created on 22-Nov-2004 + * + * TODO To change the template for this generated file go to + * Window - Preferences - Java - Code Style - Code Templates + */ +package jpl.test; + + +public class ShadowA { + public int shadow = -1; + public static int fieldStaticInt; +} \ No newline at end of file diff --git a/packages/jpl/src/java/jpl/test/ShadowB.java b/packages/jpl/src/java/jpl/test/ShadowB.java new file mode 100644 index 000000000..37c1a8637 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/ShadowB.java @@ -0,0 +1,16 @@ +/* + * Created on 22-Nov-2004 + * + * TODO To change the template for this generated file go to + * Window - Preferences - Java - Code Style - Code Templates + */ +package jpl.test; + + +public class ShadowB extends ShadowA { + public String shadow; + public ShadowB(String s) { + shadow = s; + } + public static int fieldStaticInt; +} \ No newline at end of file diff --git a/packages/jpl/src/java/jpl/test/SyntaxError.java b/packages/jpl/src/java/jpl/test/SyntaxError.java new file mode 100644 index 000000000..c224b6510 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/SyntaxError.java @@ -0,0 +1,10 @@ +package jpl.test; + +import jpl.Query; + +public class SyntaxError { + public static void main(String argv[]) { + Query q = new Query("syntax)error"); + System.err.println(q.hasSolution() ? "yes" : "no"); + } +} diff --git a/packages/jpl/src/java/jpl/test/Test.java b/packages/jpl/src/java/jpl/test/Test.java new file mode 100644 index 000000000..746f4eaab --- /dev/null +++ b/packages/jpl/src/java/jpl/test/Test.java @@ -0,0 +1,287 @@ +package jpl.test; + +import jpl.Compound; +import jpl.Query; +import jpl.Term; + +// This class contains members which support those tests which are performed from Prolog. +// See also TestJUnit +public class Test { + public Test() { + } + public Test(Term t) { + this.termFromConstructor = t; + } + public Term termFromConstructor; + // + public static boolean fieldStaticBoolean; + public static final boolean fieldStaticBoolean1 = false; + public static final boolean fieldStaticBoolean2 = true; + // + public static char fieldStaticChar; + public static final char fieldStaticChar1 = '\u0000'; + public static final char fieldStaticChar2 = '\uFFFF'; + // + public static byte fieldStaticByte; + public static final byte fieldStaticByte1 = -(1 << 7); + public static final byte fieldStaticByte2 = -1; + public static final byte fieldStaticByte3 = 0; + public static final byte fieldStaticByte4 = 1; + public static final byte fieldStaticByte5 = (1 << 7) - 1; + // + public static short fieldStaticShort; + public static final short fieldStaticShort1 = -(1 << 15); + public static final short fieldStaticShort2 = -(1 << 7); + public static final short fieldStaticShort3 = -1; + public static final short fieldStaticShort4 = 0; + public static final short fieldStaticShort5 = 1; + public static final short fieldStaticShort6 = (1 << 7) - 1; + public static final short fieldStaticShort7 = (1 << 15) - 1; + // + public static int fieldStaticInt; + public static final int fieldStaticInt1 = -(1 << 31); + public static final int fieldStaticInt2 = -(1 << 15); + public static final int fieldStaticInt3 = -(1 << 7); + public static final int fieldStaticInt4 = -1; + public static final int fieldStaticInt5 = 0; + public static final int fieldStaticInt6 = 1; + public static final int fieldStaticInt7 = (1 << 7) - 1; + public static final int fieldStaticInt8 = (1 << 15) - 1; + public static final int fieldStaticInt9 = (1 << 31) - 1; + // + public static long fieldStaticLong; + public static final long fieldStaticLong1 = -(1 << 63); + public static final long fieldStaticLong2 = -(1 << 31); + public static final long fieldStaticLong3 = -(1 << 15); + public static final long fieldStaticLong4 = -(1 << 7); + public static final long fieldStaticLong5 = -1; + public static final long fieldStaticLong6 = 0; + public static final long fieldStaticLong7 = 1; + public static final long fieldStaticLong8 = (1 << 7) - 1; + public static final long fieldStaticLong9 = (1 << 15) - 1; + public static final long fieldStaticLong10 = (1 << 31) - 1; + public static final long fieldStaticLong11 = (1 << 63) - 1; + // + public static float fieldStaticFloat; + public static final float fieldStaticFloat1 = 12345.6789F; + public static final float fieldStaticFloat2 = 3.4e+38F; // nearly MAX_VALUE + public static final float fieldStaticFloat3 = 1.4e-45F; // nearly MIN_VALUE + public static final float fieldStaticFloat4 = 0.0F; + public static final float fieldStaticFloat5 = java.lang.Float.MIN_VALUE; + public static final float fieldStaticFloat6 = java.lang.Float.MAX_VALUE; + public static final float fieldStaticFloat7 = java.lang.Float.NEGATIVE_INFINITY; + public static final float fieldStaticFloat8 = java.lang.Float.POSITIVE_INFINITY; + public static final float fieldStaticFloat9 = java.lang.Float.NaN; + // + public static double fieldStaticDouble; + public static final double fieldStaticDouble1 = 12345.6789D; + public static final double fieldStaticDouble2 = 2.3456789e+100D; + public static final double fieldStaticDouble3 = 3.456789e-100D; + public static final double fieldStaticDouble4 = 0.0D; + public static final double fieldStaticDouble5 = Double.MIN_VALUE; + public static final double fieldStaticDouble6 = Double.MAX_VALUE; + public static final double fieldStaticDouble7 = Double.NEGATIVE_INFINITY; + public static final double fieldStaticDouble8 = Double.POSITIVE_INFINITY; + public static final double fieldStaticDouble9 = Double.NaN; + // + public static Object[] fieldStaticObjectArray; // can assign e.g. String[] + public static long[] fieldStaticLongArray; // cannot assign e.g. int[] + // + public static long fac(long n) { // complements jpl:jpl_test_fac(+integer,-integer) + if (n == 1) { + return 1; + } else if (n > 1) { + // return n * ((Integer) new Query(new Compound("jpl_test_fac", new Term[] { new Integer(n - 1), new Variable("F") })).oneSolution().get("F")).intValue(); + return n * ((jpl.Integer) Query.oneSolution("jpl_test_fac(?,F)", new Term[] {new jpl.Integer(n-1)}).get("F")).longValue(); + } else { + return 0; + } + } + static void packageMethod() { // not callable via JPL + return; + } + public static void publicMethod() { + return; + } + protected static void protectedMethod() { // not callable via JPL + return; + } + private static void privateMethod() { // not callable via JPL + return; + } + public boolean fieldInstanceBoolean; + public final boolean fieldInstanceBoolean1 = false; + public final boolean fieldInstanceBoolean2 = true; + public byte fieldInstanceByte; + public final byte fieldInstanceByte1 = -(1 << 7); + public final byte fieldInstanceByte2 = -1; + public final byte fieldInstanceByte3 = 0; + public final byte fieldInstanceByte4 = 1; + public final byte fieldInstanceByte5 = (1 << 7) - 1; + public char fieldInstanceChar; + public final char fieldInstanceChar1 = '\u0000'; + public final char fieldInstanceChar2 = '\uFFFF'; + public double fieldInstanceDouble; + public final double fieldInstanceDouble1 = 12345.6789D; + public final double fieldInstanceDouble2 = 2.3456789e+100D; + public final double fieldInstanceDouble3 = 3.456789e-100D; + public final double fieldInstanceDouble4 = 0.0D; + public final double fieldInstanceDouble5 = Double.MIN_VALUE; + public final double fieldInstanceDouble6 = Double.MAX_VALUE; + public final double fieldInstanceDouble7 = Double.NEGATIVE_INFINITY; + public final double fieldInstanceDouble8 = Double.POSITIVE_INFINITY; + public final double fieldInstanceDouble9 = Double.NaN; + public float fieldInstanceFloat; + public final float fieldInstanceFloat1 = 12345.6789F; + public final float fieldInstanceFloat2 = 3.4e+38F; + public final float fieldInstanceFloat3 = 1.4e-45F; + public final float fieldInstanceFloat4 = 0.0F; + public final float fieldInstanceFloat5 = java.lang.Float.MIN_VALUE; + public final float fieldInstanceFloat6 = java.lang.Float.MAX_VALUE; + public final float fieldInstanceFloat7 = java.lang.Float.NEGATIVE_INFINITY; + public final float fieldInstanceFloat8 = java.lang.Float.POSITIVE_INFINITY; + public final float fieldInstanceFloat9 = java.lang.Float.NaN; + public int fieldInstanceInt; + public final int fieldInstanceInt1 = -(1 << 31); + public final int fieldInstanceInt2 = -(1 << 15); + public final int fieldInstanceInt3 = -(1 << 7); + public final int fieldInstanceInt4 = -1; + public final int fieldInstanceInt5 = 0; + public final int fieldInstanceInt6 = 1; + public final int fieldInstanceInt7 = (1 << 7) - 1; + public final int fieldInstanceInt8 = (1 << 15) - 1; + public final int fieldInstanceInt9 = (1 << 31) - 1; + public long fieldInstanceLong; + public final long fieldInstanceLong1 = -(1 << 63); + public final long fieldInstanceLong10 = (1 << 31) - 1; + public final long fieldInstanceLong11 = (1 << 63) - 1; + public final long fieldInstanceLong2 = -(1 << 31); + public final long fieldInstanceLong3 = -(1 << 15); + public final long fieldInstanceLong4 = -(1 << 7); + public final long fieldInstanceLong5 = -1; + public final long fieldInstanceLong6 = 0; + public final long fieldInstanceLong7 = 1; + public final long fieldInstanceLong8 = (1 << 7) - 1; + public final long fieldInstanceLong9 = (1 << 15) - 1; + public short fieldInstanceShort; + public final short fieldInstanceShort1 = -(1 << 15); + public final short fieldInstanceShort2 = -(1 << 7); + public final short fieldInstanceShort3 = -1; + public final short fieldInstanceShort4 = 0; + public final short fieldInstanceShort5 = 1; + public final short fieldInstanceShort6 = (1 << 7) - 1; + public final short fieldInstanceShort7 = (1 << 15) - 1; + // + public Term term; // obsolete + public static Term staticTerm; + public Term instanceTerm; + // + // for testing accessibility of non-public fields: + static boolean fieldPackageStaticBoolean; + protected static boolean fieldProtectedStaticBoolean; + private static boolean fieldPrivateStaticBoolean; + // + // for testing update of final field: + public static final int fieldStaticFinalInt = 7; + // + // for testing passing general terms in from Prolog: + public static Term fieldStaticTerm; + public Term fieldInstanceTerm; + public static boolean methodStaticTerm(Term t) { + return t != null; + } + public boolean methodInstanceTerm(Term t) { + return t != null; + } + public static Term methodStaticEchoTerm(Term t) { + return t; + } + public static boolean methodStaticEchoBoolean(boolean v) { + return v; + } + public static char methodStaticEchoChar(char v) { + return v; + } + public static byte methodStaticEchoByte(byte v) { + return v; + } + public static short methodStaticEchoShort(short v) { + return v; + } + public static int methodStaticEchoInt(int v) { + return v; + } + public static long methodStaticEchoLong(long v) { + return v; + } + public static float methodStaticEchoFloat(float v) { + return v; + } + public static double methodStaticEchoDouble(double v) { + return v; + } + public Term methodInstanceTermEcho(Term t) { + return t; + } + public static boolean methodStaticTermIsJNull(Term t) { + return t.hasFunctor("@", 1) && t.arg(1).hasFunctor("null", 0); + } + public boolean methodInstanceTermIsJNull(Term t) { + return t.hasFunctor("@", 1) && t.arg(1).hasFunctor("null", 0); + } + public static void hello() { + System.out.println("hello"); + } + public static boolean[] newArrayBooleanFromValue(boolean v) { + boolean[] a = new boolean[1]; + a[0] = v; + return a; + } + public static byte[] newArrayByteFromValue(byte v) { + byte[] a = new byte[1]; + a[0] = v; + return a; + } + public static char[] newArrayCharFromValue(char v) { + char[] a = new char[1]; + a[0] = v; + return a; + } + public static short[] newArrayShortFromValue(short v) { + short[] a = new short[1]; + a[0] = v; + return a; + } + public static int[] newArrayIntFromValue(int v) { + int[] a = new int[1]; + a[0] = v; + return a; + } + public static long[] newArrayLongFromValue(long v) { + long[] a = new long[1]; + a[0] = v; + return a; + } + public static float[] newArrayFloatFromValue(float v) { + float[] a = new float[1]; + a[0] = v; + return a; + } + public static double[] newArrayDoubleFromValue(double v) { + double[] a = new double[1]; + a[0] = v; + return a; + } + public static String methodStaticArray(long[] a) { + return "long[]"; + } + public static String methodStaticArray(int[] a) { + return "int[]"; + } + public static String methodStaticArray(short[] a) { + return "short[]"; + } + public static Term wrapTerm(Term in) { // for dmiles 11/Jul/2008 + return new Compound("javaWrap", new Term[] {in}); + } +} diff --git a/packages/jpl/src/java/jpl/test/TestJUnit.java b/packages/jpl/src/java/jpl/test/TestJUnit.java new file mode 100644 index 000000000..bda291eeb --- /dev/null +++ b/packages/jpl/src/java/jpl/test/TestJUnit.java @@ -0,0 +1,680 @@ +// Created on 25-Jul-2004 +package jpl.test; + +import java.util.Map; + +import jpl.Atom; +import jpl.Compound; +import jpl.Integer; +import jpl.JPL; +import jpl.PrologException; +import jpl.Query; +import jpl.Term; +import jpl.Util; +import jpl.Variable; +import jpl.fli.Prolog; +import junit.framework.TestCase; +import junit.framework.TestSuite; + +// This class defines all the tests which are run from Java. +// It needs junit.framework.TestCase and junit.framework.TestSuite, which are not supplied with JPL. +public class TestJUnit extends TestCase { + public static long fac(long n) { // complements jpl:jpl_test_fac(+integer,-integer) + if (n == 1) { + return 1; + } else if (n > 1) { + return n * ((jpl.Integer) Query.oneSolution("jpl_test_fac(?,F)", new Term[] { new jpl.Integer(n - 1) }).get("F")).longValue(); + } else { + return 0; + } + } + public TestJUnit(String name) { + super(name); + } + public static junit.framework.Test suite() { + return new TestSuite(TestJUnit.class); + } + public static void main(String args[]) { + junit.textui.TestRunner.run(suite()); + } + protected void setUp() { + // initialization code + String startup = System.getenv("SWIPL_BOOT_FILE"); + if ( startup == null ) { + startup = "../../src/swipl.prc"; + } + Prolog.set_default_init_args(new String[] { "swipl.dll", "-x", startup, "-f", "none", "-g", "true", "-q", "--home=../.." }); + assertTrue((new Query("consult(test_jpl)")).hasSolution()); + assertTrue((new Query("use_module(library(jpl))")).hasSolution()); + } + protected void tearDown() { + // cleanup code + } + // + public void testMasstest() { + assertTrue((new Query("assert(diagnose_declaration(_,_,_,[not,a,real,error]))")).hasSolution()); + } + public void testSameLibVersions1() { + String java_lib_version = JPL.version_string(); + String c_lib_version = jpl.fli.Prolog.get_c_lib_version(); + assertTrue("java_lib_version(" + java_lib_version + ") is same as c_lib_version(" + c_lib_version + ")", java_lib_version.equals(c_lib_version)); + } + public void testSameLibVersions2() { + String java_lib_version = JPL.version_string(); + String pl_lib_version = ((Term) (new Query(new Compound("jpl_pl_lib_version", new Term[] { new Variable("V") })).oneSolution().get("V"))).name(); + assertTrue("java_lib_version(" + java_lib_version + ") is same as pl_lib_version(" + pl_lib_version + ")", java_lib_version.equals(pl_lib_version)); + } + public void testAtomName1() { + String name = "fred"; + Atom a = new Atom(name); + assertEquals("an Atom's name is that with which it was created", a.name(), name); + } + public void testAtomName2() { + String name = "ha ha"; + Atom a = new Atom(name); + assertEquals("an Atom's name is that with which it was created", a.name(), name); + } + public void testAtomName3() { + String name = "3"; + Atom a = new Atom(name); + assertEquals("an Atom's name is that with which it was created", a.name(), name); + } + public void testAtomToString1() { + String name = "fred"; + String toString = "fred"; + Atom a = new Atom(name); + assertEquals("an Atom's .toString() value is quoted iff appropriate", a.toString(), toString); + } + public void testAtomToString2() { + String name = "ha ha"; + String toString = "'ha ha'"; + Atom a = new Atom(name); + assertEquals("an Atom's .toString() value is quoted iff appropriate", a.toString(), toString); + } + public void testAtomToString3() { + String name = "3"; + String toString = "'3'"; + Atom a = new Atom(name); + assertEquals("an Atom's .toString() value is quoted iff appropriate", a.toString(), toString); + } + public void testAtomArity() { + Atom a = new Atom("willy"); + assertEquals("an Atom has arity zero", a.arity(), 0); + } + public void testAtomEquality1() { + String name = "fred"; + Atom a1 = new Atom(name); + Atom a2 = new Atom(name); + assertEquals("two Atoms created with the same name are equal", a1, a2); + } + public void testAtomIdentity() { // how could this fail?! + String name = "fred"; + Atom a1 = new Atom(name); + Atom a2 = new Atom(name); + assertNotSame("two Atoms created with the same name are not identical", a1, a2); + } + public void testAtomHasFunctorNameZero() { + String name = "sam"; + Atom a = new Atom(name); + assertTrue(a.hasFunctor(name, 0)); + } + public void testAtomHasFunctorWrongName() { + assertFalse("an Atom does not have a functor whose name is other than that with which the Atom was created", new Atom("wally").hasFunctor("poo", 0)); + } + public void testAtomHasFunctorWrongArity() { + String name = "ted"; + assertFalse("an Atom does not have a functor whose arity is other than zero", new Atom(name).hasFunctor(name, 1)); + } + public void testVariableBinding1() { + Term lhs = new Compound("p", new Term[] { new Variable("X"), new Variable("Y") }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + Map soln = new Query(goal).oneSolution(); + assertTrue("two variables with different names can bind to distinct atoms", soln != null && ((Term) soln.get("X")).name().equals("a") && ((Term) soln.get("Y")).name().equals("b")); + } + public void testVariableBinding2() { + Term lhs = new Compound("p", new Term[] { new Variable("X"), new Variable("X") }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertFalse("two distinct Variables with same name cannot unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testVariableBinding3() { + Variable X = new Variable("X"); + Term lhs = new Compound("p", new Term[] { X, X }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertFalse("two occurrences of same named Variable cannot unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testVariableBinding4() { + Term lhs = new Compound("p", new Term[] { new Variable("_"), new Variable("_") }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertTrue("two distinct anonymous Variables can unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testVariableBinding5() { + Variable Anon = new Variable("_"); + Term lhs = new Compound("p", new Term[] { Anon, Anon }); + Term rhs = new Compound("p", new Term[] { new Atom("a"), new Atom("b") }); + Term goal = new Compound("=", new Term[] { lhs, rhs }); + assertTrue("two occurrences of same anonymous Variable can unify with distinct atoms", new Query(goal).hasSolution()); + } + public void testAtomEquality2() { + Atom a = new Atom("a"); + assertTrue("two occurrences of same Atom are equal by .equals()", a.equals(a)); + } + public void testAtomEquality3() { + assertTrue("two distinct Atoms with same names are equal by .equals()", (new Atom("a")).equals(new Atom("a"))); + } + public void testTextToTerm1() { + String text = "fred(B,p(A),[A,B,C])"; + Term t = Util.textToTerm(text); + assertTrue("Util.textToTerm() converts \"fred(B,p(A),[A,B,C])\" to a corresponding Term", t.hasFunctor("fred", 3) && t.arg(1).isVariable() && t.arg(1).name().equals("B") + && t.arg(2).hasFunctor("p", 1) && t.arg(2).arg(1).isVariable() && t.arg(2).arg(1).name().equals("A")); + } + public void testArrayToList1() { + Term l2 = Util.termArrayToList(new Term[] { new Atom("a"), new Atom("b"), new Atom("c"), new Atom("d"), new Atom("e") }); + Query q9 = new Query(new Compound("append", new Term[] { new Variable("Xs"), new Variable("Ys"), l2 })); + assertTrue("append(Xs,Ys,[a,b,c,d,e]) has 6 solutions", q9.allSolutions().length == 6); + } + public void testArrayToList2() { + String goal = "append(Xs,Ys,[a,b,c,d,e])"; + assertTrue(goal + " has 6 solutions", Query.allSolutions(goal).length == 6); + } + public void testLength1() { + Query q5 = new Query(new Compound("length", new Term[] { new Variable("Zs"), new jpl.Integer(2) })); + Term zs = (Term) (q5.oneSolution().get("Zs")); + assertTrue("length(Zs,2) binds Zs to a list of two distinct variables " + zs.toString(), zs.hasFunctor(".", 2) && zs.arg(1).isVariable() && zs.arg(2).hasFunctor(".", 2) + && zs.arg(2).arg(1).isVariable() && zs.arg(2).arg(2).hasFunctor("[]", 0) && !zs.arg(1).name().equals(zs.arg(2).arg(1).name())); + } + public void testGenerate1() { // we chickened out of verifying each solution :-) + String goal = "append(Xs,Ys,[_,_,_,_,_])"; + assertTrue(goal + " has 6 solutions", Query.allSolutions(goal).length == 6); + } + public void testPrologException1() { + try { + new Query("p(]"); // writes junk to stderr and enters debugger unless flag debug_on_error = false + } catch (PrologException e) { + assertTrue("new Query(\"p(]\") throws a PrologException " + e.toString(), true); + return; + } + fail("new Query(\"p(]\") oughta throw a PrologException"); + } + public void testAtom1() { + assertTrue("new Atom(\"3 3\")" + (new Atom("3 3")).toString(), true); + } + public void testTextToTerm2() { + String text1 = "fred(?,2,?)"; + String text2 = "[first(x,y),A]"; + Term plist = Util.textToTerm(text2); + Term[] ps = plist.toTermArray(); + Term t = Util.textToTerm(text1).putParams(ps); + assertTrue("fred(?,2,?) .putParams( [first(x,y),A] )", t.hasFunctor("fred", 3) && t.arg(1).hasFunctor("first", 2) && t.arg(1).arg(1).hasFunctor("x", 0) && t.arg(1).arg(2).hasFunctor("y", 0) + && t.arg(2).hasFunctor(2, 0) && t.arg(3).isVariable() && t.arg(3).name().equals("A")); + } + public void testDontTellMeMode1() { + final Query q = new Query("setof(_M,current_module(_M),_Ms),length(_Ms,N)"); + JPL.setDTMMode(true); + assertTrue("in dont-tell-me mode, setof(_M,current_module(_M),_Ms),length(_Ms,N) returns binding for just one variable", q.oneSolution().keySet().size() == 1); + } + public void testDontTellMeMode2() { + final Query q = new Query("setof(_M,current_module(_M),_Ms),length(_Ms,N)"); + JPL.setDTMMode(false); + assertTrue("not in dont-tell-me mode, setof(_M,current_module(_M),_Ms),length(_Ms,N) returns binding for three variables", q.oneSolution().keySet().size() == 3); + } + public void testModulePrefix1() { + assertTrue(Query.hasSolution("call(user:true)")); + } + private void testMutualRecursion(int n, long f) { // f is the expected result for fac(n) + try { + assertEquals("mutual recursive Java<->Prolog factorial: fac(" + n + ") = " + f, fac(n), f); + } catch (Exception e) { + fail("fac(" + n + ") threw " + e); + } + } + public void testMutualRecursion1() { + testMutualRecursion(1, 1); + } + public void testMutualRecursion2() { + testMutualRecursion(2, 2); + } + public void testMutualRecursion3() { + testMutualRecursion(3, 6); + } + public void testMutualRecursion10() { + testMutualRecursion(10, 3628800); + } + public void testIsJNull1() { + Term t = (Term) (new Query("X = @(null)")).oneSolution().get("X"); + assertTrue("@(null) . isJNull() succeeds", t.isJNull()); + } + public void testIsJNull2() { + Term t = (Term) (new Query("X = @(3)")).oneSolution().get("X"); + assertFalse("@(3) . isJNull() fails", t.isJNull()); + } + public void testIsJNull3() { + Term t = (Term) (new Query("X = _")).oneSolution().get("X"); + assertFalse("_ . isJNull() fails", t.isJNull()); + } + public void testIsJNull4() { + Term t = (Term) (new Query("X = @(true)")).oneSolution().get("X"); + assertFalse("@(true) . isJNull() fails", t.isJNull()); + } + public void testIsJNull5() { + Term t = (Term) (new Query("X = @(false)")).oneSolution().get("X"); + assertFalse("@(false) . isJNull() fails", t.isJNull()); + } + public void testIsJTrue1() { + Term t = (Term) (new Query("X = @(true)")).oneSolution().get("X"); + assertTrue("@(true) . isJTrue() succeeds", t.isJTrue()); + } + public void testIsJTrue2() { + Term t = (Term) (new Query("X = @(3)")).oneSolution().get("X"); + assertFalse("@(3) . isJTrue() fails", t.isJTrue()); + } + public void testIsJTrue3() { + Term t = (Term) (new Query("X = _")).oneSolution().get("X"); + assertFalse("_ . isJTrue() fails", t.isJTrue()); + } + public void testIsJTrue4() { + Term t = (Term) (new Query("X = @(false)")).oneSolution().get("X"); + assertFalse("@(false) . isJTrue() fails", t.isJTrue()); + } + public void testIsJVoid1() { + Term t = (Term) (new Query("X = @(void)")).oneSolution().get("X"); + assertTrue("@(void) . isJVoid() succeeds", t.isJVoid()); + } + public void testIsJVoid2() { + Term t = (Term) (new Query("X = @(3)")).oneSolution().get("X"); + assertFalse("@(3) . isJVoid() fails", t.isJVoid()); + } + public void testIsJVoid3() { + Term t = (Term) (new Query("X = _")).oneSolution().get("X"); + assertFalse("_ . isJVoid() fails", t.isJVoid()); + } + public void testTypeName1() { + assertEquals("Y = foo binds Y to an Atom", ((Term) Query.oneSolution("Y = foo").get("Y")).typeName(), "Atom"); + } + public void testTypeName2() { + assertEquals("Y = 3.14159 binds Y to a Float", ((Term) Query.oneSolution("Y = 3.14159").get("Y")).typeName(), "Float"); + } + public void testTypeName4() { + assertEquals("Y = 6 binds Y to an Integer", ((Term) Query.oneSolution("Y = 6").get("Y")).typeName(), "Integer"); + } + public void testTypeName5() { + assertEquals("Y = _ binds Y to a Variable", ((Term) Query.oneSolution("Y = _").get("Y")).typeName(), "Variable"); + } + public void testTypeName3() { + assertEquals("Y = f(x) binds Y to a Compound", ((Term) Query.oneSolution("Y = f(x)").get("Y")).typeName(), "Compound"); + } + public void testGoalWithModulePrefix1() { + String goal = "jpl:jpl_modifier_bit(volatile,I)"; + assertTrue(goal + " binds I to an integer", ((Term) Query.oneSolution(goal).get("I")).isInteger()); + } + public void testGoalWithModulePrefix2() { + String goal = "user:length([],0)"; + assertTrue(goal + " succeeds", Query.hasSolution(goal)); + } + public void testGoalWithModulePrefix3() { + try { + (new Query("3:length([],0)")).hasSolution(); + // shouldn't get to here + fail("(new Query(\"3:length([],0)\")).hasSolution() didn't throw exception"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("type_error", 2) && e.term().arg(1).arg(1).hasFunctor("atom", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"3:length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"3:length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + public void testGoalWithModulePrefix4() { + try { + (new Query("_:length([],0)")).hasSolution(); + // shouldn't get to here + fail("bad (unbound) module prefix"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("instantiation_error", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"_:length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"_:length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + public void testGoalWithModulePrefix5() { + try { + (new Query("f(x):length([],0)")).hasSolution(); + // shouldn't get to here + fail("bad (compound) module prefix"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("type_error", 2) && e.term().arg(1).arg(1).hasFunctor("atom", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + public void testGoalWithModulePrefix6() { + try { + (new Query("no_such_module:no_such_predicate(0)")).hasSolution(); + // shouldn't get to here + fail("bad (nonexistent) module prefix"); + } catch (jpl.PrologException e) { + // correct exception class, but is it correct in detail? + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("existence_error", 2) && e.term().arg(1).arg(1).hasFunctor("procedure", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("(new Query(\"f(x):length([],0)\")).hasSolution() threw wrong class of exception: " + e); + } + } + // public void testFetchCyclicTerm(){ + // assertTrue((new Query("X=f(X)")).hasSolution()); + // } + public void testFetchLongList0() { + assertTrue((new Query("findall(foo(N),between(0,10,N),L)")).hasSolution()); + } + public void testFetchLongList1() { + assertTrue((new Query("findall(foo(N),between(0,100,N),L)")).hasSolution()); + } + public void testFetchLongList2() { + assertTrue((new Query("findall(foo(N),between(0,1000,N),L)")).hasSolution()); + } + public void testFetchLongList2c() { + assertTrue((new Query("findall(foo(N),between(0,1023,N),L)")).hasSolution()); + } + //public void testFetchLongList2a() { /* leads to stack overflow */ + // assertTrue((new Query("findall(foo(N),between(0,2000,N),L)")).hasSolution()); + //} + // public void testFetchLongList2b() { + // assertTrue((new Query("findall(foo(N),between(0,3000,N),L)")).hasSolution()); + // } + // public void testFetchLongList3() { + // assertTrue((new Query("findall(foo(N),between(0,10000,N),L)")).hasSolution()); + // } + public void testUnicode0() { + assertTrue(Query.hasSolution("atom_codes(?,[32])", new Term[] { new Atom(" ") })); + } + public void testUnicode0a() { + assertTrue(Query.hasSolution("atom_codes(?,[32])", new Term[] { new Atom("\u0020") })); + } + public void testUnicode0b() { + assertTrue(Query.hasSolution("atom_codes(?,[0])", new Term[] { new Atom("\u0000") })); + } + public void testUnicode0c() { + assertTrue(Query.hasSolution("atom_codes(?,[1])", new Term[] { new Atom("\u0001") })); + } + public void testUnicode0d() { + assertTrue(Query.hasSolution("atom_codes(?,[127])", new Term[] { new Atom("\u007F") })); + } + public void testUnicode0e() { + assertTrue(Query.hasSolution("atom_codes(?,[128])", new Term[] { new Atom("\u0080") })); + } + public void testUnicode0f() { + assertTrue(Query.hasSolution("atom_codes(?,[255])", new Term[] { new Atom("\u00FF") })); + } + public void testUnicode0g() { + assertTrue(Query.hasSolution("atom_codes(?,[256])", new Term[] { new Atom("\u0100") })); + } + public void testUnicode1() { + assertTrue(Query.hasSolution("atom_codes(?,[0,127,128,255])", new Term[] { new Atom("\u0000\u007F\u0080\u00FF") })); + } + public void testUnicode2() { + assertTrue(Query.hasSolution("atom_codes(?,[256,32767,32768,65535])", new Term[] { new Atom("\u0100\u7FFF\u8000\uFFFF") })); + } + public void testStringXput1() { + Term a = (Term) (Query.oneSolution("string_concat(foo,bar,S)").get("S")); + assertTrue(a.name().equals("foobar")); + } + public void testStringXput2() { + String s1 = "\u0000\u007F\u0080\u00FF"; + String s2 = "\u0100\u7FFF\u8000\uFFFF"; + String s = s1 + s2; + Term a1 = new Atom(s1); + Term a2 = new Atom(s2); + Term a = (Term) (Query.oneSolution("string_concat(?,?,S)", new Term[] { a1, a2 }).get("S")); + assertEquals(a.name(), s); + } + // public void testMaxInteger1(){ + // assertEquals(((Term)(Query.oneSolution("current_prolog_flag(max_integer,I)").get("I"))).longValue(), java.lang.Long.MAX_VALUE); // i.e. 9223372036854775807L + // } + // public void testSingleton1() { + // assertTrue(Query.hasSolution("style_check(-singleton),consult('test_singleton.pl')")); + // } + public void testStaticQueryInvalidSourceText2() { + String goal = "p(]"; + try { + Query.hasSolution(goal); + } catch (jpl.PrologException e) { + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("syntax_error", 1) && e.term().arg(1).arg(1).hasFunctor("cannot_start_term", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("Query.hasSolution(" + goal + ") threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("Query.hasSolution(" + goal + ") threw wrong class of exception: " + e); + } + } + public void testStaticQueryInvalidSourceText1() { + String goal = "bad goal"; + try { + Query.hasSolution(goal); + } catch (jpl.PrologException e) { + if (e.term().hasFunctor("error", 2) && e.term().arg(1).hasFunctor("syntax_error", 1) && e.term().arg(1).arg(1).hasFunctor("operator_expected", 0)) { + // OK: an appropriate exception was thrown + } else { + fail("Query.hasSolution(" + goal + ") threw incorrect PrologException: " + e); + } + } catch (Exception e) { + fail("Query.hasSolution(" + goal + ") threw wrong class of exception: " + e); + } + } + public void testStaticQueryNSolutions1() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + int n = 5; + assertTrue("Query.nSolutions(" + goal + ", " + n + ") returns " + n + " solutions", Query.nSolutions(goal, n).length == n); + } + public void testStaticQueryNSolutions2() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + int n = 0; + assertTrue("Query.nSolutions(" + goal + ", " + n + ") returns " + n + " solutions", Query.nSolutions(goal, n).length == n); + } + public void testStaticQueryNSolutions3() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + int n = 20; + assertTrue("Query.nSolutions(" + goal + ", " + n + ") returns 10 solutions", Query.nSolutions(goal, n).length == 10); + } + public void testStaticQueryAllSolutions1() { + String goal = "member(X, [0,1,2,3,4,5,6,7,8,9])"; + assertTrue("Query.allSolutions(" + goal + ") returns 10 solutions", Query.allSolutions(goal).length == 10); + } + public void testStaticQueryHasSolution1() { + String goal = "memberchk(13, [?,?,?])"; + Term[] params = new Term[] { new Integer(12), new Integer(13), new Integer(14) }; + assertTrue(Query.hasSolution(goal, params)); + } + public void testStaticQueryHasSolution2() { + String goal = "memberchk(23, [?,?,?])"; + Term[] params = new Term[] { new Integer(12), new Integer(13), new Integer(14) }; + assertFalse(Query.hasSolution(goal, params)); + } + public void testUtilListToTermArray1() { + String goal = "T = [a,b,c]"; + Term list = (Term) Query.oneSolution(goal).get("T"); + Term[] array = Util.listToTermArray(list); + assertTrue(array[2].isAtom() && array[2].name().equals("c")); + } + public void testTermToTermArray1() { + String goal = "T = [a,b,c]"; + Term list = (Term) Query.oneSolution(goal).get("T"); + Term[] array = list.toTermArray(); + assertTrue(array[2].isAtom() && array[2].name().equals("c")); + } + public void testJRef1() { + // System.out.println("java.library.path=" + System.getProperties().get("java.library.path")); + // System.out.println("jpl.c version = " + jpl.fli.Prolog.get_c_lib_version()); + int i = 76543; + Integer I = new Integer(i); + Query q = new Query("jpl_call(?,intValue,[],I2)", new Term[] { Term.objectToJRef(I) }); + Term I2 = (Term) q.oneSolution().get("I2"); + assertTrue(I2.isInteger() && I2.intValue() == i); + } + public void testBerhhard1() { + assertTrue(Query.allSolutions( "consult(library('lists'))" ).length == 1); + } + public void testJRef2() { + int i = 76543; + Integer I = new Integer(i); + Query q = new Query("jpl_call(?,intValue,[],I2)", jpl.JPL.newJRef(I)); + Term I2 = (Term) q.oneSolution().get("I2"); + assertTrue(I2.isInteger() && I2.intValue() == i); + } + public void testJRef3() { + StringBuffer sb = new StringBuffer(); + Query.oneSolution("jpl_call(?,append,['xyz'],_)", new Term[] {JPL.newJRef(sb)}); + assertTrue(sb.toString().equals("xyz")); + } + public void testJRef4() { + Term jrefSB = (Term) Query.oneSolution("jpl_new('java.lang.StringBuffer',['abc'],SB)").get("SB"); + assertTrue(jrefSB.isJRef() && ((StringBuffer) jrefSB.jrefToObject()).toString().equals("abc")); + } + public void testJRef5() { + String token = "foobar345"; + Term a = (Term) (Query.oneSolution("jpl_new('java.lang.StringBuffer',[?],A)", new Term[] {new Atom(token)}).get("A")); + assertTrue(((java.lang.StringBuffer) (a.jrefToObject())).toString().equals(token)); + } + public void testRef6() { + Term nullJRef = new Compound("@", new Term[] {new Atom("null")}); + Object nullObject = nullJRef.jrefToObject(); + assertNull("@(null) .jrefToObject() yields null", nullObject); + } + public void testRef7() { + Term badJRef = new Compound("@", new Term[] {new Atom("foobar")}); + try { + badJRef.jrefToObject(); + // shouldn't get to here + fail("@(foobar) .jrefToObject() shoulda thrown JPLException"); + } catch (jpl.JPLException e) { + // correct exception class, but is it correct in detail? + if (e.getMessage().endsWith("term is not a JRef")) { + // OK: an appropriate exception was thrown + } else { + fail("@(foobar) .jrefToObject() threw incorrect JPLException: " + e); + } + } catch (Exception e) { + fail("@(foobar) .jrefToObject() threw wrong class of exception: " + e); + } + } + public void testForeignFrame1() { + int ls1 = ((Term) (Query.oneSolution("statistics(localused,LS)").get("LS"))).intValue(); + int ls2 = ((Term) (Query.oneSolution("statistics(localused,LS)").get("LS"))).intValue(); + assertTrue("local stack size unchanged after query", ls1 == ls2); + } + public void testOpenGetClose1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while ((soln = q.getSolution()) != null) { + sb.append(((Atom) soln.get("C")).name()); + } + q.close(); + assertEquals("prolog", sb.toString()); + } + public void testOpenGetClose2() { + Query q = new Query("dummy"); // we're not going to open this... + try { + q.getSolution(); // but mistakenly try to get a solution from it... + } catch (jpl.JPLException e) { // correct exception class, but is it correct in detail? + if (e.getMessage().endsWith("Query is not open")) { // ...which should throw a JPLException like this + // OK: an appropriate exception was thrown + } else { + fail("jpl.Query#getSolution() threw incorrect JPLException: " + e); + } + } catch (Exception e) { + fail("jpl.Query#getSolution() threw wrong class of exception: " + e); + } + } + public void testOpen1() { + Query q = new Query("dummy"); + assertTrue("a newly created query is not open", !q.isOpen()); + } + public void testOpen2() { + Query q = new Query("fail"); + q.open(); + assertTrue("a newly opened query which has no solutions is open", q.isOpen()); + } + public void testGetSolution1() { + Query q = new Query("fail"); + q.open(); + q.getSolution(); + assertTrue("an opened query on which getSolution has failed once is closed", !q.isOpen()); + } + public void testGetSolution2() { + Query q = new Query("fail"); // this query has no solutions + q.open(); // this opens the query + q.getSolution(); // this finds no solution, and closes the query + try { + q.getSolution(); // this call is invalid, as the query is closed + // shouldn't get to here + fail("jpl.Query#getSolution() shoulda thrown JPLException"); + } catch (jpl.JPLException e) { // correct exception class, but is it correct in detail? + if (e.getMessage().endsWith("Query is not open")) { // ...which should throw a JPLException like this + // OK: an appropriate exception was thrown + } else { + fail("jpl.Query#getSolution() threw incorrect JPLException: " + e); + } + } catch (Exception e) { + fail("jpl.Query#getSolution() threw wrong class of exception: " + e); + } + } + public void testHasMoreSolutions1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while (q.hasMoreSolutions()) { + soln = q.nextSolution(); + sb.append(((Atom) soln.get("C")).name()); + } + q.close(); + assertEquals("Query#hasMoreSolutions() + Query#nextSolution() work as intended", "prolog", sb.toString()); + } + public void testHasMoreElements1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while (q.hasMoreElements()) { + soln = (Map) q.nextElement(); + sb.append(((Atom) soln.get("C")).name()); + } + q.close(); + assertEquals("Query#hasMoreElements() + Query#nextElement() work as intended", "prolog", sb.toString()); + } + public void testStackedQueries1() { + StringBuffer sb = new StringBuffer(); + Query q = new Query("atom_chars(prolog, Cs), member(C, Cs)"); + Map soln; + q.open(); + while ((soln = q.getSolution()) != null) { + Atom a = (Atom) soln.get("C"); + if (Query.hasSolution("memberchk(?, [l,o,r])", new Term[] {a})) { // this query opens and closes while an earlier query is still open + sb.append(((Atom) soln.get("C")).name()); + } + } + assertTrue(!q.isOpen()); // q will have been closed by the final getSolution() + assertEquals("rolo", sb.toString()); + } + +} diff --git a/packages/jpl/src/java/jpl/test/TestOLD.java b/packages/jpl/src/java/jpl/test/TestOLD.java new file mode 100644 index 000000000..496fb3800 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/TestOLD.java @@ -0,0 +1,142 @@ +package jpl.test; + +import java.util.Map; +import jpl.Atom; +import jpl.Compound; +import jpl.Integer; +import jpl.JPL; +import jpl.PrologException; +import jpl.Query; +import jpl.Term; +import jpl.Util; +import jpl.Variable; +import jpl.fli.Prolog; + +// This class is nearly obsolete; most of its tests have been migrated to TestJUnit. +public class TestOLD { + private static void test10() { + System.err.println("test10:"); + System.err.println(" java_lib_version = " + JPL.version_string()); + System.err.println(" c_lib_version = " + jpl.fli.Prolog.get_c_lib_version()); + System.err.println(" pl_lib_version = " + new Query(new Compound("jpl_pl_lib_version", new Term[] { new Variable("V") })).oneSolution().get("V")); + System.err.println(" java.version = " + System.getProperty("java.version")); + System.err.println(" os.name = " + System.getProperty("os.name")); + System.err.println(" os.arch = " + System.getProperty("os.arch")); + System.err.println(" os.version = " + System.getProperty("os.version")); + System.err.println(); + } + private static void test10j() { + Term l2 = Util.termArrayToList(new Term[] { new Atom("a"), new Atom("b"), new Atom("c"), new Atom("d"), new Atom("e") }); + Query q9 = new Query(new Compound("append", new Term[] { new Variable("Xs"), new Variable("Ys"), l2 })); + Map[] s9s = q9.allSolutions(); + System.err.println("test10j:"); + for (int i = 0; i < s9s.length; i++) { + System.err.println(" append(Xs,Ys,[a,b,c,d,e]) -> " + Util.toString(s9s[i])); + } + System.err.println(); + } + private static void test10k() { + String[] args = jpl.fli.Prolog.get_default_init_args(); + String which; + String s = ""; + System.err.println("test10k:"); + if (args == null) { + args = jpl.fli.Prolog.get_actual_init_args(); + which = "actual"; + } else { + which = "default"; + } + for (int i = 0; i < args.length; i++) { + s = s + args[i] + " "; + } + System.err.println(" " + which + "_init_args = " + s + '\n'); + } + private static void test10l() { + Query q5 = new Query(new Compound("length", new Term[] { new Variable("Zs"), new jpl.Integer(5) })); + Map s5 = q5.oneSolution(); + System.err.println("test10l:"); + System.err.println(" length(Zs,5)"); + System.err.println(" " + Util.toString(s5)); + System.err.println(" Zs = " + (Term) s5.get("Zs")); + System.err.println(); + } + private static void test10m() { + String text = "append(Xs,Ys,[_,_,_,_,_])"; + Query q = new Query(text); + Map[] ss = q.allSolutions(); + System.err.println("test10m:"); + System.err.println(" all solutions of " + text); + for (int i = 0; i < ss.length; i++) { + System.err.println(" " + Util.toString(ss[i])); + } + System.err.println(); + } + private static void test10o() { + System.err.println("test10o:"); + Term l2b = Util.termArrayToList(new Term[] { new Variable("A"), new Variable("B"), new Variable("C"), new Variable("D"), new Variable("E") }); + Query q9b = new Query(new Compound("append", new Term[] { new Variable("Xs"), new Variable("Ys"), l2b })); + Map[] s9bs = q9b.allSolutions(); + for (int i = 0; i < s9bs.length; i++) { + System.err.println(" append(Xs,Ys,[A,B,C,D,E]) -> " + Util.toString(s9bs[i])); + } + System.err.println(); + } + private static void test10q() { + System.err.println("test10q:"); + System.err.println((new Compound("Bad Name", new Term[] { new Atom("3 3") })).toString()); + System.err.println(); + } + private static void test10s() { + final Query q = new Query("jpl_slow_goal"); // 10 successive sleep(1) + System.err.println("test10s:"); + Thread t = new Thread(new Runnable() { + public void run() { + try { + System.err.println("q.hasSolution() ... "); + System.err.println(q.hasSolution() ? "finished" : "failed"); + } catch (Exception e) { + System.err.println("q.hasSolution() threw " + e); + } + } + }); + t.start(); // call the query in a separate thread + System.err.println("pausing for 2 secs..."); + try { + Thread.sleep(2000); + } catch (InterruptedException e) { + ; + } // wait a coupla seconds for it to get started + // (new Query("set_prolog_flag(abort_with_exception, true)")).hasSolution(); + System.err.println("calling q.abort()..."); + q.abort(); + System.err.println(); + } + public static void main(String argv[]) { + Prolog.set_default_init_args(new String[] { "libpl.dll", "-f", "none", "-g", "set_prolog_flag(debug_on_error,false)", "-q" }); + System.err.println("tag = " + Prolog.object_to_tag(new Query("hello"))); + test10k(); + test10(); + // test10h(); + // test10i(); + test10j(); + test10k(); + test10l(); + test10m(); + // test10n(); + test10o(); + //test10p(); + test10q(); + // test10r(); + // test10s(); + // test10t(); + // test10u(); + // test10v(); + String s = new String("" + '\0' + '\377'); + System.err.println("s.length = " + s.length()); + for (int i = 0; i < s.length(); i++) { + System.err.print((new Integer(s.charAt(i))).toString() + " "); + } + System.err.println(); + System.err.println(new Query("atom_codes(A,[127,128,255,0])").oneSolution().toString()); + } +} \ No newline at end of file diff --git a/packages/jpl/src/java/jpl/test/family.pl b/packages/jpl/src/java/jpl/test/family.pl new file mode 100644 index 000000000..95203f0ff --- /dev/null +++ b/packages/jpl/src/java/jpl/test/family.pl @@ -0,0 +1,25 @@ +% a simple database for Family.java + +:- if(current_prolog_flag(dialect, yap)). +sleep(T) :- unix(sleep(T)). +:- endif. + +child_of( joe, ralf ). +child_of( mary, joe ). +child_of( steve, joe ). + +descendent_of( X, Y ) :- + child_of( X, Y ). +descendent_of( X, Y ) :- + child_of( Z, Y ), + descendent_of( X, Z ). + +p( A, B) :- + ( q( A, B) + -> write( 'OK'-q(A,B)), nl + ; write( 'FAIL'-q(A,B)), nl + ). + +q( 3, 4). + +r( 5, 5). diff --git a/packages/jpl/src/java/jpl/test/test.pl b/packages/jpl/src/java/jpl/test/test.pl new file mode 100644 index 000000000..8a9e6bd01 --- /dev/null +++ b/packages/jpl/src/java/jpl/test/test.pl @@ -0,0 +1,9 @@ +p( N, T) :- + ( N > 1 + -> Nx is N-1, + p( Nx, Tx), + T = a(Tx,Tx) + ; N == 1 + -> T = a + ). + diff --git a/packages/jpl/src/java/jpl/util/.cvsignore b/packages/jpl/src/java/jpl/util/.cvsignore new file mode 100644 index 000000000..6b468b62a --- /dev/null +++ b/packages/jpl/src/java/jpl/util/.cvsignore @@ -0,0 +1 @@ +*.class diff --git a/packages/jpl/src/java/jpl/util/Getenv.java b/packages/jpl/src/java/jpl/util/Getenv.java new file mode 100644 index 000000000..2c6f57181 --- /dev/null +++ b/packages/jpl/src/java/jpl/util/Getenv.java @@ -0,0 +1,53 @@ +package jpl.util; + +import java.io.BufferedReader; +import java.io.InputStream; +import java.io.InputStreamReader; + +public class Getenv + { + + public static void main(String args[]) + { + + try { + getenv(); + } + catch (java.io.IOException e) { } + } + + public static void getenv() + throws java.io.IOException, java.io.UnsupportedEncodingException + { + Runtime rt = Runtime.getRuntime(); + + String a[] = new String[3]; + a[0] = "CMD"; + a[1] = "/C"; + a[2] = "SET"; + + Process p = rt.exec(a); + + InputStream is = p.getInputStream(); + + InputStreamReader isr = new InputStreamReader(is,"UTF8"); + + BufferedReader br = new BufferedReader(isr); + + getenv1(br); + } + + static void getenv1(BufferedReader br) + throws java.io.IOException + { + + String s = br.readLine(); + + if ( s != null ) + { + System.out.println(s); + getenv1(br); + } + } + } + diff --git a/packages/jpl/src/java/jpl/util/HashedRefs.java b/packages/jpl/src/java/jpl/util/HashedRefs.java new file mode 100644 index 000000000..d6eefffae --- /dev/null +++ b/packages/jpl/src/java/jpl/util/HashedRefs.java @@ -0,0 +1,138 @@ +package jpl.util; + + +/** + * HashedRefs collision list. + */ +class HashedRefsEntry { + int hash; + Object obj; + public int iref; + public HashedRefsEntry next; +} + + +public +class HashedRefs { + /** + * The hash table data. + */ + public transient HashedRefsEntry table[]; + + /** + * The total number of entries in the hash table. + */ + private transient int count; + + /** + * Rehashes the table when count exceeds this threshold. + */ + private int threshold; + + /** + * The load factor for the hashtable. + */ + private float loadFactor; + + public HashedRefs(int initialCapacity, float loadFactor) { + if ((initialCapacity <= 0) || (loadFactor <= 0.0)) { + throw new IllegalArgumentException(); + } + this.loadFactor = loadFactor; + table = new HashedRefsEntry[initialCapacity]; + threshold = (int)(initialCapacity * loadFactor); + } + + public HashedRefs(int initialCapacity) { + this(initialCapacity, 0.75f); + } + + public HashedRefs() { + this(101, 0.75f); + } + + public int size() { + return count; + } + + protected void rehash() { + int oldCapacity = table.length; + HashedRefsEntry oldTable[] = table; + + int newCapacity = oldCapacity * 2 + 1; + HashedRefsEntry newTable[] = new HashedRefsEntry[newCapacity]; + + threshold = (int)(newCapacity * loadFactor); + table = newTable; + + for (int i = oldCapacity ; i-- > 0 ;) { + for (HashedRefsEntry old = oldTable[i] ; old != null ; ) { + HashedRefsEntry e = old; + old = old.next; + + int index = (e.hash & 0x7FFFFFFF) % newCapacity; + e.next = newTable[index]; + newTable[index] = e; + } + } + } + + public synchronized int add(Object obj, int iref) { + // Make sure the object reference is not null + if (obj == null) { + throw new NullPointerException(); + } + + // check whether object is already in the hashtable... + HashedRefsEntry tab[] = table; + int hash = java.lang.System.identityHashCode(obj); + int index = (hash & 0x7FFFFFFF) % tab.length; + for (HashedRefsEntry e = tab[index] ; e != null ; e = e.next) { + if ((e.hash == hash) && (e.obj == obj)) { + return e.iref; // existing global reference to this object + } + } + + if (count >= threshold) { + // Rehash the table if the threshold is exceeded + rehash(); + return add(obj, iref); + } + + // create a new entry... + HashedRefsEntry e = new HashedRefsEntry(); + e.hash = hash; + e.obj = obj; + e.iref = iref; + e.next = tab[index]; + tab[index] = e; + count++; + return 0; // indicates this reference has been added + } + + public synchronized boolean del(Object obj) { + HashedRefsEntry tab[] = table; + int hash = java.lang.System.identityHashCode(obj); + int index = (hash & 0x7FFFFFFF) % tab.length; + for (HashedRefsEntry e = tab[index], prev = null ; e != null ; prev = e, e = e.next) { + if ((e.hash == hash) && (e.obj == obj)) { + if (prev != null) { + prev.next = e.next; + } else { + tab[index] = e.next; + } + count--; + return true; + } + } + return false; + } + + public synchronized void clear() { + HashedRefsEntry tab[] = table; + for (int index = tab.length; --index >= 0; ) + tab[index] = null; + count = 0; + } + +} diff --git a/packages/jpl/src/java/jpl/util/Mod.java b/packages/jpl/src/java/jpl/util/Mod.java new file mode 100644 index 000000000..572e2bb2b --- /dev/null +++ b/packages/jpl/src/java/jpl/util/Mod.java @@ -0,0 +1,16 @@ +package jpl.util; + +public class Mod + { + public static void main(String args[]) + { + + System.out.println( " 17 % 5 = " + ( 17 % 5)); + System.out.println( " 17 % -5 = " + ( 17 % -5)); + System.out.println( "-17 % 5 = " + (-17 % 5)); + System.out.println( "-17 % -5 = " + (-17 % -5)); + while (true) + ; + } + } + diff --git a/packages/jpl/src/java/jpl/util/Overload.java b/packages/jpl/src/java/jpl/util/Overload.java new file mode 100644 index 000000000..bdc3014ad --- /dev/null +++ b/packages/jpl/src/java/jpl/util/Overload.java @@ -0,0 +1,11 @@ +package jpl.util; + +public class Overload { + static void m1(int a1, long a2) { + } + static void m1(long a1, int a2) { + } + public static void main(String[] args) { + m1((long) 0, 0); + } +} diff --git a/packages/jpl/src/java/jpl/util/Overload2.java b/packages/jpl/src/java/jpl/util/Overload2.java new file mode 100644 index 000000000..c741b40a5 --- /dev/null +++ b/packages/jpl/src/java/jpl/util/Overload2.java @@ -0,0 +1,13 @@ +package jpl.util; + +public class Overload2 + { + // experiment (why not read the language reference?) + public static int fred; + public static int fred() + { + return fred; + } + } + + diff --git a/packages/jpl/src/java/jpl/util/PopupMenuDemo.java b/packages/jpl/src/java/jpl/util/PopupMenuDemo.java new file mode 100644 index 000000000..3b8d0534a --- /dev/null +++ b/packages/jpl/src/java/jpl/util/PopupMenuDemo.java @@ -0,0 +1,137 @@ +package jpl.util; + +import java.awt.Point; +import java.awt.event.ActionEvent; +import java.awt.event.ActionListener; +import javax.swing.JFrame; +import javax.swing.JMenu; +import javax.swing.JMenuItem; +import javax.swing.JPopupMenu; + + +/* + * Adapted from a Swing Connection demo + * see pcm's jpl_demo:jpl_popup_demo/0 + */ +public class PopupMenuDemo extends JFrame + implements ActionListener { + private static final long serialVersionUID = 1L; + // JTextArea output; + public JPopupMenu popup; + JMenuItem source; + int mi; + + public PopupMenuDemo() { + + // Add regular components to the window, using the default BorderLayout. + // output = new JTextArea(5, 30); + // output.setEditable(false); + // getContentPane().add(new JScrollPane(output), BorderLayout.CENTER); + } + +/* JPopupMenu + +- JMenuItem + +- JMenuItem + +- JMenu ----- JPopupMenu + | +- JMenuItem + | +- JMenuItem + +- JMenuItem + +- JMenuItem + */ + public boolean search(JPopupMenu p) { + Object[] mes = p.getSubElements(); // array of JMenuItem or JMenu (see diagram) + int i; + + for ( i=0 ; i current_prolog_flag( max_integer, V1) + ; V1 is 2**63-1 + ), + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoDouble, [V1], V2). + +test( + method_static_echo_float_1, + [ setup(( + V1 = 1.5 + )), + true(( + V1 == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + method_static_echo_float_2, + [ setup(( + V1 is 2, + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + method_static_echo_float_3, + [ setup(( + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V1) + ; V1 is 2**63-1 % was 2**99 + ), + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + method_static_echo_float_4, + [ blocked('we do not yet widen unbounded integers to floats or doubles'), + setup(( + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V1) + ; V1 is 2**99 % an unbounded integer + ), + V2b is float(V1) + )), + true(( + V2 == V2b + )) + ] +) :- + jpl_call( 'jpl.test.Test', methodStaticEchoFloat, [V1], V2). + +test( + new_abstract_class_1, + [ setup(( + Classname = 'java.util.Dictionary' + )), + throws( + error( + type_error(concrete_class,Classname), + context(jpl_new/3,_) + ) + ) + ] +) :- + jpl_new( Classname, [], _). + +test( + new_array_boolean_from_val_1, + [ setup(( + jpl_false( V) + )), + true(( + V == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', newArrayBooleanFromValue, [V], A), + jpl_get( A, 0, V2). + +test( + new_array_double_from_val_1, + [ setup(( + V is 1.5 + )), + true(( + V == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', newArrayDoubleFromValue, [V], A), + jpl_get( A, 0, V2). + +test( + new_array_float_from_val_1, + [ setup(( + V is 1.5 + )), + true(( + V == V2 + )) + ] +) :- + jpl_call( 'jpl.test.Test', newArrayFloatFromValue, [V], A), + jpl_get( A, 0, V2). + +test( + new_interface_1, + [ setup(( + Classname = 'java.util.Enumeration' + )), + throws( + error( + type_error(concrete_class,Classname), + context(jpl_new/3,_) + ) + ) + ] +) :- + jpl_new( Classname, [], _). + +test( + new_param_cyclic_term_1, + [ setup(( + T = f(T) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_new/3,_) + ) + ) + ] +) :- + jpl_new( 'jpl.test.Test', [{T}], _). + +test( + prolog_calls_java_calls_prolog_1, + [ true(( + V == @(true) + )) + ] +) :- + jpl_new( 'jpl.Query', ['4 is 2+2'], Q), + jpl_call( Q, hasSolution, [], V). + +test( + set_array_element_cyclic_term_1, + [ setup(( + T = f(T), + jpl_new( array(class([jpl,test],['Test'])), 5, A) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 0, {T}). + +test( + set_array_elements_bad_type_1, + [ setup(( + jpl_new( array(byte), 3, A) + )), + throws( + error( + type_error(array(byte),[128]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 0, 128). + +test( + set_array_length_1, + [ setup(( + jpl_new( array(byte), 6, A) + )), + throws( + error( + permission_error(modify,final_field,length), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, length, 13). + +test( + set_field_bad_field_spec_1, + [ setup(( + BadFieldName = 3.7 + )), + throws( + error( + type_error(field_name,BadFieldName), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', BadFieldName, a). + +test( + set_field_instance_cyclic_term_1, + [ setup(( + T = f(T), + jpl_new( 'jpl.test.Test', [], Test) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( Test, instanceTerm, {T}). + +test( + set_field_long_array_1, + [ setup(( + jpl_new( array(long), [1,2,3], LongArray) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticLongArray, LongArray). + +test( + set_field_long_array_2, + [ setup(( + jpl_new( array(int), [1,2,3], IntArray) + )), + throws( + error( + type_error('[J',IntArray), % NB '[J' is *not* how the type was specified in the failing goal + context( + jpl_set/3, + 'the value is not assignable to the named field of the class' + ) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticLongArray, IntArray). + +test( + set_field_object_array_1, + [ setup(( + jpl_new( 'java.util.Date', [], Date), + jpl_new( array(class([java,lang],['Object'])), [Date,Date], ObjArray) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticObjectArray, ObjArray). + +test( + set_field_static_bad_type_1, + [ setup(( + BadVal = 27 + )), + throws( + error( + type_error(boolean,BadVal), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, BadVal). + +test( + set_field_static_boolean_1, + [ setup(( + jpl_true( V) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, V). + +test( + set_field_static_boolean_2, + [ setup(( + jpl_false( V) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, V). + +test( + set_field_static_boolean_bad_1, + [ setup(( + BadVal = foo(bar) + )), + throws( + error( + type_error(field_value,BadVal), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticBoolean, BadVal). + +test( + set_field_static_cyclic_term_1, + [ setup(( + T = f(T) + )), + throws( + error( + type_error(acyclic,T), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', staticTerm, {T}). + +test( + set_field_static_final_int_1, + [ setup(( + FieldName = fieldStaticFinalInt, + Value = 6 + )), + throws( + error( + permission_error(modify,final_field,FieldName), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', FieldName, Value). + +test( + set_field_static_shadow_1, + [ blocked('we do not yet resolve same-named shadowed fields') + ] +) :- + jpl_set( 'jpl.test.ShadowB', fieldStaticInt, 3). + +test( + set_field_static_term_1, + [ setup(( + T1 = foo(bar,33), + T2 = bar(77,bing) + )), + true(( + T1 == T1a, + T2 == T2a + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T1}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T1a}), + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T2}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T2a}). + +test( + set_field_static_term_2, + [ setup(( + T1 = foo(bar,33), + T2 = bar(77,bing) + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T1}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T1}), + jpl_set( 'jpl.test.Test', fieldStaticTerm, {T2}), + jpl_get( 'jpl.test.Test', fieldStaticTerm, {T2}). + +test( + set_get_array_element_boolean_1, + [ setup(( + jpl_new( array(boolean), 3, A), + V = @(false) + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_boolean_2, + [ setup(( + jpl_new( array(boolean), 3, A), + V = @(true) + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_boolean_3, + [ setup(( + jpl_new( array(boolean), 3, A), + V = bogus + )), + throws( + error( + type_error(array(boolean),[V]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 2, V). + +test( + set_get_array_element_byte_1, + [ setup(( + jpl_new( array(byte), 3, A), + V = 33 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_byte_2, + [ setup(( + jpl_new( array(byte), 3, A), + V = 128 + )), + throws( + error( + type_error(array(byte),[V]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 2, V). + +test( + set_get_array_element_char_1, + [ setup(( + jpl_new( array(char), 3, A), + V = 65535 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_double_1, + [ setup(( + jpl_new( array(double), 3, A), + V = 2.5 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_float_1, + [ setup(( + jpl_new( array(float), 3, A), + V = 7.5 + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_float_2, + [ setup(( + jpl_new( array(float), 3, A), + V is 2, + VrX is float(V) + )), + true(( + VrX == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_float_3, + [ setup(( + jpl_new( array(float), 3, A), + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, Imax) + ; Imax is 2**63-1 + ), + VrX is float(Imax) + )), + true(( + VrX == Vr + )) + ] +) :- + jpl_set( A, 2, Imax), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_long_1, + [ setup(( + jpl_new( array(long), 3, A), + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V) + ; V is 2**63-1 + ) + )), + true(( + V == Vr + )) + ] +) :- + jpl_set( A, 2, V), + jpl_get( A, 2, Vr). + +test( + set_get_array_element_long_2, + [ setup(( + jpl_new( array(long), 3, A), + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V) + ; V is 2**63 + ) + )), + throws( + error( + type_error(array(long),[V]), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( A, 2, V). + +test( + set_get_array_elements_boolean_1, + [ setup(( + jpl_new( array(boolean), 3, A), + Vf = @(false), + Vt = @(true) + )), + true(( + Vf+Vt+Vf == Vr0+Vr1+Vr2 + )) + ] +) :- + jpl_set( A, 0, Vf), + jpl_set( A, 1, Vt), + jpl_set( A, 2, Vf), + jpl_get( A, 0, Vr0), + jpl_get( A, 1, Vr1), + jpl_get( A, 2, Vr2). + +test( + set_get_field_static_long_1, + [ setup(( + ( current_prolog_flag( bounded, true) + -> current_prolog_flag( max_integer, V) + ; V is 2**63-1 + ) + )), + true(( + V == V2 + )) + ] +) :- + jpl_set( 'jpl.test.Test', fieldStaticLong, V), + jpl_get( 'jpl.test.Test', fieldStaticLong, V2). + +test( + set_non_accessible_field_1, + [ throws( + error( + existence_error(field,gagaga), + context(jpl_set/3,_) + ) + ) + ] +) :- + jpl_set( 'jpl.test.Test', gagaga, 4). + +test( + terms_to_array_1, + [] +) :- + jpl_terms_to_array( [foo(bar)], A), + jpl_object_to_type( A, array(class([jpl],['Term']))), + jpl_get( A, length, 1), + jpl_get( A, 0, T), + jpl_call( T, toString, [], 'foo(bar)'). + +test( + throw_java_exception_1, + [ blocked('part of the error term is nondeterministic: we need to match with _'), + throws( + error( + java_exception(@(_)), + 'java.lang.NumberFormatException' + ) + ) + ] +) :- + jpl_call( 'java.lang.Integer', decode, [q], _). + +test( + versions_1, + [ true(( + Vpl == Vc, + Vc == Vjava + )) + ] +) :- + jpl_pl_lib_version(Vpl), + jpl_c_lib_version(Vc), + jpl_call( 'jpl.JPL', version_string, [], Vjava). + +% JW: Mutual recursion check. Moved from jpl.pl to here. As the +% callback is in module user, we define it there. + +user:jpl_test_fac( N, F) :- + ( N == 1 + -> F = 1 + ; N > 1 + -> N2 is N-1, + jpl_call( 'jpl.test.Test', fac, [N2], F2), % call its Java counterpart, which does vice versa + F is N*F2 + ; F = 0 + ). + +test(fac10, + [ true(N==3628800) + ]) :- + user:jpl_test_fac(10, N). + +test(threads1, + [ true(( + thread_create(jpl_call('java.lang.System', currentTimeMillis, [], _), ThreadId, []), + thread_join(ThreadId, true) + )) + ] +) :- + jpl_call('java.lang.System', currentTimeMillis, [], _). + +test(threads2, true(X==true)) :- + jpl_call('java.lang.System', currentTimeMillis, [], _), + thread_create(jpl_call('java.lang.System', currentTimeMillis, [], _), ThreadId, []), + thread_join(ThreadId, X). + +test(threads3, + [ true(( + length(Ss, 1000), + sort(Ss, [true]) + )) + ] +) :- + jpl_call('java.lang.System', currentTimeMillis, [], _), + findall( + Status, + ( between(1, 1000, _), + thread_create(jpl_call('java.lang.System', currentTimeMillis, [], _), ThreadId, []), + thread_join(ThreadId, Status) + ), + Ss + ). + +test(jref1, + [ true(( + Term1 \== Term2, + Term1 =@= Term2 + )) + ] +) :- + length(Term1, 5), + jpl:jni_term_to_jref(Term1, JRef), + jpl:jni_jref_to_term(JRef, Term2). + +:- end_tests(jpl). diff --git a/packages/jpl/test_singleton.pl b/packages/jpl/test_singleton.pl new file mode 100644 index 000000000..c3d06fae2 --- /dev/null +++ b/packages/jpl/test_singleton.pl @@ -0,0 +1,4 @@ +% serves testSingleton1() in jpl.test.TestJUnit + +t(A). + diff --git a/packages/jpl/testenv b/packages/jpl/testenv new file mode 100755 index 000000000..d92418817 --- /dev/null +++ b/packages/jpl/testenv @@ -0,0 +1,30 @@ +#!/bin/sh + +# Verify the environment is safe for building this package. + +findexe() +{ oldifs="$IFS" + IFS=: + for d in $PATH; do + if [ -x $d/$1 ]; then + IFS="$oldifs" + return 0 + fi + done + IFS="$oldifs" + return 1 +} + +# We should also check various other things: +# +# * javac is from SUN SDK or IBM java +# * javac has same wordsize as Prolog (both 32 or 64 bits) +# * linking libpl.a in a shared object is possible. +# +# How to do this in a portable way? Can we use plld? + +if findexe javac; then + exit 0 +else + exit 1 +fi diff --git a/packages/jpl/web/README.txt b/packages/jpl/web/README.txt new file mode 100644 index 000000000..ee2954f6a --- /dev/null +++ b/packages/jpl/web/README.txt @@ -0,0 +1,21 @@ +JPL + is a simple Servlet 2.2 (or later) web application + containing its own copy of jpl.jar and a couple of + servlets which call SWI-Prolog (see JPL/WEB-INF/classes) + +JPL.war + is JPL in the form of a "web archive" + +To deploy under Tomcat, copy either JPL or JPL.war into +Tomcat's webapps folder and restart Tomcat. + +Then visit the application's default ("welcome") page, e.g. + + http://localhost:8080/JPL + +with a web browser. + +---- +Paul Singleton +February 2004 + diff --git a/packages/jpl/web/jpl.war b/packages/jpl/web/jpl.war new file mode 100644 index 000000000..3489e228c Binary files /dev/null and b/packages/jpl/web/jpl.war differ diff --git a/packages/jpl/web/jpl/build_WAR.bat b/packages/jpl/web/jpl/build_WAR.bat new file mode 100644 index 000000000..245864104 --- /dev/null +++ b/packages/jpl/web/jpl/build_WAR.bat @@ -0,0 +1,3 @@ +jar cf ..\JPL.war WEB-INF *.html +@pause + diff --git a/packages/jpl/web/jpl/index.html b/packages/jpl/web/jpl/index.html new file mode 100644 index 000000000..5d231b31b --- /dev/null +++ b/packages/jpl/web/jpl/index.html @@ -0,0 +1,20 @@ + + + welcome page for various HTTP <-> JPL <-> Prolog servlet demos + + +

    JPL servlet examples

    +

    + To invoke the JPLServletByref servlet with a couple of HTTP parameters, click + servlet/JPLServletByref?first=1st&second=2nd +

    +

    + To invoke the JPLServletByval servlet with a couple of HTTP parameters, click + servlet/JPLServletByval?first=1st&second=2nd +

    +
    +
    Paul Singleton
    +
    February 2004
    + + + diff --git a/packages/odbc b/packages/odbc deleted file mode 160000 index 997245829..000000000 --- a/packages/odbc +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9972458293415b2d72276bd67875767bfeed00df diff --git a/packages/plunit b/packages/plunit deleted file mode 160000 index c70811ad6..000000000 --- a/packages/plunit +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c70811ad67640151b4f2edc523136469fedf6a8c diff --git a/packages/raptor b/packages/raptor deleted file mode 160000 index 8dbcba9ff..000000000 --- a/packages/raptor +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 8dbcba9ff8f87abba5db6e65aaeaad7ad1b383f2 diff --git a/packages/raptor/CMakeFiles/CMakeDirectoryInformation.cmake b/packages/raptor/CMakeFiles/CMakeDirectoryInformation.cmake new file mode 100644 index 000000000..bab203dbc --- /dev/null +++ b/packages/raptor/CMakeFiles/CMakeDirectoryInformation.cmake @@ -0,0 +1,16 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Relative path conversion top directories. +set(CMAKE_RELATIVE_PATH_TOP_SOURCE "/Users/vsc/git/yap-6.3") +set(CMAKE_RELATIVE_PATH_TOP_BINARY "/Users/vsc/git/yap-6.3") + +# Force unix paths in dependencies. +set(CMAKE_FORCE_UNIX_PATHS 1) + + +# The C and CXX include file regular expressions for this directory. +set(CMAKE_C_INCLUDE_REGEX_SCAN "^.*$") +set(CMAKE_C_INCLUDE_REGEX_COMPLAIN "^$") +set(CMAKE_CXX_INCLUDE_REGEX_SCAN ${CMAKE_C_INCLUDE_REGEX_SCAN}) +set(CMAKE_CXX_INCLUDE_REGEX_COMPLAIN ${CMAKE_C_INCLUDE_REGEX_COMPLAIN}) diff --git a/packages/raptor/CMakeFiles/progress.marks b/packages/raptor/CMakeFiles/progress.marks new file mode 100644 index 000000000..0691f67b2 --- /dev/null +++ b/packages/raptor/CMakeFiles/progress.marks @@ -0,0 +1 @@ +52 diff --git a/packages/raptor/CMakeFiles/raptor.dir/DependInfo.cmake b/packages/raptor/CMakeFiles/raptor.dir/DependInfo.cmake new file mode 100644 index 000000000..6de14f3ea --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/DependInfo.cmake @@ -0,0 +1,42 @@ +# The set of languages for which implicit dependencies are needed: +set(CMAKE_DEPENDS_LANGUAGES + "C" + ) +# The set of files for implicit dependencies of each language: +set(CMAKE_DEPENDS_CHECK_C + "/Users/vsc/git/yap-6.3/packages/raptor/raptor_yap.c" "/Users/vsc/git/yap-6.3/packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o" + ) +set(CMAKE_C_COMPILER_ID "Clang") + +# Preprocessor definitions for this target. +set(CMAKE_TARGET_DEFINITIONS_C + "COROUTINING=1" + "DEBUG=1" + "DEPTH_LIMIT=1" + "HAVE_CONFIG_H" + "LOW_LEVEL_TRACER=1" + "RATIONAL_TREES=1" + "TABLING=1" + "USE_THREADEAD_CODE=1" + "UTF8PROC=1" + "_YAP_NOT_INSTALLED_=1" + ) + +# The include file search paths: +set(CMAKE_C_TARGET_INCLUDE_PATH + "." + "H" + "include" + "os" + "utf8proc" + "JIT/HPP" + "/usr/local/include" + "OPTYap" + "packages/raptor" + ) + +# Targets to which this target links. +set(CMAKE_TARGET_LINKED_INFO_FILES + "/Users/vsc/git/yap-6.3/CMakeFiles/libYap.dir/DependInfo.cmake" + "/Users/vsc/git/yap-6.3/utf8proc/CMakeFiles/utf8proc.dir/DependInfo.cmake" + ) diff --git a/packages/raptor/CMakeFiles/raptor.dir/build.make b/packages/raptor/CMakeFiles/raptor.dir/build.make new file mode 100644 index 000000000..4ad3201eb --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/build.make @@ -0,0 +1,119 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Delete rule output on recipe failure. +.DELETE_ON_ERROR: + + +#============================================================================= +# Special targets provided by cmake. + +# Disable implicit rules so canonical targets will work. +.SUFFIXES: + + +# Remove some rules from gmake that .SUFFIXES does not remove. +SUFFIXES = + +.SUFFIXES: .hpux_make_needs_suffix_list + + +# Suppress display of executed commands. +$(VERBOSE).SILENT: + + +# A target that is always out of date. +cmake_force: + +.PHONY : cmake_force + +#============================================================================= +# Set environment variables for the build. + +# The shell in which to execute make rules. +SHELL = /bin/sh + +# The CMake executable. +CMAKE_COMMAND = /usr/local/Cellar/cmake/3.3.2/bin/cmake + +# The command to remove a file. +RM = /usr/local/Cellar/cmake/3.3.2/bin/cmake -E remove -f + +# Escaping for special characters. +EQUALS = = + +# The top-level source directory on which CMake was run. +CMAKE_SOURCE_DIR = /Users/vsc/git/yap-6.3 + +# The top-level build directory on which CMake was run. +CMAKE_BINARY_DIR = /Users/vsc/git/yap-6.3 + +# Include any dependencies generated for this target. +include packages/raptor/CMakeFiles/raptor.dir/depend.make + +# Include the progress variables for this target. +include packages/raptor/CMakeFiles/raptor.dir/progress.make + +# Include the compile flags for this target's objects. +include packages/raptor/CMakeFiles/raptor.dir/flags.make + +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o: packages/raptor/CMakeFiles/raptor.dir/flags.make +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o: packages/raptor/raptor_yap.c + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_1) "Building C object packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o" + cd /Users/vsc/git/yap-6.3/packages/raptor && /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc $(C_DEFINES) $(C_FLAGS) -o CMakeFiles/raptor.dir/raptor_yap.c.o -c /Users/vsc/git/yap-6.3/packages/raptor/raptor_yap.c + +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.i: cmake_force + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green "Preprocessing C source to CMakeFiles/raptor.dir/raptor_yap.c.i" + cd /Users/vsc/git/yap-6.3/packages/raptor && /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc $(C_DEFINES) $(C_FLAGS) -E /Users/vsc/git/yap-6.3/packages/raptor/raptor_yap.c > CMakeFiles/raptor.dir/raptor_yap.c.i + +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.s: cmake_force + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green "Compiling C source to assembly CMakeFiles/raptor.dir/raptor_yap.c.s" + cd /Users/vsc/git/yap-6.3/packages/raptor && /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc $(C_DEFINES) $(C_FLAGS) -S /Users/vsc/git/yap-6.3/packages/raptor/raptor_yap.c -o CMakeFiles/raptor.dir/raptor_yap.c.s + +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.requires: + +.PHONY : packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.requires + +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.provides: packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.requires + $(MAKE) -f packages/raptor/CMakeFiles/raptor.dir/build.make packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.provides.build +.PHONY : packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.provides + +packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.provides.build: packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o + + +# Object files for target raptor +raptor_OBJECTS = \ +"CMakeFiles/raptor.dir/raptor_yap.c.o" + +# External object files for target raptor +raptor_EXTERNAL_OBJECTS = + +packages/raptor/raptor.dylib: packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o +packages/raptor/raptor.dylib: packages/raptor/CMakeFiles/raptor.dir/build.make +packages/raptor/raptor.dylib: /usr/local/lib/libraptor2.dylib +packages/raptor/raptor.dylib: libYap.6.3.4.dylib +packages/raptor/raptor.dylib: utf8proc/libutf8proc.1.3.0.dylib +packages/raptor/raptor.dylib: /usr/local/lib/libgmp.dylib +packages/raptor/raptor.dylib: /usr/local/opt/readline/lib/libreadline.dylib +packages/raptor/raptor.dylib: /usr/lib/libncurses.dylib +packages/raptor/raptor.dylib: packages/raptor/CMakeFiles/raptor.dir/link.txt + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --green --bold --progress-dir=/Users/vsc/git/yap-6.3/CMakeFiles --progress-num=$(CMAKE_PROGRESS_2) "Linking C shared library raptor.dylib" + cd /Users/vsc/git/yap-6.3/packages/raptor && $(CMAKE_COMMAND) -E cmake_link_script CMakeFiles/raptor.dir/link.txt --verbose=$(VERBOSE) + +# Rule to build all files generated by this target. +packages/raptor/CMakeFiles/raptor.dir/build: packages/raptor/raptor.dylib + +.PHONY : packages/raptor/CMakeFiles/raptor.dir/build + +packages/raptor/CMakeFiles/raptor.dir/requires: packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o.requires + +.PHONY : packages/raptor/CMakeFiles/raptor.dir/requires + +packages/raptor/CMakeFiles/raptor.dir/clean: + cd /Users/vsc/git/yap-6.3/packages/raptor && $(CMAKE_COMMAND) -P CMakeFiles/raptor.dir/cmake_clean.cmake +.PHONY : packages/raptor/CMakeFiles/raptor.dir/clean + +packages/raptor/CMakeFiles/raptor.dir/depend: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -E cmake_depends "Unix Makefiles" /Users/vsc/git/yap-6.3 /Users/vsc/git/yap-6.3/packages/raptor /Users/vsc/git/yap-6.3 /Users/vsc/git/yap-6.3/packages/raptor /Users/vsc/git/yap-6.3/packages/raptor/CMakeFiles/raptor.dir/DependInfo.cmake --color=$(COLOR) +.PHONY : packages/raptor/CMakeFiles/raptor.dir/depend + diff --git a/packages/raptor/CMakeFiles/raptor.dir/cmake_clean.cmake b/packages/raptor/CMakeFiles/raptor.dir/cmake_clean.cmake new file mode 100644 index 000000000..2adfce4a1 --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/cmake_clean.cmake @@ -0,0 +1,10 @@ +file(REMOVE_RECURSE + "CMakeFiles/raptor.dir/raptor_yap.c.o" + "raptor.pdb" + "raptor.dylib" +) + +# Per-language clean rules from dependency scanning. +foreach(lang C) + include(CMakeFiles/raptor.dir/cmake_clean_${lang}.cmake OPTIONAL) +endforeach() diff --git a/packages/raptor/CMakeFiles/raptor.dir/depend.make b/packages/raptor/CMakeFiles/raptor.dir/depend.make new file mode 100644 index 000000000..c7e43836b --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/depend.make @@ -0,0 +1,2 @@ +# Empty dependencies file for raptor. +# This may be replaced when dependencies are built. diff --git a/packages/raptor/CMakeFiles/raptor.dir/flags.make b/packages/raptor/CMakeFiles/raptor.dir/flags.make new file mode 100644 index 000000000..3c3d39bc9 --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/flags.make @@ -0,0 +1,8 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# compile C with /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc +C_FLAGS = -g -fPIC -I/Users/vsc/git/yap-6.3 -I/Users/vsc/git/yap-6.3/H -I/Users/vsc/git/yap-6.3/include -I/Users/vsc/git/yap-6.3/os -I/Users/vsc/git/yap-6.3/utf8proc -I/Users/vsc/git/yap-6.3/JIT/HPP -I/usr/local/include -I/Users/vsc/git/yap-6.3/OPTYap -I/Users/vsc/git/yap-6.3/packages/raptor -Wall -Wstrict-prototypes -Wmissing-prototypes -fexceptions + +C_DEFINES = -DCOROUTINING=1 -DDEBUG=1 -DDEPTH_LIMIT=1 -DHAVE_CONFIG_H -DLOW_LEVEL_TRACER=1 -DRATIONAL_TREES=1 -DTABLING=1 -DUSE_THREADEAD_CODE=1 -DUTF8PROC=1 -D_YAP_NOT_INSTALLED_=1 -Draptor_EXPORTS + diff --git a/packages/raptor/CMakeFiles/raptor.dir/link.txt b/packages/raptor/CMakeFiles/raptor.dir/link.txt new file mode 100644 index 000000000..db0e02d12 --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/link.txt @@ -0,0 +1 @@ +/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/cc -g -dynamiclib -Wl,-headerpad_max_install_names -o raptor.dylib -install_name /Users/vsc/git/yap-6.3/packages/raptor/raptor.dylib CMakeFiles/raptor.dir/raptor_yap.c.o /usr/local/lib/libraptor2.dylib ../../libYap.6.3.4.dylib -ldl ../../utf8proc/libutf8proc.1.3.0.dylib /usr/local/lib/libgmp.dylib /usr/local/opt/readline/lib/libreadline.dylib /usr/lib/libncurses.dylib -Wl,-rpath,/Users/vsc/git/yap-6.3 diff --git a/packages/raptor/CMakeFiles/raptor.dir/progress.make b/packages/raptor/CMakeFiles/raptor.dir/progress.make new file mode 100644 index 000000000..a6704b138 --- /dev/null +++ b/packages/raptor/CMakeFiles/raptor.dir/progress.make @@ -0,0 +1,3 @@ +CMAKE_PROGRESS_1 = +CMAKE_PROGRESS_2 = 89 + diff --git a/packages/raptor/CMakeLists.txt b/packages/raptor/CMakeLists.txt new file mode 100644 index 000000000..7359765ee --- /dev/null +++ b/packages/raptor/CMakeLists.txt @@ -0,0 +1,66 @@ +CMAKE_MINIMUM_REQUIRED ( VERSION 2.8 ) + +PROJECT ( YAP_RAPTOR C ) + +SET ( YAP_RAPTOR_VERSION 0.1) + +SET(CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake ${CMAKE_MODULE_PATH}) + + +if (NOT YAP_FOUND) + FIND_PACKAGE(YAP REQUIRED) +ENDIF (NOT YAP_FOUND) +IF (NOT YAP_FOUND) + MESSAGE (SEND_ERROR "YAP was not found!") +ENDIF (NOT YAP_FOUND) + +macro_optional_find_package (RAPTOR ON) +macro_log_feature (RAPTOR_FOUND "RAPTOR" + "Use RAPTOR Library" + "http://www.r.org" FALSE) +IF (RAPTOR_FOUND) + # RAPTOR_FOUND - system has Raptor + # RAPTOR_LIBRARIES - Link these to use Raptor + # RAPTOR_INCLUDE_DIR - Include directory for using Raptor + # RAPTOR_DEFINITIONS - Compiler switches required for using Raptor + + INCLUDE_DIRECTORIES( + ${RAPTOR_INCLUDE_DIR} + ${CMAKE_CURRENT_BINARY_DIR} + ) + + SET ( RAPTOR_SOURCES + raptor_yap.c + ) + + ADD_LIBRARY(raptor SHARED ${RAPTOR_SOURCES} ) + + if(DEFINED YAP_MAJOR_VERSION) + TARGET_LINK_LIBRARIES(raptor + ${RAPTOR_LIBRARY} + libYap + ) + else() + TARGET_LINK_LIBRARIES(raptor + ${RAPTOR_LIBRARY} + ${YAP_LIBRARY} + ) + endif() + + check_include_files( raptor2/raptor2.h HAVE_RAPTOR2_RAPTOR2_H ) + + check_include_files( raptor.h HAVE_RAPTOR_H ) + + set_target_properties (raptor PROPERTIES PREFIX "") + + configure_file ("raptor_config.h.cmake" "raptor_config.h" ) + + + install(TARGETS raptor + LIBRARY DESTINATION ${dlls} + ) + + INSTALL(FILES raptor.yap DESTINATION ${libpl}) + INSTALL(FILES rdf.yap DESTINATION ${libpl}) + +ENDIF (RAPTOR_FOUND) diff --git a/packages/raptor/Debug/raptor.dylib b/packages/raptor/Debug/raptor.dylib new file mode 100755 index 000000000..3fe08417e Binary files /dev/null and b/packages/raptor/Debug/raptor.dylib differ diff --git a/packages/raptor/LICENSE b/packages/raptor/LICENSE new file mode 100644 index 000000000..d7f105139 --- /dev/null +++ b/packages/raptor/LICENSE @@ -0,0 +1,339 @@ +GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + {description} + Copyright (C) {year} {fullname} + + 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 General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + {signature of Ty Coon}, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/packages/raptor/Makefile b/packages/raptor/Makefile new file mode 100644 index 000000000..88b7e29da --- /dev/null +++ b/packages/raptor/Makefile @@ -0,0 +1,228 @@ +# CMAKE generated file: DO NOT EDIT! +# Generated by "Unix Makefiles" Generator, CMake Version 3.3 + +# Default target executed when no arguments are given to make. +default_target: all + +.PHONY : default_target + +# Allow only one "make -f Makefile2" at a time, but pass parallelism. +.NOTPARALLEL: + + +#============================================================================= +# Special targets provided by cmake. + +# Disable implicit rules so canonical targets will work. +.SUFFIXES: + + +# Remove some rules from gmake that .SUFFIXES does not remove. +SUFFIXES = + +.SUFFIXES: .hpux_make_needs_suffix_list + + +# Suppress display of executed commands. +$(VERBOSE).SILENT: + + +# A target that is always out of date. +cmake_force: + +.PHONY : cmake_force + +#============================================================================= +# Set environment variables for the build. + +# The shell in which to execute make rules. +SHELL = /bin/sh + +# The CMake executable. +CMAKE_COMMAND = /usr/local/Cellar/cmake/3.3.2/bin/cmake + +# The command to remove a file. +RM = /usr/local/Cellar/cmake/3.3.2/bin/cmake -E remove -f + +# Escaping for special characters. +EQUALS = = + +# The top-level source directory on which CMake was run. +CMAKE_SOURCE_DIR = /Users/vsc/git/yap-6.3 + +# The top-level build directory on which CMake was run. +CMAKE_BINARY_DIR = /Users/vsc/git/yap-6.3 + +#============================================================================= +# Targets provided globally by CMake. + +# Special rule for the target edit_cache +edit_cache: + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake cache editor..." + /usr/local/Cellar/cmake/3.3.1/bin/ccmake -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) +.PHONY : edit_cache + +# Special rule for the target edit_cache +edit_cache/fast: edit_cache + +.PHONY : edit_cache/fast + +# Special rule for the target rebuild_cache +rebuild_cache: + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake to regenerate build system..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) +.PHONY : rebuild_cache + +# Special rule for the target rebuild_cache +rebuild_cache/fast: rebuild_cache + +.PHONY : rebuild_cache/fast + +# Special rule for the target list_install_components +list_install_components: + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Available install components are: \"Unspecified\"" +.PHONY : list_install_components + +# Special rule for the target list_install_components +list_install_components/fast: list_install_components + +.PHONY : list_install_components/fast + +# Special rule for the target install +install: preinstall + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -P cmake_install.cmake +.PHONY : install + +# Special rule for the target install +install/fast: preinstall/fast + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -P cmake_install.cmake +.PHONY : install/fast + +# Special rule for the target install/strip +install/strip: preinstall + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing the project stripped..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -DCMAKE_INSTALL_DO_STRIP=1 -P cmake_install.cmake +.PHONY : install/strip + +# Special rule for the target install/strip +install/strip/fast: install/strip + +.PHONY : install/strip/fast + +# Special rule for the target install/local +install/local: preinstall + @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing only the local directory..." + /usr/local/Cellar/cmake/3.3.2/bin/cmake -DCMAKE_INSTALL_LOCAL_ONLY=1 -P cmake_install.cmake +.PHONY : install/local + +# Special rule for the target install/local +install/local/fast: install/local + +.PHONY : install/local/fast + +# The main all target +all: cmake_check_build_system + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -E cmake_progress_start /Users/vsc/git/yap-6.3/CMakeFiles /Users/vsc/git/yap-6.3/packages/raptor/CMakeFiles/progress.marks + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/raptor/all + $(CMAKE_COMMAND) -E cmake_progress_start /Users/vsc/git/yap-6.3/CMakeFiles 0 +.PHONY : all + +# The main clean target +clean: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/raptor/clean +.PHONY : clean + +# The main clean target +clean/fast: clean + +.PHONY : clean/fast + +# Prepare targets for installation. +preinstall: all + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/raptor/preinstall +.PHONY : preinstall + +# Prepare targets for installation. +preinstall/fast: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/raptor/preinstall +.PHONY : preinstall/fast + +# clear depends +depend: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 1 +.PHONY : depend + +# Convenience name for target. +packages/raptor/CMakeFiles/raptor.dir/rule: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f CMakeFiles/Makefile2 packages/raptor/CMakeFiles/raptor.dir/rule +.PHONY : packages/raptor/CMakeFiles/raptor.dir/rule + +# Convenience name for target. +raptor: packages/raptor/CMakeFiles/raptor.dir/rule + +.PHONY : raptor + +# fast build rule for target. +raptor/fast: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f packages/raptor/CMakeFiles/raptor.dir/build.make packages/raptor/CMakeFiles/raptor.dir/build +.PHONY : raptor/fast + +raptor_yap.o: raptor_yap.c.o + +.PHONY : raptor_yap.o + +# target to build an object file +raptor_yap.c.o: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f packages/raptor/CMakeFiles/raptor.dir/build.make packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.o +.PHONY : raptor_yap.c.o + +raptor_yap.i: raptor_yap.c.i + +.PHONY : raptor_yap.i + +# target to preprocess a source file +raptor_yap.c.i: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f packages/raptor/CMakeFiles/raptor.dir/build.make packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.i +.PHONY : raptor_yap.c.i + +raptor_yap.s: raptor_yap.c.s + +.PHONY : raptor_yap.s + +# target to generate assembly for a file +raptor_yap.c.s: + cd /Users/vsc/git/yap-6.3 && $(MAKE) -f packages/raptor/CMakeFiles/raptor.dir/build.make packages/raptor/CMakeFiles/raptor.dir/raptor_yap.c.s +.PHONY : raptor_yap.c.s + +# Help Target +help: + @echo "The following are some of the valid targets for this Makefile:" + @echo "... all (the default if no target is provided)" + @echo "... clean" + @echo "... depend" + @echo "... edit_cache" + @echo "... rebuild_cache" + @echo "... list_install_components" + @echo "... install" + @echo "... install/strip" + @echo "... install/local" + @echo "... raptor" + @echo "... raptor_yap.o" + @echo "... raptor_yap.i" + @echo "... raptor_yap.s" +.PHONY : help + + + +#============================================================================= +# Special targets to cleanup operation of make. + +# Special rule to run CMake to check the build system integrity. +# No rule that depends on this can have commands that come from listfiles +# because they might be regenerated. +cmake_check_build_system: + cd /Users/vsc/git/yap-6.3 && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 0 +.PHONY : cmake_check_build_system + diff --git a/packages/raptor/Makefile.in b/packages/raptor/Makefile.in new file mode 100644 index 000000000..f6b3f9c5e --- /dev/null +++ b/packages/raptor/Makefile.in @@ -0,0 +1,65 @@ +# +# default base directory for YAP installation +# (EROOT for architecture-dependent files) +# +prefix = @prefix@ +exec_prefix = @exec_prefix@ +ROOTDIR = $(prefix) +EROOTDIR = @exec_prefix@ +abs_top_builddir = @abs_top_builddir@ +# +# where the binary should be +# +BINDIR = $(EROOTDIR)/bin +# +# where YAP should look for libraries +# +LIBDIR=@libdir@ +SHAREDIR=$(ROOTDIR)/share/Yap +YAPLIBDIR=@libdir@/Yap +# +# +CC=@CC@ +CFLAGS= @SHLIB_CFLAGS@ @RAPTOR_CPPFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I. -I../.. -I$(srcdir)/../../include +LDFLAGS=@LDFLAGS@ +# +# +# You shouldn't need to change what follows. +# +INSTALL=@INSTALL@ +INSTALL_DATA=@INSTALL_DATA@ +INSTALL_PROGRAM=@INSTALL_PROGRAM@ +SHELL=/bin/sh +RANLIB=@RANLIB@ +srcdir=@srcdir@ +SO=@SO@ +#4.1VPATH=@srcdir@:@srcdir@/OPTYap +CWD=$(PWD) +# + +RAPTOR_PROLOG= \ + $(srcdir)/rdf.yap + +OBJS=raptor.o +SOBJS=raptor.@SO@ + +#in some systems we just create a single object, in others we need to +# create a libray + +all: $(SOBJS) + +raptor.o: $(srcdir)/raptor_yap.c + $(CC) -c $(CFLAGS) $< -o $@ + +@DO_SECOND_LD@%.@SO@: %.o +@DO_SECOND_LD@ @SHLIB_LD@ $(LDFLAGS) -o $@ $< @RAPTOR_LIBS@ @EXTRA_LIBS_FOR_DLLS@ + + +install: all + mkdir -p $(DESTDIR)$(SHAREDIR) + for h in $(RAPTOR_PROLOG); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done + $(INSTALL_PROGRAM) $(SOBJS) $(DESTDIR)$(YAPLIBDIR) + +clean: + rm -f *.o *~ $(OBJS) $(SOBJS) *.BAK + diff --git a/packages/raptor/README.md b/packages/raptor/README.md new file mode 100644 index 000000000..affb558ce --- /dev/null +++ b/packages/raptor/README.md @@ -0,0 +1,23 @@ +@defgroup YAPRaptor An RDF Reader for YAP. +@ingroup YAPPackages + +#YAP raptor Interface + +This provides YAP a rdf reader using +[raptor](http://librdf.org/raptor/). The library is available for +Windows, Linux/Unix and MacOS machines. + +### +###Example Usage + +~~~~{.prolog} +?- use_module(rdf). +?- rdf_load('example.rdf',user,example). +../example.rdf : 3 triples + +?- example(Subject,Predicate,Object). +Object = 'http://www.example.org/tv_show', +Predicate = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#type', +Subject = 'http://www.example.org/law_and_order_ci' ? + +~~~~{.prolog} diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor.LinkFileList b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor.LinkFileList new file mode 100644 index 000000000..48975d6a1 --- /dev/null +++ b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor.LinkFileList @@ -0,0 +1 @@ +/Users/vsc/Yap/yap-6.3/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.o diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_dependency_info.dat b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_dependency_info.dat new file mode 100644 index 000000000..2f25061d9 Binary files /dev/null and b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_dependency_info.dat differ diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.d b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.d new file mode 100644 index 000000000..62385870e --- /dev/null +++ b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.d @@ -0,0 +1,6 @@ +dependencies: /Users/vsc/git/yap-6.3/packages/raptor/raptor_yap.c \ + /Users/vsc/Yap/yap-6.3/packages/raptor/raptor_config.h \ + /Users/vsc/Yap/yap-6.3/include/YapInterface.h \ + /Users/vsc/Yap/yap-6.3/include/YapDefs.h \ + /Users/vsc/Yap/yap-6.3/include/YapError.h \ + /usr/local/include/raptor2/raptor2.h diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.dia b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.dia new file mode 100644 index 000000000..eb8ef4514 Binary files /dev/null and b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.dia differ diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.o b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.o new file mode 100644 index 000000000..ee86a7032 Binary files /dev/null and b/packages/raptor/YAP.build/Debug/raptor.build/Objects-normal/x86_64/raptor_yap.o differ diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Script-100870D84F764D47B2FE31BE.sh b/packages/raptor/YAP.build/Debug/raptor.build/Script-100870D84F764D47B2FE31BE.sh new file mode 100755 index 000000000..604ac057c --- /dev/null +++ b/packages/raptor/YAP.build/Debug/raptor.build/Script-100870D84F764D47B2FE31BE.sh @@ -0,0 +1,2 @@ +#!/bin/sh +make -C /Users/vsc/Yap/yap-6.3/packages/raptor -f /Users/vsc/Yap/yap-6.3/packages/raptor/CMakeScripts/raptor_postBuildPhase.make$CONFIGURATION all diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Script-3ED09FF30F2C4260B19AD134.sh b/packages/raptor/YAP.build/Debug/raptor.build/Script-3ED09FF30F2C4260B19AD134.sh new file mode 100755 index 000000000..604ac057c --- /dev/null +++ b/packages/raptor/YAP.build/Debug/raptor.build/Script-3ED09FF30F2C4260B19AD134.sh @@ -0,0 +1,2 @@ +#!/bin/sh +make -C /Users/vsc/Yap/yap-6.3/packages/raptor -f /Users/vsc/Yap/yap-6.3/packages/raptor/CMakeScripts/raptor_postBuildPhase.make$CONFIGURATION all diff --git a/packages/raptor/YAP.build/Debug/raptor.build/Script-D6CC9EB0637843E2B16CBEE6.sh b/packages/raptor/YAP.build/Debug/raptor.build/Script-D6CC9EB0637843E2B16CBEE6.sh new file mode 100755 index 000000000..604ac057c --- /dev/null +++ b/packages/raptor/YAP.build/Debug/raptor.build/Script-D6CC9EB0637843E2B16CBEE6.sh @@ -0,0 +1,2 @@ +#!/bin/sh +make -C /Users/vsc/Yap/yap-6.3/packages/raptor -f /Users/vsc/Yap/yap-6.3/packages/raptor/CMakeScripts/raptor_postBuildPhase.make$CONFIGURATION all diff --git a/packages/raptor/YAP.build/Debug/raptor.build/dgph b/packages/raptor/YAP.build/Debug/raptor.build/dgph new file mode 100644 index 000000000..84d0c02a1 Binary files /dev/null and b/packages/raptor/YAP.build/Debug/raptor.build/dgph differ diff --git a/packages/raptor/YAP_RAPTOR.xcodeproj/project.pbxproj b/packages/raptor/YAP_RAPTOR.xcodeproj/project.pbxproj new file mode 100644 index 000000000..7937adbfd --- /dev/null +++ b/packages/raptor/YAP_RAPTOR.xcodeproj/project.pbxproj @@ -0,0 +1,177 @@ +// !$*UTF8*$! +{ + archiveVersion = 1; + classes = { + }; + objectVersion = 46; + objects = { + +/* Begin PBXFileReference section */ + 1B6B8321950C4E9F84A39082 /* CMakeLists.txt */ = {isa = PBXFileReference; explicitFileType = sourcecode.text; fileEncoding = 4; lastKnownFileType = text; path = CMakeLists.txt; sourceTree = SOURCE_ROOT; }; + 24870037203D43EEA9A11C6A /* raptor_yap.c */ = {isa = PBXFileReference; explicitFileType = sourcecode.c.c; fileEncoding = 4; path = raptor_yap.c; sourceTree = SOURCE_ROOT; }; + 2F981AAA525F4B2AA5AE65E6 /* CMakeLists.txt */ = {isa = PBXFileReference; explicitFileType = sourcecode.text; fileEncoding = 4; lastKnownFileType = text; path = CMakeLists.txt; sourceTree = SOURCE_ROOT; }; + 5C89B12741F24BCA887E2A0A /* CMakeLists.txt */ = {isa = PBXFileReference; explicitFileType = sourcecode.text; fileEncoding = 4; lastKnownFileType = text; path = CMakeLists.txt; sourceTree = SOURCE_ROOT; }; +/* End PBXFileReference section */ + +/* Begin PBXGroup section */ + 04BB6F2F821F4DB1910FDF76 /* Resources */ = { + isa = PBXGroup; + children = ( + ); + name = Resources; + sourceTree = ""; + }; + 0744EA54238D4164BE879D2E /* ALL_BUILD */ = { + isa = PBXGroup; + children = ( + A7F95FF4C317425AACAD889D /* CMake Rules */, + 1B6B8321950C4E9F84A39082 /* CMakeLists.txt */, + ); + name = ALL_BUILD; + sourceTree = ""; + }; + 23A6B2DB08AD484CA41A642F /* Sources */ = { + isa = PBXGroup; + children = ( + 0744EA54238D4164BE879D2E /* ALL_BUILD */, + 54F3E47A586847288B8EBCD5 /* ZERO_CHECK */, + CEFC46D9735F44EDAC092190 /* raptor */, + ); + name = Sources; + sourceTree = ""; + }; + 5364BBE16C7841159A7CB46B /* Source Files */ = { + isa = PBXGroup; + children = ( + 24870037203D43EEA9A11C6A /* raptor_yap.c */, + ); + name = "Source Files"; + sourceTree = ""; + }; + 54F3E47A586847288B8EBCD5 /* ZERO_CHECK */ = { + isa = PBXGroup; + children = ( + B268DDC0306D4B55A5AA8701 /* CMake Rules */, + 5C89B12741F24BCA887E2A0A /* CMakeLists.txt */, + ); + name = ZERO_CHECK; + sourceTree = ""; + }; + A7F95FF4C317425AACAD889D /* CMake Rules */ = { + isa = PBXGroup; + children = ( + ); + name = "CMake Rules"; + sourceTree = ""; + }; + B268DDC0306D4B55A5AA8701 /* CMake Rules */ = { + isa = PBXGroup; + children = ( + ); + name = "CMake Rules"; + sourceTree = ""; + }; + BF8B89FED36B48768CF87874 /* Products */ = { + isa = PBXGroup; + children = ( + ); + name = Products; + sourceTree = ""; + }; + CDC96719C5D74DC29A45C971 = { + isa = PBXGroup; + children = ( + 23A6B2DB08AD484CA41A642F /* Sources */, + 04BB6F2F821F4DB1910FDF76 /* Resources */, + BF8B89FED36B48768CF87874 /* Products */, + ); + sourceTree = ""; + }; + CEFC46D9735F44EDAC092190 /* raptor */ = { + isa = PBXGroup; + children = ( + 5364BBE16C7841159A7CB46B /* Source Files */, + 2F981AAA525F4B2AA5AE65E6 /* CMakeLists.txt */, + ); + name = raptor; + sourceTree = ""; + }; +/* End PBXGroup section */ + +/* Begin PBXProject section */ + 50D6D349DE764D24AC2ABE82 /* Project object */ = { + isa = PBXProject; + attributes = { + BuildIndependentTargetsInParallel = YES; + LastUpgradeCheck = 0630; + }; + buildConfigurationList = 1CF11351880C431989D9F623 /* Build configuration list for PBXProject "YAP_RAPTOR" */; + compatibilityVersion = "Xcode 3.2"; + developmentRegion = English; + hasScannedForEncodings = 0; + knownRegions = ( + en, + ); + mainGroup = CDC96719C5D74DC29A45C971; + projectDirPath = ""; + projectRoot = ""; + targets = ( + ); + }; +/* End PBXProject section */ + +/* Begin XCBuildConfiguration section */ + 3198AE3B53B64E3DA9EE05B6 /* Release */ = { + isa = XCBuildConfiguration; + buildSettings = { + ONLY_ACTIVE_ARCH = YES; + SDKROOT = /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk; + SYMROOT = "/Users/vsc/Yap/yap-6.3/packages/raptor/build"; + }; + name = Release; + }; + 97E862E2445544978B643E0C /* RelWithDebInfo */ = { + isa = XCBuildConfiguration; + buildSettings = { + ONLY_ACTIVE_ARCH = YES; + SDKROOT = /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk; + SYMROOT = "/Users/vsc/Yap/yap-6.3/packages/raptor/build"; + }; + name = RelWithDebInfo; + }; + C629F660997C4306BA1DD496 /* MinSizeRel */ = { + isa = XCBuildConfiguration; + buildSettings = { + ONLY_ACTIVE_ARCH = YES; + SDKROOT = /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk; + SYMROOT = "/Users/vsc/Yap/yap-6.3/packages/raptor/build"; + }; + name = MinSizeRel; + }; + EE1447ED3D454D05BD752696 /* Debug */ = { + isa = XCBuildConfiguration; + buildSettings = { + ONLY_ACTIVE_ARCH = YES; + SDKROOT = /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk; + SYMROOT = "/Users/vsc/Yap/yap-6.3/packages/raptor/build"; + }; + name = Debug; + }; +/* End XCBuildConfiguration section */ + +/* Begin XCConfigurationList section */ + 1CF11351880C431989D9F623 /* Build configuration list for PBXProject "YAP_RAPTOR" */ = { + isa = XCConfigurationList; + buildConfigurations = ( + EE1447ED3D454D05BD752696 /* Debug */, + 3198AE3B53B64E3DA9EE05B6 /* Release */, + C629F660997C4306BA1DD496 /* MinSizeRel */, + 97E862E2445544978B643E0C /* RelWithDebInfo */, + ); + defaultConfigurationIsVisible = 0; + defaultConfigurationName = Debug; + }; +/* End XCConfigurationList section */ + }; + rootObject = 50D6D349DE764D24AC2ABE82 /* Project object */; +} diff --git a/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/ALL_BUILD.xcscheme b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/ALL_BUILD.xcscheme new file mode 100644 index 000000000..2d0b1af71 --- /dev/null +++ b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/ALL_BUILD.xcscheme @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/ZERO_CHECK.xcscheme b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/ZERO_CHECK.xcscheme new file mode 100644 index 000000000..609aacbf1 --- /dev/null +++ b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/ZERO_CHECK.xcscheme @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/install.xcscheme b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/install.xcscheme new file mode 100644 index 000000000..a3810b125 --- /dev/null +++ b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/install.xcscheme @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/raptor.xcscheme b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/raptor.xcscheme new file mode 100644 index 000000000..1d26ccccf --- /dev/null +++ b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/raptor.xcscheme @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/xcschememanagement.plist b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/xcschememanagement.plist new file mode 100644 index 000000000..d793f72f3 --- /dev/null +++ b/packages/raptor/YAP_RAPTOR.xcodeproj/xcuserdata/vsc.xcuserdatad/xcschemes/xcschememanagement.plist @@ -0,0 +1,52 @@ + + + + + SchemeUserState + + ALL_BUILD.xcscheme + + orderHint + 1 + + ZERO_CHECK.xcscheme + + orderHint + 2 + + install.xcscheme + + orderHint + 3 + + raptor.xcscheme + + orderHint + 4 + + + SuppressBuildableAutocreation + + 070044167B5A42D181D2512B + + primary + + + 0B2FB387089B4CDAA21BBEBA + + primary + + + 8CD08B6A715643089054DDDF + + primary + + + D4BB36A1A264413D965A2EB5 + + primary + + + + + diff --git a/packages/raptor/bib1300.daml.txt b/packages/raptor/bib1300.daml.txt new file mode 100644 index 000000000..6fc76f5f0 --- /dev/null +++ b/packages/raptor/bib1300.daml.txt @@ -0,0 +1,10030 @@ + + + + +$Id: bib1300.bib 2001/02/01 denker $ + DAML annotation of ca. 1300 bibliography entries + + + + + + + + "D. Basin" + "M. Clavel" "J. Meseguer" + "Rewriting Logic as a Metalogical Framework" + + "url{http://www.informatik.uni-freiburg.de/{homedir}basin/pubs/pubs.html}" + + "D. Basin" + "G. Denker" + "Maude versus Haskell: an Experimental Comparison in Security Protocol Analysis" + "May 2000" + "Sumitted for publication" + + "Klaus Havelud" + "Grigore Roc{s}u" + "Testing linear temporal logic formulas on finite execution traces" + "NASA Ames Research Center" + "" "2000" + + "Peter Csaba {\"O}lveczky" + "Jos'e Meseguer" + "Specification of real-time and hybrid systems in rewriting logic" + "2000" + "To appear in {em Theoretical Computer Science}, url{maude.csl.sri.com}" + + "Francisco Dur'an" + "Jos'e Meseguer" + "On Parameterized Theories and Views in {Full Maude} 2.0" + + "Proc. 3rd. Intl. Workshop on Rewriting Logic and its Applications" + "K. Futatsugi" "2000" + "{ENTCS}, Elsevier" + + "D. Basin" + "M. Clavel" + "J. Meseguer" + "Rewriting Logic as a Metalogical Framework" + "FST TCS 2000" "S. Kapoor" + "S. Prasad" "2000" + "55-80" "Springer LNCS" + + "Peter Csaba {\"O}lveczky" + "Jos'e Meseguer" + "{Real-Time} {Maude}: a tool for simulating and analyzing real-time and hybrid systems" + + "Proc. 3rd. Intl. Workshop on Rewriting Logic and its Applications" + "K. Futatsugi" "2000" + "{ENTCS}, Elsevier" + + "Manuel Clavel" + "Francisco Dur'an" "Steven Eker" + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" "Jos'e Meseguer" + "Jos'e Quesada" + "Towards {Maude} 2.0" + "Proc. 3rd. Intl. Workshop on Rewriting Logic and its Applications" + "K. Futatsugi" "2000" + "{ENTCS}, Elsevier" + + "Manuel Clavel" + "Francisco Dur'an" + "Narciso Mart'{i}-Oliet" + "Polytypic Programming in {Maude}" + "Proc. 3rd. Intl. Workshop on Rewriting Logic and its Applications" + "K. Futatsugi" "2000" + "{ENTCS}, Elsevier" + + + "Grit Denker" "Jos'e Meseguer" + "C. Talcott" + "Rewriting Semantics of Meta-Objects and Composable Distributed Services" + + "Proc. 3rd. Intl. Workshop on Rewriting Logic and its Applications" + "K. Futatsugi" "2000" + "{ENTCS}, Elsevier" + + + "Flaviu Cristian" + "Agreeing on processor group membership in timed asynchronous distributed systems" + + "University of California San Diego, Computer Science and Engineering Department" + "CSE95-428" "1995" + + "S. Kasera" + "S. Bhattacharyya" "M. Keaton" + "D. Kiwior" "J. Kurose" + "D. Towsley" + "S. Zabele" + "Scalable fair reliable multicast using active services" + "University of Massachusetts, Amherst, CMPSCI" + "TR 99-44" "1999" + + "Flaviu Cristian" + "Synchronous and asynchronous group communication" + + "Proceedings IEEE Workshop on Fault-tolerant and Parallel Distributed Systems, Honolulu, Hawaii" + "1995" + + + "R. Allen" "D. Garlan" + "Formalizing Architectural Connection" + "Proceedings 16th International Conference on Software Engineering" + "1994" + + + "G. Denker" "J. Meseguer" + "C. Talcott" + "{Rewriting Semantics of Distributed Meta Objects and Composable Communication Services}" + "1999" "working draft" + + + "M. Hicks" "P. Kakkar" + "J. T. Moore" + "C. A. Gunter" "S. Nettles" + "{PLAN: A Packet Language for Active Networks}" + + "Proceedings of the Third {ACM} {SIGPLAN} International Conference on Functional Programming Languages" + "1998" "86-93" + "ACM" + "http://www.cis.upenn.edu/~switchware/papers/plan.ps" + + "G. Denker" + "J. Millen" + "{CAPSL Intermediate Language}" + "{Workshop on Formal Methods and Security Protocols (FMSP'99), July 5, 1999, Trento, Italy (part of FLOC'99)}" + "N. Heintze" + "E. Clarke" "1999" + "url{http://cm.bell-labs.com/cm/cs/who/nch/fmsp99/}" + + "G. Denker" + "J. Meseguer" + "C. Talcott" + "{Protocol Specification and Analysis in Maude}" + + "{Proc. of Workshop on Formal Methods and Security Protocols, 25 June 1998, Indianapolis, Indiana}" + "1998" "N. Heintze" + "J. Wing" "" + "" "" + "" "" + + "url{http://www.cs.bell-labs.com/who/nch/fmsp/index.html}" + + + "{Denker, G." "J. J. Garcia-Luna-Aceves" + "J. Meseguer" + "P. \"Olveczky" "J. Raju" + "B. Smith" "C.} Talcott" + + "{Specification and Analysis of a Reliable Broadcasting Protocol in Maude}" + + "{Proc. 37th Annual Allerton Conference on Communication, Control and Computation}" + "1999" "B. Hajek" + "R. S. Sreenivas" + "738-747" "" + "University of Illinois" "" + "" + "url{http://www.comm.csl.uiuc.edu/allerton}" + + "J. Meseguer" + "C. Talcott" + "Semantic Interoperation of Dynamic Heterogeneous Architectures" + + "Technical presentations to EDCS Architecture Cluster Meeting, April and July 1997" + "1997" + + + "N. Venkatasubramanian" + "C. L. Talcott" "1995" + "{Principles of Distributed Computation}" + "{Reasoning about Meta Level Activities in Open Distributed Systems}" + + "Manuel Clavel" + "Jos'e Meseguer" + "Internal Strategies in a Reflective Logic" + "Proceedings of the CADE-14 Workshop on Strategies in Automated Deduction (Townsville, Australia, July 1997)" + "B. Gramlich" + "H. Kirchner" "1997" + "1-12" + "Patrick Lincoln" + "Jos'e Meseguer" + "Strategic Reflection" + "Proceedings of the CADE-15 Workshop on Strategies in Automated Deduction (Lindau, Germany, July 1998)" + "B. Gramlich" + "F. Pfenning" "1998" "3-9" + + "P. Borovansk'y" + "C. Kirchner" + "H. Kirchner" + "Strategies and Rewriting in {ELAN}" + "Proceedings of the CADE-14 Workshop on Strategies in Automated Deduction (Townsville, Australia, July 1997)" + "B. Gramlich" + "H. Kirchner" "1997" + + "P. Borovansk'y" + "C. Kirchner" "H. Kirchner" + + "Strategies of {ELAN}: meta-interpretation and partial evaluation" + + "Proceedings of the International Workshop on Theory and Practice of Algebraic Specifications (Amsterdam, Holland)" + "1997" + + "P.-E. Moreau" + "H. Kirchner" + "Compilation techniques for associative-commutative normalisation" + + "Proceedings of the International Workshop on Theory and Practice of Algebraic Specifications (Amsterdam, Holland)" + "1997" + + "Francisco Dur'an" + "Jos'e Meseguer" + "An extensible module algebra for {Maude}" + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "David Basin" + "Sean Matthews" + "Scoped Metatheorems" + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "L. J. Steggles" "P. Kosiuczenko" + + "A timed rewriting logic semantics for {SDL}: a case study of the alternating bit protocol" + + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "Francisco Dur'an" + "Jos'e Meseguer" + "Structured Theories and Institutions" + "{em Proc. Category Theory and Computer Science 1999/}, (Edinburgh, Scotland, September 1999) {ENTCS}, Vol. 29, {Elsevier}, 1999, url{http://www.elsevier.nl/locate/entcs/volume29.html}" + + "Bow-Yaw Wang" + "Jos'e Meseguer" "Carl A. Gunter" + + "Specification and formal analysis of a {PLAN} algorithm in {Maude}" + "To appear in Proc. DSVV 2000" + + + "G. Carabetta" "P. Degano" + "F. Gadducci" + "{CCS} semantics via proved transition systems and rewriting logic" + + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "Jos'e Meseguer" + "Carolyn Talcott" + "Mapping {OMRS} to rewriting logic" + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "Grit Denker" + "Jos'e Meseguer" "Carolyn Talcott" + + "Rewriting semantics of meta-objects and composable distributed services" + "Manuscript, February 1999" + + + "Jos'e Meseguer" + "A logical framework for distributed systems and communication protocols" + "{em Proc. FORTE/PSTV'98/}, {Kluwer}, 1998" + + "Manuel Clavel" + "Francisco Dur'an" "Steven Eker" + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" "Jos'e Meseguer" + "Jos'e Quesada" + "{Maude}: specification and programming in rewriting logic" + "SRI International, January 1999, url{http://maude.csl.sri.com}" + + "A. Verdejo" + "N. Mart'{i}-Oliet" + "Executing and verifying {CCS} in {Maude}" + "Technical Report 99-00, Dto. Sistemas Inform'aticos y Programaci'on, Universidad Complutense, Madrid; also, url{http://maude.csl.sri.com}" + + "Manuel Clavel" + "Francisco Dur'an" "Steven Eker" + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" "Jos'e Meseguer" + "Jos'e Quesada" + "A Tutorial on {Maude}" + "SRI International, March 2000, url{http://maude.csl.sri.com}" + + + "Manuel Clavel" "Francisco Dur'an" + "Steven Eker" + "Patrick Lincoln" "Narciso Mart'{i}-Oliet" + "Jos'e Meseguer" + "Jos'e Quesada" "{Maude} as a Metalanguage" + + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "Manuel Clavel" + "Francisco Dur'an" "Steven Eker" + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" "Jos'e Meseguer" + "Metalevel computation in {Maude}" + + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + + "Steven Eker" + "Term rewriting with operator evaluation strategy" + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "Peter Borovansk'y" + "Salma Jamoussi" + "Pierre-Etienne Moreau" "Christophe Ringeissen" + + "Handling {ELAN} rewrite programs via an exchange format" + + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "Roberto Bruni" "Jos'e Meseguer" + "Ugo Montanari" + "Internal strategies in a rewriting implementation of tile systems" + + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "K. Futatsugi" + "R. Diaconescu" "{CafeOBJ} Report" + "World Scientific, AMAST Series" + "1998" + + "T. Genet" + + "Proving termination of sequential reduction relation using tree automata" + "Manuscript; INRIA Lorraine, 1997" + + + "F. Gadducci" "U. Montanari" + "The tile model" + "In G. Plotkin, C. Stirling and M. Tofte, eds., {em Proof, Language and Interaction: Essays in Honour of Robin Milner}, MIT Press. Also, TR-96-27, C.S. Dept., Univ. of Pisa, 1996." + + "P. Viry" + "Rewriting modulo a rewrite system" + "TR-95-20, C.S. Department, University of Pisa, 1996." + + + "R. Bruni" "J. Meseguer" + "U. Montanari" + "Process and term tile logic" + "Technical Report SRI-CSL-98-06, SRI International, July 1998." + + + "M.-O. Stehr" + "A rewriting semantics for algebraic {Petri} nets" + "Manuscript, March 1998, SRI International and C.S. Dept., Univ. of Hamburg, 1998." + + "J. Meseguer" + "C. Talcott" + "Using Rewriting Logic to Interoperate Architectural Description Languages ({I and II})" + + "Lectures at the Santa Fe and Seattle DARPA-EDCS Workshops, March and July 1997. url{http://www-formal.stanford.edu/clt/ArpaNsf/adl-interop.html}." + + "E. Contejean" + "C. March'e" + "The {CiME} system: tutorial and user's manual" + "Manuscript, Universit'e Paris-Sud, Centre d'Orsay" + + + "M. Clavel" "F. Dur'an" + "S. Eker" + "J. Meseguer" "P. Lincoln" + "An introduction to {Maude} (beta version)" + "Manuscript, SRI International, March 1998" + + + "J. J. Garc'{i}a-Luna" + "Reliable broadcasting in computer networks" + "Manuscript; University of California at Santa Cruz, January 1998" + + "Grit Denker" + "Jos'e Meseguer" "Carolyn Talcott" + + "Formal specification and analysis of active networks and communication protocols: the {Maude} experience" + + "Proc. DARPA Information Survivability Conference and Exposition DICEX 2000, Vol. 1, Hilton Head, South Carolina, January 2000" + "2000" "251-265" + "IEEE" + + "Jos'e Meseguer" + + "Rewriting Logic and {Maude}: Concepts and Applications" + "Rewriting Techniques and Applications, RTA 2000" + "L. Bachmair" "2000" + "1-26" "1833" + "Springer-Verlag" + "Lecture Notes in Computer Science" + + "Francisco Dur'an" + "Steven Eker" + "Patrick Lincoln" "Jos'e Meseguer" + "Principles of {Mobile} {Maude}" + "Agent Systems, Mobile Agents, and Applications, ASA/MA 2000" + "D. Kotz" + "F. Mattern" "2000" + "73-85" "1882" + "Springer-Verlag" + "Lecture Notes in Computer Science" + + + "C. L. Talcott" + "Composable Semantic Models for Actor Theories" + "Theoretical Aspects of Computer Science" + "Lecture Notes in Computer Science" + "T. Ito M. Abadi" "1997" + "" "Springer-Verlag" + + "An Actor Rewriting Theory" + "C. L. Talcott" + "Proc. 1st Intl. Workshop on Rewriting Logic and its Applications" + "J. Meseguer" "1996" + "Electronic Notes in Theoretical Computer Science" + "4" + "North Holland" + "J. Meseguer" + "C. Talcott" "" + "Technical presentations to EDCS Architecture Cluster Meeting, April and July 1997" + + "1997" "J. Ad'amek" + "J. Rosick'y" + "Locally Presentable and Accessible Categories" + "Cambridge University Press" + "1994" + "P. D. Mosses" + "Action Semantics" + "Cambridge University Press" "1992" + + + "P. Burmeister" + "Partial Algebras---{S}urvey of a Unifying Approach Towards a Two-Valued Model Theory for Partial Algebras" + "Algebra Universalis" + "1982" "15" "306-358" + + + "Doron Peled" + "Combining partial order reductions with on-the-fly model-checking" + "Formal Methods in System Design" + "1996" "8" + "39-64" + "C. Strachey" + "Fundamental concepts in programming languages" + "Higher-Order and Symbolic Computation" "2000" + "13" "11-49" + + "T. Mossakowski" + + "Representations, Hierarchies, and Graphs of Institutions" + + "Fachbereich Mathematik und Informatik der Universit{\"a}t Bremen" + "1996" + + "A. Knapp" + "A formal approach to object-oriented software engineering" + + "Institut f{\"u}r Informatik, Universit{\"a}t M{\"u}nchen" + "2000" "To appear" + + + "J. F. Quesada" + "{The {SCP} parsing algorithm based on syntactic constraint propagation}" + "University of Seville" + "{Doctoral Dissertation}" + "1997" + "A. van Deursen" + "Executable Language Definitions" + "University of Amsterdam" "1994" + + "U. Lechner" + "Object-oriented specification of distributed systems" + "University of Passau" "1997" + + + "Grit Denker" "Jos'e Meseguer" + "Carolyn Talcott" + "Formal Specification and Analysis of Active Networks and Communication Protocols: The {Maude} Experience" + "Manuscript, SRI International, October 1999" + + "David Basin" "Manuel Clavel" + "Jos'e Meseguer" + "Reflective metalogical frameworks" + "In Proc. LFM'99, (Paris, France, September 1999) url{http://www.cs.bell-labs.com/~felty/LFM99/}" + + "Manuel Clavel" + "Francisco Dur'an" "Steven Eker" + "Jos'e Meseguer" + "Mark-Oliver Stehr" + "{Maude} as a formal meta-tool" + "FM'99 --- Formal Methods" "1999" + "J. Wing" "J. Woodcock" + "1684-1703" + "Springer-Verlag" "1709" + "Lecture Notes in Computer Science" + + + "Isabel Pita" + "Narciso Mart'{i}-Oliet" + "Using reflection to specify transaction sequences in rewriting logic" + + "Recent Trends in Algebraic Development Techniques" + "1999" "J. L. Fiadeiro" + "261-276" "Springer-Verlag" + "1589" + "Lecture Notes in Computer Science" + + + "J. Fiadeiro" "N. Mart'{i}-Oliet" + "T. Maibaum" + "J. Meseguer" "I. Pita" + "Towards a Verification Logic for Rewriting Logic" + + "Recent Trends in Algebraic Development Techniques, WADT'99" + "2000" "D. Bert" + "C. Choppy" + "P. Mosses" "438-458" + "Springer-Verlag" "1827" + "Lecture Notes in Computer Science" + + + "T. Mossakowski" + "Equivalences among Various Logical Frameworks of Partial Algebras" + + "Computer Science Logic, Paderborn, Germany, September 1995, Selected Papers" + "1996" + "H. Kleine B{\"u}ning" "403-433" + "Springer-Verlag" "1092" + "Lecture Notes in Computer Science" + + "Jos'e Meseguer" + "Formal Interoperability" + "Proceedings of the 1998 Conference on Mathematics in Artificial Intelligence, Fort Laurerdale, Florida, January 1998" + + "url{http://rutcor.rutgers.edu/~amai/Proceedings.html}" + "1998" + + + "M. Coste" + "Localisation, Spectra and Sheaf Representation" + "Applications of Sheaves" + "1979" "M. P. Fourman" + "C. J. Mulvey" "D. S. Scott" + "212-238" "Springer-Verlag" + "753" + "Lecture Notes in Mathematics" + + "V. Manca" + "A. Salibra" + "G. Scollo" "Equational Type Logic" + "Theoretical Computer Science" + "1990" "77" "131-159" + + + "S. Morasca" "M. Pezz`e" + "M. Trubian" + "Timed high-level nets" + "J. of Real-Time Systems" "1991" + "3" "165-189" + + "P. D. Mosses" + "Unified Algebras and Institutions" + + "Proc. Fourth Annual IEEE Symp. on Logic in Computer Science" + "1989" "304-312" + "Asilomar, California" + "June" + + "W. W. Wadge" + "Classified Algebras" + "1982" "University of Warwick" + + "Manuel Clavel" + "Francisco Dur'an" + "Steven Eker" "Jos'e Meseguer" + + "Design and Implementation of the {Cafe} Prover and {Church-Rosser} Checker Tools" + "1997" "December" + "SRI International" + + + "G. F. Stuart" "W. W. Wadge" + "Classified Model Abstract Data Type Specification" + "1991" + "Manuscript, University of Victoria" + + + "Manuel Clavel" + "Reflection in General Logics and in Rewriting Logic, with Applications to the {Maude} Language" + "1998" + "Ph.D. Thesis, University of Navarre" + + + "Manuel Clavel" + "Reflection in Rewriting Logic: Metalogical Foundations and Metaprogramming Applications" + "2000" + "CSLI Publications" + "Francisco Dur'an" + "A Reflective Module Algebra with Applications to the {Maude} Language" + "1999" + "Ph.D. Thesis, University of M'alaga" + + + "Jos'e Meseguer" + "Membership algebra as a logical framework for equational specification" + "1998" + "In F. Parisi-Presicce, ed., {it Proc. WADT'97}, 18--61, Springer LNCS 1376" + + + "Jos'e Meseguer" "Ugo Montanari" + "Mapping Tile Logic into Rewriting Logic" + "1998" + "in F. Parisi-Presicce, ed., Proc. WADT'97, Springer LNCS 1376" + + + "{CoFI Task Group on Semantics}" + "{CASL}---{T}he {CoFI} Algebraic Specification Language, Version 0.97, {S}emantics" + "July" "1997" + "url{http://www.brics.dk/Projects/CoFI}" + + + "A. Poign'e" "Algebra Categoricaly" + "Category Theory and Computer Programming" + "1985" + "D. Pitt et al." "76-102" + "Springer-Verlag" "240" + "Lecture Notes in Computer Science" + + "Manuel Clavel" + "Francisco Dur'an" "Steven Eker" + "Jos'e Meseguer" + "Building equational proving tools by reflection in rewriting logic" + "1998" "April" + "Proc. of the CafeOBJ Symposium '98, Numazu, Japan" + "CafeOBJ Project" + "url{http://maude.csl.sri.com}" + + + "Manuel Clavel" "Francisco Dur'an" + "Steven Eker" + "Jos'e Meseguer" + "Building equational proving tools by reflection in rewriting logic" + "2000" + "CAFE: An Industrial-Strength Algebraic Formal Method" + "Elsevier" + "url{http://maude.csl.sri.com}" + + "M. Ishisone" + "T. Sawada" + "Brute: brute force rewriting engine" "1998" + "April" + "Proc. of the CafeOBJ Symposium '98, Numazu, Japan" + "CafeOBJ Project" + + + "S. Nakajima" + "Encoding mobility in {CafeOBJ}: an exercise of describing mobile code-based software architecture" + "1998" "April" + "Proc. of the CafeOBJ Symposium '98, Numazu, Japan" + "CafeOBJ Project" + + "A. Knapp" + "Case Studies with {CafeOBJ}" "1998" + "April" + "Proc. of the CafeOBJ Symposium '98, Numazu, Japan" + "CafeOBJ Project" + + "P. Freyd" + + "Algebra valued functors in general and tensor products in particular" + "Coll. Math." "14" + "89-106" "1966" + + "F. W. Lawvere" + "Some algebraic problems in the context of functorial semantics of algebraic theories" + "Proc. Midwest Category Seminar II" + "1968" "41-61" + "Springer Lecture Notes in Mathematics No. 61" + + "Digital Signature Schemes" + "B. Pfitzmann" "1996" + "Springer-Verlag" + "LNCS, Volume 1100" + "C. Kirchner" + "P. Viry" + "Implementing Parallel Rewriting" + "Parallelization in Inference Systems" "1992" + "B. Fronh{\"o}fer" + "G. Wrightson" "123-138" + "Springer LNAI 590" + + + "Adel Bouhoula" "Jean-Pierre Jouannaud" + "Jos'e Meseguer" + "Specification and Proof in Membership Equational Logic" + "Proceedings TAPSOFT'97" "1997" + "M. Bidoit" + "M. Dauchet" "Springer-Verlag" + "1214" "67-92" + "Lecture Notes in Computer Science" + + + "T. Genet" + "Termination proofs using gpo ordering constraints" + + "Proceedings 22nd International Colloquium on Trees in Algebra and Programming" + "1997" "M. Bidoit" + "M. Dauchet" + "Springer-Verlag" "1214" + "249-260" + "Lecture Notes in Computer Science" + + + "mbox{Franc{c}ois-Nicola Demers" + "Jacques Malenfant}" + "Reflection in logic, functional and object-oriented programming: a Short Comparative Study" + + "IJCAI '95 Workshop on Reflection and Metalevel Architectures and their Applications in AI" + "1995" "August" + "29-38" + + + "C. Dony J. Malenfant" "P. Cointe" + + "A Semantics of Introspection in a Reflective Prototype-Based Language" + "To appear in emph{Lisp and Symbolic Computation}" + + "Jos'e Meseguer" + "Membership Algebra" + "Lecture and abstract at the Dagstuhl Seminar on ``Specification and Semantics,'' July 9, 1996" + + "Jos'e Meseguer" + "Carolynn Talcott" + "Rewriting Logic and Secure Mobility" + "To appear in {em Proc. Workshop on Foundations for Secure Mobile Code}, Monterey, California, March 1997" + + "M. Walicki" + "S. Meldal" + "Algebraic approaches to nondeterminism---an overview" + "To appear in emph{Computing Surveys}" + + "Vijay Saraswat" + "Jos'{e} Meseguer" "Carolyn Talcott" + "Radha Jagadeesan" + "Formal Foundations for {\bf tic-toc}" "February" + "1996" + + "Chris Hankin" + "Gamma" + "In C. Hankin and H.R. Nielson (editors) {em New Trends in the Integration of Paradigms}, Dagstuhl Seminar Report 125, (9538), 1995" + + "Peter Aczel" + "A general {Church-Rosser} theorem" + "Manuscript, University of Manchester, 1978" + + "Jos'e Meseguer" + + "Rewriting Logic and {Maude}: a wide-spectrum semantic framework for object-based distributed systems" + + "Formal Methods for Open Object-based Distributed Systems, FMOODS 2000" + "S. Smith" + "C. L. Talcott" "2000" + "89-117" "Kluwer" + + "Jos'e Meseguer" + + "Specifying, analyzing, and programming communication systems in {Maude}" + "Communication-Based Systems" + "G. Hommel" "2000" + "93-101" "Kluwer" + + "C. L. Talcott" + + "Interaction Semantics for Components of Distributed Systems" + "Formal Methods for Open Object-based Distributed Systems" + "E. Najm" + "J-B. Stefani" "1997" + "154-169" "Chapman & Hall" + + "E. Najm" + "J-B. Stefani" + "Computational models for open distributed systems" + + "Formal Methods for Open Object-based Distributed Systems, Vol. 2" + "H. Bowman" + "J. Derrick" "1997" + "157-176" "Chapman & Hall" + + "G. Agha" + "I. A. Mason" "S. F. Smith" + "C. L. Talcott" + "A Foundation for Actor Computation" + "Journal of Functional Programming" "1996" + "to appear" + + + "Vineet Gupta" "Radha Jagadeesan" + "Vijay A. Saraswat" + "Danny G. Bobrow" + "Computing with Continuous Change" + "Submitted for publication, October 1995" + + + "Vijay A. Saraswat" "Radha Jagadeesan" + "Vineet Gupta" + "Timed Default Concurrent Constraint Programming" + "Submitted for publication. Extended abstract published in Proc. of the 22nd Ann. ACM SIGPLAN SIGACT Sym. on the Principles of Prog. Lang., San Francisco, January 1995" + + + "Vijay A. Saraswat" "Vineet Gupta" + "The {\bf tic-toc} computation model" + "Pueblo Working Document #1, July 1996" + + + "William E. Aitken" + "Robert L. Constable" "Judith L. Underwood" + + "Metalogical Frameworks {II}: Using Reflected Decision Procedures" + + "Technical Report, Computer Sci. Dept., Cornell University, 1993; also, lecture at the Max Planck Institut f{\"u}r Informatik, Saarbr{\"u}cken, Germany, July 1993" + + "C. Kirchner" + "H. Kirchner" + "Personal communication" "July 1995" + + + "John Harrison" + "Metatheory and reflection in theorem proving: a survey and critique" + "University of Cambridge Computer Laboratory" + "1995" + + + "Jos'e Meseguer" "Formal Interoperability" + + "Paper presented at the 14th IMACS World Congress, Atlanta, Georgia, July" + "1994" + + "M. Vittek" + + "{ELAN}: Un cadre logique pour le prototypage de langages de programmation avec contraintes" + "Universit'e Henry Poincar'e --- Nancy I" + "1994" + + "J. Levy" + + "The calculus of refinements: a formal specification model based on inclusions" + "Universitat Polit`ecnica de Catalunya" + "1994" + + + "A. Corradini" "F. Gadducci" + "U. Montanari" + "Relating two categorical models of term rewriting" + + "Proc. Rewriting Techniques and Applications, Kaiserslautern" + "J. Hsiang" + "225-240" "1995" + + + "F. Gadducci" "U. Montanari" + "Enriched categories as models of computation" + + "Proc. $5^{th}$ Italian Conference on Theoretical Computer Science, Ravello" + "1995" + + + "H. Kirchner" "P.-E. Moreau" + + "Prototyping completion with constraints using computational systems" + + "Proc. Rewriting Techniques and Applications, Kaiserslautern" + "J. Hsiang" "1995" + + "E. Battiston" + "V. Crespi" "F. De Cindio" + "G. Mauri" + "Semantic frameworks for a class of modular algebraic nets" + "Proc. of the 3rd International AMAST Conference" + "1994" "M. Nivat" + "C. Rattray" + "T. Russ" "G. Scollo" + "Springer-Verlag" + "Workshops in Computing" + + "Manuel Clavel" + "Jos'e Meseguer" + "Axiomatizing reflective logics and languages" + "Proceedings of Reflection'96, San Francisco, California, April 1996" + "Gregor Kiczales" + "263-288" + "url{http://jerry.cs.uiuc.edu/reflection/}" "1996" + + + "Proceedings of Reflection'96, San Francisco, California, April 1996" + "Gregor Kiczales" + "Xerox PARC" "1996" + + + "Proceedings of the Partial Evaluation Dagstuhl Meeting, 1996" + "O. Danvy" "R. Gl{\"u}ck" + "P. Thiemann" + "Springer LNCS 1110" "1996" + + + "Meta-Level Architectures and Reflection" + "P. Cointe" "Springer LNCS 1616" + "1999" + + + "U. Lechner" "C. Lengauer" + "M. Wirsing" + "An Object-Oriented Airport" + "Recent Trends in Data Type Specification, Santa Margherita, Italy, May/June 1994" + "1995" "E. Astesiano" + "G. Reggio" + "A. Tarlecki" "351-367" + "Springer LNCS 906" + + "T. Mossakowski" + "Equivalences among various logical frameworks of partial algebras" + + "9th Workshop on Computer Science Logic, CSL'95, Paderborn, September 1995" + "1996" + "H. Kleine B{\"u}ning" "403-433" + "Springer LNCS 1092" + + + "A. Corradini" "F. Gadducci" + "{CPO} models for infinite term rewriting" + "Proc. AMAST'95" + "1995" "368-384" + "Springer LNCS 936" + + + "P. Borovansk'y" + "Implementation of higher-order unification based on calculus of explicit substitutions" + "Proc. SOFTSEM'95" + "1995" "M. Bartosek" + "J. Staudek" "J. Wiedermann" + "363-368" "Springer LNCS 1012" + + "R. Alur" + "C. Courcoubetis" "T. A. Henzinger" + "P.-H. Ho" + "Hybrid automata: an algorithmic approach to the specification and verification of hybrid systems" + "Workshop on Theory of Hybrid Systems" + "1993" + "R. L. Grossman" "A. Nerode" + "A. P. Ravn" "H. Rischel" + "209-229" + "Springer LNCS 739" + + + "Jos'e Meseguer" "Narciso Mart'{i}-Oliet" + "From abstract data types to logical frameworks" + + "Recent Trends in Data Type Specification, Santa Margherita, Italy, May/June 1994" + "1995" "E. Astesiano" + "G. Reggio" + "A. Tarlecki" "48-80" + "Springer LNCS 906" + + + "M. Bettaz" "M. Maouche" + + "How to specify nondeterminism and true concurrency with algebraic term nets" + "Recent Trends in Data Type Specification" + "1993" "M. Bidoit" + "C. Choppy" "164-180" + "Springer LNCS 655" + + "M. Bettaz" "M. Maouche" + + "Modeling of object based systems with hidden sorted {ECATNets}" + "Proc. of MASCOTS'95, Durham, North Carolina" + "1995" "307-311" + "IEEE" + + + "K. Futatsugi" "T. Sawada" + "Cafe as an extensible specification environment" + + "In {it Proc. of the Kunming International CASE Symposium, Kunming, China, November}" + "1994" + + + "H. Reichel" + "An Approach to Object Semantics Based on Terminal Co-algebras" + + "To appear in {it Mathematical Structures in Computer Science/}, 1995. Presented at {em Dagstuhl Seminar on Specification and Semantics}, Schloss Dagstuhl, Germany, May 1993" + + "C. Landauer" + "K. Bellman" + "A. Gillam" + "Software Infrastructure for System Engineering Support" + + "{AAAI}'93 Workshop on Artificial Intelligence for System Engineering" + "1993" + + + "Common Object Request Borker Architecture and Specification" + "OMG" + "Hewlett-Packard Company and SunSoft, Inc." + "{OMG Document Number 91.12.1}" "1991" + + + "J. G. Stell" + "Modelling term rewriting systems by sesqui-categories" + "Keele University" + "{TR94-02}" "1994" + "Also in shorter form in Proc. C.A.E.N., 1994, pp. 121--127" + + "J. M. Purtilo" + "A Software Interconnection Technology" + "University of Maryland" + "{UMIACS-TR-88-83, CS-TR-2139}" "1988" + + + "J. Lee" "T. W. Malone" + + "Partially shared views: {A} {SC}heme for Communicating among Groups that Use Different Type Hierarchies" + "{ACM} Transactions on Information Systems" + "8" "1" + "1-26" "1990" + + + "Adel Bouhoula" "Jean-Pierre Jouannaud" + "Jos'e Meseguer" + "Specification and Proof in Membership Equational Logic" + "Theoretical Computer Science" + "236" "35-132" "2000" + + + "R. P. Lippmann" + "An introduction to computing with neural nets" + "{IEEE} {ASSP} Magazine" "April" + "4-22" "1987" + + + "M. R. Genesereth" + "An Agent-Based Framework for Software Interoperation" + "Proceedings {DARPA} Software Technology Conference" + "1992" "359-366" + + "J. W. Lewis" + "the {DICE} Team" + "Wrappers: Integration Utilities and Services for the {DICE} Architecture" + + "Proceedings {CALS & CE}: Computer Aided Logistic Systems and Concurrent Engineering" + "1991" "445-457" + + + "Connecting Tools Using Message Passing in the Field Environment" + "{IEEE} Software" + "July" "1990" "57-66" + + "K. Bellman" + + "An Approach to Integrating and Creating Flexible Software Environments Supporting the Design of Complex Systems" + + "Proceedins of {SOAR}'91: The 1991 Symposium on Space Operations, Automation and Research, 9-11 July 1991, Houston, Texas" + "1991" + "Computer Science and Technology SubDivision, The Aeorspace Corporation, Los Angeles CA, 90009-2957" + + "C. Landauer" + "K. Bellman" + "Integrated Simulation Environments" + "Proceedins of {DARPA} Variable-Resolution Modeling Conference, 5-6 May 1992, Herndon, Virginia" + "1993" + "CF-103-DARPA, published by RAND" + + "C. Landauer" + "K. Bellman" + "The Role of Self-Referential Logics in a Software Architecture Using Wrappings" + "1993" + "3rd Irvine Software Symposium" + + "D. Walter" + "K. Bellman" + "Some issues in model integration" "1990" + "1990 Eastern Simulation Conference" + + + "Narciso Mart'{i}-Oliet" "Jos'e Meseguer" + "General Logics and Logical Frameworks" + "D. Gabbay" + "What is a Logical System?" "1994" + "355-392" + "Oxford University Press" + + "Shmuel Katz" + + "Refinement with global equivalence proofs in temporal logic" + "DIMACS Series in Discrete Mathematics, Vol. 29" + "19997" "59-78" + "American Mathematical Society" + + "R. Jagannathan" + "Dataflow Models" "E. Y. Zoyama" + "Parallel and Distributed Computing Handbook" + "1996" "223-238" + "McGraw Hill" + + + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" "Jos'e Meseguer" + + "Specification, transformation, and programming of concurrent systems in rewriting logic" + "G. E. Blelloch" + "K. M. Chandy" "S. Jagannathan" + "Specification of Parallel Algorithms" + "309-339" + "DIMACS Series, Vol. 18, American Mathematical Society" + "1994" "R. Harper" + "D. Sanella" "A. Tarlecki" + "Logic representation in {LF}" + "D. H. Pitt et al." + "Category Theory and Computer Science" "1989" + "250-272" + "Springer LNCS 389" + + "Andrea Corradini" + "Ugo Montanari" + "An algebra of graphs and graph rewriting" + "D. H. Pitt et al." + "Category Theory and Computer Science" "1991" + "236-260" + "Springer LNCS 530" + + + "Christophe Ringeissen" + "Combination of matching algorithms" + "P. Enjalbert et al." + "Proceedings of the 11th TACS Symposium" "1994" + "187-198" + "Springer LNCS 775" + + + "Christophe Ringeissen" + "Prototyping combination of unification algorithms with the {ELAN} rule-based programming language" + "H. Comon" + "Proceedings of the 8th Conference on Rewriting Techniques and Applications" + "1997" + "Springer LNCS 1232" + + "K. Ogata" + "K. Futatsugi" + "An abstract machine for order-sorted conditional term rewriting systems" + "H. Comon" + "Proceedings of the 8th Conference on Rewriting Techniques and Applications" + "1997" + "Springer LNCS 1232" + + + "Jos'e Meseguer" + "Completions, factorizations and colimits for $omega$-posets" + + "Mathematical Logic in Computer Science, Salgotarjan, 1978, Colloquia Mathematica Societatis Janos Bolyai" + "26" "1981" + "509-545" + "North Holland" + + + "Maura Cerioli" "Jos'e Meseguer" + "May {I} borrow your logic?" + "Proceedings of MFCS'93, 18th International Symposium on Mathematical Foundations of Computer Science" + "1993" "342-351" + "Springer LNCS 711" + + "Peter Mosses" + "Foundations of Modular {SOS}" + "Proceedings of MFCS'99, 24th International Symposium on Mathematical Foundations of Computer Science" + "1999" "70-80" + "Springer LNCS 1672" + + "C. Braga" + "H. Haeusler" "J. Meseguer" + "P. Mosses" + "Maude {Action} {Tool}: using reflection to map action semantics to rewriting logic" + "Proceedings of AMAST'2000" + "2000" "Springer LNCS" + "To appear" + + "F. Parisi-Presicce" + "S. Veglioni" + "Heterogeneous unified algebras" + "Proceedings of MFCS'93, 18th International Symposium on Mathematical Foundations of Computer Science" + "1993" "618-628" + "Springer LNCS 711" + + "Jos'e Meseguer" + "Ugo Montanari" + "Vladimiro Sassone" + "On the model of computation of {Place/Transition} {Petri} nets" + + "Proceedings 15th International Conference on Application and Theory of Petri Nets" + "1994" "16-38" + "Springer LNCS 815" + + "Jos'e Meseguer" + "Ugo Montanari" + "Vladimiro Sassone" + "Representation Theorems for {Petri} nets" + "Foundations of Computer Science: Potential, Theory, Cognition" + "C. Freska" + "M. Jantzen" "R. Valk" + "1997" "239-249" + "Springer LNCS 1337" + + + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" "Jos'{e} Meseguer" + "Livio Ricciulli" + "Compiling rewriting onto {SIMD} and {MIMD/SIMD} machines" + + "Proceedings of PARLE'94, 6th International Conference on Parallel Architectures and Languages Europe" + "1994" "37-48" + "Springer LNCS 817" + + + "Patrick Lincoln" "Jos'{e} Meseguer" + "Livio Ricciulli" + "The {Rewrite Rule Machine Node Architecture and its Performance}" + + "Proceedings of CONPAR'94, Linz, Austria, September 1994" + "1994" "509-520" + "Springer LNCS 854" + + + "Jeffrey Arnold" "Duncan Buel" + "Elaine Davis" + "{SPLASH} 2" + "Proceedings of the 1992 Symposium on Parallel Algorithms and Architectures" + "1992" "ACM" + + "J. L. Fiadeiro" + "T. Maibaum" + "Interconnecting formalisms: supporting modularity, reuse and incrementality" + + "Proceedings of the 1995 SIGSOFT Conference, Washington DC, USA" + "1995" "72-80" + "ACM" + + "Timothy Winkler" + "Programming in {OBJ} and {Maude}" + "Peter Lauer" + "Functional Programming, Concurrency, Simulation and Automated Reasoning" + "1993" "229-277" + "Springer LNCS 693" + + "Kokichi Futatsugi" + "Joseph Goguen" + "Jean-Pierre Jouannaud" "Jos'{e} Meseguer" + "Principles of {OBJ}2" + "1985" + "Proceedings of 12th ACM Symposium on Principles of Programming Languages" + "Brian Reid" + "ACM" "52-66" + + + "P. M. Hill" "J. W. Lloyd" + "The {G\"odel} Language" + "University of Bristol, Computer Science Department" + "CSTR-92-27" + "1992" + "Wolfgang Schreiner" + "Parallel functional programming: an annotated bibliography" + + "Research Institute for Symbolic Computation, Johannes Kepler University, Linz, Austria" + "1993" + + + "Narciso Mart'{i}-Oliet" + "Jos'e Meseguer" + "Rewriting Logic as a Logical and Semantic Framework" + "SRI International, Computer Science Laboratory" + "SRI-CSL-93-05" + "1993" "August" + "To appear in D. Gabbay, ed., {em Handbook of Philosophical Logic/}, Kluwer Academic Publishers" + + + "Unifying Functional, Object-Oriented and Relational Programming with Logical Semantics" + "Joseph Goguen" + "Jos'{e} Meseguer" + "Research Directions in Object-Oriented Programming" + "Bruce Shriver" "Peter Wegner" + "1987" "417-477" + "MIT Press" + + + "Jos'e Meseguer" + "A Logical Theory of Concurrent Objects and its realization in the {Maude} Language" + + "Research Directions in Concurrent Object-Oriented Programming" + "Gul Agha" + "Peter Wegner" "Akinori Yonezawa" + "1993" "314-390" + "MIT Press" + + + "Joseph Goguen" "Timothy Winkler" + "Jos'e Meseguer" + "Kokichi Futatsugi" "Jean-Pierre Jouannaud" + "Introducing {OBJ}" + "Software Engineering with OBJ: Algebraic Specification in Action" + "3-167" "Kluwer" + "J.A. Goguen" + "G. Malcolm" "2000" + + + "Satoshi Matsuoka" + "Akinori Yonezawa" + "Analysis of inheritance anomaly in object-oriented concurrent programming languages" + + "Research Directions in Concurrent Object-Oriented Programming" + "Gul Agha" + "Peter Wegner" "Akinori Yonezawa" + "1993" "107-150" + "MIT Press" + + + "Peter Csaba {\"O}lveczky" "Jos'e Meseguer" + "Specifying real-time systems in rewriting logic" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "C. L. Talcott" + "An actor rewrite theory" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + + "C. L. Talcott" + "An actor rewrite theory" "This volume" + + + "R. Diaconescu" + "Hidden sorted rewriting logic" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "M. Schorlemmer" + "Bi-rewriting rewriting logic" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "C. Castro" + "An approach to solving binary {CSP} using computational systems" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "A. Ciampolini" + "E. Lamma" "P. Mello" + "C. Stefanelli" + "Distributed logic objects: a fragment of rewriting logic and its implementation" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "M. Wirsing" "A. Knapp" + + "A formal approach to object-oriented software engineering" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "Steven Eker" + "Fast matching in combination of regular equational theories" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "Manuel Clavel" + "Steven Eker" "Patrick Lincoln" + "Jos'e Meseguer" + "Principles of {Maude}" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "Manuel Clavel" + "Jos'e Meseguer" + "Reflection and strategies in rewriting logic" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "Manuel Clavel" + "Jos'e Meseguer" + "Reflection in conditional rewriting logic" "2000" + "Submitted for publication" + + + "P. Borovansk'y" "C. Kirchner" + "H. Kirchner" + "P.-E. Moreau" "M. Vittek" + "{ELAN}: {A} logical framework based on computational systems" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "P. Borovansk'y" + "C. Kirchner" "H. Kirchner" + "Controlling rewriting by rewriting" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "H. Kirchner" + "P.-E. Moreau" + "Computational reflection and extension in {ELAN}" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "P. Viry" + "Input/Output for {ELAN}" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "C. Landauer" + "Discrete event systems in rewriting logic" + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "U. Lechner" + + "Object-oriented specification of distributed systems in the $mu$-calculus and {Maude}" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "U. Lechner" + "C. Lengauer" "Modal $mu$-{Maude}" + + "In {it Object Orientation with Parallelism and Persistence/}, B. Freitag, C.B. Jones, C. Lengauer and H.-J. Schek, editors, Kluwer, 1996" + + "Isabel Pita" + "Narciso Mart'{i}-Oliet" + "A {Maude} specification of an object oriented database model for telecommunication networks" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "Narciso Mart'{i}-Oliet" + "Jos'e Meseguer" + "Rewriting logic as a logical and semantic framework" + + "Proc. First Intl. Workshop on Rewriting Logic and its Applications" + "1996" "J. Meseguer" + "Elsevier" "4" + + "Electronic Notes in Theoretical Computer Science" + "url{http://www.elsevier.nl/cas/tree/store/tcs/free/noncas/pc/volume4.htm}" + + "Jos'e Meseguer (ed.)" + + "{em Proc. First Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1996" + + "C. Kirchner" + "H. Kirchner (eds.)" + "{em Proc. 2nd Intl. Workshop on Rewriting Logic and its Applications/}, {ENTCS}, {North Holland}, 1998" + + "U. Lechner" "C. Lengauer" + "F. Nickl" + "M. Wirsing" + "How to overcome the inheritance anomaly" + "in {it Proc.ECOOP'96/}, Springer LNCS, 1996" + + + "Charles Leiserson" + "{FAT-TREES}: Universal Networks for Hardware-Efficient Supercomputing" + + "MIT, Laboratory for Computer Science, November 1984" + + + "C. Talcott" + "Semantics of Component Based Distributed, Open, Heterogeneous Systems" + "Manuscript, Stanford University, February 1995" + + + "C. Talcott" + "Concurrent Rewriting Interaction Semantics for Abstract Actor Systems" + "Manuscript, Stanford University, September 1995" + + "Jos'e Meseguer" + "Carolyn Talcott" + "Reasoning theories and rewriting logic" + "Manuscript, Stanford University, June 1996" + + + "Dale Miller" + "The $pi$-calculus as a theory in linear logic: preliminary results" + + "Computer Science Department, University of Pennsylvania, February 1992" + + "Bart Jacobs" + "Categorical logic and type theory" + "To be published by North-Holland" + + + "Patrick Lincoln" "Jos'e Meseguer" + "Babak Taheri" + "Timothy Winkler" + "Preliminary Estimates for the Use of the Splash {II} System in the Emulation of the Rewrite Rule Machine" + "Manuscript, August 1992" + + "Joseph Goguen" + "Jos'e Meseguer" + "Software Componet Search" + "September 1994. Submitted for publication" + + "C. Talcott" + "Mathematical Foundations for Survivable Systems" + + "Proceedings of the $14^{\rm th}$ {IMACS} Congress, Atlanta, Georgia, July 1994" + + "Livio Ricciulli" + "Patrick Lincoln" "Jos'e Meseguer" + "Distributed simulation of parallel executions" + + "In {it Proc. 29th Ann. Simulation Symp.}, New Orleans, Louisiana, April 8--11 1996, IEEE" + + "Livio Ricciulli" + "Patrick Lincoln" "Jos'e Meseguer" + + "Decoupled simulation of parallel computer systems" + "SRI International, Computer Science Laboratory, March 1996" + + + "Vladimiro Sassone" "Jos'e Meseguer" + "Ugo Montanari" + "Inductive Completion of Monoidal Categories and Infinite Net Computations" + "Submitted for publication" + + "Adel Bouhoula" + "Micha{\"e}l Rusinowitch" + "Implicit Induction in Conditional Theories" + "J. of Automated Reasoning" "14" + "189-235" "1995" + + "Joseph Goguen" + "Doan Nguyen" "Jos'e Meseguer" + "Luqi" "Du Zhang" + "Valdis Berzins" + "Software Componet Search" + "J. of Systems Integration" "6" + "93-134" "1996" + + "P. Degano" + "J. Meseguer" + "U. Montanari" + "Axiomatizing the Algebra of Net Computations and Processes" + "1996" "Acta Informatica" + "33" "641-667" + + "C. Beeri" + "Theoretical Foundations for {OODB}'s -- {A} Personal Perspective" + "IEEE Data Engineering Bulletin" + "1991" "14" + "2" "8-12" + + "Luca Cardelli" + "A language with distributed scope" + "Computing Systems" "1995" + "8" "1" + + "27-59" "Akinori Yonezawa" + "Satoshi Matsuoka" + "Masahiro Yagusi" "Kenjiro Taura" + + "Implementing concurrent object-oriented languages on multicomputers" + + "IEEE Parallel and Distributed Technology Journal" + "1993" "1" + "2" "49-61" + + "M. Kifer" + "G. Lausen" + "{F}-Logic: {A} Higher-Order Language for Reasoning about Objects, Inheritance, and Scheme" + "Proc. ACM SIGMOD" + "1989" "134-146" + + "Jos'e Meseguer" + "Xiaolei Qian" + "A Logical Semantics for Object-Oriented Databases" + + "Proc. International SIGMOD Conference on Management of Data" + "1993" "ACM" + "89-98" + + + "S. Abiteboul" "P. Kanellakis" + "The Two Facets of Object-Oriented Data Models" + "IEEE Data Engineering Bulletin" + "1991" "14" + "2" "3-7" + + "S. Abiteboul" "P. Kanellakis" + "Object Identity as a Query Language Primitive" + "Proc. ACM SIGMOD" + "1989" "159-173" + + "S. Abiteboul" + "A. Bonner" "Objects and Views" + "Proc. ACM SIGMOD" + "1991" "238-247" + + "S. Abiteboul" + "P. Kanellakis" "E. Waller" + "Method Schemas" + "Proc. 9th PODS" "1990" + "ACM" "16-27" + + "E. Bertino" + "A View Mechanism for Object-Oriented Databases" + "Proc. EDBT" + "1992" "136-151" + "Springer LNCS 580" + + + "W. Chen" "M. Kifer" + "D. S. Warren" + "HiLog as a Platform for Database Languages (or Why Predicate Calculus is not Enough)" + + "Proc. 2nd Int'l Workshop on Database Programming Languages" + "1989" "315-329" + + + "Kokichi Futatsugi" + "Trends in Formal Specification Methods based on Algebraic Specification Techniques -- from Abstract Data Types to Software Processes: {A} Personal Perspective --" + + "Proceedings of the International Conference of Information Technology Commemorating the 30th Anniversary of the Information Processing Society of Japan (InfoJapan'90)" + "IPSJ" "1990" + "October" "59-66" + + + "ISO" + "{IS8807} : Information Processing Systems - Open System Interconnection - {LOTOS} - {A} formal description technique based on the temporal ordering of observational behavior" + "1989" "February" + "ISO" + + + "CafeOBJ-Project" + "Proceedings of the {CafeOBJ} Symposium'98, Numazu, Japan" + "1998" "April" + + "ITU-T" + + "Recommendation {X}.903 | {ISO}/{IEC} International Standard 10746--3: ``{ODP} Reference Model: Prescriptive Model''" + "1995" "ISO" + + "K. Ohmaki" + "K. Futatsugi" "K. Takahashi" + "A Basic {LOTOS} Simulator in {OBJ}" + + "Proceedings of the International Conference of Information Technology Commemorating the 30th Anniversary of the Information Processing Society of Japan (InfoJapan'90)" + "IPSJ" "1990" + "October" "497-504" + + + "Stanley Peters" + "An architecture and a language for software agents communicating to solve problems cooperatively" + "1992" "In preparation" + + "Wesley Phoa" + "Using fibrations to understand subtypes" "1992" + + "To appear in M. Fourman, P. Johnstone, and A. Pitts (eds.) {it Proc. Symp. on Applications of Categories in Computer Science, Durham, 1991}, Cambridge University Press" + + "J. R. B. Cockett" + "R. A. G. Seely" + "Weakly distributive categories" "1992" + "M. Fourman" "P. Johnstone" + "A. Pitts" + "Proc. Symp. on Applications of Categories in Computer Science, Durham, 1991" + "Cambridge University Press" + "45-65" + + + "Pierre-Louis Curien" "Giorgio Ghelli" + "Coherence and Subsumption" + "1991" + "To appear in {it Mathematical Structures in Computer Science}" + + "Egidio Astesiano" + "Gianna Reggio" + "Algebraic Specification of Concurrency" "1992" + + "To appear in {it Proceedings of the ADT'91 Workshop}, Springer LNCS" + + "Jonathan Ginzburg" + "Embedding questions: {Facts} and questions" + "1992" "In preparation" + + + "R. Burstall" "R. Diaconescu" + "Hiding and Behaviour: An Institutional Approach" + + "Laboratory for Foundations of Computer Science, University of Edinburgh" + "1992" + "ECS-LFCS-92-253" "December" + + + "M. Wirsing" "F. Nickl" + "U. Lechner" + "Concurrent object-oriented design specification in {SPECTRUM}" + + "Institut f{\"u}r Informatik, Universit{\"a}t M{\"u}nchen" + "1995" + + + "P. Kosiuczenko" "M. Wirsing" + + "Timed rewriting logic with application to object-oriented specification" + + "Institut f{\"u}r Informatik, Universit{\"a}t M{\"u}nchen" + "1995" + + + "Johan Lilius" "Sheaf semantics for {P}etri nets" + "1992" + "To appear as Technical report, Helsinki University of Technology" + + "William Tracz" + "Formal specification of parameterized programs in {LILEANNA}" + "1993" + "Manuscript, Version 7.0" + + + "Kristen Nygaard" + "Basic concepts in object-oriented programming" + "1986" + "Lecture and paper delivered at the Object-Oriented Programming Workshop held at Yorktwon Heights, New Yor, June 9-13, 1986; abstract in {it Sigplan Notices}, 21, No. 10, page 187, October 1986" + + + "Lincoln Wallen" + "A constructive interpretation of proof search" + "1992" "To appear" + + + "Han Yan" "Joseph Goguen" + "Tom Kemp" + "Proving properties of partial functions with sort constraints" + "1992" "To appear" + + "Joseph Goguen" + "Algebraic semantics for the object paradigm" + "1992" "To appear" + + + "Ru{a}zvan Diaconescu" + "Joseph Goguen" "Petros Stefaneas" + "Logical support for modularisation" + "1992" + "To appear, {em Proceedings/} of Workshop on Logical Frameworks (Edinburgh, Scotland, May 1991)" + + "J. Hardy" + "B. Hasslacher" + "Y. Pomeau" + "Lattice Gas Automata for the {Navier-Stokes} Equation" + "Physical Review Letters" "56" + "1986" "1505" + + + "{HOT} Chips {III}" "HOT Chips" + + "Record of Symposium held at Stanford University August 26--27, 1991" + "1991" "IEEE" + + + "Ulrich Schmidt" "Knut Caesar" + + "Datawave: {A} Single-Chip Multiprocessor for Video Applications" + "IEEE Micro" + "{IEEE} Computer Society" "11" + "3" "22-25" + "June" "1991" + + "Patrick Hayes" + "The second naive physics manifesto" + "Readings in Knowledge Representation" + "Ronald Brachman" "Hector Levesque" + "467-485" "1985" + "Morgan Kaufmann" + + + "Nancy Lynch" "Distributed Algorithms" + "1996" + "Morgan Kaufmann" "S. Borkar" + "R. Cohn" "G. Cox" + "H. T. Kung" "M. Lam" + "B. Moore" "C. Peterson" + "J. Pieper" "L. Rankin" + "P. S. Tseng" + "J. Sutton" "J. Urbanski" + "J. Webb" + "{iWARP}: an integrated solution to high-speed parallel computing" + "Proceedings of Supercomputing '88" + "IEEE Press" + "330-339" "1988" + + "H. Aida" + "J. Goguen" + "S. Leinwand" "P. Lincoln" + "J. Meseguer" "B. Taheri" + "T. Winkler" + "Simulation and Performance Estimation for the Rewrite Rule Machine" + + "Proceedings of the Fourth Symposium on the Frontiers of Massively Parallel Computation" + "336-344" "1992" + "IEEE" + + "G. Bracha" + "G. Lindstrom" + "Modularity meets inheritance" + "Proceedings of the International Conference on Computer Languages" + "282-290" "1992" + "IEEE" + + "D. Decouchant" + "P. Le Dot" + "M. Riveill" "C. Roisin" + "X. Rousett de Pina" + "A synchronization mechanism for an object-oriented distributed system" + + "Proceedings of the Eleventh International Conference on Distributed Computing Systems" + "152-159" "1991" + "IEEE" + + "Joseph Goguen" + "Jos'e Meseguer" + "Security policies and security models" + "Proceedings of the 1982 Symposium on Security and Privacy" + "11-20" "1982" + "IEEE" + + "Joseph Goguen" + "Jos'e Meseguer" + "Unwinding and inference control" + "Proceedings of the 1984 Symposium on Security and Privacy" + "75-86" "1984" + "IEEE" + + "Denis Caromel" + + "Concurrency and reusability: from sequential to parallel" + "Journal of Object-Oriented Programming" + "1990" "September/October" + + "34-42" "C. Weems" + "E. Riseman" + "A. Hamson" + "The {DARPA} Image Understanding Benchmark for Parallel Computers" + "Journal of Parallel and Distributed Computing" + "1991" "11" + "1" "1-24" + + + "R. Davis" "R. G. Smith" + + "Negotiation as a metaphor for distributed problem solving" + "Artificial Intelligence" "1983" + "20" "1" + + "63-109" "M. Wand" + "D. P. Friedman" + "The mystery of the tower revealed: a non-reflective description of the reflective tower" + "Lisp and Symbolic Computation" + "1988" "1" + "1" "11-38" + + "Christoph Walther" + + "A mechanical solution to {Schubert's} steamroller by many-sorted resolution" + "Artificial Intelligence" + "1985" "26" + "2" "217-224" + + "John Hayes" + "Trevor Mudge" + "Hypercube supercomputers" + "Proceedings of the IEEE" "1989" + "77" "12" + "1829-1841" + "Nils Nilsson" + "Logic and artificial intelligence" + "Artificial Intelligence" "1991" + "47" "31-56" + + "Jos'{e} Meseguer" + "Ugo Montanari" "Petri Nets Are Monoids" + "Information and Computation" + "1990" "88" + "105-155" + "Andrea Asperti" + "Simone Martini" + "Categorical models of polymorphism" + "Information and Computation" "1992" + "99" "1-79" + + + "David Mac{Queen}" + "Modules for Standard {ML}" "Polymorphism" + "1985" "2" + "2" "October" + + "Earlier version appeared in Proc. 1984 ACM Symp. on Lisp and Functional Programming" + + "L. Moss" + "J. Meseguer" + "J. A. Goguen" + "Final Algebras, Cosemicomputable Algebras, and Degrees of Unsolvability" + "Theoretical Computer Science" + "1992" "100" + "267-302" + "Ehud Shapiro" + "Akikazu Takeuchi" + "Object oriented programming in concurrent {Prolog}" + "New Generation Computing" "1983" + "1" "25-48" + + + "M. Nigam" "S. Sahni" + "D. Shetti" "J. R. Slagle" + "Allocation of Weapons to Targets" + "Computer Science Department, University of Minnesota" + + "Joseph Goguen" + "Hyperprogramming: a formal approach to software environments" + + "In Proc. 1990 Symp. on Formal Methods in Software Development, Tokyo, Japan" + + "Fernand Bedard" + "Private communication" "1990" + "December" + + + "Sansom Abramsky" + "Computational Interpretations of Linear Logic" + "Imperial College, October 1990" + + + "Zohar Manna" "Amir Pnueli" + "The {Temporal} {Logic} of {Reactive} {Systems}" + "To be published by Springer-Verlag" + + + "Egidio Astesiano" + "Alessandro Giovini" "Gianna Reggio" + "Observational structures and their logics" + "To appear in {it Theoretical Computer Science}" + + "Steven Bloom" + "Varieties of Ordered Algebras" + "Journal of Computer and System Sciences" "13" + "200-212" "1976" + + + "Joseph Goguen" "Jos'{e} Meseguer" + + "Correctness of recursive parallel nondeterministic flow programs" + "Journal of Computer and System Sciences" + "27" "268-290" + "1983" + + + "Peter Wegner" + "Concepts and Paradigms of Object-Oriented Programming" + "OOPS Messenger" "1" + "7-87" "1990" + + + "Bruno Courcelle" + "Infinite trees in normal form and recursive equations having a unique solution" + "Mathematical Systems Theory" + "13" "131-180" + + "1979" + "Varieties of Chain-Complete Algebras" + "Jos'e Meseguer" "1980" + "Journal of Pure and Applied Algebra" "19" + "347-383" + + + "A mathematical approach to nondeterminism in data types" + "W. H. Hesselink" "1988" + "ACM Trans. Prog. Lang. and Sys." + "10" "87-117" + + + "A formal basis for architectural connection" + "R. Allen" "D. Garlan" + "1997" "July" + "ACM Trans. Soft. Eng. and Meth." + + + "A {Birkhoff}-like Theorem for Algebraic Classes of Interpretations of Program Schemes" + "Jos'e Meseguer" "1981" + "Formalization of Programming Concepts" + "Springer-Verlag" + "152-168" "J. Diaz" + "I. Ramos" "LNCS, Volume 107" + + + "Parallel Programming in {Maude}" + "Jos'{e} Meseguer" "Timothy Winkler" + "1992" + "Research Directions in High-level Parallel Programming Languages" + "Springer LNCS 574" + "253-293" "J.-P. Ban^{a}tre" + "D. Le M`{e}tayer" + "Also Technical Report SRI-CSL-91-08, SRI International, Computer Science Laboratory, November 1991" + + + + "A logic programming language with lambda-abstraction, function variables, and simple unification" + "Dale Miller" "1990" + "Extensions of Logic Programming" + "Springer-Verlag" + "253-281" "P. Schroeder-Heister" + "LNCS, Volume 475" + + + "Temporal Logic" "Johan van Benthem" + + "Handbook of Logic in Artificial Intelligence and Logic Programming" + "Oxford University Press" + "D. Gabbay" "C. Hogger" + "J. Robinson" + "To appear" + "Modal and Temporal Logics" + "Colin Stirling" + "Handbook of Logic in Computer Science" + "Oxford University Press" "S. Abramsky" + "D. Gabbay" + "T. Maibaum" "To appear" + + "Concurrent Architectures" + "Charles L. Seitz" "1990" + "{VLSI} and Parallel Computation" + "Morgan Kaufmann" "1-84" + "R. Suaya" + "G. Birtwistle" + "Network and processor architecture for message-driven computers" + "William Dally" "1990" + "{VLSI} and Parallel Computation" + "Morgan Kaufmann" + "140-222" "R. Suaya" + "G. Birtwistle" + + + "On undecidable propositions of formal mathematical systems" + "K. {G\"odel}" "1965" + "The Undecidable" + "Raven Press" "39-74" + "Martin Davis" + + + "Algebraic Semantics" "Irene Guessarian" + "1981" + "Springer-Verlag" "LNCS, Volume 99" + + + "Past, Present, Parallel: {A} survey of Available Computing Systems" + "Arthur Trew" + "Greg Wilson" "1991" + "Springer-Verlag" + + "Fundamentals of Algebraic Specification 1" + "Hartmut Ehrig" "Bernd Mahr" + "1985" "Springer-Verlag" + + + "Readings in Knowledge Representation" + "Ronald Brachman" "Hector Levesque" + "1985" + "Morgan Kaufmann" + + "Formal Structures for Computation and Deduction" + "G. Huet" "1986" + "INRIA" + "Combinatory reduction systems" + "J. W. Klop" "1980" + "Mathematisch Centrum, Amsterdam" + + + "The Algebraic Semantics of Recursive Program Schemes" + "Bruno Courcelle" + "Maurice Nivat" "1978" + "16-30" + "Proceedings, Mathematical Foundations of Computer Science" + "LNCS, Volume 64" + "Springer-Verlag" + + + "On order-complete universal algebra and enriched functorial semantics" + "Jos'e Meseguer" "1977" + + "Proceedings, Foundations of Computation Theory" + "Marek Karpi'nski" "LNCS, Volume 56" + "294-301" + "Springer-Verlag" + + + "R. Jagannathan" "A. A. Faustini" + "The {GLU} Programming Language" "1990" + "November" + "SRI-CSL-90-11" + "SRI International, Computer Science Laboratory" + + + "Gert Smolka" "Martin Henz" + "J{\"{o}}rg W{\"{u}}rtz" + "Object-oriented concurrent constraint programming in {Oz}" + "1993" "April" + "RR-93-16" + "DFKI, Saarbr{\"{u}}cken" + + "Kim Bruce" + + "A paradigmatic object-oriented programming language: design, static typing and semantics" + "1992" "January" + "CS-92-01" + "Williams College" + + + "Joseph Goguen" "Order Sorted Algebra" + "1978" + "Semantics and Theory of Computation Report 14" + "UCLA" + + + "Douglas R. Smith" + "Constructing Specification Morphisms" "1992" + "January" "KES.U.92.1" + "Kestrel Institute" + + "Paul Hudak" + "Report on the Programming Language {Haskell}" + "1990" "April" + "Computing Science Department, University of Glasgow" + + "C. Talcott" + "A theory of binding structures and applications to rewriting" + "1991" "October" + "Computer Science Department, Stanford University" + + "G. Wiederhold" + "P. Wegner" "S. Ceri" + "Towards {Megaprogramming}" "1990" + "October" + "STAN-CS-90-1341" + "Computer Science Department, Stanford University" + + + "F. Giunchiglia" "C. L. Pecchiari" + "C. Talcott" + "Reasonig theories: towards an architecture for open mechanized reasoning systems" + "1994" "November" + "9409-15" + "IRST, University of Trento" + "Also in {em Workshop on Frontiers of Combining Systems, FROCOS'96, 1996}" + + "Jos'{e} Meseguer" + "Rewriting as a Unified Model of Concurrency" + "1990" "February" + "SRI-CSL-90-02" + "SRI International, Computer Science Laboratory" + "Revised June 1990" + + + "Thinking Machines Corporation" + "Connection Machine Technical Summary" "1990" + + "Shigeru Watari" + "Shinji Kono" "Ei-ichi Osawa" + "Rik Smoody" + "Mario Tokoro" + "Extending object-oriented systems to support dialectic worldviews" + "1989" + "Sony Computer Science Laboratory, Tokyo" + "Presented at the Advanced Database System Symposium, Kyoto, December 1989" + + "S. Matsuoka" + "K. Wakita" "A. Yonezawa" + + "Inheritance anomaly in object-oriented concurrent programming languages" + "1991" "January" + + "University of Tokyo, Dept. of Information Science" + + "Jos'e Meseguer" + "Ugo Montanari" + "Vladimiro Sassone" + "Process versus unfolding semantics for {Place/Transition} {Petri} nets" + "Theoretical Computer Science" + "153" "1--2" + "171-210" "1996" + + "R. Alur" + "C. Courcoubetis" + "N. Halbwachs" "T. A. Henzinger" + "P.-H. Ho" "X. Nicollin" + "A. Olivero" + "J. Sifakis" "S. Yovine" + "The algorithmic analysis of hybrid systems" + "Theoretical Computer Science" + "138" "3-34" "1995" + + + "The Chemical Abstract Machine" + "{G'{e}rard Berry" "G'{e}rard Boudol}" + "Proc. POPL'90" + "ACM" "81-94" + + "1990" "G'{e}rard Berry" + "G'{e}rard Boudol" + "The Chemical Abstract Machine" + "Theoretical Computer Science" "96" + "1" "217-248" + "1992" + + "Jos'{e} Meseguer" + "Conditional Rewriting Logic as a Unified Model of Concurrency" + "Theoretical Computer Science" + "96" "1" + "73-155" "1992" + + "Maura Cerioli" + "Jos'e Meseguer" + "May {I} borrow your logic? ({Transporting} logical structure along maps)" + "Theoretical Computer Science" + "173" "311-347" + + "1997" "E. Best" + "R. Devillers" + "Sequential and concurrent behavior in {Petri} net theory" + "Theoretical Computer Science" + "55" "87-136" "1989" + + + "Gerard Huet" + "A unification algorithm for typed lambda calculus" + "Theoretical Computer Science" + "1" "1" "27-57" + "1973" + + "Eric Badouel" + + "Conditional rewrite rules as an algebraic semantics of processes" + "1990" "May" + "1226" "INRIA" + + "Gilles Dowek" + "Amy Felty" "Hugo Herberlin" + "G'erard Huet" + "Christine Paulin-Mohring" "Benjamin Werner" + "The {Coq} proof assistant user's guide" + "1991" "December" + "Rapport Technique 134" + "INRIA" + + + "P. Degano" "J. Meseguer" + "U. Montanari" + "Axiomatizing the Algebra of Net Computations and Processes" + "1990" "November" + "SRI-CSL-90-12" + "SRI International, Computer Science Laboratory" + "To appear in {em Acta Informatica}" + + "C. L. Seitz" + "J. Seizovic" + "W.-K. Su" + "The {C} Programmer's Abbreviated Guide to Multicomputer Programming" + "1988" "January" + "CS-TR-88-1" + "California Institute of Technology" + "Revised April 1989" "Jos'{e} Meseguer" + + "Conditional rewriting logic: deduction, models and concurrency" + + "In S. Kaplan and M. Okada (eds.) {it Proc. CTRS'90}, Montreal, Canada, 1990, Springer LNCS 516, pp. 64-91, 1991" + + "Patrick Lincoln" + "Narciso Mart'{i}-Oliet" + "Jos'{e} Meseguer" + "Maude: Making parallel programming machine-independent" + "Submitted for publication" + + + "Jos'{e} Meseguer" + "Conditional rewriting logic: deduction, models and concurrency" + "This volume" + + "P. M. Sewell" + + "Cell machine correctness via parallel jungle rewriting" + "1990" + "MSc Thesis, Programming Research Group, University of Oxford" + + "K. Ohmaki" "K. Futatsugi" + "K. Takahashi" + "A Basic {LOTOS} simulator in {OBJ}" "1990" + "March" "TR-90-11" + "ETL" + + + "H. Hussmann" + "Nondeterministic algebraic specifications and nonconfluent term rewriting" + "Computer Science Dept., TU Munich" + + + "Keith Devlin" + "Logic and Information" "Book to appear" + + + "J. Engelfriet" "G. Leih" + "G. Rozenberg" + "Parallel Object-Based Systems and {Petri} Nets, {I} and {II}" + "1990" "February" + "90-04,90-05" + "Dept. of Computer Science, University of Leiden" + + "J. Engelfriet" + "G. Leih" "G. Rozenberg" + + "Net-based description of parallel object-based systems, or {POT}s and {POP}s" + + "Foundations of Object-Oriented Languages, Noordwijkerhout, The Netherlands, May/June 1990" + "J. W. de Bakker" + "W. P. de Roever" "G. Rozenberg" + "1991" "Springer LNCS 489" + "229-273" + + "Sverker Janson" "Seif Haridi" + + "Programming paradigms of the {Andorra} kernel language" + "1991" + "Proc. 1991 Intl. Symp. on Logic Programming" + "V. Saraswat" "K. Ueda" + "MIT Press" "167-186" + + "Jos'e Meseguer" + "Multiparadigm Logic Programming" + "Proc. 3rd Intl. Conf. on Algebraic and Logic Programming" + "H. Kirchner" + "G. Levi" "1992" + "Springer LNCS 632" "158-200" + + + "Jos'e Meseguer" "Kokichi Futatsugi" + "Timothy Winkler" + "Using Rewriting Logic to Specify, Program, Integrate, and Reuse Open Concurrent Systems of Cooperating Agents" + "1992" + "Proceedings of the 1992 International Symposium on New Models for Software Architecture, Tokyo, Japan, November 1992" + + "Research Institute of Software Engineering" + "61-106" + "Sven Frolund" + + "Inheritance of Synchronization Constraints in Concurrent Object-Oriented Programming Languages" + "Proc. ECOOP'92" + "O. Lehrmann Madsen" "1992" + "Springer LNCS 615" "185-196" + + + "Jos'e Meseguer" + "Solving the Inheritance Anomaly in Concurrent Object-Oriented Programming" + "Proc. ECOOP'93" + "Oscar M. Nierstrasz" "1993" + "Springer LNCS 707" "220-246" + + "Christian Neusius" + "Synchronizing Actions" + "Proc. ECOOP'91" "Pierre America" + "1991" + "Springer LNCS 512" "118-132" + + "Pierre America" + "Synchronizing Actions" + "Proc. ECOOP'87" "1987" + "Springer LNCS 276" "234-242" + + "Dennis Kafura" + "Keung Lee" + "Inheritance in actor based concurrent object oriented languages" + "Proc. ECOOP'89" + "1989" "Cambridge University Press" + "131-145" + + "David Maier" + "A Logic for Objects" + "Proc. Workshop on Foundations of Deductive Databases and Logic Programming, Washington, D.C." + "1986" "6-26" + + + "Joseph Goguen" + "Merged Views, Closed Worlds, and Ordered Sorts: Some Novel Database Features in {OBJ}" + "Proc. 1982 Workshop on Database Interfaces" + "Alex Borgida" + "Peter Buneman" "1985" + "University of Pennsylvania, Computer Science Department" + "38-47" + + "M. Atkinson" + "P. Richard" + "P. Trinder" + "Bulk types for large scale programming" + "Proc. Next Generation Information System Technology" + "1991" "Springer LNCS 504" + "228-250" + + "V. Breazu-Tannen" + "R. Subrahmanyam" + "Logical and computational aspects of programming with sets/bags/lists" + "Proc. ICALP'91" + "1991" "Springer LNCS 510" + "60-75" + + "P. Degano" + "C. Priami" + "Proved trees" "Proc. ICALP'92" + "1992" + "Springer LNCS 623" "629-640" + + + "I. Mason" "C. Talcott" + "A semantics preserving actor translation" + "Proc. ICALP'97" + "1997" "Springer LNCS 1256" + "369-378" + + + "I. Mason" "C. Talcott" + + "Simple Network Protocol Simulation within {Maude}" + "May 2000" "Submitted for publication" + + + "C. Hintermeier" "C. Kirchner" + "H. Kirchner" + "Dynamically-typed computations for order-sorted equational presentations" + "Proc. ICALP'94" + "1994" "Springer LNCS 510" + "60-75" + + "Hans-Dieter Ehrich" + "Joseph Goguen" + "Am'{i}lcar Sernadas" + "A categorical theory of objects a observed processes" + + "Foundations of Object-Oriented Languages, Noordwijkerhout, The Netherlands, May/June 1990" + "J. W. de Bakker" + "W. P. de Roever" "G. Rozenberg" + "1991" "Springer LNCS 489" + "203-228" + + "J. Fiadeiro" + "A. Sernadas" + "Structuring Theories on Consequence" + "D. Sannella" "A. Tarlecki" + "Recent Trends in Data Type Specification" + "1988" "Springer LNCS 332" + "44-72" + + "J. R. Slagle" + "R. R. Cantone" + "E. J. Halpern" + "Battle, an expert decision aid for fire support command and control" + "Proceedings 49th MORS" + "1982" "35-38" + + + "J. Engelfriet" "G. Leih" + "G. Rozenberg" + "Parallel Object-Based Systems and {Petri} Nets. {Part} {I}: Basic Notions, Reference Passing and Handshaking" + "1990" "February" + "90-04" + "Dept. of Computer Science, University of Leiden" + + + "C. Hintermeier" "C. Kirchner" + "H. Kirchner" + "Dynamically-typed computations for order-sorted equational presentations" + "1994" "March" + "2208" "INRIA" + + + "J. Engelfriet" "G. Leih" + "G. Rozenberg" + "Parallel Object-Based Systems and {Petri} Nets. {Part} {II}: Actor Systems, Dangling References and Semantics" + "1990" "February" + "90-05" + "Dept. of Computer Science, University of Leiden" + + "Peter Mosses" + "Unified Algebras and Institutions" + "1989" + "Computer Science Department, Aarhus University" + "DAIMI PB-274" + + + "Peter Mosses" + "Unified Algebras and Institutions" "1989" + + "Computer Science Department, Aarhus University" + "DAIMI PB-274" + + + "J. A. Goguen" "S. Leinwand" + "J. Meseguer" "T. Winkler" + "The Rewrite Rule Machine, 1988" + "1989" + "Oxford University, Programming Research Group" + "PRG-76" + + + "Categorical Foundations for General Systems Theory" + "Joseph Goguen" + "Advances in Cybernetics and Systems Research" + "F. Pichler" "R. Trappl" + "1973" + "Transcripta Books" "121-130" + + + + "Confluent Reductions: Abstract Properties and Applications to Term Rewriting Systems" + "Gerard Huet" + "Journal of the Association for Computing Machinery" + "27" "797-821" + "1980" + "Preliminary version in {it 18th Symposium on Mathematical Foundations of Computer Science}, 1977" + + + "The Family of Concurrent Logic Programming Languages" + "E. Shapiro" + "ACM Computing Surveys" "21" + "413-510" "1989" + + + "Programming Languages for Distributed Computing Systems" + "H. Bal" "J. Steiner" + "A. Tanenbaum" + "ACM Computing Surveys" "21" + "261-322" "1989" + + + "Subequalizers" "J. Lambek" + "Canadian Math. Bull." "13" + "337-349" "1970" + + "Rewrite Systems" + "N. Dershowitz" "J.-P. Jouannaud" + + "Handbook of Theoretical Computer Science, Vol. B" + "1990" "J. van Leeuwen" + "243-320" "North-Holland" + + + "Graph rewriting: an algebraic and logic approach" + "B. Courcelle" + "Handbook of Theoretical Computer Science, Vol. B" + "1990" "J. van Leeuwen" + "193-242" "North-Holland" + + "The incompleteness theorems" + "C. Smorynski" + "Handbook of Mathematical Logic" "1977" + "J. Barwise" "821-865" + "North-Holland" + + + "{OBJ} as a Theorem Prover with Application to Hardware Verification" + "Joseph Goguen" + "Current Trends in Hardware Verification and Automated Theorem Proving" + "P. S. Subramanyam" + "G. Birtwistle" "1989" + "Springer-Verlag" "218-267" + + "Objects" "Joseph Goguen" + "International Journal of General Systems" + "1" "4" + "1975" "237-243" + + + "General Recursive Functions of Natural Numbers" + "Stephen C. Kleene" "Mathematische Annalen" + "112" "5" + "1936" "727-742" + + + "$lambda$-definability and recursiveness" + "Stephen C. Kleene" + "Duke Math. J." "2" + "1936" "340-353" + + + "Principles of Parameterized Programming" + "Joseph Goguen" + "Software Reusability, Volume {I}: Concepts and Models" + "Ted Biggerstaff" "Alan Perlis" + "Addison-Wesley" + "1989" "159-225" + + + "Applications of Algebraic Specification Using {OBJ}" + "Joseph Goguen" + "Cambridge University Press" "1993" + + + "Graph Grammars and their Application to Computer Science" + "H. Ehrig" "H.-J. Kreowski" + "G. Rozenberg" + "Springer LNCS 532" "1991" + + + "J.-C. Raoult" "F. Voisin" + "Set-theoretic graph rewriting" + "Graph Transformations in Computer Science" + "H.-J. Schneider" "H. Ehrig" + "312-325" "Springer LNCS 776" + "1994" + + + "Graph Transformations in Computer Science" + "H.-J. Schneider" "H. Ehrig" + "Springer LNCS 776" "1994" + + "Term Graph Rewriting" + "M. R. Sleep" "M. J. Plasmeijer" + "M. C. J. D. van Eekelen" + "Wiley" "1993" + + + "The Logic of Typed Feature Structures" + "Bob Carpenter" "Cambridge University Press" + "1992" + + + "A. Yonezawa" "M. Tokoro" + "Object-Oriented Concurrent Programming" + "MIT Press" "1988" + + + "Valentin F. Turchin" + "Refal-5: programming guide and reference manual" + "New England Publishing Co." + "1989" + + "Brian Smith" "Akinori Yonezawa" + + "Proc. of the {IMSA}'92 International Workshop on Reflection and Meta-Level Architecture, Tokyo, November 1992" + "Research Institute of Software Engineering" + "1992" + + + "M. Tokoro" "O. Nierstrasz" + "P. Wegner" + "Object-Based Concurrent Computing" + "Springer LNCS 612" "1992" + + + "A. Bond" "L. Gasser" + "Readings in Distributed Artificial Intelligence" + "Morgan Kaufmann" "1988" + + + "G. Saake" "A. Sernadas" + + "Information Systems---Correctness and Reusability" + + "Technische Universit{\"{a}}t Braunschweig, Information-Berichte 91-03" + "1991" + + "R. Junglclaus" + "G. Saake" + "T. Hartmann" "C. Sernadas" + + "Object-oriented specification of information systems: the {TROLL} language" + + "Technische Universit{\"{a}}t Braunschweig, Information-Berichte 91-04" + "1991" + + "W. Hillis" + "The Connection Machine" + "MIT Press" "1985" + + + "P. M. Hill" "J. W. Lloyd" + "The {G\"odel} Programming Language" + "MIT Press" "1994" + + + "Gregor Kiczales" + "Jim des Rivieres" "Daniel G. Bobrow" + "The Art of the Metaobject Protocol" + "MIT Press" "1991" + + + "V. Madisetti" "D. Nicol" + "R. Fujimoto" + "Advances in Parallel and Distributed Simulation" + "Society for Computer Simulation" + + "1990" "R. K. Ege" + "Object-oriented Simulation" + "Society for Computer Simulation" "1990" + + + "Proc. Workshop on graph reduction, Santa Fe, New Mexico" + "1987" "R. Keller" + "J. Fasel" + "Springer LNCS 279" + + "Proceedings, Conference on Conditional Term Rewriting, Orsay, France, July 8-10, 1987" + "Jean-Pierre Jouannaud" + "Stephane Kaplan" + "Springer-Verlag, LNCS No. 308" "1988" + + + "The Situation in Logic" "The situation in logic" + + "Center for the Study of Language and Information" + "CSLI Lecture Notes No. 17" "1989" + + + "Concurrent Programming Using Actors" "G. Agha" + "C. Hewitt" + "Object-Oriented Concurrent Programming" + "A. Yonezawa" "M. Tokoro" + "MIT Press" "37-53" + "1988" + + + "Concurrent object-oriented programming in {Act 1}" + "Henry Lieberman" + "Object-Oriented Concurrent Programming" + "A. Yonezawa" "M. Tokoro" + "MIT Press" "9-36" + "1988" + + + "{POOL-T}: {A} parallel object-oriented language" + "Pierre America" + "Object-Oriented Concurrent Programming" + "A. Yonezawa" "M. Tokoro" + "MIT Press" "199-220" + "1988" + + + "Semantic Specifications for the Rewrite Rule Machine" + "J. A. Goguen" + "Concurrency: Theory, Language and Architecture" + "A. Yonezawa" "W. {Mc}{Coll}" + "T. Ito" "216-234" + "Springer LNCS, Vol. 491" + + "1990" "G. Agha" "Actors" + "MIT Press" "1986" + + + "A. Chien" "Concurrent Aggregates" + "MIT Press" "1993" + + "K. Mani Chandy" "Jayadev Misra" + "Parallel Program Design: {A} Foundation" + "Addison-Wesley" + "1988" + "I. Jacobson" + "M. Christerson" + "P. Jonsson" "G. {\"O}vergaard" + "Object-Oriented Software Engineering" + "Addison-Wesley" "1993" + + + "M. Fowler" "K. Scott" + "{UML} Distilled" + "Addison-Wesley" "1997" + + + "M. Shaw" "D. Garlan" + "Software Architecture" "Prentice Hall" + "1996" + + + "K. Mani Chandy" "Stephen Taylor" + "An Introduction to Parallel Programming" + "Jones and Bartlett Publishers" + "1992" + "H. P. Barendregt" + + "{The} {Lambda} {Calculus}, its {Syntax} and {Semantics}" + "North-Holland" "1984" + + + "H. B. Curry" "R. Feys" + "Combinatory Logic" + "North-Holland" "1968" + + + "A. D. Goldberg" "D. Robson" + "Smalltalk80: The Language and its Implementation" + "Addison-Wesley" "1983" + + "Jos'{e} Meseguer" + "General Logics" + "Logic Colloquium'87" "1989" + "H.-D. Ebbinghaus et al." + "North-Holland" "275-329" + + "S. Holmstrom" + "A Linear Functional Language" + "Workshop on Implementation of Lazy Functional Languages" + "1988" "T. Johnsson" + "S. Peyton-Jones" + "K. Karlsson" + "Univ. of G{\"{o}}teborg and Chalmers University of Technology" + "13-32" + + "Philip Wadler" + "Is there a use for linear logic?" + + "ACM/IFIP Symposium on Partial Evaluation and Semantic Based Program Manipulation" + "1991" "ACM" + + "Catriel Beeri" + "New Data Models and Languages---the Challenge" + + "Proc. 11th Symposium on Principles of Database Systems" + "1992" "1-15" + "ACM" + + + "Catriel Beeri" "Tova Milo" + "Functional and Predicative Programming in {OODB}'s" + + "Proc. 11th Symposium on Principles of Database Systems" + "1992" "176-190" + "ACM" + + "Andrea Corradini" + "Ugo Montanari" + "An algebraic semantics of logic programs as structured transition systems" + "S. Debray" + "M. Hermenegildo" + "North American Conference on Logic Programming" + "788-812" "1990" + "MIT Press" + + + "H. Hussmann" + "Unification in conditional equational theories" + "Proc. {EUROCAL} 2" + "B. F. Caviness" "Springer LNCS, Vol. 204" + "1985" "543-553" + + + "Michael J. O'Donnell" + "Survey of the Equational Logic Programming Project" + "Resolution of Equations in Algebraic Structures" + "1987" "Maurice Nivat" + "Hassan A{\"{}i}t-Kaci" + "MCC Corporation" + "Preliminary Proceedings" + + + "J. Darlington" "M. J. Reeve" + + "Alice: {A} Multiprocessor Reduction Machine for the Parallel Evaluation of Applicative Languages" + + "ACM Conference on Functional Programming Languages and Computer Architecture" + "1981" "ACM" + + "John Hughes" + "Super-combinators: a new implementation method for applicative languages" + "1-10" + "ACM Symposium on Lisp and Functional Programming" + "1982" "ACM" + + "Jos'{e} Meseguer" + "A Logical Theory of Concurrent Objects" + + "{ECOOP-OOPSLA'90} Conference on Object-Oriented Programming, Ottawa, Canada, October 1990" + "101-115" "1990" + "ACM" + + + "Jean-Marc Andreoli" "Remo Pareschi" + + "{LO} and behold! {Concurrent} structured processes" + + "{ECOOP-OOPSLA'90} Conference on Object-Oriented Programming, Ottawa, Canada, October 1990" + "44-56" "1990" + "ACM" + + + "Jean-Marc Andreoli" "Remo Pareschi" + "Communication as fair distribution of knowledge" + + "{OOPSLA'91} Conference on Object-Oriented Programming, Phoenix, Arizona, October 1991" + "212-229" "1991" + "ACM" + + + "Yutaka Ishikawa" + "Communication Mechanism on Autonomous Objects" + "{OOPSLA'92} Conference on Object-Oriented Programming" + "303-314" "1992" + "ACM" + + + "Chris Tomlinson" "Vineet Singh" + + "Inheritance and Synchronization with Enabled Sets" + "{OOPSLA'89} Conference on Object-Oriented Programming" + "103-112" "1989" + "ACM" + + + "Ken Wakita" "Akinori Yonezawa" + + "Linguistic Support for Development of Distributed Organizational Information Systems" + "Proc. {ACM COCS}" + "1991" "ACM" + + + "Etsuya Shibayama" + "Reuse of concurrent object descriptions" + "Proc. {TOOLS 3}, Sydney" "254-266" + "1990" + + + "Denis Caromel" + "Programming abstractions for concurrent programming---a solution to the explicit/implicit control dilemma" + "Proc. {TOOLS 3}, Sydney" + "245-253" "1990" + + + "Paul Bergstein" + "Object-preserving class transformations" + "{OOPSLA'91} Conference on Object-Oriented Programming, Phoenix, Arizona, October 1991" + "299-313" "1991" + "ACM" + + + "Oscar Nierstrasz" "Michael Papathomas" + + "Viewing objects as patterns of communicating agents" + + "{ECOOP-OOPSLA'90} Conference on Object-Oriented Programming, Ottawa, Canada, October 1990" + "38-43" "1990" + "ACM" + + "S. Watari" + "S. Kono" "E. Osawa" + "R. Smoody" + "M. Tokoro" + "Extending object-oriented systems to support dialectic worldviews" + + "Symposium on Advanced Database Systems, Kyoto, Japan, December 1989" + "1989" + + + "A. Yonezawa" "J.-P. Briot" + "Etsuya Shibayama" + "Object-oriented Concurrent Programming in {ABCL/1}" + + "{OOPSLA'86} Conference on Object-Oriented Programming, Portland, Oregon, September-October 1986" + "1986" "258-268" + "ACM" + + + "N. Kobayashi" "A. Yonezawa" + + "Type-theoretic foundations for concurrent object-oriented programming" + + "{OOPSLA'94} Conference on Object-Oriented Programming, Portland, Oregon, October 1994" + "1994" "31-45" + "ACM" + + "Oscar Nierstrasz" + "Active Objects in {Hybrid}" + "{OOPSLA'87} Conference on Object-Oriented Programming" + "1987" "243-253" + "ACM" + + + "Bertrand Meyer" + "Genericity versus inheritance" + "{OOPSLA'86} Conference on Object-Oriented Programming, Portland, Oregon, September-October 1986" + "1986" "391-405" + "ACM" + + + "T. Watanabe" "A. Yonezawa" + "Reflection in an Object-Oriented Concurrent Language" + + "{OOPSLA'88} Conference on Object-Oriented Programming, San Diego, California, September 1988" + "1986" "306-315" + "ACM" + + "G. Agha" + "P. Wegner" + "A. Yonezawa" + "Proceedings of the {ACM}-{SIGPLAN} Workshop on Object-Based Concurrent Programming" + "ACM Sigplan Notices, April 1989" + + "B. Kramer" + "Specifying Concurrent Objects" + "G. Agha" "P. Wegner" + "A. Yonezawa" + "Proceedings of the ACM-SIGPLAN Workshop on Object-Based Concurrent Programming" + "1989" "162-164" + "ACM" + "Sigplan Notices, April 1989" + + + "O. Nierstrasz" + "Two Models of Concurrent Objects" "G. Agha" + "P. Wegner" + "A. Yonezawa" + "Proceedings of the ACM-SIGPLAN Workshop on Object-Based Concurrent Programming" + "1989" "174-176" + "ACM" + "Sigplan Notices, April 1989" + + "R. A. G. Seely" + "Linear Logic, $\ast$-Autonomous Categories and Cofree Coalgebras" + + "Proc. AMS Summer Research Conference on Categories in Computer Science and Logic, Boulder, Colorado, June 1987" + "J. W. Gray" + "A. Scedrov" "371-382" + "AMS" "1989" + + "Nachum Dershowitz" + "David A. Plaisted" + "Equational Programming" + "Machine Intelligence 11: The logic and acquisition of knowledge" + "J. Richards" + "21-56" "Oxford University Press" + "1988" + + + "H. Reichel" + "Initial Computability, Algebraic Specifications, and Partial Algebras" + "Oxford University Press" + + "1987" + "Bengt Nordstr{\"o}m" "Kent Petersson" + "Jan Smith" + "Programming in {Martin-L\"of} Type Theory" + "Oxford University Press" "1990" + + + "A small complete category" "J. M. E. Hyland" + + "Proc. Conf. on Church's Thesis: Fifty Years Later" + "1987" + + + "A. Grothendieck" "J. L. Verdier" + "Pr'{e}fascieaux" + "Th'{e}orie de Topos et Cohomologie Etale des Sch'{e}mas, SGA4" + "1972" + "J. L. Verdier {M. Artin, A Grothendieck}" + "Springer Lecture Notes in Mathematics No. 269" + + + "P. Gabriel" "F. Ulmer" + "{Lokal} pr{\"{a}}sentierbare {Kategorien}" + "1971" + "Springer Lecture Notes in Mathematics No. 221" + + + "G. M. Kelly" "R. Street" + "Review of the elements of 2-categories" + "{Category} {Seminar}, {Sydney} 1972/73" + "1974" "75-103" + "G. M. Kelly" + "Springer Lecture Notes in Mathematics No. 420" + + "H. Volger" + "Completeness Theorem for Logical Categories" + "Model Theory and Topoi" + "1975" "F. W. Lawvere" + "C. Maurer" "G. C. Wraith" + + "Springer Lecture Notes in Mathematics No. 445" + + + "Orville Keane" + "Abstract {Horn} theories" + "Model Theory and Topoi" "1975" + "15-50" "F. W. Lawvere" + "C. Maurer" "G. C. Wraith" + + "Springer Lecture Notes in Mathematics No. 445" + + "Joachim Lambek" + "Deductive Systems and Categories {II}" + + "Category Theory, Homology Theory and their Applications I" + "1969" "76-122" + "Springer Lecture Notes in Mathematics No. 86" + + "J. W. Gray" + "Fibred and Cofibred Categories" + "Proc. Conf. Categorical Algebra, La Jolla 1965" + "1966" "S. Eilenberg" + "D. K. Harrison" "S. MacLane" + "H. R{\"{o}}hrl" + "Springer-Verlag" + + + "A. Grothendieck" + "Cat'{e}gories fibr'{e}es et descente" + "Seminaire de g'{e}om'{e}trie alg'{e}brique" + "1961" + "Institut des Hautes '{E}tudes Scientifiques" + + "H.-D. Ebbinghaus" + "Extended Logics: The General Framework" + "Model-Theoretic Logics" "1985" + "J. Barwise" + "S. Feferman" "25-76" + "Springer Verlag" + + + "Joseph Goguen" + "Higher-order functions considered unnecessary for higher-order programming" + + "Proc., University of Texas Year of Programming, Institute on Declarative Programming" + "1988" "David Turner" + + "Preliminary version as SRI Tech. Rep. SRI-CSL-88-1, January 1988" + "Addison-Wesley" + + + "J. Reynolds" "G. Plotkin" + + "On functors expressible in the polymorphic typed lambda calculus" + + "Logical Foundations of Functional Programming" + "1988" "G. Huet" + "To appear" "Addison-Wesley" + + + "G. Plotkin" + "Complete Partial Orders, a Tool for Making Meanings" + "Pisa Summer School Lecture Notes" + "1978" + + + "E. S. Bainbridge" "P. J. Freyd" + "A. Scedrov" "P. J Scott" + "Functorial Polymorphism" + "Logical Foundations of Functional Programming" + "1988" "G. Huet" + "To appear" + "Addison-Wesley" + + "G. Longo" + "E. Moggi" + "Constructive natural deduction and its ``modest'' interpretation" + "Semantics of Natural and Computer Languages" + "1988" "M. Gawron" + "D. Israel" + "J. Meseguer" "S. Peters" + "To appear" "MIT Press" + + "J. A. Goguen" + "J. Meseguer" + "Logic Programming and Situation Semantics" + "Semantics of Natural and Computer Languages" + "1988" "M. Gawron" + "D. Israel" "J. Meseguer" + "S. Peters" "To appear" + "MIT Press" + + + "J. M. E. Hyland" "The Effective Topos" + "The L.E.J. Brouwer Centenary Symposium" + "1982" + "A. S. Toelstra" "D. van Dalen" + "165-216" "North-Holland" + + "A. M. Pitts" + "Polymorphism is set theoretic, constructively" + + "Proceedings of the Summer Conference on Category Theory and Computer Science, Edinburgh, Sept. 1987" + "1987" + "Springer LNCS 283" + + + "Jos'{e} Meseguer" "Ugo Montanari" + "Vladimiro Sassone" + "On the semantics of {P}etri nets" + "Proceedings of the Concur'92 Conference, Stony Brook, New York, August 1992" + "W. R. Cleaveland" + "1992" "286-301" + "Springer LNCS 630" + + + "Jos'{e} Meseguer" + "Rewriting as a Unified Model of Concurrency" + "Proceedings of the Concur'90 Conference, Amsterdam, August 1990" + "1990" "384-400" + "Springer LNCS 458" + + + "Jos'{e} Meseguer" + "Rewriting logic as a semantic framework for concurrency: a progress report" + "Proc. CONCUR'96, Pisa, August 1996" + "U. Montanari" + "V. Sassone" "331-372" + "1996" "Springer LNCS 1119" + + + "Jos'e Meseguer" "Carolyn Talcott" + + "A partial order event model for concurrent objects" + "Proc. CONCUR'99, Eindhoven, The Netherlands, August 1999" + "J.C.M. Baaten" + "S. Mauw" "415-430" + "1999" "Springer LNCS 1664" + + + "Jos'{e} Meseguer" "Carolyn Talcott" + + "A Partial Order Event Model for Concurrent Objects" + "Proc. CONCUR'99, Eindhoven, The Netherlands, August 1999" + "J. Baeten" + "S. Mauw" "415-430" + "1999" "Springer LNCS 1664" + + "D. E. Rydeheard" + "J. G. Stell" + "Foundations of Equational Deduction: {A} Categorical Treatment of Equational Proofs and Unification Algorithms" + "114-139" + "Proceedings of the Summer Conference on Category Theory and Computer Science, Edinburgh, Sept. 1987" + "1987" + "Springer LNCS 283" + + + "H. Ehrig" + "Introduction to the Algebraic Theory of Graph Grammars" + + "Graph-Grammars and their Application to Computer Science and Biology" + "V. Claus" + "H. Ehrig" "G. Rozenberg" + "1979" "1-69" + "Springer LNCS 73" + + "L. Moss" + "J. Meseguer" + "J. A. Goguen" + "Final Algebras, Cosemicomputable Algebras, and Degrees of Unsolvability" + + "Proceedings of the Summer Conference on Category Theory and Computer Science, Edinburgh, Sept. 1987" + "1987" + "Springer LNCS 283" + "Extended version to appear in {it Theoretical Computer Science}" + + "T. Coquand" + "T. Ehrhard" + "An Equational Presentation of Higher Order Logic" + + "Proceedings of the Summer Conference on Category Theory and Computer Science, Edinburgh, Sept. 1987" + "1987" + "Springer LNCS" + + "Thomas Ehrhard" + "A categorical semantics of constructions" + + "Proceedings of the 3rd Sympossium on Logic in Computer Science, Edinburgh, July 1988" + "1988" "264-273" + "IEEE" + + "D. S. Scott" + "Models for Various Type-free Calculi" + + "Proc. 4th Intl. Congr. on Logic, Methodology and Philosophy of Science, Bucharest" + "1972" "157-187" + "North-Holland" + + "J. C. Reynolds" + "Polymorphism is Not Set-Theoretic" + "Semantics of Data Types" + "1984" "G. Kahn" + "D. B. MacQueen" "G. D. Plotkin" + "145-156" "Springer LNCS 173" + + + "R. Burstall" "B. Lampson" + "A Kernel Language for Abstract Data Types and Modules" + "Semantics of Data Types" + "1984" "G. Kahn" + "D. B. MacQueen" "G. D. Plotkin" + "1-50" + "Springer LNCS 173" + + "K. Bruce" "A. Meyer" + + "The Semantics of Second Order Polymorphic Lambda Calculus" + "Semantics of Data Types" + "1984" "G. Kahn" + "D. B. MacQueen" "G. D. Plotkin" + "131-144" "Springer LNCS 173" + + "K. L. Clark" + "Negation as Failure" + "Logic and Data Bases" "1978" + "H. Gallaire" "J. Minker" + "293-322" "Plenum" + + "J. A. Goguen" + "T. Winkler" "Introducing {OBJ3}" + + "Computer Science Laboratory, SRI International" + "SRI-CSL-88-9" "August" + + "1988" "T. Winkler" + "Numerical Computation on the {RRM}" + "Computer Science Laboratory, SRI International" + "SRI-CSL-TN88-3" + "November" "1988" + + + "H.-J. Kreowski" + "Partial Algebras Flow from Algebraic Specifications" + "FB Informatik, Univ. Bremen" + "" "August" + "1986" + + "Order-Sorted Algebra {I}: Equational Deduction for Multiple Inheritance, Overloading, Exceptions and Partial Operations" + "Joseph Goguen" + "Jos'{e} Meseguer" + "Theoretical Computer Science" "1992" + "105" "217-273" + + + + "Order-Sorted Algebra {I}: Equational Deduction for Multiple Inheritance, Overloading, Exceptions and Partial Operations" + "Joseph Goguen" + "Jos'{e} Meseguer" + "Theoretical Computer Science" "1992" + "105" "217-273" + + + "Order-Sorted Algebra Solves the Constructor-Selector, Multiple Representation and Coercion Problems" + "Jos'{e} Meseguer" + "Joseph Goguen" "Information and Computation" + "1993" "103" + "1" "114-158" + + + "Order-Sorted Algebra Solves the Constructor-Selector, Multiple Representation and Coercion Problems" + "Jos'{e} Meseguer" + "Joseph Goguen" + "To appear in {it Information and Computation}" + + + "Duality in closed and linear categories" + "Narciso Mart'i-Oliet" + "Jos'e Meseguer" + "SRI International, Computer Science Laboratory" + "1990" "February" + "SRI-CSL-90-01" + + + "Inclusions and subtypes {I}: First Order Case" + "Narciso Mart'i-Oliet" "Jos'e Meseguer" + "J. Logic and Computation" + "6" "409-438" + + "1996" + "Inclusions and subtypes {II}: Higher-Order Case" + "Narciso Mart'i-Oliet" "Jos'e Meseguer" + + "To appear in {it J. Logic and Computation}; appeared also as SRI Report SRI-CSL-90-16" + + + "Inclusions and subtypes {I}: First Order Case" + "Narciso Mart'i-Oliet" "Jos'e Meseguer" + "To appear in {it J. Logic and Computation}, 1996" + + + "Inclusions and subtypes {II}: Higher-Order Case" + "Narciso Mart'i-Oliet" "Jos'e Meseguer" + "To appear in {it J. Logic and Computation}, 1996" + + + "An Algebraic Axiomatization of Linear Logic Models" + "Narciso Mart'i-Oliet" + "Jos'e Meseguer" "G. M. Reed" + "A. W. Roscoe" "R. Wachter" + "1991" + "Topology and Category Theory in Computer Science" + "Oxford University Press" + "335-355" + "Types as theories" + "Joseph Goguen" "G. M. Reed" + "A. W. Roscoe" + "R. Wachter" "1991" + "Topology and Category Theory in Computer Science" + "Oxford University Press" + "357-390" + "On Types and {FOOPS}" + "Joseph Goguen" "David Wolfram" + + "To appear in {it Proc. IFIP Working Group 2.6 Working Conference on Database Semantics: Object-Oriented Databases: Analysis, Design and Construction, 1990}" + + + "A sheaf semantics for {FOOPS} expressions (extended abstract)" + "Joseph Goguen" + "David Wolfram" "M. Tokoro" + "O. Nierstrasz" "P. Wegner" + "Object-Based Concurrent Computing" + "Springer LNCS 612" + "81-98" "1992" + + + "Object-oriented concurrent reflective architectures" + "Satoshi Matsuoka" + "Takuo Watanabe" "Yuuji Ichisugi" + "Akinori Yonezawa" "M. Tokoro" + "O. Nierstrasz" + "P. Wegner" + "Object-Based Concurrent Computing" + "Springer LNCS 612" "211-226" + "1992" "Order-sorted algebra {II}" + "Jos'e Meseguer" + "Joseph Goguen" "In preparation" + + + "Proving and Rewriting" + "Joseph Goguen" + "In {Proc.} {Conf.} on {Algebraic} and {Logic} {Programming}, {Nancy}, {Springer} {LNCS} 463, 1990" + + "Logic programs with equational type specifications" + "Michael Hanus" + "In {Proc.} {Conf.} on {Algebraic} and {Logic} {Programming}, {Nancy}, {Springer} {LNCS} 463, 70-85, 1990" + + "The Rewrite Rule Machine" + "Joseph Goguen" + "Jos'{e} Meseguer" "Sany Leinwand" + "Timothy Winkler" "Hitoshi Aida" + + "SRI International, Computer Science Laboratory" + "1989" "March" + "SRI-CSL-89-6" + "Equational Logic Programming" + "Maarten H. van Emden" + "Keitaro Yukawa" "University of Waterloo" + "1986" "March" + "CS-86-05" + + "Standard {ML}" + "Robert Harper" + "David MacQueen" "Robin Milner" + "Dept. of Computer Science, University of Edinburgh" + "1986" + "ECS-LFCS-86-2" + + "A calculus of mobile processes {I} and {II}" + "Robin Milner" "Joachim Parrow" + "David Walker" + "Dept. of Computer Science, University of Edinburgh" + "1989" "ECS-LFCS-89-85&86" + + + "A Structural Approach to Operational Semantics" + "Gordon D. Plotkin" + "Computer Science Dept., Aarhus University" + "1981" "DAIMI FN-19" + + + "Galleries and Institutions" + "Brian H. Mayoh" + "Computer Science Dept., Aarhus University" + "1985" "DAIMI PB-191" + + + "Domain Theoretic Models of Polymorphism" + "T. Coquand" "C. Gunter" + "G. Winskel" + "Computer Laboratory, Univ. of Cambridge" + "1987" "116" + + + "Di-Domains as a Model of Polymorphism" + "T. Coquand" "C. Gunter" + "G. Winskel" + "Computer Laboratory, Univ. of Cambridge" + "1987" "107" + + + "The Semantics of Second-Order Lambda Calculus" + "K. Bruce" "A. Meyer" + "J. Mitchell" + "Lab. Computer Sci., MIT" "1985" + "to appear" "Dag Prawitz" + "Natural Deduction" + "Almqvist and Wiksell, Stockholm" "1965" + + + "Wolfgang Reisig" "Petri Nets" + "Springer-Verlag" + "1985" + + "Pierre-Louis Curien" + "Categorical Combinators, Sequential Algorithms and Functional Programming" + "Pitman, London" + "1986" + + "Michael J. O'Donnell" + "Equational Logic as a Programming Language" + "MIT Press" "1985" + + + "Robert Kowalski" "Logic for Problem Solving" + "North-Holand" + "1979" + + "Michael J. O'Donnell" + "Computing in Systems Described by Equations" + "Springer-Verlag LNCS 58" "1977" + + + "Joseph R. Shoenfield" + "Degrees of Unsolvability" "North-Holland" + "1971" + + "M. Barr" + "C. Wells" + "Toposes, Triples and Theories" + "Springer-Verlag" "1985" + + + "Peter Johnstone" "Topos Theory" + "Academic Press" "1977" + + "J. R. Hindley" + "J. P. Seldin" + "Introduction to Combinators and $lambda$-Calculus" + "Cambridge UP" "1986" + + "J. Barwise" + "S. Feferman (eds.)" + "Model-Theoretic Logics" "Springer-Verlag" + "1985" + + + "J. Lambek" "P. J. Scott" + "Introduction to Higher Order Categorical Logic" + "Cambridge Univ. Press" + + "1986" "G. M. Kelly" + "Basic Concepts of Enriched Category Theory" + "Cambridge Univ. Press" + + "1982" + "Michael J. O'Donnell" + "Equational Logic as a Programming Language" + "MIT Press" "1985" + + + "Maurice Nivat" + "On the Interpretation of Recursive Program Schemes" + "Symposia Mathematica" "1975" + "XV" "225-281" + + "Instituto di Alta Matematica, Bologna, Italy, Academic Press" + + "Glynn Winskel" + + "Petri Nets, Algebras, Morphisms and Compositionality" + "Info and Co" "1987" + "72" "197-238" + + + + "From {Petri} nets to linear logic through categories: a survey" + "Narciso Mart'i-Oliet" + "Jos'e Meseguer" "1991" + "2" "4" "297-399" + "Intl. J. of Foundations of Comp. Sci." + + "Ross Street" + "Limits Indexed by Category-Valued 2-Functors" + "J. Pure Appl. Algebra" + "1976" "8" + "149-181" + "J.-C. Raoult" + "On Graph Rewritings" + "Theoretical Computer Science" "1984" + "32" "1-24" + + + "E. W. Stark" + "Concurrent Transition Systems" + "Theoretical Computer Science" "1989" + "64" "221-269" + + + "J.-C. Raoult" "J. Vuillemin" + + "Operational and semantic equivalence between recursive programs" + "J. ACM" "1980" + "27" "772-796" + + + "Y. Lafont" + "The linear abstract machine" + "Theoretical Computer Science" "1988" + "59" "157-180" + + + "N. Dershowitz" "M. Okada" + "A rationale for conditional equational programming" + "Theoretical Computer Science" + "1990" "75" + "111-138" + "Steffen H{\"o}ldobler" + + "Conditional equational theories and complete sets of transformations" + "Theoretical Computer Science" + "1990" "75" + "85-110" + "R. Kennaway" + "On ``On Graph Rewritings''" + "Theoretical Computer Science" "1987" + "52" "37-58" + + "M. Bauderon" + "B. Courcelle" + "Graph Expressions and Graph Rewriting" + "Math. Systems Theory" "1987" + "20" "83-127" + + + "D. Janssens" "G. Rozenberg" + "Actor Grammars" + "Math. Systems Theory" "1989" + "22" "75-107" + + "J. A. Goguen" + "Reusing and Interconnecting Software Components" + "Computer" "1986" + "19" "2" + "February" "16-28" + + + "W. Athas" "C. Seitz" + "Multicomputers: Message-Passing Concurrent Computers" + "Computer" "1988" + "August" "9-24" + + + "J. A. Goguen" "M. Moriconi" + "Formalization in Programming Environments" + "Computer" "1987" + "20" "11" + "November" "55-64" + + + "G. Cousineau" "P.-L. Curien" + "M. Mauny" + "The Categorical Abstract Machine" + "Science of Computer Programming" "1987" + "8" "173-202" + + + "J.-P. Ban^{a}tre" + "D. Le M`{e}tayer" + "The {Gamma} model and its discipline of programming" + "Science of Computer Programming" + "1990" "15" "55-77" + + + "J.-P. Ban^{a}tre" "A. Coutant" + "D. Le M`{e}tayer" + "Parallel machines for multiset transformation and their programming style" + "Informationstechnik {\bf it}" + "1988" "30" + "2" "99-109" + + + "J. Cartmell" + "Generalised Algebraic Theories and Contextual Categories" + "Annals Pure Appl. Logic" "1986" + "32" "209-243" + + + "J. A. Goguen" + "Modular Algebraic Specification of Some Basic Geometrical Constructions" + "Artificial Intelligence" + "1988" "37" + "123-153" + "Jos'e Meseguer" + "Order Completion Monads" + "Algebra Universalis" "1983" + "16" "63-82" + + "T. Coquand" + "G. Huet" + "The Calculus of Constructions" + "Information and Computation" "1988" + "76" "95-120" + + + "Donald Sannella" + "Andrzej Tarlecki" + "Specifications in an Arbitrary Institution" + "Information and Computation" "1988" + "76" "165-210" + + "J. Meseguer" + + "Universe Models and Initial Model Semantics for the Second Order Polymorphic Lambda Calculus" + "Abstracts of the AMS" + "1988" "August" "338" + + "Also appeared as a communication in the {em Types} electronic forum (types@theory.lcs.mit.edu), April 13 1988" + + "L. Henkin" + "Completeness in the Theory of Types" + "J. Symbolic Logic" "1950" + "15" "81-91" + + "P. Freyd" "Aspects of Topoi" + "Bull. Austral. Math. Soc." + "1972" "7" + "1-76" + "Wolfgang K{\"u}hnel" + "Jos'e Meseguer" "Michael Pfender" + "Ignacio Sols" + "Primitive recursive algebraic theories and program schemes" + "Bull. Austral. Math. Soc." "1977" + "17" "207-233" + + + "Wolfgang K{\"u}hnel" + "Jos'e Meseguer" "Michael Pfender" + "Ignacio Sols" + "Algebras with actions and automata" + "Int. J. Math. and Math. Sci." "1982" + "5" "61-85" + + + "J. McCarthy" + "Circumscription--{A} Form of Non-Monotonic Reasoning" + "Artificial Intelligence" "1980" + "13" "27-39" + + + "J. Siekmann" "P. Szab'o" + + "A {Noetherian} and confluent rewrite system for idempotent semigroups" + "Semigroup Forum" + "1982" "25" "83-110" + + "Alexander Herold" + "J{\"{o}}rg H. Siekmann" + "Unification in Abelian Semigroups" + "J. Automated Reasoning" "1987" + "3" "247-283" + + "K. J. Barwise" + "Axioms for Abstract Model Theory" + "Ann. Math. Logic" "1974" + "7" "221-265" + + "J. Meseguer" + + "Universe Models and Initial Model Semantics for the Second Order Polymorphic Lambda Calculus" + "Abstracts Amer. Math. Soc." + "1988" "August" + + "Robin Milner" + + "Lectures on a Calculus for Communicating Systems" + + "Control Flow and Data Flow: Concepts of Distributed Programming" + "Springer NATO ASI Series F, vol. 14" + "1985" "M. Broy" + "205-228" + + + "Jos'e Meseguer" + "Research Directions in Rewriting Logic" + "Computational Logic, NATO Advanced Study Institute, Marktoberdorf, Germany, July 29 -- August 6, 1997" + "Springer-Verlag" + "1999" "U. Berger" + "H. Schwichtenberg" + + + "Architectural design of the rewrite rule machine ensemble" + "Hitoshi Aida" "Sany Leinwand" + "Jos'{e} Meseguer" + "{VLSI} for {Artificial} {Intelligence} and {Neural} {Networks}" + "Plenum Publ. Co." + "1991" "J. Delgado-{Frias}" + "W. R. Moore" "11-22" + + "Proceedings of an International Workshop held in {Oxford}, England, {September} 1990" + + + "Francis William Lawvere" + "Qualitative Distinctions Between Some Toposes of Generalized Graphs" + + "Proc. AMS Summer Research Conference on Categories in Computer Science and Logic, Boulder, Colorado, June 1987" + "J. Gray" "AMS" + "1988" + + + "Francis William Lawvere" + "Quantifiers and Sheaves" + "Actes Congr`{e}s Intl. Math. (Nice 1970), vol. 1" + "Gauthier-Villars" "1971" + "329-334" + + + "David Park" + "Concurrency and Automata on Infinite Sequences" + "Proc. Theoretical Computer Science" + "Springer LNCS 104" "1981" + "P. Deussen" "167-183" + + "Joseph Goguen" + "An Algebraic Approach to Refinement" + "Proc. {VDM}'90" + "Springer LNCS 428" "1990" + "D. Bjorner" + "C. A. R. Hoare" "H. Langmaack" + "11-28" + + + "A. Sernadas" "J. Fiadeiro" + "C. Sernadas" "H.-D. Ehrich" + "Abstract Object Types: {A} Temporal Perspective" + "Temporal Logic in Specification" + "Springer LNCS 398" + "1989" "B. Banieqbal" + "H. Barringer" "A. Pnueli" + "324-350" + + + "K. Ueda" "Guarded Horn Clauses" + "Logic Programming" + "Springer LNCS 221" "1986" + "E. Wada" "168-179" + + "D. Scott" + + "Completeness and Axiomatizability in Many-Valued Logic" + "Proc. Tarski Symp." "AMS" + "1974" + "L. Henkin et al." "411-435" + + "A. Tarski" + "On Some Fundamental Concepts of Metamathematics" + "Logic, Semantics, Metamathematics" + "Oxford U.P." + "1956" "30-37" + + + "J. Meseguer" "General Logics" + "Logic Colloquium'87" "1989" + "H.-D. Ebbinghaus et al." + "North-Holland" "275-329" + + "G. Longo" + "Some Aspects of Impredicativity" + "Proc. Logic Colloquium'87" + "North-Holland" "M. Garrido" + "To appear. Also, Carnegie-Mellon Report CMU-CS-88-135" + "1988" + + + "Pierpaolo Degano" + "Rocco De Nicola" "Ugo Montanari" + "Observational Equivalences for Concurrency Models" + + "Proc. IFIP TC2 Workshop on Formal Description of Programming Concepts IV" + "North-Holland" + "1987" "M. Wirsing" + "To appear." + + + "Pierpaolo Degano" "Ugo Montanari" + + "Concurrent Histories: {A} Basis for Observing Distributed Systems" + "Journal of Computer and System Sciences" + "1987" "34" + "2/3" "422-461" + "April/June" + + + "Andrzej Tarlecki" + "Quasi-varieties in Abstract Algebraic Institutions" + "Journal of Computer and System Sciences" + "1986" "33" + "333-360" + "F. W. Lawvere" + "Adjointness in Foundations" + "Dialectica" "1969" "23" + "3/4" "281-296" + + "Ilaria Castellani" + "Paola Franceschi" + "Ugo Montanari" + "Labelled Event Structures: {A} Model for Observable Concurrency" + + "Proc. IFIP TC2 Workshop on Formal Description of Programming Concepts III" + "North-Holland" + "1983" "D. Bjo rner" + "383-400" + + + "Ilaria Castellani" + "Bisimulation and Abstraction Homomorphisms" + "Proc. TAPSOFT Conference, Berlin" + "Springer LNCS 185" "1985" + "H. Ehrig" "C. Floyd" + "M. Nivat" "J. Thatcher" + "223-238" + "Also to appear in JCSS" + + + "M. T. Sanderson" "Proof Techniques for {CCS}" + + "Computer Science Department, University of Edinburgh" + "1982" "Technical Report CST-19-82" + + + "Gert Smolka" + "Logic programming over polymorphic order-sorted types" + "Computer Science Department, University of Kaiserslautern" + "1989" + + "Vijay Saraswat" + "Concurrent constraint programming languages" + + "Computer Science Department, Carnegie-Mellon University" + + "1989" + "G. Sivakumar" + "Proofs and Computations in Conditional Equational Theories" + "CS Dept., U. Illinois at Urbana" + "1989" + "Valeria C. V. de Paiva" + "The Dialectica Categories" + "Mathematics Department, University of Cambridge" + "1988" + + + "P. Taylor" + "Recursive Domains, Indexed Category Theory and Polymorphism" + "Mathematics Department, University of Cambridge" + "1987" + + "N. McCracken" + "An Investigation of a Programming Language with a Polymorphic Type Structure" + "Syracuse University" + "1979" + "D. McCarty" + "Realizabity and Recursive Mathematics" + "Oxford University" "1984" + + + "G'{e}rard Boudol" + "Ilaria Castellani" + "On the semantics of concurrency: partial orders and transition systems" + "TAPSOFT '87" + "1987" "H. Ehrig et al." + "123-137" "Springer" + + + "G'{e}rard Boudol" + "Towards a lambda calculus for concurrent and communicating systems" + "TAPSOFT '89" + "1989" "149-161" + "Springer LNCS Vol. 351" + + "Pierpaolo Degano" + "Rocco De Nicola" + "Ugo Montanari" + "A distributed operational semantics for {CCS} based on condition/event systems" + "IEI-CNR" + "1987" "Nota Interna" + "B4-21" "Pisa" + "September" + "Roberto Amadio" + "Formal theories of inheritance for typed functional languages" + "University of Pisa, Comp. Sci. Dept." + "1989" "TR-28/89" + "July" + + + "Robin Milner" + "Calculi for Synchrony and Asynchrony" + "C.S. Dept, U. Edinburgh" "1982" + "CSR-104-82" "February" + + + "J. A. Makowski" + "Why {Horn} Formulas Matter in Computer Science: Initial Structures and Generic Examples" + "C.S. Dept, Technion" + "1984" "329" + "July" + + "Narciso Mart'i-Oliet" "Jos'{e} Meseguer" + "From {Petri} Nets to Linear Logic" + "D. H. Pitt et al." + "Category Theory and Computer Science" "1989" + "313-340" + "Springer LNCS 389" + "Final version in {it Mathematical Structures in Computer Science}, 1:69-101, 1991" + + + "Narciso Mart'i-Oliet" "Jos'{e} Meseguer" + "From {Petri} Nets to Linear Logic" + "Math. Struct. in Comp. Sci." + "1991" "69-101" "1" + + + "H.-J. Kreowski" "T. Mossakowski" + + "Equivalence and difference between institutions: simulating {Horn Clause Logic} with based algebras" + "Math. Struct. in Comp. Sci." + "1995" "189-215" + + "5" "Luca Cardelli" + "John Mitchell" + "Operations on records" + "Math. Struct. in Comp. Sci." "1991" + "3-48" "1" + + + "A. J. Power" + "An abstract formulation of rewrite systems" + "D. H. Pitt et al." + "Category Theory and Computer Science" "1989" + "300-312" + "Springer LNCS, Vol. 389" + + + "A. Pitts" + "An Elementary Calculus of Approximations" + "Unpublished manuscript, University of Sussex, December 1987" + + + "Jos'{e} Meseguer" + "The Category of Commutations of {$Sigma$}-Term Rewriting Systems" + + "Unpublished manuscript, SRI International, December 1987" + + + "Ross Casley" "Roger Crew" + "Jos'{e} Meseguer" + "Vaughan Pratt" "Temporal Structures" + "D. H. Pitt et al." + "Category Theory and Computer Science" "1989" + "21-51" + "Springer LNCS, Vol. 389" + + + "H. Aida" "J. A. Goguen" + "S. Leinwand" "J. Meseguer" + "T. Winkler" + "The Rewrite Rule Machine" + "Computer Science Laboratory, SRI International" + "1989" "SRI-CSL-89-6" + "March" "Jos'{e} Meseguer" + "Relating Models of Polymorphism" + "C.S. Lab., SRI International" + "1988" "SRI-CSL-TN88-1" + "June" + + + "Jos'{e} Meseguer" "Ugo Montanari" + + "Petri Nets Are Monoids: {A} New Algebraic Foundation for Net Theory" + "Proc. LICS'88" + "1988" "155-164" + "IEEE" + "Claude March'e" + "Normalised rewriting and normalised completion" + "Proc. LICS'94" "1994" + "394-403" "IEEE" + + "Tobias Nipkow" + "Functional unification of higher-order patterns" + "Proc. LICS'93" "1993" + "64-74" "IEEE" + + "V. Breazu-Tannen" + "T. Coquand" + "C. A. Gunter" "A. Scedrov" + "Inheritance and Explicit Coercion" + "Proc. LICS'89" "1989" + "112-129" "IEEE" + + "P. Degano" + "J. Meseguer" + "U. Montanari" + "Axiomatizing Net Computations and Processes" + "Proc. LICS'89" "1989" + "175-185" "IEEE" + + "R. Harper" + "D. Sannella" "A. Tarlecki" + "Structure and Representation in {LF}" + "Proc. LICS'89" + "1989" "226-237" + "IEEE" + + "Mitchell Wand" + "Type Inference for Record Concatenation and Multiple Inheritance" + "Proc. LICS'89" + "1989" "92-97" "IEEE" + + "T. Coquand" + "Categories of Embeddings" + "Proc. LICS'88" "1988" + "256-263" "IEEE" + + "R. Amadio" + "K. B. Bruce" + "G. Longo" + "The Finitary Projection Model for Second Order Lambda Calculus and Solutions to Higher Order Domain Equations" + "Proc. LICS'86" + "1986" "122-130" + "IEEE" + "P. J. Freyd" + "J.-Y. Girard" + "A. Scedrov" "P. J. Scott" + "Semantic Parametricity in Polymorphic Lambda Calculus" + "Proc. LICS'88" + "1988" "274-279" + "IEEE" + "Rob van Glabbeek" + "Frits Vaandrager" + "Petri net models for algebraic theories of concurrency" + "PARLE Conference" "1987" + "J. W. de Bakker et al." + "" + "Springer LNCS 259" + + + "Ernst-R{\"{u}}diger Olderog" + "Operational Petri net semantics for {CCSP}" + "Advances in Petri Nets 1987" "1987" + "G. Rozenberg" "196-223" + "" + "Springer LNCS 266" + + + "Glynn Winskel" + "Categories of Models for Concurrency" + "Workshop on the semantics of concurrency" + "1984" "S. Brooks" + "July" + "Glynn Winskel" + "Event structures" + "University of Cambridge Computer Laboratory" + "1986" "Technical Report" + "95" "July" + + + "Pierpaolo Degano" "Ugo Montanari" + "Specification languages for distributed systems" + "TAPSOFT" "1985" + "H Ehrig et al." "29-51" + "Springer LNCS 185" + + "Saunders MacLane" + "Categories for the Working Mathematician" + "Springer-Verlag" "1971" + + + "C. A. R. Hoare" + "Communicating Sequential Processes" + "Prentice Hall" "1985" + + + "S. Y. Kung" + "{VLSI} Processor Arrays" "Prentice Hall" + "1988" + + "Ian Foster" + "Stephen Taylor" + "Strand: New Concepts in Parallel Programming" + "Prentice Hall" "1990" + + + "Robin Milner" "Communication and Concurrency" + "Prentice Hall" + "1989" + + "Simon Peyton-Jones" + "The Implementation of Functional Programming Languages" + "Prentice Hall" "1987" + + + "Herrlich" "Strecker" + "Category theory" + "Allyn and Bacon" "1973" + + + "Saunders MacLane" "Garrett Birkhoff" + "Algebra" + "Mac Millan" "1967" + + "E. Manes" + "Algebraic theories" "Springer" + "1976" "26" + "Graduate Texts in Mathematics" + + + "S. Eilenberg" "J. C. Moore" + "Adjoint functors and triples" + "Illinois J. Math." "1965" + "9" "381-398" + + "Kim Bruce" + "Giuseppe Longo" + "A Modest Model of Records, Inheritance and Bounded Quantification" + "Information and Computation" + "1990" "87" + "196-240" + "Robin Milner" + "Functions as Processes" + "Mathematical Structures in Computer Science" + "1992" "2" "2" + "119-141" + + "Jos'e Meseguer" + "Ugo Montanari" + "Vladimiro Sassone" + "On the semantics of place/transition {P}etri nets" + "Mathematical Structures in Computer Science" + "1997" "7" + "4" "359-397" + + "Joseph Goguen" + "A Categorical Manifesto" + "Mathematical Structures in Computer Science" + "1991" "1" + "1" "49-67" + + "Ross Casley" + "Roger Crew" + "Jos'{e} Meseguer" "Vaughan Pratt" + "Temporal Structures" + "Mathematical Structures in Computer Science" + "1991" "1" "2" + "179-213" + + "Joseph Goguen" + + "Sheaf semantics for concurrent interacting objects" + "Mathematical Structures in Computer Science" + "1992" "2" + "2" "159-191" + + + "Ross Cassley" "Roger Crew" + "Jos'{e} Meseguer" "Vaughan Pratt" + "Temporal Structures" + "J. Math. Structures in Computer Science" "1991" + "1" "2" + + "179-213" "V. R. Pratt" + "Modelling Concurrency with Partial Orders" + "Intl. J. Parallel Programming" + "1986" "15" + "33-71" + "F. E. J. Linton" + "Autonomous Equational Categories" + "J. of Mathematics and Mechanics" + "1966" "15" "637-642" + + + "Anders Kock" + "Closed categories generated by commutative monads" + "J. Australian Math. Soc." "1971" + "12" "405-424" + + "Joseph Goguen" + "Claude Kirchner" + "Jos'{e} Meseguer" + "Concurrent term rewriting as a model of computation" + "Proc. Workshop on Graph Reduction, Santa Fe, New Mexico" + "1987" "R. Keller" + "J. Fasel" "53-93" + "Springer LNCS 279" + + + "P. G. Harrison" "M. J. Reeve" + "The Parallel Graph Reduction Machine, {Alice}" + "Proc. Workshop on graph reduction, Santa Fe, New Mexico" + "1987" "R. Keller" + "J. Fasel" "181-202" + "Springer LNCS 279" + + "Order-Sorted Unification" + "Jos'{e} Meseguer" + "Joseph Goguen" "Gert Smolka" + + "To appear in the {it Journal of Symbolic Computation}, special issue on unification" + + "T. Naoi" + "Y. Inagaki" + "Algebraic Semantics of Term Rewriting Systems" + "Comp86, pp. 1-10" "Jos'{e} Meseguer" + "Lectures on Algebraic Data Types" + + "ASL-CSLI Summer School on Logic, Language and Computation, Stanford, July 1985" + + + "Luca Cardelli" "John Mitchell" + "Semantic Methods for Object-Oriented Languages, Part 2" + "Tutorial at OOPSLA'88" + + "Jean-Yves Girard" + "Towards a Geometry of Interaction" + + "{Proc. AMS Summer Research Conference on Categories in Computer Science and Logic, Boulder, Colorado, June 1987}" + "1989" "69-108" + "J. W. Gray" + "A. Scedrov" "American Mathematical Society" + + "Jean-Yves Girard" + "Geometry of Interaction {III}: the general case" + "{Proc. Workshop on Linear Logic}" + "1994" + "To appear in MIT Press" + + + "A. M. Pitts" "P. Taylor" + + "A note on {Russell's} Paradox in Locally Cartesian Closed Categories" + "1987" + "University of Sussex" + + + "P. Taylor" + "Stable Categories form a Cartesian Closed Category" + "1988" + "Dept. of Computing, Imperial College" + + + "F. W. Lawvere" "Skolem Categories" + + "Unpublished Seminar Lectures at University of Buffalo. Fall of 1974" + + "A. Asperti" + "G. Longo" + "Categories for Denotational Semantics" "To appear" + + + "A. Asperti" + "A logic for concurrency" + "Unpublished manuscript, November 1987" + + + "Edmund Robinson" "How complete is {PER}?" + + "Queen's University, Department of Computing and Information Science" + "1988" "88-229" + + "Carl Gunter" + "Vijay Gehlot" + "Nets as Tensor Theories" + "Dept. of Computer and Information Science, University of Pennsylvania" + "1989" + "MS-CIS-89-68" + "Edmund Robinson" + "Personal Communication" "July 1988" + + "G. Hotz" + + "Eine Algebraisierung des Syntheseproblemen von Schaltkreisen, {I} and {II}" + "EIK" "1965" + "1" "185--206, 209--231" + + "A. Kock" + "Bilinearity and Cartesian Closed Monads" + "Math. Scand." "1971" + "29" "161-174" + + + "Jos'{e} Meseguer" "Ignacio Sols" + "Automata in semimodule categories" + "Category Theory Applied to Computation and Control" + "Springer LNCS 25" + "1975" "E. G. Manes" + "193-198" "David B. Benson" + "The basic algebraic structures in categories of derivations" + "Info. and Co." "1975" + "28" "1-29" + + + "Michael G. Main" "David B. Benson" + + "Functional behaviour of nondeterministic and concurrent programs" + "Info. and Co." "1984" + "62" "144-189" + + "Wolfgang Hinderer" + + "Transfer of graph constructs in Goguen's paper to net constructs" + "Application and Theory of Petri Nets" + "Springer Informatik-Fachberichte 52" + "1982" + "Claude Girault" "Wolfgang Reisig" + "142-150" + + + "W. M. P. van der Aalst" + "Interval timed coloured {Petri} nets and their analysis" + "Application and Theory of Petri Nets 1993" + "Springer LNCS 691" + "1993" "M. Ajmone Marsan" + "453-472" + + + "Carl Adam Petri" "Concepts of net theory" + "Mathematical Foundations of Computer Science" + "1973" "137-146" + + "Mathematical Institute of the Slovak Academy of Sciences" + + "Stefan Drees" + "Dominik Gomm" + "Helmut Pl{\"{u}}nnecke" "Wolfgang Reisig" + "Rolf Walter" + "Bibliography of Net Theory" + "Gesellschaft f{\"{u}}r Mathematik und Datenverarbeitung MBH" + "1986" + "Arbeitspapiere der GMD" "212" + + "V. Breazu-Tannen" "A. R. Meyer" + "Computable values can be classical" + + "{Proceedings of the 14th Symposium on Principles of Programming Languages}" + "ACM" + "238-245" "January" "1987" + + "V. Breazu-Tannen" + "Conservative extensions of type theories" + "MIT" "February" + "1987" "Supervised by A. R. Meyer" + + "V. Breazu-Tannen" + "T. Coquand" + "Extensional models for polymorphism" + "{Proceedings of TAPSOFT - Colloquium on Functional and Logic Programming and Specifications, Pisa, March 1987}" + "LNCS, Vol. 250, Springer-Verlag" + "291-307" "1987" + + "An expanded version will appear in the special issue of {em Theoretical Computer Science} dedicated to the colloquium" + + "V. Breazu-Tannen" + "A. R. Meyer" + "Polymorphism is conservative over simple types" + + "{Proceedings of the Symposium on Logic in Computer Science}" + "IEEE" + "June" "1987" "7-17" + + "L. Bachmair" + "N. Dershowitz" "J. Hsiang" + "Orderings for Equational Proofs" + + "{Proceedings of the Symposium on Logic in Computer Science}" + "IEEE" + "June" "1986" "346-357" + + "Joseph Goguen" + "Jos'{e} Meseguer" + "Software for the Rewrite Rule Machine" + "Proceedings of the International Conference on Fifth Generation Computer Systems, Tokyo, Japan" + "ICOT" + "1988" "628-637" + + + "Hideyuki Nakashima" "Hiroyuki Suzuki" + "Per-Kristian Halvorsen" + "Stanley Peters" + "Towards a Computational Interpretation of Situation Theory" + + "Proceedings of the International Conference on Fifth Generation Computer Systems, Tokyo, Japan" + "ICOT" + "1988" "489-498" + + + "S. Leinwand" "J. A. Goguen" + "T. Winkler" + "Cell and Ensemble Architecture for the Rewrite Rule Machine" + + "Proceedings of the International Conference on Fifth Generation Computer Systems, Tokyo, Japan" + "ICOT" + "1988" "869-878" + + + "V. Breazu-Tannen" + "Proof of a conjecture on polymorphic lambda models with all types non-empty" + "Manuscript, Univ. of Pennsylvania, 1987" + + "V. Breazu-Tannen" + "Combining algebra and higher-order types" + + "{Proceedings of the Symposium on Logic in Computer Science}" + "IEEE" + "July" "1988" "To appear" + + "A. Carboni" + "P. J. Freyd" + "A. Scedrov" + "{A Categorical Approach to Realizability and Polymorphic Types}" + + "{Mathematical Foundations of Programming Language Semantics}" + "April" "1987" + "M. Main" "A. Melton" + "Springer LNCS" + + "T. Coquand" + "C. A. Gunter" "Glynn Winskel" + "{dI-domains as a Model of Polymorphism}" + + "{Mathematical Foundations of Programming Language Semantics}" + "April" "1987" + "M. Main" "A. Melton" + "Springer LNCS" + + "P. J. Freyd" + "A. Scedrov" + "{Some Semantic Aspects of Polymorphic Lambda Calculus}" + "{Second IEEE Symposium on Logic in Computer Science}" + "June" "1987" + "D. Gries" "315-319" + "IEEE Computer Society" + + + "R. Seely" + "Modelling computations: a 2-categorical framework" + "{Second IEEE Symposium on Logic in Computer Science}" + "June" "1987" + "D. Gries" "65-71" + "IEEE Computer Society" + + "P. J. Freyd" + "J. Y. Girard" + "A. Scedrov" "P. J. Scott" + "{Semantic Parametricity in Polymorphic Lambda Calculus}" + + "{Third IEEE Symposium on Logic in Computer Science}" + "July" "1988" + "IEEE Computer Society" + + + "P. Giannini" "G. Longo" + "{Effectively Given Domains and Lambda Calculus Models}" + "Information and Control" + "1984" "62" + "36-63" + + "Jean-Yves Girard" + "Interpr'etation Fonctionelle et 'Elimination des Coupures dans l'Arithm'etique d'ordre Sup'erieure" + "Univ. Paris VII" "1972" + + + "Jean-Yves Girard" + "{The System F of Variable Types, Fifteen Years Later}" + "Theoretical Computer Science" + "1986" "45" "159-192" + + "D. A. Schmidt" + + "{Approximation Properties of Abstract Data Types}" + "Theoretical Computer Science" + "1983" "24" "73-94" + + + "Andrzej Tarlecki" + "{On the Existence of Free Models in Abstract Algebraic Institutions}" + "Theoretical Computer Science" + "1985" "37" + "269-304" + "Jean-Yves Girard" + "{Linear Logic}" + "Theoretical Computer Science" "1987" + "50" "1-102" + + + "Jean-Yves Girard" + "{Proof Theory and Logical Complexity}" + "Bibliopolis" "1987" + + + "C. A. Gunter" + "{Sets and the Semantics of Bounded Non-Determinism}" + "In preparation" + + + "G. Huet" "{A Uniform Approach to Type Theory}" + + "{Logical Foundations of Functional Programming}" + "June" "1987" + "G. Huet" + "Proceedings University of Texas Year of Programming" + + + "J. M. E. Hyland" "E. Robinson" + "G. Rosolini" + "{Discrete Objects in the Effective Topos}" + "Preprint" "1987" + + + "J. M. E. Hyland" "A. Pitts" + + "The Theory of Constructions: Categorical Semantics and Topos-Theoretic Models" + + "{Proc. AMS Summer Research Conference on Categories in Computer Science and Logic, Boulder, Colorado, June 1987}" + "1988" "J. W. Gray" + "A. Scedrov" "137-199" + "American Mathematical Society" + + "P. Martin-Loef" + "{Intuitionistic Type Theory}" + "Bibliopolis" "1984" + + "P. Martin-Loef" + + "{An Intuitionistic Theory of Types: Predicative Part}" + "{Logic Colloquium'73}" + "H. E. Rose" "J. C. Shepherdson" + "Noth-Holland" "1973" + "73-118" + + + "J. C. Mitchell" + "{Representation Independence and Data Abstraction}" + + "{13th ACM Symposium on Principles of Programming Languages}" + "1986" "263-276" + + "J. C. Reynolds" + "{Towards a Theory of Type Structure}" + "{Programming Symposium}" + "1974" "B. Robinet" + "408-425" "Springer LNCS 19" + + "J. C. Reynolds" + + "{Types, Abstraction, and Parametric Polymorphism}" + "{Information Processing '83}" + "1983" "R. E. A. Mason" + "513-523" "North-Holland" + + "G. Rosolini" + "{Continuity and Effectiveness in Topoi}" + "Oxford University" + "{Doctoral Dissertation}" "1986" + + "A. Scedrov" + + "{Recursive Realizability Semantics for Calculus of Constructions}" + + "{Logical Foundations of Functional Programming}" + "June" "1987" + "G. Huet" + "Proceedings University of Texas Year of Programming" + + + "D. S. Scott" + "{Data Types as Lattices}" + "SIAM Journal of Computing" "1976" + "5" "522-587" + + + "Jos'e Meseguer" "Ir`ene Guessarian" + "{On the axiomatization of if-then-else}" + "SIAM Journal of Computing" + "1987" "16" + "332-357" + "D. S. Scott" + "{Domains for Denotational Semantics}" + + "{International Colloquium on Automata, Languages and Programs}" + "1982" "M. Nielsen" + "E. M. Schmidt" + "577-613" "Springer LNCS 140" + + + "D. S. Scott" + "{Realizability and Domain Theory}" + "Lecture at the AMS Conference on Categories in Computer Science and Logic" + "June" "1987" + + + "M. B. Smyth" "G. D. Plotkin" + + "{The Category-Theoretic Solution of Recursive Domain Equations}" + "SIAM Journal of Computing" + "1982" "11" + "761-783" + + "A. S. Troelstra" + "{Metamathematical Investigation of Intuitionistic Arithmetic and Analysis}" + "Springer Lecture Notes in Mathematics 344" + "1973" + + + "N. McCracken" + "The Type-Checking of Programs with Implicit Type Structure" + "G. Kahn" "D. B. MacQueen" + "G. Plotkin" + "Proceedings of the Conference on Semantics of Data Types, Sophia-Antipolis, June 1984" + "{em LNCS}, Vol. 173, Springer-Verlag" + "301-315" "1984" + + "J. C. Mitchell" + "Type Inference and Type Containment" + "G. Kahn" + "D. B. MacQueen" "G. Plotkin" + + "Proceedings of the Conference on Semantics of Datan Types, Sophia-Antipolis, June 1984" + "{em LNCS}, Vol. 173, Springer-Verlag" + "257-277" "1984" + + + "R. L. Constable" + "{Implementing Mathematics with the Nuprl Proof Development System}" + "Prentice Hall" + "1987" + "E. Moggi" + "Communication in the {sc Types} electronic forum (types@theory.lcs.mit.edu), {February 10, 1986}" + + + "A. M. Pitts" + "An extension of {Reynolds'} result on the non-existence of set-models of polymorphism" + + "Communication in the {it Types} electronic forum (types@theory.lcs.mit.edu), {May 29, 1988}" + + + "H. Huwig" "A. Poign'{e}" + + "A note on inconsistencies caused by fixpoints in a cartesian closed category" + "Manuscript, C.S. Dept., Univ. of Dortmund" + + + "E. Moggi" + "Communication in the {sc Types} electronic forum (types@theory.lcs.mit.edu), {July 23, 1986}" + + + "D. S. Scott" + "Relating theories of the lambda calculus" + "To H.B. Curry: Essays on Combinatory Logic, Lambda Calculus and Formalism" + "J. P. Seldin" + "J. R. Hindley" "Academic Press" + "1980" "403-450" + + "J.-J. L'{e}vy" + "Optimal reductions in the lambda calculus" + "159-191" + "To H.B. Curry: Essays on Combinatory Logic, Lambda Calculus and Formalism" + "J. P. Seldin" + "J. R. Hindley" "Academic Press" + "1980" + + "R. A. G. Seely" + + "Higher order polymorphic lambda calculus and categories" + "Mathematical Reports, Academy of Science (Canada)" + "{VIII}" "2" + "1986" "135-139" + + + "R. A. G. Seely" + "Locally cartesian closed categories and type theory" + "Math. Proc. Camb. Phil. Soc." + "95" "1984" "33-48" + + + "R. A. G. Seely" + "Categorical semantics for higher order polymorphic lambda calculus" + "J. Symbol. Logic" + "52" "4" "1987" + "969-989" + + + "A. Boileau" "A. Joyal" + "La Logique des Topos" + "J. Symbol. Logic" "46" + "1" "1981" + "6-16" + "J. M. E. Hyland" + "A small complete category" "1987" + + "Manuscript, to appear in the proceedings of the Conference on Church's Thesis: Fifty Years Later" + + "A. Ohori" + "P. Buneman" + "OhoriBuneman" + "{Type Inference in a Database Programming Language}" + "University of Pennsylvania" + "Technical report" "November" + "1987" + + + "J. Meseguer J. A. Goguen" + "E. Munthe-Kaas." + "{Object-Oriented Programming and Specification is a Natural Extension of Pure Functional Programming}" + "SRI International" + "Technical report" "To appear" + "1989" + + + "P. Buneman" "S. Davidson" + "Watters A." + "Buneman, Davidson & Watters" + "{A Semantics for Complex Objects and Approximate Queries}" + "Principles of Database Systems" + "ACM" "March" + "1988" + + + "C. A. Gunter" + "Profinite Solutions for Recursive Domain Equations" + "University of Wisconsin at Madison" + "1985" + + "{A Semantics of Multiple Inheritance}" + "Luca Cardelli" + "Semantics of Data Types, LNCS 173" "G. Kahn" + "D. Mac{Queen}" + "G. Plotkin" "Springer LNCS 173" + "51-67" "1984" + + + "{A Semantics of Multiple Inheritance}" + "Luca Cardelli" "Information and Computation" + "76" "138-164" + "1988" + + + "{Structural Subtyping and the Notion of Power Type}" + "Luca Cardelli" + "Proc. POPL'88" "ACM" + "1988" + + + "{Reflection and Semantics in {Lisp}}" + "Brian C. Smith" "Proc. POPL'84" + "23-35" "ACM" + "1984" + + + "Modeling concurrency with geometry" + "Vaughan Pratt" "311-322" + "Proc. POPL'91" "ACM" + "1991" + + + "Algorithmic aspects of type inference with subtypes" + "Patrick Lincoln" "John Mitchell" + "" "Proc. POPL'92" + "ACM" "1992" + + "Coercion and type inference" + "John Mitchell" + "175-185" "Proc. POPL'84" + "ACM" "1984" + + + "{Relating Models of Polymorphism}" + "Jos'e Meseguer" "Proc. POPL'89" + "ACM" + "228-241" "1989" + + + "{Inheritance is not Subtyping}" + "William Cook" "Walter Hill" + "Peter Canning" "Proc. POPL'90" + "ACM" + "125-135" "1990" + + + "{Toward a Typed Foundation for Method Specialization and Inheritance}" + "John Mitchell" + "Proc. POPL'90" "ACM" + "109-124" "1990" + + "{Explicit Substitutions}" + "M. Abadi" "L. Cardelli" + "P.-L. Curien" "J.-J. L'evy" + "Proc. POPL'90" + "ACM" "31-46" + "1990" + + + "{Rewrite, Rewrite, Rewrite, Rewrite, Rewrite,...}" + "N. Dershowitz" "S. Kaplan" + "Proc. POPL'89" + "ACM" "250-259" + "1989" + + + "{Empty Types in Polymorphic $lambda$ Calculus}" + "A. R. Meyer" "J. R. Mitchell" + "E. Moggi" + "R. Statman" "Proc. POPL'87" + "ACM" "253-262" + "1987" "Luca Cardelli" + "{A polymorphic $lambda$-calculus with Type:Type}" + "DEC System Research Center" + "Palo Alto, CA" "1986" + "10" "Leslie Lamport" + "{A Temporal Logic of Actions}" + "DEC System Research Center" + "Palo Alto, Ca" "1990" + + + "Luca Cardelli" "{A Quest Preview}" + "DEC System Research Center" + "Palo Alto, Ca" + "1988" + "Luca Cardelli" + "Giuseppe Longo" + "{A semantic basis for {Quest}}" + "DEC System Research Center" + "Palo Alto, Ca" "55" + "1990" + "G. Winskel" + "{On Powerdomains and Modalities}" + "{Theoretical Computer Science}" "1985" + "36" "127-137" + + "D. Miller" + "A. Felty" + "An Integretation of Resolution and Natural Deduction Theorem Proving" + + "Proceedings of the Fifth National Conference on Artificial Intelligence" + "August" "1986" + + + "D. Miller" "G. Nadathur" + "A. Scedrov" + "Hereditary Harrop Formulas and Uniform Proofs Systems" + "{Second Annual Symposium on Logic in Computer Science}" + "Cornell University" + "June" "1987" + "98-105" + + "Proving Properties of Programs by Structural Induction" + "Rod Burstall" "1969" + "Computer Journal" "12" + "1" "41-48" + + + "Putting Theories together to Make Specifications" + "Rod Burstall" "Joseph Goguen" + + "Proceedings, Fifth International Joint Conference on Artificial Intelligence" + "Raj Reddy" + "Department of Computer Science, Carnegie-Mellon University" + "1977" "1045-1058" + + "Rod Burstall" + "Joseph A. Goguen" + "The Semantics of {C}lear, a Specification Language" + + "Proceedings of the 1979 Copenhagen Winter School on Abstract Software Specification" + "Dines Bjorner" + "Springer LNCS 86" "292-332" + "1980" + "An Informal Introduction to Specifications using Clear" + "Rod Burstall" "Joseph Goguen" + "1981" + "The Correctness Problem in Computer Science" + "Robert Boyer" "J Moore" + "Academic Press" "185-213" + + "Reprinted in {it Software Specification Techniques}, Narain Gehani and Andrew McGettrick, Eds., Addison-Wesley, 1985, pages 363-390" + + "Joseph Goguen" + "Semantics of Computation" "1974" + + "Proceedings, First International Symposium on Category Theory Applied to Computation and Control" + "Ernest G. Manes" + "University of Massachusetts at Amherst" + "234-249" + "Also published in LNCS, Volume 25, Springer-Verlag, 1975, pages 151-163" + + + "Some Remarks on Data Structures" "Joseph Goguen" + "1973" + "Abstract of 1973 Lectures at Eidgenoschiche Technische Hochschule, Zurich" + + + "Mathematical Representation of Hierarchically Organized Systems" + "Joseph Goguen" "1971" + "E. Attinger" + "Global Systems Dynamics" "S. Karger" + "112-128" + + + "A Categorical Approach to General Systems Theory" + "Joseph Goguen" "Susanna Ginali" + "1978" + "Applied General Systems Research" + "George Klir" "257-270" + "Plenum" + + + + "Algebraic Denotational Semantics using Parameterized Abstract Modules" + "Joseph Goguen" + "Kamran Parsaye-Ghomi" "1981" + "Formalizing Programming Concepts" + "J. Diaz" "I. Ramos" + "LNCS, Volume 107" "292-309" + "Springer-Verlag" + + + "The Specification and Application to Programming of Abstract Data Types" + "John Guttag" "1975" + "University of Toronto" + "Computer Science Department, Report CSRG-59" + + + "Abstract Data Types and the Development of Data Structures" + "John Guttag" + "Communications of the Association for Computing Machinery" + "1977" "20" + "June" "297-404" + + + + "Asynchronous Distributed Simulation via a Sequence of Parallel Computations" + "K. M. Chandy" + "J. Misra" + "Communications of the Association for Computing Machinery" + "1981" "24" + "April" "198-206" + + + "An Expert System for a Resource Allocation Problem" + "J. R. Slagle" + "H. Hamburger" + "Communications of the Association for Computing Machinery" + "1985" "28" + "September" "994-1004" + + + "Concurrent object-oriented programming" + "G. Agha" + "Communications of the Association for Computing Machinery" + "1990" "33" + "September" "125-141" + + + "Linda in context" "N. Carriero" + "D. Gelernter" + "Communications of the Association for Computing Machinery" + "1989" "32" + "April" "444-458" + + + "Parallel Discrete Event Simulation" + "Richard M. Fujimoto" + "Communications of the Association for Computing Machinery" + "1990" "33" + "October" "31-53" + + + "Pascal User Manual and Report" "K. Jensen" + "Niklaus Wirth" "1978" + "Springer-Verlag" + "second" "Order Sorted Algebra" + "Joseph Goguen" "1978" + "14" + "UCLA Computer Science Department" + "Semantics and Theory of Computation Series" + + + "Abstract Errors for Abstract Data Types" + "Joseph Goguen" "1977" + "Proceedings of First IFIP Working Conference on Formal Description of Programming Concepts" + "Peter Neuhold" + "MIT" "21.1--21.32" + "Also published in {it Formal Description of Programming Concepts}, Peter Neuhold, Ed., North-Holland, pages 491-522, 1979" + + + "Concurrency issues in object-oriented programming languages" + "M. Papathomas" "1989" + "Object Oriented Development" + "D. Tsichritzis" "Universit'e de Geneve" + "207-246" + + + "Reductive conditional term rewriting systems" + "J.-P. Jouannaud" "B. Waldmann" + "1986" + "Proceedings of Third IFIP Working Conference on Formal Description of Programming Concepts" + "Ebberup, Denmark" + + + "Fair termination is decidable for ground systems" + "Sophie Tison" "1989" + "462-476" "Nachum Dershowitz" + + "Rewriting Techniques and Applications, Chappel Hill, North Carolina" + "Springer LNCS 355" + + + "Termination for the direct sum of term rewriting systems" + "Y. Toyama" + "J. W. Klop" "H. P. Barendregt" + "1989" "477-491" + "Nachum Dershowitz" + "Rewriting Techniques and Applications, Chappel Hill, North Carolina, Springer LNCS No. 355" + + + "H. Kaphengst" "Horst Reichel" + "Initial Algebraic Semantics for Non-Context-Free Languages" + "1977" + "Fundamentals of Computation Theory" + "Marek Karpinski" "LNCS, Volume 56" + "Springer-Verlag" "120-126" + + + "An Initial Algebra Approach to the Specification, Correctness and Implementation of Abstract Data Types" + "Joseph Goguen" + "James Thatcher" "Eric Wagner" + "1976" "October" + "IBM T. J. Watson Research Center" + "RC 6487" + "Appears in {it Current Trends in Programming Methodology, IV}, Raymond Yeh, editor, Prentice-Hall, 1978, pages 80-149" + + + "Abstract Data Types as Initial Algebras and the Correctness of Data Representations" + "Joseph Goguen" + "James Thatcher" "Eric Wagner" + "Jesse Wright" "1975" + "Computer Graphics, Pattern Recognition and Data Structure" + "Alan Klinger" + "IEEE Press" "89-93" + + "Joseph Goguen" + "James Thatcher" + "Eric Wagner" "Jesse Wright" + "Initial Algebra Semantics and Continuous Algebras" + + "Journal of the Association for Computing Machinery" + "24" "1" + "68-95" "January" "1977" + + + "Computable Algebra: General Theory and Theory of Computable Fields" + "Michael Rabin" "1960" + + "Transactions of the American Mathematical Society" + "95" "341-360" + + + "Ordinary Specification of Some Construction in Plane Geometry" + "Joseph Goguen" "1982" + + "Proceedings, Workshop on Program Specification" + "J{o}rgen Staunstrup" + "Springer-Verlag" "31-46" + "LNCS, Volume 134" + + + "Institutions: Abstract Model Theory for Computer Science" + "Joseph Goguen" "Rod Burstall" + "1985" + "Center for the Study of Language and Information, Stanford University" + "{CSLI}-85-30" + "Also submitted for publication" + + + "Universal Realization, Persistent Interconnection and Implementation of Abstract Modules" + "Joseph Goguen" + "Jos'{e} Meseguer" "1982" + + "Proceedings, 9th International Conference on Automata, Languages and Programming" + "265-281" + "M. Nielsen" "E. M. Schmidt" + "Springer LNCS 140" + + "Infinite Normal Forms" + "Nachum Dershowitz" + "Stephan Kaplan" "David Plaisted" + "1989" + "Proceedings, 16th International Conference on Automata, Languages and Programming" + "249-262" + "G. Ausiello" "M. Dezani-Ciancaglini" + "S. Ronchi Della Rocca" + "Springer-Verlag" + "LNCS, Volume 372" + + + "Models and Equality for Logical Programming" + "Joseph Goguen" "Jos'e Meseguer" + "Proceedings TAPSOFT'87" + "H. Ehrig" "G. Levi" + "R. Kowalski" "U. Montanari" + "1987" "Springer-Verlag" + "1-22" "250" + "Lecture Notes in Computer Science" + + + "Eqlog: Equality, Types, and Generic Modules for Logic Programming" + "Joseph Goguen" + "Jos'{e} Meseguer" + "Logic Programming: Functions, Relations and Equations" + "Douglas DeGroot" "Gary Lindstrom" + "1986" "Prentice-Hall" + "295-363" + + + "Joseph Goguen" "Jos'{e} Meseguer" + + "Equality, Types, Modules and (Why Not?) Generics for Logic Programming" + "Journal of Logic Programming" + "1" "2" + "1984" "179-210" + + + "Specification Language {Z}" + "Jean-Raymond Abrial" "S. A. Schuman" + "Bertrand Meyer" "1979" + "Massachusetts Computer Associates" + + + "Unifying Functional, Object-Oriented and Relational Programming with Logical Semantics" + "Joseph Goguen" + "Jos'{e} Meseguer" + "Research Directions in Object-Oriented Programming" + "Bruce Shriver" "Peter Wegner" + "1987" "417-477" + "MIT Press" + + + "Order-Sorted Algebra Solves the Constructor Selector, Multiple Representation and Coercion Problems" + "Joseph Goguen" + "Jos'{e} Meseguer" + "Proceedings, Second Symposium on Logic in Computer Science" + "1987" "18-29" + "IEEE Computer Society Press" + "Extended version to appear in {it Information and Computation}" + + + "A Framework for Defining Logics" "R. Harper" + "F. Honsell" + "G. Plotkin" + "Proceedings, Second Symposium on Logic in Computer Science" + "1987" "194-204" + "IEEE Computer Society Press" + + + "How to Prove Algebraic Inductive Hypotheses without Induction: with Applications to the Correctness of Data Type Representations" + "Joseph Goguen" "1980" + + "Proceedings, Fifth Conference on Automated Deduction" + "Springer-Verlag" + "LNCS, Volume 87" "Wolfgang Bibel" + "Robert Kowalski" "356-373" + + + "Canonical Forms and Unification" + "Jean-Marie Hullot" "1980" + "Proceedings, Fifth Conference on Automated Deduction" + "Springer-Verlag" + "LNCS, Volume 87" "Wolfgang Bibel" + "Robert Kowalski" + "318-334" + + "{OBJ} as a Language for Concurrent Programming" + "Joseph Goguen" "Claude Kirchner" + "Jos'{e} Meseguer" + "Timothy Winkler" + "Proceedings, Second International Supercomputing Conference, Volume I" + "Steven Kartashev" + "Svetlana Kartashev" + "International Supercomputing Institute, Inc." + "1987" "195-198" + + + "Simulation of Concurrent Term Rewriting" + "Timothy Winkler" "Sany Leinwand" + "Joseph Goguen" + "Proceedings, Second International Supercomputing Conference, Volume I" + "Steven Kartashev" + "Svetlana Kartashev" + "International Supercomputing Institute, Inc." + "1987" "199-208" + + + "Architectural Options for the Rewrite Rule Machine" + "Sany Leinwand" "Joseph Goguen" + + "Proceedings, Second International Supercomputing Conference, Volume I" + "Steven Kartashev" + "Svetlana Kartashev" + "International Supercomputing Institute, Inc." + "1987" "63-70" + + + "Graphical Programming by Generic Example" + "Joseph Goguen" + "Proceedings, Second International Supercomputing Conference, Volume I" + "Steven Kartashev" + "Svetlana Kartashev" + "International Supercomputing Institute, Inc." + "1987" "209-216" + + + "Larch in Five Easy Pieces" "John Guttag" + "James Horning" + "Jeanette Wing" + "Digital Equipment Corporation, Systems Research Center" + "5" "1985" + "July" + "Mobile ambients" + "L. Cardelli" "A. D. Gordon" + + "Digital Equipment Corporation, Systems Research Center" + + "1997" + "Progress Report on the Rewrite Rule Machine" + "Joseph Goguen" "Claude Kirchner" + "Sany Leinwand" "Jos'{e} Meseguer" + "Timothy Winkler" + "1986" + "{IEEE} Computer Architecture Technical Committee Newsletter" + "March" "7-21" + + + "Compiling Pattern-Matching" "Lennart Augustsson" + + "University of GH{o}teborg, Programming Methodology Group" + "25" "September" + "1986" + + + "Epsilon-Reduction: Another View of Unification" + "Klaus Berkling" "Syracuse University" + "1986" + + + "Can Programming be Liberated from the von Neumann Style?" + "John Backus" "1978" + "Communications of the Association for Computing Machinery" + "21" "8" + "613-641" + + + "Operational Semantics of Order-Sorted Algebra" + "Joseph Goguen" + "Jean-Pierre Jouannaud" "Jos'{e} Meseguer" + "1985" "221-231" + + "Proceedings, 1985 International Conference on Automata, Languages and Programming" + "W. Brauer" "194" + "Lecture Notes in Computer Science" + "Springer-Verlag" + + + "Equations and Rewrite Rules: {A} Survey" + "G'{e}rard Huet" "Derek Oppen" + "1980" + "Formal Language Theory: Perspectives and Open Problems" + "Ron Book" "Academic Press" + + + "Initiality, Induction and Computability" + "Jos'{e} Meseguer" "Joseph Goguen" + "Algebraic Methods in Semantics" + "Maurice Nivat" "John Reynolds" + "Cambridge University Press" + "1985" "459-541" + + + "Computational semantics of term rewriting systems" + "G. Boudol" + "Algebraic Methods in Semantics" + "Maurice Nivat" "John Reynolds" + "Cambridge University Press" + "1985" "169-236" + + + "Deduction with Many-Sorted Rewrite Rules" + "Jos'{e} Meseguer" "Joseph Goguen" + "1985" "December" + + "Center for the Study of Language and Information, Stanford University" + "{CSLI}-85-42" + + + "Resource Control in a Demand-Driven Data-Flow Model" + "Bharadwaj Jayaraman" + "Robert Keller" "1980" + "{IEEE C}onference on Parallel Processing" + "August" "" "118-127" + + "Rediflow Multiprocessing" + "Robert Keller" + "F. C. H. Lin" "J. Tanaka" + "1984" "{IEEE C}ompcon" + "February" "" + + "410-417" + "A Loosely-Coupled Applicative Multi-Processing System" + "Robert Keller" "Gary Lindstrom" + "S. Patil" "1979" + "{AFIPS} Conference Proceedings" + "June" "" + "613-622" + "Cynthia Dwork" + "Paris Kanellakis" + "Larry Stockmeyer" + "Parallel Algorithms for Term Matching" "1986" + "{MIT}" + + + "Cynthia Dwork" "Paris Kanellakis" + "John Mitchell" + "On the Sequential Nature of Unification" + "Journal of Logic Programming" "1" + "1" "1984" + "35-50" "{MIT}" + + + "Laurent Fribourg" + "Oriented Equational Clauses as a Programming Language" + "Journal of Logic Programming" + "1" "2" "1984" + "179-210" + + + "Computations in Non-ambiguous Linear Term Rewriting Systems" + "G'{e}rard Huet" + "Jean-Jacques Levy" "{INRIA L}aboria" + "1979" + + + "Computational Semantics of Term Rewriting Systems" + "G'{e}rard Boudol" + "Algebraic Methods in Semantics" + "Maurice Nivat" "John Reynolds" + "Cambridge University Press" + "1985" "169-236" + + + "M. Bauderon" "Bruno Courcelle" + "Graph expressions and graph rewritings" + "1985" + "Universit'{e} de Bordeaux 1" + + + "Completion of a Set of Rules Modulo a Set of Equations" + "Jean-Pierre Jouannaud" + "helene Kirchner" "1984" + + "Proceedings 11th ACM Symposium on Principles of Programming Languages" + "To appear in {it {SIAM J}ournal of Computing}" + + + "Completion of a Set of Rules Modulo a Set of Equations" + "Jean-Pierre Jouannaud" + "helene Kirchner" "1986" + "November" "{SIAM} {Journal} of {Computing}" + "15" "1155-1194" + + "Lazy Memo-Functions" + "John Hughes" + "University of GH{o}teborg, Programming Methodology Group" + "21" "September" + "1985" + + + "Christoph M. Hoffmann" "Michael O'Donnell" + "Programming with Equations" + "Transactions on Programming Languages and Systems" + "1" "4" + "1982" "83-112" + "Association for Computing Machinery" + + + "Alberto Martelli" "Ugo Montanari" + "An efficient unification algorithm" + "Transactions on Programming Languages and Systems" + "4" "2" + "1982" "258-282" + "Association for Computing Machinery" + + "D. R. Jefferson" + "Virtual Time" + "Transactions on Programming Languages and Systems" + "7" "3" + "1985" "404-425" + "Association for Computing Machinery" + + "F. Wieland" + + "The performance of a distributed combat simulation with the time warp operating system" + "Concurrency: Practice and Experience" + "1" "1" + "1989" "35-50" + "John Wiley & Sons, Ltd." + + + "P. L. Reiher" "D. R. Jefferson" + "Dynamic Load Management in the Time Warp Operating System" + + "Transactions of the Society for Computer Simulation" + "7" "2" + "1990" "91-120" + + + "Algebras, Theories and Freeness: An Introduction for Computer Scientists" + "Rod Burstall" + "Joseph Goguen" "1982" + "Theoretical Foundations of Programming Methodology" + + "Proceedings, 1981 Marktoberdorf NATO Summer School, NATO Advanced Study Institute Series, Volume C91" + "Reidel" "329-350" + "Manfred Wirsing" + "Gunther Schmidt" + + + "John Reynolds" + "Using Category Theory to Design Implicit Conversions and Generic Operators" + "Semantics Directed Compiler Generation" + "Neal D. Jones" + "1980" "Springer LNCS 94" + "211-258" + + "Philip Wadler" + + "Views: {A} Way for Pattern Matching to Cohabit with Data Abstraction" + + "Proceedings, 14th Symposium on Principles of Programming Languages" + "Steve Munchnik" + "1987" "ACM" + "307-312" + "Modern Analytic Geometry" + "W. K. Morrill" + "S. M. Selby" "W. G. Johnson" + "1972" "Intext (Scranton PA)" + "third" + + + "Geometrical Constructions" "J{o}rgen Staunstrup" + "1982" + "Proceedings, Aarhus Workshop on Specification" + "J{o}rgen Staunstrup" + "Springer-Verlag" "25-30" + "LNCS, Volume 134" + + + "David Parnas" + "On the Criteria to be Used in Decomposing Systems into Modules" + + "Communications of the Association for Computing Machinery" + "15" "1053-1058" + + "1972" "Mitchell Wand" + "Final Algebra Semantics and Data Type Extension" + "1979" + "Journal of Computer and System Sciences" "19" + "27-44" + + + "Hiroto Yasuura" + "On the Parallel Computational Complexity of Unification" + "Yajima Lab" "ER 83-01" + "October" "1983" + + "Christoph Hoffmann" + "Michael O'Donnell" + "Robert Strandh" + "Implementation of an Interpreter for Abstract Equations" + "Software -- Practice and Experience" + "15" "12" + "1985" "December" + "1185-1204" "John Wiley and Sons" + + "Christoph M. Hoffmann" + "Michael O'Donnell" + "Pattern Matching in Trees" + "Journal of the Association for Computing Machinery" + "29" "1" + "1982" "68-95" + "Association for Computing Machinery" + + "Joseph Goguen" + "Rod Burstall" + "Institutions: Abstract Model Theory for Specification and Programming" + "Journal of the ACM" + "39" "1" "95-146" + "1992" + + "R. M. Karp" + "R. E. Miller" "S. Winograd" + + "The organization of computations for uniform recurrence equations" + + "Journal of the Association for Computing Machinery" + "14" "3" + "1967" "563-590" + "Association for Computing Machinery" + + "Mathew Hennessy" + "Robin Milner" + "Algebraic laws for nondeterminism and concurrency" + "Journal of the Association for Computing Machinery" + "32" "1" + "1985" "137-172" + "Association for Computing Machinery" + + + "Maarten H. van Emden" "Robert A. Kowalski" + + "The Semantics of Predicate Logic as a Programming Language" + "Journal of the Association for Computing Machinery" + "23" "4" + "1976" "733-742" + + + "Refutational Theorem Proving using Term Rewriting Systems" + "Jieh Hsiang" "1981" + "Univeristy of Illinois at Champaign-Urbana" + + + "An Algebraic Model of Subtypes in Object-Oriented Languages (Draft)" + "Kim Bruce" + "Peter Wegner" "SIGPLAN Notices" + "21" "10" + "163-172" "1986" "October" + + + "Completeness of Many-sorted Equational Logic" + "Joseph Goguen" "Jos'{e} Meseguer" + "SIGPLAN Notices" "16" + "7" "24-37" + "1981" "July" + + + "On understanding types, data abstracton and polymorphism" + "Luca Cardelli" "Peter Wegner" + "Computing Surveys" + "17" "471-522" "1985" + + + "Proofs by Induction in Equational Theories with Constructors" + "Gerard Huet" "Jean-Marie Hullot" + "Journal of Computing and System Sciences" + "25" "2" + "October" "1982" + "239-266" + "Preliminary version in Proceedings 21th Symposium on Foundations of Computer Science, IEEE, 1980" + + + "David Musser" + "On Proving Inductive Properties of Abstract Data Types" + + "Proceedings, 7th Symposium on Principles of Programming Languages" + "1980" + "Association for Computing Machinery" + + + "Claude Kirchner" + "{M}'{e}thodes et outils de conception syst'{e}matique d'algorithmes d'uni-fi-ca-tion dans les th'{e}ories '{e}quationnelles" + "l'Universit'{e} de Nancy 1" + + "1985" "Claude Kirchner" + "helene Kirchner" + "Reveur-3: implementation of a general completion procedure parameterized by built-in theories and strategies" + "Science of Computer Programming" + + "1986" "helene Kirchner" + "A general inductive completion algorithm and application to abstract data types" + + "Proceedings, 7th Conference on Automated Deduction" + "Springer-Verlag" + "LNCS, Volume 170" "282-302" + "1984" "helene Kirchner" + + "Preuves par compl'{e}tion dans les vari'{e}t'{e}s d'alg`{e}bres" + "Universit'{e} de Nancy 1" + "1985" + "Simple Word Problems in Universal Algebra" + "Donald Knuth" "P. Bendix" + "1970" + "Computational Problems in Abstract Algebra" + "J. Leech" "Pergamon Press" + + "Pierre Lescanne" + "Computer experiments with the {R}eve term rewriting systems generator" + + "Proceedings, 10th ACM Symposium on Principles of Programming Languages" + "ACM" "1983" + + + "{OBJ3}" "Kokichi Futatsugi" + "Joseph Goguen" + "Jean-Pierre Jouannaud" "Claude Kirchner" + "helene Kirchner" + "Jos'{e} Meseguer" "In preparation" + "1988" + + + "Joseph Goguen" "Joseph Tardo" + "{OBJ}-0 Preliminary Users Manual" + "1977" "UCLA" + "Semantics and Theory of Computation Report 10" + + + + "An Introduction to {OBJ}: {A} Language for Writing and Testing Software Specifications" + "Joseph Goguen" + "Joseph Tardo" "1979" + "Specification of Reliable Software" + "Marvin Zelkowitz" "IEEE Press" + "170-189" + "Reprinted in {it Software Specification Techniques}, Nehan Gehani and Andrew McGettrick, Eds., Addison-Wesley, 1985, pages 391-420" + + "Joseph Goguen" + + "Some Design Principles and Theory for {OBJ}-0, a Language for Expressing and Executing Algebraic Specifications of Programs" + + "Proceedings, Mathematical Studies of Information Processing" + "Edward Blum" + "Manfred Paul" "Satsoru Takasu" + "Springer-Verlag" "1979" + + "LNCS, Volume 75; Proceedings of a Workshop held August 1978" + "425-473" + "A Practical Method for Testing Algebraic Specifications" + "Joseph Goguen" "Joseph Tardo" + "Norman Williamson" + "Maria Zamfir" "1979" + "UCLA Computer Science Department Quarterly" + "7" "1" "59-80" + + + "The Design, Specification and Implementation of {OBJT}: {A} Language for Writing and Testing Abstract Algebraic Program Specifications" + "Joseph Tardo" "1981" + "UCLA, Computer Science Department" + + + "Joseph Goguen" "Jos'{e} Meseguer" + + "Rapid Prototyping in the {OBJ} Executable Specification Language" + "Software Engineering Notes" + + "Association for Computing Machinery, Special Interest Group on Software Engineering" + "1982" "December" + "7" "5" + "75-84" + "Proceedings of Rapid Prototyping Workshop" + + + "Programming with Parameterized Abstract Objects in {OBJ}" + "Joseph Goguen" + "Jos'{e} Meseguer" "David Plaisted" + "Theory and Practice of Software Technology" + "Domenico Ferrari" + "Mario Bolognani" "Joseph Goguen" + "1983" "163-193" + "North-Holland" + + + "Parameterized Programming" "Joseph Goguen" + "Transactions on Software Engineering" + "1984" "September" + "IEEE" "SE-10" + "5" "528-543" + + + "A relational notation for state transition systems" + "S. S. Lam" "A. U. Shankar" + "Transactions on Software Engineering" + "1990" "July" + "IEEE" "SE-16" + "7" "755-775" + + "Kokichi Futatsugi" + "Joseph Goguen" + "Jos'{e} Meseguer" "Koji Okada" + "Parameterized Programming in {OBJ2}" + + "Proceedings, Ninth International Conference on Software Engineering" + "Robert Balzer" + "IEEE Computer Society Press" "1987" + "March" "51-60" + + "S. Nakajima" + "K. Futatsugi" + "An object-oriented modeling method for algebraic specifications in {CafeOBJ}" + + "Proceedings, 19th International Conference on Software Engineering" + "IEEE Computer Society Press" + "1997" "May" + "34-44" + + + "Kokichi Futatsugi" "Joseph Goguen" + "Jos'{e} Meseguer" + "Koji Okada" + "Parameterized Programming and its Application to Rapid Prototyping in {OBJ2}" + + "Japanese Perspectives in Software Engineering" + "Y. Matsumoto" "Y. Ohno" + "Addison-Wesley" + "1989" "77-102" + + "Writing Programs in {OBJ2}" + "Steffan Bonnier" + "Department of Computer and Information Science, Linkoping University, Linkoping, Sweden" + "1987" + + + + "The Design of a Rewrite Rule Interpreter from Algebraic Specifications" + "Derek Coleman" + "Robin Gallimore" "Victoria Stavridou" + "IEE Software Engineering Journal" + "95-104" "1987" + "July" + + + "{UMIST OBJ} Manual, Version 1.0" "Colin Walter" + "Derek Coleman" + "Robin Gallimore" "Victoria Stavridou" + "UMIST, Manchester, England" + "1986" + + + + "The Design of a Rewrite Rule Interpreter from Algebraic Specifications" + "Derek Coleman" + "Robin Gallimore" "Victoria Stavridou" + "IEE Software Engineering Journal" + "95-104" "1987" + "July" + + + "Specifying in {OBJ}, Verifying in {REVE}, and Some Ideas about Time" + "Victoria Stavridou" + + "Department of Computer Science, University of Manchester" + "1987" "Draft" + + + "An Implementation of {OBJ2}: An Object-Oriented Language for Abstract Program Specification" + "S. Sridhar" + "Proceedings, Sixth Conference on Foundations of Software Technology and Theoretical Computer Science" + "K. V. Nori" + "Springer-Verlag" "1986" + "81-95" "LNCS, Volume 241" + + + "{MC-OBJ}: a {C} Interpreter for {OBJ}" + "C. Cavenathi" "M. De Zanet" + "Giancarlo Mauri" + "Note di Software" "36/37" + + "Dipmentarto Scienze dell'Informazione, Universita de Milano" + "1988" "October" + "16-26" "In Italian" + + "An Introduction to {OBJ3}" + "Joseph Goguen" + "Claude Kirchner" "H'{e}l`{e}ne Kirchner" + "Aristide M'{e}grelis" + "Jos'{e} Meseguer" + "Timothy Winkler" + "Proceedings, Conference on Conditional Term Rewriting, Orsay, France, July 8-10, 1987" + "Jean-Pierre Jouannaud" + "Stephane Kaplan" + "Springer LNCS 308" "258-263" + "1988" + "Confluence of conditional rewrite systems" + "N. Dershowitz" "M. Okada" + "G. Sivakumar" + "Proceedings, Conference on Conditional Term Rewriting, Orsay, France, July 8-10, 1987" + "Jean-Pierre Jouannaud" + "Stephane Kaplan" + "Springer-Verlag, LNCS No. 308" "31-44" + "1988" + + + "A completion procedure for conditional equations" + "H. Ganzinger" + "Proceedings, Conference on Conditional Term Rewriting, Orsay, France, July 8-10, 1987" + "Jean-Pierre Jouannaud" + "Stephane Kaplan" + "Springer-Verlag, LNCS No. 308" "62-83" + "Final version will appear in J. Symb. Comp." + "1988" + + + "Notes on the elimination of conditions" + "E. Giovannetti" "C. Moiso" + + "Proceedings, Conference on Conditional Term Rewriting, Orsay, France, July 8-10, 1987" + "Jean-Pierre Jouannaud" + "Stephane Kaplan" + "Springer-Verlag, LNCS No. 308" "91-97" + "1988" + + + "Operational Semantics of {OBJ3}" + "Claude Kirchner" "H'el`ene Kirchner" + "Jos'{e} Meseguer" + "Proceedings, 15th Intl. Coll. on Automata, Languages and Programming, Tampere, Finland, July 11-15, 1988" + "T. Lepist{\"{o}}" + "A. Salomaa" "Springer LNCS 317" + "287-301" "1988" + + + "Simple Examples of Parameterized Programming in {OBJ2}" + "Kokichi Futatsugi" + "Proceedings, Summer Programming Symposium" + "Information Processing Society of Japan" + "1986" "55-61" + + "An Overview of {OBJ2}" + "Kokichi Futatsugi" + "Proceedings, France-Japan AI and CS Symposium" + "Kazuhiru Fuchi" "Maurice Nivat" + "ICOT" + "Also, Information Processing Society of Japan, Technical Memorandum PL-86-6" + "1986" + + + "Natural semantics on the computer" "D. Cl'ement" + "J. Despeyroux" + "L. Hascoet" "G. Kahn" + "Proceedings, France-Japan AI and CS Symposium" + "Kazuhiru Fuchi" + "Maurice Nivat" "49-89" + "ICOT" + "Also, Information Processing Society of Japan, Technical Memorandum PL-86-6" + "1986" + + + + "Algebraic Specification of {M}acintosh's {Q}uick{D}raw Using {OBJ2}" + "Ataru Nakagawa" + "Kokichi Futatsugi" "S. Tomura" + "T. Shimizu" + "ElectroTechnical Laboratory, Tsukuba Science City, Japan" + "1987" "Draft" + + "To appear, {it Proceedings}, Tenth International Conference on Software Engineering, Singapore, April 1988" + + + "Abstract Pascal: {A} Tutorial Introduction" + "John T. Latham" "1987" + "Version 2.1" + "University of Manchester, Department of Computer Science" + + + "The Specification and Controlled Implementation of a Configuration Management Tool using {OBJ} and {A}da" + "Christopher Paul Gerrard" + "Experience with {OBJ}" + "Derek Coleman" "Robin Gallimore" + "Joseph Goguen" "Addison-Wesley" + "1988" "To appear" + + "{OBJ} for {OBJ}" + "Claude Kirchner" "helene Kirchner" + "Aristide Megrelis" + "Experience with {OBJ}" + "Derek Coleman" "Robin Gallimore" + "Joseph Goguen" "Addison-Wesley" + "1988" "To appear" + + + "{OBJSA} Net Systems: a Class of High-Level Nets having Objects as Domains" + "E. Battiston" + "F. DeCindio" "Giancarlo Mauri" + "Experience with {OBJ}" + "Derek Coleman" "Robin Gallimore" + "Joseph Goguen" "Addison-Wesley" + "1988" "To appear" + + + "Concerning the Compatibility of {PHIGS} and {GKS}" + "D. A. Duce" + "Experience with {OBJ}" "Derek Coleman" + "Robin Gallimore" + "Joseph Goguen" "Addison-Wesley" + "1988" "To appear" + + + "Using Mathematical Tools to Aid System Development" + "Martin Loomes" "Richard Mitchell" + "Experience with {OBJ}" + "Derek Coleman" "Robin Gallimore" + "Joseph Goguen" + "Addison-Wesley" "1988" + "To appear" + "A Brief History of {OBJ}" + "Joseph Goguen" + "Experience with {OBJ}" "Derek Coleman" + "Robin Gallimore" + "Joseph Goguen" "Addison-Wesley" + "1988" "To appear" + + + "Higher-Order Functions Considered Unnecessary for Higher-Order Programming" + "Joseph Goguen" + "Proceedings, Univeristy of Texas Year of Programming, Institute on Declarative Programming" + "David Turner" + "Addison-Wesley" "1988" + "To appear" + + "Actors: {A} Model of Concurrent Computation in Distributed Systems" + "Gul Agha" "1986" + "MIT Press" + + + "G. Agha" + "Abstracting Interaction Patterns: {A} Programming Paradigm for Open Distribute Systems" + + "Formal Methods for Open Object-based Distributed Systems" + "E. Najm" "J-B. Stefani" + "1997" "135-153" + "Chapman & Hall" + + + "Foundations of Actor Semantics" "Will Clinger" + "1981" + "Massachusetts Institute of Technology, Artificial Intelligence Laboratory" + "Technical Report {AI-TR-633}" + + + "Computational Aspects of {VLSI}" + "Jeffrey Ullman" "1983" + "Computer Science Press" + + + "An Abstract Machine for Fast Parallel Matching of Linear Patterns" + "Ugo Montanari" + "Joseph Goguen" "1987" + "May" + "Computer Science Laboratory, SRI International" + "SRI-CSL-87-3" + + + "Recherches sur la Th'eorie de la {D}'emonstration" + "Jacques Herbrand" + "Travaux de la Soci'et'e des Sciences et des Lettres de Varsovie, Classe III" + "33" "128" + "1930" + + + "Functorial Semantics of Algebraic Theories" + "F. William Lawvere" "1963" + "Proceedings, National Academy of Sciences" + "50" "869-873" + "Summary of Ph.D. Thesis, Columbia University" + + + "Categories for the Working Mathematician" + "Saunders Mac Lane" "1971" + "Springer-Verlag" + + + "Topoi, The Categorial Analysis of Logic" + "Robert Goldblatt" "1979" + "North-Holland" + + "Categories" + "Horst Schubert" "1972" + "Springer-Verlag" + + + "J. Alan Robinson" + "A Machine-Oriented Logic Based on the Resolution Principle" + "1965" + "Journal of the Association for Computing Machinery" + "12" "23-41" + + + "Order-Sorted Unification" + "Jos'{e} Meseguer" "Joseph Goguen" + "Gert Smolka" "1989" + "J. Symbolic Computation" "8" + "383-413" + + + "Basic narrowing revisited" "Werner Nutt" + "Pierre R'ety" + "Gert Smolka" "1989" + "J. Symbolic Computation" "7" + + "295-317" + "Computational Category Theory" "David Rydeheard" + "Rod Burstall" "1988" + "Prentice-Hall" + "To appear" + + "On the Theory of Specification, Implementation and Parameterization of Abstract Data Types" + "Hans-Dieter Ehrich" + "1982" + "Journal of the Association for Computing Machinery" + "29" "206-227" + + + "Hans-Dieter Ehrich" "Udo Lipeck" + "Algebraic Domain Equations" + "Theoretical Computer Science" + "27" "1983" "167-196" + + "Dana Scott" + "Outline of a Mathematical Theory of Computation" + "1970" + "Proceedings, Fourth Annual Princeton Conference on Information Sciences and Systems" + + "Also appeared as Technical Monograph PRG 2, Oxford University, Programming Research Group" + "Princeton University" + "169-176" + + + "Dana Scott" + "Lattice Theory, Data Types and Semantics" + "Formal Semantics of Algorithmic Languages" + "Randall Rustin" "1972" + "Prentice Hall" "65-106" + + + "Remarks on Remarks on Many-Sorted Equational Logic" + "Joseph Goguen" "Jos'{e} Meseguer" + + "Bulletin of the European Association for Theoretical Computer Science" + "30" "October" + "1986" "66-73" + + "Also in {it SIGPLAN Notices}, Volume 22, Number 4, pages 41-48, April 1987" + + + "On a categorical tensor calculus for automata" + "Jos'{e} Meseguer" "Ignacio Sols" + + "Bull. Acad. Polon. Sci., ser. math. astr. et phys." + "23" "1975" + "1161-1166" + + "Order-Sorted Equational Computation" + "Gert Smolka" "Werner Nutt" + "Joseph Goguen" "Jos'{e} Meseguer" + + "Resolution of Equations in Algebraic Structures" + "2" "297-367" + "Maurice Nivat" + "Hassan A{\"{i}}t-Kaci" "Academic Press" + "1989" + + + "Completion algorithms for conditional rewriting systems" + "S. Kaplan" "J.-L. R'{e}my" + + "Resolution of Equations in Algebraic Structures" + "2" "141-170" + "Maurice Nivat" + "Hassan A{\"{i}}t-Kaci" "Academic Press" + "1989" + + + "Thomas Johnsson" + "Target code generation from {G}-machine code" + "Graph Reduction" "Joseph Fasel" + "Robert Keller" + "LNCS, Volume 279" "Springer-Verlag" + "119-159" "1987" + + "Richard Kieburtz" + "The {G}-machine: a fast, graph-reduction evaluator" + + "Proceedings, Conference on Functional Programming Languages and Computer Architecture" + "400-413" + "Jean-Pierre Jouannaud" "LNCS, Volume 201" + "Springer-Verlag" + "1985" + "A. Appel" + "D. Mac{Queen}" "A {Standard} {ML} compiler" + + "Proceedings, Conference on Functional Programming Languages and Computer Architecture" + "LNCS, Volume 274" + "Springer-Verlag" "301-324" + "1987" + "Peter Canning" "William Cook" + "Walt Hill" "John Mitchell" + "Walter Olthoff" + "{F}-Bounded Quantification for Object-Oriented Programming" + + "Proceedings, Conference on Functional Programming Languages and Computer Architecture" + "David MacQueen" + "LNCS" "Springer-Verlag" + + "1989" "Unification Theory" + "{J\"{o}rg} Siekmann" + "To appear in {it Journal of Symbolic Computation}" + "1988" + "Preliminary Version in {it Proceedings}, European Conference on Artificial Intelligence, Brighton, 1986" + + + "What is Unification? | {A} Categorical View of Substitution, Equation and Solution" + "Joseph Goguen" + "Resolution of Equations in Algebraic Structures" + "Maurice Nivat" + "Hassan A{\"{i}}t-Kaci" "Academic Press" + "217-261" "1989" + + + "Foundations of Logic Programming" "John Lloyd" + "Springer-Verlag" + "1984" + + "Hope: an Experimental Applicative Language" + "Rod Burstall" "David MacQueen" + "Donald Sannella" "1980" + "Proceedings, First LISP Conference" + "Stanford University" + "136-143" "1" + + + "Etude et {R}'ealisation d'un Syst`eme {Prolog}" + "A. Colmerauer" "H. Kanoui" + "M. van Caneghem" + "Groupe d'Intelligence Artificielle, U.E.R. de Luminy, Universit'e d'Aix-Marseille II" + "1979" + + + "Unification in Many-sorted Equational Theories" + + "Proceedings, 8th International Conference on Automated Deduction" + "Manfred Schmidt-Schauss" + "Springer-Verlag" "1986" + "538-552" + "LNCS, Volume 230" + + "Computational aspects of order-sorted logic with term declarations" + "Manfred Schmidt-Schauss" + "Springer LNCS 395" "1989" + + + "A Classification of Many-Sorted Unification Theories" + + "Proceedings, 8th International Conference on Automated Deduction" + "Christoph Walther" + "Springer-Verlag" "1986" + "525-537" + "LNCS, Volume 230" + + "Building-in Equational Theories" + "Gordon Plotkin" "Machine Intelligence" + "7" "1972" + "November" + "Edinburgh University Press" "73-90" + + + "An Introduction to Unification-Based Approaches to Grammar" + "Stuart Shieber" "1986" + "Center for the Study of Language and Information" + + + "Prolog and Infinite Trees" "Alain Colmerauer" + "Logic Programming" + "Keith Clark" + "Sten-{AA}ke T{\"{a}}rnlund" "1982" + "231-251" "Academic Press" + + + "A Lattice-Theoretic Approach to Computation Based on a Calculus of Partially-Ordered Type Structures" + "Hassan Ait-Kaci" "1984" + "University of Pennsylvania" + + + "An Algebraic Semantics Approach to the Effective Resolution of Type Equations" + "Hassan Ait-Kaci" "1986" + "Theoretical Computer Science" + "45" "293-351" + + + "Inheritance Hierarchies: Semantics and Unification" + "Gert Smolka" + "Hassan A{\"{i}}t-Kaci" "1989" + "Journal of Symbolic Computation" + "7" "343-370" + + "Data Types" + "Daniel Lehmann" + "Michael Smyth" "The University of Warnick" + "1977" "May" + "19" + "Theory of Computation Report" + + + "Unification over Complex Indeterminates in Prolog" + "Kuniaki Mukai" "1985" + "ICOT" "TR-113" + + "Mitchell Wand" + "On the Recursive Specification of Data Types" + + "Proceedings, Symposium on Category Theory Applied to Computation and Control" + "Ernest Manes" + "214-217" "Springer-Verlag" + "LNCS, Volume 25" "1975" + + + "Some Fundamental Algebraic Tools for the Semantics of Computation, Part 1: Comma Categories, Colimits, Signatures and Theories" + "Joseph Goguen" + "Rod Burstall" "1984" + "Theoretical Computer Science" "31" + "2" "175-209" + + + "A Unification Algorithm for Associative-Commutative Functions" + "Mark Stickel" + "Journal of the Association for Computing Machinery" + "28" "1981" + "423-434" + + "Structures Alg'ebriques dans les Cat'egories" + "Jean B'{e}nabou" + "Cahiers de Topologie et G'eometrie Diff'erentielle" + "10" "1-126" + "1968" + + "Structures defined by finite limits in the enriched context, {I}" + "G. M. Kelly" + "Cahiers de Topologie et G'eometrie Diff'erentielle" + "23" "3-42" + "1982" + + "The Category-Theoretic Solution of Recursive Domain Equations" + "Michael Smyth" + "Gordon Plotkin" "1982" + "11" "761-783" + "{SIAM} Journal of Computation" + "Also Technical Report D.A.I. 60, University of Edinburgh, Department of Artificial Intelligence, December 1978" + + + "Functional Analysis" "Kosaku Yosida" + "1968" "Second Edition" + "Springer-Verlag" + + + "Ernest Manes" "Algebraic Theories" + "1976" "Springer-Verlag" + "Graduate Texts in Mathematics, Volume 26" + + + "A Theory of Type Polymorphism in Programming" + "Robin Milner" + "Journal of Computer and System Sciences" "17" + "3" "1978" + + "348-375" "Edinburgh {LCF}" + "Michael Gordon" "Robin Milner" + "Christopher Wadsworth" + "Springer-Verlag" "1979" + "LNCS, Volume 78" + + + "Logic and Data Bases" "Herve Gallaire" + "Jack Minker" "1978" + "Plenum Press" + + + "Logic Programming: Functions, Relations and Equations" + "Douglas DeGroot" "Gary Lindstrom" + "1986" "Prentice-Hall" + + + "{HOL}: {A} Machine Oriented Formulation of Higher-Order Logic" + "Michael Gordon" "1985" + "July" "85" + "University of Cambridge, Computer Laboratory" + + + "Characterization of Computable Data Types by Means of a Finite Equational Specification Method" + "Jan Bergstra" + "John Tucker" + "Automata, Languages and Programming, Seventh Colloquium" + "Springer-Verlag" "1980" + "J. W. de Bakker" + "J. van Leeuwen" "76-90" + "LNCS, Volume 81" + "Permutation of transitions: an event structure semantics for {CCS} and {SCCS}" + "G'erard Boudol" + "Illaria Castellani" + "Linear Time, Branching Time and Partial Order in Logics and Models for Concurrency" + "Springer-Verlag" + "1988" "J. W. de Bakker" + "W.-P. de Roever" "G. Rozenberg" + "411-427" + "LNCS, Volume 354" + "Algebraic Specifications of Computable and Semicomputable Data Structures" + "Jan Bergstra" + "John Tucker" "1987" + "To appear in {it Theoretical Computer Science}; originally, Preprint IW 115, Mathematisch Centrum, Department of Computer Science, Amsterdam, August 1979" + + + "A view of systolic design" + "Christian Lengauer" "1991" + "To appear in Proc. of {it Parallel Computing Technologies}, Novosibirsk, USSR, September 1991" + + + "Completeness of Proof Systems for Equational Specifications" + "David MacQueen" "Donald Sannella" + "IEEE Transactions on Software Engineering" + "1985" "SE-11" + "5" "May" + + "454-461" + "The mapping of linear recurrence equations on regular arrays" + "P. Quinton" "V. van Dongen" + "J. VLSI Signal Processing" + "1989" "1" + "2" "October" "95-113" + + + "On the Structure of Abstract Algebras" + "Garrett Birkhoff" "1935" + "Proceedings of the Cambridge Philosophical Society" + "31" "433-454" + + + "Completeness of Many-sorted Equational Logic" + "Joseph Goguen" "Jos'{e} Meseguer" + "1985" + "Houston Journal of Mathematics" "11" + "3" "307-334" + + "Preliminary versions have appeared in: {it SIGPLAN Notices}, July 1981, Volume 16, Number 7, pages 24-37; SRI Computer Science Laboratory Technical Report CSL-135, May 1982; and Report CSLI-84-15, Center for the Study of Language and Information, Stanford University, September 1984" + + + "Inductive Methods for Reasoning about Abstract Data Types" + "Stephen Garland" "John Guttag" + + "Proceedings, Fifteenth Symposium on Principles of Programming Languages" + "1988" "January" + "ACM" "219-229" + + "A Computational Logic" + "Robert Boyer" "J Moore" + "Academic Press" + "1980" + + "A {P}rolog Technology Theorem Prover" + "Mark Stickel" + "First International Symposium on Logic Programming" + "Association for Computing Machinery" + "1984" "February" + + + "Social Processes and Proofs of Theorems and Programs" + "R. A. DeMillo" "Richard Lipton" + "Alan Perlis" "1977" + + "Proceedings, Fourth Symposium on Principles of Programming Languages" + "Association for Computing Machinery" + "206-214" + + + "Logic and Computation: Interactive Proof with {C}ambridge {LCF}" + "Lawrence Paulson" + "Cambridge University Press" "1987" + "Cambridge Tracts in Theoretical Computer Science, Volume 2" + + + "Department of Defense" + "Reference Manual for the Ada Programming Language" + "United States Government, Report ANSI/MIL-STD-1815 A" + "1983" + + + "Kokichi Futatsugi" "Koji Okada" + + "Specification Writing as Construction of Hierarchically Structured Clusters of Operators" + "Information Processing '80" + "IFIP Press" "1980" + "287-292" + "Proceedings of 1980 IFIP Congress" + + "H. G. Baker" + "C. Hewitt" + "Laws for communicating parallel processes" + "Proceedings of the 1977 IFIP Congress" + "IFIP Press" "1977" + "987-992" + + "Kokichi Futatsugi" "Koji Okada" + + "A Hierarchical Structuring Method for Functional Software Systems" + + "Proceedings, Sixth International Conference on Software Engineering" + "IEEE Press" + "1982" "393-402" + + + "Abstract Specification of Data Types" + "Steven Zilles" "1974" + "Computation Structures Group, MIT" + "119" + + + "Stop Losing Sleep over Incomplete Data Type Specification" + "Jean-Jacques Thiel" + "Proceedings, Eleventh Symposium on Principles of Programming Languages" + "Ken Kennedy" + "Association for Computing Machinery" "1984" + + "Reiji Nakajima" + "T. Yuasa" + "The {IOTA} Programming System" "1983" + "Springer-Verlag" + "LNCS, Volume 160" + "Graham Birtwistle" + "Ole-Johan Dahl" "Bjorn Myhrhaug" + "Kristen Nygaard" + "Simula underline{Begin}" "1979" + "Charwell-Bratt Ltd" + + + "The {SIMULA} 67 Common Base Language" + "Ole-Johan Dahl" "Bjorn Myhrhaug" + "Kristen Nygaard" "1970" + "Norwegian Computing Center, Oslo" + "Publication S-22" + + + "Logic for Problem Solving" "Robert Kowalski" + + "Department of Artificial Intelligence, University of Edinburgh" + "1974" "DCL Memo 75" + + "Also, a book in the Artificial Intelligence Series, North-Holland Press, 1979" + + + "Source Level Tools for Logic Programming" + "Richard O'Keefe" "1985" + "Symposium on Logic Programming" + "IEEE" "68-72" + + + "A Study in the Foundations of Programming Methodology: Specifications, Institutions, Charters and Parchments" + "Joseph Goguen" + "Rod Burstall" + "Proceedings, Conference on Category Theory and Computer Programming" + "David Pitt" + "Samson Abramsky" "Axel Poign'{e}" + "David Rydeheard" + "Springer-Verlag" "1986" + "313-333" + "LNCS, Volume 240; also, Report Number CSLI-86-54, Center for the Study of Language and Information, Stanford University, June 1986" + + "Introducing Institutions" + "Joseph Goguen" + "Rod Burstall" "Logics of Programs" + "Edmund Clarke" + "Dexter Kozen" "Springer-Verlag" + "1984" "221-256" + "LNCS, Volume 164" + + + "One, None, {A} Hundred Thousand Specification Languages" + "Joseph Goguen" "1986" + "Information Processing '86" + "H.-J. Kugler" "Proceedings of 1986 IFIP Congress" + "Elsevier" + "995-1003" + "Unification Revisited" + "Foundations of Deductive Databases and Logic Programming" + "Jack Minker" + "Jean-Louis Lassez" "Michael Maher" + "Kimbal Marriott" + "1988" "587-625" + "Morgan Kaufmann" + + + "Unification in Categories" + "Several Aspects of Unification" + "Toshiaki Kurokawa" "Takanori Adachi" + "1984" "35-43" + "ICOT, Technical Report TM-0029" + + + "Formal Philosophy: Selected Papers of Richard Montague" + "Richard Montague" + "Yale University Press" "1974" + "Edited and with an introduction by Richard Thomason" + + + "Peter van Emde Boas" "Theo Janssen" + + "The Impact of Frege's Principle of Compositionality for the Semantics of Programming and Natural Languages" + + "University of Amsterdam, Department of Mathematics" + "79-07" "1979" + + + "Why Higher-Order Logic is a Good Formalism for Specifying and Verifying Hardware" + "Formal Aspects of {VLSI} Design" + "George Milne" + "P. A. Subrahmanyam" "Michael Gordon" + "1986" "North-Holland" + + + "Hardware Verification Using Higher-Order Logic" + "Albert Camilleri" "Michael Gordon" + "Tom Melham" "1986" + "June" "91" + "University of Cambridge, Computer Laboratory" + + + "Compiling for the Rewrite Rule Machine" + "Hitoshi Aida" "Joseph Goguen" + "Jos'e Meseguer" "In preparation" + + "Fairness in term rewriting systems" + "Sara Porat" "Nissim Francez" + "Manuscript, Technion, May 3, 1990." + + + "Implementing Term Rewriting by Graph Reduction: Termination of Combined Systems" + "Detlef Plump" + "To appear in S. Kaplan and M. Okada (eds.) Proc. Intl. Workshop on Conditional and Typed Rewriting Systems, Montreal, Canada, June 1990, Springer LNCS" + + + "Compiling Concurrent Rewriting onto the Rewrite Rule Machine" + "Hitoshi Aida" "Joseph Goguen" + "Jos'e Meseguer" + "S. Kaplan" "M. Okada" + + "Conditional and Typed Rewriting Systems, Montreal, Canada, June 1990" + "Springer LNCS 516" + "320-332" "1991" + + + + "Conditional rewriting logic: deduction, models and concurrency" + "Jos'e Meseguer" + "S. Kaplan" "M. Okada" + + "Conditional and Typed Rewriting Systems, Montreal, Canada, June 1990" + "Springer LNCS 516" + "64-91" + "Also Technical Report SRI-CSL-90-14, SRI International, Computer Science Laboratory, November 1990" + "1991" + + + + "Transforming Conditional Rewrite Rules into Unconditional Ones" + "Hitoshi Aida" + "Jos'e Meseguer" "In preparation" + + "The Rewrite Rule Machine" + "Joseph Goguen" + "Jos'{e} Meseguer" "Sany Leinwand" + "Timothy Winkler" "Hitoshi Aida" + + "SRI International, Computer Science Laboratory" + "1989" "March" + "SRI-CSL-89-6" + "Arvind" + "D. E. Culler" "Dataflow Architectures" + "Annual Reviews in Computer Science" + + "1986" + "H. P. Barendregt" "M. C. J. D. van Eekelen" + "J. R. W. Glauert" + "J. R. Kennaway" "M. J. Plasmeijer" + "M. R. Sleep" + "Towards an Intermediate Language Based on Graph Rewriting" + "Proceedings, PARLE Conference" + "LNCS, Volume 259" "Springer-Verlag" + "1987" + + + "J. R. W. Glauert" "J. R. Kennaway" + "M. R. Sleep" + "Specification of {Dactl}" + "School of Information Systems, University of East Anglia" + "1987" + + "R. Kennaway" + "Graph Rewriting in Some Categories of Partial Morphisms" + + "School of Information Systems, University of East Anglia" + "1990" + + + "A Categorical Construction for Generalised Graph Rewriting" + "J. R. W. Glauert" + "J. R. Kennaway" + "Submitted to PARLE 89 conference" + + + "Simon L Peyton Jones" "Chris Clack" + "Jon Salkild" + "Mark Hardie" + "{GRIP} - a high-performance architecture for parallel graph reduction" + + "Proceedings, IFIP Conference on Functional Programming Languages and Computer Architecture" + "Portland" + "G. Kahn" "LNCS, Volume 274" + "Springer-Verlag" "98-112" + "September" "1987" + + "B. Jayaraman" + "D. Plaisted" + "Functional programming with sets" + "Proceedings, IFIP Conference on Functional Programming Languages and Computer Architecture" + "Portland" + "G. Kahn" "LNCS, Volume 274" + "Springer-Verlag" "194-210" + "September" "1987" + + + "A Network of Microprocessors to Execute Reduction Languages" + "Gulyo Mag'o" + "International Journal of Computer and Information Sciences" + "8" "5 and 6" + "1979" "349--358 and 435--481" + + + "The {FFP} Machine -- {A} Progress Report" + "Gulyo Mag'o" "D. Middleton" + + "Proceedings, International Workshop on High-level Computer Architecture" + "IEEE Press" + "5.13--5.25" "1984" + + + "G. Wiederhold" + "Mediators in the Architecture of Future Information Systems" + "IEEE Computer" "1992" + "25" "3" + "38-49" "March" + + + "G. Wiederhold" "P. Wegner" + "S. Ceri" "Toward Megaprogramming" + "Communications of the ACM" + "1992" "35" + "11" "89-99" "November" + + "P. Mills" + "L. Nyland" "J. Prins" + "J. Reif" + "Prototyping high performance parallel computing applications in Proteus" + + "Proceedings of 1992 DARPA Software Conference" + "1992" "433-442" + "DARPA" + "N. J. Pelc" + "R. J. Herfkens" + "A. Shimakawa" "D. R. Enzmann" + "Phase Contrast Cine Magnetic Resonance Imaging" + "Magnetic Resonance Quarterly" + "1991" "7" "229-254" + + + "N. J. Pelc" "F. G. Sommer" + "D. R. Enzmann" "L. R. Pelc" + "G. H. Glover" + "Accuracy and Precision of Phase-Contrast {MR} Flow Measurements" + "77th {RSNA}, Radiology 189" + "1991" "Chicago, Illinois" + + "S. Napel" + "D. H. Lee" + "R. Frayne" "B. K. Rutt" + + "Visualizing Three-Dimensional Flow with Simulated Streamlines and Three-Dimensional Phase-Contrast {MR} Imaging" + "J. Magn. Reson. Imaging" + "1992" "2" + "143-53" + "C. A. Pelizzari" + "G. T. Chen" + "D. R. Spelbring" "R. R. Weichselbaum" + "C. T. Chen" + "Accurate Three-Dimensional Registration of {CT}, {PET}, and/or {MR} Images of the Brain" + "J. Comput. Assist. Tomogr." + "1989" "13" + "20-6" + "P. van den Elsen" + "E.-J. D. Pol" + "T. S. Sumanaweera" "P. F. Hemler" + "S. Napel" "J. R. Adler" + + "Grey Value Correlation Techniques Used for Automatic Matching of {CT} and {MR} Brain and Spine Images" + "Manuscript" "1994" + + + "E. Astesiano" "M. Cerioli" + + "Free Objects and Equational Deduction for Partial Conditional Specifications" + + "Dipartimento de Matematica, University of Genova" + "1990" "3" + + "E. Astesiano" + "M. Cerioli" + "Partial Higher-Order Specifications" + "Fundamenta Informaticae" "1992" + "16" "2" + "101-126" + "E. Astesiano" + "M. Cerioli" + "Relationships between Logical Frameworks" + "Recent Trends in Data Type Specification" + "1993" "M. Bidoit" + "C. Choppy" "126-143" + "Springer-Verlag" "655" + "LNCS" + + + "A. Avron" "F. Honsell" + "I. A. Mason" + "R. Pollack" + "Using Typed Lambda Calculus to Implement Formal Systems on a Machine" + "Journal of Automated Reasoning" + "1992" "9" + "3" "309-354" "December" + + "M. Barr" + "C. Wells" + "Category Theory for Computing Science" + "Prentice-Hall" "1990" + + + "D. A. Basin" "R. L. Constable" + "Metalogical Frameworks" + "Logical Environments" "1993" + "G. Huet" "G. Plotkin" + "1-29" + "Cambridge University Press" + + + "M. Bidoit" "H.-J. Kreowski" + "P. Lescanne" "F. Orejas" + "D. Sannella" + "Algebraic System Specification and Development. {A} Survey and Annotated Bibliography" + "Springer-Verlag" + "1991" "501" "LNCS" + + + "M. P. Bonacina" "J. Hsiang" + + "A Category Theory Approach to Completion-Based Theorem Proving Strategies" + + "Unpublished manuscript presented at {em Category Theory 1991}, Mc Gill University, Montr'eal, Canada" + "1991" + + "M. Broy" + "M. Wirsing" + "Partial Abstract Types" "Acta Informatica" + "1982" "18" + "47-64" + + "U. Montanari" + "F. Rossi" + "Contextual nets" "Acta Informatica" + "1995" "32" + "545-596" + + + "L. Cardelli" "G. Longo" + "A Semantic Basis for {Q}uest" + "Journal of Functional Programming" "1991" + "1" "4" + "417-458" "M. Cerioli" + "Relationships between Logical Formalisms" + + "Technical Report TD-4/93, Dipartimento di Informatica, Universit`a di Pisa" + "1993" + + "F. Gadducci" + + "On the algebraic approach to concurrent term rewriting" + "Dipartimento di Informatica, Universit`a di Pisa" + "1996" + + + "J. Darlington" "Y. Guo" + "Constrained Equational Deduction" + "Proc. Second Int. Workshop on Conditional and Typed Rewriting Systems, Montreal, Canada, June 1990" + "1991" "S. Kaplan" + "M. Okada" "424-435" + "Springer-Verlag" + "516" "LNCS" + + "G. Denker" + "M. Gogolla" + "Translating {TROLL} {it light} concepts to {M}aude" + "Recent Trends in Data Type Specification" + "1994" "H. Ehrig" + "F. Orejas" "173-187" + "Springer-Verlag" "785" + "LNCS" + + + "H. Ehrig" "M. Baldamus" + "F. Orejas" + "New Concepts of Amalgamation and Extension of a General Theory of Specifications" + "Recent Trends in Data Type Specification" + "1993" "M. Bidoit" + "C. Choppy" "199-221" + "Springer-Verlag" + "655" "LNCS" + + "S. Feferman" + "Finitary Inductively Presented Logics" + "Logic Colloquium'88" + "1989" "R. Ferro" + "others" "191-220" + "North-Holland" + + + "A. Felty" "D. Miller" + "Encoding a Dependent-Type $lambda$-Calculus in a Logic Programming Language" + + "Proc. 10th. Int. Conf. on Automated Deduction, Kaiserslautern, Germany, July 1990" + "1990" "M. E. Stickel" + "221-235" + "Springer-Verlag" "449" + "LNCS" + + + "J. Fiadeiro" "J. Costa" + + "Mirror, Mirror in my Hand: {A} Duality Between Specifications and Models of Process Behaviour" + "Research Report, DI-FCUL, Lisboa, Portugal" + "May" "1994" + + "J. Fiadeiro" + "T. Maibaum" + "Generalising Interpretations between Theories in the Context of ($pi$-)Institutions" + "G. Burn" "S. Gay" + "M. Ryan" + "Theory and Formal Methods 93" + "Springer-Verlag" "126-147" + "1993" "D. Gabbay" + "Labelled Deductive Systems. {V}olume 1: Foundations" + "Max Planck Institut f{\"u}r Informatik" + "Saarbr{\"u}cken, Germany" + "1994" "MPI-I-94-223" + "May" "D. Gabbay" + "Fibred Semantics and the Weaving of Logics 1" + "Unpublished manuscript" + "May" "1993" + + + "P. Gardner" "Representing Logics in Type Theory" + + "Technical Report CST-93-92, Department of Computer Science, University of Edinburgh" + "1992" + + + "M. Gogolla" + "Partially Ordered Sorts in Algebraic Specifications" + + "Proc. Ninth Colloquium on Trees in Algebra and Programming" + "1984" "B. Courcelle" + "139-153" + "Cambridge University Press" + + + "Martin Gogolla" "Maura Cerioli" + "What is an {A}bstract {D}ata {T}ype after all?" + "DISI- University of Genova" + "To appear" "1994" + + "J. A. Goguen" + "R. Diaconescu" + "Towards an Algebraic Semantics for the Object Paradigm" + "Recent Trends in Data Type Specification" + "1994" "H. Ehrig" + "F. Orejas" "1-29" + "Springer-Verlag" "785" + "LNCS" + + "J. A. Goguen" + "A. Stevens" "K. Hobley" + "H. Hilberdink" + "{2OBJ}: {A} Meta-logical Framework Based on Equational Logic" + "Philosophical Transactions of the Royal Society, Series A" + "1992" "339" + "69-86" + + + "R. Harper" "F. Honsell" + "G. Plotkin" + "A Framework for Defining Logics" + "Journal of the Association Computing Machinery" + "1993" "40" "1" + "143-184" + + + "J. A. Bergstra" "J. Heering" + "P. Klint" "Module Algebra" + "Journal of the Association Computing Machinery" + "1990" "37" + "335-372" + + + "J. A. Bergstra" "J. Heering" + "P. Klint" "Algebraic Specification" + "ACM Press" "1989" + + "R. Harper" + "D. Sannella" + "A. Tarlecki" + "Structure Theory Presentations and Logic Representations" + "Annals of Pure and Applied Logic" + "1994" "67" "113-160" + + + "C. Kirchner" "H. Kirchner" + "M. Vittek" + "Designing Constraint Logic Programming Languages using Computational Systems" + + "Principles and Practice of Constraint Programming: The Newport Papers" + "1995" "133-160" + "V. Saraswat" + "P. van Hentenryck" "MIT Press" + + "C. Laneve" + "U. Montanari" + "Axiomatizing Permutation Equivalence in the $lambda$-Calculus" + + "Proc. Third Int. Conf. on Algebraic and Logic Programming, Volterra, Italy, September 1992" + "1992" "H. Kirchner" + "G. Levi" "350-363" + "Springer-Verlag" + "632" "LNCS" + + "C. Laneve" + "U. Montanari" + "Axiomatizing Permutation Equivalence" + "Mathematical Structures in Computer Science" + "1996" "6" "219-249" + + + "J. Levy" + "A Higher Order Unification Algorithm for Bi-Rewriting Systems" + "Segundo Congreso Programaci'on Declarativa" + "1993" "291-305" + "J. Agust'{i}" + "P. Garc'{i}a" "CSIC" + "Blanes, Spain" "September" + + "J. Levy" + "J. Agust'{i}" + "Bi-Rewriting, a Term Rewriting Technique for Monotonic Order Relations" + + "Proc. Fifth Int. Conf. on Rewriting Techniques and Applications, Montreal, Canada, June 1993" + "1993" "17-31" + "C. Kirchner" + "Springer-Verlag" "690" + "LNCS" + + + "Narciso Mart'{i}-Oliet" + "Jos'e Meseguer" + "Action and Change in Rewriting Logic" + "Dynamic Worlds: From the Frame Problem to Knowledge Management" + "R. Pareschi" + "B. Fronhoefer" "1998" + "To be published by Kluwer Academic Publishers" + + + "P. Martin-L{\"o}f" + "Constructive Mathematics and Computer Programming" + + "Proc. 6th Int. Congress for Logic, Methodology, and Philosophy of Science, Hannover, 1979" + "L. J. Cohen" + "others" "1982" "153-175" + "North-Holland" + + "S. Matthews" + "A. Smaill" + "D. Basin" + "Experience with {{it FS}$_0$} as a Framework Theory" + "Logical Environments" "1993" + "G. Huet" "G. Plotkin" + "61-82" + "Cambridge University Press" + + + "K. Meinke" "Universal Algebra in Higher Types" + "Theoretical Computer Science" + "1992" "100" + "385-417" + "G. Nadathur" + "D. Miller" + "An Overview of {$lambda$Prolog}" + "Fifth Int. Joint Conf. and Symp. on Logic Programming" + "1988" "K. Bowen" + "R. Kowalski" "810-827" + "The MIT Press" + + + "L. Paulson" + "The Foundation of a Generic Theorem Prover" + "Journal of Automated Reasoning" "1989" + "5" "363-39" + + "F. Pfenning" + "Elf: {A} Language for Logic Definition and Verified Metaprogramming" + + "Proc. Fourth Annual IEEE Symp. on Logic in Computer Science" + "1989" "313-322" + "Asilomar, California" + "June" "A. Poign'e" + + "On Specifications, Theories, and Models with Higher Types" + "Information and Control" "1986" + "68" "1-46" + + "A. Poign'e" + + "Foundations Are Rich Institutions, but Institutions Are Poor Foundations" + + "Categorical Methods in Computer Science with Aspects from Topology" + "1989" "H. Ehrig" + "H. Herrlich" + "H.-J. Kreowski" "G. Preuss" + "82-101" "Springer-Verlag" + "393" "LNCS" + + "A. Poign'e" + + "Parametrization for Order-Sorted Algebraic Specification" + "Journal of Computer and System Sciences" + "1990" "40" + "2" "229-268" + + + "A. Poign'e" "Typed {H}orn Logic" + + "Proc. 15th. Int. Symp. on Mathematical Foundations of Computer Science, Bansk'a Bystrica, Czechoslovaquia, August 1990" + "1990" "B. Rovan" + "470-477" + "Springer-Verlag" "452" + "LNCS" + + + "H. Reichel" + "An Approach to Object Semantics Based on Final Coalgebras" + + "Unpublished manuscript presented at {em Dagstuhl Seminar on Specification and Semantics}, Schloss Dagstuhl, Germany, May 1993" + + "A. Salibra" + "G. Scollo" + "A Soft Stairway to Institutions" + "Recent Trends in Data Type Specification" + "1993" "M. Bidoit" + "C. Choppy" "310-329" + "Springer-Verlag" "655" + "LNCS" + + + "A. Salibra" "G. Scollo" + + "Compactness and {L}{\"o}wenheim-{S}kolem Properties in Pre-Institution Categories" + + "Laboratoire d'Informatique de l'Ecole Normale Sup'erieure" + "1992" "LIENS-92-10" + "Paris" "March" + + + "D. Sannella" "A. Tarlecki" + + "Toward Formal Development of Programs from Algebraic Specifications: Implementations Revisited" + "Acta Informatica" + "1988" "25" "233-281" + + "R. M. Smullyan" + "Theory of Formal Systems" + "Princeton University Press" + "1961" "47" + "Annals of Mathematics Studies" "R. M. Smullyan" + "Diagonalization and Self-Reference" + "Oxford University Press" + "1994" + "A. Tarlecki" + "Free Constructions in Algebraic Institutions" + + "Proc. Mathematical Foundations of Computer Science '84" + "1984" "M. P. Chytil" + "V. Koubek" "526-534" + "Springer-Verlag" "176" + "LNCS" + + + "A. Tarlecki" + "Bits and Pieces of the Theory of Institutions" + + "Proc. Workshop on Category Theory and Computer Programming, Guildford, UK, September 1985" + "1986" "D. Pitt" + "S. Abramsky" + "A. Poign'e" "D. Rydeheard" + "334-363" "Springer-Verlag" + "240" "LNCS" + + + "A. Tarlecki" "R. M. Burstall" + "J. A. Goguen" + "Some Fundamental Algebraic Tools for the Semantics of Computation. {P}art 3: Indexed Categories" + "Theoretical Computer Science" + "1991" "91" + "239-264" + "P. Viry" + "Rewriting: An Effective Model of Concurrency" + "PARLE'94, Proc. Sixth Int. Conf. on Parallel Architectures and Languages Europe, Athens, Greece, July 1994" + "1994" "648-660" + "C. Halatsis" + "D. Maritsas" "G. Philokyprou" + "S. Theodoridis" + "Springer-Verlag" "817" + "LNCS" + + + "David Culler" "Andrea Dusseau" + "Seth Copen Goldstein" + "Arvind Krishnamurthy" "Steven Lumetta" + "Thorsten {von} Eicken" + "Katherine Yelick" + "Parallel Programming in Split-{C}" + "{Proceedings of Supercomputing '93}" "1993" + + "Sunderam" "V. Sunderam" + "{PVM: } {A} Framework for Parallel Distributed Computing" + "Concurrency: Practice and Experience" + "2" "4" + "1990" "December" + + + "K. M. Chandy" "C. Kesselman" + + "{{CC++}: A Declarative Concurrent Object-Oriented Programming Notation}" + + "{Research Directions in Concurrent Object-Oriented Programming}" + "1993" + " {Agha, Wegner}" "Yonezawa" + "175-211" "MIT Press" + + "Valentin F. Turchin" + "The Concept of a Supercompiler" + "{ACM} Transactions on Programming Languages and Systems" + "8" "3" + "292-325" "1986" + + + "Valentin F. Turchin" + "{REFAL}-5, Programming Guide and Reference Manual" + "1989" "New England Publishing Co." + + "Valentin F. Turchin" + "Andrei P. Nemytykh" + "Metavariables: their Implementation and Use in Program Transformation" + "City College of CUNY" + "CSc-TR-95-012" "1995" + + + "Anders Bondorf" + "A Self-Applicable Partial Evaluator for Term Rewriting Systems" + "TAPSOFT'89" + "1989" "J. D'{i}az" + "F. Orejas" "81-95" + "Springer LNCS 352" "Leon Sterling" + "Ehud Shapiro" "The Art of Prolog" + "MIT Press" "1986" + + + "Takuo Watanabe" + "Towards a Foundation of Computational Reflection based on Abstract Rewriting (Preliminary Result)" + "IMSA'95" "1995" + "143-145" + "Information-Technology Promotion Agency, Japan" + + "F. Kumeno" "Y. Tahara" + "A. Ohsuga" + "S. Honiden" + "Agent oriented programming language, {Flage}" + "IMSA'95" "1995" + "29-44" + "Information-Technology Promotion Agency, Japan" + + + "David Sherman" "Robert Strandh" + "Ir`{e}ne Durand" + "Optimization of Equational Programs Using Partial Evaluation" + "PEPM'91" "1991" + "72-82" "SIGPLAN Notices" + + "N. Jones" + "Mix ten year later" "PEPM'95" + "1995" "24-38" + "ACM-SIGPLAN" + + + "Efficient self-interpretation in lambda calculus" + "Torben AE. Mogensen" "1992" + "Journal of Functional Programming" + "2" "3" + "345-364" + + + "Harald Ruess" + "Formal Meta-Programming in the Calculus of Constructions" + "Universit{\"{a}}t Ulm" "1995" + + "Lawrence Paulson" + "Tactics and Tacticals in {Cambridge LCF}" + "University of Cambridge" + "39" "1983" + + + "Patricia Hill" "John Lloyd" + "The {G\"{o}del} Programming Language" + "MIT Press" "1994" + + "G. L. {Steele, Jr.}" + "G. J. Sussman" + "The Art of the Interpreter or, the Modularity Complex" + "{AIM-453}" "{MIT AI-Lab}" + "May" "1978" + + + "The Mystery of the Tower Revealed" "M. Wand" + "D. P. Friedman" "1988" + "Lisp and Symbolic Computation" + "1" "1" + "11-38" + + "Prolegomena to a Theory of Mechanized Formal Reasoning" + "Richard W. Weyhrauch" "1980" + "Artificial Intelligence" + "13" "133-170" + + + "Metafunctions: proving them correct and using them efficiently as new proof procedures" + "R. S. Boyer" + "J Strother Moore" "1981" + "The Correctness Problem in Computer Science" + "Robert Boyer" + "J Moore" "Academic Press" + "103-185" "N. Shankar" + + "Metamathematics, Machines, and {G\"{o}del's} Proof" + "Cambridge University Press" + "1994" + + "Reflecting the Semantics of Reflected Proof" + "Douglas J. Howe" "1990" + "Proof Theory" "Peter Aczel" + "Harold Simmons" + "Stanley S. Wainer" + "Cambridge University Press" "229-250" + + "Se'{a}n Matthews" + "Reflection in Logical Systems" + "IMSA'92" "1992" + "178-183" + "Information-Technology Promotion Agency, Japan" + + + "Fausto Giunchiglia" "Paolo Traverso" + "Alessandro Cimatti" + "Paolo Pecchiari" + "A System for Multi-Level Reasoning" "IMSA'92" + "1992" "190-195" + + "Information-Technology Promotion Agency, Japan" + + + "Alessandro Coglio" "Fausto Giunchiglia" + "Jos'e Meseguer" + "Carolyn Talcott" + "Composing and Controlling Search in Reasoning Theories Using Mappings" + "Frontiers of Combining Systems, FroCos 2000" + "2000" "200-216" + + "Information-Technology Promotion Agency, Japan" + + + "Luis H. {Rodriguez, Jr.}" + "A Study on the Viability of a Production-Quality Metaobject Protocol-Based Statically Parallelizing Compiler" + "IMSA'92" "1992" + "107-112" + "Information-Technology Promotion Agency, Japan" + + + "Hideaki Okamura" "Yutaka Ishikawa" + "Mario Tokoro" + "{AL-1/D}: {A} Distributed Programming System with Multi-Model Reflection Framework" + "IMSA'92" "1992" + "36-47" + "Information-Technology Promotion Agency, Japan" + + "Manuel Clavel" + "Jose Meseguer" + "Reflection in rewriting logic and its applications in the {Maude} language" + "IMSA'97" "1997" + "128-139" + "Information-Technology Promotion Agency, Japan" + + + "Hiroshi Ishikawa" "Jose Meseguer" + "Takuo Watanabe" + "Kokichi Futatsugi" "Hideyuki Nakashima" + + "On the semantics of {GAEA}---an object-oriented specification of a concurrent reflective language in rewriting logic" + "IMSA'97" "1997" + "70-109" + "Information-Technology Promotion Agency, Japan" + + "Hideyuki Nakashima" + "Organic programming for situation-thick {AI} systems" + "IMSA'97" "1997" + "156-163" + "Information-Technology Promotion Agency, Japan" + + + "Analysis of meta-programs" + "Patricia Hill" "John Lloyd" + "1989" + "Meta-Programming in Logic Programming" + "H. D. Abramson" "M. H. Rogers" + "MIT Press" "23-52" + + + "Program transformation with metasystem transitions" + "Valentin F. Turchin" "1993" + "Journal of Functional Programming" + "3" "3" + "283-313" + + + "Microsoft Corporation" + "The {COM} Specificication" "1995" + + + "Common Object Model Specification" + "Microsoft Corp." "Digital Equipment Corp." + "1994" + "{OMG} Document 94.10.9" + + "The Common Object Request Broker: Architecture and Specification" + "Object Management Group" + "1993" "{OMG} Document 93-12-43" + + + "J. R. Abrial" + "Steam-boiler control specification problem" "1994" + + "Distributed to the participants of a {D}agstuhl seminar on {'}Methods for {S}emantics and {S}pecification{'}. Available via url{http://www.informatik.uni-kiel.de/~{ }procos/dag9523/dag9523.html}" + + "See also {'}Additional Information Concerning the Physical Behaviour of the Steam-boiler{'} at the same address" + + "A. Agarwal" + "Limits on Interconnection Network Performance" + + "{IEEE} Transactions on Parallel and Distributed Systems" + "1991" "4" + "2" "398-412" + + + "Rajeev Alur" "David Dill" + "The Theory of Timed Automata" + "Real-Time: Theory in Practice" + "J. W. de Bakker" "G. Huizing" + "W. P. de Roever" "G. Rozenberg" + "Lecture Notes in Computer Science" + "600" "1991" + + "T. A. Henzinger" + "Z. Manna" + "A. Pnueli" "Timed Transition Systems" + "Real-Time: Theory in Practice" + "J. W. de Bakker" + "G. Huizing" "W. P. de Roever" + "G. Rozenberg" + "Lecture Notes in Computer Science" "600" + "1991" + + + "L. Bachmair" + "Proof by Consistency in Equational Theories" + "Proceedings 3rd IEEE Symposium on Logic in Computer Science, Edinburgh (UK)" + "1988" "228-233" + + "L. Bachmair" + "Proof methods for equational theories" + "University of Illinois, Urbana-Champaign" "1987" + + "L. Bachmair" + "Completion for Rewriting modulo a Congruence" + "Theoretical Computer Science" + "1989" "67" "173-201" + + "L. Bachmair" + "N. Dershowitz" + "J. Hsiang" "Completion Without Failiure" + "H. A{\"i}t-Kaci" + "M. Nivat" + "Resolution of Equations in Algebraic Structures" + "Rewriting Techniques" "2" + "1" + "Academic Press" "1989" + + "H. P. Barendregt" + "The Lambda Calculus, its Syntax and Semantics" + "North Holland, Amsterdam, 2nd ed." + "1984" + + + "H. P. Barendregt" + "Handbook of Logic in Computer Science" + "Typed lambda calculi" "1993" + "Oxford Univ. Press" + "eds. Abramsky et al." + "L. Bachmair" + "Canonical equational proofs" + "Birkh{\"a}user Verlag AG" "1991" + + "Computer Science Logic, Progress in Theoretical Computer Science" + + "E. Bevers" + "J. Lewi" + "Proof by Consistency in Conditional Equational Theories" + + "Proceedings Second International Workshop on Conditional and Typed Rewriting Systems" + "1990" + "Springer-Verlag" + "Lecture Notes in Computer Science" "516" + "194-205" + + + "K. Becker" + "Proving Ground Confluence and Inductive Validity in Constructor Based Equational Specifications" + "Lecture Notes in Computer Science" + + "Proceedings from TAPSOFT'93: Theory and Practice of Software Development (Orsay France)" + "1993" "668" + "46-60" + + + "J. A. Bergstra" "J. V. Tucker" + + "Initial and Final Algebra Semantics for Data Type Specificartions: Two Characterization Theorems" + "SIAM Journal on Computing" + "1983" "12" + "2" "366-387" + + "G. Birkhoff" + "On the structure of abstract algebras" + "Proc. Cambridge Philosophical Society 31" + "1935" "433-454" + + "A. Boudet" + "E. Contejean" "{AC}-unification is easy" + + "Laboratoire de Recherche en Informatique, Universite Paris-Sud, Orsay, France" + "April1989" + + + "R. S. Boyer" "J. S. Moore" + "A Computational Logic Handbook" + "Academic Press, Inc." "1988" + + + "V. Breazu-Tannen" + "Combining Algebra and Higher-Order Types" + "Proceedings 3rd IEEE Symposium on Logic in Computer Science, Edinburgh (UK)" + "1988" "July" + + + "V. Breazu-Tannen" "J. Gallier" + + "Polymorphic Rewriting Conserves Algebraic Strong Normalization and Confluence" + "Lecture Notes in Computer Science" + + "Proceedings 16th International Colloquium on Automata, Languages and Pro-gramming" + "1988" + "Springer-Verlag" "372" + "137-150" + + + "R. Burstall" + "Proving Properties of Programs by Structural Induction" + "Computer Journal" "1969" + "12(1)" "41-48" + + "H.-J. B{\"u}rckert" + "Solving Disequations in Equational Theories" + "Lecture Notes in Computer Science" + + "Proceedings 9th International Conference on Automated Deduction, Argonne (Illinois, USA)" + "1988" "310" + "517-526" + + "J. Chabin" + "P. R{'e}ty" + "Narrowing directed by a graph of terms" + "Lecture Notes in Computer Science" + "Proceedings 4th Conference on Rewriting Techniques and Applications, Como (Italy)" + "1991" "488" + "112-123" + + + "K. M. Chandy" "J. Misra" + "Parallel Program Design: {A} Foundation" + "Addison-Wesley" "1988" + + + "J. Christian" + "Proceedings 11th International Conference on Automated Deduction, Saratoga Springs (NY, USA)" + + "Some Termination Criteria for Narrowing and {E}-Narrowing" + "1992" + "Lecture Notes in Artificial Intelligence" + "Springer-Verlag" "607" + + "E. M. Clarke" + + "Verification of the Futurebus+Cache Coherence Protocol" + + + "H. Comon" "P. Lescanne" + "Equational Problems and Disunification" + "Journal of Symbolic Computation" + "1989" "7" + "371-425" + "H. Comon" + ". Haberstrau M" + "J.-P. Jouannaud" + "Proceedings 7th IEEE Symposium on Logic in Computer Science, Santa Cruz, (California, USA)" + + "Decidable Problems in Shallow Equational Theories" + "1992" "255-265" + + + "O.-J. Dahl" "D. F. Langmyhr" + "O. Owe" + "Preliminary Report on the Specification and Programming Language {ABEL}" + + "Department of informatics, University of Oslo, Norway" + "1986" "Research Report" + "106" "O.-J. Dahl" + "O. Owe" + "Formal Development with {ABEL}" + "Department of informatics, University of Oslo, Norway" + "1991" "Research Report" + "552" + + + "O.-J. Dahl" "O. Owe" + "Proceedings 4th International Symposium of VDM Europe" + "Formal Development with {ABEL}" + "1991" + "Lecture Notes in Computer Science" + "Springer-Verlag" "552" + + + "O.-J. Dahl" + "Verifiable Programming" "Prentice Hall" + "1992" + + "N. Dershowitz" + "Orderings for term-rewriting systems" + "Theoretical Computer Science" + "1982" "17" + "279-301" + "N. Dershowitz" + "Termination of rewriting" + "Journal of Symbolic Computation" "1987" + "3" "69-116" + + "N. Dershowitz" + "Completion and Its Applications" + "H. A{\"i}t-Kaci" "M. Nivat" + + "Resolution of Equations in Algebraic Structures" + "Rewriting Techniques" "2" + "2" + "Academic Press" "1989" + + "N. Dershowitz" + "Open Problems in Rewriting" + "Lecture Notes in Computer Science" + + "Proceedings 4th Conference on Rewriting Techniques and Applications, Como (Italy)" + "1991" "488" + "445-456" + + + "N. Dershowitz" "M. Okada" + "G. Sivakumar" + "Confluence of Conditional Rewrite Systems" + "Proceedings 1st International Workshop on Conditional Term Rewriting Systems, Orsay (France)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "308" + "31-44" + + + "N. Dershowitz" "L. Marcus" + "A. Tarlecki" + "Existence, Uniqueness and Construction of Rewrite Systems" + "SIAM Journal on Computing" "1988" + "4" "629-639" + + "N. Dershowitz" + "J.-P. Jouannaud" "Rewrite Systems" + "J. van Leeuwen" + "Handbook of Theoretical Computer Science" + "B" "6" + "Elsevier, Amsterdam" "1990" + + "N. Dershowitz" + "C. Hoot" "Topics in Termination" + + "Proceedings 5th Conference on Rewriting Techniques and Applications, Montreal (Canada)" + "1993" + "Springer-Verlag" + "Lecture Notes in Computer Science" "690" + "198-212" + + + "H. Devie" "Linear Completion" + + "Proceedings Second International Workshop on Conditional and Typed Rewriting Systems" + "1990" + "Springer-Verlag" + "Lecture Notes in Computer Science" "516" + "233-245" + + "H. Devie" + "Proce'dures de comple'tion e'quationnelle" + "Universite' de Paris-Sud" "1991" + + + "On Completeness of Narrowing Strategies" + "R. Echahed" "Theoretical Computer Science" + "1990" "72" + "133-146" + + + "Uniform Narrowing Strategies" "R. Echahed" + + "Proceedings 3rd International Conference on Algebraic and Logic Programming, Pisa (Italy)" + "Lecture Notes in Computer Science" + "Springer-Verlag" + "632" "1992" + "259-275" + + "H. Ehrig" "B. Mahr" + "Fundamentals of Algebraic Specifications {I}, Equations and Initial Semantics" + "Springer-Verlag" + "1985" + "EATCS Monographs on Theoretical Computer Science" + + "6" + "Overview of algebraic specification languages, environments and tools, and algebraic specification of software systems" + "H. Ehrig" + "I. Cla{ss}en" + "Bulletin of European Association for Theoretical Computer Science" + "1989" "39" + "103-111" + + + "The {AFFIRM} Theorem prover: Proof Forests and Management of Large Proofs" + "R. W. Erickson" + "D. L. Musser" + "Proceedings 5th International Conference on Automated Deduction" + "Lecture Notes in Computer Science" + "87" "1980" + "220-231" + + + "Complete Sets of Unifiers and Matchers in Equational Theories" + "F. Fages" "G. Huet" + "Theoretical Computer Science" + "1986" "43" + "189-200" + "M. Fay" + "First-order Unification in an Equational Theory" + "Proceedings of the 4th Workshop on Automated Deduction" + "1979" "161-167" + + + "Narrowing Based Procedures for Equational Disunification" + "M. Fern{'a}ndez" + "Applicable Algebra in Engineering, Communication and Computation" + "1992" "3" + "1-26" "M. C. F. Ferreira" + "H. Zantema" + "Well-foundedness of Term Orderings" + "Proceedings 4th International Workshop on Conditional Term Rewriting Systems, Jesuralem (Israel)" + "1994" + "To be published by Springer Verlag" + + + "U. Fraus" "H. Hussmann" + "A Narrowing-Based Theorem Prover" + + "Distributed at 2nd International Conference on Algebraic and Logic Programming, Nancy (France)" + "October" "1990" + + "L. Fribourg" + + "A Narrowing Procedure for Theories with Constructors" + + "Proceedings 7th International Conference on Automated Deduction, Napa (CA, USA)" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "170" "1984" "259-281" + + + "L. Fribourg" + "Handling Function Definitions through Innermost Superposition and Rewriting" + + "Proceedings 1st Conference on Rewriting Techniques and Applications, Dijon (France)" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "202" "1985" "325-344" + + "L. Fribourg" + "{SLOG:} {A} Logic Programming Interpreter Based on Clausal Superposition and Rewriting" + + "Proceedings of the 1985 Symposium on Logic Programming, Boston" + "1985" "172-184" + + "L. Fribourg" + + "A Strong Restriction on the Inductive Completion Procedure" + + "Proceedings 13th International Colloquium on Automata, Languages and Pro-gramming" + "1986" + "Springer-Verlag" + "Lecture Notes in Computer Science" "226" + "105-115" + + + "{D. de} Frutos-Escrig" + "M.-I. Fern{'a}ndes-Camacho" + "On Narrowing Strategies for Partial Non-Strict Functions" + + "Proceedings from TAPSOFT'91: Theory and Practice of Software Development" + "1991" + "Springer-Verlag" + "Lecture Notes in Computer Science" "494" + "416-437" + + + "H. Ganzinger" + "A Completion Procedure for Conditional Equations" + + "Proceedings 1st International Workshop on Conditional Term Rewriting Systems, Orsay (France)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "308" + "62-83" + + + "H. Ganzinger" "J. Stuber" + + "Inductive Theorem Proving by Consistency for First-Order Clauses" + + "Proceedings 3rd International Workshop on Conditional Term Rewriting Systems, Pont-a-Mousson (France)" + "1993" + "Springer-Verlag" + "Lecture Notes in Computer Science" "656" + "226-241" + + + "S. J. Garland" "J. V. Guttag" + "Inductive Methods for Reasoning about Abstract Data Types" + + "Proceedings of the fifteenth annual ACM Symposium on Principles of Programming Languages" + "January 1988" + "219-228" + "S. J. Garland" + "J. V. Guttag" + "An Overwiew of {LP}, The {L}arch {P}rover" + "Proceedings 3rd Conference on Rewriting Techniques and Applications, Chapel Hill (North Carolina, USA)" + "137-151" "1989" + "Springer-Verlag" + "Lecture Notes in Computer Science" "355" + "N. Dershowitz" + "April" + "V. Girranata" + "F. Gimona" "U. Montanari" + + "Observability Concepts in abstract data type specification" + + "Proceedings 1st Mathematical Foundations of Computer Science, Gdansk (Poland)" + "1976" + "Springer-Verlag" + "Lecture Notes in Computer Science" "45" + "576-587" + + + "S. Gjessing" "S. Krogdahl" + "E. Munthe-Kaas" + "A Top Down Approach to the Formal Specification of {SCI} Cashe Coherence" + + "Department of informatics, University of Oslo, Norway" + "1990" "Research Report" + "146" + + + "S. Gjessing" "S. Krogdahl" + "E. Munthe-Kaas" + "A Linked List Cache Coherence Protocol: Verifying the Bottom Layer" + + "Proceedings of the 5th International Parallel Processing Symposium, Anaheim (California)" + "324-329" + "V. K. Prasanna Kumar" + "IEEE Computer Society Press" "1991" + + "I. Gnaedig" + "Termination of order-sorted rewriting" + "Proc. Algebraic and Logic Programming. Third International Conference" + "Springer-Verlag" + "1992" + + "J. A. Goguen" + "J. W. Thatcher" + "E. G. Wagner" + "An initial algebra approach to the specification, correctness and implementation of abstract data types" + "Current Trends in Programming Methodology" + "R. Yeh" "80-149" + "Prentice-Hall" + "1978" + "J. A. Goguen" + + "Exception and Error sorts, Coercion and Overload Operations" + "SRI International,Computer Science Lab" + "1978" + + + "Equality, Types, Modules, and (why not?) Generics for Logic Programming" + "J. A. Goguen" + "J. Meseguer" "Journal of Logic Programming" + "1984" "2" + "179-210" "J. A. Goguen" + "{OBJ} as a theorem prover with applications to hardware verification" + "SRI International,Computer Science Lab" + "1988" + + + "J. A. Goguen" "T. Winkler" + "Introducing {OBJ3}" + "SRI International,Computer Science Lab" + "1988" + "J. A. Goguen" + "J. Meseguer" + "Order-Sorted Algebra {I}: {E}quational Deduction for Multiple Inheritance, Overloading, Exceptions and Partial Operators" + + "Programming Research Group, Oxford University Computing Laboratory" + "1989" + + "J. A. Goguen" + + "How to prove inductive hypotheses without induction" + "Proceedings of the 5th Conference on Automated Deduction" + "1980" + "Springer-Verlag" + "Lecture Notes in Computer Science" "87" + "356-373" "W. Bibel" + "R. Kowalski" + + + "J. A. Goguen" + "Parameterized Programming" + "IEEE Transactions on Software Engineering" + "1984" "September" + "SE-10(5)" "528-543" + + + "J. V. Guttag" + "The Specification and Application to Programming of Abstract Data Types" + + "Computer Science Department, University of Toronto" + + "1975" + "The Algebraic Specification of Abstract Data Types" + "J. V. Guttag" "J. J. Horning" + "Acta Informatica" + "1978" "10" "27-52" + + "Larch in Five easy Pieces" + "J. V. Guttag" + "J. J. Horning" "J. M. Wing" + "Digital Systems Research Center" + "1985" "R. Hennicker" + "Observational Implementations" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "Proceedings of the 6th Annual Symposium on Theoretical Aspects of Computer Science" + "349" "59-71" + "1989" + + + "Context Induction: {A} Proof Principle for Behavioural Abstractions and Algebraic Implementations" + "R. Hennicker" + "Formal Aspects of Computing" "1991" + "3" "326-345" + + + "Verifying a distributed list system: a case history" + "S. Krogdahl" "O. Lysne" + "Formal Aspects of Computing" + "1997" "9" + "98-118" + "M. Hermann" + "On Proving Properties of Completion Strategies" + "Springer-Verlag" + "Lecture Notes in Computer Science" + + "Proceedings 4th Conference on Rewriting Techniques and Applications, Como (Italy)" + "488" "398-410" + "1991" + + "R. Hindley" + "J. Seldin" "1986" + "Introduction to Combinators and $lambda$-calculus" + "Cambridge University Press" + + + "C. A. R. Hoare" + "Communicating Sequential Processes" + "Prentice-Hall" "1985" + + + "G. Hornung" "P. Raulefs" + + "Terminal Algebra Semantics and Retractions for Abstract Data Types" + "Lecture Notes in Computer Science" + "85" "310-323" + "July 1980" + + "J. Hsiang" + "M. Rusinowitch" + "On word problems in equational theories" + "Proceedings 14th International Colloquium on Automata, Languages and Pro-gramming, Karlsruhe (Germany)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "267" + "54-71" "T. Ottmann" + "July" + + "G. Huet" + "June" "1975" + "A unification algorithm for typed $lambda$-calculus" + "Theoretical Computer Science" + "1" "1" "27-57" + + "G. Huet" + + "A Complete proof of correctness of the {K}nuth and {B}endix completion algorithm" + "Journal of Computer and System Sciences" + "1981" "23(1)" + "11-21" + + + "G. Huet" "J.-M. Hullot" + "Proofs by Induction in Equational Theories with Constructors" + "Journal of Computer and System Sciences" + "1982" "239-266" + + "J.-M. Hullot" + "Canonical Forms and Unification" + "Proceedings 5th International Conference on Automated Deduction" + "Lecture Notes in Computer Science" + "Springer-Verlag" + "87" "318-334" + + "1980" "P. Inverardi" + "M. Nesi" + "A Rewriting Strategy to Verify Observational Congruence" + "Information Processing Letters" + "35" "191-199" "1990" + + + "{IEEE working group P1596}" + "{IEEE} Standard for {S}calable {C}oherent {I}nterface {(SCI)}" + "{IEEE}" + "August" "1992" + + "D. V. James" "A. T. Laundrie" + "S. Gjessing" + "G. S. Sohi" + "New Directions in Scalable Shared-Memory Mulitprocessor Architectures: {S}calable {C}oherent {I}nterface" + "{IEEE} Computer" + "1990" "June" + + + "R. E. Johnson" + "How to Get a Paper Accepted at {OOPSLA}" "1993" + + + "J.-P. Jouannaud" "E. Kounalis" + + "Automatic Proofs by Induction in Theories without Constructors" + "82" + "Information and Computation" "1-33" + "1" "1989" + + "July" "J.-P. Jouannaud" + "H. Kirchner" + "Completion of a Set of Rules modulo a Set of Equations" + "SIAM Journal of Computing" + "1055-1094" "15" "4" + "1986" "November" + + + "J.-P. Jouannaud" "C. March'e" + + "Completion modulo Associativity, Commutativity and Identity ({AC1})" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "Proceedings of DISCO'90, Capri (Italy)" + "429" "111-120" + "1990" + + + "J.-P. Jouannaud" "M. Okada" + + "A Computation Model for Executable Higer-Order Algebraic Specification Languages" + + "Proceedings 6th IEEE Symposium on Logic in Computer Science" + "1991" "350-361" + + "S. Kamin" + "J.-J. L{'e}vy" + "Attempts for generalizing the recursive path ordering" + "INRIA" "1980" + "Rocquencourt" + + "S. Kamin" + "J.-J. L{'e}vy" + "Two generalizations of the recursive path ordering" + "1980" + "Unpublished Note, Department of Computer Science, University of Illinois, Urbana, IL" + + + "S. Kamin" + "Final data types and their specification" + "ACM Transactions on Programming Languages and Systems" + "5" "1" + "1983" "January" "97-123" + + "S. Kaplan" + "Conditional Rewrite Rules" + "Theoretical Computer Science" "33" + "1984" "175-193" + + "S. Kaplan" + "Positive/Negative Conditional Rewriting" + + "Proceedings 1st International Workshop on Conditional Term Rewriting Systems, Orsay (France)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "308" + "129-141" + + + "D. Kapur" "P. Narendran" + "H. Zhang" + "Proof by Induction using Test Sets" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "Proceedings 8th International Conference on Automated Deduction, Oxford (UK)" + "230" "99-117" + "1986" + + + "D. Kapur" "P. Narendran" + "H. Zhang" + "On Sufficient-Completeness and Related Properties of Term Rewriting Systems" + "Acta Informatica" + "24" "4" "395-415" + "1987" + + "Proof by consistency" + "D. Kapur" "R. Musser" + "Artificial Intelligence" + "31" "1987" + "125-157" + "J. H. Kim" + "A. A. Chien" + "The Impact of Packetization in Wormhole-Routed Networks" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "Proceedings 5th Conference of Parallel Architectures and Languages Europe" + "694" "242-253" + "1993" + + + "C. Kirchner" "P. Lescanne" + "Solving Disequations" + "Proceedings 2nd IEEE Symposium on Logic in Computer Science, Ithaca (New York, USA)" + "347-352" "1987" + + "H. Kirchner" + "Proofs in Parameterized Specifications" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "Proceedings 4th Conference on Rewriting Techniques and Applications, Como (Italy)" + "488" "174-187" + "1991" + + + "Deduction with Symbolic Constraints" + "K. Kirchner" "H. Kirchner" + "M. Rusinowitch" + "Revue d'intelligence artificielle" "4" + "3" "1990" + + "9-52" "J. W. Klop" + "{it Combinatory Reduction Systems}" + + "Mathematical Centre Tracts 127, Mathematisch Centrum,Amsterdam" + "1980" + + "D. E. Knuth" + "P. B. Bendix" + "Simple word problems in universal algebras" + "Computational Problems in Abstract Algebra" + "Pergamon Press" "1970" + "J. Leech" "263-297" + "Oxford" + + + "Timed Rewriting Logic" "P. Kosiuczenko" + "M. Wirsing" "1995" + + "Working material for the 1995 {M}arktoberdorf {I}nternational {S}ummer {S}chool ``{L}ogic of {C}omputation''" + + + "P. Kosiuczenko" "M. Wirsing" + + "Timed Rewriting Logic with an Application to Object-Oriented Specification" + "Submitted for publication" + "1995" + "E. Kounalis" + "M. Rusinowitch" + "Mechanizing inductive reasoning" + "Proceedings Eighth National Conference on Artificial Intelligence, Boston" + "240-245" "1990" + + + "Verification of a Class of Link-Level Protocols" + "S. Krogdahl" "BIT" + "1978" "18" "436-448" + + "W. K{\"u}chlin" + + "Inductive Completion by Ground Proof Transformation" + "H. A{\"i}t-Kaci" "M. Nivat" + + "Resolution of Equations in Algebraic Structures" + "Rewriting Techniques" "2" + "7" + "Academic Press" "1989" + + + "L. Lamport" + "The '{H}oare Logic' of Concurrent Programs" + "Acta Informatica" "1980" + "14" "21-37" + + + "D. S. Lankford" + "Canonical inference" + "Department of Mathematics and Computer Science, Univ. of Texas, Austin" + "ATP-32" "1975" + + "P. Lescanne" + + "Computer experiments with the {REVE} term rewriting system generator" + + "Proceedings of 10th ACM Symposium on Principles of Programming Languages" + "1983" "99-108" + "ACM" + + + "P. Lescanne" + "Behavioural Categoricity of Abstract Data Type Specifications" + "The Computer Journal" + "1983" "26" "4" + "289-292" + + + "P. Lescanne" + "Implementation of completion by transition rules + control: {{sc ORME}}" + + "Proceedings 2nd International Conference on Algebraic and Logic Programming, Nancy (France)" + "1990" + "Springer-Verlag" + "Lecture Notes in Computer Science" "463" + "262-269" "H. Kirchner" + "W. Wechler" + + + "C. Lor{'i}a-S{'a}enz" "J. Steinbach" + + "Termination of Combined (Rewrite and $lambda$-Calculus) Systems" + + "Proceedings 3rd International Workshop on Conditional Term Rewriting Systems, Pont-a-Mousson (France)" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "656" "143-147" "1992" + + + "C. Lor{'i}a-S{'a}enz" + "A Theoretical Framework for Reasoning about Program Con-struction based on Extensions of Rewrite Systems" + + "Fachbereich Informatik der Universit{\"a}t Kaiserslautern" + "1993" "O. Lysne" + + "Syntaksorientert Editor Basert p{\aa} 2-niv{\aa} {BNF}" + "Department of Informatics, University of Oslo, Norway" + "1988" + + "O. Lysne" + "A width first approach to completion" + + "Proceedings from NIK'90: Norsk Informatikk Konferanse, Bergen" + "TAPIR" + "145-154" "November" + "1990" + "O. Lysne" + "A width first approach to completion" + "Department of informatics, University of Oslo, Norway" + "1990" "Research Report" + "139" "March" + + "O. Lysne" + + "Term Rewriting Techniques for Systems based on Generator Induction" + + "Department of Informatics, University of Oslo, Norway" + "1991" "Research Report 163" + + + "O. Lysne" + "Proof by Consistency in Constructive Systems with Final Algebra Semantics" + "Springer-Verlag" + "Lecture Notes in Computer Science" + + "Proceedings 3rd International Conference on Algebraic and Logic Programming, Pisa (Italy)" + "632" "276-290" + "1992" + + + "O. Lysne" "O. Owe" + "Definedness and Strictness in Generator Inductive Definitions" + + "Department of informatics, University of Oslo, Norway" + "1991" "Research Report" + "161" "October" + + "Also presented at the 3rd Nordic Workshop on Program Correctness, G{\"o}teborg (Sweden)" + + "O. Lysne" + + "Towards Mechanizing Proofs by Structural Induction" + + "Proceedings from NIK'92: Norsk Informatikk Konferanse, Troms{o}" + "243-255" "TAPIR" + "November" "1992" + + + "The Equational Part of Proofs by Structural Induction" + "O. Lysne" "BIT" + "1993" "33" + "596-618" + "O. Lysne" + "Linear Proofs in the Final Algebra" + "Department of informatics, University of Oslo, Norway" + "1993" + "Research Report" "173" + "April" + "O. Lysne" + + "Initial Equality as a Function in Algebraic Specification" + "Department of informatics, University of Oslo, Norway" + "1993" + "Research Report" "179" + "September" + "O. Lysne" + "{E}-Unification by Consistency" + + "Presented at the 5th Nordic Workshop on Program Correctness, Turku (Finland)" + "1993" + + + "O. Lysne" + "On the Connection between Narrowing and Proof by Consistency" + "Springer-Verlag" + "Lecture Notes in Artificial Intelligence" + "Proceedings 12th International Conference on Automated Deduction, Nancy (France)" + "814" "133-147" + "1994" + + + "O. Lysne" + "Heuristics for Completion in Automatic Proofs by Structural Induction" + "Nordic Journal of Computing" + "1994" "1" + "135-156" + "O. Lysne" + "Extending {B}achmair's method for proof by consistency to the final algebra" + "Information Processing Letters" + "1994" "51" + "303-310" + "O. Lysne" + "{it E}-Unification by Consistency" + "{AA}bo Akademi" + "Reports on Computer Science & Mathematics" + "Proceedings 5th Nordic Workshop on Program Correctness" + "18" "127-136" + "1994" + + + "O. Lysne" "J. Piris" + "A Termination Ordering for Higher Order Rewrite Systems" + + "To be presented at {it Rewriting techniques and Applications '95}. Proceedings to be published by Springer Verlag in the series LNCS" + "1995" + + + "S. Krogdahl" "O. Lysne" + + "Verifying a Distributed List System: {A} Case History" + "Department of informatics, University of Oslo, Norway" + "1993" + "Research Report" "182" + "December" + + "K. L. McMillan" "J. Schwalbe" + + "Formal Verification of the {G}igamax Cache Consistency Protocol" + + "Proceedings of the International Symposium on Shared Memory Multiprocessing, Tokyo (Japan)" + "April" "1991" + "242-251" + + + "An Efficient Unification Algorithm" + "A. Martelli" "U. Montanari" + "Transactions on Programming Languages and Systems" + "1982" "April" + "4(2)" "258-282" + + "J. Meseguer" + "J. A. Goguen" + "Initiality, Induction and Computability" + "M. Nivat" "J. C. Reynolds" + "Algebraic Methods in Semantics" + "14" + "Cambridge University Press" "1985" + + + "Conditional rewriting logic as a unified model of concurrency" + "J. Meseguer" + "Theoretical Computer Science" "1992" + "96" "73-155" + + + "J. Meseguer" "T. Winkler" + "Parallel programming in {M}aude" + + "Research {D}irections in {H}igh-{L}evel {P}arallel {P}rogramming {L}anguages" + "Lecture Notes in Computer Science" + "Springer-Verlag" + "574" "1992" + "253-293" + + "R. Bruni" "J. Meseguer" + "U. Montanari" "V. Sassone" + + "A Comparison of Petri Net Semantics under the Collective Token Philosophy" + + "Proceedings of {ASIAN'98}, 4th Asian Computing Science Conference" + "J. Hsiang" + "A. Ohori" "Lecture Notes in Computer Science" + "Springer-Verlag" + "1538" "1998" + "225-244" + + "A Logic Programming Language with Lambda-Abstraction Function Variables, and Simple Unification" + "D. Miller" + "Journal of Logic and Computation" "1991" + "1" "4" + + "497-536" + "A Calculus of Mobile Processes ({P}arts {I} and {II})" + "R. Milner" "J. Parrow" + "D. Walker" + "Information and Computation" "1992" + "100" "1-77" + + + "R. Milner" + "Communication and Concurrency" + "Prentice-Hall" "1989" + + "P. D. Mosses" + "The Use of Sorts in Algebraic Specifications" + + "Recent trends in Data Type Specification, 8th WADT, August 1991" + "M. Bidoit" + "C. Choppy" "66-91" + "Lecture Notes in Computer Science" + "Springer-Verlag" "655" + + "1993" + "Final algebras, cosemicomputable algebras and degrees of unsolvability" + "L. S. Moss" + "J. Meseguer" "J. A. Goguen" + "Theoretical Computer Science" + "1992" "100" "267-302" + + + "On proving inductive properties in abstract data types" + "D. L. Musser" + "Proceedings of the 7th Annual ACM Symposium on Principles of Programming Languages" + "1980" "January" + "154-162" + + + "T. Nipkow" + "Higher Order Critical Pairs" + "Proceedings 6th IEEE Symposium on Logic in Computer Science" + "1991" "342-349" + + "W. Nutt" + "P. R{'e}ty" "G. Smolka" + "Basic Narrowing Revisited" + "Journal of Symbolic Computation" + "1989" "7" "295-317" + + "F. Orejas" + "Implementation and Behavioural Equivalence: {A} Survey" + "Recent trends in Data Type Specification" + "Lecture Notes in Computer Science" + "Springer-Verlag" + "655" "1991" + + "J. Ostroff" + + "Formal Methods for the Specification and Design of Real-Time Safety-Critical Systems" + "Journal of Systems and Software" + "Elsevier" "1992" + + "33-60" "O. Owe" + "A specification Technique with Idealization" + "Department of informatics, University of Oslo, Norway" + "1980" "March" + + "O. Owe" + + "Axiomatic Treatment of Processes with Shared Variables Revisited" + "Formal Aspects of Computing" + "1992" "4" + "323-340" + "O. Owe" + "O.-J. Dahl" + "Generator Induction in Ordered Sorted Algebras" + "Formal Aspects of Computing" "1991" + "3" "2-20" + + "P. Padawitz" + "Strategy-Controlled Reduction and Narrowing" + + "Proceedings 2nd Conference on Rewriting Techniques and Applications, Bordeaux (France)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "256" + "242-255" + + + "Complete Sets of Reductions for Some Equational Theories" + "G. E. Peterson" + "M. E. Stickel" + "Journal of the Association Computing Machinery" + "1981" "28" "2" + "233-264" + + + "Semantic Confluence Tests and Completion Methods" + "D. Plaisted" + "Information and Control" "1985" + "65" "182-215" + + "D. Plaisted" + "A Logic for Conditional Term Rewriting Systems" + + "Proceedings 1st International Workshop on Conditional Term Rewriting Systems, Orsay (France)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "308" + "212-227" + + + "J. van de Pol" + "Termination Proofs for Higher-order Rewrite Systems" + + "First International Workshop on Higher-Order Algebra, Logic and Term Rewriting" + "1993" + "Springer-Verlag" + "Lecture Notes in Computer Science" "816" + "305-325" + + + "L. Puel" + "Proceedings 9th Colloquium on Trees in Algebra and Programming" + "1984" "B. Courcelle" + "Cambridge University Press" + "227-242" "Proof in the Final Algebra" + + "Z. Qian" + "Linear Unification of Higher-Order Patterns" + "Proceedings TAPSOFT'93" + "1993" "Springer-Verlag" + "Lecture Notes in Computer Science" + "668" "391-405" + + "U. S. Reddy" + "Term Rewriting Induction" + "Proceedings 10th International Conference on Automated Deduction, Kaiserslautern (Germany)" + "1990" + "Springer-Verlag" + "Lecture Notes in Computer Science" "449" + "162-177" + + "P. R{'e}ty" + "C. Kirchner" + "H. Kirchner" "P. Lescanne" + + "{NARROWER:} a new algorithm for unification and its application to Logic Programming" + + "Proceedings 1st Conference on Rewriting Techniques and Applications, Dijon (France)" + "1985" + "Springer-Verlag" + "Lecture Notes in Computer Science" "202" + "141-155" + + "P. R{'e}ty" + "Improving basic narrowing techniques" + + "Proceedings 2nd Conference on Rewriting Techniques and Applications, Bordeaux (France)" + "1987" + "Springer-Verlag" + "Lecture Notes in Computer Science" "256" + "228-241" + + "J. A. Robinson" + + "A machine-oriented logic based on the resolution principle" + "Journal of the Association Computing Machinery" + "1965" "12" + "1" "23-41" + + "W. Snyder" + "J. H. Gallier" + "Higher Order unification Reviseted : Complete Sets of Transformations" + "Journal of Symbolic Computation" + "8" "101-140" + + "1989" "M. Stickel" + "A unification algorithm for associative-commutative functions" + "Journal of the Association Computing Machinery" + "1981" "28" + "3" "423-434" + + "M. Wirsing" "J. A. Bergstra" + + "Algebraic Methods: Theory, Tools and Applications" + "Springer-Verlag" "1989" + "394" + "Lecture Notes in Computer Science" + + + "M. Wirsing" "Algebraic Specification" + "J. van Leeuwen" + "Handbook of Theoretical Computer Science" + "B" "13" + "Elsevier, Amsterdam" "1990" + + "K. A. Yelick" + + "Using Abstraction in Explicitly Parallel Programs" + "Massachusetts Institute of Technology" + "1990" + "Jia-Huai You" + "Outer Narrowing for Equational Theories Based on Constructors" + + "Proceedings 15th International Colloquium on Automata, Languages and Pro-gramming, Tampere (Finland)" + "1988" + "Springer-Verlag" + "Lecture Notes in Computer Science" "317" + "727-741" + + + "R. Bruni" "J. Meseguer" + "U. Montanari" + "Executable Tile Specifications for Process Calculi" + + "Proc. of FASE'99, 2nd Intl. Conf. on Fundamental Approaches to Software Engineering" + "1992" + "Springer-Verlag" + "Lecture Notes in Computer Science" "1577" + "60-76" + + "D. Harel" + + "From play-in scenarios to code: an achievable dream" + + "Proc. of FASE'00, 3rd Intl. Conf. on Fundamental Approaches to Software Engineering" + "2000" + "Springer-Verlag" + "Lecture Notes in Computer Science" "1783" + "22-34" + + "H. Zantema" + "Termination of term rewriting by interpretation" + + "Proceedings 3rd International Workshop on Conditional Term Rewriting Systems, Pont-a-Mousson (France)" + "1992" + "Springer-Verlag" + "Lecture Notes in Computer Science" "656" + "155-167" + + + "P. C. {O}lveczky" + "Terminering av typeordnet omskrivning" + "Department of informatics, University of Oslo, Norway" + "1994" + + + "P. C. {O}lveczky" + "Termination of order-sorted rewriting" + "Proceedings of the 6th {N}ordic {W}orkshop on {P}rogramming {T}heory, {A}arhus, {D}enmark" + "1995" "To appear" + + + "Peter Csaba {\"O}lveczky" "Piotr Kosiuczenko" + "Martin Wirsing" + "An Object-Oriented Algebraic Steam-Boiler Control Specification" + "The Steam-Boiler Case Study Book" + "Jean-Raymond Abrial" + "Egon B{\"o}rger" "Hans Langmaack" + "379-402" + "Springer-Verlag" "1996" + "Vol. 1165" + + "R. Jagannathan" + "Coarse-Grain Parallel Programming of Conventional Parallel Computers Advanced Topics in Dataflow Computing and Multithreading" + "IEEE Computer Society Press" + "1995" + "L. Bic, J-L. Gaudiot, G. Gao (Editors)" + + + "ECSD98" "H.-D. Ehrich" + "C. Caleiro" "A Sernadas" + "G. Denker" + "{Logics for Specifying Concurrent Information Systems}" + "Logics for Databases and Information Systems" + "J. Chomicki" + "G. Saake" "Kluwer Academic Publishers" + "1998" "167-198" + + "G. Denker" + "H.-D. Ehrich" + "{Specifying Distributed Information Systems: Fundamentals of an Object-Oriented Approach Using Distributed Temporal Logic}" + + "{Formal Methods for Open Object-Based Distributed Systems (FMOODS'97), Volume 2, IFIP TC6 WG6.1 Intern. Workshop, 21-23 July, Canterbury, Kent, UK}" + "1997" "H. Bowman" + "J. Derrick" "89-104" + "" + "Chapman & Hall" "" + "" "" + + + "Ehr96" "H.-D. Ehrich" + "{Object Specification}" + "TU Braunschweig" "{Informatik-Bericht}" + "96--07" "1996" + + + "G. Denker" + "{dtlplus: A Distributed Temporal Logic Supporting Several Communication Principles}" + + "SRI International, Computer Science Laboratory" + "{Technical Report}" "1998" + "{}" + "333 Ravenswood Ave, Menlo Park, CA 94025" "" + "{em To appear}" + + + "G. Denker" "J. Meseguer" + "C. Talcott" + "{Protocol Specification and Analysis in Maude}" + + "{Proc. of Workshop on Formal Methods and Security Protocols, 25 June 1998, Indianapolis, Indiana}" + "1998" "N. Heintze" + "J. Wing" "" + "" "" + "" "" + "" + + "G. Denker" + "J. Millen" + "{{CAPSL} intermediate language}" + "{Proc. of Workshop on Formal Methods and Security Protocols, July 1999, Trento, Italy}" + "1999" "N. Heintze" + "E. Clarke" "" + "" "" + "" "" + + "url{www.cs.bell-labs.com/who/nch/fmsp99/program.html}" + + "H.-D. Ehrich" + "P. Hartel" + "{Temporal Specification of Information Systems}" + + "{Logic and Software Engineering, Proc. Int. Workshop in Honor of C.S. Tang,Beijing, 14-15 August 1995}" + "1996" "A. Pnueli" + "H. Lin" "43-71" + "" + "World Scientific" "" + "" "" + + "ESSS94" + "H.-D. Ehrich" + "A. Sernadas" "G. Saake" + "C. Sernadas" + "{Distributed Temporal Logic for Concurrent Object Families}" + "R. Wieringa" "R. Feenstra" + + "Working papers of the International Workshop on Information Systems - Correctness and Reusability" + "1994" + "Vrije Universiteit Amsterdam, RapportNr. IR-357" + + "22-30" "Kenneth L. McMillan" + "Symbolic Model Checking" + "Kluwer Academic Publishers" + "Boston, MA" "1993" + + + "David L. Dill" + "The {Mur{$phi$}} Verification System" "390-393" + + + "CAV" "Computer-Aided Verification, CAV" + "Computer-Aided Verification, CAV" + "July/August" "1996" + "Rajeev Alur" + "Thomas A. Henzinger" "New Brunswick, NJ" + "Springer-Verlag" + "Lecture Notes in Computer Science" + "1102" + "J. F. Quesada" + "Bidirectional and event-driven parsing with multi-virtual trees" + "C. Martin-Vide" + "Mathematical and Computational Models in Linguistics" + "John Benjamins" "1996" + + "J. F. Quesada" + "The {SCP} parsing algorithm based on syntactic constraints propagation" + "University of Seville" + "June" "1997" + + + "J. F. Quesada" "Overparsing" + "Workshop on Mathematical Linguistics" + "Pennsylvania State University, State College" + "1998" + + "J. F. Quesada" + "The {SCP} parsing algorithm" + "SRI International, Computer Science Laboratory" + "{Technical Report}" + "1999" "{}" + "333 Ravenswood Ave, Menlo Park, CA 94025" + "{em To appear}" + "J. F. Quesada" + "The {Maude} parser: Parsing and meta-parsing $\beta$-extended %context-free grammars" + + "SRI International, Computer Science Laboratory" + "{Technical Report}" "1999" + "{}" + "333 Ravenswood Ave, Menlo Park, CA 94025" + "{em To appear}" + "Francisco Dur'an" + "Jos'e Meseguer" + "The {Maude} Specification of {Full Maude}" + "Computer Science Laboratory, SRI International" + "February" "1999" + + + "M. J. C. Gordon" + "Introduction to {HOL:} {A} Theorem Proving Environment" + "Cambridge University Press" + "1993" + "D. J. Howe" + + "Semantical Foundations for Embedding {HOL} in {Nuprl}" + "Algebraic Methodology and Software Technology" + "1996" + "Martin Wirsing" "Maurice Nivat" + "Springer-Verlag" "Berlin" + "Lecture Notes in Computer Science" + "1101" "85-101" + + "C. L. Talcott" + "Actor Theories in Rewriting Logic" + "1999" "Submitted for publication" + + + "Joseph A. Goguen" "Grant Malcolm" + + "Software Engineering with {OBJ}: Algebraic Specification in Action" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Kluwer Academic Publishers, Boston" + "Advances in Formal Methods" + "2" "ISBN 0-7923-7757-5" + + "2000" "Joseph A. Goguen" + "Timothy Winkler" + "Jos'{e} Meseguer" "Kokichi Futatsugi" + "Jean-Pierre Jouannaud" + "Introducing {OBJ}" "1" + "3-167" + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Victoria Stavridou" + "Specifying in {OBJ}, Verifying in {REVE} and Some Ideas about Time" + "2" "171-191" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Ataru T. Nakagawa" + "Kokichi Futatsugi" + "Constructing a Graphics System with {OBJ2}: {A} Practical Guide" + "3" "193-247" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "David A. Duce" + "Applications of {OBJ} to the Specification of Standards for Computer Graphics" + "4" "249-279" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Joseph A. Goguen" + "Semantic Specifications for the {R}ewrite {R}ule {M}achine" + "5" "283-306" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Claude Kirchner" "H'{e}l`{e}ne Kirchner" + "Aristide M'{e}grelis" + "{OBJ} for {OBJ}" "6" + "307-330" + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Eugenio Battiston" "Fiorella De Cindio" + "Giancarlo Mauri" + "{OBJSA} Nets: {OBJ} and Petri Nets for Specifying Concurrent Systems" + "7" "331-360" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Kazuhito Ohmaki" "Koichi Takahashi" + "Kokichi Futatsugi" + "A {LOTOS} Simulator in {OBJ}" "8" + "363-395" + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + + "Joseph A. Goguen" "Grant Malcolm" + "More Higher Order Programming in {OBJ3}" + "9" "397-408" + + "Software Engineering with OBJ: Algebraic Specification in Action" + "Joseph A. Goguen" + "Grant Malcolm" "Kluwer, Boston" + "2000" + + "I. A. Mason" + "C. L. Talcott" + "Actor Languages: Their Syntax, Semantics, Translation, and Equivalence" + "1999" + "Theoretical Computer Science" "228" + "1" + + + "I. A. Mason" "C. L. Talcott" + "A Semantically Sound Actor Translation" + "{ICALP'97}" + "1997" "Lecture Notes in Computer Science" + "1256" "369-378" + + "C. L. Talcott" + + "Towards a Toolkit for Actor System Specification" + "{AMAST 2000}" "2000" + "Lecture Notes in Computer Science" + "To appear" + + + "J. Van Baalen" "J. L. Caldwell" + "S. Mishra" + "Specifying and checking fault-tolerant agent-based protocols using {Maude}" + "Formal Approaches to Agent-Based Systems" + "2000" + "Lecture Notes in Computer Science" "To appear" + + "M.-O. Stehr" + "C. Girault" + "R. Valk" + "Petri Nets for System Engineering -- A Guide to Modelling, Verification, and Applications" + "A Rewriting Semantics for Algebraic Nets" + "Springer-Verlag" + "2000" "To appear" + + "M.-O. Stehr" + "J. Meseguer" + "Pure Type Systems in Rewriting Logic" + "Proc. of LFM'99: Workshop on Logical Frameworks and Meta-languages, Paris, France, September 28, 1999" + + "url{http://www.cs.bell-labs.com/~felty/LFM99/}" + + "M.-O. Stehr" + "P. Naumov" + "J. Meseguer" + "A Proof-Theoretic Approach to the {HOL-Nuprl} Connection with Applications to Proof Translation" + + "Manuscript, SRI International, url{http://www.csl.sri.com/~stehr/fi_eng.html}" + "February" "2000" + + + "Seven good reasons for mobile agents" + "Danny B. Lange" "Mitsuru Oshima" + + "Communications of the Association for Computing Machinery" + "1999" "42" + "March" "88-89" + + + "editor {Giovanni Vigna}" + "Mobile Agents and Security" "LNCS 1419" + "1998" + + + "David Kotz" "Robert S. Gray" + "Mobile Agents and the Future of the {Internet}" + "ACM Operating Systems Review" + "1999" "August" "33" + "3" "7-13" + + "http://www.cs.dartmouth.edu/~dfk/papers/kotz:future2/" + + + "D. Martin" "A. Cheyer" + "D. Moran" + "The Open Agent Architecture: {A} framework for building distributed software systems" + "Applied Artificial Intelligence" + "1999" "13" + "91-128" + "Available via url{http://www.ai.sri.com/~cheyer/papers/aai/oaa.html}" + + + "Robert S. Gray" "David Kotz" + "George Cybenko" + "Daniela Rus" + "{D'Agents}: Security in a multiple-language, mobile-agent system" + "Mobile Agents and Security" + "Giovanni Vigna" "1998" + "LNCS 1419" "154-187" + "Springer-Verlag" + "http://agent.cs.dartmouth.edu/papers/gray:security-book.ps.Z" + + "Danny Lange" + "Mitsushuru Oshima" + "Programming and Deploying Java Mobile Agents with Aglets" + "Addison-Wesley" "1998" + + + "M. Abadi" "A. Gordon" + + "A Calculus for cryptographic protocols: the spi calculus" + "Information and Computation" + "1999" "148" "1-70" + + "An extended version of this paper appears as Research Report 149, Digital Equipment Corporation Systems Research Center, January 1998" + + + "James White" + "Telescript technology: the foundation for the electronic marketplace" + "1994" + "General Magic White Paper, General Magic, Inc." + + "L. Cardelli" + "A. Gordon" "Mobile Ambients" + + "Proceedings of {FoSSaCS'98}: Foundations of Software Science and Computational Structures" + "Lecture Notes in Computer Science" + "M. Nivat" + "Springer-Verlag" "1378" + "1998" "140-155" + "To appear in TCS July 2000" + + "G. C. Roman" + "P. J. McCann" + "J. Y. Plun" + "Mobile {UNITY}: Reasoning and specification in mobile computing" + + "ACM Transactions on Software Engineering and Methodology" + "1997" "6" + "250-282" "July" + + "C. Fournet" + "G. Gonthier" + "The reflexive {CHAM} and the join-calculus" "1996" + + "Proceedings of 23rd ACM Symposium on Principles of Programming Languages" + "ACM" "52-66" + + "P. Ciancarini" + "A. L. Wolf (eds.)" + "Coordination Languages And Models" "1999" + "Springer LNCS" + "1594" + "Anand Tripathi" + "Neeran Karnik" + "Manish Vora" "Tanvir Ahmed" + "Ram Singh" + "Mobile Agent Programming in Ajanta" + "Proceedings of the 19th International Confernce on Distributed Computing Systems (ICDCS '99)" + "1999" + + + + diff --git a/packages/raptor/cmake/FindRAPTOR.cmake b/packages/raptor/cmake/FindRAPTOR.cmake new file mode 100644 index 000000000..ca3c7dbc1 --- /dev/null +++ b/packages/raptor/cmake/FindRAPTOR.cmake @@ -0,0 +1,103 @@ +# - Try to find the Raptor RDF parsing library (http://librdf.org/raptor/) +# Once done this will define +# +# RAPTOR_FOUND - system has Raptor +# RAPTOR_LIBRARIES - Link these to use Raptor +# RAPTOR_INCLUDE_DIR - Include directory for using Raptor +# RAPTOR_DEFINITIONS - Compiler switches required for using Raptor +# +# Capabilities +# RAPTOR_HAVE_TRIG - Set if raptor has TRIG + +# (c) 2007-2011 Sebastian Trueg +# (c) 2011 Artem Serebriyskiy +# (c) 2011 Michael Jansen +# +# Based on FindFontconfig Copyright (c) 2006,2007 Laurent Montel, +# +# Redistribution and use is allowed according to the terms of the BSD license. +# For details see the accompanying COPYING-CMAKE-SCRIPTS file. + + +MACRO ( FIND_RAPTOR ) + +ENDMACRO () + + + +# Check if we have cached results in case the last round was successful. +if ( NOT( RAPTOR_INCLUDE_DIR AND RAPTOR_LIBRARIES ) OR NOT RAPTOR_FOUND ) + + set( RAPTOR_LDFLAGS ) + + find_package(PkgConfig) + + if ( NOT WIN32 ) + pkg_check_modules(PC_RAPTOR QUIET raptor) + if ( PC_RAPTOR_FOUND ) + set(RAPTOR_DEFINITIONS ${PC_RAPTOR_CFLAGS_OTHER}) + set(RAPTOR_VERSION ${PC_RAPTOR_VERSION} CACHE STRING "Raptor Version found" ) + string( REGEX REPLACE "^.*-lraptor;" "" RAPTOR_LDFLAGS "${PC_RAPTOR_STATIC_LDFLAGS}") + endif () + endif () + + find_path(RAPTOR_INCLUDE_DIR + NAMES raptor2.h raptor2/raptor2.h raptor.h raptor/raptor.h + PATHS $ENV{RAPTOR_DIR}/include + $ENV{RAPTOR_DIR} + ~/Library/Frameworks + /Library/Frameworks + /usr/local/include + /usr/include/ + /sw/include # Fink + /opt/local/include # MacPorts + /opt/csw/include # Blastwave + /usr/local/opt/raptor/include # brew + /opt/include + /usr/freeware/include + + ) + + + find_library(RAPTOR_LIBRARY + NAMES raptor raptor2 + PATHS $ENV{RAPTOR_DIR}/lib + $ENV{RAPTOR_DIR}/lib-dbg + $ENV{RAPTOR_DIR} + ~/Library/Frameworks + /Library/Frameworks + /usr/local/lib + /usr/local/lib64 + /usr/lib + /usr/lib64 + /sw/lib # Fink + /opt/local/lib # MacPorts + /opt/csw/lib # Blastwave + /usr/local/opt/raptor/lib # brew + /opt/lib + /usr/freeware/lib64 + ) + + if ( RAPTOR_LDFLAGS ) + set( RAPTOR_LIBRARY ${RAPTOR_LIBRARY} ${RAPTOR_LDFLAGS} ) + endif () + + mark_as_advanced(RAPTOR_INCLUDE_DIR RAPTOR_LIBRARY) + +endif () # Check for cached values + +include(FindPackageHandleStandardArgs) + +find_package_handle_standard_args( + Raptor + VERSION_VAR RAPTOR_VERSION + REQUIRED_VARS RAPTOR_LIBRARY RAPTOR_INCLUDE_DIR) + +mark_as_advanced(RAPTOR_VERSION) + +if (NOT RAPTOR_FOUND AND Raptor_FIND_VERSION_MAJOR EQUAL "2" AND NOT Raptor_FIND_QUIET ) + pkg_check_modules(PC_RAPTOR QUIET raptor) + if (PC_RAPTOR_FOUND) + message( STATUS "You have raptor1 version ${PC_RAPTOR_VERSION} installed. Please update." ) + endif () +endif () diff --git a/packages/raptor/cmake/FindYAP.cmake b/packages/raptor/cmake/FindYAP.cmake new file mode 100644 index 000000000..220206c94 --- /dev/null +++ b/packages/raptor/cmake/FindYAP.cmake @@ -0,0 +1,76 @@ +# CMake module to search for YAP library +# +# If YAP_INCLUDE_DIR and YAP_PL_LIBRARY_DIR sets YAP_FOUND +# Also checks for YAP_LIBRARY + +if (YAP_ROOT) + set( YAP_INCLUDE_DIR ../../include ) + set( YAP_PL_LIBRARY_DIR ${libpl} ) + set( YAP_LIBRARY libYap ) + set( YAP_DLLS ${dlls} ) + +else() + + FIND_PATH(YAP_INCLUDE_DIR YapInterface.h + /usr/local/include/Yap + /usr/include/Yap + #MSVC + "$ENV{LIB_DIR}/include/Yap" + #mingw + c:/msys/local/include/Yap + c:/Yap/include/Yap + c:/Yap64/include/Yap + "c:/Program Files/Yap/include/Yap" + "c:/Program Files (x86)/Yap/include/Yap" + ) + +FIND_PATH(YAP_PL_LIBRARY_DIR terms.yap + /usr/local/share/Yap + /usr/share/Yap + #MSVC + "$ENV{LIB_DIR}/share/Yap" + #mingw + c:/msys/local/share/Yap + c:/Yap/share/Yap + c:/Yap64/share/Yap + "c:/Program Files/Yap/share/Yap" + "c:/Program Files (x86)/Yap/share/Yap" +) + +FIND_LIBRARY(YAP_LIBRARY NAMES libYap.a libYap.so libYap.dylib PATHS + /usr/local/lib + /usr/lib + #MSVC + "$ENV{LIB_DIR}/lib" + #mingw + c:/msys/local/lib + c:/msys/local/lib + c:/Yap/lib + c:/Yap64/lib + "c:/Program Files/Yap/lib" + "c:/Program Files (x86)/Yap/lib" + ) + +If (YAP_INCLUDE_DIR AND YAP_PL_LIBRARY_DIR) + SET(YAP_FOUND TRUE) +ENDIF (YAP_INCLUDE_DIR AND YAP_PL_LIBRARY_DIR) + +IF (YAP_FOUND) + + IF (NOT YAP_FIND_QUIETLY) + MESSAGE(STATUS "Found YAP: ${YAP_LIBRARY}") + ENDIF (NOT YAP_FIND_QUIETLY) + + get_filename_component( YAP_DLLS ${YAP_LIBRARY} PATH ) + set( dlls ${YAP_DLLS}/Yap ) + +ELSE (YAP_FOUND) + + IF (YAP_FIND_REQUIRED) + MESSAGE(SYSTEM_ERROR_FATAL "Could not find YAP") + ENDIF (YAP_FIND_REQUIRED) + + ENDIF (YAP_FOUND) + +endif() + diff --git a/packages/raptor/cmake_install.cmake b/packages/raptor/cmake_install.cmake new file mode 100644 index 000000000..d64c3571d --- /dev/null +++ b/packages/raptor/cmake_install.cmake @@ -0,0 +1,81 @@ +# Install script for directory: /Users/vsc/git/yap-6.3/packages/raptor + +# Set the install prefix +if(NOT DEFINED CMAKE_INSTALL_PREFIX) + set(CMAKE_INSTALL_PREFIX "/usr/local") +endif() +string(REGEX REPLACE "/$" "" CMAKE_INSTALL_PREFIX "${CMAKE_INSTALL_PREFIX}") + +# Set the install configuration name. +if(NOT DEFINED CMAKE_INSTALL_CONFIG_NAME) + if(BUILD_TYPE) + string(REGEX REPLACE "^[^A-Za-z0-9_]+" "" + CMAKE_INSTALL_CONFIG_NAME "${BUILD_TYPE}") + else() + set(CMAKE_INSTALL_CONFIG_NAME "Debug") + endif() + message(STATUS "Install configuration: \"${CMAKE_INSTALL_CONFIG_NAME}\"") +endif() + +# Set the component getting installed. +if(NOT CMAKE_INSTALL_COMPONENT) + if(COMPONENT) + message(STATUS "Install component: \"${COMPONENT}\"") + set(CMAKE_INSTALL_COMPONENT "${COMPONENT}") + else() + set(CMAKE_INSTALL_COMPONENT) + endif() +endif() + +if(NOT CMAKE_INSTALL_COMPONENT OR "${CMAKE_INSTALL_COMPONENT}" STREQUAL "Unspecified") + list(APPEND CMAKE_ABSOLUTE_DESTINATION_FILES + "/usr/local/lib/Yap/raptor.dylib") + if(CMAKE_WARN_ON_ABSOLUTE_INSTALL_DESTINATION) + message(WARNING "ABSOLUTE path INSTALL DESTINATION : ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() + if(CMAKE_ERROR_ON_ABSOLUTE_INSTALL_DESTINATION) + message(FATAL_ERROR "ABSOLUTE path INSTALL DESTINATION forbidden (by caller): ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() +file(INSTALL DESTINATION "/usr/local/lib/Yap" TYPE SHARED_LIBRARY FILES "/Users/vsc/git/yap-6.3/packages/raptor/raptor.dylib") + if(EXISTS "$ENV{DESTDIR}/usr/local/lib/Yap/raptor.dylib" AND + NOT IS_SYMLINK "$ENV{DESTDIR}/usr/local/lib/Yap/raptor.dylib") + execute_process(COMMAND "/usr/bin/install_name_tool" + -id "raptor.dylib" + -change "/Users/vsc/git/yap-6.3/utf8proc/libutf8proc.1.dylib" "libutf8proc.1.dylib" + "$ENV{DESTDIR}/usr/local/lib/Yap/raptor.dylib") + execute_process(COMMAND /usr/bin/install_name_tool + -delete_rpath "/Users/vsc/git/yap-6.3" + "$ENV{DESTDIR}/usr/local/lib/Yap/raptor.dylib") + execute_process(COMMAND /usr/bin/install_name_tool + -add_rpath "/usr/local/lib" + "$ENV{DESTDIR}/usr/local/lib/Yap/raptor.dylib") + if(CMAKE_INSTALL_DO_STRIP) + execute_process(COMMAND "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/strip" "$ENV{DESTDIR}/usr/local/lib/Yap/raptor.dylib") + endif() + endif() +endif() + +if(NOT CMAKE_INSTALL_COMPONENT OR "${CMAKE_INSTALL_COMPONENT}" STREQUAL "Unspecified") + list(APPEND CMAKE_ABSOLUTE_DESTINATION_FILES + "/usr/local/share/Yap/raptor.yap") + if(CMAKE_WARN_ON_ABSOLUTE_INSTALL_DESTINATION) + message(WARNING "ABSOLUTE path INSTALL DESTINATION : ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() + if(CMAKE_ERROR_ON_ABSOLUTE_INSTALL_DESTINATION) + message(FATAL_ERROR "ABSOLUTE path INSTALL DESTINATION forbidden (by caller): ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() +file(INSTALL DESTINATION "/usr/local/share/Yap" TYPE FILE FILES "/Users/vsc/git/yap-6.3/packages/raptor/raptor.yap") +endif() + +if(NOT CMAKE_INSTALL_COMPONENT OR "${CMAKE_INSTALL_COMPONENT}" STREQUAL "Unspecified") + list(APPEND CMAKE_ABSOLUTE_DESTINATION_FILES + "/usr/local/share/Yap/rdf.yap") + if(CMAKE_WARN_ON_ABSOLUTE_INSTALL_DESTINATION) + message(WARNING "ABSOLUTE path INSTALL DESTINATION : ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() + if(CMAKE_ERROR_ON_ABSOLUTE_INSTALL_DESTINATION) + message(FATAL_ERROR "ABSOLUTE path INSTALL DESTINATION forbidden (by caller): ${CMAKE_ABSOLUTE_DESTINATION_FILES}") + endif() +file(INSTALL DESTINATION "/usr/local/share/Yap" TYPE FILE FILES "/Users/vsc/git/yap-6.3/packages/raptor/rdf.yap") +endif() + diff --git a/packages/raptor/configure.in b/packages/raptor/configure.in new file mode 100644 index 000000000..fb1840ba4 --- /dev/null +++ b/packages/raptor/configure.in @@ -0,0 +1,94 @@ +dnl Process this file with autoconf to produce a configure script. + +m4_ifdef([HAS_TOP],[m4_ignore],[ +AC_INIT(install-sh) +AC_PREREQ([2.50]) +AC_CONFIG_HEADER(config.h) +]) + +AC_ARG_WITH(raptor, + [ --with-raptor[=DIR] raptor RDF parser], + if test "$withval" = yes; then + yap_cv_raptor=yes + elif test "$withval" = no; then + yap_cv_raptor=no + else + yap_cv_raptor=$withval + fi, + [yap_cv_raptor=yes]) + + +AC_SUBST(PKG_RAPTOR) +AC_SUBST(RAPTOR_LIBS) +AC_SUBST(RAPTOR_CPPFLAGS) + +if test "$yap_cv_raptor" = no; +then + PKG_RAPTOR="" +else + + old_inc="$CPPFLAGS" + old_libs="$LIBS" + + if test "$yap_cv_raptor" != "NONE" -a "$yap_cv_raptor" != "yes"; then + RAPTOR_CPPFLAGS="-I $yap_cv_raptor/include" + raptor_dir="$yap_cv_raptor" + elif test "$prefix" != "NONE"; then + RAPTOR_CPPFLAGS="-I $prefix/include" + raptor_dir="$prefix" + else + RAPTOR_CPPFLAGS="-I /usr/local/include" + raptor_dir=/usr/local + fi + + CPPFLAGS="$CPPFLAGS $RAPTOR_CPPFLAGS" + + AC_CHECK_HEADERS(raptor2/raptor2.h) + AC_CHECK_HEADERS(raptor.h) + + +dnl raptor can be most everywhere + if test -d "$raptor_dir/lib64/raptor" -a "$YAP_TARGET" = amd64; then + LIBS="-L $raptor_dir/lib64/raptor" + elif test -d "$raptor_dir/lib64" -a "$YAP_TARGET" = amd64; then + LIBS="$LIBS -L $raptor_dir/lib64 -L $raptor_dir/lib " + elif test -d "$raptor_dir/lib/raptor"; then + LIBS="$LIBS -L $raptor_dir/lib/raptor" + elif test -d "$raptor_dir/lib"; then + LIBS="$LIBS -L $raptor_dir/lib" + fi + + AC_CHECK_LIB( raptor2, raptor_world_open, [], [ + AC_CHECK_LIB( raptor, raptor_world_open, [], [raptor_available=no]] ) + ) + RAPTOR_LIBS="$LIBS" + + if test "$raptor_available" = no + then + PKG_RAPTOR="" + cat << EOF +################################################################## +# ERROR: Could not find raptor library. Either I don't have the +# correct path, or RAPTOR is installed in some strange way +################################################################## +EOF +else + PKG_RAPTOR="packages/raptor" +fi + + + CPPFLAGS="$old_inc" + LIBS="$oldlibs" + +fi + + +m4_ifdef([HAS_TOP],[ + AC_CONFIG_HEADER(packages/raptor/raptor_config.h) + AC_OUTPUT(packages/raptor/Makefile) + ] + ,[ + AC_CONFIG_HEADER(raptor_config.h) + AC_OUTPUT(Makefile) + ]) + diff --git a/packages/raptor/example.rdf b/packages/raptor/example.rdf new file mode 100644 index 000000000..99d6f8b12 --- /dev/null +++ b/packages/raptor/example.rdf @@ -0,0 +1,15 @@ + + + + + + + + + + + + + + diff --git a/packages/raptor/music.rdf b/packages/raptor/music.rdf new file mode 100644 index 000000000..922ba7819 --- /dev/null +++ b/packages/raptor/music.rdf @@ -0,0 +1,27 @@ + + + + + + Bob Dylan + USA + Columbia + 10.90 + 1985 + + + + Bonnie Tyler + UK + CBS Records + 9.90 + 1988 + +. +. +. + diff --git a/packages/raptor/raptor.yap b/packages/raptor/raptor.yap new file mode 100644 index 000000000..7e8d464c3 --- /dev/null +++ b/packages/raptor/raptor.yap @@ -0,0 +1,3 @@ + +:- load_foreign_files(['raptor'],[],raptor_yap_init). + diff --git a/packages/raptor/raptor_config.h b/packages/raptor/raptor_config.h new file mode 100644 index 000000000..e8ac59e6c --- /dev/null +++ b/packages/raptor/raptor_config.h @@ -0,0 +1,2 @@ +#define HAVE_RAPTOR2_RAPTOR2_H 1 +/* #undef HAVE_RAPTOR_H */ diff --git a/packages/raptor/raptor_config.h.cmake b/packages/raptor/raptor_config.h.cmake new file mode 100644 index 000000000..b02736725 --- /dev/null +++ b/packages/raptor/raptor_config.h.cmake @@ -0,0 +1,2 @@ +#cmakedefine HAVE_RAPTOR2_RAPTOR2_H ${HAVE_RAPTOR2_RAPTOR2_H} +#cmakedefine HAVE_RAPTOR_H ${HAVE_RAPTOR_H} diff --git a/packages/raptor/raptor_config.h.in b/packages/raptor/raptor_config.h.in new file mode 100644 index 000000000..dcdb03e91 --- /dev/null +++ b/packages/raptor/raptor_config.h.in @@ -0,0 +1,2 @@ +#undef HAVE_RAPTOR2_RAPTOR2_H +#undef HAVE_RAPTOR_H diff --git a/packages/raptor/raptor_yap.c b/packages/raptor/raptor_yap.c new file mode 100644 index 000000000..ba7301675 --- /dev/null +++ b/packages/raptor/raptor_yap.c @@ -0,0 +1,175 @@ +/* Copyright (C) 2013 David Vaz + * + * 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 General Public + * License along with this program; if not, write to the Free + * Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + */ +#include +#include +#include +#include + +#include "raptor_config.h" +#include "YapInterface.h" +#ifdef HAVE_RAPTOR2_RAPTOR2_H +#include "raptor2/raptor2.h" +#else +#include "raptor2.h" +#endif + +void raptor_yap_init (void); + +raptor_world* world; + +struct exo_aux { + YAP_Functor functor; + YAP_PredEntryPtr pred; + size_t n; +}; + +static YAP_Atom +term_load(const raptor_term *term) +{ + size_t len; + switch(term->type) { + case RAPTOR_TERM_TYPE_LITERAL: +// fprintf(stderr, "%s,", term->value.literal.string); + return YAP_LookupAtom((const char *)term->value.literal.string); + + case RAPTOR_TERM_TYPE_BLANK: +// fprintf(stderr, "%s,", term->value.blank.string); + return YAP_LookupAtom((const char *)term->value.blank.string); + + case RAPTOR_TERM_TYPE_URI: +// fprintf(stderr, "%s,", raptor_uri_as_counted_string(term->value.uri, &len)); + return YAP_LookupAtom((const char *)raptor_uri_as_counted_string(term->value.uri, &len)); + + case RAPTOR_TERM_TYPE_UNKNOWN: + default: + raptor_log_error_formatted(term->world, RAPTOR_LOG_LEVEL_ERROR, NULL, + "Triple has unsupported term type %d", + term->type); + break; + } + + return NULL; +} + +static int so_far = 0; + +static void +load_triples(void* user_data, raptor_statement* triple) +{ + struct exo_aux *aux = (struct exo_aux *) user_data; + YAP_Term args[4]; + + //args[0] = (YAP_CELL)aux->functor; + args[0] = YAP_MkAtomTerm(term_load(triple->subject)); + args[1] = YAP_MkAtomTerm(term_load(triple->predicate)); + args[2] = YAP_MkAtomTerm(term_load(triple->object)); +// fprintf(stderr, "\n"); + + YAP_AssertTuples( aux->pred, args, so_far++, 1 ); +} + +static void +count_triples(void* user_data, raptor_statement* triple) +{ + unsigned int* count_p = (unsigned int*)user_data; + (*count_p)++; + + term_load(triple->subject); + term_load(triple->predicate); + term_load(triple->object); +// fprintf(stderr, "\n"); +} + +static YAP_Bool +load(void) +{ + YAP_Term tfn = YAP_ARG1; + YAP_Term mod = YAP_ARG2; + YAP_Term tfunctor = YAP_ARG3; + const char *filename; + + raptor_parser* rdf_parser = NULL; + unsigned int count; + unsigned char *uri_string; + raptor_uri *uri, *base_uri; + + if (YAP_IsVarTerm(tfn) || !YAP_IsAtomTerm(tfn)) { + return FALSE; + } + + filename = YAP_AtomName(YAP_AtomOfTerm(tfn)); + + rdf_parser = raptor_new_parser(world, "rdfxml"); + + raptor_parser_set_statement_handler(rdf_parser, &count, count_triples); + + uri_string = raptor_uri_filename_to_uri_string(filename); + uri = raptor_new_uri(world, uri_string); + base_uri = raptor_uri_copy(uri); + + count = 0; + if(!raptor_parser_parse_file(rdf_parser, uri, base_uri)) { +// fprintf(stderr, "%s : %d triples\n", filename, count); + } else { + fprintf(stderr, "%s : failed to parse\n", filename); + return FALSE; + } + + /* now lets load */ + { + struct exo_aux aux; + size_t sz; + + aux.functor = YAP_MkFunctor(YAP_AtomOfTerm(tfunctor), 3); + aux.pred = YAP_FunctorToPredInModule( aux.functor, mod ); + sz = 3*sizeof(YAP_CELL)*count; + + if (!YAP_NewExo( aux.pred, sz, NULL)){ + fprintf(stderr, "Failed to alocate space\n"); + return FALSE; + } + + aux.n = 0; + raptor_parser_set_statement_handler(rdf_parser, (void *) &aux, load_triples); + if(!raptor_parser_parse_file(rdf_parser, uri, base_uri)) { + fprintf(stderr, "%s : %d triples\n", filename, count); + } + } + + raptor_free_uri(base_uri); + raptor_free_uri(uri); + raptor_free_memory(uri_string); + + raptor_free_parser(rdf_parser); + + return TRUE; +} + +static inline void +raptor_yap_halt (int exit, void* world) +{ + raptor_free_world((raptor_world*) world); +} + +void raptor_yap_init (void) +{ + world = raptor_new_world(); + YAP_HaltRegisterHook (raptor_yap_halt, (void *) world); + + YAP_UserCPredicate("rdf_load", load, 3); +} diff --git a/packages/raptor/raptor_yap.c~ b/packages/raptor/raptor_yap.c~ new file mode 100644 index 000000000..70c1bf2b0 --- /dev/null +++ b/packages/raptor/raptor_yap.c~ @@ -0,0 +1,174 @@ +/* Copyright (C) 2013 David Vaz + * + * 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 General Public + * License along with this program; if not, write to the Free + * Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + */ +#include +#include +#include +#include + +#include "raptor_config.h" +#include "YapInterface.h" +#ifdef HAVE_RAPTOR2_RAPTOR2_H +#include "raptor2/raptor2.h" +#elif HAVE_RAPTOR2_H +#include "raptor2.h" +#else +#include "raptor.h" +#endif + +raptor_world* world; + +struct exo_aux { + void * handle; + YAP_Functor functor; + int n; +}; + +YAP_Atom +term_load(const raptor_term *term) +{ + size_t len; + switch(term->type) { + case RAPTOR_TERM_TYPE_LITERAL: +// fprintf(stderr, "%s,", term->value.literal.string); + return YAP_LookupAtom(term->value.literal.string); + + case RAPTOR_TERM_TYPE_BLANK: +// fprintf(stderr, "%s,", term->value.blank.string); + return YAP_LookupAtom(term->value.blank.string); + + case RAPTOR_TERM_TYPE_URI: +// fprintf(stderr, "%s,", raptor_uri_as_counted_string(term->value.uri, &len)); + return YAP_LookupAtom(raptor_uri_as_counted_string(term->value.uri, &len)); + + case RAPTOR_TERM_TYPE_UNKNOWN: + default: + raptor_log_error_formatted(term->world, RAPTOR_LOG_LEVEL_ERROR, NULL, + "Triple has unsupported term type %d", + term->type); + break; + } + + return NULL; +} + +static void +load_triples(void* user_data, raptor_statement* triple) +{ + struct exo_aux *aux = (struct exo_aux *) user_data; + YAP_Term appl; + YAP_Term args[3]; + + args[0] = YAP_MkAtomTerm(term_load(triple->subject)); + args[1] = YAP_MkAtomTerm(term_load(triple->predicate)); + args[2] = YAP_MkAtomTerm(term_load(triple->object)); +// fprintf(stderr, "\n"); + + appl = YAP_MkApplTerm(aux->functor, 3, args); + + exoassert(aux->handle, aux->n++, appl ); +} + +static void +count_triples(void* user_data, raptor_statement* triple) +{ + unsigned int* count_p = (unsigned int*)user_data; + (*count_p)++; + + term_load(triple->subject); + term_load(triple->predicate); + term_load(triple->object); +// fprintf(stderr, "\n"); +} + +static YAP_Bool +load(void) +{ + YAP_Term tfn = YAP_ARG1; + YAP_Term mod = YAP_ARG2; + YAP_Term tfunctor = YAP_ARG3; + const char *filename; + + raptor_parser* rdf_parser = NULL; + unsigned int count; + unsigned char *uri_string; + raptor_uri *uri, *base_uri; + + if (YAP_IsVarTerm(tfn) || !YAP_IsAtomTerm(tfn)) { + return FALSE; + } + + filename = YAP_AtomName(YAP_AtomOfTerm(tfn)); + + rdf_parser = raptor_new_parser(world, "rdfxml"); + + raptor_parser_set_statement_handler(rdf_parser, &count, count_triples); + + uri_string = raptor_uri_filename_to_uri_string(filename); + uri = raptor_new_uri(world, uri_string); + base_uri = raptor_uri_copy(uri); + + count = 0; + if(!raptor_parser_parse_file(rdf_parser, uri, base_uri)) { +// fprintf(stderr, "%s : %d triples\n", filename, count); + } else { + fprintf(stderr, "%s : failed to parse\n", filename); + return FALSE; + } + + /* now lets load */ + { + struct exo_aux aux; + YAP_Term appl; + + aux.functor = YAP_MkFunctor(YAP_AtomOfTerm(tfunctor), 3); + appl = YAP_MkNewApplTerm(aux.functor,3); + + if ((aux.handle = exodb_get_space(appl, mod, YAP_MkIntTerm(count))) == NULL){ + fprintf(stderr, "Failed to alocate space\n"); + return FALSE; + } + + aux.n = 0; + raptor_parser_set_statement_handler(rdf_parser, (void *) &aux, load_triples); + if(!raptor_parser_parse_file(rdf_parser, uri, base_uri)) { + fprintf(stderr, "%s : %d triples\n", filename, count); + } + } + + raptor_free_uri(base_uri); + raptor_free_uri(uri); + raptor_free_memory(uri_string); + + raptor_free_parser(rdf_parser); + + return TRUE; +} + +inline void +raptor_yap_halt (int exit, void* world) +{ + raptor_free_world((raptor_world*) world); +} + +void raptor_yap_init (void) +{ + world = raptor_new_world(); + YAP_HaltRegisterHook (raptor_yap_halt, (void *) world); + + YAP_UserCPredicate("rdf_load", load, 3); +} diff --git a/packages/raptor/rdf.yap b/packages/raptor/rdf.yap new file mode 100644 index 000000000..d08f7e05a --- /dev/null +++ b/packages/raptor/rdf.yap @@ -0,0 +1 @@ +:- load_foreign_files(['raptor'],[],raptor_yap_init). diff --git a/packages/real b/packages/real deleted file mode 160000 index e9135f8b6..000000000 --- a/packages/real +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e9135f8b6e2058f7133a7c16e2eb33ffa47749fc diff --git a/packages/semweb b/packages/semweb deleted file mode 160000 index 5105a53f4..000000000 --- a/packages/semweb +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 5105a53f4400903b742e445684bf762a9650af20 diff --git a/packages/sgml b/packages/sgml deleted file mode 160000 index 7c5ce10ef..000000000 --- a/packages/sgml +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 7c5ce10efc8f03b71543968cd98851cde0b0e868 diff --git a/packages/udi b/packages/udi deleted file mode 160000 index 5e423b2d0..000000000 --- a/packages/udi +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 5e423b2d029c9dbf320649b08fc0253d64853257 diff --git a/packages/udi/CMakeLists.txt b/packages/udi/CMakeLists.txt new file mode 100644 index 000000000..c09fa337a --- /dev/null +++ b/packages/udi/CMakeLists.txt @@ -0,0 +1,21 @@ +CMAKE_MINIMUM_REQUIRED ( VERSION 2.8 ) + +PROJECT ( YAP_UDI_INDEXERS C ) + +SET(CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake ${CMAKE_MODULE_PATH}) + +FIND_PACKAGE(YAP REQUIRED) +IF (NOT YAP_FOUND) + MESSAGE (SEND_ERROR "YAP was not found!") +ENDIF (NOT YAP_FOUND) + +INCLUDE_DIRECTORIES( + ${YAP_INCLUDE_DIR} + ${CMAKE_CURRENT_BINARY_DIR} + . +) + +#indexers +ADD_SUBDIRECTORY(rtree) +ADD_SUBDIRECTORY(b+tree) +ADD_SUBDIRECTORY(uthash) diff --git a/packages/udi/LOG b/packages/udi/LOG new file mode 100644 index 000000000..dedd1f5b8 --- /dev/null +++ b/packages/udi/LOG @@ -0,0 +1,34 @@ +Doxygen version 1.8.8 +Copyright Dimitri van Heesch 1997-2014 + +You can use doxygen in a number of ways: + +1) Use doxygen to generate a template configuration file: + /Users/vsc/bin/doxygen [-s] -g [configName] + + If - is used for configName doxygen will write to standard output. + +2) Use doxygen to update an old configuration file: + /Users/vsc/bin/doxygen [-s] -u [configName] + +3) Use doxygen to generate documentation using an existing configuration file: + /Users/vsc/bin/doxygen [configName] + + If - is used for configName doxygen will read from standard input. + +4) Use doxygen to generate a template file controlling the layout of the + generated documentation: + /Users/vsc/bin/doxygen -l layoutFileName.xml + +5) Use doxygen to generate a template style sheet file for RTF, HTML or Latex. + RTF: /Users/vsc/bin/doxygen -w rtf styleSheetFile + HTML: /Users/vsc/bin/doxygen -w html headerFile footerFile styleSheetFile [configFile] + LaTeX: /Users/vsc/bin/doxygen -w latex headerFile footerFile styleSheetFile [configFile] + +6) Use doxygen to generate a rtf extensions file + RTF: /Users/vsc/bin/doxygen -e rtf extensionsFile + +If -s is specified the comments of the configuration items in the config file will be omitted. +If configName is omitted `Doxyfile' will be used as a default. + +-v print version string diff --git a/packages/udi/LOGE b/packages/udi/LOGE new file mode 100644 index 000000000..45ce2a68e --- /dev/null +++ b/packages/udi/LOGE @@ -0,0 +1 @@ +error: configuration file docs/doxfull.rc not found! diff --git a/packages/udi/b+tree/CMakeLists.txt b/packages/udi/b+tree/CMakeLists.txt new file mode 100644 index 000000000..8264b72dc --- /dev/null +++ b/packages/udi/b+tree/CMakeLists.txt @@ -0,0 +1,17 @@ +CMAKE_MINIMUM_REQUIRED ( VERSION 2.8 ) + +PROJECT ( YAP_UDI_RTREE ) + +INCLUDE_DIRECTORIES( + . +) + +SET ( SOURCES + b+tree.c + b+tree_udi.c + ) + +ADD_LIBRARY(udi_b+tree SHARED ${SOURCES}) + +INSTALL(TARGETS udi_b+tree DESTINATION ${YAP_PL_LIBRARY_DIR}) +INSTALL(FILES b+tree.yap DESTINATION ${YAP_PL_LIBRARY_DIR}) diff --git a/packages/udi/b+tree/b+tree.c b/packages/udi/b+tree/b+tree.c new file mode 100644 index 000000000..a0f9f6f17 --- /dev/null +++ b/packages/udi/b+tree/b+tree.c @@ -0,0 +1,354 @@ +#include +#include +#include +#include + +#include "b+tree_private.h" + +btree_t BTreeNew (void) +{ + btree_t t; + t = BTreeNewNode(); + t->level = 0; /*leaf*/ + return t; +} + +void BTreeDestroy (btree_t t) +{ + if (t) + BTreeDestroyNode (t); +} + +static void BTreeDestroyNode (node_t n) +{ + int i; + + if (n->level == 0) + { + for (i = 0; i < n->count; i++) + ;/* allow user free data*/ + } + else + { + for (i = 0; i < n->count; i++) + BTreeDestroyNode (n->branch[i].child); + } +} + +static node_t BTreeNewNode (void) +{ + node_t n; + + n = (node_t) malloc (SIZEOF_NODE); + assert(n); + BTreeNodeInit(n); + return n; +} + +static void BTreeNodeInit (node_t n) +{ + memset((void *) n,0, SIZEOF_NODE); + n->level = -1; +} + +void *BTreeMin (node_t n, node_t *f, int *i) +{ + + if (n->level > 0) + return BTreeMin((node_t) n->branch[0].child, f, i); + else + { + if(f) + *f = n; + if(i) + *i = 0; + return n->branch[0].child; + } +} + +void *BTreeMax (node_t n, node_t *f, int *i) +{ + + if (n->level > 0) + return BTreeMax((node_t) n->branch[n->count].child, f, i); + else + { + if(n->count > 0) + { + if(f) + *f = n; + if(i) + *i = n->count - 1; + return n->branch[n->count - 1].child; + } + } + + if (f) + *f = NULL; + if (i) + *i = -1; + return NULL; +} + +void * BTreeSearch (node_t n, double k, int s, node_t *f, int *i) +{ + int j; + + assert(s == EQ || s == GE || s == GT); + + if (n->level > 0) + { + for (j = 0; j < n->count; j++) + if (n->branch[j].key >= k) + return BTreeSearch((node_t) n->branch[j].child,k,s,f,i); + return BTreeSearch((node_t) n->branch[j].child,k,s,f,i); + } + else + { + if (s == EQ || s == GE) /*== or >=*/ + for (j = 0; j < n->count; j++) + if (n->branch[j].key == k) + { + if (f) + *f = n; + if (i) + *i = j; + return n->branch[j].child; + } + if (s == GE || s == GT) /* >= or > */ + { + if (f) + *f = n; + for (j = 0; j < n->count; j++) + if (n->branch[j].key > k) + { + if (i) + *i = j; + return n->branch[j].child; + } + } + } + if (f) + *f = NULL; + if (i) + *i = -1; + return NULL; +} + +void *BTreeSearchNext (double max, int s, node_t *n, int *i) +{ + assert(n && i); + assert(s == LT || s == LE); + + if (*i == (*n)->count - 1) + { + if (!(*n)->branch[MAXCARD - 1].child) /*terminou*/ + return NULL; + *n = (node_t) (*n)->branch[MAXCARD - 1].child; + *i = 0; + } + else + (*i) ++; + + if ((*n)->branch[*i].key > max || + ((*n)->branch[*i].key == max && s == LT)) + return NULL; + + return (*n)->branch[*i].child; +} + +void BTreeInsert (btree_t *t, double k, void *ptr) +{ + node_t new_root; + + assert(t && *t); + + if (BTreeInsertNode(*t,&k,&ptr)) + /* deal with root split */ + { + new_root = BTreeNewNode(); + new_root->level = (*t)->level + 1; + new_root->count = 1; + new_root->branch[0].key = k; + new_root->branch[0].child = (void *) (*t); + new_root->branch[1].child = ptr; + *t = new_root; + } +} + +static int BTreeInsertNode(node_t n, double *k, void **ptr) +/*ptr holds data and can return node_t*/ +{ + int i; + + assert(n); + + if (n->level > 0) + { + i = BTreePickBranch(n,*k); + if (!BTreeInsertNode((node_t) n->branch[i].child, k, ptr)) + /*not split */ + { + return FALSE; + } + else + /* node split */ + { + return BTreeAddBranch(n, i, k, ptr); /*propagate split*/ + } + } + else + { + return BTreeAddLeaf(n,k,ptr); + } +} + +static int BTreeAddBranch(node_t n, int idx, double *k, + void **ptr) +{ + int i,j; + double key[MAXCARD]; + void *branch[MAXCARD+1]; + int level; + node_t t; + + if (n->count < MAXCARD - 1) + { + i = n->count; + if (i > 0) + for(; n->branch[i-1].key > *k ; i--) + { + n->branch[i].key = n->branch[i-1].key; + n->branch[i+1].child = n->branch[i].child; + } + n->branch[i].key = *k; + n->branch[i+1].child = *ptr; + n->branch[i].child = n->branch[idx].child; + n->count ++; + return FALSE; + } + else + { + for(i = n->count, j = MAXCARD; + n->branch[i - 1].key > *k; + i--, j--) + { + key[j - 1] = n->branch[i - 1].key; + branch[j] = n->branch[i].child; + } + key[j - 1] = *k; + branch[j - 1] = n->branch[idx].child; + branch[j] = *ptr; + j--; + for(; i > 0;i--,j--) + { + key[j-1] = n->branch[i-1].key; + branch[j-1] = n->branch[i-1].child; + } + + level = n->level; + BTreeNodeInit(n); + n->level = level; + t = BTreeNewNode(); + t->level = level; + + for (i = 0; i < MAXCARD / 2; i ++) + { + n->branch[i].key = key[i]; + n->branch[i].child = branch[i]; + n->count ++; + } + n->branch[i].child = branch[i]; + + *k = key[i]; + *ptr = t; + + for (j = 0,i++; i < MAXCARD; j ++, i ++) + { + t->branch[j].key = key[i]; + t->branch[j].child = branch[i]; + t->count ++; + } + t->branch[j].child = branch[i]; + + return TRUE; + } +} + +static int BTreePickBranch(node_t n, double k) +{ + int i; + + for (i = 0; i < n->count; i++) + if (n->branch[i].key > k) + return i; + return i; +} + +static int BTreeAddLeaf(node_t n, double *k, void **ptr) +{ + int i,j; + node_t t; + double key[MAXCARD]; + void *branch[MAXCARD]; + + assert(n); + + if (n->count < MAXCARD - 1) /*split not necessary*/ + { + i = n->count; + if (i > 0) + for (; n->branch[i - 1].key > *k; i--) + { + n->branch[i].key = n->branch[i-1].key; + n->branch[i].child = n->branch[i-1].child; + } + n->branch[i].key = *k; + n->branch[i].child = *ptr; + n->count ++; + return FALSE; + } + else /*needs to split*/ + { + for(i = n->count - 1, j = MAXCARD - 1; + n->branch[i].key > *k; + i--, j--) + { + key[j] = n->branch[i].key; + branch[j] = n->branch[i].child; + } + key[j] = *k; + branch[j] = *ptr; + j--; + for(; i >= 0;i--,j--) + { + key[j] = n->branch[i].key; + branch[j] = n->branch[i].child; + } + + n->count = 0; + t = BTreeNewNode(); + t->level = n->level; + + for (i = 0; i <= MAXCARD / 2; i ++) + { + n->branch[i].key = key[i]; + n->branch[i].child = branch[i]; + n->count ++; + } + *k = key[i-1]; + *ptr = t; + for (j = 0; i < MAXCARD; j ++, i ++) + { + t->branch[j].key = key[i]; + t->branch[j].child = branch[i]; + t->count ++; + } + + /*linked list*/ + t->branch[MAXCARD -1].child = n->branch[MAXCARD - 1].child; + n->branch[MAXCARD -1].child = t; + + return TRUE; + } +} diff --git a/packages/udi/b+tree/b+tree.h b/packages/udi/b+tree/b+tree.h new file mode 100644 index 000000000..b1bac20a5 --- /dev/null +++ b/packages/udi/b+tree/b+tree.h @@ -0,0 +1,89 @@ +#ifndef __BTREE_H__ +#define __BTREE_H__ + +#ifndef __BTREE_PRIVATE_H__ +typedef void * btree_t; +typedef void * node_t; +#endif + +/* + * Alocates and initializes a new b+tree structure + */ +extern btree_t BTreeNew (void); + +/* + * Inserts in the b+tree the object with key key + */ +extern void BTreeInsert (btree_t *btree, double key, void *data); + +/* + * Searchs the b+tree for the min key object returning it + * + * If nidx(node index) and bidx(branch index) is not NULL + * ... + */ +extern void * BTreeMin(btree_t btree, node_t *nidx, int *bidx); + +/* + * Searchs the b+tree for the max key object returning it + * + * If nidx(node index) and bidx(branch index) is not NULL + * ... + */ +extern void * BTreeMax(btree_t btree, node_t *nidx, int *bidx); + +/* Seach Kinds */ +#define EQ 1 /* BTreeSearch(btree, key, EQ, NULL, NULL); */ +#define LE 2 +#define LT 3 +/* First call: BTreeMin(btree, nidx, bidx); + Next Calls(until NULL is returned): + BTreeSearchNext(key_max, LT || LE, btree, nidx, bidx);*/ +#define GE 4 +#define GT 5 +/* First call: BTreeSearch(btree, key_min, GE || GT, nidx, bidx); + Next Calls(until NULL is returned): + BTreeSearchNext(key_min, LT || LE, btree, nidx, bidx);*/ + +/* Range Searches + * First call: BTreeSearch(btree, key_min, GE || GT, nidx, bidx); + * Next Calls(until NULL is returned): + * BTreeSearchNext(key_max, LT || LE, btree, nidx, bidx); + */ + +/* + * Searchs the b+tree for: + * if kind == EQ finds the key object returning it + * if kind == GE || GT finds the first valid key returning it + * + * Returns NULL on fail to find + * + * Other parameter to kind will fail + * + * If nidx(node index) and bidx(branch index) is not NULL it those values + */ +extern void * BTreeSearch(btree_t btree, double key, int kind, + node_t *nidx, int *bidx); + +/* + * Searches next valid answers given nidx, bidx where set in previous call to + * BTreeMin or BTreeSearch + * + * It will return the valid key objects with kind LE or LT, NULL otherwise + * + * nidx(node index) and bidx(branch index) will also be set + */ +extern void * BTreeSearchNext (double key, int kind, + node_t *nidx, int *bidx); + +/* + * Destroys b+tree, freeing all the memory allocated to it + */ +extern void BTreeDestroy (btree_t); + +/* + * Debug function, prints b+tree + */ +extern void BTreePrint(btree_t); + +#endif /*__BTREE_H__*/ diff --git a/packages/udi/b+tree/b+tree.yap b/packages/udi/b+tree/b+tree.yap new file mode 100644 index 000000000..9219e0d38 --- /dev/null +++ b/packages/udi/b+tree/b+tree.yap @@ -0,0 +1,76 @@ +:- load_foreign_files(['libudi_b+tree'],[],udi_btree_init). + +:- op(700,fx,max). +:- op(700,fx,min). +:- op(700,xfx,#==). +:- op(700,xfx,#>). +:- op(700,xfx,#<). +:- op(700,xfx,#>=). +:- op(700,xfx,#=<). + +max X :- %%this overrides any previous att + attributes:put_att_term(X,max(C)). + +min X :- %%this overrides any previous att + attributes:put_att_term(X,min(C)). + +X #== Y :-%%this overrides any previous att + attributes:put_att_term(X,eq(C,Y)). + +%% range definition +X #> Y :- + attributes:get_all_atts(X,C), + c1(C,gt(_,Y),NC), + attributes:put_att_term(X,NC). +X #>= Y :- + attributes:get_all_atts(X,C), + c1(C,ge(_,Y),NC), + attributes:put_att_term(X,NC). +X #=< Y :- + attributes:get_all_atts(X,C), + c1(C,le(_,Y),NC), + attributes:put_att_term(X,NC). +X #< Y :- + attributes:get_all_atts(X,C), + c1(C,lt(_,Y),NC), + attributes:put_att_term(X,NC). + +c1(A,X,X) :- + var(A), !. + +c1(gt(_,X),gt(_,Y),gt(_,Z)) :- + Z is max(X,Y). +c1(gt(_,X),ge(_,Y),ge(_,Y)) :- + Y is max(X,Y). +c1(gt(_,X),ge(_,Y),gt(_,X)) :- + X is max(X,Y). +c1(ge(_,X),ge(_,Y),ge(_,Z)) :- + Z is max(X,Y). +c1(ge(_,X),gt(_,Y),ge(_,X)) :- + X is max(X,Y). +c1(ge(_,X),gt(_,Y),gt(_,Y)) :- + Y is max(X,Y). + +c1(lt(_,X),lt(_,Y),lt(_,Z)) :- + Z is min(X,Y). +c1(lt(_,X),le(_,Y),le(_,Y)) :- + Y is min(X,Y). +c1(lt(_,X),le(_,Y),lt(_,X)) :- + X is min(X,Y). +c1(le(_,X),ge(_,Y),le(_,Z)) :- + Z is min(X,Y). +c1(le(_,X),lt(_,Y),le(_,X)) :- + X is min(X,Y). +c1(le(_,X),lt(_,Y),lt(_,Y)) :- + Y is min(X,Y). + +/*range construct*/ +c1(gt(_,X),lt(_,Y),range(_,X,false,Y,false)). +c1(gt(_,X),le(_,Y),range(_,X,false,Y,true)). +c1(lt(_,Y),gt(_,X),range(_,X,false,Y,false)). +c1(lt(_,Y),ge(_,X),range(_,X,true,Y,false)). +c1(le(_,Y),gt(_,X),range(_,X,false,Y,true)). +c1(le(_,Y),ge(_,X),range(_,X,true,Y,true)). +c1(ge(_,X),lt(_,Y),range(_,X,true,Y,false)). +c1(ge(_,X),le(_,Y),range(_,X,true,Y,true)). +/*still needs to construct range +stuff*/ \ No newline at end of file diff --git a/packages/udi/b+tree/b+tree_private.h b/packages/udi/b+tree/b+tree_private.h new file mode 100644 index 000000000..bc09768c0 --- /dev/null +++ b/packages/udi/b+tree/b+tree_private.h @@ -0,0 +1,57 @@ +#ifndef __BTREE_PRIVATE_H__ +#define __BTREE_PRIVATE_H__ 1 + +#include "udi_common.h" + +// Do not kown where it is defined but I need it +extern int Yap_page_size; +#define MAXCARD (int)((Yap_page_size-(2*sizeof(int)))/ (2 * sizeof(void*))) +#define MINCARD (MAXCARD / 2) + +struct Branch +{ + double key; + void * child; + /*This B+Tree will allways hold index_t both in branches and leaves*/ +}; +typedef struct Branch branch_t; + +struct Node +{ + int count; + int level; + +// double key[MAXCARD - 1]; +// void * branch[MAXCARD]; + + /* we do not use one key with this representation */ + branch_t branch[FLEXIBLE_SIZE]; + /* in leaf nodes last child is ptr to next node + * for fast in order run + */ +}; +typedef struct Node * node_t; +#define SIZEOF_NODE SIZEOF_FLEXIBLE(struct Node, branch, MAXCARD) + +struct Range +{ + double min; + int le; + double max; + int ge; +}; +typedef struct Range range_t; + +typedef node_t btree_t; + +static node_t BTreeNewNode (void); +static void BTreeNodeInit (node_t); +static int BTreeInsertNode(node_t, double *, void **); +static int BTreePickBranch(node_t, double); +static int BTreeAddBranch(node_t, int, double *, void **); +static int BTreeAddLeaf(node_t, double *, void **); +static void BTreeDestroyNode (node_t n); + +#include "b+tree.h" + +#endif /* __BTREE_PRIVATE_H__ */ diff --git a/packages/udi/b+tree/b+tree_udi.c b/packages/udi/b+tree/b+tree_udi.c new file mode 100644 index 000000000..780b4b813 --- /dev/null +++ b/packages/udi/b+tree/b+tree_udi.c @@ -0,0 +1,218 @@ +#include +#include +#include +#include +#include + +#include "b+tree_udi.h" + +static struct udi_control_block BtreeCB; + +void udi_btree_init(void) { + UdiControlBlock cb = &BtreeCB; + + memset((void *) cb,0, sizeof(*cb)); + + cb->decl=YAP_LookupAtom(SPEC); + + cb->init=BtreeUdiInit; + cb->insert=BtreeUdiInsert; + cb->search=BtreeUdiSearch; + cb->destroy=BtreeUdiDestroy; + + Yap_UdiRegister(cb); +} +void *BtreeUdiInit (YAP_Term spec, int arg, int arity) +{ + return (void *) BTreeNew(); +} + +void *BtreeUdiInsert (void *control, + YAP_Term term, int arg, void *data) +{ + btree_t btree = (btree_t) control; + assert(control); + + BTreeInsert(&btree, + YAP_FloatOfTerm(YAP_ArgOfTerm(arg,term)), + data); + + return (void *) btree; +} + +/*ARGS ARE AVAILABLE*/ +int BtreeUdiSearch (void *control, + int arg, Yap_UdiCallback callback, void *args) +{ + int j; + size_t n; + YAP_Term Constraints; + const char * att; + + YAP_Term t = YAP_A(arg); + if (YAP_IsAttVar(t)) + { + Constraints = YAP_AttsOfVar(t); + /* Yap_DebugPlWrite(Constraints); */ + att = YAP_AtomName(YAP_NameOfFunctor(YAP_FunctorOfTerm(Constraints))); + + n = sizeof (att_func) / sizeof (struct Att); + for (j = 0; j < n; j ++) + if (strcmp(att_func[j].att,att) == 0) /*TODO: Improve this do not need strcmp*/ + return att_func[j].proc_att(control, Constraints, callback, args); + } + return -1; /*YAP FALLBACK*/ +} + +/*Needs to test if tree is not null*/ +int BTreeMinAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + void *d; + d = BTreeMin(tree,NULL,NULL); + callback(d,d,args); + /*TODO: test empty tree*/ + return 1; +} + +int BTreeMaxAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + void *d; + d = BTreeMax(tree,NULL,NULL); + callback(d,d,args); + /*TODO: test empty tree*/ + return 1; +} + +int BTreeEqAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + node_t n; + int i; + double r; + void * d; + + r = YAP_FloatOfTerm(YAP_ArgOfTerm(2,constraint)); + + d = BTreeSearch(tree,r,EQ,&n,&i); + if (d) { + callback(d,d,args); + return 1; + } + return 0; +} + +int BTreeLtAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + node_t n; + int i; + double max; + void * d; + int count = 0; + + max = YAP_FloatOfTerm(YAP_ArgOfTerm(2,constraint)); + + d = BTreeMin(tree,&n,&i); + if (d) + do { + callback(d,d,args); + count ++; + } while ((d = BTreeSearchNext(max,LT,&n,&i))); + + return count; +} + +int BTreeLeAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + node_t n; + int i; + double max; + void * d; + int count = 0; + + max = YAP_FloatOfTerm(YAP_ArgOfTerm(2,constraint)); + + d = BTreeMin(tree,&n,&i); + if (d) + do { + callback(d,d,args); + count ++; + } while ((d = BTreeSearchNext(max,LE,&n,&i))); + + return count; +} + +int BTreeGtAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + node_t n; + int i; + double min; + void * d; + int count = 0; + + min = YAP_FloatOfTerm(YAP_ArgOfTerm(2,constraint)); + + d = BTreeSearch(tree,min,GT,&n,&i); + if (d) + do { + callback(d,d,args); + count ++; + } while ((d = BTreeSearchNext(DBL_MAX,LT,&n,&i))); + + return count; +} + +int BTreeGeAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + node_t n; + int i; + double min; + void * d; + int count = 0; + + min = YAP_FloatOfTerm(YAP_ArgOfTerm(2,constraint)); + + d = BTreeSearch(tree,min,GE,&n,&i); + if (d) + do { + callback(d,d,args); + count ++; + } while ((d = BTreeSearchNext(DBL_MAX,LT,&n,&i))); + + return count; +} + +int BTreeRangeAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args) +{ + node_t n; + int i; + double min,max; + int minc,maxc; + void * d; + int count = 0; + + min = YAP_FloatOfTerm(YAP_ArgOfTerm(2,constraint)); + minc = strcmp(YAP_AtomName(YAP_AtomOfTerm(YAP_ArgOfTerm(3,constraint))), + "true") == 0 ? GE: GT; + max = YAP_FloatOfTerm(YAP_ArgOfTerm(4,constraint)); + maxc = strcmp(YAP_AtomName(YAP_AtomOfTerm(YAP_ArgOfTerm(5,constraint))), + "true") == 0 ? LE: LT; + + d = BTreeSearch(tree,min,minc,&n,&i); + if (d) + do { + callback(d,d,args); + count ++; + } while ((d = BTreeSearchNext(max,maxc,&n,&i))); + + return count; +} + +int BtreeUdiDestroy(void *control) +{ + btree_t btree = (btree_t) control; + + assert(btree); + + BTreeDestroy(btree); + + return TRUE; +} diff --git a/packages/udi/b+tree/b+tree_udi.h b/packages/udi/b+tree/b+tree_udi.h new file mode 100644 index 000000000..1558115d4 --- /dev/null +++ b/packages/udi/b+tree/b+tree_udi.h @@ -0,0 +1,51 @@ +#ifndef __BTREE_UDI_H__ +#define __BTREE_UDI_H__ 1 + +#include +#include +#include "b+tree.h" + +#define SPEC "btree" +/*Prolog term from :- udi(a(-,btree,-)).*/ + +extern void *BtreeUdiInit + (YAP_Term spec, int arg, int arity); + +extern void *BtreeUdiInsert + (void *control, YAP_Term term, int arg, void *data); + +extern int BtreeUdiSearch + (void *control, int arg, Yap_UdiCallback callback, void *args); + +extern int BtreeUdiDestroy(void *control); + +typedef int (*BTreeSearchAtt) (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); + +struct Att +{ + const char *att; + BTreeSearchAtt proc_att; +}; + +int BTreeMinAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeMaxAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeEqAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeLtAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeLeAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeGtAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeGeAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); +int BTreeRangeAtt (btree_t tree, YAP_Term constraint, Yap_UdiCallback callback, void *args); + +static struct Att att_func[] = + { + {"min",BTreeMinAtt}, + {"max",BTreeMaxAtt}, + {"eq",BTreeEqAtt}, + {"lt",BTreeLtAtt}, + {"le",BTreeLeAtt}, + {"gt",BTreeGtAtt}, + {"ge",BTreeGeAtt}, + {"range",BTreeRangeAtt} + }; + +#endif /* __BTREE_UDI_H__ */ diff --git a/packages/udi/cmake/FindYAP.cmake b/packages/udi/cmake/FindYAP.cmake new file mode 100644 index 000000000..4edcda613 --- /dev/null +++ b/packages/udi/cmake/FindYAP.cmake @@ -0,0 +1,49 @@ +# CMake module to search for YAP library +# +# If YAP_INCLUDE_DIR and YAP_PL_LIBRARY_DIR sets YAP_FOUND +# Also checks for YAP_LIBRARY + +FIND_PATH(YAP_INCLUDE_DIR YapInterface.h + /usr/local/include/Yap + /usr/include/Yap + #MSVC + "$ENV{LIB_DIR}/include/Yap" + #mingw + c:/msys/local/include/Yap + ) + +FIND_PATH(YAP_PL_LIBRARY_DIR terms.yap + /usr/local/share/Yap + /usr/share/Yap + #MSVC + "$ENV{LIB_DIR}/share/Yap" + #mingw + c:/msys/local/share/Yap + ) + +FIND_LIBRARY(YAP_LIBRARY NAMES libyap.a PATHS + /usr/local/lib + /usr/lib + #MSVC + "$ENV{LIB_DIR}/lib" + #mingw + c:/msys/local/lib + ) + +IF (YAP_INCLUDE_DIR AND YAP_PL_LIBRARY_DIR) + SET(YAP_FOUND TRUE) +ENDIF (YAP_INCLUDE_DIR AND YAP_PL_LIBRARY_DIR) + +IF (YAP_FOUND) + + IF (NOT YAP_FIND_QUIETLY) + MESSAGE(STATUS "Found YAP: ${YAP_LIBRARY}") + ENDIF (NOT YAP_FIND_QUIETLY) + +ELSE (YAP_FOUND) + + IF (YAP_FIND_REQUIRED) + MESSAGE(SYSTEM_ERROR_FATAL "Could not find YAP") + ENDIF (YAP_FIND_REQUIRED) + +ENDIF (YAP_FOUND) \ No newline at end of file diff --git a/packages/udi/rtree/CMakeLists.txt b/packages/udi/rtree/CMakeLists.txt new file mode 100644 index 000000000..d39bc1d40 --- /dev/null +++ b/packages/udi/rtree/CMakeLists.txt @@ -0,0 +1,17 @@ +CMAKE_MINIMUM_REQUIRED ( VERSION 2.8 ) + +PROJECT ( YAP_UDI_RTREE ) + +INCLUDE_DIRECTORIES( + . +) + +SET ( SOURCES + rtree.c + rtree_udi.c + ) + +ADD_LIBRARY(udi_rtree SHARED ${SOURCES}) + +INSTALL(TARGETS udi_rtree DESTINATION ${YAP_PL_LIBRARY_DIR}) +INSTALL(FILES rtree.yap DESTINATION ${YAP_PL_LIBRARY_DIR}) diff --git a/packages/udi/rtree/rtree.c b/packages/udi/rtree/rtree.c new file mode 100644 index 000000000..e802a9ac0 --- /dev/null +++ b/packages/udi/rtree/rtree.c @@ -0,0 +1,510 @@ +#include +#include +#include +#include +#include + +#include "rtree_private.h" + +rtree_t RTreeNew (void) +{ + rtree_t t; + t = RTreeNewNode(); + t->level = 0; /*leaf*/ + return t; +} + +void RTreeDestroy (rtree_t t) +{ + if (t) + RTreeDestroyNode (t); +} + +static node_t RTreeNewNode (void) +{ + node_t n; + + n = (node_t) malloc (SIZEOF_NODE); + assert(n); + RTreeNodeInit(n); + return n; +} + +static void RTreeDestroyNode (node_t node) +{ + int i; + + if (node->level == 0) /* leaf level*/ + { + for (i = 0; i < MAXCARD; i++) + if (node->branch[i].child) + continue;/* allow user free data*/ + else + break; + } + else + { + for (i = 0; i < MAXCARD; i++) + if (node->branch[i].child) + RTreeDestroyNode (node->branch[i].child); + else + break; + } + free (node); +} + +static void RTreeNodeInit (node_t n) +{ + memset((void *) n,0, SIZEOF_NODE); + n->level = -1; +} + +int RTreeSearch (rtree_t t, rect_t s, SearchHitCallback f, void *arg) +{ + assert(t); + return RTreeSearchNode(t,s,f,arg); +} + +static int RTreeSearchNode (node_t n, rect_t s, SearchHitCallback f, void *arg) +{ + int i; + int c = 0; + + if (n->level > 0) + { + for (i = 0; i < MAXCARD; i++) + if (n->branch[i].child && + RectOverlap (s,n->branch[i].mbr)) + c += RTreeSearchNode ((node_t) n->branch[i].child, s, f, arg); + } + else + { + for (i = 0; i < MAXCARD; i++) + if (n->branch[i].child && + RectOverlap (s,n->branch[i].mbr)) + { + c ++; + if (f) + if ( !f(&(n->branch[i].mbr),n->branch[i].child,arg)) + return c; + } + } + return c; +} + +void RTreeInsert (rtree_t *t, rect_t r, void *data) +{ + node_t n2; + node_t new_root; + branch_t b; + assert(t && *t); + + if (RTreeInsertNode(*t, 0, r, data, &n2)) + /* deal with root split */ + { + new_root = RTreeNewNode(); + new_root->level = (*t)->level + 1; + b.mbr = RTreeNodeCover(*t); + b.child = (void *) *t; + RTreeAddBranch(new_root, b, NULL); + b.mbr = RTreeNodeCover(n2); + b.child = (void *) n2; + RTreeAddBranch(new_root, b, NULL); + *t = new_root; + } +} + +static int RTreeInsertNode (node_t n, int level, + rect_t r, void *data, + node_t *new_node) +{ + int i; + node_t n2; + branch_t b; + + assert(n && new_node); + assert(level >= 0 && level <= n->level); + + if (n->level > level) + { + i = RTreePickBranch(r,n); + if (!RTreeInsertNode((node_t) n->branch[i].child, level, + r, data,&n2)) /* not split */ + { + n->branch[i].mbr = RectCombine(r,n->branch[i].mbr); + return FALSE; + } + else /* node split */ + { + n->branch[i].mbr = RTreeNodeCover(n->branch[i].child); + b.child = n2; + b.mbr = RTreeNodeCover(n2); + return RTreeAddBranch(n, b, new_node); + } + } + else /*insert level*/ + { + b.mbr = r; + b.child = data; + return RTreeAddBranch(n, b, new_node); + } +} + +static int RTreeAddBranch(node_t n, branch_t b, node_t *new_node) +{ + int i; + + assert(n); + + if (n->count < MAXCARD) /*split not necessary*/ + { + for (i = 0; i < MAXCARD; i++) + if (n->branch[i].child == NULL) + { + n->branch[i] = b; + n->count ++; + break; + } + return FALSE; + } + else /*needs to split*/ + { + assert(new_node); + RTreeSplitNode (n, b, new_node); + return TRUE; + } +} + +static int RTreePickBranch (rect_t r, node_t n) +{ + int i; + double area; + double inc_area; + rect_t tmp; + int best_i; + double best_inc; + double best_i_area; + + best_i = 0; + best_inc = DBL_MAX; /* double Max value */ + best_i_area = DBL_MAX; + + for (i = 0; i < MAXCARD; i++) + if (n->branch[i].child) + { + area = RectArea (n->branch[i].mbr); + tmp = RectCombine (r, n->branch[i].mbr); + inc_area = RectArea (tmp) - area; + + if (inc_area < best_inc) + { + best_inc = inc_area; + best_i = i; + best_i_area = area; + } + else if (inc_area == best_inc && best_i_area > area) + { + best_inc = inc_area; + best_i = i; + best_i_area = area; + } + } + else + break; + return best_i; +} + +static void RTreeSplitNode (node_t n, branch_t b, node_t *new_node) +{ + partition_t p; + int level; + int i; + + assert(n); + assert(new_node); + + p = PartitionNew(); + + for (i = 0; i < MAXCARD; i ++) + PartitionPush(p,n->branch[i]); + PartitionPush(p,b); + + level = n->level; + RTreeNodeInit(n); + n->level = level; + *new_node = RTreeNewNode(); + (*new_node)->level = level; + + RTreePickSeeds(p, n, *new_node); + + while (p->n) + if (n->count + p->n <= MINCARD) + /* first group (n) needs all entries */ + RTreeNodeAddBranch(&(p->cover[0]), n, PartitionPop(p)); + else if ((*new_node)->count + p->n <= MINCARD) + /* second group (new_node) needs all entries */ + RTreeNodeAddBranch(&(p->cover[1]), *new_node, PartitionPop(p)); + else + RTreePickNext(p, n, *new_node); +} + +static void RTreePickNext(partition_t p, node_t n1, node_t n2) +/* linear version */ +{ + branch_t b; + double area[2], inc_area[2]; + rect_t tmp; + + b = PartitionPop(p); + + area[0] = RectArea (p->cover[0]); + tmp = RectCombine (p->cover[0], b.mbr); + inc_area[0] = RectArea (tmp) - area[0]; + + area[1] = RectArea (p->cover[1]); + tmp = RectCombine (p->cover[1], b.mbr); + inc_area[1] = RectArea (tmp) - area[1]; + + if (inc_area[0] < inc_area[1] || + (inc_area[0] == inc_area[1] && area[0] < area[1])) + RTreeNodeAddBranch(&(p->cover[0]),n1,b); + else + RTreeNodeAddBranch(&(p->cover[1]),n2,b); +} + +static void RTreePickSeeds(partition_t p, node_t n1, node_t n2) +/* puts in index 0 of each node the resulting entry, forming the two + groups + This is the linear version +*/ +{ + int dim,high, i; + int highestLow[NUMDIMS], lowestHigh[NUMDIMS]; + double width[NUMDIMS]; + int seed0, seed1; + double sep, best_sep; + + assert(p->n == MAXCARD + 1); + + for (dim = 0; dim < NUMDIMS; dim++) + { + high = dim + NUMDIMS; + highestLow[dim] = lowestHigh[dim] = 0; + for (i = 1; i < MAXCARD +1; i++) + { + if (p->buffer[i].mbr.coords[dim] > + p->buffer[highestLow[dim]].mbr.coords[dim]) + highestLow[dim] = i; + if (p->buffer[i].mbr.coords[high] < + p->buffer[lowestHigh[dim]].mbr.coords[high]) + lowestHigh[dim] = i; + } + width[dim] = p->cover_all.coords[high] - p->cover_all.coords[dim]; + assert(width[dim] >= 0); + } + + seed0 = lowestHigh[0]; + seed1 = highestLow[0]; + best_sep = 0; + for (dim = 0; dim < NUMDIMS; dim ++) + { + high = dim + NUMDIMS; + + sep = (p->buffer[highestLow[dim]].mbr.coords[dim] - + p->buffer[lowestHigh[dim]].mbr.coords[high]) / width[dim]; + if (sep > best_sep) + { + seed0 = lowestHigh[dim]; + seed1 = highestLow[dim]; + best_sep = sep; + } + } +/* assert (seed0 != seed1); */ + if (seed0 > seed1) + { + RTreeNodeAddBranch(&(p->cover[0]),n1,PartitionGet(p,seed0)); + RTreeNodeAddBranch(&(p->cover[1]),n2,PartitionGet(p,seed1)); + } + else if (seed0 < seed1) + { + RTreeNodeAddBranch(&(p->cover[0]),n1,PartitionGet(p,seed1)); + RTreeNodeAddBranch(&(p->cover[1]),n2,PartitionGet(p,seed0)); + } +} + +static void RTreeNodeAddBranch(rect_t *r, node_t n, branch_t b) +{ + int i; + + assert(n); + assert(n->count < MAXCARD); + + for (i = 0; i < MAXCARD; i++) + if (n->branch[i].child == NULL) + { + n->branch[i] = b; + n->count ++; + break; + } + *r = RectCombine(*r,b.mbr); +} + + +void RTreePrint(node_t t) +{ + int i; + + /* printf("rtree([_,_,_,_,_]).\n"); */ + printf("rtree(%p,%d,[",t,t->level); + for (i = 0; i < MAXCARD; i++) + { + if (t->branch[i].child != NULL) + { + printf("(%p,",t->branch[i].child); + RectPrint(t->branch[i].mbr); + printf(")"); + } + else + { + printf("nil"); + } + if (i < MAXCARD-1) + printf(","); + } + printf("]).\n"); + + if (t->level != 0) + for (i = 0; i < MAXCARD; i++) + if (t->branch[i].child != NULL) + RTreePrint((node_t) t->branch[i].child); + else + break; +} + +/* + * Partition related + */ + +static partition_t PartitionNew (void) +{ + partition_t p; + + p = (partition_t) malloc(SIZEOF_PARTITION); + /*TODO: check return value*/ + memset((void *) p,0, SIZEOF_PARTITION); + p->cover[0] = p->cover[1] = p->cover_all = RectInit(); + return p; +} + +static void PartitionPush (partition_t p, branch_t b) +{ + assert(p->n < MAXCARD + 1); + p->buffer[p->n] = b; + p->n ++; + p->cover_all = RectCombine(p->cover_all,b.mbr); +} + +static branch_t PartitionPop (partition_t p) +{ + assert(p->n > 0); + p->n --; + return p->buffer[p->n]; +} + +static branch_t PartitionGet (partition_t p, int n) +{ + branch_t b; + assert (p->n > n); + b = p->buffer[n]; + p->buffer[n] = PartitionPop(p); + return b; +} + +/* + * Rect related + */ + +rect_t RectInit (void) +{ + rect_t r = {{DBL_MAX, DBL_MAX, DBL_MIN, DBL_MIN}}; + return (r); +} + +rect_t RectInitCoords (double c[4]) +{ + rect_t r; + r.coords[0] = c[0]; + r.coords[1] = c[1]; + r.coords[2] = c[2]; + r.coords[3] = c[3]; + return (r); +} + +static double RectArea (rect_t r) +{ + int i; + double area; + + for (i = 0,area = 1; i < NUMDIMS; i++) + area *= r.coords[i+NUMDIMS] - r.coords[i]; + +/* area = (r.coords[1] - r.coords[0]) * */ +/* (r.coords[3] - r.coords[2]); */ + + return area; +} + +static rect_t RectCombine (rect_t r, rect_t s) +{ + int i; + rect_t new_rect; + + for (i = 0; i < NUMDIMS; i++) + { + new_rect.coords[i] = MIN(r.coords[i],s.coords[i]); + new_rect.coords[i+NUMDIMS] = MAX(r.coords[i+NUMDIMS],s.coords[i+NUMDIMS]); + } + + return new_rect; +} + +static int RectOverlap (rect_t r, rect_t s) +{ + int i; + + for (i = 0; i < NUMDIMS; i++) + if (r.coords[i] > s.coords[i + NUMDIMS] || + s.coords[i] > r.coords[i + NUMDIMS]) + return FALSE; + return TRUE; +} + +static rect_t RTreeNodeCover(node_t n) +{ + int i; + rect_t r = RectInit(); + + for (i = 0; i < MAXCARD; i++) + if (n->branch[i].child) + { + r = RectCombine (r, n->branch[i].mbr); + } + else + break; + + return r; +} + +void RectPrint (rect_t r) +{ + int i; + + printf("["); + for (i = 0; i < 2*NUMDIMS; i++) + { + printf("%f",r.coords[i]); + if ( i < 2*NUMDIMS - 1) + printf(","); + } + printf("]"); +} diff --git a/packages/udi/rtree/rtree.h b/packages/udi/rtree/rtree.h new file mode 100644 index 000000000..ac58a7706 --- /dev/null +++ b/packages/udi/rtree/rtree.h @@ -0,0 +1,26 @@ +#ifndef _RTREE_ +#define _RTREE_ 1 + +#ifndef __RTREE_PRIVATE_H__ + typedef void * rtree_t; + typedef void * node_t; + + struct Rect + { + double coords[4]; /*TODO: change this from here*/ + }; + typedef struct Rect rect_t; +#endif + +typedef int (*SearchHitCallback)(void *, void *data, void *arg); + +extern rtree_t RTreeNew (void); +extern void RTreeInsert (rtree_t *, rect_t, void *); +extern int RTreeSearch (rtree_t, rect_t, SearchHitCallback, void *); +extern void RTreeDestroy (rtree_t); +extern void RTreePrint(node_t); +extern rect_t RectInit (void); +extern void RectPrint (rect_t); +extern rect_t RectInitCoords (double *); + +#endif /* _RTREE_ */ diff --git a/packages/udi/rtree/rtree.yap b/packages/udi/rtree/rtree.yap new file mode 100644 index 000000000..93597247f --- /dev/null +++ b/packages/udi/rtree/rtree.yap @@ -0,0 +1,7 @@ +:- load_foreign_files(['libudi_rtree'],[],udi_rtree_init). + +:- op(700,xfx,'&&'). + +A '&&' B :- + attributes:get_all_atts(A,C), + attributes:put_att_term(A,overlap(C,B)). diff --git a/packages/udi/rtree/rtree_private.h b/packages/udi/rtree/rtree_private.h new file mode 100644 index 000000000..f36139c42 --- /dev/null +++ b/packages/udi/rtree/rtree_private.h @@ -0,0 +1,81 @@ +#ifndef __RTREE_PRIVATE_H__ +#define __RTREE_PRIVATE_H__ 1 + +#include "udi_common.h" + +#define NUMDIMS 2 /* we will work in 2d changing this will + break some functions */ + +// Do not kown where it is defined but I need it +extern int Yap_page_size; +#define MAXCARD (int)((Yap_page_size-(2*sizeof(int)))/ sizeof(struct Branch)) +#define MINCARD (MAXCARD / 2) + +struct Rect +{ + double coords[2*NUMDIMS]; /* x1min, y1min, ... , x1max, y1max, ...*/ +}; +typedef struct Rect rect_t; + +typedef size_t index_t; + +struct Branch +{ + rect_t mbr; + void * child; /*void * so user can store whatever he needs, in case + of non-leaf ndes it stores the child-pointer*/ +}; +typedef struct Branch branch_t; + +struct Node +{ + int count; + int level; + branch_t branch[FLEXIBLE_SIZE]; +}; +typedef struct Node * node_t; +#define SIZEOF_NODE SIZEOF_FLEXIBLE(struct Node, branch, MAXCARD) + +typedef node_t rtree_t; + +struct Partition +{ + int n; + rect_t cover_all; + rect_t cover[2]; + branch_t buffer[FLEXIBLE_SIZE]; +}; +typedef struct Partition * partition_t; +#define SIZEOF_PARTITION SIZEOF_FLEXIBLE(struct Partition, buffer, MAXCARD + 1) + +/* #define ALIGN(addr, size) (((addr)+(size-1))&(~(size-1))) */ + +#include "rtree.h" + +static node_t RTreeNewNode (void); +static void RTreeDestroyNode (node_t); +static void RTreeNodeInit (node_t); + +static int RTreeSearchNode (node_t, rect_t, SearchHitCallback, void *); +static int RTreeInsertNode (node_t, int, rect_t,void *,node_t *); + +static int RTreePickBranch (rect_t, node_t); +static int RTreeAddBranch(node_t, branch_t, node_t *); +static void RTreeSplitNode (node_t, branch_t, node_t *); + +static void RTreePickSeeds(partition_t, node_t, node_t); +static void RTreeNodeAddBranch(rect_t *, node_t, branch_t); +static void RTreePickNext(partition_t, node_t, node_t); + +static rect_t RTreeNodeCover(node_t); + +static double RectArea (rect_t); +static rect_t RectCombine (rect_t, rect_t); +static int RectOverlap (rect_t, rect_t); + +static partition_t PartitionNew (void); +static void PartitionPush (partition_t, branch_t); +static branch_t PartitionPop (partition_t); +static branch_t PartitionGet (partition_t, int); + +#endif /* __RTREE_PRIVATE_H__ */ diff --git a/packages/udi/rtree/rtree_udi.c b/packages/udi/rtree/rtree_udi.c new file mode 100644 index 000000000..fcf5c51c5 --- /dev/null +++ b/packages/udi/rtree/rtree_udi.c @@ -0,0 +1,121 @@ +#include +#include +#include +#include + +#include "rtree_udi.h" + +static struct udi_control_block RtreeCB; + +void udi_rtree_init(void) { + UdiControlBlock cb = &RtreeCB; + + memset((void *) cb,0, sizeof(*cb)); + + cb->decl=YAP_LookupAtom(SPEC); + + cb->init=RtreeUdiInit; + cb->insert=RtreeUdiInsert; + cb->search=RtreeUdiSearch; + cb->destroy=RtreeUdiDestroy; + + Yap_UdiRegister(cb); +} + +static int YAP_IsNumberTermToFloat (YAP_Term term, YAP_Float *n) +{ + if (YAP_IsIntTerm (term) != FALSE) + { + if (n != NULL) + *n = (YAP_Float) YAP_IntOfTerm (term); + return (TRUE); + } + if (YAP_IsFloatTerm (term) != FALSE) + { + if (n != NULL) + *n = YAP_FloatOfTerm (term); + return (TRUE); + } + return (FALSE); +} + +static rect_t RectOfTerm (YAP_Term term) +{ + YAP_Term tmp; + rect_t rect; + int i; + + if (!YAP_IsPairTerm(term)) + return (RectInit()); + + for (i = 0; YAP_IsPairTerm(term) && i < 4; i++) + { + tmp = YAP_HeadOfTerm (term); + if (!YAP_IsNumberTermToFloat(tmp,&(rect.coords[i]))) + return (RectInit()); + term = YAP_TailOfTerm (term); + } + + return (rect); +} + +void * +RtreeUdiInit (YAP_Term spec, int arg, int arity) { + return (void *) RTreeNew(); +} + +void * +RtreeUdiInsert (void *control, + YAP_Term term, int arg, void *data) +{ + rect_t r; + rtree_t rtree = (rtree_t) control; + + assert(rtree); + + /*TODO: better check of rect, or even not needing it + * and use the geometry itself */ + r = RectOfTerm(YAP_ArgOfTerm(arg,term)); + RTreeInsert(&rtree, r, data); + + return (void *) rtree; +} + +/*ARGS ARE AVAILABLE*/ +int RtreeUdiSearch (void *control, + int arg, Yap_UdiCallback callback, void *args) +{ + int i; + rtree_t rtree = (rtree_t) control; + YAP_Term Constraints; + rect_t r; + + assert(rtree); + + YAP_Term t = YAP_A(arg); + if (YAP_IsAttVar(t)) + { + /*get the constraits rect*/ + Constraints = YAP_AttsOfVar(t); +// Yap_DebugPlWrite(Constraints); + if (YAP_IsApplTerm(Constraints)) + { + r = RectOfTerm(YAP_ArgOfTerm(2,Constraints)); + + return RTreeSearch(rtree, r, callback, args); + } + } + + return -1; /*YAP FALLBACK*/ +} + +int RtreeUdiDestroy(void *control) +{ + rtree_t rtree = (rtree_t) control; + + assert(rtree); + + RTreeDestroy(rtree); + + return TRUE; +} diff --git a/packages/udi/rtree/rtree_udi.h b/packages/udi/rtree/rtree_udi.h new file mode 100644 index 000000000..470ac2f22 --- /dev/null +++ b/packages/udi/rtree/rtree_udi.h @@ -0,0 +1,24 @@ +#ifndef _RTREE_UDI_ +#define _RTREE_UDI_ + +#include +#include +#include "rtree.h" + +#define SPEC "rtree" +/*Prolog term from :- udi(a(-,rtree,-)).*/ + +extern void *RtreeUdiInit + (YAP_Term spec, int arg, int arity); + +extern void *RtreeUdiInsert + (void *control, YAP_Term term, int arg, void *data); + +extern int RtreeUdiSearch + (void *control, int arg, Yap_UdiCallback callback, void *args); + +extern int RtreeUdiDestroy(void *control); + +void udi_rtree_init(void); + +#endif /* _RTREE_UDI_ */ diff --git a/packages/udi/udi.md b/packages/udi/udi.md new file mode 100644 index 000000000..459d88f65 --- /dev/null +++ b/packages/udi/udi.md @@ -0,0 +1,5 @@ +User Defined Indexers. +====================== + +YAP UDI indexers. + diff --git a/packages/udi/udi_common.h b/packages/udi/udi_common.h new file mode 100644 index 000000000..d089a2be2 --- /dev/null +++ b/packages/udi/udi_common.h @@ -0,0 +1,30 @@ +#ifndef FALSE +#define FALSE 0 +#endif +#ifndef TRUE +#define TRUE !FALSE +#endif + +/* + * hack to emulate flexible array member of C99 + * + * Example + * + * struct header { + * ... + * int data[FLEXIBLE_SIZE]; + * }; + * + * ... + * + * size_t n = 123; + * struct header *my_header = malloc(SIZEOF_FLEXIBLE(struct header, data, n)); + * + */ +#include +#define FLEXIBLE_SIZE 1 +#define SIZEOF_FLEXIBLE(type, member, length) \ + ( offsetof(type, member) + (length) * sizeof ((type *)0)->member[0] ) + +#define MIN(a, b) ((a) < (b) ? (a) : (b)) +#define MAX(a, b) ((a) > (b) ? (a) : (b)) diff --git a/packages/udi/utarray.h b/packages/udi/utarray.h new file mode 100644 index 000000000..0c1e59b5b --- /dev/null +++ b/packages/udi/utarray.h @@ -0,0 +1,233 @@ +/* +Copyright (c) 2008-2013, Troy D. Hanson http://uthash.sourceforge.net +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ + +/* a dynamic array implementation using macros + * see http://uthash.sourceforge.net/utarray + */ +#ifndef UTARRAY_H +#define UTARRAY_H + +#define UTARRAY_VERSION 1.9.7 + +#ifdef __GNUC__ +#define _UNUSED_ __attribute__ ((__unused__)) +#else +#define _UNUSED_ +#endif + +#include /* size_t */ +#include /* memset, etc */ +#include /* exit */ + +#define oom() exit(-1) + +typedef void (ctor_f)(void *dst, const void *src); +typedef void (dtor_f)(void *elt); +typedef void (init_f)(void *elt); +typedef struct { + size_t sz; + init_f *init; + ctor_f *copy; + dtor_f *dtor; +} UT_icd; + +typedef struct { + unsigned i,n;/* i: index of next available slot, n: num slots */ + UT_icd icd; /* initializer, copy and destructor functions */ + char *d; /* n slots of size icd->sz*/ +} UT_array; + +#define utarray_init(a,_icd) do { \ + memset(a,0,sizeof(UT_array)); \ + (a)->icd=*_icd; \ +} while(0) + +#define utarray_done(a) do { \ + if ((a)->n) { \ + if ((a)->icd.dtor) { \ + size_t _ut_i; \ + for(_ut_i=0; _ut_i < (a)->i; _ut_i++) { \ + (a)->icd.dtor(utarray_eltptr(a,_ut_i)); \ + } \ + } \ + free((a)->d); \ + } \ + (a)->n=0; \ +} while(0) + +#define utarray_new(a,_icd) do { \ + a=(UT_array*)malloc(sizeof(UT_array)); \ + utarray_init(a,_icd); \ +} while(0) + +#define utarray_free(a) do { \ + utarray_done(a); \ + free(a); \ +} while(0) + +#define utarray_reserve(a,by) do { \ + if (((a)->i+by) > ((a)->n)) { \ + while(((a)->i+by) > ((a)->n)) { (a)->n = ((a)->n ? (2*(a)->n) : 8); } \ + if ( ((a)->d=(char*)realloc((a)->d, (a)->n*(a)->icd.sz)) == NULL) oom(); \ + } \ +} while(0) + +#define utarray_push_back(a,p) do { \ + utarray_reserve(a,1); \ + if ((a)->icd.copy) { (a)->icd.copy( _utarray_eltptr(a,(a)->i++), p); } \ + else { memcpy(_utarray_eltptr(a,(a)->i++), p, (a)->icd.sz); }; \ +} while(0) + +#define utarray_pop_back(a) do { \ + if ((a)->icd.dtor) { (a)->icd.dtor( _utarray_eltptr(a,--((a)->i))); } \ + else { (a)->i--; } \ +} while(0) + +#define utarray_extend_back(a) do { \ + utarray_reserve(a,1); \ + if ((a)->icd.init) { (a)->icd.init(_utarray_eltptr(a,(a)->i)); } \ + else { memset(_utarray_eltptr(a,(a)->i),0,(a)->icd.sz); } \ + (a)->i++; \ +} while(0) + +#define utarray_len(a) ((a)->i) + +#define utarray_eltptr(a,j) (((j) < (a)->i) ? _utarray_eltptr(a,j) : NULL) +#define _utarray_eltptr(a,j) ((char*)((a)->d + ((a)->icd.sz*(j) ))) + +#define utarray_insert(a,p,j) do { \ + utarray_reserve(a,1); \ + if (j > (a)->i) break; \ + if ((j) < (a)->i) { \ + memmove( _utarray_eltptr(a,(j)+1), _utarray_eltptr(a,j), \ + ((a)->i - (j))*((a)->icd.sz)); \ + } \ + if ((a)->icd.copy) { (a)->icd.copy( _utarray_eltptr(a,j), p); } \ + else { memcpy(_utarray_eltptr(a,j), p, (a)->icd.sz); }; \ + (a)->i++; \ +} while(0) + +#define utarray_inserta(a,w,j) do { \ + if (utarray_len(w) == 0) break; \ + if (j > (a)->i) break; \ + utarray_reserve(a,utarray_len(w)); \ + if ((j) < (a)->i) { \ + memmove(_utarray_eltptr(a,(j)+utarray_len(w)), \ + _utarray_eltptr(a,j), \ + ((a)->i - (j))*((a)->icd.sz)); \ + } \ + if ((a)->icd.copy) { \ + size_t _ut_i; \ + for(_ut_i=0;_ut_i<(w)->i;_ut_i++) { \ + (a)->icd.copy(_utarray_eltptr(a,j+_ut_i), _utarray_eltptr(w,_ut_i)); \ + } \ + } else { \ + memcpy(_utarray_eltptr(a,j), _utarray_eltptr(w,0), \ + utarray_len(w)*((a)->icd.sz)); \ + } \ + (a)->i += utarray_len(w); \ +} while(0) + +#define utarray_resize(dst,num) do { \ + size_t _ut_i; \ + if (dst->i > (size_t)(num)) { \ + if ((dst)->icd.dtor) { \ + for(_ut_i=num; _ut_i < dst->i; _ut_i++) { \ + (dst)->icd.dtor(utarray_eltptr(dst,_ut_i)); \ + } \ + } \ + } else if (dst->i < (size_t)(num)) { \ + utarray_reserve(dst,num-dst->i); \ + if ((dst)->icd.init) { \ + for(_ut_i=dst->i; _ut_i < num; _ut_i++) { \ + (dst)->icd.init(utarray_eltptr(dst,_ut_i)); \ + } \ + } else { \ + memset(_utarray_eltptr(dst,dst->i),0,(dst)->icd.sz*(num-dst->i)); \ + } \ + } \ + dst->i = num; \ +} while(0) + +#define utarray_concat(dst,src) do { \ + utarray_inserta((dst),(src),utarray_len(dst)); \ +} while(0) + +#define utarray_erase(a,pos,len) do { \ + if ((a)->icd.dtor) { \ + size_t _ut_i; \ + for(_ut_i=0; _ut_i < len; _ut_i++) { \ + (a)->icd.dtor(utarray_eltptr((a),pos+_ut_i)); \ + } \ + } \ + if ((a)->i > (pos+len)) { \ + memmove( _utarray_eltptr((a),pos), _utarray_eltptr((a),pos+len), \ + (((a)->i)-(pos+len))*((a)->icd.sz)); \ + } \ + (a)->i -= (len); \ +} while(0) + +#define utarray_renew(a,u) do { \ + if (a) utarray_clear(a); \ + else utarray_new((a),(u)); \ +} while(0) + +#define utarray_clear(a) do { \ + if ((a)->i > 0) { \ + if ((a)->icd.dtor) { \ + size_t _ut_i; \ + for(_ut_i=0; _ut_i < (a)->i; _ut_i++) { \ + (a)->icd.dtor(utarray_eltptr(a,_ut_i)); \ + } \ + } \ + (a)->i = 0; \ + } \ +} while(0) + +#define utarray_sort(a,cmp) do { \ + qsort((a)->d, (a)->i, (a)->icd.sz, cmp); \ +} while(0) + +#define utarray_find(a,v,cmp) bsearch((v),(a)->d,(a)->i,(a)->icd.sz,cmp) + +#define utarray_front(a) (((a)->i) ? (_utarray_eltptr(a,0)) : NULL) +#define utarray_next(a,e) (((e)==NULL) ? utarray_front(a) : ((((a)->i) > (utarray_eltidx(a,e)+1)) ? _utarray_eltptr(a,utarray_eltidx(a,e)+1) : NULL)) +#define utarray_prev(a,e) (((e)==NULL) ? utarray_back(a) : ((utarray_eltidx(a,e) > 0) ? _utarray_eltptr(a,utarray_eltidx(a,e)-1) : NULL)) +#define utarray_back(a) (((a)->i) ? (_utarray_eltptr(a,(a)->i-1)) : NULL) +#define utarray_eltidx(a,e) (((char*)(e) >= (char*)((a)->d)) ? (((char*)(e) - (char*)((a)->d))/(a)->icd.sz) : -1) + +/* last we pre-define a few icd for common utarrays of ints and strings */ +static void utarray_str_cpy(void *dst, const void *src) { + char **_src = (char**)src, **_dst = (char**)dst; + *_dst = (*_src == NULL) ? NULL : strdup(*_src); +} +static void utarray_str_dtor(void *elt) { + char **eltc = (char**)elt; + if (*eltc) free(*eltc); +} +static const UT_icd ut_str_icd _UNUSED_ = {sizeof(char*),NULL,utarray_str_cpy,utarray_str_dtor}; +static const UT_icd ut_int_icd _UNUSED_ = {sizeof(int),NULL,NULL,NULL}; +static const UT_icd ut_ptr_icd _UNUSED_ = {sizeof(void*),NULL,NULL,NULL}; + + +#endif /* UTARRAY_H */ diff --git a/packages/udi/uthash.h b/packages/udi/uthash.h new file mode 100644 index 000000000..fe2d51b6f --- /dev/null +++ b/packages/udi/uthash.h @@ -0,0 +1,917 @@ +/* +Copyright (c) 2003-2013, Troy D. Hanson http://uthash.sourceforge.net +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef UTHASH_H +#define UTHASH_H + +#include /* memcmp,strlen */ +#include /* ptrdiff_t */ +#include /* exit() */ + +/* These macros use decltype or the earlier __typeof GNU extension. + As decltype is only available in newer compilers (VS2010 or gcc 4.3+ + when compiling c++ source) this code uses whatever method is needed + or, for VS2008 where neither is available, uses casting workarounds. */ +#ifdef _MSC_VER /* MS compiler */ +#if _MSC_VER >= 1600 && defined(__cplusplus) /* VS2010 or newer in C++ mode */ +#define DECLTYPE(x) (decltype(x)) +#else /* VS2008 or older (or VS2010 in C mode) */ +#define NO_DECLTYPE +#define DECLTYPE(x) +#endif +#else /* GNU, Sun and other compilers */ +#define DECLTYPE(x) (__typeof(x)) +#endif + +#ifdef NO_DECLTYPE +#define DECLTYPE_ASSIGN(dst,src) \ +do { \ + char **_da_dst = (char**)(&(dst)); \ + *_da_dst = (char*)(src); \ +} while(0) +#else +#define DECLTYPE_ASSIGN(dst,src) \ +do { \ + (dst) = DECLTYPE(dst)(src); \ +} while(0) +#endif + +/* a number of the hash function use uint32_t which isn't defined on win32 */ +#ifdef _MSC_VER +typedef unsigned int uint32_t; +typedef unsigned char uint8_t; +#else +#include /* uint32_t */ +#endif + +#define UTHASH_VERSION 1.9.7 + +#ifndef uthash_fatal +#define uthash_fatal(msg) exit(-1) /* fatal error (out of memory,etc) */ +#endif +#ifndef uthash_malloc +#define uthash_malloc(sz) malloc(sz) /* malloc fcn */ +#endif +#ifndef uthash_free +#define uthash_free(ptr,sz) free(ptr) /* free fcn */ +#endif + +#ifndef uthash_noexpand_fyi +#define uthash_noexpand_fyi(tbl) /* can be defined to log noexpand */ +#endif +#ifndef uthash_expand_fyi +#define uthash_expand_fyi(tbl) /* can be defined to log expands */ +#endif + +/* initial number of buckets */ +#define HASH_INITIAL_NUM_BUCKETS 32 /* initial number of buckets */ +#define HASH_INITIAL_NUM_BUCKETS_LOG2 5 /* lg2 of initial number of buckets */ +#define HASH_BKT_CAPACITY_THRESH 10 /* expand when bucket count reaches */ + +/* calculate the element whose hash handle address is hhe */ +#define ELMT_FROM_HH(tbl,hhp) ((void*)(((char*)(hhp)) - ((tbl)->hho))) + +#define HASH_FIND(hh,head,keyptr,keylen,out) \ +do { \ + unsigned _hf_bkt,_hf_hashv; \ + out=NULL; \ + if (head) { \ + HASH_FCN(keyptr,keylen, (head)->hh.tbl->num_buckets, _hf_hashv, _hf_bkt); \ + if (HASH_BLOOM_TEST((head)->hh.tbl, _hf_hashv)) { \ + HASH_FIND_IN_BKT((head)->hh.tbl, hh, (head)->hh.tbl->buckets[ _hf_bkt ], \ + keyptr,keylen,out); \ + } \ + } \ +} while (0) + +#ifdef HASH_BLOOM +#define HASH_BLOOM_BITLEN (1ULL << HASH_BLOOM) +#define HASH_BLOOM_BYTELEN (HASH_BLOOM_BITLEN/8) + ((HASH_BLOOM_BITLEN%8) ? 1:0) +#define HASH_BLOOM_MAKE(tbl) \ +do { \ + (tbl)->bloom_nbits = HASH_BLOOM; \ + (tbl)->bloom_bv = (uint8_t*)uthash_malloc(HASH_BLOOM_BYTELEN); \ + if (!((tbl)->bloom_bv)) { uthash_fatal( "out of memory"); } \ + memset((tbl)->bloom_bv, 0, HASH_BLOOM_BYTELEN); \ + (tbl)->bloom_sig = HASH_BLOOM_SIGNATURE; \ +} while (0) + +#define HASH_BLOOM_FREE(tbl) \ +do { \ + uthash_free((tbl)->bloom_bv, HASH_BLOOM_BYTELEN); \ +} while (0) + +#define HASH_BLOOM_BITSET(bv,idx) (bv[(idx)/8] |= (1U << ((idx)%8))) +#define HASH_BLOOM_BITTEST(bv,idx) (bv[(idx)/8] & (1U << ((idx)%8))) + +#define HASH_BLOOM_ADD(tbl,hashv) \ + HASH_BLOOM_BITSET((tbl)->bloom_bv, (hashv & (uint32_t)((1ULL << (tbl)->bloom_nbits) - 1))) + +#define HASH_BLOOM_TEST(tbl,hashv) \ + HASH_BLOOM_BITTEST((tbl)->bloom_bv, (hashv & (uint32_t)((1ULL << (tbl)->bloom_nbits) - 1))) + +#else +#define HASH_BLOOM_MAKE(tbl) +#define HASH_BLOOM_FREE(tbl) +#define HASH_BLOOM_ADD(tbl,hashv) +#define HASH_BLOOM_TEST(tbl,hashv) (1) +#endif + +#define HASH_MAKE_TABLE(hh,head) \ +do { \ + (head)->hh.tbl = (UT_hash_table*)uthash_malloc( \ + sizeof(UT_hash_table)); \ + if (!((head)->hh.tbl)) { uthash_fatal( "out of memory"); } \ + memset((head)->hh.tbl, 0, sizeof(UT_hash_table)); \ + (head)->hh.tbl->tail = &((head)->hh); \ + (head)->hh.tbl->num_buckets = HASH_INITIAL_NUM_BUCKETS; \ + (head)->hh.tbl->log2_num_buckets = HASH_INITIAL_NUM_BUCKETS_LOG2; \ + (head)->hh.tbl->hho = (char*)(&(head)->hh) - (char*)(head); \ + (head)->hh.tbl->buckets = (UT_hash_bucket*)uthash_malloc( \ + HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \ + if (! (head)->hh.tbl->buckets) { uthash_fatal( "out of memory"); } \ + memset((head)->hh.tbl->buckets, 0, \ + HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \ + HASH_BLOOM_MAKE((head)->hh.tbl); \ + (head)->hh.tbl->signature = HASH_SIGNATURE; \ +} while(0) + +#define HASH_ADD(hh,head,fieldname,keylen_in,add) \ + HASH_ADD_KEYPTR(hh,head,&((add)->fieldname),keylen_in,add) + +#define HASH_ADD_KEYPTR(hh,head,keyptr,keylen_in,add) \ +do { \ + unsigned _ha_bkt; \ + (add)->hh.next = NULL; \ + (add)->hh.key = (char*)keyptr; \ + (add)->hh.keylen = (unsigned)keylen_in; \ + if (!(head)) { \ + head = (add); \ + (head)->hh.prev = NULL; \ + HASH_MAKE_TABLE(hh,head); \ + } else { \ + (head)->hh.tbl->tail->next = (add); \ + (add)->hh.prev = ELMT_FROM_HH((head)->hh.tbl, (head)->hh.tbl->tail); \ + (head)->hh.tbl->tail = &((add)->hh); \ + } \ + (head)->hh.tbl->num_items++; \ + (add)->hh.tbl = (head)->hh.tbl; \ + HASH_FCN(keyptr,keylen_in, (head)->hh.tbl->num_buckets, \ + (add)->hh.hashv, _ha_bkt); \ + HASH_ADD_TO_BKT((head)->hh.tbl->buckets[_ha_bkt],&(add)->hh); \ + HASH_BLOOM_ADD((head)->hh.tbl,(add)->hh.hashv); \ + HASH_EMIT_KEY(hh,head,keyptr,keylen_in); \ + HASH_FSCK(hh,head); \ +} while(0) + +#define HASH_TO_BKT( hashv, num_bkts, bkt ) \ +do { \ + bkt = ((hashv) & ((num_bkts) - 1)); \ +} while(0) + +/* delete "delptr" from the hash table. + * "the usual" patch-up process for the app-order doubly-linked-list. + * The use of _hd_hh_del below deserves special explanation. + * These used to be expressed using (delptr) but that led to a bug + * if someone used the same symbol for the head and deletee, like + * HASH_DELETE(hh,users,users); + * We want that to work, but by changing the head (users) below + * we were forfeiting our ability to further refer to the deletee (users) + * in the patch-up process. Solution: use scratch space to + * copy the deletee pointer, then the latter references are via that + * scratch pointer rather than through the repointed (users) symbol. + */ +#define HASH_DELETE(hh,head,delptr) \ +do { \ + unsigned _hd_bkt; \ + struct UT_hash_handle *_hd_hh_del; \ + if ( ((delptr)->hh.prev == NULL) && ((delptr)->hh.next == NULL) ) { \ + uthash_free((head)->hh.tbl->buckets, \ + (head)->hh.tbl->num_buckets*sizeof(struct UT_hash_bucket) ); \ + HASH_BLOOM_FREE((head)->hh.tbl); \ + uthash_free((head)->hh.tbl, sizeof(UT_hash_table)); \ + head = NULL; \ + } else { \ + _hd_hh_del = &((delptr)->hh); \ + if ((delptr) == ELMT_FROM_HH((head)->hh.tbl,(head)->hh.tbl->tail)) { \ + (head)->hh.tbl->tail = \ + (UT_hash_handle*)((ptrdiff_t)((delptr)->hh.prev) + \ + (head)->hh.tbl->hho); \ + } \ + if ((delptr)->hh.prev) { \ + ((UT_hash_handle*)((ptrdiff_t)((delptr)->hh.prev) + \ + (head)->hh.tbl->hho))->next = (delptr)->hh.next; \ + } else { \ + DECLTYPE_ASSIGN(head,(delptr)->hh.next); \ + } \ + if (_hd_hh_del->next) { \ + ((UT_hash_handle*)((ptrdiff_t)_hd_hh_del->next + \ + (head)->hh.tbl->hho))->prev = \ + _hd_hh_del->prev; \ + } \ + HASH_TO_BKT( _hd_hh_del->hashv, (head)->hh.tbl->num_buckets, _hd_bkt); \ + HASH_DEL_IN_BKT(hh,(head)->hh.tbl->buckets[_hd_bkt], _hd_hh_del); \ + (head)->hh.tbl->num_items--; \ + } \ + HASH_FSCK(hh,head); \ +} while (0) + + +/* convenience forms of HASH_FIND/HASH_ADD/HASH_DEL */ +#define HASH_FIND_STR(head,findstr,out) \ + HASH_FIND(hh,head,findstr,strlen(findstr),out) +#define HASH_ADD_STR(head,strfield,add) \ + HASH_ADD(hh,head,strfield,strlen(add->strfield),add) +#define HASH_FIND_INT(head,findint,out) \ + HASH_FIND(hh,head,findint,sizeof(int),out) +#define HASH_ADD_INT(head,intfield,add) \ + HASH_ADD(hh,head,intfield,sizeof(int),add) +#define HASH_FIND_PTR(head,findptr,out) \ + HASH_FIND(hh,head,findptr,sizeof(void *),out) +#define HASH_ADD_PTR(head,ptrfield,add) \ + HASH_ADD(hh,head,ptrfield,sizeof(void *),add) +#define HASH_DEL(head,delptr) \ + HASH_DELETE(hh,head,delptr) + +/* HASH_FSCK checks hash integrity on every add/delete when HASH_DEBUG is defined. + * This is for uthash developer only; it compiles away if HASH_DEBUG isn't defined. + */ +#ifdef HASH_DEBUG +#define HASH_OOPS(...) do { fprintf(stderr,__VA_ARGS__); exit(-1); } while (0) +#define HASH_FSCK(hh,head) \ +do { \ + unsigned _bkt_i; \ + unsigned _count, _bkt_count; \ + char *_prev; \ + struct UT_hash_handle *_thh; \ + if (head) { \ + _count = 0; \ + for( _bkt_i = 0; _bkt_i < (head)->hh.tbl->num_buckets; _bkt_i++) { \ + _bkt_count = 0; \ + _thh = (head)->hh.tbl->buckets[_bkt_i].hh_head; \ + _prev = NULL; \ + while (_thh) { \ + if (_prev != (char*)(_thh->hh_prev)) { \ + HASH_OOPS("invalid hh_prev %p, actual %p\n", \ + _thh->hh_prev, _prev ); \ + } \ + _bkt_count++; \ + _prev = (char*)(_thh); \ + _thh = _thh->hh_next; \ + } \ + _count += _bkt_count; \ + if ((head)->hh.tbl->buckets[_bkt_i].count != _bkt_count) { \ + HASH_OOPS("invalid bucket count %d, actual %d\n", \ + (head)->hh.tbl->buckets[_bkt_i].count, _bkt_count); \ + } \ + } \ + if (_count != (head)->hh.tbl->num_items) { \ + HASH_OOPS("invalid hh item count %d, actual %d\n", \ + (head)->hh.tbl->num_items, _count ); \ + } \ + /* traverse hh in app order; check next/prev integrity, count */ \ + _count = 0; \ + _prev = NULL; \ + _thh = &(head)->hh; \ + while (_thh) { \ + _count++; \ + if (_prev !=(char*)(_thh->prev)) { \ + HASH_OOPS("invalid prev %p, actual %p\n", \ + _thh->prev, _prev ); \ + } \ + _prev = (char*)ELMT_FROM_HH((head)->hh.tbl, _thh); \ + _thh = ( _thh->next ? (UT_hash_handle*)((char*)(_thh->next) + \ + (head)->hh.tbl->hho) : NULL ); \ + } \ + if (_count != (head)->hh.tbl->num_items) { \ + HASH_OOPS("invalid app item count %d, actual %d\n", \ + (head)->hh.tbl->num_items, _count ); \ + } \ + } \ +} while (0) +#else +#define HASH_FSCK(hh,head) +#endif + +/* When compiled with -DHASH_EMIT_KEYS, length-prefixed keys are emitted to + * the descriptor to which this macro is defined for tuning the hash function. + * The app can #include to get the prototype for write(2). */ +#ifdef HASH_EMIT_KEYS +#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) \ +do { \ + unsigned _klen = fieldlen; \ + write(HASH_EMIT_KEYS, &_klen, sizeof(_klen)); \ + write(HASH_EMIT_KEYS, keyptr, fieldlen); \ +} while (0) +#else +#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) +#endif + +/* default to Jenkin's hash unless overridden e.g. DHASH_FUNCTION=HASH_SAX */ +#ifdef HASH_FUNCTION +#define HASH_FCN HASH_FUNCTION +#else +#define HASH_FCN HASH_JEN +#endif + +/* The Bernstein hash function, used in Perl prior to v5.6 */ +#define HASH_BER(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _hb_keylen=keylen; \ + char *_hb_key=(char*)(key); \ + (hashv) = 0; \ + while (_hb_keylen--) { (hashv) = ((hashv) * 33) + *_hb_key++; } \ + bkt = (hashv) & (num_bkts-1); \ +} while (0) + + +/* SAX/FNV/OAT/JEN hash functions are macro variants of those listed at + * http://eternallyconfuzzled.com/tuts/algorithms/jsw_tut_hashing.aspx */ +#define HASH_SAX(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _sx_i; \ + char *_hs_key=(char*)(key); \ + hashv = 0; \ + for(_sx_i=0; _sx_i < keylen; _sx_i++) \ + hashv ^= (hashv << 5) + (hashv >> 2) + _hs_key[_sx_i]; \ + bkt = hashv & (num_bkts-1); \ +} while (0) + +#define HASH_FNV(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _fn_i; \ + char *_hf_key=(char*)(key); \ + hashv = 2166136261UL; \ + for(_fn_i=0; _fn_i < keylen; _fn_i++) \ + hashv = (hashv * 16777619) ^ _hf_key[_fn_i]; \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +#define HASH_OAT(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _ho_i; \ + char *_ho_key=(char*)(key); \ + hashv = 0; \ + for(_ho_i=0; _ho_i < keylen; _ho_i++) { \ + hashv += _ho_key[_ho_i]; \ + hashv += (hashv << 10); \ + hashv ^= (hashv >> 6); \ + } \ + hashv += (hashv << 3); \ + hashv ^= (hashv >> 11); \ + hashv += (hashv << 15); \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +#define HASH_JEN_MIX(a,b,c) \ +do { \ + a -= b; a -= c; a ^= ( c >> 13 ); \ + b -= c; b -= a; b ^= ( a << 8 ); \ + c -= a; c -= b; c ^= ( b >> 13 ); \ + a -= b; a -= c; a ^= ( c >> 12 ); \ + b -= c; b -= a; b ^= ( a << 16 ); \ + c -= a; c -= b; c ^= ( b >> 5 ); \ + a -= b; a -= c; a ^= ( c >> 3 ); \ + b -= c; b -= a; b ^= ( a << 10 ); \ + c -= a; c -= b; c ^= ( b >> 15 ); \ +} while (0) + +#define HASH_JEN(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _hj_i,_hj_j,_hj_k; \ + char *_hj_key=(char*)(key); \ + hashv = 0xfeedbeef; \ + _hj_i = _hj_j = 0x9e3779b9; \ + _hj_k = (unsigned)keylen; \ + while (_hj_k >= 12) { \ + _hj_i += (_hj_key[0] + ( (unsigned)_hj_key[1] << 8 ) \ + + ( (unsigned)_hj_key[2] << 16 ) \ + + ( (unsigned)_hj_key[3] << 24 ) ); \ + _hj_j += (_hj_key[4] + ( (unsigned)_hj_key[5] << 8 ) \ + + ( (unsigned)_hj_key[6] << 16 ) \ + + ( (unsigned)_hj_key[7] << 24 ) ); \ + hashv += (_hj_key[8] + ( (unsigned)_hj_key[9] << 8 ) \ + + ( (unsigned)_hj_key[10] << 16 ) \ + + ( (unsigned)_hj_key[11] << 24 ) ); \ + \ + HASH_JEN_MIX(_hj_i, _hj_j, hashv); \ + \ + _hj_key += 12; \ + _hj_k -= 12; \ + } \ + hashv += keylen; \ + switch ( _hj_k ) { \ + case 11: hashv += ( (unsigned)_hj_key[10] << 24 ); \ + case 10: hashv += ( (unsigned)_hj_key[9] << 16 ); \ + case 9: hashv += ( (unsigned)_hj_key[8] << 8 ); \ + case 8: _hj_j += ( (unsigned)_hj_key[7] << 24 ); \ + case 7: _hj_j += ( (unsigned)_hj_key[6] << 16 ); \ + case 6: _hj_j += ( (unsigned)_hj_key[5] << 8 ); \ + case 5: _hj_j += _hj_key[4]; \ + case 4: _hj_i += ( (unsigned)_hj_key[3] << 24 ); \ + case 3: _hj_i += ( (unsigned)_hj_key[2] << 16 ); \ + case 2: _hj_i += ( (unsigned)_hj_key[1] << 8 ); \ + case 1: _hj_i += _hj_key[0]; \ + } \ + HASH_JEN_MIX(_hj_i, _hj_j, hashv); \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +/* The Paul Hsieh hash function */ +#undef get16bits +#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \ + || defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__) +#define get16bits(d) (*((const uint16_t *) (d))) +#endif + +#if !defined (get16bits) +#define get16bits(d) ((((uint32_t)(((const uint8_t *)(d))[1])) << 8) \ + +(uint32_t)(((const uint8_t *)(d))[0]) ) +#endif +#define HASH_SFH(key,keylen,num_bkts,hashv,bkt) \ +do { \ + char *_sfh_key=(char*)(key); \ + uint32_t _sfh_tmp, _sfh_len = keylen; \ + \ + int _sfh_rem = _sfh_len & 3; \ + _sfh_len >>= 2; \ + hashv = 0xcafebabe; \ + \ + /* Main loop */ \ + for (;_sfh_len > 0; _sfh_len--) { \ + hashv += get16bits (_sfh_key); \ + _sfh_tmp = (get16bits (_sfh_key+2) << 11) ^ hashv; \ + hashv = (hashv << 16) ^ _sfh_tmp; \ + _sfh_key += 2*sizeof (uint16_t); \ + hashv += hashv >> 11; \ + } \ + \ + /* Handle end cases */ \ + switch (_sfh_rem) { \ + case 3: hashv += get16bits (_sfh_key); \ + hashv ^= hashv << 16; \ + hashv ^= _sfh_key[sizeof (uint16_t)] << 18; \ + hashv += hashv >> 11; \ + break; \ + case 2: hashv += get16bits (_sfh_key); \ + hashv ^= hashv << 11; \ + hashv += hashv >> 17; \ + break; \ + case 1: hashv += *_sfh_key; \ + hashv ^= hashv << 10; \ + hashv += hashv >> 1; \ + } \ + \ + /* Force "avalanching" of final 127 bits */ \ + hashv ^= hashv << 3; \ + hashv += hashv >> 5; \ + hashv ^= hashv << 4; \ + hashv += hashv >> 17; \ + hashv ^= hashv << 25; \ + hashv += hashv >> 6; \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +#ifdef HASH_USING_NO_STRICT_ALIASING +/* The MurmurHash exploits some CPU's (x86,x86_64) tolerance for unaligned reads. + * For other types of CPU's (e.g. Sparc) an unaligned read causes a bus error. + * MurmurHash uses the faster approach only on CPU's where we know it's safe. + * + * Note the preprocessor built-in defines can be emitted using: + * + * gcc -m64 -dM -E - < /dev/null (on gcc) + * cc -## a.c (where a.c is a simple test file) (Sun Studio) + */ +#if (defined(__i386__) || defined(__x86_64__) || defined(_M_IX86)) +#define MUR_GETBLOCK(p,i) p[i] +#else /* non intel */ +#define MUR_PLUS0_ALIGNED(p) (((unsigned long)p & 0x3) == 0) +#define MUR_PLUS1_ALIGNED(p) (((unsigned long)p & 0x3) == 1) +#define MUR_PLUS2_ALIGNED(p) (((unsigned long)p & 0x3) == 2) +#define MUR_PLUS3_ALIGNED(p) (((unsigned long)p & 0x3) == 3) +#define WP(p) ((uint32_t*)((unsigned long)(p) & ~3UL)) +#if (defined(__BIG_ENDIAN__) || defined(SPARC) || defined(__ppc__) || defined(__ppc64__)) +#define MUR_THREE_ONE(p) ((((*WP(p))&0x00ffffff) << 8) | (((*(WP(p)+1))&0xff000000) >> 24)) +#define MUR_TWO_TWO(p) ((((*WP(p))&0x0000ffff) <<16) | (((*(WP(p)+1))&0xffff0000) >> 16)) +#define MUR_ONE_THREE(p) ((((*WP(p))&0x000000ff) <<24) | (((*(WP(p)+1))&0xffffff00) >> 8)) +#else /* assume little endian non-intel */ +#define MUR_THREE_ONE(p) ((((*WP(p))&0xffffff00) >> 8) | (((*(WP(p)+1))&0x000000ff) << 24)) +#define MUR_TWO_TWO(p) ((((*WP(p))&0xffff0000) >>16) | (((*(WP(p)+1))&0x0000ffff) << 16)) +#define MUR_ONE_THREE(p) ((((*WP(p))&0xff000000) >>24) | (((*(WP(p)+1))&0x00ffffff) << 8)) +#endif +#define MUR_GETBLOCK(p,i) (MUR_PLUS0_ALIGNED(p) ? ((p)[i]) : \ + (MUR_PLUS1_ALIGNED(p) ? MUR_THREE_ONE(p) : \ + (MUR_PLUS2_ALIGNED(p) ? MUR_TWO_TWO(p) : \ + MUR_ONE_THREE(p)))) +#endif +#define MUR_ROTL32(x,r) (((x) << (r)) | ((x) >> (32 - (r)))) +#define MUR_FMIX(_h) \ +do { \ + _h ^= _h >> 16; \ + _h *= 0x85ebca6b; \ + _h ^= _h >> 13; \ + _h *= 0xc2b2ae35l; \ + _h ^= _h >> 16; \ +} while(0) + +#define HASH_MUR(key,keylen,num_bkts,hashv,bkt) \ +do { \ + const uint8_t *_mur_data = (const uint8_t*)(key); \ + const int _mur_nblocks = (keylen) / 4; \ + uint32_t _mur_h1 = 0xf88D5353; \ + uint32_t _mur_c1 = 0xcc9e2d51; \ + uint32_t _mur_c2 = 0x1b873593; \ + uint32_t _mur_k1 = 0; \ + const uint8_t *_mur_tail; \ + const uint32_t *_mur_blocks = (const uint32_t*)(_mur_data+_mur_nblocks*4); \ + int _mur_i; \ + for(_mur_i = -_mur_nblocks; _mur_i; _mur_i++) { \ + _mur_k1 = MUR_GETBLOCK(_mur_blocks,_mur_i); \ + _mur_k1 *= _mur_c1; \ + _mur_k1 = MUR_ROTL32(_mur_k1,15); \ + _mur_k1 *= _mur_c2; \ + \ + _mur_h1 ^= _mur_k1; \ + _mur_h1 = MUR_ROTL32(_mur_h1,13); \ + _mur_h1 = _mur_h1*5+0xe6546b64; \ + } \ + _mur_tail = (const uint8_t*)(_mur_data + _mur_nblocks*4); \ + _mur_k1=0; \ + switch((keylen) & 3) { \ + case 3: _mur_k1 ^= _mur_tail[2] << 16; \ + case 2: _mur_k1 ^= _mur_tail[1] << 8; \ + case 1: _mur_k1 ^= _mur_tail[0]; \ + _mur_k1 *= _mur_c1; \ + _mur_k1 = MUR_ROTL32(_mur_k1,15); \ + _mur_k1 *= _mur_c2; \ + _mur_h1 ^= _mur_k1; \ + } \ + _mur_h1 ^= (keylen); \ + MUR_FMIX(_mur_h1); \ + hashv = _mur_h1; \ + bkt = hashv & (num_bkts-1); \ +} while(0) +#endif /* HASH_USING_NO_STRICT_ALIASING */ + +/* key comparison function; return 0 if keys equal */ +#define HASH_KEYCMP(a,b,len) memcmp(a,b,len) + +/* iterate over items in a known bucket to find desired item */ +#define HASH_FIND_IN_BKT(tbl,hh,head,keyptr,keylen_in,out) \ +do { \ + if (head.hh_head) DECLTYPE_ASSIGN(out,ELMT_FROM_HH(tbl,head.hh_head)); \ + else out=NULL; \ + while (out) { \ + if ((out)->hh.keylen == keylen_in) { \ + if ((HASH_KEYCMP((out)->hh.key,keyptr,keylen_in)) == 0) break; \ + } \ + if ((out)->hh.hh_next) DECLTYPE_ASSIGN(out,ELMT_FROM_HH(tbl,(out)->hh.hh_next)); \ + else out = NULL; \ + } \ +} while(0) + +/* add an item to a bucket */ +#define HASH_ADD_TO_BKT(head,addhh) \ +do { \ + head.count++; \ + (addhh)->hh_next = head.hh_head; \ + (addhh)->hh_prev = NULL; \ + if (head.hh_head) { (head).hh_head->hh_prev = (addhh); } \ + (head).hh_head=addhh; \ + if (head.count >= ((head.expand_mult+1) * HASH_BKT_CAPACITY_THRESH) \ + && (addhh)->tbl->noexpand != 1) { \ + HASH_EXPAND_BUCKETS((addhh)->tbl); \ + } \ +} while(0) + +/* remove an item from a given bucket */ +#define HASH_DEL_IN_BKT(hh,head,hh_del) \ + (head).count--; \ + if ((head).hh_head == hh_del) { \ + (head).hh_head = hh_del->hh_next; \ + } \ + if (hh_del->hh_prev) { \ + hh_del->hh_prev->hh_next = hh_del->hh_next; \ + } \ + if (hh_del->hh_next) { \ + hh_del->hh_next->hh_prev = hh_del->hh_prev; \ + } + +/* Bucket expansion has the effect of doubling the number of buckets + * and redistributing the items into the new buckets. Ideally the + * items will distribute more or less evenly into the new buckets + * (the extent to which this is true is a measure of the quality of + * the hash function as it applies to the key domain). + * + * With the items distributed into more buckets, the chain length + * (item count) in each bucket is reduced. Thus by expanding buckets + * the hash keeps a bound on the chain length. This bounded chain + * length is the essence of how a hash provides constant time lookup. + * + * The calculation of tbl->ideal_chain_maxlen below deserves some + * explanation. First, keep in mind that we're calculating the ideal + * maximum chain length based on the *new* (doubled) bucket count. + * In fractions this is just n/b (n=number of items,b=new num buckets). + * Since the ideal chain length is an integer, we want to calculate + * ceil(n/b). We don't depend on floating point arithmetic in this + * hash, so to calculate ceil(n/b) with integers we could write + * + * ceil(n/b) = (n/b) + ((n%b)?1:0) + * + * and in fact a previous version of this hash did just that. + * But now we have improved things a bit by recognizing that b is + * always a power of two. We keep its base 2 log handy (call it lb), + * so now we can write this with a bit shift and logical AND: + * + * ceil(n/b) = (n>>lb) + ( (n & (b-1)) ? 1:0) + * + */ +#define HASH_EXPAND_BUCKETS(tbl) \ +do { \ + unsigned _he_bkt; \ + unsigned _he_bkt_i; \ + struct UT_hash_handle *_he_thh, *_he_hh_nxt; \ + UT_hash_bucket *_he_new_buckets, *_he_newbkt; \ + _he_new_buckets = (UT_hash_bucket*)uthash_malloc( \ + 2 * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \ + if (!_he_new_buckets) { uthash_fatal( "out of memory"); } \ + memset(_he_new_buckets, 0, \ + 2 * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \ + tbl->ideal_chain_maxlen = \ + (tbl->num_items >> (tbl->log2_num_buckets+1)) + \ + ((tbl->num_items & ((tbl->num_buckets*2)-1)) ? 1 : 0); \ + tbl->nonideal_items = 0; \ + for(_he_bkt_i = 0; _he_bkt_i < tbl->num_buckets; _he_bkt_i++) \ + { \ + _he_thh = tbl->buckets[ _he_bkt_i ].hh_head; \ + while (_he_thh) { \ + _he_hh_nxt = _he_thh->hh_next; \ + HASH_TO_BKT( _he_thh->hashv, tbl->num_buckets*2, _he_bkt); \ + _he_newbkt = &(_he_new_buckets[ _he_bkt ]); \ + if (++(_he_newbkt->count) > tbl->ideal_chain_maxlen) { \ + tbl->nonideal_items++; \ + _he_newbkt->expand_mult = _he_newbkt->count / \ + tbl->ideal_chain_maxlen; \ + } \ + _he_thh->hh_prev = NULL; \ + _he_thh->hh_next = _he_newbkt->hh_head; \ + if (_he_newbkt->hh_head) _he_newbkt->hh_head->hh_prev = \ + _he_thh; \ + _he_newbkt->hh_head = _he_thh; \ + _he_thh = _he_hh_nxt; \ + } \ + } \ + uthash_free( tbl->buckets, tbl->num_buckets*sizeof(struct UT_hash_bucket) ); \ + tbl->num_buckets *= 2; \ + tbl->log2_num_buckets++; \ + tbl->buckets = _he_new_buckets; \ + tbl->ineff_expands = (tbl->nonideal_items > (tbl->num_items >> 1)) ? \ + (tbl->ineff_expands+1) : 0; \ + if (tbl->ineff_expands > 1) { \ + tbl->noexpand=1; \ + uthash_noexpand_fyi(tbl); \ + } \ + uthash_expand_fyi(tbl); \ +} while(0) + + +/* This is an adaptation of Simon Tatham's O(n log(n)) mergesort */ +/* Note that HASH_SORT assumes the hash handle name to be hh. + * HASH_SRT was added to allow the hash handle name to be passed in. */ +#define HASH_SORT(head,cmpfcn) HASH_SRT(hh,head,cmpfcn) +#define HASH_SRT(hh,head,cmpfcn) \ +do { \ + unsigned _hs_i; \ + unsigned _hs_looping,_hs_nmerges,_hs_insize,_hs_psize,_hs_qsize; \ + struct UT_hash_handle *_hs_p, *_hs_q, *_hs_e, *_hs_list, *_hs_tail; \ + if (head) { \ + _hs_insize = 1; \ + _hs_looping = 1; \ + _hs_list = &((head)->hh); \ + while (_hs_looping) { \ + _hs_p = _hs_list; \ + _hs_list = NULL; \ + _hs_tail = NULL; \ + _hs_nmerges = 0; \ + while (_hs_p) { \ + _hs_nmerges++; \ + _hs_q = _hs_p; \ + _hs_psize = 0; \ + for ( _hs_i = 0; _hs_i < _hs_insize; _hs_i++ ) { \ + _hs_psize++; \ + _hs_q = (UT_hash_handle*)((_hs_q->next) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + if (! (_hs_q) ) break; \ + } \ + _hs_qsize = _hs_insize; \ + while ((_hs_psize > 0) || ((_hs_qsize > 0) && _hs_q )) { \ + if (_hs_psize == 0) { \ + _hs_e = _hs_q; \ + _hs_q = (UT_hash_handle*)((_hs_q->next) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_qsize--; \ + } else if ( (_hs_qsize == 0) || !(_hs_q) ) { \ + _hs_e = _hs_p; \ + _hs_p = (UT_hash_handle*)((_hs_p->next) ? \ + ((void*)((char*)(_hs_p->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_psize--; \ + } else if (( \ + cmpfcn(DECLTYPE(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_p)), \ + DECLTYPE(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_q))) \ + ) <= 0) { \ + _hs_e = _hs_p; \ + _hs_p = (UT_hash_handle*)((_hs_p->next) ? \ + ((void*)((char*)(_hs_p->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_psize--; \ + } else { \ + _hs_e = _hs_q; \ + _hs_q = (UT_hash_handle*)((_hs_q->next) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_qsize--; \ + } \ + if ( _hs_tail ) { \ + _hs_tail->next = ((_hs_e) ? \ + ELMT_FROM_HH((head)->hh.tbl,_hs_e) : NULL); \ + } else { \ + _hs_list = _hs_e; \ + } \ + _hs_e->prev = ((_hs_tail) ? \ + ELMT_FROM_HH((head)->hh.tbl,_hs_tail) : NULL); \ + _hs_tail = _hs_e; \ + } \ + _hs_p = _hs_q; \ + } \ + _hs_tail->next = NULL; \ + if ( _hs_nmerges <= 1 ) { \ + _hs_looping=0; \ + (head)->hh.tbl->tail = _hs_tail; \ + DECLTYPE_ASSIGN(head,ELMT_FROM_HH((head)->hh.tbl, _hs_list)); \ + } \ + _hs_insize *= 2; \ + } \ + HASH_FSCK(hh,head); \ + } \ +} while (0) + +/* This function selects items from one hash into another hash. + * The end result is that the selected items have dual presence + * in both hashes. There is no copy of the items made; rather + * they are added into the new hash through a secondary hash + * hash handle that must be present in the structure. */ +#define HASH_SELECT(hh_dst, dst, hh_src, src, cond) \ +do { \ + unsigned _src_bkt, _dst_bkt; \ + void *_last_elt=NULL, *_elt; \ + UT_hash_handle *_src_hh, *_dst_hh, *_last_elt_hh=NULL; \ + ptrdiff_t _dst_hho = ((char*)(&(dst)->hh_dst) - (char*)(dst)); \ + if (src) { \ + for(_src_bkt=0; _src_bkt < (src)->hh_src.tbl->num_buckets; _src_bkt++) { \ + for(_src_hh = (src)->hh_src.tbl->buckets[_src_bkt].hh_head; \ + _src_hh; \ + _src_hh = _src_hh->hh_next) { \ + _elt = ELMT_FROM_HH((src)->hh_src.tbl, _src_hh); \ + if (cond(_elt)) { \ + _dst_hh = (UT_hash_handle*)(((char*)_elt) + _dst_hho); \ + _dst_hh->key = _src_hh->key; \ + _dst_hh->keylen = _src_hh->keylen; \ + _dst_hh->hashv = _src_hh->hashv; \ + _dst_hh->prev = _last_elt; \ + _dst_hh->next = NULL; \ + if (_last_elt_hh) { _last_elt_hh->next = _elt; } \ + if (!dst) { \ + DECLTYPE_ASSIGN(dst,_elt); \ + HASH_MAKE_TABLE(hh_dst,dst); \ + } else { \ + _dst_hh->tbl = (dst)->hh_dst.tbl; \ + } \ + HASH_TO_BKT(_dst_hh->hashv, _dst_hh->tbl->num_buckets, _dst_bkt); \ + HASH_ADD_TO_BKT(_dst_hh->tbl->buckets[_dst_bkt],_dst_hh); \ + (dst)->hh_dst.tbl->num_items++; \ + _last_elt = _elt; \ + _last_elt_hh = _dst_hh; \ + } \ + } \ + } \ + } \ + HASH_FSCK(hh_dst,dst); \ +} while (0) + +#define HASH_CLEAR(hh,head) \ +do { \ + if (head) { \ + uthash_free((head)->hh.tbl->buckets, \ + (head)->hh.tbl->num_buckets*sizeof(struct UT_hash_bucket)); \ + HASH_BLOOM_FREE((head)->hh.tbl); \ + uthash_free((head)->hh.tbl, sizeof(UT_hash_table)); \ + (head)=NULL; \ + } \ +} while(0) + +#ifdef NO_DECLTYPE +#define HASH_ITER(hh,head,el,tmp) \ +for((el)=(head), (*(char**)(&(tmp)))=(char*)((head)?(head)->hh.next:NULL); \ + el; (el)=(tmp),(*(char**)(&(tmp)))=(char*)((tmp)?(tmp)->hh.next:NULL)) +#else +#define HASH_ITER(hh,head,el,tmp) \ +for((el)=(head),(tmp)=DECLTYPE(el)((head)?(head)->hh.next:NULL); \ + el; (el)=(tmp),(tmp)=DECLTYPE(el)((tmp)?(tmp)->hh.next:NULL)) +#endif + +/* obtain a count of items in the hash */ +#define HASH_COUNT(head) HASH_CNT(hh,head) +#define HASH_CNT(hh,head) ((head)?((head)->hh.tbl->num_items):0) + +typedef struct UT_hash_bucket { + struct UT_hash_handle *hh_head; + unsigned count; + + /* expand_mult is normally set to 0. In this situation, the max chain length + * threshold is enforced at its default value, HASH_BKT_CAPACITY_THRESH. (If + * the bucket's chain exceeds this length, bucket expansion is triggered). + * However, setting expand_mult to a non-zero value delays bucket expansion + * (that would be triggered by additions to this particular bucket) + * until its chain length reaches a *multiple* of HASH_BKT_CAPACITY_THRESH. + * (The multiplier is simply expand_mult+1). The whole idea of this + * multiplier is to reduce bucket expansions, since they are expensive, in + * situations where we know that a particular bucket tends to be overused. + * It is better to let its chain length grow to a longer yet-still-bounded + * value, than to do an O(n) bucket expansion too often. + */ + unsigned expand_mult; + +} UT_hash_bucket; + +/* random signature used only to find hash tables in external analysis */ +#define HASH_SIGNATURE 0xa0111fe1 +#define HASH_BLOOM_SIGNATURE 0xb12220f2 + +typedef struct UT_hash_table { + UT_hash_bucket *buckets; + unsigned num_buckets, log2_num_buckets; + unsigned num_items; + struct UT_hash_handle *tail; /* tail hh in app order, for fast append */ + ptrdiff_t hho; /* hash handle offset (byte pos of hash handle in element */ + + /* in an ideal situation (all buckets used equally), no bucket would have + * more than ceil(#items/#buckets) items. that's the ideal chain length. */ + unsigned ideal_chain_maxlen; + + /* nonideal_items is the number of items in the hash whose chain position + * exceeds the ideal chain maxlen. these items pay the penalty for an uneven + * hash distribution; reaching them in a chain traversal takes >ideal steps */ + unsigned nonideal_items; + + /* ineffective expands occur when a bucket doubling was performed, but + * afterward, more than half the items in the hash had nonideal chain + * positions. If this happens on two consecutive expansions we inhibit any + * further expansion, as it's not helping; this happens when the hash + * function isn't a good fit for the key domain. When expansion is inhibited + * the hash will still work, albeit no longer in constant time. */ + unsigned ineff_expands, noexpand; + + uint32_t signature; /* used only to find hash tables in external analysis */ +#ifdef HASH_BLOOM + uint32_t bloom_sig; /* used only to test bloom exists in external analysis */ + uint8_t *bloom_bv; + char bloom_nbits; +#endif + +} UT_hash_table; + +typedef struct UT_hash_handle { + struct UT_hash_table *tbl; + void *prev; /* prev element in app order */ + void *next; /* next element in app order */ + struct UT_hash_handle *hh_prev; /* previous hh in bucket order */ + struct UT_hash_handle *hh_next; /* next hh in bucket order */ + void *key; /* ptr to enclosing struct's key */ + unsigned keylen; /* enclosing struct's key len */ + unsigned hashv; /* result of hash-fcn(key) */ +} UT_hash_handle; + +#endif /* UTHASH_H */ diff --git a/packages/udi/uthash/CMakeLists.txt b/packages/udi/uthash/CMakeLists.txt new file mode 100644 index 000000000..e62c90246 --- /dev/null +++ b/packages/udi/uthash/CMakeLists.txt @@ -0,0 +1,16 @@ +CMAKE_MINIMUM_REQUIRED ( VERSION 2.8 ) + +PROJECT ( YAP_UDI_UTHASH ) + +INCLUDE_DIRECTORIES( + . +) + +SET ( SOURCES + uthash_udi.c + ) + +ADD_LIBRARY(udi_uthash SHARED ${SOURCES}) + +INSTALL(TARGETS udi_uthash DESTINATION ${YAP_PL_LIBRARY_DIR}) +INSTALL(FILES uthash.yap DESTINATION ${YAP_PL_LIBRARY_DIR}) diff --git a/packages/udi/uthash/uthash.h b/packages/udi/uthash/uthash.h new file mode 100644 index 000000000..9f83fc34f --- /dev/null +++ b/packages/udi/uthash/uthash.h @@ -0,0 +1,915 @@ +/* +Copyright (c) 2003-2012, Troy D. Hanson http://uthash.sourceforge.net +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef UTHASH_H +#define UTHASH_H + +#include /* memcmp,strlen */ +#include /* ptrdiff_t */ +#include /* exit() */ + +/* These macros use decltype or the earlier __typeof GNU extension. + As decltype is only available in newer compilers (VS2010 or gcc 4.3+ + when compiling c++ source) this code uses whatever method is needed + or, for VS2008 where neither is available, uses casting workarounds. */ +#ifdef _MSC_VER /* MS compiler */ +#if _MSC_VER >= 1600 && defined(__cplusplus) /* VS2010 or newer in C++ mode */ +#define DECLTYPE(x) (decltype(x)) +#else /* VS2008 or older (or VS2010 in C mode) */ +#define NO_DECLTYPE +#define DECLTYPE(x) +#endif +#else /* GNU, Sun and other compilers */ +#define DECLTYPE(x) (__typeof(x)) +#endif + +#ifdef NO_DECLTYPE +#define DECLTYPE_ASSIGN(dst,src) \ +do { \ + char **_da_dst = (char**)(&(dst)); \ + *_da_dst = (char*)(src); \ +} while(0) +#else +#define DECLTYPE_ASSIGN(dst,src) \ +do { \ + (dst) = DECLTYPE(dst)(src); \ +} while(0) +#endif + +/* a number of the hash function use uint32_t which isn't defined on win32 */ +#ifdef _MSC_VER +typedef unsigned int uint32_t; +typedef unsigned char uint8_t; +#else +#include /* uint32_t */ +#endif + +#define UTHASH_VERSION 1.9.6 + +#ifndef uthash_fatal +#define uthash_fatal(msg) exit(-1) /* fatal error (out of memory,etc) */ +#endif +#ifndef uthash_malloc +#define uthash_malloc(sz) malloc(sz) /* malloc fcn */ +#endif +#ifndef uthash_free +#define uthash_free(ptr,sz) free(ptr) /* free fcn */ +#endif + +#ifndef uthash_noexpand_fyi +#define uthash_noexpand_fyi(tbl) /* can be defined to log noexpand */ +#endif +#ifndef uthash_expand_fyi +#define uthash_expand_fyi(tbl) /* can be defined to log expands */ +#endif + +/* initial number of buckets */ +#define HASH_INITIAL_NUM_BUCKETS 32 /* initial number of buckets */ +#define HASH_INITIAL_NUM_BUCKETS_LOG2 5 /* lg2 of initial number of buckets */ +#define HASH_BKT_CAPACITY_THRESH 10 /* expand when bucket count reaches */ + +/* calculate the element whose hash handle address is hhe */ +#define ELMT_FROM_HH(tbl,hhp) ((void*)(((char*)(hhp)) - ((tbl)->hho))) + +#define HASH_FIND(hh,head,keyptr,keylen,out) \ +do { \ + unsigned _hf_bkt,_hf_hashv; \ + out=NULL; \ + if (head) { \ + HASH_FCN(keyptr,keylen, (head)->hh.tbl->num_buckets, _hf_hashv, _hf_bkt); \ + if (HASH_BLOOM_TEST((head)->hh.tbl, _hf_hashv)) { \ + HASH_FIND_IN_BKT((head)->hh.tbl, hh, (head)->hh.tbl->buckets[ _hf_bkt ], \ + keyptr,keylen,out); \ + } \ + } \ +} while (0) + +#ifdef HASH_BLOOM +#define HASH_BLOOM_BITLEN (1ULL << HASH_BLOOM) +#define HASH_BLOOM_BYTELEN (HASH_BLOOM_BITLEN/8) + ((HASH_BLOOM_BITLEN%8) ? 1:0) +#define HASH_BLOOM_MAKE(tbl) \ +do { \ + (tbl)->bloom_nbits = HASH_BLOOM; \ + (tbl)->bloom_bv = (uint8_t*)uthash_malloc(HASH_BLOOM_BYTELEN); \ + if (!((tbl)->bloom_bv)) { uthash_fatal( "out of memory"); } \ + memset((tbl)->bloom_bv, 0, HASH_BLOOM_BYTELEN); \ + (tbl)->bloom_sig = HASH_BLOOM_SIGNATURE; \ +} while (0) + +#define HASH_BLOOM_FREE(tbl) \ +do { \ + uthash_free((tbl)->bloom_bv, HASH_BLOOM_BYTELEN); \ +} while (0) + +#define HASH_BLOOM_BITSET(bv,idx) (bv[(idx)/8] |= (1U << ((idx)%8))) +#define HASH_BLOOM_BITTEST(bv,idx) (bv[(idx)/8] & (1U << ((idx)%8))) + +#define HASH_BLOOM_ADD(tbl,hashv) \ + HASH_BLOOM_BITSET((tbl)->bloom_bv, (hashv & (uint32_t)((1ULL << (tbl)->bloom_nbits) - 1))) + +#define HASH_BLOOM_TEST(tbl,hashv) \ + HASH_BLOOM_BITTEST((tbl)->bloom_bv, (hashv & (uint32_t)((1ULL << (tbl)->bloom_nbits) - 1))) + +#else +#define HASH_BLOOM_MAKE(tbl) +#define HASH_BLOOM_FREE(tbl) +#define HASH_BLOOM_ADD(tbl,hashv) +#define HASH_BLOOM_TEST(tbl,hashv) (1) +#endif + +#define HASH_MAKE_TABLE(hh,head) \ +do { \ + (head)->hh.tbl = (UT_hash_table*)uthash_malloc( \ + sizeof(UT_hash_table)); \ + if (!((head)->hh.tbl)) { uthash_fatal( "out of memory"); } \ + memset((head)->hh.tbl, 0, sizeof(UT_hash_table)); \ + (head)->hh.tbl->tail = &((head)->hh); \ + (head)->hh.tbl->num_buckets = HASH_INITIAL_NUM_BUCKETS; \ + (head)->hh.tbl->log2_num_buckets = HASH_INITIAL_NUM_BUCKETS_LOG2; \ + (head)->hh.tbl->hho = (char*)(&(head)->hh) - (char*)(head); \ + (head)->hh.tbl->buckets = (UT_hash_bucket*)uthash_malloc( \ + HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \ + if (! (head)->hh.tbl->buckets) { uthash_fatal( "out of memory"); } \ + memset((head)->hh.tbl->buckets, 0, \ + HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \ + HASH_BLOOM_MAKE((head)->hh.tbl); \ + (head)->hh.tbl->signature = HASH_SIGNATURE; \ +} while(0) + +#define HASH_ADD(hh,head,fieldname,keylen_in,add) \ + HASH_ADD_KEYPTR(hh,head,&((add)->fieldname),keylen_in,add) + +#define HASH_ADD_KEYPTR(hh,head,keyptr,keylen_in,add) \ +do { \ + unsigned _ha_bkt; \ + (add)->hh.next = NULL; \ + (add)->hh.key = (char*)keyptr; \ + (add)->hh.keylen = (unsigned)keylen_in; \ + if (!(head)) { \ + head = (add); \ + (head)->hh.prev = NULL; \ + HASH_MAKE_TABLE(hh,head); \ + } else { \ + (head)->hh.tbl->tail->next = (add); \ + (add)->hh.prev = ELMT_FROM_HH((head)->hh.tbl, (head)->hh.tbl->tail); \ + (head)->hh.tbl->tail = &((add)->hh); \ + } \ + (head)->hh.tbl->num_items++; \ + (add)->hh.tbl = (head)->hh.tbl; \ + HASH_FCN(keyptr,keylen_in, (head)->hh.tbl->num_buckets, \ + (add)->hh.hashv, _ha_bkt); \ + HASH_ADD_TO_BKT((head)->hh.tbl->buckets[_ha_bkt],&(add)->hh); \ + HASH_BLOOM_ADD((head)->hh.tbl,(add)->hh.hashv); \ + HASH_EMIT_KEY(hh,head,keyptr,keylen_in); \ + HASH_FSCK(hh,head); \ +} while(0) + +#define HASH_TO_BKT( hashv, num_bkts, bkt ) \ +do { \ + bkt = ((hashv) & ((num_bkts) - 1)); \ +} while(0) + +/* delete "delptr" from the hash table. + * "the usual" patch-up process for the app-order doubly-linked-list. + * The use of _hd_hh_del below deserves special explanation. + * These used to be expressed using (delptr) but that led to a bug + * if someone used the same symbol for the head and deletee, like + * HASH_DELETE(hh,users,users); + * We want that to work, but by changing the head (users) below + * we were forfeiting our ability to further refer to the deletee (users) + * in the patch-up process. Solution: use scratch space to + * copy the deletee pointer, then the latter references are via that + * scratch pointer rather than through the repointed (users) symbol. + */ +#define HASH_DELETE(hh,head,delptr) \ +do { \ + unsigned _hd_bkt; \ + struct UT_hash_handle *_hd_hh_del; \ + if ( ((delptr)->hh.prev == NULL) && ((delptr)->hh.next == NULL) ) { \ + uthash_free((head)->hh.tbl->buckets, \ + (head)->hh.tbl->num_buckets*sizeof(struct UT_hash_bucket) ); \ + HASH_BLOOM_FREE((head)->hh.tbl); \ + uthash_free((head)->hh.tbl, sizeof(UT_hash_table)); \ + head = NULL; \ + } else { \ + _hd_hh_del = &((delptr)->hh); \ + if ((delptr) == ELMT_FROM_HH((head)->hh.tbl,(head)->hh.tbl->tail)) { \ + (head)->hh.tbl->tail = \ + (UT_hash_handle*)((char*)((delptr)->hh.prev) + \ + (head)->hh.tbl->hho); \ + } \ + if ((delptr)->hh.prev) { \ + ((UT_hash_handle*)((char*)((delptr)->hh.prev) + \ + (head)->hh.tbl->hho))->next = (delptr)->hh.next; \ + } else { \ + DECLTYPE_ASSIGN(head,(delptr)->hh.next); \ + } \ + if (_hd_hh_del->next) { \ + ((UT_hash_handle*)((char*)_hd_hh_del->next + \ + (head)->hh.tbl->hho))->prev = \ + _hd_hh_del->prev; \ + } \ + HASH_TO_BKT( _hd_hh_del->hashv, (head)->hh.tbl->num_buckets, _hd_bkt); \ + HASH_DEL_IN_BKT(hh,(head)->hh.tbl->buckets[_hd_bkt], _hd_hh_del); \ + (head)->hh.tbl->num_items--; \ + } \ + HASH_FSCK(hh,head); \ +} while (0) + + +/* convenience forms of HASH_FIND/HASH_ADD/HASH_DEL */ +#define HASH_FIND_STR(head,findstr,out) \ + HASH_FIND(hh,head,findstr,strlen(findstr),out) +#define HASH_ADD_STR(head,strfield,add) \ + HASH_ADD(hh,head,strfield,strlen(add->strfield),add) +#define HASH_FIND_INT(head,findint,out) \ + HASH_FIND(hh,head,findint,sizeof(int),out) +#define HASH_ADD_INT(head,intfield,add) \ + HASH_ADD(hh,head,intfield,sizeof(int),add) +#define HASH_FIND_PTR(head,findptr,out) \ + HASH_FIND(hh,head,findptr,sizeof(void *),out) +#define HASH_ADD_PTR(head,ptrfield,add) \ + HASH_ADD(hh,head,ptrfield,sizeof(void *),add) +#define HASH_DEL(head,delptr) \ + HASH_DELETE(hh,head,delptr) + +/* HASH_FSCK checks hash integrity on every add/delete when HASH_DEBUG is defined. + * This is for uthash developer only; it compiles away if HASH_DEBUG isn't defined. + */ +#ifdef HASH_DEBUG +#define HASH_OOPS(...) do { fprintf(stderr,__VA_ARGS__); exit(-1); } while (0) +#define HASH_FSCK(hh,head) \ +do { \ + unsigned _bkt_i; \ + unsigned _count, _bkt_count; \ + char *_prev; \ + struct UT_hash_handle *_thh; \ + if (head) { \ + _count = 0; \ + for( _bkt_i = 0; _bkt_i < (head)->hh.tbl->num_buckets; _bkt_i++) { \ + _bkt_count = 0; \ + _thh = (head)->hh.tbl->buckets[_bkt_i].hh_head; \ + _prev = NULL; \ + while (_thh) { \ + if (_prev != (char*)(_thh->hh_prev)) { \ + HASH_OOPS("invalid hh_prev %p, actual %p\n", \ + _thh->hh_prev, _prev ); \ + } \ + _bkt_count++; \ + _prev = (char*)(_thh); \ + _thh = _thh->hh_next; \ + } \ + _count += _bkt_count; \ + if ((head)->hh.tbl->buckets[_bkt_i].count != _bkt_count) { \ + HASH_OOPS("invalid bucket count %d, actual %d\n", \ + (head)->hh.tbl->buckets[_bkt_i].count, _bkt_count); \ + } \ + } \ + if (_count != (head)->hh.tbl->num_items) { \ + HASH_OOPS("invalid hh item count %d, actual %d\n", \ + (head)->hh.tbl->num_items, _count ); \ + } \ + /* traverse hh in app order; check next/prev integrity, count */ \ + _count = 0; \ + _prev = NULL; \ + _thh = &(head)->hh; \ + while (_thh) { \ + _count++; \ + if (_prev !=(char*)(_thh->prev)) { \ + HASH_OOPS("invalid prev %p, actual %p\n", \ + _thh->prev, _prev ); \ + } \ + _prev = (char*)ELMT_FROM_HH((head)->hh.tbl, _thh); \ + _thh = ( _thh->next ? (UT_hash_handle*)((char*)(_thh->next) + \ + (head)->hh.tbl->hho) : NULL ); \ + } \ + if (_count != (head)->hh.tbl->num_items) { \ + HASH_OOPS("invalid app item count %d, actual %d\n", \ + (head)->hh.tbl->num_items, _count ); \ + } \ + } \ +} while (0) +#else +#define HASH_FSCK(hh,head) +#endif + +/* When compiled with -DHASH_EMIT_KEYS, length-prefixed keys are emitted to + * the descriptor to which this macro is defined for tuning the hash function. + * The app can #include to get the prototype for write(2). */ +#ifdef HASH_EMIT_KEYS +#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) \ +do { \ + unsigned _klen = fieldlen; \ + write(HASH_EMIT_KEYS, &_klen, sizeof(_klen)); \ + write(HASH_EMIT_KEYS, keyptr, fieldlen); \ +} while (0) +#else +#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) +#endif + +/* default to Jenkin's hash unless overridden e.g. DHASH_FUNCTION=HASH_SAX */ +#ifdef HASH_FUNCTION +#define HASH_FCN HASH_FUNCTION +#else +#define HASH_FCN HASH_JEN +#endif + +/* The Bernstein hash function, used in Perl prior to v5.6 */ +#define HASH_BER(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _hb_keylen=keylen; \ + char *_hb_key=(char*)(key); \ + (hashv) = 0; \ + while (_hb_keylen--) { (hashv) = ((hashv) * 33) + *_hb_key++; } \ + bkt = (hashv) & (num_bkts-1); \ +} while (0) + + +/* SAX/FNV/OAT/JEN hash functions are macro variants of those listed at + * http://eternallyconfuzzled.com/tuts/algorithms/jsw_tut_hashing.aspx */ +#define HASH_SAX(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _sx_i; \ + char *_hs_key=(char*)(key); \ + hashv = 0; \ + for(_sx_i=0; _sx_i < keylen; _sx_i++) \ + hashv ^= (hashv << 5) + (hashv >> 2) + _hs_key[_sx_i]; \ + bkt = hashv & (num_bkts-1); \ +} while (0) + +#define HASH_FNV(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _fn_i; \ + char *_hf_key=(char*)(key); \ + hashv = 2166136261UL; \ + for(_fn_i=0; _fn_i < keylen; _fn_i++) \ + hashv = (hashv * 16777619) ^ _hf_key[_fn_i]; \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +#define HASH_OAT(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _ho_i; \ + char *_ho_key=(char*)(key); \ + hashv = 0; \ + for(_ho_i=0; _ho_i < keylen; _ho_i++) { \ + hashv += _ho_key[_ho_i]; \ + hashv += (hashv << 10); \ + hashv ^= (hashv >> 6); \ + } \ + hashv += (hashv << 3); \ + hashv ^= (hashv >> 11); \ + hashv += (hashv << 15); \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +#define HASH_JEN_MIX(a,b,c) \ +do { \ + a -= b; a -= c; a ^= ( c >> 13 ); \ + b -= c; b -= a; b ^= ( a << 8 ); \ + c -= a; c -= b; c ^= ( b >> 13 ); \ + a -= b; a -= c; a ^= ( c >> 12 ); \ + b -= c; b -= a; b ^= ( a << 16 ); \ + c -= a; c -= b; c ^= ( b >> 5 ); \ + a -= b; a -= c; a ^= ( c >> 3 ); \ + b -= c; b -= a; b ^= ( a << 10 ); \ + c -= a; c -= b; c ^= ( b >> 15 ); \ +} while (0) + +#define HASH_JEN(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _hj_i,_hj_j,_hj_k; \ + char *_hj_key=(char*)(key); \ + hashv = 0xfeedbeef; \ + _hj_i = _hj_j = 0x9e3779b9; \ + _hj_k = (unsigned)keylen; \ + while (_hj_k >= 12) { \ + _hj_i += (_hj_key[0] + ( (unsigned)_hj_key[1] << 8 ) \ + + ( (unsigned)_hj_key[2] << 16 ) \ + + ( (unsigned)_hj_key[3] << 24 ) ); \ + _hj_j += (_hj_key[4] + ( (unsigned)_hj_key[5] << 8 ) \ + + ( (unsigned)_hj_key[6] << 16 ) \ + + ( (unsigned)_hj_key[7] << 24 ) ); \ + hashv += (_hj_key[8] + ( (unsigned)_hj_key[9] << 8 ) \ + + ( (unsigned)_hj_key[10] << 16 ) \ + + ( (unsigned)_hj_key[11] << 24 ) ); \ + \ + HASH_JEN_MIX(_hj_i, _hj_j, hashv); \ + \ + _hj_key += 12; \ + _hj_k -= 12; \ + } \ + hashv += keylen; \ + switch ( _hj_k ) { \ + case 11: hashv += ( (unsigned)_hj_key[10] << 24 ); \ + case 10: hashv += ( (unsigned)_hj_key[9] << 16 ); \ + case 9: hashv += ( (unsigned)_hj_key[8] << 8 ); \ + case 8: _hj_j += ( (unsigned)_hj_key[7] << 24 ); \ + case 7: _hj_j += ( (unsigned)_hj_key[6] << 16 ); \ + case 6: _hj_j += ( (unsigned)_hj_key[5] << 8 ); \ + case 5: _hj_j += _hj_key[4]; \ + case 4: _hj_i += ( (unsigned)_hj_key[3] << 24 ); \ + case 3: _hj_i += ( (unsigned)_hj_key[2] << 16 ); \ + case 2: _hj_i += ( (unsigned)_hj_key[1] << 8 ); \ + case 1: _hj_i += _hj_key[0]; \ + } \ + HASH_JEN_MIX(_hj_i, _hj_j, hashv); \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +/* The Paul Hsieh hash function */ +#undef get16bits +#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \ + || defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__) +#define get16bits(d) (*((const uint16_t *) (d))) +#endif + +#if !defined (get16bits) +#define get16bits(d) ((((uint32_t)(((const uint8_t *)(d))[1])) << 8) \ + +(uint32_t)(((const uint8_t *)(d))[0]) ) +#endif +#define HASH_SFH(key,keylen,num_bkts,hashv,bkt) \ +do { \ + char *_sfh_key=(char*)(key); \ + uint32_t _sfh_tmp, _sfh_len = keylen; \ + \ + int _sfh_rem = _sfh_len & 3; \ + _sfh_len >>= 2; \ + hashv = 0xcafebabe; \ + \ + /* Main loop */ \ + for (;_sfh_len > 0; _sfh_len--) { \ + hashv += get16bits (_sfh_key); \ + _sfh_tmp = (get16bits (_sfh_key+2) << 11) ^ hashv; \ + hashv = (hashv << 16) ^ _sfh_tmp; \ + _sfh_key += 2*sizeof (uint16_t); \ + hashv += hashv >> 11; \ + } \ + \ + /* Handle end cases */ \ + switch (_sfh_rem) { \ + case 3: hashv += get16bits (_sfh_key); \ + hashv ^= hashv << 16; \ + hashv ^= _sfh_key[sizeof (uint16_t)] << 18; \ + hashv += hashv >> 11; \ + break; \ + case 2: hashv += get16bits (_sfh_key); \ + hashv ^= hashv << 11; \ + hashv += hashv >> 17; \ + break; \ + case 1: hashv += *_sfh_key; \ + hashv ^= hashv << 10; \ + hashv += hashv >> 1; \ + } \ + \ + /* Force "avalanching" of final 127 bits */ \ + hashv ^= hashv << 3; \ + hashv += hashv >> 5; \ + hashv ^= hashv << 4; \ + hashv += hashv >> 17; \ + hashv ^= hashv << 25; \ + hashv += hashv >> 6; \ + bkt = hashv & (num_bkts-1); \ +} while(0) + +#ifdef HASH_USING_NO_STRICT_ALIASING +/* The MurmurHash exploits some CPU's (x86,x86_64) tolerance for unaligned reads. + * For other types of CPU's (e.g. Sparc) an unaligned read causes a bus error. + * MurmurHash uses the faster approach only on CPU's where we know it's safe. + * + * Note the preprocessor built-in defines can be emitted using: + * + * gcc -m64 -dM -E - < /dev/null (on gcc) + * cc -## a.c (where a.c is a simple test file) (Sun Studio) + */ +#if (defined(__i386__) || defined(__x86_64__)) +#define MUR_GETBLOCK(p,i) p[i] +#else /* non intel */ +#define MUR_PLUS0_ALIGNED(p) (((unsigned long)p & 0x3) == 0) +#define MUR_PLUS1_ALIGNED(p) (((unsigned long)p & 0x3) == 1) +#define MUR_PLUS2_ALIGNED(p) (((unsigned long)p & 0x3) == 2) +#define MUR_PLUS3_ALIGNED(p) (((unsigned long)p & 0x3) == 3) +#define WP(p) ((uint32_t*)((unsigned long)(p) & ~3UL)) +#if (defined(__BIG_ENDIAN__) || defined(SPARC) || defined(__ppc__) || defined(__ppc64__)) +#define MUR_THREE_ONE(p) ((((*WP(p))&0x00ffffff) << 8) | (((*(WP(p)+1))&0xff000000) >> 24)) +#define MUR_TWO_TWO(p) ((((*WP(p))&0x0000ffff) <<16) | (((*(WP(p)+1))&0xffff0000) >> 16)) +#define MUR_ONE_THREE(p) ((((*WP(p))&0x000000ff) <<24) | (((*(WP(p)+1))&0xffffff00) >> 8)) +#else /* assume little endian non-intel */ +#define MUR_THREE_ONE(p) ((((*WP(p))&0xffffff00) >> 8) | (((*(WP(p)+1))&0x000000ff) << 24)) +#define MUR_TWO_TWO(p) ((((*WP(p))&0xffff0000) >>16) | (((*(WP(p)+1))&0x0000ffff) << 16)) +#define MUR_ONE_THREE(p) ((((*WP(p))&0xff000000) >>24) | (((*(WP(p)+1))&0x00ffffff) << 8)) +#endif +#define MUR_GETBLOCK(p,i) (MUR_PLUS0_ALIGNED(p) ? ((p)[i]) : \ + (MUR_PLUS1_ALIGNED(p) ? MUR_THREE_ONE(p) : \ + (MUR_PLUS2_ALIGNED(p) ? MUR_TWO_TWO(p) : \ + MUR_ONE_THREE(p)))) +#endif +#define MUR_ROTL32(x,r) (((x) << (r)) | ((x) >> (32 - (r)))) +#define MUR_FMIX(_h) \ +do { \ + _h ^= _h >> 16; \ + _h *= 0x85ebca6b; \ + _h ^= _h >> 13; \ + _h *= 0xc2b2ae35l; \ + _h ^= _h >> 16; \ +} while(0) + +#define HASH_MUR(key,keylen,num_bkts,hashv,bkt) \ +do { \ + const uint8_t *_mur_data = (const uint8_t*)(key); \ + const int _mur_nblocks = (keylen) / 4; \ + uint32_t _mur_h1 = 0xf88D5353; \ + uint32_t _mur_c1 = 0xcc9e2d51; \ + uint32_t _mur_c2 = 0x1b873593; \ + const uint32_t *_mur_blocks = (const uint32_t*)(_mur_data+_mur_nblocks*4); \ + int _mur_i; \ + for(_mur_i = -_mur_nblocks; _mur_i; _mur_i++) { \ + uint32_t _mur_k1 = MUR_GETBLOCK(_mur_blocks,_mur_i); \ + _mur_k1 *= _mur_c1; \ + _mur_k1 = MUR_ROTL32(_mur_k1,15); \ + _mur_k1 *= _mur_c2; \ + \ + _mur_h1 ^= _mur_k1; \ + _mur_h1 = MUR_ROTL32(_mur_h1,13); \ + _mur_h1 = _mur_h1*5+0xe6546b64; \ + } \ + const uint8_t *_mur_tail = (const uint8_t*)(_mur_data + _mur_nblocks*4); \ + uint32_t _mur_k1=0; \ + switch((keylen) & 3) { \ + case 3: _mur_k1 ^= _mur_tail[2] << 16; \ + case 2: _mur_k1 ^= _mur_tail[1] << 8; \ + case 1: _mur_k1 ^= _mur_tail[0]; \ + _mur_k1 *= _mur_c1; \ + _mur_k1 = MUR_ROTL32(_mur_k1,15); \ + _mur_k1 *= _mur_c2; \ + _mur_h1 ^= _mur_k1; \ + } \ + _mur_h1 ^= (keylen); \ + MUR_FMIX(_mur_h1); \ + hashv = _mur_h1; \ + bkt = hashv & (num_bkts-1); \ +} while(0) +#endif /* HASH_USING_NO_STRICT_ALIASING */ + +/* key comparison function; return 0 if keys equal */ +#define HASH_KEYCMP(a,b,len) memcmp(a,b,len) + +/* iterate over items in a known bucket to find desired item */ +#define HASH_FIND_IN_BKT(tbl,hh,head,keyptr,keylen_in,out) \ +do { \ + if (head.hh_head) DECLTYPE_ASSIGN(out,ELMT_FROM_HH(tbl,head.hh_head)); \ + else out=NULL; \ + while (out) { \ + if ((out)->hh.keylen == keylen_in) { \ + if ((HASH_KEYCMP((out)->hh.key,keyptr,keylen_in)) == 0) break; \ + } \ + if ((out)->hh.hh_next) DECLTYPE_ASSIGN(out,ELMT_FROM_HH(tbl,(out)->hh.hh_next)); \ + else out = NULL; \ + } \ +} while(0) + +/* add an item to a bucket */ +#define HASH_ADD_TO_BKT(head,addhh) \ +do { \ + head.count++; \ + (addhh)->hh_next = head.hh_head; \ + (addhh)->hh_prev = NULL; \ + if (head.hh_head) { (head).hh_head->hh_prev = (addhh); } \ + (head).hh_head=addhh; \ + if (head.count >= ((head.expand_mult+1) * HASH_BKT_CAPACITY_THRESH) \ + && (addhh)->tbl->noexpand != 1) { \ + HASH_EXPAND_BUCKETS((addhh)->tbl); \ + } \ +} while(0) + +/* remove an item from a given bucket */ +#define HASH_DEL_IN_BKT(hh,head,hh_del) \ + (head).count--; \ + if ((head).hh_head == hh_del) { \ + (head).hh_head = hh_del->hh_next; \ + } \ + if (hh_del->hh_prev) { \ + hh_del->hh_prev->hh_next = hh_del->hh_next; \ + } \ + if (hh_del->hh_next) { \ + hh_del->hh_next->hh_prev = hh_del->hh_prev; \ + } + +/* Bucket expansion has the effect of doubling the number of buckets + * and redistributing the items into the new buckets. Ideally the + * items will distribute more or less evenly into the new buckets + * (the extent to which this is true is a measure of the quality of + * the hash function as it applies to the key domain). + * + * With the items distributed into more buckets, the chain length + * (item count) in each bucket is reduced. Thus by expanding buckets + * the hash keeps a bound on the chain length. This bounded chain + * length is the essence of how a hash provides constant time lookup. + * + * The calculation of tbl->ideal_chain_maxlen below deserves some + * explanation. First, keep in mind that we're calculating the ideal + * maximum chain length based on the *new* (doubled) bucket count. + * In fractions this is just n/b (n=number of items,b=new num buckets). + * Since the ideal chain length is an integer, we want to calculate + * ceil(n/b). We don't depend on floating point arithmetic in this + * hash, so to calculate ceil(n/b) with integers we could write + * + * ceil(n/b) = (n/b) + ((n%b)?1:0) + * + * and in fact a previous version of this hash did just that. + * But now we have improved things a bit by recognizing that b is + * always a power of two. We keep its base 2 log handy (call it lb), + * so now we can write this with a bit shift and logical AND: + * + * ceil(n/b) = (n>>lb) + ( (n & (b-1)) ? 1:0) + * + */ +#define HASH_EXPAND_BUCKETS(tbl) \ +do { \ + unsigned _he_bkt; \ + unsigned _he_bkt_i; \ + struct UT_hash_handle *_he_thh, *_he_hh_nxt; \ + UT_hash_bucket *_he_new_buckets, *_he_newbkt; \ + _he_new_buckets = (UT_hash_bucket*)uthash_malloc( \ + 2 * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \ + if (!_he_new_buckets) { uthash_fatal( "out of memory"); } \ + memset(_he_new_buckets, 0, \ + 2 * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \ + tbl->ideal_chain_maxlen = \ + (tbl->num_items >> (tbl->log2_num_buckets+1)) + \ + ((tbl->num_items & ((tbl->num_buckets*2)-1)) ? 1 : 0); \ + tbl->nonideal_items = 0; \ + for(_he_bkt_i = 0; _he_bkt_i < tbl->num_buckets; _he_bkt_i++) \ + { \ + _he_thh = tbl->buckets[ _he_bkt_i ].hh_head; \ + while (_he_thh) { \ + _he_hh_nxt = _he_thh->hh_next; \ + HASH_TO_BKT( _he_thh->hashv, tbl->num_buckets*2, _he_bkt); \ + _he_newbkt = &(_he_new_buckets[ _he_bkt ]); \ + if (++(_he_newbkt->count) > tbl->ideal_chain_maxlen) { \ + tbl->nonideal_items++; \ + _he_newbkt->expand_mult = _he_newbkt->count / \ + tbl->ideal_chain_maxlen; \ + } \ + _he_thh->hh_prev = NULL; \ + _he_thh->hh_next = _he_newbkt->hh_head; \ + if (_he_newbkt->hh_head) _he_newbkt->hh_head->hh_prev = \ + _he_thh; \ + _he_newbkt->hh_head = _he_thh; \ + _he_thh = _he_hh_nxt; \ + } \ + } \ + uthash_free( tbl->buckets, tbl->num_buckets*sizeof(struct UT_hash_bucket) ); \ + tbl->num_buckets *= 2; \ + tbl->log2_num_buckets++; \ + tbl->buckets = _he_new_buckets; \ + tbl->ineff_expands = (tbl->nonideal_items > (tbl->num_items >> 1)) ? \ + (tbl->ineff_expands+1) : 0; \ + if (tbl->ineff_expands > 1) { \ + tbl->noexpand=1; \ + uthash_noexpand_fyi(tbl); \ + } \ + uthash_expand_fyi(tbl); \ +} while(0) + + +/* This is an adaptation of Simon Tatham's O(n log(n)) mergesort */ +/* Note that HASH_SORT assumes the hash handle name to be hh. + * HASH_SRT was added to allow the hash handle name to be passed in. */ +#define HASH_SORT(head,cmpfcn) HASH_SRT(hh,head,cmpfcn) +#define HASH_SRT(hh,head,cmpfcn) \ +do { \ + unsigned _hs_i; \ + unsigned _hs_looping,_hs_nmerges,_hs_insize,_hs_psize,_hs_qsize; \ + struct UT_hash_handle *_hs_p, *_hs_q, *_hs_e, *_hs_list, *_hs_tail; \ + if (head) { \ + _hs_insize = 1; \ + _hs_looping = 1; \ + _hs_list = &((head)->hh); \ + while (_hs_looping) { \ + _hs_p = _hs_list; \ + _hs_list = NULL; \ + _hs_tail = NULL; \ + _hs_nmerges = 0; \ + while (_hs_p) { \ + _hs_nmerges++; \ + _hs_q = _hs_p; \ + _hs_psize = 0; \ + for ( _hs_i = 0; _hs_i < _hs_insize; _hs_i++ ) { \ + _hs_psize++; \ + _hs_q = (UT_hash_handle*)((_hs_q->next) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + if (! (_hs_q) ) break; \ + } \ + _hs_qsize = _hs_insize; \ + while ((_hs_psize > 0) || ((_hs_qsize > 0) && _hs_q )) { \ + if (_hs_psize == 0) { \ + _hs_e = _hs_q; \ + _hs_q = (UT_hash_handle*)((_hs_q->next) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_qsize--; \ + } else if ( (_hs_qsize == 0) || !(_hs_q) ) { \ + _hs_e = _hs_p; \ + _hs_p = (UT_hash_handle*)((_hs_p->next) ? \ + ((void*)((char*)(_hs_p->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_psize--; \ + } else if (( \ + cmpfcn(DECLTYPE(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_p)), \ + DECLTYPE(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_q))) \ + ) <= 0) { \ + _hs_e = _hs_p; \ + _hs_p = (UT_hash_handle*)((_hs_p->next) ? \ + ((void*)((char*)(_hs_p->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_psize--; \ + } else { \ + _hs_e = _hs_q; \ + _hs_q = (UT_hash_handle*)((_hs_q->next) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_qsize--; \ + } \ + if ( _hs_tail ) { \ + _hs_tail->next = ((_hs_e) ? \ + ELMT_FROM_HH((head)->hh.tbl,_hs_e) : NULL); \ + } else { \ + _hs_list = _hs_e; \ + } \ + _hs_e->prev = ((_hs_tail) ? \ + ELMT_FROM_HH((head)->hh.tbl,_hs_tail) : NULL); \ + _hs_tail = _hs_e; \ + } \ + _hs_p = _hs_q; \ + } \ + _hs_tail->next = NULL; \ + if ( _hs_nmerges <= 1 ) { \ + _hs_looping=0; \ + (head)->hh.tbl->tail = _hs_tail; \ + DECLTYPE_ASSIGN(head,ELMT_FROM_HH((head)->hh.tbl, _hs_list)); \ + } \ + _hs_insize *= 2; \ + } \ + HASH_FSCK(hh,head); \ + } \ +} while (0) + +/* This function selects items from one hash into another hash. + * The end result is that the selected items have dual presence + * in both hashes. There is no copy of the items made; rather + * they are added into the new hash through a secondary hash + * hash handle that must be present in the structure. */ +#define HASH_SELECT(hh_dst, dst, hh_src, src, cond) \ +do { \ + unsigned _src_bkt, _dst_bkt; \ + void *_last_elt=NULL, *_elt; \ + UT_hash_handle *_src_hh, *_dst_hh, *_last_elt_hh=NULL; \ + ptrdiff_t _dst_hho = ((char*)(&(dst)->hh_dst) - (char*)(dst)); \ + if (src) { \ + for(_src_bkt=0; _src_bkt < (src)->hh_src.tbl->num_buckets; _src_bkt++) { \ + for(_src_hh = (src)->hh_src.tbl->buckets[_src_bkt].hh_head; \ + _src_hh; \ + _src_hh = _src_hh->hh_next) { \ + _elt = ELMT_FROM_HH((src)->hh_src.tbl, _src_hh); \ + if (cond(_elt)) { \ + _dst_hh = (UT_hash_handle*)(((char*)_elt) + _dst_hho); \ + _dst_hh->key = _src_hh->key; \ + _dst_hh->keylen = _src_hh->keylen; \ + _dst_hh->hashv = _src_hh->hashv; \ + _dst_hh->prev = _last_elt; \ + _dst_hh->next = NULL; \ + if (_last_elt_hh) { _last_elt_hh->next = _elt; } \ + if (!dst) { \ + DECLTYPE_ASSIGN(dst,_elt); \ + HASH_MAKE_TABLE(hh_dst,dst); \ + } else { \ + _dst_hh->tbl = (dst)->hh_dst.tbl; \ + } \ + HASH_TO_BKT(_dst_hh->hashv, _dst_hh->tbl->num_buckets, _dst_bkt); \ + HASH_ADD_TO_BKT(_dst_hh->tbl->buckets[_dst_bkt],_dst_hh); \ + (dst)->hh_dst.tbl->num_items++; \ + _last_elt = _elt; \ + _last_elt_hh = _dst_hh; \ + } \ + } \ + } \ + } \ + HASH_FSCK(hh_dst,dst); \ +} while (0) + +#define HASH_CLEAR(hh,head) \ +do { \ + if (head) { \ + uthash_free((head)->hh.tbl->buckets, \ + (head)->hh.tbl->num_buckets*sizeof(struct UT_hash_bucket)); \ + HASH_BLOOM_FREE((head)->hh.tbl); \ + uthash_free((head)->hh.tbl, sizeof(UT_hash_table)); \ + (head)=NULL; \ + } \ +} while(0) + +#ifdef NO_DECLTYPE +#define HASH_ITER(hh,head,el,tmp) \ +for((el)=(head), (*(char**)(&(tmp)))=(char*)((head)?(head)->hh.next:NULL); \ + el; (el)=(tmp),(*(char**)(&(tmp)))=(char*)((tmp)?(tmp)->hh.next:NULL)) +#else +#define HASH_ITER(hh,head,el,tmp) \ +for((el)=(head),(tmp)=DECLTYPE(el)((head)?(head)->hh.next:NULL); \ + el; (el)=(tmp),(tmp)=DECLTYPE(el)((tmp)?(tmp)->hh.next:NULL)) +#endif + +/* obtain a count of items in the hash */ +#define HASH_COUNT(head) HASH_CNT(hh,head) +#define HASH_CNT(hh,head) ((head)?((head)->hh.tbl->num_items):0) + +typedef struct UT_hash_bucket { + struct UT_hash_handle *hh_head; + unsigned count; + + /* expand_mult is normally set to 0. In this situation, the max chain length + * threshold is enforced at its default value, HASH_BKT_CAPACITY_THRESH. (If + * the bucket's chain exceeds this length, bucket expansion is triggered). + * However, setting expand_mult to a non-zero value delays bucket expansion + * (that would be triggered by additions to this particular bucket) + * until its chain length reaches a *multiple* of HASH_BKT_CAPACITY_THRESH. + * (The multiplier is simply expand_mult+1). The whole idea of this + * multiplier is to reduce bucket expansions, since they are expensive, in + * situations where we know that a particular bucket tends to be overused. + * It is better to let its chain length grow to a longer yet-still-bounded + * value, than to do an O(n) bucket expansion too often. + */ + unsigned expand_mult; + +} UT_hash_bucket; + +/* random signature used only to find hash tables in external analysis */ +#define HASH_SIGNATURE 0xa0111fe1 +#define HASH_BLOOM_SIGNATURE 0xb12220f2 + +typedef struct UT_hash_table { + UT_hash_bucket *buckets; + unsigned num_buckets, log2_num_buckets; + unsigned num_items; + struct UT_hash_handle *tail; /* tail hh in app order, for fast append */ + ptrdiff_t hho; /* hash handle offset (byte pos of hash handle in element */ + + /* in an ideal situation (all buckets used equally), no bucket would have + * more than ceil(#items/#buckets) items. that's the ideal chain length. */ + unsigned ideal_chain_maxlen; + + /* nonideal_items is the number of items in the hash whose chain position + * exceeds the ideal chain maxlen. these items pay the penalty for an uneven + * hash distribution; reaching them in a chain traversal takes >ideal steps */ + unsigned nonideal_items; + + /* ineffective expands occur when a bucket doubling was performed, but + * afterward, more than half the items in the hash had nonideal chain + * positions. If this happens on two consecutive expansions we inhibit any + * further expansion, as it's not helping; this happens when the hash + * function isn't a good fit for the key domain. When expansion is inhibited + * the hash will still work, albeit no longer in constant time. */ + unsigned ineff_expands, noexpand; + + uint32_t signature; /* used only to find hash tables in external analysis */ +#ifdef HASH_BLOOM + uint32_t bloom_sig; /* used only to test bloom exists in external analysis */ + uint8_t *bloom_bv; + char bloom_nbits; +#endif + +} UT_hash_table; + +typedef struct UT_hash_handle { + struct UT_hash_table *tbl; + void *prev; /* prev element in app order */ + void *next; /* next element in app order */ + struct UT_hash_handle *hh_prev; /* previous hh in bucket order */ + struct UT_hash_handle *hh_next; /* next hh in bucket order */ + void *key; /* ptr to enclosing struct's key */ + unsigned keylen; /* enclosing struct's key len */ + unsigned hashv; /* result of hash-fcn(key) */ +} UT_hash_handle; + +#endif /* UTHASH_H */ diff --git a/packages/udi/uthash/uthash.yap b/packages/udi/uthash/uthash.yap new file mode 100644 index 000000000..f44e1d731 --- /dev/null +++ b/packages/udi/uthash/uthash.yap @@ -0,0 +1 @@ +:- load_foreign_files(['libudi_uthash'],[],udi_uthash_init). diff --git a/packages/udi/uthash/uthash_udi.c b/packages/udi/uthash/uthash_udi.c new file mode 100644 index 000000000..23800fabf --- /dev/null +++ b/packages/udi/uthash/uthash_udi.c @@ -0,0 +1,101 @@ +#include +#include + +#include "uthash_udi.h" +#include "uthash_udi_private.h" + +static struct udi_control_block UTHashCB; + +void udi_uthash_init(void) { + UdiControlBlock cb = &UTHashCB; + + memset((void *) cb,0, sizeof(*cb)); + + cb->decl=YAP_LookupAtom(SPEC); + + cb->init=UTHashUdiInit; + cb->insert=UTHashUdiInsert; + cb->search=UTHashUdiSearch; + cb->destroy=UTHashUdiDestroy; + + Yap_UdiRegister(cb); +} + +void *UTHashUdiInit (YAP_Term spec, int arg, int arity) { + return NULL; /*empty uthash*/ +} + +void *UTHashUdiInsert (void *control, + YAP_Term term, int arg, void *data) +{ + uthash_t hash = (uthash_t) control; + YAP_Term argterm; + uthash_t element; + +// Yap_DebugPlWrite(term); fprintf(stderr, "\n"); + argterm = YAP_ArgOfTerm(arg,term); + + if (YAP_IsAtomTerm(argterm) || YAP_IsIntTerm(argterm)) + { + element = (uthash_t) malloc(sizeof(*element)); + element->data = data; + if (YAP_IsAtomTerm(argterm)) + element->key.atom = YAP_AtomOfTerm(argterm); + else + element->key.integer = YAP_IntOfTerm(argterm); + + HASH_ADD_AI(hash, element); + } + + /*TODO: check how to handle if a different value appears*/ + return (void *) hash; +} + +/*ARGS ARE AVAILABLE*/ +int UTHashUdiSearch (void *control, + int arg, Yap_UdiCallback callback, void *args) +{ + YAP_Term argterm; + YAP_Atom atom; + uthash_t element; + uthash_t hash = (uthash_t) control; + int count = 0; + union AI ai; + + assert(hash); + + argterm = YAP_A(arg); /*Deref(XREGS[arg]); */ + + if (YAP_IsAtomTerm(argterm) || YAP_IsIntTerm(argterm)) + { + if (YAP_IsAtomTerm(argterm)) + ai.atom = YAP_AtomOfTerm(argterm); + else + ai.integer = YAP_IntOfTerm(argterm); + + HASH_FIND_AI(hash,&ai,element); + /* HASH_FIND(hh,utcontrol->tree,&atom,sizeof(Atom),element); */ + while (element) + { + callback((void *) &(element->key), element->data, args); + count ++; + HASH_FIND_NEXT_AI(element,&ai); + } +// fprintf(stderr,"found %d\n",count); + return (count); + } +// fprintf(stderr,"not found\n"); + return -1; /*YAP FALLBACK*/ +} + +int UTHashUdiDestroy(void *control) +{ + uthash_t hash = (uthash_t) control; + + assert(hash); + + if (hash) + HASH_CLEAR(hh,hash); /* TODO: check if this is enough */ + + return TRUE; +} diff --git a/packages/udi/uthash/uthash_udi.h b/packages/udi/uthash/uthash_udi.h new file mode 100644 index 000000000..f6bd562d8 --- /dev/null +++ b/packages/udi/uthash/uthash_udi.h @@ -0,0 +1,24 @@ +#ifndef _UTHASH_UDI_ +#define _UTHASH_UDI_ + +#include +#include +#include "uthash.h" + +#define SPEC "#" +/*Prolog term from :- udi(a(#,-)).*/ + +extern void *UTHashUdiInit + (YAP_Term spec, int arg, int arity); + +extern void *UTHashUdiInsert + (void *control, YAP_Term term, int arg, void *data); + +extern int UTHashUdiSearch + (void *control, int arg, Yap_UdiCallback callback, void *args); + +extern int UTHashUdiDestroy(void *control); + +void udi_uthash_init(void); + +#endif /* _UTHASH_UDI_ */ diff --git a/packages/udi/uthash/uthash_udi_private.h b/packages/udi/uthash/uthash_udi_private.h new file mode 100644 index 000000000..63ef8f92b --- /dev/null +++ b/packages/udi/uthash/uthash_udi_private.h @@ -0,0 +1,47 @@ +#ifndef _UTHASH_UDI_PRIVATE_ +#define _UTHASH_UDI_PRIVATE_ + +#include "uthash.h" + +union AI { + YAP_Atom atom; + YAP_Int integer; +}; + +struct UTHash +{ + union AI key; + void *data; + UT_hash_handle hh; +}; +typedef struct UTHash *uthash_t; + +/* + Used to Iterate over equal keys in hash table +*/ +#define HASH_FIND_NEXT(hh,last,keyptr,keylen_in) \ + do { \ + if (last->hh.hh_next) \ + DECLTYPE_ASSIGN(last,ELMT_FROM_HH(last->hh.tbl,last->hh.hh_next)); \ + else last = NULL; \ + while (last) { \ + if (last->hh.keylen == keylen_in) { \ + if ((HASH_KEYCMP(last->hh.key,keyptr,keylen_in)) == 0) { \ + break; \ + } \ + } \ + if (last->hh.hh_next) \ + DECLTYPE_ASSIGN(last,ELMT_FROM_HH(last->hh.tbl,last->hh.hh_next)); \ + else last = NULL; \ + } \ + } while (0) \ + +/* to ease code for a Atom hash table*/ +#define HASH_FIND_AI(head,find,out) \ + HASH_FIND(hh,head,find,sizeof(union AI),out) +#define HASH_ADD_AI(head,add) \ + HASH_ADD(hh,head,key,sizeof(union AI),add) +#define HASH_FIND_NEXT_AI(last,find) \ + HASH_FIND_NEXT(hh,last,find,sizeof(union AI)) + +#endif /* _UTHASH_UDI_PRIVATE_ */ diff --git a/packages/zlib b/packages/zlib deleted file mode 160000 index 322e89ade..000000000 --- a/packages/zlib +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 322e89ade522dfe43ff47d50c2a2767ae897120c