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

update package locations to a subdir packages

Browse Source
This commit is contained in:
Vitor Santos Costa 2009-02-16 12:23:29 +00:00
parent 495ff55868
commit 9c9444bece
151 changed files with 62955 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
packages/CLPBN/Makefile.in Normal file
View File

@ -0,0 +1,85 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share/Yap
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
CLPBN_TOP= $(srcdir)/clpbn.yap
CLPBN_SRCDIR = $(srcdir)/clpbn
CLPBN_LEARNING_SRCDIR = $(srcdir)/learning
CLPBN_EXDIR = $(srcdir)/clpbn/examples
CLPBN_PROGRAMS= \
$(CLPBN_SRCDIR)/aggregates.yap \
$(CLPBN_SRCDIR)/bnt.yap \
$(CLPBN_SRCDIR)/connected.yap \
$(CLPBN_SRCDIR)/discrete_utils.yap \
$(CLPBN_SRCDIR)/display.yap \
$(CLPBN_SRCDIR)/dists.yap \
$(CLPBN_SRCDIR)/evidence.yap \
$(CLPBN_SRCDIR)/gibbs.yap \
$(CLPBN_SRCDIR)/graphs.yap \
$(CLPBN_SRCDIR)/graphviz.yap \
$(CLPBN_SRCDIR)/hmm.yap \
$(CLPBN_SRCDIR)/jt.yap \
$(CLPBN_SRCDIR)/matrix_cpt_utils.yap \
$(CLPBN_SRCDIR)/table.yap \
$(CLPBN_SRCDIR)/topsort.yap \
$(CLPBN_SRCDIR)/utils.yap \
$(CLPBN_SRCDIR)/vel.yap \
$(CLPBN_SRCDIR)/viterbi.yap \
$(CLPBN_SRCDIR)/xbif.yap
CLPBN_LEARNING_PROGRAMS= \
$(CLPBN_LEARNING_SRCDIR)/aleph_parms.yap \
$(CLPBN_LEARNING_SRCDIR)/bnt_parms.yap \
$(CLPBN_LEARNING_SRCDIR)/em.yap \
$(CLPBN_LEARNING_SRCDIR)/learn_utils.yap \
$(CLPBN_LEARNING_SRCDIR)/mle.yap
CLPBN_SCHOOL_EXAMPLES= \
$(CLPBN_EXDIR)/School/README \
$(CLPBN_EXDIR)/School/evidence_128.yap \
$(CLPBN_EXDIR)/School/schema.yap \
$(CLPBN_EXDIR)/School/school_128.yap \
$(CLPBN_EXDIR)/School/school_32.yap \
$(CLPBN_EXDIR)/School/school_64.yap \
$(CLPBN_EXDIR)/School/tables.yap
CLPBN_EXAMPLES= \
$(CLPBN_EXDIR)/cg.yap \
$(CLPBN_EXDIR)/sprinkler.yap
install: $(CLBN_TOP) $(CLBN_PROGRAMS) $(CLPBN_PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/clpbn
mkdir -p $(DESTDIR)$(SHAREDIR)/clpbn/learning
mkdir -p $(DESTDIR)$(SHAREDIR)/clpbn/examples/School
for h in $(CLPBN_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done
for h in $(CLPBN_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/clpbn; done
for h in $(CLPBN_LEARNING_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/clpbn/learning; done
for h in $(CLPBN_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/clpbn/examples; done
for h in $(CLPBN_SCHOOL_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/clpbn/examples/School; done

397
packages/CLPBN/clpbn.yap Normal file
View File

@ -0,0 +1,397 @@
:- module(clpbn, [{}/1,
clpbn_flag/2,
set_clpbn_flag/2,
clpbn_flag/3,
clpbn_key/2,
clpbn_init_solver/4,
clpbn_run_solver/3,
clpbn_init_solver/5,
clpbn_run_solver/4]).
:- use_module(library(atts)).
:- use_module(library(lists)).
:- use_module(library(terms)).
:- op( 500, xfy, with).
%
% avoid the overhead of using goal_expansion/2.
%
:- multifile
user:term_expansion/2.
:- dynamic
user:term_expansion/2.
:- attribute key/1, dist/2, evidence/1, starter/0.
:- use_module('clpbn/vel',
[vel/3,
check_if_vel_done/1,
init_vel_solver/4,
run_vel_solver/3
]).
:- use_module('clpbn/jt',
[jt/3,
init_jt_solver/4,
run_jt_solver/3
]).
:- use_module('clpbn/bnt',
[do_bnt/3,
check_if_bnt_done/1
]).
:- use_module('clpbn/gibbs',
[gibbs/3,
check_if_gibbs_done/1,
init_gibbs_solver/4,
run_gibbs_solver/3
]).
:- use_module('clpbn/graphs',
[
clpbn2graph/1
]).
:- use_module('clpbn/dists',
[
dist/4,
get_dist/4,
get_evidence_position/3,
get_evidence_from_position/3
]).
:- use_module('clpbn/evidence',
[
store_evidence/1,
incorporate_evidence/2,
check_stored_evidence/2,
add_evidence/2
]).
:- use_module('clpbn/utils',
[
sort_vars_by_key/3
]).
:- use_module('clpbn/graphviz',
[clpbn2gviz/4]).
:- dynamic solver/1,output/1,use/1,suppress_attribute_display/1, parameter_softening/1, em_solver/1.
solver(vel).
em_solver(vel).
%output(xbif(user_error)).
%output(gviz(user_error)).
output(no).
suppress_attribute_display(false).
parameter_softening(m_estimate(10)).
clpbn_flag(Flag,Option) :-
clpbn_flag(Flag, Option, Option).
set_clpbn_flag(Flag,Option) :-
clpbn_flag(Flag, _, Option).
clpbn_flag(output,Before,After) :-
retract(output(Before)),
assert(output(After)).
clpbn_flag(solver,Before,After) :-
retract(solver(Before)),
assert(solver(After)).
clpbn_flag(em_solver,Before,After) :-
retract(em_solver(Before)),
assert(em_solver(After)).
clpbn_flag(bnt_solver,Before,After) :-
retract(bnt:bnt_solver(Before)),
assert(bnt:bnt_solver(After)).
clpbn_flag(bnt_path,Before,After) :-
retract(bnt:bnt_path(Before)),
assert(bnt:bnt_path(After)).
clpbn_flag(bnt_model,Before,After) :-
retract(bnt:bnt_model(Before)),
assert(bnt:bnt_model(After)).
clpbn_flag(suppress_attribute_display,Before,After) :-
retract(suppress_attribute_display(Before)),
assert(suppress_attribute_display(After)).
clpbn_flag(parameter_softening,Before,After) :-
retract(parameter_softening(Before)),
assert(parameter_softening(After)).
{_} :-
solver(none), !.
{Var = Key with Dist} :-
put_atts(El,[key(Key),dist(DistInfo,Parents)]),
dist(Dist, DistInfo, Key, Parents),
add_evidence(Var,Key,DistInfo,El).
check_constraint(Constraint, _, _, Constraint) :- var(Constraint), !.
check_constraint((A->D), _, _, (A->D)) :- var(A), !.
check_constraint((([A|B].L)->D), Vars, NVars, (([A|B].NL)->D)) :- !,
check_cpt_input_vars(L, Vars, NVars, NL).
check_constraint(Dist, _, _, Dist).
check_cpt_input_vars([], _, _, []).
check_cpt_input_vars([V|L], Vars, NVars, [NV|NL]) :-
replace_var(Vars, V, NVars, NV),
check_cpt_input_vars(L, Vars, NVars, NL).
replace_var([], V, [], V).
replace_var([V|_], V0, [NV|_], NV) :- V == V0, !.
replace_var([_|Vars], V, [_|NVars], NV) :-
replace_var(Vars, V, NVars, NV).
add_evidence(V,Key,Distinfo,NV) :-
nonvar(V), !,
get_evidence_position(V, Distinfo, Pos),
check_stored_evidence(Key, Pos),
clpbn:put_atts(NV,evidence(Pos)).
add_evidence(V,K,_,V) :-
add_evidence(K,V).
clpbn_marginalise(V, Dist) :-
attributes:all_attvars(AVars),
project_attributes([V], AVars),
vel:get_atts(V, posterior(_,_,Dist,_)).
%
% called by top-level
% or by call_residue/2
%
project_attributes(GVars, AVars) :-
suppress_attribute_display(false),
AVars = [_|_],
solver(Solver),
( GVars = [_|_] ; Solver = graphs), !,
clpbn_vars(AVars, DiffVars, AllVars),
get_clpbn_vars(GVars,CLPBNGVars0),
simplify_query_vars(CLPBNGVars0, CLPBNGVars),
(output(xbif(XBifStream)) -> clpbn2xbif(XBifStream,vel,AllVars) ; true),
(output(gviz(XBifStream)) -> clpbn2gviz(XBifStream,sort,AllVars,GVars) ; true),
(
Solver = graphs
->
write_out(Solver, [[]], AllVars, DiffVars)
;
write_out(Solver, [CLPBNGVars], AllVars, DiffVars)
).
project_attributes(_, _).
clpbn_vars(AVars, DiffVars, AllVars) :-
sort_vars_by_key(AVars,SortedAVars,DiffVars),
incorporate_evidence(SortedAVars, AllVars).
get_clpbn_vars([],[]).
get_clpbn_vars([V|GVars],[V|CLPBNGVars]) :-
get_atts(V, [key(_)]), !,
get_clpbn_vars(GVars,CLPBNGVars).
get_clpbn_vars([_|GVars],CLPBNGVars) :-
get_clpbn_vars(GVars,CLPBNGVars).
simplify_query_vars(LVs0, LVs) :-
sort(LVs0,LVs1),
get_rid_of_ev_vars(LVs1,LVs).
%
% some variables might already have evidence in the data-base.
%
get_rid_of_ev_vars([],[]).
get_rid_of_ev_vars([V|LVs0],LVs) :-
clpbn:get_atts(V, [dist(Id,_),evidence(Pos)]), !,
get_evidence_from_position(Ev, Id, Pos),
clpbn_display:put_atts(V, [posterior([],Ev,[],[])]), !,
get_rid_of_ev_vars(LVs0,LVs).
get_rid_of_ev_vars([V|LVs0],[V|LVs]) :-
get_rid_of_ev_vars(LVs0,LVs).
% do nothing if we don't have query variables to compute.
write_out(graphs, _, AVars, _) :-
clpbn2graph(AVars).
write_out(vel, GVars, AVars, DiffVars) :-
vel(GVars, AVars, DiffVars).
write_out(jt, GVars, AVars, DiffVars) :-
jt(GVars, AVars, DiffVars).
write_out(gibbs, GVars, AVars, DiffVars) :-
gibbs(GVars, AVars, DiffVars).
write_out(bnt, GVars, AVars, DiffVars) :-
do_bnt(GVars, AVars, DiffVars).
get_bnode(Var, Goal) :-
get_atts(Var, [key(Key),dist(Dist,Parents)]),
get_dist(Dist,_,Domain,CPT),
(Parents = [] -> X = tab(Domain,CPT) ; X = tab(Domain,CPT,Parents)),
dist_goal(X, Key, Goal0),
include_evidence(Var, Goal0, Key, Goali),
include_starter(Var, Goali, Key, Goal).
include_evidence(Var, Goal0, Key, ((Key:-Ev),Goal0)) :-
get_atts(Var, [evidence(Ev)]), !.
include_evidence(_, Goal0, _, Goal0).
include_starter(Var, Goal0, Key, ((:-Key),Goal0)) :-
get_atts(Var, [starter]), !.
include_starter(_, Goal0, _, Goal0).
dist_goal(Dist, Key, (Key=NDist)) :-
term_variables(Dist, DVars),
process_vars(DVars, DKeys),
my_copy_term(Dist,DVars, NDist,DKeys).
my_copy_term(V, DVars, Key, DKeys) :-
find_var(DVars, V, Key, DKeys).
my_copy_term(A, _, A, _) :- atomic(A), !.
my_copy_term(T, Vs, NT, Ks) :-
T =.. [Na|As],
my_copy_terms(As, Vs, NAs, Ks),
NT =.. [Na|NAs].
my_copy_terms([], _, [], _).
my_copy_terms([A|As], Vs, [NA|NAs], Ks) :-
my_copy_term(A, Vs, NA, Ks),
my_copy_terms(As, Vs, NAs, Ks).
find_var([V1|_], V, Key, [Key|_]) :- V1 == V, !.
find_var([_|DVars], V, Key, [_|DKeys]) :-
find_var(DVars, V, Key, DKeys).
process_vars([], []).
process_vars([V|Vs], [K|Ks]) :-
process_var(V, K),
process_vars(Vs, Ks).
process_var(V, K) :- get_atts(V, [key(K)]), !.
% oops: this variable has no attributes.
process_var(V, _) :- throw(error(instantiation_error,clpbn(attribute_goal(V)))).
%
% unify a CLPBN variable with something.
%
verify_attributes(Var, T, Goals) :-
get_atts(Var, [key(Key),dist(Dist,Parents)]), !,
/* oops, someone trying to bind a clpbn constrained variable */
Goals = [],
bind_clpbn(T, Var, Key, Dist, Parents).
verify_attributes(_, _, []).
bind_clpbn(T, Var, _, _, _) :- nonvar(T),
!, ( add_evidence(Var,T) -> true ; writeln(T:Var), fail ).
bind_clpbn(T, Var, Key, Dist, Parents) :- var(T),
get_atts(T, [key(Key1),dist(Dist1,Parents1)]), !,
bind_clpbns(Key, Dist, Parents, Key1, Dist1, Parents1),
(
get_atts(T, [evidence(Ev1)]) ->
bind_evidence_from_extra_var(Ev1,Var)
;
get_atts(Var, [evidence(Ev)]) ->
bind_evidence_from_extra_var(Ev,T)
;
true).
bind_clpbn(_, Var, _, _, _, _) :-
use(bnt),
check_if_bnt_done(Var), !.
bind_clpbn(_, Var, _, _, _, _) :-
use(vel),
check_if_vel_done(Var), !.
bind_clpbn(_, Var, _, _, _, _) :-
use(jt),
check_if_vel_done(Var), !.
bind_clpbn(T, Var, Key0, _, _, _) :-
get_atts(Var, [key(Key)]), !,
(
Key = Key0 -> true
;
add_evidence(Var,T)
).
fresh_attvar(Var, NVar) :-
get_atts(Var, LAtts),
put_atts(NVar, LAtts).
% I will now allow two CLPBN variables to be bound together.
%bind_clpbns(Key, Dist, Parents, Key, Dist, Parents).
bind_clpbns(Key, Dist, Parents, Key1, Dist1, Parents1) :-
Key == Key1, !,
get_dist(Dist,Type,Domain,Table),
get_dist(Dist1,Type1,Domain1,Table1),
( Dist == Dist1,
same_parents(Parents,Parents1)
->
true
;
throw(error(domain_error(bayesian_domain),bind_clpbns(var(Dist, Key, Type, Domain, Table, Parents),var(Dist1, Key1, Type1, Domain1, Table1, Parents1))))
).
bind_clpbns(Key, _, _, _, Key1, _, _, _) :-
Key\=Key1, !, fail.
bind_clpbns(_, _, _, _, _, _, _, _) :-
format(user_error, 'unification of two bayesian vars not supported~n', []).
same_parents([],[]).
same_parents([P|Parents],[P1|Parents1]) :-
same_node(P,P1),
same_parents(Parents,Parents1).
same_node(P,P1) :- P == P1, !.
same_node(P,P1) :-
get_atts( P,[key(K)]),
get_atts(P1,[key(K)]),
P = P1.
bind_evidence_from_extra_var(Ev1,Var) :-
get_atts(Var, [evidence(Ev0)]), !,
Ev0 = Ev1.
bind_evidence_from_extra_var(Ev1,Var) :-
put_atts(Var, [evidence(Ev1)]).
user:term_expansion((A :- {}), ( :- true )) :- !, % evidence
prolog_load_context(module, M),
store_evidence(M:A).
clpbn_key(Var,Key) :-
get_atts(Var, [key(Key)]).
%
% This is a routine to start a solver, called by the learning procedures (ie, em).
% LVs is a list of lists of variables one is interested in eventually marginalising out
% Vs0 gives the original graph
% AllDiffs gives variables that are not fully constrainted, ie, we don't fully know
% the key. In this case, we assume different instances will be bound to different
% values at the end of the day.
%
clpbn_init_solver(LVs, Vs0, VarsWithUnboundKeys, State) :-
solver(Solver),
clpbn_init_solver(Solver, LVs, Vs0, VarsWithUnboundKeys, State).
clpbn_init_solver(gibbs, LVs, Vs0, VarsWithUnboundKeys, State) :-
init_gibbs_solver(LVs, Vs0, VarsWithUnboundKeys, State).
clpbn_init_solver(vel, LVs, Vs0, VarsWithUnboundKeys, State) :-
init_vel_solver(LVs, Vs0, VarsWithUnboundKeys, State).
clpbn_init_solver(jt, LVs, Vs0, VarsWithUnboundKeys, State) :-
init_jt_solver(LVs, Vs0, VarsWithUnboundKeys, State).
%
% LVs is the list of lists of variables to marginalise
% Vs is the full graph
% Ps are the probabilities on LVs.
%
%
clpbn_run_solver(LVs, LPs, State) :-
solver(Solver, State),
clpbn_run_solver(Solver, LVs, LPs, State).
clpbn_run_solver(gibbs, LVs, LPs, State) :-
run_gibbs_solver(LVs, LPs, State).
clpbn_run_solver(vel, LVs, LPs, State) :-
run_vel_solver(LVs, LPs, State).
clpbn_run_solver(jt, LVs, LPs, State) :-
run_jt_solver(LVs, LPs, State).

283
packages/CLPBN/clpbn/aggregates.yap Normal file
View File

@ -0,0 +1,283 @@
%
% generate explicit CPTs
%
:- module(clpbn_aggregates, [
check_for_agg_vars/2,
cpt_average/6,
cpt_average/7,
cpt_max/6,
cpt_min/6
]).
:- use_module(library(clpbn), [{}/1]).
:- use_module(library(lists),
[last/2,
sumlist/2,
sum_list/3,
max_list/2,
min_list/2,
nth0/3
]).
:- use_module(library(matrix),
[matrix_new/3,
matrix_to_list/2,
matrix_set/3]).
:- use_module(library('clpbn/dists'),
[
dist/4,
get_dist_domain_size/2]).
:- use_module(library('clpbn/matrix_cpt_utils'),
[normalise_CPT_on_lines/3]).
check_for_agg_vars([], []).
check_for_agg_vars([V|Vs0], [V|Vs1]) :-
clpbn:get_atts(V, [key(K), dist(Id,Parents)]), !,
simplify_dist(Id, V, K, Parents, Vs0, Vs00),
check_for_agg_vars(Vs00, Vs1).
check_for_agg_vars([_|Vs0], Vs1) :-
check_for_agg_vars(Vs0, Vs1).
% transform aggregate distribution into tree
simplify_dist(avg(Domain), V, Key, Parents, Vs0, VsF) :- !,
cpt_average([V|Parents], Key, Domain, NewDist, Vs0, VsF),
dist(NewDist, Id, Key, ParentsF),
clpbn:put_atts(V, [dist(Id,ParentsF)]).
simplify_dist(_, _, _, _, Vs0, Vs0).
cpt_average(AllVars, Key, Els0, Tab, Vs, NewVs) :-
cpt_average(AllVars, Key, Els0, 1.0, Tab, Vs, NewVs).
% support variables with evidence from domain. This should make everyone's life easier.
cpt_average([Ev|Vars], Key, Els0, Softness, p(Els0, CPT, NewParents), Vs, NewVs) :-
find_evidence(Vars, 0, TotEvidence, RVars),
build_avg_table(RVars, Vars, Els0, Key, TotEvidence, Softness, MAT0, NewParents0, Vs, IVs),
include_qevidence(Ev, MAT0, MAT, NewParents0, NewParents, Vs, IVs, NewVs),
matrix_to_list(MAT, CPT), writeln(NewParents: Vs: NewVs: CPT).
% find all fixed kids, this simplifies significantly the function.
find_evidence([], TotEvidence, TotEvidence, []).
find_evidence([V|Vars], TotEvidence0, TotEvidence, RVars) :-
clpbn:get_atts(V,[evidence(Ev)]), !,
TotEvidenceI is TotEvidence0+Ev,
find_evidence(Vars, TotEvidenceI, TotEvidence, RVars).
find_evidence([V|Vars], TotEvidence0, TotEvidence, [V|RVars]) :-
find_evidence(Vars, TotEvidence0, TotEvidence, RVars).
cpt_max([_|Vars], Key, Els0, CPT, Vs, NewVs) :-
build_max_table(Vars, Els0, Els0, Key, 1.0, CPT, Vs, NewVs).
cpt_min([_|Vars], Key, Els0, CPT, Vs, NewVs) :-
build_min_table(Vars, Els0, Els0, Key, 1.0, CPT, Vs, NewVs).
build_avg_table(Vars, OVars, Domain, _, TotEvidence, Softness, CPT, Vars, Vs, Vs) :-
length(Domain, SDomain),
int_power(Vars, SDomain, 1, TabSize),
TabSize =< 256,
/* case gmp is not there !! */
TabSize > 0, !,
average_cpt(Vars, OVars, Domain, TotEvidence, Softness, CPT).
build_avg_table(Vars, OVars, Domain, Key, TotEvidence, Softness, CPT, [V1,V2], Vs, [V1,V2|NewVs]) :-
length(Vars,L),
LL1 is L//2,
LL2 is L-LL1,
list_split(LL1, Vars, L1, L2),
Min = 0,
length(Domain,Max1), Max is Max1-1,
build_intermediate_table(LL1, sum(Min,Max), L1, V1, Key, 1.0, 0, I1, Vs, Vs1),
build_intermediate_table(LL2, sum(Min,Max), L2, V2, Key, 1.0, I1, _, Vs1, NewVs),
average_cpt([V1,V2], OVars, Domain, TotEvidence, Softness, CPT).
build_max_table(Vars, Domain, Softness, p(Domain, CPT, Vars), Vs, Vs) :-
length(Domain, SDomain),
int_power(Vars, SDomain, 1, TabSize),
TabSize =< 16,
/* case gmp is not there !! */
TabSize > 0, !,
max_cpt(Vars, Domain, Softness, CPT).
build_max_table(Vars, Domain, Softness, p(Domain, CPT, [V1,V2]), Vs, [V1,V2|NewVs]) :-
length(Vars,L),
LL1 is L//2,
LL2 is L-LL1,
list_split(LL1, Vars, L1, L2),
build_intermediate_table(LL1, max(Domain,CPT), L1, V1, Key, 1.0, 0, I1, Vs, Vs1),
build_intermediate_table(LL2, max(Domain,CPT), L2, V2, Key, 1.0, I1, _, Vs1, NewVs),
max_cpt([V1,V2], Domain, Softness, CPT).
build_min_table(Vars, Domain, Softness, p(Domain, CPT, Vars), Vs, Vs) :-
length(Domain, SDomain),
int_power(Vars, SDomain, 1, TabSize),
TabSize =< 16,
/* case gmp is not there !! */
TabSize > 0, !,
min_cpt(Vars, Domain, Softness, CPT).
build_min_table(Vars, Domain, Softness, p(Domain, CPT, [V1,V2]), Vs, [V1,V2|NewVs]) :-
length(Vars,L),
LL1 is L//2,
LL2 is L-LL1,
list_split(LL1, Vars, L1, L2),
build_intermediate_table(LL1, min(Domain,CPT), L1, V1, Key, 1.0, 0, I1, Vs, Vs1),
build_intermediate_table(LL2, min(Domain,CPT), L2, V2, Key, 1.0, I1, _, Vs1, NewVs),
min_cpt([V1,V2], Domain, Softness, CPT).
int_power([], _, TabSize, TabSize).
int_power([_|L], X, I0, TabSize) :-
I is I0*X,
int_power(L, X, I, TabSize).
build_intermediate_table(1,_,[V],V, _, _, I, I, Vs, Vs) :- !.
build_intermediate_table(2, Op, [V1,V2], V, Key, Softness, I0, If, Vs, Vs) :- !,
If is I0+1,
generate_tmp_random(Op, 2, [V1,V2], V, Key, Softness, I0).
build_intermediate_table(N, Op, L, V, Key, Softness, I0, If, Vs, [V1,V2|NewVs]) :-
LL1 is N//2,
LL2 is N-LL1,
list_split(LL1, L, L1, L2),
I1 is I0+1,
build_intermediate_table(LL1, Op, L1, V1, Key, Softness, I1, I2, Vs, Vs1),
build_intermediate_table(LL2, Op, L2, V2, Key, Softness, I2, If, Vs1, NewVs),
generate_tmp_random(Op, N, [V1,V2], V, Key, Softness, I0).
% averages are transformed into sums.
generate_tmp_random(sum(Min,Max), N, [V1,V2], V, Key, Softness, I) :-
Lower is Min*N,
Upper is Max*N,
generate_list(Lower, Upper, Nbs),
sum_cpt([V1,V2], Nbs, Softness, CPT),
% write(sum(Nbs, CPT, [V1,V2])),nl, % debugging
{ V = 'AVG'(I,Key) with p(Nbs,CPT,[V1,V2]) }.
generate_tmp_random(max(Domain,CPT), _, [V1,V2], V, Key, I) :-
{ V = 'MAX'(I,Key) with p(Domain,CPT,[V1,V2]) }.
generate_tmp_random(min(Domain,CPT), _, [V1,V2], V, Key, I) :-
{ V = 'MIN'(I,Key) with p(Domain,CPT,[V1,V2]) }.
generate_list(M, M, [M]) :- !.
generate_list(I, M, [I|Nbs]) :-
I1 is I+1,
generate_list(I1, M, Nbs).
list_split(0, L, [], L) :- !.
list_split(I, [H|L], [H|L1], L2) :-
I1 is I-1,
list_split(I1, L, L1, L2).
%
% if we have evidence, we need to check if we are always consistent, never consistent, or can be consistent
%
include_qevidence(V, MAT0, MAT, NewParents0, NewParents, Vs, IVs, NewVs) :-
clpbn:get_atts(V,[evidence(Ev)]), !,
normalise_CPT_on_lines(MAT0, MAT1, L1),
check_consistency(L1, Ev, MAT0, MAT1, L1, MAT, NewParents0, NewParents, Vs, IVs, NewVs).
include_qevidence(_, MAT, MAT, NewParents, NewParents, _, Vs, Vs).
check_consistency(L1, Ev, MAT0, MAT1, L1, MAT, NewParents0, NewParents, Vs, IVs, NewVs) :-
sumlist(L1, Tot),
nth0(Ev, L1, Val),
(Val == Tot ->
writeln(Ev:L1:Val:1),
MAT1 = MAT,
NewParents = [],
Vs = NewVs
;
Val == 0.0 ->
writeln(Ev:L1:Val:2),
throw(error(domain_error(incompatible_evidence),evidence(Ev)))
;
writeln(Ev:L1:Val:3),
MAT0 = MAT,
NewParents = NewParents0,
IVs = NewVs
).
%
% generate actual table, instead of trusting the solver
%
average_cpt(Vs, OVars, Vals, Base, _, MCPT) :-
get_ds_lengths(Vs,Lengs),
length(OVars, N),
length(Vals, SVals),
matrix_new(floats,[SVals|Lengs],MCPT),
fill_in_average(Lengs,N,Base,MCPT).
get_ds_lengths([],[]).
get_ds_lengths([V|Vs],[Sz|Lengs]) :-
get_vdist_size(V, Sz),
get_ds_lengths(Vs,Lengs).
fill_in_average(Lengs, N, Base, MCPT) :-
generate(Lengs, Case),
average(Case, N, Base, Val),
matrix_set(MCPT,[Val|Case],1.0),
fail.
fill_in_average(_,_,_,_).
generate([], []).
generate([N|Lengs], [C|Case]) :-
from(0,N,C),
generate(Lengs, Case).
from(I,_,I).
from(I1,M,J) :-
I is I1+1,
I < M,
from(I,M,J).
average(Case, N, Base, Val) :-
sum_list(Case, Base, Tot),
Val is integer(round(Tot/N)).
sum_cpt(Vs,Vals,_,CPT) :-
get_ds_lengths(Vs,Lengs),
length(Vals,SVals),
matrix_new(floats,[SVals|Lengs],MCPT),
fill_in_sum(Lengs,MCPT),
matrix_to_list(MCPT,CPT).
fill_in_sum(Lengs,MCPT) :-
generate(Lengs, Case),
sumlist(Case, Val),
matrix_set(MCPT,[Val|Case],1.0),
fail.
fill_in_sum(_,_).
max_cpt(Vs,Vals,_,CPT) :-
get_ds_lengths(Vs,Lengs),
length(Vals,SVals),
matrix_new(floats,[SVals|Lengs],MCPT),
fill_in_max(Lengs,MCPT),
matrix_to_list(MCPT,CPT).
fill_in_max(Lengs,MCPT) :-
generate(Lengs, Case),
max_list(Case, Val),
matrix_set(MCPT,[Val|Case],1.0),
fail.
fill_in_max(_,_).
min_cpt(Vs,Vals,_,CPT) :-
get_ds_lengths(Vs,Lengs),
length(Vals,SVals),
matrix_new(floats,[SVals|Lengs],MCPT),
fill_in_max(Lengs,MCPT),
matrix_to_list(MCPT,CPT).
fill_in_min(Lengs,MCPT) :-
generate(Lengs, Case),
max_list(Case, Val),
matrix_set(MCPT,[Val|Case],1.0),
fail.
fill_in_min(_,_).
get_vdist_size(V, Sz) :-
clpbn:get_atts(V, [dist(Dist,_)]),
get_dist_domain_size(Dist, Sz).

425
packages/CLPBN/clpbn/bnt.yap Normal file
View File

@ -0,0 +1,425 @@
:- module(bnt, [do_bnt/3,
create_bnt_graph/2,
check_if_bnt_done/1]).
:- use_module(library('clpbn/display'), [
clpbn_bind_vals/3]).
:- use_module(library('clpbn/dists'), [
get_dist_domain_size/2,
get_dist_domain/2,
get_dist_params/2
]).
:- use_module(library('clpbn/discrete_utils'), [
reorder_CPT/5]).
:- use_module(library(matlab), [start_matlab/1,
close_matlab/0,
matlab_on/0,
matlab_eval_string/1,
matlab_eval_string/2,
matlab_matrix/4,
matlab_vector/2,
matlab_sequence/3,
matlab_initialized_cells/4,
matlab_get_variable/2,
matlab_call/2
]).
:- use_module(library(dgraphs), [dgraph_new/1,
dgraph_add_vertices/3,
dgraph_add_edges/3,
dgraph_top_sort/2,
dgraph_vertices/2,
dgraph_edges/2
]).
:- use_module(library(lists), [append/3,
member/2,nth/3]).
:- use_module(library(ordsets), [
ord_insert/3]).
:- yap_flag(write_strings,on).
% syntactic sugar for matlab_call.
:- op(800,yfx,<--).
G <-- Y :-
matlab_call(Y,G).
:- attribute bnt_id/1.
:- dynamic bnt/1.
:- dynamic bnt_solver/1, bnt_path/1, bnt_model/1.
% belprop
bnt_solver(jtree).
% likelihood_weighting
bnt_path("$HOME/Yap/CLPBN/FullBNT-1.0.4/BNT").
%
% What BNT are we using:
% a propositional one
% a tied parameter one.
%
%bnt_model(propositional).
bnt_model(tied).
%bnt_model(dbn).
/*****************************************
BNT uses:
bnet
dag
discrete_nodes: which nodes are discrete (all by now),
node_sizes
engine
evidence
marg
*****************************************/
check_if_bnt_done(Var) :-
get_atts(Var, [map(_)]).
do_bnt([], _, _) :- !.
do_bnt(QueryVars, AllVars, AllDiffs) :-
create_bnt_graph(AllVars, _, SortedVertices, NumberedVertices, Size),
set_inference,
add_evidence(SortedVertices, Size, NumberedVertices),
marginalize(QueryVars, SortedVertices, NumberedVertices, Ps),
clpbn_bind_vals(QueryVars, Ps, AllDiffs).
create_bnt_graph(AllVars, Representatives) :-
create_bnt_graph(AllVars, Representatives, _, _, _).
create_bnt_graph(AllVars, Representatives, SortedVertices, NumberedVertices, Size) :-
init_matlab,
sort_nodes(AllVars, SortedVertices),
number_graph(SortedVertices, NumberedVertices, 0, Size),
bnt_model(ModelType),
init_bnet(ModelType, SortedVertices, NumberedVertices, Size, Representatives).
% make sure MATLAB works.
init_matlab :-
bnt(on), !.
init_matlab :-
start_matlab,
bnt_path(Path),
append("cd ",Path,Command),
% atom_concat('cd ', Path, Command),
matlab_eval_string(Command),
matlab_eval_string('addpath(genpathKPM(pwd))',_),
assert(bnt(on)).
start_matlab :-
matlab_on, !.
start_matlab :-
start_matlab('matlab -nojvm -nosplash').
sort_nodes(AllVars, SortedVertices) :-
bnt_model(tied), !,
extract_tied(AllVars, SortedVertices).
sort_nodes(AllVars, SortedVertices) :-
bnt_model(propositional), !,
extract_graph(AllVars, Graph),
dgraph_top_sort(Graph, SortedVertices).
extract_tied(AllVars, SortedVars) :-
extract_kvars(AllVars,KVars),
keysort(KVars,SVars),
split_tied_vars(SVars,TVars, Vertices),
tied_graph(TVars,TGraph,Vertices),
dgraph_top_sort(TGraph, Sort),
distribute_tied_variables(Sort, TVars, 1, SortedVars).
extract_kvars([],[]).
extract_kvars([V|AllVars],[N-i(V,Parents)|KVars]) :-
clpbn:get_atts(V, [dist(N,Parents)]),
extract_kvars(AllVars,KVars).
split_tied_vars([],[],[]).
split_tied_vars([N-i(V,Par)|More],[N-g(Vs,Ns,Es)|TVars],[N|LNs]) :-
get_pars(Par,N,V,NPs,[],Es0,Es),
get_tied(More,N,Vs,[V],Ns,NPs,Es,Es0,SVars),
split_tied_vars(SVars,TVars,LNs).
get_pars([],_,_,NPs,NPs,Es,Es).
get_pars([V|Par],N,V0,NPs,NPs0,Es,Es0) :-
clpbn:get_atts(V, [dist(N,_)]), !,
get_pars(Par,N,V0,NPs,NPs0,Es,[V-V0|Es0]).
get_pars([V|Par],N,V0,NPs,NPs0,Es,Es0) :-
clpbn:get_atts(V, [dist(M,_)]),
ord_insert(NPs0,M,NPsI),
get_pars(Par,N,V0,NPs,NPsI,Es,Es0).
get_tied([N-i(V,Par)|More],N,Vs,Vs0,Ns,NPs,Es,Es0,SVars) :- !,
get_pars(Par,N,V,NPsI,NPs,EsI,Es0),
get_tied(More,N,Vs,[V|Vs0],Ns,NPsI,Es,EsI,SVars).
get_tied(More,_,Vs,Vs,Ns,Ns,Es,Es,More).
tied_graph(TVars,Graph,Vertices) :-
dgraph_new(Graph0),
dgraph_add_vertices(Graph0, Vertices, Graph1),
get_tied_edges(TVars,Edges),
dgraph_add_edges(Graph1, Edges, Graph).
get_tied_edges([],[]).
get_tied_edges([N-g(_,Vs,_)|TGraph],Edges) :-
add_tied(Vs,N,Edges,Edges0),
get_tied_edges(TGraph,Edges0).
add_tied([],_,Edges,Edges).
add_tied([N1|Vs],N,[N1-N|Edges],Edges0) :-
add_tied(Vs,N,Edges,Edges0).
distribute_tied_variables([], _, _, []).
distribute_tied_variables([N|Sort], TVars, I0, SortedVars) :-
member(N-g(Vs,_,_),TVars),
distribute_tied(Vs,I0,In,SortedVars,SortedVars0),
distribute_tied_variables(Sort, TVars, In, SortedVars0).
distribute_tied([],I,I,Vs,Vs).
distribute_tied([V|Vs],I0,In,[V|NVs],NVs0) :-
I is I0+1,
put_atts(V, [bnt_id(I0)]),
% clpbn:get_atts(V,[key(K)]),
distribute_tied(Vs,I,In,NVs,NVs0).
extract_graph(AllVars, Graph) :-
dgraph_new(Graph0),
dgraph_add_vertices(Graph0, AllVars, Graph1),
get_edges(AllVars,Edges),
dgraph_add_edges(Graph1, Edges, Graph).
get_edges([],[]).
get_edges([V|AllVars],Edges) :-
clpbn:get_atts(V, [dist(_,Parents)]),
add_parent_child(Parents,V,Edges,Edges0),
get_edges(AllVars,Edges0).
add_parent_child([],_,Edges,Edges).
add_parent_child([P|Parents],V,[P-V|Edges],Edges0) :-
add_parent_child(Parents,V,Edges,Edges0).
number_graph([], [], I, I).
number_graph([V|SortedGraph], [I|Is], I0, IF) :-
I is I0+1,
put_atts(V, [bnt_id(I)]),
% clpbn:get_atts(V,[key(K)]),
% write(I:K),nl,
number_graph(SortedGraph, Is, I, IF).
init_bnet(propositional, SortedGraph, NumberedGraph, Size, []) :-
build_dag(SortedGraph, Size),
init_discrete_nodes(SortedGraph, Size),
bnet <-- mk_bnet(dag, node_sizes, \discrete, discrete_nodes),
dump_cpts(SortedGraph, NumberedGraph).
init_bnet(tied, SortedGraph, NumberedGraph, Size, Representatives) :-
build_dag(SortedGraph, Size),
init_discrete_nodes(SortedGraph, Size),
dump_tied_cpts(SortedGraph, NumberedGraph, Representatives).
build_dag(SortedVertices, Size) :-
get_numbered_edges(SortedVertices, Edges),
mkdag(Size, Edges).
get_numbered_edges([], []).
get_numbered_edges([V|SortedVertices], Edges) :-
clpbn:get_atts(V, [dist(_,Ps)]),
v2number(V,N),
add_numbered_edges(Ps, N, Edges, Edges0),
get_numbered_edges(SortedVertices, Edges0).
add_numbered_edges([], _, Edges, Edges).
add_numbered_edges([P|Ps], N, [PN-N|Edges], Edges0) :-
v2number(P,PN),
add_numbered_edges(Ps, N, Edges, Edges0).
v2number(V,N) :-
get_atts(V,[bnt_id(N)]).
init_discrete_nodes(SortedGraph, Size) :-
matlab_sequence(1,Size,discrete_nodes),
mksizes(SortedGraph, Size).
mkdag(N,Els) :-
Tot is N*N,
functor(Dag,dag,Tot),
add_els(Els,N,Dag),
Dag=..[_|L],
addzeros(L),
matlab_matrix(N,N,L,dag).
add_els([],_,_).
add_els([X-Y|Els],N,Dag) :-
Pos is (X-1)*N+Y,
arg(Pos,Dag,1),
add_els(Els,N,Dag).
addzeros([]).
addzeros([0|L]) :- !,
addzeros(L).
addzeros([1|L]) :-
addzeros(L).
mksizes(SortedVertices, Size) :-
get_szs(SortedVertices,Sizes),
matlab_matrix(1,Size,Sizes,node_sizes).
get_szs([],[]).
get_szs([V|SortedVertices],[LD|Sizes]) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id,LD),
get_szs(SortedVertices,Sizes).
dump_cpts([], []).
dump_cpts([V|SortedGraph], [I|Is]) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
get_dist_params(Id,CPT),
reorder_cpt(CPT,V,Parents,Tab),
mkcpt(bnet,I,Tab),
dump_cpts(SortedGraph, Is).
%
% This is complicated, the BNT and we have different orders
%
reorder_cpt(CPT,_, [], CPT) :- !.
reorder_cpt(CPT,V,Parents,Tab) :-
% get BNT label
get_sizes_and_ids(Parents,Ids),
% sort to BNT
keysort(Ids,NIds),
% get vars in order
extract_vars(NIds, [], NParents),
% do the actual work
reorder_CPT([V|Parents],CPT,[V|NParents],STab,_),
STab=..[_|Tab].
get_sizes_and_ids([],[]).
get_sizes_and_ids([V|Parents],[Id-V|Ids]) :-
get_atts(V, [bnt_id(Id)]),
get_sizes_and_ids(Parents,Ids).
extract_vars([], L, L).
extract_vars([_-V|NIds], NParents, Vs) :-
extract_vars(NIds, [V|NParents], Vs).
mkcpt(BayesNet, I, Tab) :-
(BayesNet.'CPD'({I})) <-- tabular_CPD(BayesNet,I,Tab).
dump_tied_cpts(Graph, Is, Reps) :-
create_class_vector(Graph, Is, Classes, Reps0),
matlab_vector(Classes, eclass),
keysort(Reps0,Reps1),
representatives(Reps1,Reps),
bnet <-- mk_bnet(dag, node_sizes, \discrete, discrete_nodes, \equiv_class, eclass),
dump_tied_cpts(Reps).
create_class_vector([], [], [],[]).
create_class_vector([V|Graph], [I|Is], [Id|Classes], [Id-v(V,I,Parents)|Sets]) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
create_class_vector(Graph, Is,Classes,Sets).
representatives([],[]).
representatives([Class-Rep|Reps1],[Class-Rep|Reps]) :-
nonrepresentatives(Reps1, Class, Reps2),
representatives(Reps2,Reps).
nonrepresentatives([Class-_|Reps1], Class, Reps2) :- !,
nonrepresentatives(Reps1, Class, Reps2).
nonrepresentatives(Reps, _, Reps).
dump_tied_cpts([]).
dump_tied_cpts([Class-v(V,Id,Parents)|SortedGraph]) :-
get_dist_params(Class,CPT),
reorder_cpt(CPT,V,Parents,NCPT),
mktiedcpt(bnet,Id,Class,NCPT),
dump_tied_cpts(SortedGraph).
mktiedcpt(BayesNet, V, Class, Tab) :-
(BayesNet.'CPD'({Class})) <-- tabular_CPD(BayesNet,V,Tab).
set_inference :-
bnt_solver(Solver),
init_solver(Solver).
init_solver(jtree) :-
engine <-- jtree_inf_engine(bnet).
init_solver(belprop) :-
engine <-- belprop_inf_engine(bnet).
init_solver(likelihood_weighting) :-
engine <-- likelihood_weighting_inf_engine(bnet).
init_solver(enumerative) :-
engine <-- enumerative_inf_engine(bnet).
init_solver(gibbs) :-
engine <-- gibbs_sampling_inf_engine(bnet).
init_solver(global_joint) :-
engine <-- global_joint_inf_engine(bnet).
init_solver(pearl) :-
engine <-- pearl_inf_engine(bnet).
init_solver(var_elim) :-
engine <-- var_elim_inf_engine(bnet).
add_evidence(Graph, Size, Is) :-
mk_evidence(Graph, Is, LN),
matlab_initialized_cells( 1, Size, LN, evidence),
[engine_ev, loglik] <-- enter_evidence(engine, evidence).
mk_evidence([], [], []).
mk_evidence([V|L], [I|Is], [ar(1,I,EvVal1)|LN]) :-
clpbn:get_atts(V, [evidence(EvVal)]), !,
EvVal1 is EvVal +1,
mk_evidence(L, Is, LN).
mk_evidence([_|L], [_|Is], LN) :-
mk_evidence(L, Is, LN).
evidence_val(Ev,Val,[Ev|_],Val) :- !.
evidence_val(Ev,I0,[_|Domain],Val) :-
I1 is I0+1,
evidence_val(Ev,I1,Domain,Val).
marginalize([[V]], _SortedVars,_NunmberedVars, Ps) :- !,
v2number(V,Pos),
marg <-- marginal_nodes(engine_ev, Pos),
matlab_get_variable( marg.'T', Ps).
marginalize([Vs], SortedVars, NumberedVars,Ps) :-
bnt_solver(jtree),!,
matlab_get_variable(loglik, Den),
clpbn_display:get_all_combs(Vs, Vals),
mk_evidence(SortedVars, NumberedVars, Ev),
length(SortedVars,L),
cycle_values(Den, Ev, Vs, L, Vals, Ps).
cycle_values(_D, _Ev, _Vs, _Size, [], []).
cycle_values(Den,Ev,Vs,Size,[H|T],[HP|TP]):-
mk_evidence_query(Vs, H, EvQuery),
append(EvQuery,Ev,Instantiation),
matlab_initialized_cells( 1, Size, Instantiation, instantiation),
[engine_ev, logll] <-- enter_evidence(engine, instantiation),
matlab_get_variable(logll, Num),
HP is exp(Num-Den),
cycle_values(Den,Ev,Vs,Size,T,TP).
mk_evidence_query([], [], []).
mk_evidence_query([V|L], [H|T], [ar(1,Pos,El)|LN]) :-
v2number(V,Pos),
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain(Id,D),
nth(El,D,H),
mk_evidence_query(L, T, LN).

172
packages/CLPBN/clpbn/connected.yap Normal file
View File

@ -0,0 +1,172 @@
:- module(clpbn_connected,
[clpbn_subgraphs/2,
influences/4,
init_influences/3,
influences/5]).
:- use_module(library(dgraphs),
[dgraph_new/1,
dgraph_add_edges/3,
dgraph_add_vertex/3,
dgraph_neighbors/3,
dgraph_edge/3]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_insert/4,
rb_lookup/3]).
:- attribute component/1.
% search for connected components, that is, where we know that A influences B or B influences A.
clpbn_subgraphs(Vs, Gs) :-
mark_components(Vs, Components),
keysort(Components, Ordered),
same_key(Ordered, Gs).
% ignore variables with evidence,
% the others mark the MB.
mark_components([], []).
mark_components([V|Vs], Components) :-
clpbn:get_atts(V, [evidence(_),dist(_,Parents)]), !,
merge_parents(Parents, _),
mark_components(Vs, Components).
mark_components([V|Vs], [Mark-V|Components]) :-
mark_var(V, Mark),
mark_components(Vs, Components).
mark_var(V, Mark) :-
get_atts(V, [component(Mark)]), !,
clpbn:get_atts(V, [dist(_,Parents)]), !,
merge_parents(Parents, Mark).
mark_var(V, Mark) :-
clpbn:get_atts(V, [dist(_,Parents)]), !,
put_atts(V,[component(Mark)]),
merge_parents(Parents, Mark).
merge_parents([], _).
merge_parents([V|Parents], Mark) :-
clpbn:get_atts(V,[evidence(_)]), !,
merge_parents(Parents, Mark).
merge_parents([V|Parents], Mark) :-
get_atts(V,[component(Mark)]), !,
merge_parents(Parents, Mark).
merge_parents([V|Parents], Mark) :-
put_atts(V,[component(Mark)]),
merge_parents(Parents, Mark).
same_key([],[]).
same_key([K-El|More],[[El|Els]|Gs]) :-
same_keys(More, K, Els, Rest),
same_key(Rest,Gs).
same_keys([], _, [], []).
same_keys([K1-El|More], K, [El|Els], Rest) :-
K == K1, !,
same_keys(More, K, Els, Rest).
same_keys(Rest, _, [], Rest).
influences_more([], _, _, Is, Is, Evs, Evs, V2, V2).
influences_more([V|LV], G, RG, Is0, Is, Evs0, Evs, GV0, GV2) :-
rb_lookup(V, _, GV0), !,
influences_more(LV, G, RG, Is0, Is, Evs0, Evs, GV0, GV2).
influences_more([V|LV], G, RG, Is0, Is, Evs0, Evs, GV0, GV3) :-
rb_insert(GV0, V, _, GV1),
follow_dgraph(V, G, RG, [V|Is0], Is1, [V|Evs0], Evs1, GV1, GV2),
influences_more(LV, G, RG, Is1, Is, Evs1, Evs, GV2, GV3).
% search for the set of variables that influence V
influences(Vs, LV, Is, Evs) :-
init_influences(Vs, G, RG),
influences(LV, Is, Evs, G, RG).
init_influences(Vs, G, RG) :-
dgraph_new(G0),
dgraph_new(RG0),
to_dgraph(Vs, G0, G, RG0, RG).
influences([], [], [], _, _).
influences([V|LV], Is, Evs, G, RG) :-
rb_new(V0),
rb_insert(V0, V, _, V1),
follow_dgraph(V, G, RG, [V], Is1, [V], Evs1, V1, V2),
influences_more(LV, G, RG, Is1, Is, Evs1, Evs, V2, _).
to_dgraph([], G, G, RG, RG).
to_dgraph([V|Vs], G0, G, RG0, RG) :-
clpbn:get_atts(V, [evidence(_),dist(_,Parents)]), !,
build_edges(Parents, V, Edges, REdges),
dgraph_add_edges(G0,[V-e|Edges],G1),
dgraph_add_edges(RG0,REdges,RG1),
to_dgraph(Vs, G1, G, RG1, RG).
to_dgraph([V|Vs], G0, G, RG0, RG) :-
clpbn:get_atts(V, [dist(_,Parents)]),
build_edges(Parents, V, Edges, REdges),
dgraph_add_vertex(G0,V,G1),
dgraph_add_edges(G1, Edges, G2),
dgraph_add_vertex(RG0,V,RG1),
dgraph_add_edges(RG1, REdges, RG2),
to_dgraph(Vs, G2, G, RG2, RG).
build_edges([], _, [], []).
build_edges([P|Parents], V, [P-V|Edges], [V-P|REdges]) :-
build_edges(Parents, V, Edges, REdges).
follow_dgraph(V, G, RG, Is0, IsF, Evs0, EvsF, Visited0, Visited) :-
dgraph_neighbors(V, RG, Parents),
add_parents(Parents, G, RG, Is0, IsI, Evs0, EvsI, Visited0, Visited1),
dgraph_neighbors(V, G, Kids),
add_kids(Kids, G, RG, IsI, IsF, EvsI, EvsF, Visited1, Visited).
add_parents([], _, _, Is, Is, Evs, Evs, Visited, Visited).
% been here already, can safely ignore.
add_parents([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :-
rb_lookup(V, _, Visited0), !,
add_parents(Vs, G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF).
% evidence node,
% just say that we visited it
add_parents([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :-
dgraph_edge(V,e,G), !, % has evidence
rb_insert(Visited0, V, _, VisitedI),
add_parents(Vs, G, RG, Is0, IsF, [V|Evs0], EvsF, VisitedI, VisitedF).
% non-evidence node,
% we will need to find its parents.
add_parents([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :-
rb_insert(Visited0, V, _, VisitedI),
follow_dgraph(V, G, RG, [V|Is0], IsI, [V|Evs0], EvsI, VisitedI, VisitedII),
add_parents(Vs, G, RG, IsI, IsF, EvsI, EvsF, VisitedII, VisitedF).
add_kids([], _, _, Is, Is, Evs, Evs, Visited, Visited).
add_kids([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :-
dgraph_edge(V,e,G), % has evidence
% we will go there even if it was visited
( rb_insert(Visited0, V, _, Visited1) ->
true
;
% we've been there, but were we there as a father or as a kid?
not_in(Evs0, V),
Visited1 = Visited0
),
!,
dgraph_neighbors(V, RG, Parents),
add_parents(Parents, G, RG, Is0, Is1, [V|Evs0], EvsI, Visited1, VisitedI),
(Is1 = Is0 ->
% ignore whatever we did with this node,
% it didn't lead anywhere (all parents have evidence).
add_kids(Vs, G, RG, Is0, IsF, [V|Evs0], EvsF, Visited1, VisitedF)
;
% insert parents
add_kids(Vs, G, RG, Is1, IsF, EvsI, EvsF, VisitedI, VisitedF)
).
add_kids([_|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :-
add_kids(Vs, G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF).
not_in([V1|_], V) :- V1 == V, !, fail.
not_in([_|Evs0], V) :-
not_in(Evs0, V).

146
packages/CLPBN/clpbn/discrete_utils.yap Normal file
View File

@ -0,0 +1,146 @@
:- module(discrete_utils, [project_from_CPT/3,
reorder_CPT/5,
get_dist_size/2]).
:- use_module(dists, [get_dist_domain_size/2,
get_dist_domain/2]).
%
% remove columns from a table
%
project_from_CPT(V,tab(Table,Deps,Szs),tab(NewTable,NDeps,NSzs)) :-
propagate_evidence(V,Evs),
functor(Table,_,Max),
find_projection_factor(Deps, V, NDeps, Szs, NSzs, F, Sz),
OLoop is Max//(Sz*F),
project_outer_loop(0,OLoop,F,Sz,Table,Evs,NTabl),
NewTable =.. [t|NTabl].
propagate_evidence(V, Evs) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,_)]), !,
get_dist_domain(Id, Out),
generate_szs_with_evidence(Out,Ev,0,Evs,Found),
(var(Found) ->
clpbn:get_atts(V, [key(K)]),
throw(clpbn(evidence_does_not_match,K,Ev,[Out]))
;
true
).
propagate_evidence(_, _).
generate_szs_with_evidence([],_,_,[],_).
generate_szs_with_evidence([_|Out],Ev,Ev,[ok|Evs],found) :- !,
I is Ev+1,
generate_szs_with_evidence(Out,Ev,I,Evs,found).
generate_szs_with_evidence([_|Out],Ev,I0,[not_ok|Evs],Found) :-
I is I0+1,
generate_szs_with_evidence(Out,Ev,I,Evs,Found).
find_projection_factor([V|Deps], V1, Deps, [Sz|Szs], Szs, F, Sz) :-
V == V1, !,
mult(Szs, 1, F).
find_projection_factor([V|Deps], V1, [V|NDeps], [Sz|Szs], [Sz|NSzs], F, NSz) :-
find_projection_factor(Deps, V1, NDeps, Szs, NSzs, F, NSz).
mult([], F, F).
mult([Sz|Szs], Sz0, F) :-
SzI is Sz0*Sz,
mult(Szs, SzI, F).
project_outer_loop(OLoop,OLoop,_,_,_,_,[]) :- !.
project_outer_loop(I,OLoop,F,Sz,Table,Evs,NTabl) :-
Base is I*Sz*F,
project_mid_loop(0,F,Base,Sz,Table,Evs,NTabl,NTabl0),
I1 is I+1,
project_outer_loop(I1,OLoop,F,Sz,Table,Evs,NTabl0).
project_mid_loop(F,F,_,_,_,_,NTabl,NTabl) :- !.
project_mid_loop(I,F,Base,Sz,Table,Evs,[Ent|NTablF],NTabl0) :-
I1 is I+1,
NBase is I+Base,
project_inner_loop(0,Sz,Evs,NBase,F,Table,0.0,Ent),
project_mid_loop(I1,F,Base,Sz,Table,Evs,NTablF,NTabl0).
project_inner_loop(Sz,Sz,[],_,_,_,Ent,Ent) :- !.
project_inner_loop(I,Sz,[ok|Evs],NBase,F,Table,Ent0,Ent) :- !,
I1 is I+1,
Pos is NBase+I*F+1,
arg(Pos,Table,E1),
Ent1 is E1+Ent0,
project_inner_loop(I1,Sz,Evs,NBase,F,Table,Ent1,Ent).
project_inner_loop(I,Sz,[_|Evs],NBase,F,Table,Ent0,Ent) :- !,
I1 is I+1,
project_inner_loop(I1,Sz,Evs,NBase,F,Table,Ent0,Ent).
%
% Given a set of variables Vs0 and a discrete CPT T0,
% reorder according to keysort if Vs is unbound, or according to Vs
% resulting in CPT
% TF. Sizes of variables in Vs are given as Sizes.
%
reorder_CPT(Vs0, T0, Vs, TF, Sizes) :-
var(Vs), !,
get_sizes(Vs0, Szs),
numb_vars(Vs0, Szs, _, VPs0, VLs0),
keysort(VLs0, VLs),
compute_new_factors(VLs, _, Vs, Sizes),
get_factors(VLs0,Fs),
length(T0,L),
functor(TF,t,L),
copy_to_new_array(T0, 0, VPs0, Fs, TF).
reorder_CPT(Vs0, T0, Vs, TF, Sizes) :-
get_sizes(Vs0, Szs),
numb_vars(Vs0, Szs, _, VPs0, VLs0),
sort_according_to_parent(Vs, VLs0, VLs),
compute_new_factors(VLs, _, Vs, Sizes),
get_factors(VLs0,Fs),
length(T0,L),
functor(TF,t,L),
copy_to_new_array(T0, 0, VPs0, Fs, TF).
numb_vars([], [], 1, [], []).
numb_vars([V|Vs], [L|Ls], A0, [Ai|VPs], [V-(L,_)|VLs]) :-
numb_vars(Vs, Ls, Ai, VPs, VLs),
A0 is Ai*L.
sort_according_to_parent([],[], []).
sort_according_to_parent([V|Vs],VLs0, [Arg|VLs]) :-
fetch_var(V,VLs0,VLsI,Arg),
sort_according_to_parent(Vs,VLsI, VLs).
fetch_var(V,[V0-(L,A)|VLs],VLs,V0-(L,A)) :- V == V0, !.
fetch_var(V,[A|VLs0],[A|VLsI],Arg) :-
fetch_var(V,VLs0,VLsI,Arg).
compute_new_factors([], 1, [], []).
compute_new_factors([V-(L,F)|VLs], NF, [V|Vs], [L|Szs]) :-
compute_new_factors(VLs, F, Vs, Szs),
NF is F*L.
get_factors([],[]).
get_factors([_-(_,F)|VLs0],[F|Fs]) :-
get_factors(VLs0,Fs).
copy_to_new_array([], _, _, _, _).
copy_to_new_array([P|Ps], I, F0s, Fs, S) :-
convert_factor(F0s, Fs, I, N),
I1 is I+1,
N1 is N+1,
arg(N1,S,P),
copy_to_new_array(Ps, I1, F0s, Fs, S).
convert_factor([], [], _, 0).
convert_factor([F0|F0s], [F|Fs], I, OUT) :-
X is I//F0,
NI is I mod F0,
NEXT is F*X,
convert_factor(F0s, Fs, NI, OUT1),
OUT is OUT1+NEXT.
get_sizes([], []).
get_sizes([V|Deps], [Sz|Sizes]) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id,Sz),
get_sizes(Deps, Sizes).

71
packages/CLPBN/clpbn/display.yap Normal file
View File

@ -0,0 +1,71 @@
:- module(clpbn_display, [
clpbn_bind_vals/3]).
:- use_module(library(lists),
[
member/2
]).
:- use_module(dists, [get_dist_domain/2]).
:- attribute posterior/4.
%
% what is actually output
%
attribute_goal(V, G) :-
clpbn:suppress_attribute_display(false),
get_atts(V, [posterior(Vs,Vals,Ps,AllDiffs)]),
massage_out(Vs, Vals, Ps, G, AllDiffs, V).
massage_out([], Ev, _, V=Ev, _, V) :- !.
massage_out(Vs, [D], [P], p(CEqs)=P, AllDiffs, _) :- !,
gen_eqs(Vs,D,Eqs),
add_alldiffs(AllDiffs,Eqs,CEqs).
massage_out(Vs, [D|Ds], [P|Ps], (p(CEqs)=P,G) , AllDiffs, V) :-
gen_eqs(Vs,D,Eqs),
add_alldiffs(AllDiffs,Eqs,CEqs),
massage_out(Vs, Ds, Ps, G, AllDiffs, V).
gen_eqs([V], [D], (V=D)) :- !.
gen_eqs([V], D, (V=D)) :- !.
gen_eqs([V|Vs], [D|Ds], ((V=D),Eqs)) :-
gen_eqs(Vs,Ds,Eqs).
add_alldiffs([],Eqs,Eqs).
add_alldiffs(AllDiffs,Eqs,(Eqs/alldiff(AllDiffs))).
clpbn_bind_vals([],[],_).
clpbn_bind_vals([Vs|MoreVs],[Ps|MorePs],AllDiffs) :-
clpbn_bind_vals2(Vs, Ps, AllDiffs),
clpbn_bind_vals(MoreVs,MorePs,AllDiffs).
clpbn_bind_vals2([],_,_) :- !.
% simple case, we want a distribution on a single variable.
%bind_vals([V],Ps) :- !,
% clpbn:get_atts(V, [dist(Vals,_,_)]),
% put_atts(V, posterior([V], Vals, Ps)).
% complex case, we want a joint distribution, do it on a leader.
% should split on cliques ?
clpbn_bind_vals2(Vs,Ps,AllDiffs) :-
get_all_combs(Vs, Vals),
Vs = [V|_],
put_atts(V, posterior(Vs, Vals, Ps, AllDiffs)).
get_all_combs(Vs, Vals) :-
get_all_doms(Vs,Ds),
findall(L,ms(Ds,L),Vals).
get_all_doms([], []).
get_all_doms([V|Vs], [D|Ds]) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain(Id,D),
get_all_doms(Vs, Ds).
ms([], []).
ms([H|L], [El|Els]) :-
member(El,H),
ms(L, Els).

316
packages/CLPBN/clpbn/dists.yap Normal file
View File

@ -0,0 +1,316 @@
%
% routines to manipulate distributions
%
:- module(clpbn_dist,
[
dist/1,
dist/4,
dists/1,
dist_new_table/2,
get_dist/4,
get_dist_matrix/5,
get_possibly_deterministic_dist_matrix/5,
get_dist_domain/2,
get_dist_domain_size/2,
get_dist_params/2,
get_dist_key/2,
get_evidence_position/3,
get_evidence_from_position/3,
dist_to_term/2,
empty_dist/2,
all_dist_ids/1,
randomise_all_dists/0,
randomise_dist/1,
uniformise_all_dists/0,
uniformise_dist/1,
reset_all_dists/0
]).
:- use_module(library(lists),[is_list/1,nth0/3]).
:- use_module(library(matrix),
[matrix_new/4,
matrix_new/3,
matrix_to_list/2,
matrix_to_logs/1]).
:- use_module(library('clpbn/matrix_cpt_utils'),
[random_CPT/2,
uniform_CPT/2]).
/*
:- mode dist(+, -).
:- mode get_dist(+, -, -, -).
:- mode get_dist_params(+, -).
:- mode get_dist_domain_size(+, -).
:- mode get_dist_domain(+, -).
:- mode get_dist_nparams(+, -).
:- mode dist(?).
:- mode dist_to_term(+,-).
*/
/*******************************************
store stuff in a DB of the form:
db(Id, Key, CPT, Type, Domain, CPTSize, DSize)
where Id is the id,
Key is a skeleton of the key(main functor only)
cptsize is the table size or -1,
DSize is the domain size,
Type is
tab for tabular
avg for average
max for maximum
min for minimum
trans for HMMs
continuous
Domain is
a list of values
bool for [t,f]
aminoacids for [a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y]
dna for [a,c,g,t]
rna for [a,c,g,u]
reals
********************************************/
:- dynamic id/1.
id(1).
new_id(Id) :-
retract(id(Id)),
Id1 is Id+1,
assert(id(Id1)).
reset_id :-
retract(id(_)),
assert(id(1)).
dists(X) :- id(X1), X is X1-1.
dist(V, Id, Key, Parents) :-
dist_unbound(V, Culprit), !,
when(Culprit, dist(V, Id, Key, Parents)).
dist(V, Id, Key, Parents) :-
var(Key), !,
when(Key, dist(V, Id, Key, Parents)).
dist(avg(Domain, Parents), avg(Domain), _, Parents).
dist(max(Domain, Parents), max(Domain), _, Parents).
dist(min(Domain, Parents), min(Domain), _, Parents).
dist(p(Type, CPT), Id, Key, FParents) :-
copy_structure(Key, Key0),
distribution(Type, CPT, Id, Key0, [], FParents).
dist(p(Type, CPT, Parents), Id, Key, FParents) :-
copy_structure(Key, Key0),
distribution(Type, CPT, Id, Key0, Parents, FParents).
dist_unbound(V, ground(V)) :-
var(V), !.
dist_unbound(p(Type,_), ground(Type)) :-
\+ ground(Type), !.
dist_unbound(p(_,CPT), ground(CPT)) :-
\+ ground(CPT).
dist_unbound(p(Type,_,_), ground(Type)) :-
\+ ground(Type), !.
dist_unbound(p(_,CPT,_), ground(CPT)) :-
\+ ground(CPT).
distribution(bool, trans(CPT), Id, Key, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist([t,f], trans, Tab, Parents, Key, Id).
distribution(bool, CPT, Id, Key, Parents, Parents) :-
is_list(CPT), !,
add_dist([t,f], tab, CPT, Parents, Key, Id).
distribution(aminoacids, trans(CPT), Id, Key, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist([a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y], trans, Tab, FParents, Key, Id).
distribution(aminoacids, CPT, Id, Key, Parents, Parents) :-
is_list(CPT), !,
add_dist([a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y], tab, CPT, Parents, Key, Id).
distribution(dna, trans(CPT), Key, Id, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist([a,c,g,t], trans, Tab, FParents, Key, Id).
distribution(dna, CPT, Id, Key, Parents, Parents) :-
is_list(CPT), !,
add_dist([a,c,g,t], tab, CPT, Key, Id).
distribution(rna, trans(CPT), Id, Key, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents, FParents),
add_dist([a,c,g,u], trans, Tab, Key, Id).
distribution(rna, CPT, Id, Key, Parents, Parents) :-
is_list(CPT), !,
add_dist([a,c,g,u], tab, CPT, Parents, Key, Id).
distribution(Domain, trans(CPT), Id, Key, Parents, FParents) :-
is_list(Domain),
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist(Domain, trans, Tab, FParents, Key, Id).
distribution(Domain, CPT, Id, Key, Parents, Parents) :-
is_list(Domain),
is_list(CPT), !,
add_dist(Domain, tab, CPT, Parents, Key, Id).
add_dist(Domain, Type, CPT, _, Key, Id) :-
recorded(clpbn_dist_db, db(Id, Key, CPT, Type, Domain, _, _), _), !.
add_dist(Domain, Type, CPT, Parents, Key, Id) :-
length(CPT, CPTSize),
length(Domain, DSize),
new_id(Id),
record_parent_sizes(Parents, Id, PSizes, [DSize|PSizes]),
recordz(clpbn_dist_db,db(Id, Key, CPT, Type, Domain, CPTSize, DSize),_).
record_parent_sizes([], Id, [], DSizes) :-
recordz(clpbn_dist_psizes,db(Id, DSizes),_).
record_parent_sizes([P|Parents], Id, [Size|Sizes], DSizes) :-
clpbn:get_atts(P,dist(Dist,_)), !,
get_dist_domain_size(Dist, Size),
record_parent_sizes(Parents, Id, Sizes, DSizes).
record_parent_sizes([_|_], _, _, _).
%
% Often, * is used to code empty in HMMs.
%
compress_hmm_table([], [], [], []).
compress_hmm_table([*|L],[_|Parents],NL,NParents) :- !,
compress_hmm_table(L,Parents,NL,NParents).
compress_hmm_table([Prob|L],[P|Parents],[Prob|NL],[P|NParents]) :-
compress_hmm_table(L,Parents,NL,NParents).
dist(Id) :-
recorded(clpbn_dist_db, db(Id, _, _, _, _, _, _), _).
get_dist(Id, Type, Domain, Tab) :-
recorded(clpbn_dist_db, db(Id, _, Tab, Type, Domain, _, _), _).
get_dist_matrix(Id, Parents, Type, Domain, Mat) :-
recorded(clpbn_dist_db, db(Id, _, Tab, Type, Domain, _, DomainSize), _),
get_dsizes(Parents, Sizes, []),
matrix_new(floats, [DomainSize|Sizes], Tab, Mat),
matrix_to_logs(Mat).
get_possibly_deterministic_dist_matrix(Id, Parents, Type, Domain, Mat) :-
recorded(clpbn_dist_db, db(Id, _, Tab, Type, Domain, _, DomainSize), _),
get_dsizes(Parents, Sizes, []),
matrix_new(floats, [DomainSize|Sizes], Tab, Mat).
get_dsizes([], Sizes, Sizes).
get_dsizes([P|Parents], [Sz|Sizes], Sizes0) :-
clpbn:get_atts(P,dist(Dist,_)),
get_dist_domain_size(Dist, Sz),
get_dsizes(Parents, Sizes, Sizes0).
get_dist_params(Id, Parms) :-
recorded(clpbn_dist_db, db(Id, _, Parms, _, _, _, _), _).
get_dist_domain_size(avg(D,_), DSize) :- !,
length(D, DSize).
get_dist_domain_size(Id, DSize) :-
recorded(clpbn_dist_db, db(Id, _, _, _, _, _, DSize), _).
get_dist_domain(Id, Domain) :-
recorded(clpbn_dist_db, db(Id, _, _, _, Domain, _, _), _).
get_dist_key(Id, Key) :-
recorded(clpbn_dist_db, db(Id, Key, _, _, _, _, _), _).
get_dist_nparams(Id, NParms) :-
recorded(clpbn_dist_db, db(Id, _, _, _, _, NParms, _), _).
get_evidence_position(El, avg(Domain), Pos) :- !,
nth0(Pos, Domain, El), !.
get_evidence_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, _, Domain, _, _), _),
nth0(Pos, Domain, El), !.
get_evidence_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, _, _, _, _), _), !,
throw(error(domain_error(evidence,Id),get_evidence_position(El, Id, Pos))).
get_evidence_position(El, Id, Pos) :-
throw(error(domain_error(no_distribution,Id),get_evidence_position(El, Id, Pos))).
get_evidence_from_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, _, Domain, _, _), _),
nth0(Pos, Domain, El), !.
get_evidence_from_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, _, _, _, _), _), !,
throw(error(domain_error(evidence,Id),get_evidence_from_position(El, Id, Pos))).
get_evidence_from_position(El, Id, Pos) :-
throw(error(domain_error(no_distribution,Id),get_evidence_from_position(El, Id, Pos))).
dist_to_term(_Id,_Term).
empty_dist(Dist, TAB) :-
recorded(clpbn_dist_psizes,db(Dist, DSizes),_), !,
matrix_new(floats, DSizes, TAB).
empty_dist(Dist, TAB) :-
throw(error(domain_error(no_distribution,Dist),empty_dist(Dist,TAB))).
dist_new_table(Id, NewMat) :-
matrix_to_list(NewMat, List),
recorded(clpbn_dist_db, db(Id, Key, _, A, B, C, D), R),
erase(R),
recorda(clpbn_dist_db, db(Id, Key, List, A, B, C, D), _),
fail.
dist_new_table(_, _).
copy_structure(V, V) :- var(V), !.
copy_structure(V, _) :- primitive(V), !.
copy_structure(Key, Key0) :-
Key =.. [A|LKey],
copy_Lstructure(LKey, LKey0),
Key0 =.. [A|LKey0].
copy_Lstructure([], []).
copy_Lstructure([H|LKey], [NH|LKey0]) :-
copy_structure(H, NH),
copy_Lstructure(LKey, LKey0).
randomise_all_dists :-
randomise_dist(_),
fail.
randomise_all_dists.
randomise_dist(Dist) :-
recorded(clpbn_dist_psizes, db(Dist,DSizes), _),
random_CPT(DSizes, NewCPT),
dist_new_table(Dist, NewCPT).
uniformise_all_dists :-
uniformise_dist(_),
fail.
uniformise_all_dists.
uniformise_dist(Dist) :-
recorded(clpbn_dist_psizes, db(Dist,DSizes), _),
uniform_CPT(DSizes, NewCPT),
dist_new_table(Dist, NewCPT).
reset_all_dists :-
recorded(clpbn_dist_psizes, _, R),
erase(R),
fail.
reset_all_dists :-
recorded(clpbn_dist_db, _, R),
erase(R),
fail.
reset_all_dists :-
reset_id,
fail.
reset_all_dists.

136
packages/CLPBN/clpbn/evidence.yap Normal file
View File

@ -0,0 +1,136 @@
%
%
%
%
:- module(clpbn_evidence,
[
store_evidence/1,
incorporate_evidence/2,
check_stored_evidence/2,
add_evidence/2,
put_evidence/2
]).
:- use_module(library(clpbn), [
{}/1,
clpbn_flag/3,
set_clpbn_flag/2
]).
:- use_module(library('clpbn/dists'), [
get_evidence_position/3
]).
:- use_module(library(rbtrees), [
rb_new/1,
rb_lookup/3,
rb_insert/4
]).
:- meta_predicate store_evidence(:).
:- dynamic node/4, edge/2, evidence/2.
%
% new evidence storage algorithm. The idea is that instead of
% redoing all the evidence every time we query the network, we shall
% keep a precompiled version around.
%
% the format is as follows:
% evidence_store:parent(Key,ParentList,[EvidenceChildren])
%
%
store_evidence(G) :-
clpbn_flag(solver,PreviousSolver, graphs),
compute_evidence(G, PreviousSolver).
compute_evidence(G, PreviousSolver) :-
catch(call_residue(G, Vars), Ball, evidence_error(Ball,PreviousSolver)), !,
store_graph(Vars),
set_clpbn_flag(solver, PreviousSolver).
compute_evidence(_,PreviousSolver) :-
set_clpbn_flag(solver, PreviousSolver).
evidence_error(Ball,PreviousSolver) :-
set_clpbn_flag(solver,PreviousSolver),
throw(Ball).
store_graph([]).
store_graph([_-node(K,Dom,CPT,TVs,Ev)|Vars]) :-
\+ node(K,_,_,_), !,
assert(node(K,Dom,CPT,TVs)),
( nonvar(Ev) -> assert(evidence(K,Ev)) ; true),
add_links(TVs,K),
store_graph(Vars).
store_graph([_|Vars]) :-
store_graph(Vars).
add_links([],_).
add_links([K0|TVs],K) :-
assert(edge(K,K0)),
add_links(TVs,K).
incorporate_evidence(Vs,AllVs) :-
rb_new(Cache0),
create_open_list(Vs, OL, FL, Cache0, CacheI),
do_variables(OL, FL, CacheI),
extract_vars(OL, AllVs).
create_open_list([], L, L, C, C).
create_open_list([V|Vs], [K-V|OL], FL, C0, CF) :-
clpbn:get_atts(V,[key(K)]),
add_evidence(K, V),
rb_insert(C0, K, V, CI),
create_open_list(Vs, OL, FL, CI, CF).
do_variables([], [], _) :- !.
do_variables([K-V|Vs], Vf, C0) :-
check_for_evidence(K, V, Vf, Vff, C0, Ci),
do_variables(Vs, Vff, Ci).
create_new_variable(K, V, Vf0, Vff, C0, Cf) :-
node(K,Dom, CPT, TVs),
{ V = K with p(Dom, CPT, NTVs) },
add_evidence(K, V),
add_variables(TVs, NTVs, Vf0, Vff, C0, Cf).
add_variables([], [], Vf, Vf, C, C).
add_variables([K|TVs], [V|NTVs], Vf0, Vff, C0, Cf) :-
rb_lookup(K, V, C0), !,
add_variables(TVs, NTVs, Vf0, Vff, C0, Cf).
add_variables([K|TVs], [V|NTVs], [K-V|Vf0], Vff, C0, Cf) :-
rb_insert(C0, K, V, C1),
create_new_variable(K, V, Vf0, Vf1, C1, C2),
add_variables(TVs, NTVs, Vf1, Vff, C2, Cf).
extract_vars([], []).
extract_vars([_-V|Cache], [V|AllVs]) :-
extract_vars(Cache, AllVs).
%make sure that we are
check_stored_evidence(K, Ev) :-
evidence(K, Ev0), !, Ev0 = Ev.
check_stored_evidence(_, _).
add_evidence(K, V) :-
evidence(K, Ev), !,
clpbn:put_atts(V, [evidence(Ev)]).
add_evidence(_, _).
check_for_evidence(_, V, Vf, Vf, C, C) :-
clpbn:get_atts(V, [evidence(_)]), !.
check_for_evidence(K, _, Vf0, Vff, C0, Ci) :-
findall(Rt,edge(Rt,K),Rts),
add_variables(Rts, _, Vf0, Vff, C0, Ci).
put_evidence(K, V) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_evidence_position(K, Id, Ev),
clpbn:put_atts(V, [evidence(Ev)]).

53
packages/CLPBN/clpbn/examples/School/README Normal file
View File

@ -0,0 +1,53 @@
This is a version of the school database, based on the PRM School example.
There are four main files:
school_128.yap: a school with 128 professors, 256 courses and 4096 students.
school_64.yap: medium size school
school_32.yap: small school
schema.yap: the schema
tables: CPTs
professor_ability(p0,X).
professor_popularity(p0,X).
professor_ability(p0,X), professor_popularity(p0,h).
professor_ability(p0,h), professor_popularity(p0,X).
registration_grade(r0,X).
registration_grade(r0,X), registration_course(r0,C), course_difficulty(C,h).
registration_grade(r0,X), registration_course(r0,C), course_difficulty(C,h), registration_student(r0,S), student_intelligence(S,h).
registration_grade(r0,X), registration_course(r0,C), course_difficulty(C,l), registration_student(r0,S), student_intelligence(S,h).
registration_satisfaction(r0,X).
registration_satisfaction(r0,X), registration_student(r0,S), student_intelligence(S,h).
registration_satisfaction(r0,X), registration_grade(r0,a).
registration_satisfaction(r0,X), registration_grade(r0,d).
registration_satisfaction(r0,h), registration_grade(r0,X).
course_rating(c0,X).
course_rating(c0,h), course_difficulty(c0,X).
course_difficulty(c0,X).
student_ranking(s0,X).
student_ranking(s0,X), student_intelligence(s0,h).

17
packages/CLPBN/clpbn/examples/School/evidence_128.yap Normal file
View File

@ -0,0 +1,17 @@
:- [school_128].
professor_popularity(p0,h) :- {}.
professor_popularity(p3,h) :- {}.
professor_popularity(p5,l) :- {}.
professor_popularity(p45,h) :- {}.
professor_popularity(p15,m) :- {}.
course_rating(c0, h) :- {}.
course_rating(c1, m) :- {}.
course_rating(c2, l) :- {}.
course_rating(c3, h) :- {}.
course_rating(c4, m) :- {}.
course_rating(c5, l) :- {}.
course_rating(c62, m) :- {}.

44
packages/CLPBN/clpbn/examples/School/parlearn.yap Normal file
View File

@ -0,0 +1,44 @@
:- [pos:sample32].
:- ['~/Yap/work/CLPBN/clpbn/examples/School/school_32'].
% These libraries provide same functionality.
:- [library('clpbn/learning/mle')].
%:- [library('clpbn/learning/bnt_parms')].
:- [library(matrix)].
main :-
findall(X,goal(X),L),
learn_parameters(L,CPTs),
write_cpts(CPTs).
goal(professor_ability(P,V)) :-
pos:professor_ability(P,V),
p(pa, M), random < M.
goal(professor_popularity(P,V)) :-
pos:professor_popularity(P,V),
p(pp, M), random < M.
goal(registration_grade(P,V)) :-
pos:registration_grade(P,V),
p(rg, M), random < M.
goal(student_intelligence(P,V)) :-
pos:student_intelligence(P,V),
p(si, M), random < M.
goal(course_difficulty(P,V)) :-
pos:course_difficulty(P,V),
p(cd, M), random < M.
goal(registration_satisfaction(P,V)) :-
pos:registration_satisfaction(P,V),
p(rs, M), random < M.
% sampling parameter
p(_, 1.0).
write_cpts([]).
write_cpts([CPT|CPTs]) :-
matrix_to_list(CPT,L),
format('CPT=~w~n',[L]),
write_cpts(CPTs).

2433
packages/CLPBN/clpbn/examples/School/sample32.yap Normal file
View File

File diff suppressed because it is too large Load Diff

71
packages/CLPBN/clpbn/examples/School/schema.yap Normal file
View File

@ -0,0 +1,71 @@
/* base file for school database. Supposed to be called from school_*.yap */
professor_key(Key) :-
professor(Key).
professor_ability(Key,Abi) :-
abi_table(Key, AbiDist),
{ Abi = ability(Key) with p([h,m,l], AbiDist) }.
professor_popularity(Key, Pop) :-
professor_ability(Key, Abi),
pop_table(Key,PopTable),
{ Pop = popularity(Key) with
p([h,m,l], PopTable,[Abi]) }.
registration_key(Key) :-
registration(Key, _, _).
registration_course(Key, CKey) :-
registration(Key, CKey, _).
registration_student(Key, SKey) :-
registration(Key, _, SKey).
registration_grade(Key, Grade) :-
registration(Key, CKey, SKey),
course_difficulty(CKey, Dif),
student_intelligence(SKey, Int),
grade_table(Int, Dif, Table),
{ Grade = grade(Key) with Table }.
% registration_satisfaction(r0, h) :- {}.
registration_satisfaction(Key, Sat) :-
registration_course(Key, CKey),
course_professor(CKey, PKey),
professor_ability(PKey, Abi),
registration_grade(Key, Grade),
satisfaction_table(Abi, Grade, Table),
{ Sat = satisfaction(Key) with Table }.
course_key(Key) :-
course(Key,_).
course_professor(Key, PKey) :-
course(Key, PKey).
course_rating(CKey, Rat) :-
setof(Sat, RKey^(registration_course(RKey,CKey), registration_satisfaction(RKey,Sat)), Sats),
{ Rat = rating(CKey) with avg([h,m,l],Sats) }.
course_difficulty(Key, Dif) :-
dif_table(Key, Dist),
{ Dif = difficulty(Key) with p([h,m,l], Dist) }.
student_key(Key) :-
student(Key).
student_intelligence(Key, Int) :-
int_table(Key, IDist, Domain),
{ Int = intelligence(Key) with p(Domain, IDist) }.
student_ranking(Key, Rank) :-
setof(Grade, CKey^(registration_student(CKey,Key),
registration_grade(CKey, Grade)), Grades),
{ Rank = ranking(Key) with avg([a,b,c,d],Grades) }.
:- ensure_loaded(tables).

18432
packages/CLPBN/clpbn/examples/School/school_128.yap Normal file
View File

File diff suppressed because it is too large Load Diff

1238
packages/CLPBN/clpbn/examples/School/school_32.yap Normal file
View File

File diff suppressed because it is too large Load Diff

4706
packages/CLPBN/clpbn/examples/School/school_64.yap Normal file
View File

File diff suppressed because it is too large Load Diff

45
packages/CLPBN/clpbn/examples/School/tables.yap Normal file
View File

@ -0,0 +1,45 @@
int_table(_, [0.5,
0.4,
0.1],[h, m, l]).
grade_table(I, D,
/* h h h m h l m h m m m l l h l m l l */
p([a,b,c,d],
[ 0.2, 0.7, 0.85, 0.1, 0.2, 0.5, 0.01, 0.05,0.1 ,
0.6, 0.25, 0.12, 0.3, 0.6,0.35,0.04, 0.15, 0.4 ,
0.15,0.04, 0.02, 0.4,0.15,0.12, 0.5, 0.6, 0.4,
0.05,0.01, 0.01, 0.2,0.05,0.03, 0.45, 0.2, 0.1 ], [I,D])).
/*
A: professor's ability;
B: student's grade (for course registration).
*/
satisfaction_table(A, G,
/* h a h b h c h d m a m b m c m d l a l b l c l d */
p([h,m,l],
/*h*/ [0.98, 0.9,0.8 , 0.6, 0.9, 0.4, 0.2, 0.01, 0.5, 0.2, 0.01, 0.01,
/*m*/ 0.01, 0.09,0.15, 0.3,0.05, 0.4, 0.3, 0.04,0.35, 0.3, 0.09, 0.01 ,
/*l*/ 0.01, 0.01,0.05, 0.1,0.05, 0.2, 0.5, 0.95,0.15, 0.5, 0.9, 0.98], [A,G])).
% The idea is quite simple:
% hs = h -> r = ( 0.9, 0.1, 0)
% hs = m -> r = ( 0.2, 0.6, 0.2)
% hs = l -> r = ( 0, 0.1, 0.9)
%
% add all and divide on the number of elements on the table!
%
rating_prob_table([0.9,0.05,0.01,
0.09,0.9,0.09,
0.01,0.05,0.9]).
abi_table( _, [0.50, 0.40, 0.10]).
pop_table(_, [0.9, 0.2, 0.01,
0.09, 0.6, 0.09,
0.01, 0.2, 0.9]).
dif_table( _, [0.25, 0.50, 0.25]).

35
packages/CLPBN/clpbn/examples/cg.yap Normal file
View File

@ -0,0 +1,35 @@
%
% adapted from Hendrik Blockeel's ILP04 paper.
%
:- use_module(library(clpbn)).
cg(X,1,C):-
father(Y,X),
cg(Y,1,C1),cg(Y,2,C2),
parent_cpt(cg(X,1), C1, C2, C).
cg(X,2,C):-
mother(Y,X),
cg(Y,1,C1),cg(Y,2,C2),
parent_cpt(cg(X,2), C1, C2, C).
cg(f,X,C) :-
prior_cpt(cg(f,X),C).
cg(m,X,C) :-
prior_cpt(cg(m,X),C).
prior_cpt(CKEY, C) :-
{ C = CKEY with p([p,w], [0.5,0.5])}.
parent_cpt(CKEY, C1, C2, C) :-
{ C = CKEY with p([p,w], [ 1,0.5,0.5,0.0,
0.0,0.5,0.5, 1],[C1,C2])}.
father(f,s).
mother(m,s).

31
packages/CLPBN/clpbn/examples/sprinkler.yap Normal file
View File

@ -0,0 +1,31 @@
:- ensure_loaded(library(clpbn)).
wet_grass(W) :-
sprinkler(S),
rain(R),
{ W = wet with p([f,t],
([1.0,0.1,0.1,0.01,
0.0,0.9,0.9,0.99]),
[S,R])
}.
sprinkler(P) :-
cloudy(C),
{ P = sprinkler with p([f,t],
[0.5,0.9,
0.5,0.1],
[C])
}.
rain(R) :-
cloudy(C),
{ R = rain with p([f,t], [0.8,0.2,
0.2,0.8],
[C]) }.
cloudy(C) :-
{ C = cloudy with p([f,t],[0.5,0.5],[]) }.

546
packages/CLPBN/clpbn/gibbs.yap Normal file
View File

@ -0,0 +1,546 @@
%
% each variable is represented by a node in a binary tree.
% each node contains:
% key,
% current_value
% Markov Blanket
%
:- module(clpbn_gibbs,
[gibbs/3,
check_if_gibbs_done/1,
init_gibbs_solver/4,
run_gibbs_solver/3]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_insert/4,
rb_lookup/3]).
:- use_module(library(lists),
[member/2,
append/3,
delete/3,
max_list/2,
sum_list/2]).
:- use_module(library(ordsets),
[ord_subtract/3]).
:- use_module(library('clpbn/matrix_cpt_utils'), [
project_from_CPT/3,
reorder_CPT/5,
multiply_possibly_deterministic_factors/3,
column_from_possibly_deterministic_CPT/3,
normalise_possibly_deterministic_CPT/2,
list_from_CPT/2]).
:- use_module(library('clpbn/utils'), [
check_for_hidden_vars/3]).
:- use_module(library('clpbn/dists'), [
get_possibly_deterministic_dist_matrix/5,
get_dist_domain_size/2]).
:- use_module(library('clpbn/topsort'), [
topsort/2]).
:- use_module(library('clpbn/display'), [
clpbn_bind_vals/3]).
:- use_module(library('clpbn/connected'),
[
influences/4
]).
:- dynamic gibbs_params/3.
:- dynamic explicit/1.
% arguments:
%
% list of output variables
% list of attributed variables
%
gibbs(LVs,Vs0,AllDiffs) :-
init_gibbs_solver(LVs, Vs0, AllDiffs, Vs),
run_gibbs_solver(LVs, LPs, Vs),
clpbn_bind_vals(LVs,LPs,AllDiffs),
clean_up.
init_gibbs_solver(GoalVs, Vs0, _, Vs) :-
clean_up,
term_variables(GoalVs, LVs),
check_for_hidden_vars(Vs0, Vs0, Vs1),
influences(Vs1, LVs, _, Vs2),
sort(Vs2,Vs).
run_gibbs_solver(LVs, LPs, Vs) :-
initialise(Vs, Graph, LVs, OutputVars, VarOrder),
process(VarOrder, Graph, OutputVars, Estimates),
sum_up_all(Estimates, LPs),
clean_up.
initialise(LVs, Graph, GVs, OutputVars, VarOrder) :-
init_keys(Keys0),
gen_keys(LVs, 0, VLen, Keys0, Keys),
functor(Graph,graph,VLen),
graph_representation(LVs, Graph, 0, Keys, TGraph),
compile_graph(Graph),
topsort(TGraph, VarOrder),
%writeln(TGraph:VarOrder),
% show_sorted(VarOrder, Graph),
add_all_output_vars(GVs, Keys, OutputVars).
init_keys(Keys0) :-
rb_new(Keys0).
gen_keys([], I, I, Keys, Keys).
gen_keys([V|Vs], I0, If, Keys0, Keys) :-
clpbn:get_atts(V,[evidence(_)]), !,
gen_keys(Vs, I0, If, Keys0, Keys).
gen_keys([V|Vs], I0, If, Keys0, Keys) :-
I is I0+1,
rb_insert(Keys0,V,I,KeysI),
gen_keys(Vs, I, If, KeysI, Keys).
graph_representation([],_,_,_,[]).
graph_representation([V|Vs], Graph, I0, Keys, TGraph) :-
clpbn:get_atts(V,[evidence(_)]), !,
clpbn:get_atts(V, [dist(Id,Parents)]),
get_possibly_deterministic_dist_matrix(Id, Parents, _, Vals, Table),
get_sizes(Parents, Szs),
length(Vals,Sz),
project_evidence_out([V|Parents],[V|Parents],Table,[Sz|Szs],Variables,NewTable),
% all variables are parents
propagate2parents(Variables, NewTable, Variables, Graph, Keys),
graph_representation(Vs, Graph, I0, Keys, TGraph).
graph_representation([V|Vs], Graph, I0, Keys, [I-IParents|TGraph]) :-
I is I0+1,
clpbn:get_atts(V, [dist(Id,Parents)]),
get_possibly_deterministic_dist_matrix(Id, Parents, _, Vals, Table),
get_sizes(Parents, Szs),
length(Vals,Sz),
project_evidence_out([V|Parents],[V|Parents],Table,[Sz|Szs],Variables,NewTable),
Variables = [V|NewParents],
sort_according_to_indices(NewParents,Keys,SortedNVs,SortedIndices),
reorder_CPT(Variables,NewTable,[V|SortedNVs],NewTable2,_),
add2graph(V, Vals, NewTable2, SortedIndices, Graph, Keys),
propagate2parents(NewParents, NewTable, Variables, Graph,Keys),
parent_indices(NewParents, Keys, IVariables0),
sort(IVariables0, IParents),
arg(I, Graph, var(_,_,_,_,_,_,_,NewTable2,SortedIndices)),
graph_representation(Vs, Graph, I, Keys, TGraph).
write_pars([]).
write_pars([V|Parents]) :-
clpbn:get_atts(V, [key(K),dist(I,_)]),write(K:I),nl,
write_pars(Parents).
get_sizes([], []).
get_sizes([V|Parents], [Sz|Szs]) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id, Sz),
get_sizes(Parents, Szs).
parent_indices([], _, []).
parent_indices([V|Parents], Keys, [I|IParents]) :-
rb_lookup(V, I, Keys),
parent_indices(Parents, Keys, IParents).
%
% first, remove nodes that have evidence from tables.
%
project_evidence_out([],Deps,Table,_,Deps,Table).
project_evidence_out([V|Parents],Deps,Table,Szs,NewDeps,NewTable) :-
clpbn:get_atts(V,[evidence(_)]), !,
project_from_CPT(V,tab(Table,Deps,Szs),tab(ITable,IDeps,ISzs)),
project_evidence_out(Parents,IDeps,ITable,ISzs,NewDeps,NewTable).
project_evidence_out([_Par|Parents],Deps,Table,Szs,NewDeps,NewTable) :-
project_evidence_out(Parents,Deps,Table,Szs,NewDeps,NewTable).
propagate2parents([], _, _, _, _).
propagate2parents([V|NewParents], Table, Variables, Graph, Keys) :-
delete(Variables,V,NVs),
sort_according_to_indices(NVs,Keys,SortedNVs,SortedIndices),
reorder_CPT(Variables,Table,[V|SortedNVs],NewTable,_),
add2graph(V, _, NewTable, SortedIndices, Graph, Keys),
propagate2parents(NewParents,Table, Variables, Graph, Keys).
add2graph(V, Vals, Table, IParents, Graph, Keys) :-
rb_lookup(V, Index, Keys),
(var(Vals) -> true ; length(Vals,Sz)),
arg(Index, Graph, var(V,Index,_,Vals,Sz,VarSlot,_,_,_)),
member(tabular(Table,Index,IParents), VarSlot), !.
sort_according_to_indices(NVs,Keys,SortedNVs,SortedIndices) :-
vars2indices(NVs,Keys,ToSort),
keysort(ToSort, Sorted),
split_parents(Sorted, SortedNVs,SortedIndices).
split_parents([], [], []).
split_parents([I-V|Sorted], [V|SortedNVs],[I|SortedIndices]) :-
split_parents(Sorted, SortedNVs, SortedIndices).
vars2indices([],_,[]).
vars2indices([V|Parents],Keys,[I-V|IParents]) :-
rb_lookup(V, I, Keys),
vars2indices(Parents,Keys,IParents).
%
% This is the really cool bit.
%
compile_graph(Graph) :-
Graph =.. [_|VarsInfo],
compile_vars(VarsInfo,Graph).
compile_vars([],_).
compile_vars([var(_,I,_,Vals,Sz,VarSlot,Parents,_,_)|VarsInfo],Graph)
:-
compile_var(I,Vals,Sz,VarSlot,Parents,Graph),
compile_vars(VarsInfo,Graph).
compile_var(I,Vals,Sz,VarSlot,Parents,Graph) :-
fetch_all_parents(VarSlot,Graph,[],Parents,[],Sizes),
mult_list(Sizes,1,TotSize),
compile_var(TotSize,I,Vals,Sz,VarSlot,Parents,Sizes,Graph).
fetch_all_parents([],_,Parents,Parents,Sizes,Sizes) :- !.
fetch_all_parents([tabular(_,_,Ps)|CPTs],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
merge_these_parents(Ps,Graph,Parents0,ParentsI,Sizes0,SizesI),
fetch_all_parents(CPTs,Graph,ParentsI,ParentsF,SizesI,SizesF).
merge_these_parents([],_,Parents,Parents,Sizes,Sizes).
merge_these_parents([I|Ps],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
member(I,Parents0), !,
merge_these_parents(Ps,Graph,Parents0,ParentsF,Sizes0,SizesF).
merge_these_parents([I|Ps],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
arg(I,Graph,var(_,I,_,Vals,_,_,_,_,_)),
length(Vals, Sz),
add_parent(Parents0,I,ParentsI,Sizes0,Sz,SizesI),
merge_these_parents(Ps,Graph,ParentsI,ParentsF,SizesI,SizesF).
add_parent([],I,[I],[],Sz,[Sz]).
add_parent([P|Parents0],I,[I,P|Parents0],Sizes0,Sz,[Sz|Sizes0]) :-
P > I, !.
add_parent([P|Parents0],I,[P|ParentsI],[S|Sizes0],Sz,[S|SizesI]) :-
add_parent(Parents0,I,ParentsI,Sizes0,Sz,SizesI).
mult_list([],Mult,Mult).
mult_list([Sz|Sizes],Mult0,Mult) :-
MultI is Sz*Mult0,
mult_list(Sizes,MultI,Mult).
% compile node as set of facts, faster execution
compile_var(TotSize,I,_Vals,Sz,CPTs,Parents,_Sizes,Graph) :-
TotSize < 1024*64, TotSize > 0, !,
multiply_all(I,Parents,CPTs,Sz,Graph).
% do it dynamically
compile_var(_,_,_,_,_,_,_,_).
multiply_all(I,Parents,CPTs,Sz,Graph) :-
markov_blanket_instance(Parents,Graph,Values),
(
multiply_all(CPTs,Graph,Probs)
->
store_mblanket(I,Values,Probs)
;
throw(error(domain_error(bayesian_domain),gibbs_cpt(I,Parents,Values,Sz)))
),
fail.
multiply_all(I,_,_,_,_) :-
assert(explicit(I)).
% note: what matters is how this predicate instantiates the temp
% slot in the graph!
markov_blanket_instance([],_,[]).
markov_blanket_instance([I|Parents],Graph,[Pos|Values]) :-
arg(I,Graph,var(_,I,Pos,Vals,_,_,_,_,_)),
fetch_val(Vals,0,Pos),
markov_blanket_instance(Parents,Graph,Values).
% backtrack through every value in domain
%
fetch_val([_|_],Pos,Pos).
fetch_val([_|Vals],I0,Pos) :-
I is I0+1,
fetch_val(Vals,I,Pos).
multiply_all([tabular(Table,_,Parents)|CPTs],Graph,Probs) :-
fetch_parents(Parents, Graph, Vals),
column_from_possibly_deterministic_CPT(Table,Vals,Probs0),
multiply_more(CPTs,Graph,Probs0,Probs).
fetch_parents([], _, []).
fetch_parents([P|Parents], Graph, [Val|Vals]) :-
arg(P,Graph,var(_,_,Val,_,_,_,_,_,_)),
fetch_parents(Parents, Graph, Vals).
multiply_more([],_,Probs0,LProbs) :-
normalise_possibly_deterministic_CPT(Probs0, Probs),
list_from_CPT(Probs, LProbs0),
accumulate_up_list(LProbs0, 0.0, LProbs).
multiply_more([tabular(Table,_,Parents)|CPTs],Graph,Probs0,Probs) :-
fetch_parents(Parents, Graph, Vals),
column_from_possibly_deterministic_CPT(Table, Vals, P0),
multiply_possibly_deterministic_factors(Probs0, P0, ProbsI),
multiply_more(CPTs,Graph,ProbsI,Probs).
accumulate_up_list([], _, []).
accumulate_up_list([P|LProbs], P0, [P1|L]) :-
P1 is P0+P,
accumulate_up_list(LProbs, P1, L).
store_mblanket(I,Values,Probs) :-
recordz(mblanket,m(I,Values,Probs),_).
add_all_output_vars([], _, []).
add_all_output_vars([Vs|LVs], Keys, [Is|OutputVars]) :-
add_output_vars(Vs, Keys, Is),
add_all_output_vars(LVs, Keys, OutputVars).
add_output_vars([], _, []).
add_output_vars([V|LVs], Keys, [I|OutputVars]) :-
rb_lookup(V, I, Keys),
add_output_vars(LVs, Keys, OutputVars).
process(VarOrder, Graph, OutputVars, Estimates) :-
gibbs_params(NChains,BurnIn,NSamples),
functor(Graph,_,Len),
init_chains(NChains,VarOrder,Len,Graph,Chains0),
init_estimates(NChains,OutputVars,Graph,Est0),
process_chains(BurnIn,VarOrder,BurnedIn,Chains0,Graph,Len,Est0,_),
process_chains(NSamples,VarOrder,_,BurnedIn,Graph,Len,Est0,Estimates).
%
% I use an uniform distribution to generate the initial sample.
%
init_chains(0,_,_,_,[]) :- !.
init_chains(I,VarOrder,Len,Graph,[Chain|Chains]) :-
init_chain(VarOrder,Len,Graph,Chain),
I1 is I-1,
init_chains(I1,VarOrder,Len,Graph,Chains).
init_chain(VarOrder,Len,Graph,Chain) :-
functor(Chain,sample,Len),
gen_sample(VarOrder,Graph,Chain).
gen_sample([],_,_) :- !.
gen_sample([I|Vs],Graph,Chain) :-
arg(I,Graph,var(_,I,_,_,Sz,_,_,_,_)),
Pos is integer(random*Sz),
arg(I,Chain,Pos),
gen_sample(Vs,Graph,Chain).
init_estimates(0,_,_,[]) :- !.
init_estimates(NChains,OutputVars,Graph,[Est|Est0]) :-
NChainsI is NChains-1,
init_estimate_all_outvs(OutputVars,Graph,Est),
init_estimates(NChainsI,OutputVars,Graph,Est0).
init_estimate_all_outvs([],_,[]).
init_estimate_all_outvs([Vs|OutputVars],Graph,[E|Est]) :-
init_estimate(Vs, Graph, E),
init_estimate_all_outvs(OutputVars,Graph,Est).
init_estimate([],_,[]).
init_estimate([V],Graph,[I|E0L]) :- !,
arg(V,Graph,var(_,I,_,_,Sz,_,_,_,_)),
gen_e0(Sz,E0L).
init_estimate(Vs,Graph,me(Is,Mults,Es)) :-
generate_est_mults(Vs, Is, Graph, Mults, Sz),
gen_e0(Sz,Es).
generate_est_mults([], [], _, [], 1).
generate_est_mults([V|Vs], [I|Is], Graph, [M0|Mults], M) :-
arg(V,Graph,var(_,I,_,_,Sz,_,_,_,_)),
generate_est_mults(Vs, Is, Graph, Mults, M0),
M is M0*Sz.
gen_e0(0,[]) :- !.
gen_e0(Sz,[0|E0L]) :-
Sz1 is Sz-1,
gen_e0(Sz1,E0L).
process_chains(0,_,F,F,_,_,Est,Est) :- !.
process_chains(ToDo,VarOrder,End,Start,Graph,Len,Est0,Estf) :-
%format('ToDo = ~d~n',[ToDo]),
process_chains(Start,VarOrder,Int,Graph,Len,Est0,Esti),
% (ToDo mod 100 =:= 1 -> statistics,cvt2problist(Esti, Probs), Int =[S|_], format('did ~d: ~w~n ~w~n',[ToDo,Probs,S]) ; true),
ToDo1 is ToDo-1,
process_chains(ToDo1,VarOrder,End,Int,Graph,Len,Esti,Estf).
process_chains([], _, [], _, _,[],[]).
process_chains([Sample0|Samples0], VarOrder, [Sample|Samples], Graph, SampLen,[E0|E0s],[Ef|Efs]) :-
functor(Sample,sample,SampLen),
do_sample(VarOrder,Sample,Sample0,Graph),
% format('Sample = ~w~n',[Sample]),
update_estimates(E0,Sample,Ef),
process_chains(Samples0, VarOrder, Samples, Graph, SampLen,E0s,Efs).
do_sample([],_,_,_).
do_sample([I|VarOrder],Sample,Sample0,Graph) :-
do_var(I,Sample,Sample0,Graph),
do_sample(VarOrder,Sample,Sample0,Graph).
do_var(I,Sample,Sample0,Graph) :-
( explicit(I) ->
arg(I,Graph,var(_,_,_,_,_,_,Parents,_,_)),
fetch_parents(Parents,I,Sample,Sample0,Args),
recorded(mblanket,m(I,Args,Vals),_)
;
arg(I,Graph,var(_,_,_,_,_,CPTs,Parents,_,_)),
fetch_parents(Parents,I,Sample,Sample0,Bindings),
multiply_all_in_context(Parents,Bindings,CPTs,Graph,Vals)
),
X is random,
pick_new_value(Vals,X,0,Val),
arg(I,Sample,Val).
multiply_all_in_context(Parents,Args,CPTs,Graph,Vals) :-
set_pos(Parents,Args,Graph),
multiply_all(CPTs,Graph,Vals),
assert(mall(Vals)), fail.
multiply_all_in_context(_,_,_,_,Vals) :-
retract(mall(Vals)).
set_pos([],[],_).
set_pos([I|Is],[Pos|Args],Graph) :-
arg(I,Graph,var(_,I,Pos,_,_,_,_,_,_)),
set_pos(Is,Args,Graph).
fetch_parents([],_,_,_,[]).
fetch_parents([P|Parents],I,Sample,Sample0,[VP|Args]) :-
arg(P,Sample,VP),
nonvar(VP), !,
fetch_parents(Parents,I,Sample,Sample0,Args).
fetch_parents([P|Parents],I,Sample,Sample0,[VP|Args]) :-
arg(P,Sample0,VP),
fetch_parents(Parents,I,Sample,Sample0,Args).
pick_new_value([V|Vals],X,I0,Val) :-
( X < V ->
Val = I0
;
I is I0+1,
pick_new_value(Vals,X,I,Val)
).
update_estimates([],_,[]).
update_estimates([Est|E0],Sample,[NEst|Ef]) :-
update_estimate(Est,Sample,NEst),
update_estimates(E0,Sample,Ef).
update_estimate([I|E],Sample,[I|NE]) :-
arg(I,Sample,V),
update_estimate_for_var(V,E,NE).
update_estimate(me(Is,Mult,E),Sample,me(Is,Mult,NE)) :-
get_estimate_pos(Is, Sample, Mult, 0, V),
update_estimate_for_var(V,E,NE).
get_estimate_pos([], _, [], V, V).
get_estimate_pos([I|Is], Sample, [M|Mult], V0, V) :-
arg(I,Sample,VV),
VI is VV*M+V0,
get_estimate_pos(Is, Sample, Mult, VI, V).
update_estimate_for_var(V0,[X|T],[X1|NT]) :-
( V0 == 0 ->
X1 is X+1,
NT = T
;
V1 is V0-1,
X1 = X,
update_estimate_for_var(V1,T,NT)
).
check_if_gibbs_done(Var) :-
get_atts(Var, [dist(_)]), !.
clean_up :-
eraseall(mblanket),
fail.
clean_up :-
retractall(explicit(_)),
fail.
clean_up.
gibbs_params(5,1000,10000).
cvt2problist([], []).
cvt2problist([[[_|E]]|Est0], [Ps|Probs]) :-
sum_all(E,0,Sum),
do_probs(E,Sum,Ps),
cvt2problist(Est0, Probs) .
sum_all([],Sum,Sum).
sum_all([E|Es],S0,Sum) :-
SI is S0+E,
sum_all(Es,SI,Sum).
do_probs([],_,[]).
do_probs([E|Es],Sum,[P|Ps]) :-
P is E/Sum,
do_probs(Es,Sum,Ps).
show_sorted([], _) :- nl.
show_sorted([I|VarOrder], Graph) :-
arg(I,Graph,var(V,I,_,_,_,_,_,_,_)),
clpbn:get_atts(V,[key(K)]),
format('~w ',[K]),
show_sorted(VarOrder, Graph).
sum_up_all([[]|_], []).
sum_up_all([[C|MoreC]|Chains], [Dist|Dists]) :-
extract_sums(Chains, CurrentChains, LeftChains),
sum_up([C|CurrentChains], Dist),
sum_up_all([MoreC|LeftChains], Dists).
extract_sums([], [], []).
extract_sums([[C|Chains]|MoreChains], [C|CurrentChains], [Chains|LeftChains]) :-
extract_sums(MoreChains, CurrentChains, LeftChains).
sum_up([[_|Counts]|Chains], Dist) :-
add_up(Counts,Chains, Add),
normalise(Add, Dist).
sum_up([me(_,_,Counts)|Chains], Dist) :-
add_up_mes(Counts,Chains, Add),
normalise(Add, Dist).
add_up(Counts,[],Counts).
add_up(Counts,[[_|Cs]|Chains], Add) :-
sum_lists(Counts, Cs, NCounts),
add_up(NCounts, Chains, Add).
add_up_mes(Counts,[],Counts).
add_up_mes(Counts,[me(_,_,Cs)|Chains], Add) :-
sum_lists(Counts, Cs, NCounts),
add_up_mes(NCounts, Chains, Add).
sum_lists([],[],[]).
sum_lists([Count|Counts], [C|Cs], [NC|NCounts]) :-
NC is Count+C,
sum_lists(Counts, Cs, NCounts).
normalise(Add, Dist) :-
sum_list(Add, Sum),
divide_list(Add, Sum, Dist).
divide_list([], _, []).
divide_list([C|Add], Sum, [P|Dist]) :-
P is C/Sum,
divide_list(Add, Sum, Dist).

43
packages/CLPBN/clpbn/graphs.yap Normal file
View File

@ -0,0 +1,43 @@
%
% Just output a graph with all the variables.
%
:- module(clpbn2graph, [clpbn2graph/1]).
:- use_module(library('clpbn/utils'), [
check_for_hidden_vars/3]).
:- use_module(library('clpbn/dists'), [
get_dist/4]).
:- attribute node/0.
clpbn2graph(Vs) :-
check_for_hidden_vars(Vs, Vs, NVs),
clpbn2graph2(NVs).
clpbn2graph2([]).
clpbn2graph2([V|Vs]) :-
put_atts(V,[node]),
clpbn2graph2(Vs).
%
% what is actually output
%
attribute_goal(V, node(K,Dom,CPT,TVs,Ev)) :-
get_atts(V, [node]),
clpbn:get_atts(V, [key(K),dist(Id,Vs)]),
get_dist(Id,_,Dom,CPT),
translate_vars(Vs,TVs),
( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true).
translate_vars([],[]).
translate_vars([V|Vs],[K|Ks]) :-
clpbn:get_atts(V, [key(K)]),
translate_vars(Vs,Ks).

71
packages/CLPBN/clpbn/graphviz.yap Normal file
View File

@ -0,0 +1,71 @@
:- module(clpbn_gviz, [clpbn2gviz/4]).
clpbn2gviz(Stream, Name, Network, Output) :-
format(Stream, 'digraph ~w {
graph [ rankdir="LR" ];~n',[Name]),
output_vars(Stream, Network),
info_ouput(Stream, Output),
format(Stream, '}~n',[]).
output_vars(_, []).
output_vars(Stream, [V|Vs]) :-
output_var(Stream, V),
output_vars(Stream, Vs).
output_var(Stream, V) :-
clpbn:get_atts(V,[key(Key),evidence(_)]),
output_key(Stream,Key),
format(Stream, ' [ shape=box, style=filled, fillcolor=red, fontsize=18.0 ]~n',[]),
fail.
output_var(Stream, V) :-
clpbn:get_atts(V,[key(Key),dist(_,Parents)]),
Parents = [_|_], !,
format(Stream, ' ',[]),
output_parents(Stream, Parents),
format(' -> ',[]),
output_key(Stream,Key),
nl(Stream).
output_var(_, _).
info_ouput(_, []).
info_ouput(Stream, [V|Output]) :-
clpbn:get_atts(V,[key(Key)]),
output_key(Stream,Key),
format(Stream, ' [ shape=box, style=filled, fillcolor=green, fontsize=18.0 ]~n',[]),
info_ouput(Stream, Output).
output_parents(Stream, [V]) :- !,
clpbn:get_atts(V,[key(Key)]),
output_key(Stream,Key).
output_parents(Stream, L) :-
format(Stream,'{ ',[]),
output_parents1(Stream,L),
format(Stream,'}',[]).
output_parents1(_,[]).
output_parents1(Stream,[V|L]) :-
clpbn:get_atts(V,[key(Key)]),
output_key(Stream,Key),
put_code(Stream, 0' ),
output_parents1(Stream,L).
output_key(Stream, Key) :-
output_key(Stream, 0, Key).
output_key(Stream, _, Key) :-
primitive(Key), !,
write(Stream, Key).
output_key(Stream, I0, Key) :-
Key =.. [Name|Args],
write(Stream, Name),
I is I0+1,
output_key_args(Stream, I, Args).
output_key_args(_, _, []).
output_key_args(Stream, I, [Arg|Args]) :-
format(Stream, '~*c', [I,0'_]),
output_key(Stream, I, Arg),
output_key_args(Stream, I, Args).

83
packages/CLPBN/clpbn/hmm.yap Normal file
View File

@ -0,0 +1,83 @@
:- module(hmm, [init_hmm/0,
hmm_state/1,
emission/1]).
:- ensure_loaded(library(clpbn)).
:- use_module(library(lists),
[nth/3]).
:- use_module(library(nbhash),
[nb_hash_new/2,
nb_hash_lookup/3,
nb_hash_insert/3
]).
:- ensure_loaded(library(tries)).
:- meta_predicate hmm_state(:).
:- dynamic hmm_tabled/1.
:- attribute emission/1.
:- ensure_loaded(library('clpbn/viterbi')).
init_hmm :-
% retractall(hmm_tabled(_)).
% eraseall(hmm_tabled).
% nb_hash_new(hmm_table, 1000000).
trie_open(Trie), nb_setval(trie,Trie).
hmm_state(Mod:A) :- !, hmm_state(A,Mod).
hmm_state(A) :- prolog_flag(typein_module,Mod), hmm_state(A,Mod).
hmm_state(Mod:N/A,_) :- !,
hmm_state(N/A,Mod).
hmm_state((A,B),Mod) :- !,
hmm_state(A,Mod),
hmm_state(B,Mod).
hmm_state(N/A,Mod) :-
atom_codes(N,[TC|_]),
atom_codes(T,[TC]),
build_args(A,LArgs,KArgs,First,Last),
Key =.. [T|KArgs],
Head =.. [N|LArgs],
asserta_static( (Mod:Head :-
( First > 2 ->
Last = Key, !
;
nb_getval(trie, Trie), trie_check_entry(Trie, Key, _)
->
% leave work for solver!
%
Last = Key, !
;
% first time we saw this entry
nb_getval(trie, Trie), trie_put_entry(Trie, Key, _),
fail
)
)
).
build_args(4,[A,B,C,D],[A,B,C],A,D).
build_args(3, [A,B,C], [A,B],A,C).
build_args(2, [A,B], [A],A,B).
emission(V) :-
put_atts(V,[emission(Prob)]).
cvt_vals(aminoacids,[a, c, d, e, f, g, h, i, k, l, m, n, p, q, r, s, t, v, w, y]).
cvt_vals(bool,[t,f]).
cvt_vals(dna,[a,c,g,t]).
cvt_vals(rna,[a,c,g,u]).
cvt_vals([A|B],[A|B]).
% first, try standard representation
find_probs(Logs,Nth,Log) :-
arg(Nth,Logs,Log).

528
packages/CLPBN/clpbn/jt.yap Normal file
View File

@ -0,0 +1,528 @@
:- module(jt, [jt/3,
init_jt_solver/4,
run_jt_solver/3]).
:- use_module(library(dgraphs),
[dgraph_new/1,
dgraph_add_edges/3,
dgraph_add_vertex/3,
dgraph_add_vertices/3,
dgraph_edges/2,
dgraph_vertices/2,
dgraph_transpose/2,
dgraph_to_ugraph/2,
ugraph_to_dgraph/2,
dgraph_neighbors/3
]).
:- use_module(library(undgraphs),
[undgraph_new/1,
undgraph_add_edge/4,
undgraph_add_edges/3,
undgraph_del_vertex/3,
undgraph_del_vertices/3,
undgraph_vertices/2,
undgraph_edges/2,
undgraph_neighbors/3,
undgraph_edge/3,
dgraph_to_undgraph/2
]).
:- use_module(library(wundgraphs),
[wundgraph_new/1,
wundgraph_max_tree/3,
wundgraph_add_edges/3,
wundgraph_add_vertices/3,
wundgraph_to_undgraph/2
]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_insert/4,
rb_lookup/3]).
:- use_module(library(ordsets),
[ord_subset/2,
ord_insert/3,
ord_intersection/3,
ord_del_element/3,
ord_memberchk/2]).
:- use_module(library(lists),
[reverse/2]).
:- use_module(library('clpbn/aggregates'),
[check_for_agg_vars/2]).
:- use_module(library('clpbn/dists'),
[get_dist_domain_size/2,
get_dist_domain/2,
get_dist_matrix/5]).
:- use_module(library('clpbn/matrix_cpt_utils'),
[project_from_CPT/3,
reorder_CPT/5,
unit_CPT/2,
multiply_CPTs/4,
divide_CPTs/3,
normalise_CPT/2,
expand_CPT/4,
get_CPT_sizes/2,
reset_CPT_that_disagrees/5,
sum_out_from_CPT/4,
list_from_CPT/2]).
:- use_module(library('clpbn/display'), [
clpbn_bind_vals/3]).
:- use_module(library('clpbn/connected'),
[
init_influences/3,
influences/5
]).
jt([[]],_,_) :- !.
jt(LLVs,Vs0,AllDiffs) :-
init_jt_solver(LLVs, Vs0, AllDiffs, State),
run_jt_solver(LLVs, LLPs, State),
clpbn_bind_vals(LLVs,LLPs,AllDiffs).
init_jt_solver(LLVs, Vs0, _, State) :-
check_for_agg_vars(Vs0, Vs1),
init_influences(Vs1, G, RG),
init_jt_solver_for_questions(LLVs, G, RG, State).
init_jt_solver_for_questions([], _, _, []).
init_jt_solver_for_questions([LLVs|MoreLLVs], G, RG, [state(JTree, Evidence)|State]) :-
influences(LLVs, _, NVs0, G, RG),
sort(NVs0, NVs),
get_graph(NVs, BayesNet, CPTs, Evidence),
build_jt(BayesNet, CPTs, JTree),
init_jt_solver_for_questions(MoreLLVs, G, RG, State).
run_jt_solver([], [], []).
run_jt_solver([LVs|MoreLVs], [LPs|MorePs], [state(JTree, Evidence)|MoreState]) :-
% JTree is a dgraph
% now our tree has cpts
fill_with_cpts(JTree, NewTree),
% write_tree(NewTree,0),
propagate_evidence(Evidence, NewTree, EvTree),
message_passing(EvTree, MTree),
get_margin(MTree, LVs, LPs),
run_jt_solver(MoreLVs, MorePs, MoreState).
get_graph(LVs, BayesNet, CPTs, Evidence) :-
run_vars(LVs, Edges, Vertices, CPTs, Evidence),
dgraph_new(V0),
dgraph_add_edges(V0, Edges, V1),
dgraph_add_vertices(V1, Vertices, V2),
dgraph_to_ugraph(V2, BayesNet).
run_vars([], [], [], [], []).
run_vars([V|LVs], Edges, [V|Vs], [CPTVars-dist([V|Parents],Id)|CPTs], Ev) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
add_evidence_from_vars(V, Ev, Ev0),
sort([V|Parents],CPTVars),
add_edges(Parents, V, Edges, Edges0),
run_vars(LVs, Edges0, Vs, CPTs, Ev0).
add_evidence_from_vars(V, [e(V,P)|Evs], Evs) :-
clpbn:get_atts(V, [evidence(P)]), !.
add_evidence_from_vars(_, Evs, Evs).
find_nth0([Id|_], Id, P, P) :- !.
find_nth0([_|D], Id, P0, P) :-
P1 is P0+1,
find_nth0(D, Id, P1, P).
add_edges([], _, Edges, Edges).
add_edges([P|Parents], V, [V-P|Edges], Edges0) :-
add_edges(Parents, V, Edges, Edges0).
build_jt(BayesNet, CPTs, Tree) :-
init_undgraph(BayesNet, Moral0),
moralised(BayesNet, Moral0, Markov),
undgraph_vertices(Markov, Vertices),
triangulate(Vertices, Markov, Markov, _, Cliques0),
cliques(Cliques0, EndCliques),
wundgraph_max_tree(EndCliques, J0Tree, _),
root(J0Tree, JTree),
populate(CPTs, JTree, Tree).
initial_graph(_,Parents, CPTs) :-
test_graph(0, Graph0, CPTs),
dgraph_new(V0),
dgraph_add_edges(V0, Graph0, V1),
% OK, this is a bit silly, I could have written the transposed graph
% from the very beginning.
dgraph_transpose(V1, V2),
dgraph_to_ugraph(V2, Parents).
problem_graph([], []).
problem_graph([V|BNet], GraphF) :-
clpbn:get_atts(V, [dist(_,_,Parents)]),
add_parents(Parents, V, Graph0, GraphF),
problem_graph(BNet, Graph0).
add_parents([], _, Graph, Graph).
add_parents([P|Parents], V, Graph0, [P-V|GraphF]) :-
add_parents(Parents, V, Graph0, GraphF).
% From David Page's lectures
test_graph(0,
[1-3,2-3,2-4,5-4,5-7,10-7,10-9,11-9,3-6,4-6,7-8,9-8,6-12,8-12],
[[1]-a,
[2]-b,
[1,2,3]-c,
[2,4,5]-d,
[5]-e,
[3,4,6]-f,
[5,7,10]-g,
[7,8,9]-h,
[9]-i,
[10]-j,
[11]-k,
[6,8,12]-l
]).
test_graph(1,[a-b,a-c,b-d,c-e,d-f,e-f],
[]).
init_undgraph(Parents, UndGraph) :-
ugraph_to_dgraph(Parents, DGraph),
dgraph_to_undgraph(DGraph, UndGraph).
get_par_keys([], []).
get_par_keys([P|Parents],[K|KPars]) :-
clpbn:get_atts(P, [key(K)]),
get_par_kets(Parents,KPars).
moralised([],Moral,Moral).
moralised([_-KPars|Ks],Moral0,MoralF) :-
add_moral_edges(KPars, Moral0, MoralI),
moralised(Ks,MoralI,MoralF).
add_moral_edges([], Moral, Moral).
add_moral_edges([_], Moral, Moral).
add_moral_edges([K1,K2|KPars], Moral0, MoralF) :-
undgraph_add_edge(Moral0, K1, K2, MoralI),
add_moral_edges([K1|KPars], MoralI, MoralJ),
add_moral_edges([K2|KPars],MoralJ,MoralF).
triangulate([], _, Triangulated, Triangulated, []) :- !.
triangulate(Vertices, S0, T0, Tf, Cliques) :-
choose(Vertices, S0, +inf, [], -1, BestVertex, _, Cliques0, Cliques, Edges),
ord_del_element(Vertices, BestVertex, NextVertices),
undgraph_add_edges(T0, Edges, T1),
undgraph_del_vertex(S0, BestVertex, Si),
undgraph_add_edges(Si, Edges, Si2),
triangulate(NextVertices, Si2, T1, Tf, Cliques0).
choose([], _, _, NewEdges, Best, Best, Clique, Cliques0, [Clique|Cliques0], NewEdges).
choose([V|Vertices], Graph, Score0, _, _, Best, _, Cliques0, Cliques, EdgesF) :-
undgraph_neighbors(V, Graph, Neighbors),
ord_insert(Neighbors, V, PossibleClique),
new_edges(Neighbors, Graph, NewEdges),
(
% simplicial edge
NewEdges == []
->
!,
Best = V,
NewEdges = EdgesF,
length(PossibleClique,L),
Cliques = [L-PossibleClique|Cliques0]
;
% cliquelength(PossibleClique,1,CL),
length(PossibleClique,CL),
CL < Score0, !,
choose(Vertices,Graph,CL,NewEdges, V, Best, CL-PossibleClique, Cliques0,Cliques,EdgesF)
).
choose([_|Vertices], Graph, Score0, Edges0, BestSoFar, Best, Clique, Cliques0, Cliques, EdgesF) :-
choose(Vertices,Graph,Score0,Edges0, BestSoFar, Best, Clique, Cliques0,Cliques,EdgesF).
new_edges([], _, []).
new_edges([N|Neighbors], Graph, NewEdgesF) :-
new_edges(Neighbors,N,Graph,NewEdges0, NewEdgesF),
new_edges(Neighbors, Graph, NewEdges0).
new_edges([],_,_,NewEdges, NewEdges).
new_edges([N1|Neighbors],N,Graph,NewEdges0, NewEdgesF) :-
undgraph_edge(N, N1, Graph), !,
new_edges(Neighbors,N,Graph,NewEdges0, NewEdgesF).
new_edges([N1|Neighbors],N,Graph,NewEdges0, [N-N1|NewEdgesF]) :-
new_edges(Neighbors,N,Graph,NewEdges0, NewEdgesF).
cliquelength([],CL,CL).
cliquelength([V|Vs],CL0,CL) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id, Sz),
CL1 is CL0*Sz,
cliquelength(Vs,CL1,CL).
%
% This is simple stuff, I just have to remove cliques that
% are subset of the others.
%
cliques(CliqueList, CliquesF) :-
wundgraph_new(Cliques0),
% first step, order by size,
keysort(CliqueList,Sort),
reverse(Sort, Rev),
get_links(Rev, [], Vertices, [], Edges),
wundgraph_add_vertices(Cliques0, Vertices, CliquesI),
wundgraph_add_edges(CliquesI, Edges, CliquesF).
% stupid quadratic algorithm, needs to be improved.
get_links([], Vertices, Vertices, Edges, Edges).
get_links([Sz-Clique|Cliques], SoFar, Vertices, Edges0, Edges) :-
add_clique_edges(SoFar, Clique, Sz, Edges0, EdgesI), !,
get_links(Cliques, [Clique|SoFar], Vertices, EdgesI, Edges).
get_links([_|Cliques], SoFar, Vertices, Edges0, Edges) :-
get_links(Cliques, SoFar, Vertices, Edges0, Edges).
add_clique_edges([], _, _, Edges, Edges).
add_clique_edges([Clique1|Cliques], Clique, Sz, Edges0, EdgesF) :-
ord_intersection(Clique1, Clique, Int),
Int \== Clique,
(
Int = [] ->
add_clique_edges(Cliques, Clique, Sz, Edges0, EdgesF)
;
% we connect
length(Int, LSz),
add_clique_edges(Cliques, Clique, Sz, [Clique-(Clique1-LSz)|Edges0], EdgesF)
).
root(WTree, JTree) :-
wundgraph_to_undgraph(WTree, Tree),
remove_leaves(Tree, SmallerTree),
undgraph_vertices(SmallerTree, InnerVs),
pick_root(InnerVs, Root),
rb_new(M0),
build_tree(Root, M0, Tree, JTree, _).
remove_leaves(Tree, SmallerTree) :-
undgraph_vertices(Tree, Vertices),
Vertices = [_,_,_|_],
get_leaves(Vertices, Tree, Leaves),
Leaves = [_|_], !,
undgraph_del_vertices(Tree, Leaves, NTree),
remove_leaves(NTree, SmallerTree).
remove_leaves(Tree, Tree).
get_leaves([], _, []).
get_leaves([V|Vertices], Tree, [V|Leaves]) :-
undgraph_neighbors(V, Tree, [_]), !,
get_leaves(Vertices, Tree, Leaves).
get_leaves([_|Vertices], Tree, Leaves) :-
get_leaves(Vertices, Tree, Leaves).
pick_root([V|_],V).
direct_edges([], _, [], []) :- !.
direct_edges([], NewVs, RemEdges, Directed) :-
direct_edges(RemEdges, NewVs, [], Directed).
direct_edges([V1-V2|Edges], NewVs0, RemEdges, [V1-V2|Directed]) :-
ord_memberchk(V1, NewVs0), !,
ord_insert(NewVs0, V2, NewVs),
direct_edges(Edges, NewVs, RemEdges, Directed).
direct_edges([V1-V2|Edges], NewVs0, RemEdges, [V2-V1|Directed]) :-
ord_memberchk(V2, NewVs0), !,
ord_insert(NewVs0, V1, NewVs),
direct_edges(Edges, NewVs, RemEdges, Directed).
direct_edges([Edge|Edges], NewVs, RemEdges, Directed) :-
direct_edges(Edges, NewVs, [Edge|RemEdges], Directed).
populate(CPTs, JTree, NewJTree) :-
keysort(CPTs, KCPTs),
populate_cliques(JTree, KCPTs, NewJTree, []).
populate_cliques(tree(Clique,Kids), CPTs, tree(Clique-MyCPTs,NewKids), RemCPTs) :-
get_cpts(CPTs, Clique, MyCPTs, MoreCPTs),
populate_trees_with_cliques(Kids, MoreCPTs, NewKids, RemCPTs).
populate_trees_with_cliques([], MoreCPTs, [], MoreCPTs).
populate_trees_with_cliques([Node|Kids], MoreCPTs, [NewNode|NewKids], RemCPts) :-
populate_cliques(Node, MoreCPTs, NewNode, ExtraCPTs),
populate_trees_with_cliques(Kids, ExtraCPTs, NewKids, RemCPts).
get_cpts([], _, [], []).
get_cpts([CPT|CPts], [], [], [CPT|CPts]) :- !.
get_cpts([[I|MCPT]-Info|CPTs], [J|Clique], MyCPTs, MoreCPTs) :-
compare(C,I,J),
( C == < ->
% our CPT cannot be a part of the clique.
MoreCPTs = [[I|MCPT]-Info|LeftoverCPTs],
get_cpts(CPTs, [J|Clique], MyCPTs, LeftoverCPTs)
;
C == = ->
% our CPT cannot be a part of the clique.
get_cpt(MCPT, Clique, I, Info, MyCPTs, MyCPTs0, MoreCPTs, MoreCPTs0),
get_cpts(CPTs, [J|Clique], MyCPTs0, MoreCPTs0)
;
% the first element in our CPT may not be in a clique
get_cpts([[I|MCPT]-Info|CPTs], Clique, MyCPTs, MoreCPTs)
).
get_cpt(MCPT, Clique, I, Info, [[I|MCPT]-Info|MyCPTs], MyCPTs, MoreCPTs, MoreCPTs) :-
ord_subset(MCPT, Clique), !.
get_cpt(MCPT, _, I, Info, MyCPTs, MyCPTs, [[I|MCPT]-Info|MoreCPTs], MoreCPTs).
translate_edges([], [], []).
translate_edges([E1-E2|Edges], [(E1-A)-(E2-B)|NEdges], [E1-A,E2-B|Vs]) :-
translate_edges(Edges, NEdges, Vs).
match_vs(_,[]).
match_vs([K-A|Cls],[K1-B|KVs]) :-
compare(C, K, K1),
(C == = ->
A = B,
match_vs([K-A|Cls], KVs)
;
C = < ->
match_vs(Cls,[K1-B|KVs])
;
match_vs([K-A|Cls],KVs)
).
fill_with_cpts(tree(Clique-Dists,Leafs), tree(Clique-NewDists,NewLeafs)) :-
compile_cpts(Dists, Clique, NewDists),
fill_tree_with_cpts(Leafs, NewLeafs).
fill_tree_with_cpts([], []).
fill_tree_with_cpts([L|Leafs], [NL|NewLeafs]) :-
fill_with_cpts(L, NL),
fill_tree_with_cpts(Leafs, NewLeafs).
transform([], []).
transform([Clique-Dists|Nodes],[Clique-NewDist|NewNodes]) :-
compile_cpts(Dists, Clique, NewDist),
transform(Nodes, NewNodes).
compile_cpts([Vs-dist(OVs,Id)|Dists], Clique, TAB) :-
OVs = [_|Ps], !,
get_dist_matrix(Id, Ps, _, _, TAB0),
reorder_CPT(OVs, TAB0, Vs, TAB1, Sz1),
multiply_dists(Dists,Vs,TAB1,Sz1,Vars2,ITAB),
expand_CPT(ITAB,Vars2,Clique,TAB).
compile_cpts([], [V|Clique], TAB) :-
unit_CPT(V, CPT0),
expand_CPT(CPT0, [V], [V|Clique], TAB).
multiply_dists([],Vs,TAB,_,Vs,TAB).
multiply_dists([Vs-dist(OVs,Id)|Dists],MVs,TAB2,Sz2,FVars,FTAB) :-
OVs = [_|Ps],
get_dist_matrix(Id, Ps, _, _, TAB0),
reorder_CPT(OVs, TAB0, Vs, TAB1, Sz1),
multiply_CPTs(tab(TAB1,Vs,Sz1),tab(TAB2,MVs,Sz2),tab(TAB3,NVs,Sz),_),
multiply_dists(Dists,NVs,TAB3,Sz,FVars,FTAB).
build_tree(Root, Leafs, WTree, tree(Root,Leaves), NewLeafs) :-
rb_insert(Leafs, Root, [], Leafs0),
undgraph_neighbors(Root, WTree, Children),
build_trees(Children, Leafs0, WTree, Leaves, NewLeafs).
build_trees( [], Leafs, _, [], Leafs).
build_trees([V|Children], Leafs, WTree, NLeaves, NewLeafs) :-
% back pointer
rb_lookup(V, _, Leafs), !,
build_trees(Children, Leafs, WTree, NLeaves, NewLeafs).
build_trees([V|Children], Leafs, WTree, [VT|NLeaves], NewLeafs) :-
build_tree(V, Leafs, WTree, VT, Leafs1),
build_trees(Children, Leafs1, WTree, NLeaves, NewLeafs).
propagate_evidence([], NewTree, NewTree).
propagate_evidence([e(V,P)|Evs], Tree0, NewTree) :-
add_evidence_to_matrix(Tree0, V, P, Tree1), !,
propagate_evidence(Evs, Tree1, NewTree).
add_evidence_to_matrix(tree(Clique-Dist,Kids), V, P, tree(Clique-NDist,Kids)) :-
ord_memberchk(V, Clique), !,
reset_CPT_that_disagrees(Dist, Clique, V, P, NDist).
add_evidence_to_matrix(tree(C,Kids), V, P, tree(C,NKids)) :-
add_evidence_to_kids(Kids, V, P, NKids).
add_evidence_to_kids([K|Kids], V, P, [NK|Kids]) :-
add_evidence_to_matrix(K, V, P, NK), !.
add_evidence_to_kids([K|Kids], V, P, [K|NNKids]) :-
add_evidence_to_kids(Kids, V, P, NNKids).
message_passing(tree(Clique-Dist,Kids), tree(Clique-NDist,NKids)) :-
get_CPT_sizes(Dist, Sizes),
upward(Kids, Clique, tab(Dist, Clique, Sizes), IKids, ITab, 1),
ITab = tab(NDist, _, _),
nb_setval(cnt,0),
downward(IKids, Clique, ITab, NKids).
upward([], _, Dist, [], Dist, _).
upward([tree(Clique1-Dist1,DistKids)|Kids], Clique, Tab, [tree(Clique1-(NewDist1,EDist1),NDistKids)|NKids], NewTab, Lev) :-
get_CPT_sizes(Dist1, Sizes1),
Lev1 is Lev+1,
upward(DistKids, Clique1, tab(Dist1,Clique1,Sizes1), NDistKids, NewTab1, Lev1),
NewTab1 = tab(NewDist1,_,_),
ord_intersection(Clique1, Clique, Int),
sum_out_from_CPT(Int, NewDist1, Clique1, Tab1),
multiply_CPTs(Tab, Tab1, ITab, EDist1),
upward(Kids, Clique, ITab, NKids, NewTab, Lev).
downward([], _, _, []).
downward([tree(Clique1-(Dist1,Msg1),DistKids)|Kids], Clique, Tab, [tree(Clique1-NDist1,NDistKids)|NKids]) :-
get_CPT_sizes(Dist1, Sizes1),
ord_intersection(Clique1, Clique, Int),
Tab = tab(Dist,_,_),
divide_CPTs(Dist, Msg1, Div),
sum_out_from_CPT(Int, Div, Clique, STab),
multiply_CPTs(STab, tab(Dist1, Clique1, Sizes1), NewTab, _),
NewTab = tab(NDist1,_,_),
downward(DistKids, Clique1, NewTab, NDistKids),
downward(Kids, Clique, Tab, NKids).
get_margin(NewTree, LVs0, LPs) :-
sort(LVs0, LVs),
find_clique(NewTree, LVs, Clique, Dist),
sum_out_from_CPT(LVs, Dist, Clique, tab(TAB,_,_)),
reorder_CPT(LVs, TAB, LVs0, NTAB, _),
normalise_CPT(NTAB, Ps),
list_from_CPT(Ps, LPs).
find_clique(tree(Clique-Dist,_), LVs, Clique, Dist) :-
ord_subset(LVs, Clique), !.
find_clique(tree(_,Kids), LVs, Clique, Dist) :-
find_clique_from_kids(Kids, LVs, Clique, Dist).
find_clique_from_kids([K|_], LVs, Clique, Dist) :-
find_clique(K, LVs, Clique, Dist), !.
find_clique_from_kids([_|Kids], LVs, Clique, Dist) :-
find_clique_from_kids(Kids, LVs, Clique, Dist).
write_tree(tree(Clique-(Dist,_),Leaves), I0) :- !,
matrix:matrix_to_list(Dist,L),
format('~*c ~w:~w~n',[I0,0' ,Clique,L]),
I is I0+2,
write_subtree(Leaves, I).
write_tree(tree(Clique-Dist,Leaves), I0) :-
matrix:matrix_to_list(Dist,L),
format('~*c ~w:~w~n',[I0,0' ,Clique, L]),
I is I0+2,
write_subtree(Leaves, I).
write_subtree([], _).
write_subtree([Tree|Leaves], I) :-
write_tree(Tree, I),
write_subtree(Leaves, I).

267
packages/CLPBN/clpbn/matrix_cpt_utils.yap Normal file
View File

@ -0,0 +1,267 @@
:- module(clpbn_matrix_utils,
[init_CPT/2,
project_from_CPT/3,
reorder_CPT/5,
get_CPT_sizes/2,
normalise_CPT/2,
multiply_CPTs/4,
divide_CPTs/3,
expand_CPT/4,
reset_CPT_that_disagrees/5,
unit_CPT/2,
sum_out_from_CPT/4,
list_from_CPT/2,
multiply_factors/3,
normalise_possibly_deterministic_CPT/2,
column_from_possibly_deterministic_CPT/3,
multiply_possibly_deterministic_factors/3,
random_CPT/2,
uniform_CPT/2,
uniform_CPT_as_list/2,
normalise_CPT_on_lines/3]).
:- use_module(dists,
[get_dist_domain_size/2,
get_dist_domain/2]).
:- use_module(library(matrix),
[matrix_new/4,
matrix_new_set/4,
matrix_select/4,
matrix_dims/2,
matrix_size/2,
matrix_shuffle/3,
matrix_expand/3,
matrix_op/4,
matrix_dims/2,
matrix_sum/2,
matrix_sum_logs_out/3,
matrix_sum_logs_out_several/3,
matrix_op_to_all/4,
matrix_to_exps2/1,
matrix_to_logs/1,
matrix_set_all_that_disagree/5,
matrix_to_list/2,
matrix_agg_lines/3,
matrix_agg_cols/3,
matrix_op_to_lines/4,
matrix_column/3]).
init_CPT(List, Sizes, TAB) :-
matrix_new(floats, Sizes, List, TAB),
matrix_to_logs(TAB).
init_possibly_deterministic_CPT(List, Sizes, TAB) :-
matrix_new(floats, Sizes, List, TAB).
project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
evidence(V,Pos), !,
vnth(Deps, 0, V, N, NDeps),
matrix_select(Table, N, Pos, NewTable),
matrix_dims(NewTable, NSzs).
project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
vnth(Deps, 0, V, N, NDeps),
matrix_sum_logs_out(Table, N, NewTable),
matrix_dims(NewTable, NSzs).
evidence(V, Pos) :-
clpbn:get_atts(V, [evidence(Pos)]).
vnth([V1|Deps], N, V, N, Deps) :-
V == V1, !.
vnth([V1|Deps], N0, V, N, [V1|NDeps]) :-
N1 is N0+1,
vnth(Deps, N1, V, N, NDeps).
reorder_CPT(Vs0,T0,Vs,TF,Sizes) :-
var(Vs), !,
order_vec(Vs0,Vs,Map),
(
Vs == Vs0
->
TF = T0
;
matrix_shuffle(T0,Map,TF)
),
matrix_dims(TF, Sizes).
reorder_CPT(Vs0,T0,Vs,TF,Sizes) :-
mapping(Vs0,Vs,Map),
(
Vs == Vs0
->
TF = T0
;
matrix_shuffle(T0,Map,TF)
),
matrix_dims(TF, Sizes).
order_vec(Vs0,Vs,Map) :-
add_indices(Vs0,0,Is),
keysort(Is,NIs),
get_els(NIs, Vs, Map).
add_indices([],_,[]).
add_indices([V|Vs0],I0,[V-I0|Is]) :-
I is I0+1,
add_indices(Vs0,I,Is).
get_els([], [], []).
get_els([V-I|NIs], [V|Vs], [I|Map]) :-
get_els(NIs, Vs, Map).
mapping(Vs0,Vs,Map) :-
add_indices(Vs0,0,I1s),
add_indices( Vs,I2s),
keysort(I1s,Ks),
keysort(I2s,Ks),
split_map(I2s, Map).
add_indices([],[]).
add_indices([V|Vs0],[V-_|I1s]) :-
add_indices(Vs0,I1s).
split_map([], []).
split_map([_-M|Is], [M|Map]) :-
split_map(Is, Map).
divide_CPTs(Tab1, Tab2, OT) :-
matrix_op(Tab1,Tab2,-,OT).
multiply_CPTs(tab(Tab1, Deps1, Sz1), tab(Tab2, Deps2, Sz2), tab(OT, NDeps, NSz), NTab2) :-
expand_tabs(Deps1, Sz1, Deps2, Sz2, Map1, Map2, NDeps),
matrix_expand_compact(Tab1, Map1, NTab1),
matrix_expand_compact(Tab2, Map2, NTab2),
matrix_op(NTab1,NTab2,+,OT),
matrix_dims(OT,NSz).
expand_tabs([], [], [], [], [], [], []).
expand_tabs([V1|Deps1], [S1|Sz1], [], [], [0|Map1], [S1|Map2], [V1|NDeps]) :-
expand_tabs(Deps1, Sz1, [], [], Map1, Map2, NDeps).
expand_tabs([], [], [V2|Deps2], [S2|Sz2], [S2|Map1], [0|Map2], [V2|NDeps]) :-
expand_tabs([], [], Deps2, Sz2, Map1, Map2, NDeps).
expand_tabs([V1|Deps1], [S1|Sz1], [V2|Deps2], [S2|Sz2], Map1, Map2, NDeps) :-
compare(C,V1,V2),
(C == = ->
NDeps = [V1|MDeps],
Map1 = [0|M1],
Map2 = [0|M2],
NDeps = [V1|MDeps],
expand_tabs(Deps1, Sz1, Deps2, Sz2, M1, M2, MDeps)
;
C == < ->
NDeps = [V1|MDeps],
Map1 = [0|M1],
Map2 = [S1|M2],
NDeps = [V1|MDeps],
expand_tabs(Deps1, Sz1, [V2|Deps2], [S2|Sz2], M1, M2, MDeps)
;
NDeps = [V2|MDeps],
Map1 = [S2|M1],
Map2 = [0|M2],
NDeps = [V2|MDeps],
expand_tabs([V1|Deps1], [S1|Sz1], Deps2, Sz2, M1, M2, MDeps)
).
normalise_CPT(MAT,NMAT) :-
matrix_to_exps2(MAT),
matrix_sum(MAT, Sum),
matrix_op_to_all(MAT, /, Sum, NMAT).
list_from_CPT(MAT, List) :-
matrix_to_list(MAT, List).
expand_CPT(MAT0, Dims0, DimsNew, MAT) :-
generate_map(DimsNew, Dims0, Map),
matrix_expand(MAT0, Map, MAT).
generate_map([], [], []).
generate_map([V|DimsNew], [V0|Dims0], [0|Map]) :- V == V0, !,
generate_map(DimsNew, Dims0, Map).
generate_map([V|DimsNew], Dims0, [Sz|Map]) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id, Sz),
generate_map(DimsNew, Dims0, Map).
unit_CPT(V,CPT) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id, Sz),
matrix_new_set(floats,[Sz],1.0,CPT).
reset_CPT_that_disagrees(CPT, Vars, V, Pos, NCPT) :-
vnth(Vars, 0, V, Dim, _),
matrix_set_all_that_disagree(CPT, Dim, Pos, -inf, NCPT).
sum_out_from_CPT(Vs,Table,Deps,tab(NewTable,Vs,Sz)) :-
conversion_matrix(Vs, Deps, Conv),
matrix_sum_logs_out_several(Table, Conv, NewTable),
matrix_dims(NewTable, Sz).
conversion_matrix([], [], []).
conversion_matrix([], [_|Deps], [1|Conv]) :-
conversion_matrix([], Deps, Conv).
conversion_matrix([V|Vs], [V1|Deps], [0|Conv]) :- V==V1, !,
conversion_matrix(Vs, Deps, Conv).
conversion_matrix([V|Vs], [_|Deps], [1|Conv]) :-
conversion_matrix([V|Vs], Deps, Conv).
get_CPT_sizes(CPT, Sizes) :-
matrix_dims(CPT, Sizes).
matrix_expand_compact(M0,Zeros,M0) :-
zero_map(Zeros), !.
matrix_expand_compact(M0,Map,M) :-
matrix_expand(M0, Map, M).
zero_map([]).
zero_map([0|Zeros]) :-
zero_map(Zeros).
col_from_CPT(CPT, Parents, Column) :-
matrix_col(CPT, Parents, Column),
matrix_to_logs(Column).
column_from_possibly_deterministic_CPT(CPT, Parents, Column) :-
matrix_column(CPT, Parents, Column).
multiply_factors(F1, F2, F) :-
matrix_op(F1,F2,+,F).
multiply_possibly_deterministic_factors(F1, F2, F) :-
matrix_op(F1,F2,*,F).
normalise_possibly_deterministic_CPT(MAT,NMAT) :-
matrix_agg_lines(MAT, +, Sum),
matrix_op_to_lines(MAT, Sum, /, NMAT).
random_CPT(Dims, M) :-
mult_all(Dims,1,Size),
generate_random_entries(Size, Randoms),
matrix_new(floats, Dims, Randoms, M1),
normalise_possibly_deterministic_CPT(M1, M).
mult_all([],Size,Size).
mult_all([D|Dims],Size0,Size) :-
Size1 is Size0*D,
mult_all(Dims,Size1,Size).
generate_random_entries(0, []) :- !.
generate_random_entries(Size, [R|Randoms]) :-
R is random,
Size1 is Size-1,
generate_random_entries(Size1, Randoms).
uniform_CPT_as_list(Dims, L) :-
uniform_CPT(Dims, M),
matrix_to_list(M, L).
uniform_CPT(Dims, M) :-
matrix_new_set(floats,Dims,1.0,M1),
normalise_possibly_deterministic_CPT(M1, M).
normalise_CPT_on_lines(MAT0, MAT2, L1) :-
matrix_agg_cols(MAT0, +, MAT1),
matrix_sum(MAT1, SUM),
matrix_op_to_all(MAT1, /, SUM, MAT2),
matrix:matrix_to_list(MAT2,L1).

223
packages/CLPBN/clpbn/table.yap Normal file
View File

@ -0,0 +1,223 @@
/*
Deterministcally table a predicate of the form
K -> RV
where the K are the first N-1 arguments.
Note that this does not include support for backtracking
*/
:- module(clpbn_table,
[clpbn_table/1,
clpbn_tabled_clause/2,
clpbn_tabled_abolish/1,
clpbn_tabled_asserta/1,
clpbn_tabled_assertz/1,
clpbn_tabled_asserta/2,
clpbn_tabled_assertz/2,
clpbn_tabled_dynamic/1,
clpbn_tabled_number_of_clauses/2,
clpbn_reset_tables/0,
clpbn_reset_tables/1,
clpbn_is_tabled/1
]).
:- use_module(library(bhash),
[b_hash_new/2,
b_hash_lookup/3,
b_hash_insert/3]).
:- meta_predicate clpbn_table(:),
clpbn_tabled_clause(:.?),
clpbn_tabled_abolish(:),
clpbn_tabled_asserta(:),
clpbn_tabled_assertz(:),
clpbn_tabled_asserta(:,-),
clpbn_tabled_assertz(:,-),
clpbn_tabled_number_of_clauses(:,-),
clpbn_is_tabled(:).
:- dynamic clpbn_table/3.
:- initialization(init).
init :-
clpbn_reset_tables.
clpbn_reset_tables :-
clpbn_reset_tables(1024).
clpbn_reset_tables(Sz) :-
b_hash_new(Tab, Sz),
nb_setval(clpbn_tables, Tab).
clpbn_table(M:X) :- !,
clpbn_table(X,M).
clpbn_table(X) :-
prolog_load_context(module, M),
clpbn_table(X,M).
clpbn_table(M:X,_) :- !,
clpbn_table(X,M).
clpbn_table((P1,P2),M) :- !,
clpbn_table(P1,M),
clpbn_table(P2,M).
clpbn_table(F/N,M) :-
functor(S,F,N),
S =.. L0,
take_tail(L0, V, L1, V1, L2),
Key =.. L1,
atom_concat(F, '___tabled', NF),
L2 = [_|Args],
S1 =.. [NF|Args],
L0 = [_|OArgs],
S2 =.. [NF|OArgs],
asserta(clpbn_table(S, M, S2)),
assert((M:S :- nb_getval(clpbn_tables, Tab), ( b_hash_lookup(Key, V1, Tab) -> true ; M:S1, b_hash_insert(Tab, Key, V1) ; true), ( nonvar(V) -> clpbn_evidence:put_evidence(V, V1) ; V = V1 ), ! ) ).
take_tail([V], V, [], V1, [V1]) :- !.
take_tail([A|L0], V, [A|L1], V1, [A|L2]) :-
take_tail(L0, V, L1, V1, L2).
user:term_expansion((P :- Gs), NC) :-
clpbn_table(P, M, NP),
prolog_load_context(module, M), !,
assert(M:(NP :- Gs)),
NC = (:-true).
in_table(K, V) :-
nb_getval(clpbn_tables, Tab),
b_hash_lookup(K, V, Tab).
store_in_table(K, V) :-
nb_getval(clpbn_tables, Tab),
b_hash_insert(Tab, K, V).
clpbn_tabled_clause(M:Head, Body) :- !,
clpbn_tabled_clause(Head, M, Body).
clpbn_tabled_clause(Head, Body) :-
prolog_load_context(module, M),
clpbn_tabled_clause(Head, M, Body).
clpbn_tabled_clause(M:Head, _, Body) :- !,
clpbn_tabled_clause(Head, M, Body).
clpbn_tabled_clause(Head, M, Body) :-
clpbn_table(Head, M, THead),
clause(M:THead, Body).
clpbn_tabled_assertz(M:Clause) :- !,
clpbn_tabled_assertz2(Clause, M).
clpbn_tabled_assertz(Clause) :-
prolog_load_context(module, M),
clpbn_tabled_assertz2(Clause, M).
clpbn_tabled_assertz2(M:Clause, _) :- !,
clpbn_tabled_assertz2(Clause, M).
clpbn_tabled_assertz2((Head:-Body), M) :- !,
clpbn_table(Head, M, THead),
assertz(M:(THead :- Body)).
clpbn_tabled_assertz2(Head, M) :-
clpbn_table(Head, M, THead),
assertz(THead).
clpbn_tabled_assertz(M:Clause, Ref) :- !,
clpbn_tabled_assertz2(Clause, M, Ref).
clpbn_tabled_assertz(Clause, Ref) :-
prolog_load_context(module, M),
clpbn_tabled_assertz2(Clause, M, Ref).
clpbn_tabled_assertz2(M:Clause, _, Ref) :- !,
clpbn_tabled_assertz2(Clause, M, Ref).
clpbn_tabled_assertz2((Head:-Body), M, Ref) :- !,
clpbn_table(Head, M, THead),
assertz(M:(THead :- Body), Ref).
clpbn_tabled_assertz2(Head, M, Ref) :-
clpbn_table(Head, M, THead, Ref),
assertz(THead).
clpbn_tabled_asserta(M:Clause) :- !,
clpbn_tabled_asserta2(Clause, M).
clpbn_tabled_asserta(Clause) :-
prolog_load_context(module, M),
clpbn_tabled_asserta2(Clause, M).
clpbn_tabled_asserta2(M:Clause, _) :- !,
clpbn_tabled_asserta2(Clause, M).
clpbn_tabled_asserta2((Head:-Body), M) :- !,
clpbn_table(Head, M, THead),
asserta(M:(THead :- Body)).
clpbn_tabled_asserta2(Head, M) :-
clpbn_table(Head, M, THead),
asserta(THead).
clpbn_tabled_asserta(M:Clause, Ref) :- !,
clpbn_tabled_asserta2(Clause, M, Ref).
clpbn_tabled_asserta(Clause, Ref) :-
prolog_load_context(module, M),
clpbn_tabled_asserta2(Clause, M, Ref).
clpbn_tabled_asserta2(M:Clause, _, Ref) :- !,
clpbn_tabled_asserta2(Clause, M, Ref).
clpbn_tabled_asserta2((Head:-Body), M, Ref) :- !,
clpbn_table(Head, M, THead),
asserta(M:(THead :- Body), Ref).
clpbn_tabled_asserta2(Head, M, Ref) :-
clpbn_table(Head, M, THead, Ref),
asserta(THead).
clpbn_tabled_abolish(M:Clause) :- !,
clpbn_tabled_abolish(Clause, M).
clpbn_tabled_abolish(Clause) :-
prolog_load_context(module, M),
clpbn_tabled_abolish(Clause, M).
clpbn_tabled_abolish(M:Clause, _) :- !,
clpbn_tabled_abolish(Clause, M).
clpbn_tabled_abolish(N/A, M) :-
functor(Head, N, A),
clpbn_table(Head, M, THead),
functor(THead, TN, A),
abolish(M:TN/A).
clpbn_tabled_dynamic(M:Clause) :- !,
clpbn_tabled_dynamic(Clause, M).
clpbn_tabled_dynamic(Clause) :-
prolog_load_context(module, M),
clpbn_tabled_dynamic(Clause, M).
clpbn_tabled_dynamic(M:Clause, _) :- !,
clpbn_tabled_dynamic(Clause, M).
clpbn_tabled_dynamic(N/A, M) :-
functor(Head, N, A),
clpbn_table(Head, M, THead),
functor(THead, TN, A),
dynamic(M:TN/A).
clpbn_tabled_number_of_clauses(M:Clause, N) :- !,
clpbn_tabled_number_of_clauses(Clause, M, N).
clpbn_tabled_number_of_clauses(Clause, N) :-
prolog_load_context(module, M),
clpbn_tabled_number_of_clauses(Clause, M, N).
clpbn_tabled_number_of_clauses(M:Clause, _, N) :- !,
clpbn_tabled_number_of_clauses(Clause, M, N).
clpbn_tabled_number_of_clauses(Head, M, N) :-
clpbn_table(Head, M, THead),
predicate_property(M:THead,number_of_clauses(N)).
clpbn_is_tabled(M:Clause) :- !,
clpbn_is_tabled(Clause, M).
clpbn_is_tabled(Clause) :-
prolog_load_context(module, M),
clpbn_is_tabled(Clause, M).
clpbn_is_tabled(M:Clause, _) :- !,
clpbn_is_tabled(Clause, M).
clpbn_is_tabled(Head, M) :-
clpbn_table(Head, M, _).

34
packages/CLPBN/clpbn/topsort.yap Normal file
View File

@ -0,0 +1,34 @@
:- module(topsort, [topsort/2]).
:- use_module(library(dgraphs),
[dgraph_new/1,
dgraph_add_edges/3,
dgraph_add_vertices/3,
dgraph_top_sort/2]).
/* simple implementation of a topological sorting algorithm */
/* graph is as Node-[Parents] */
topsort(Graph0, Sorted) :-
mkedge_list(Graph0, EdgeList, []),
mkvertices_list(Graph0, VList, []),
dgraph_new(DGraph0),
dgraph_add_vertices(DGraph0, VList, DGraph1),
dgraph_add_edges(DGraph1, EdgeList, DGraph2),
dgraph_top_sort(DGraph2, Sorted).
mkvertices_list([]) --> [].
mkvertices_list([V-_|More]) --> [V],
mkvertices_list(More).
mkedge_list([]) --> [].
mkedge_list([V-Parents|More]) -->
add_edges(Parents, V),
mkedge_list(More).
add_edges([], _V) --> [].
add_edges([P|Parents], V) --> [P-V],
add_edges(Parents, V).

116
packages/CLPBN/clpbn/utils.yap Normal file
View File

@ -0,0 +1,116 @@
:- module(clpbn_utils, [
clpbn_not_var_member/2,
clpbn_var_member/2,
check_for_hidden_vars/3,
sort_vars_by_key/3,
sort_vars_by_key_and_parents/3]).
%
% It may happen that variables from a previous query may still be around.
% and be used in the next evaluation, so we cannot trust the list of *new*
% variables.
%
check_for_hidden_vars([], _, []).
check_for_hidden_vars([V|Vs], AllVs0, [V|NVs]) :-
check_for_extra_variables(V,AllVs0, AllVs, Vs, IVs),
check_for_hidden_vars(IVs, AllVs, NVs).
check_for_extra_variables(V,AllVs0, AllVs, Vs, IVs) :-
var(V),
clpbn:get_atts(V, [dist(_,[V1|LV])]), !,
add_old_variables([V1|LV], AllVs0, AllVs, Vs, IVs).
check_for_extra_variables(_,AllVs, AllVs, Vs, Vs).
add_old_variables([], AllVs, AllVs, Vs, Vs).
add_old_variables([V1|LV], AllVs0, AllVs, Vs, IVs) :-
clpbn_not_var_member(AllVs0, V1), !,
add_old_variables(LV, [V1|AllVs0], AllVs, [V1|Vs], IVs).
add_old_variables([_|LV], AllVs0, AllVs, Vs, IVs) :-
add_old_variables(LV, AllVs0, AllVs, Vs, IVs).
clpbn_var_member([V1|_], V) :- V1 == V, !.
clpbn_var_member([_|Vs], V) :-
clpbn_var_member(Vs, V).
clpbn_not_var_member([], _).
clpbn_not_var_member([V1|Vs], V) :- V1 \== V,
clpbn_not_var_member(Vs, V).
sort_vars_by_key(AVars, SortedAVars, UnifiableVars) :-
get_keys(AVars, KeysVars),
msort(KeysVars, KVars),
merge_same_key(KVars, SortedAVars, [], UnifiableVars).
get_keys([], []).
get_keys([V|AVars], [K-V|KeysVars]) :-
clpbn:get_atts(V, [key(K)]), !,
get_keys(AVars, KeysVars).
get_keys([_|AVars], KeysVars) :- % may be non-CLPBN vars.
get_keys(AVars, KeysVars).
merge_same_key([], [], _, []).
merge_same_key([K1-V1,K2-V2|Vs], SortedAVars, Ks, UnifiableVars) :-
K1 == K2, !,
(clpbn:get_atts(V1, [evidence(E)])
->
clpbn:put_atts(V2, [evidence(E)])
;
clpbn:get_atts(V2, [evidence(E)])
->
clpbn:put_atts(V1, [evidence(E)])
;
true
),
% V1 = V2,
attributes:fast_unify_attributed(V1,V2),
merge_same_key([K1-V1|Vs], SortedAVars, Ks, UnifiableVars).
merge_same_key([K1-V1,K2-V2|Vs], [V1|SortedAVars], Ks, [K1|UnifiableVars]) :-
(in_keys(K1, Ks) ; \+ \+ K1 == K2), !,
add_to_keys(K1, Ks, NKs),
merge_same_key([K2-V2|Vs], SortedAVars, NKs, UnifiableVars).
merge_same_key([K-V|Vs], [V|SortedAVars], Ks, UnifiableVars) :-
add_to_keys(K, Ks, NKs),
merge_same_key(Vs, SortedAVars, NKs, UnifiableVars).
in_keys(K1,[K|_]) :- \+ \+ K1 = K, !.
in_keys(K1,[_|Ks]) :-
in_keys(K1,Ks).
add_to_keys(K1, Ks, Ks) :- ground(K1), !.
add_to_keys(K1, Ks, [K1|Ks]).
sort_vars_by_key_and_parents(AVars, SortedAVars, UnifiableVars) :-
get_keys_and_parents(AVars, KeysVars),
keysort(KeysVars, KVars),
merge_same_key(KVars, SortedAVars, [], UnifiableVars).
get_keys_and_parents([], []).
get_keys_and_parents([V|AVars], [K-V|KeysVarsF]) :-
clpbn:get_atts(V, [key(K),dist(Id,Parents)]), !,
add_parents(Parents,V,Id,KeysVarsF,KeysVars0),
get_keys_and_parents(AVars, KeysVars0).
get_keys_and_parents([_|AVars], KeysVars) :- % may be non-CLPBN vars.
get_keys_and_parents(AVars, KeysVars).
add_parents(Parents,_,_,KeyVars,KeyVars) :-
all_vars(Parents), !.
add_parents(Parents,V,Id,KeyVarsF,KeyVars0) :-
transform_parents(Parents,NParents,KeyVarsF,KeyVars0),
clpbn:put_atts(V, [dist(Id,NParents)]).
all_vars([]).
all_vars([P|Parents]) :-
var(P),
all_vars(Parents).
transform_parents([],[],KeyVars,KeyVars).
transform_parents([P|Parents0],[P|NParents],KeyVarsF,KeyVars0) :-
var(P), !,
transform_parents(Parents0,NParents,KeyVarsF,KeyVars0).
transform_parents([P|Parents0],[V|NParents],[P-V|KeyVarsF],KeyVars0) :-
transform_parents(Parents0,NParents,KeyVarsF,KeyVars0).

274
packages/CLPBN/clpbn/vel.yap Normal file
View File

@ -0,0 +1,274 @@
/***********************************
Variable Elimination in Prolog
How to do it
Three steps:
build the graph:
- for all variables, find out
all tables they connect to;
multiply their size
order by size
*********************************/
:- module(clpbn_vel, [vel/3,
check_if_vel_done/1,
init_vel_solver/4,
run_vel_solver/3]).
:- attribute size/1, all_diffs/1.
:- use_module(library(ordsets),
[ord_union/3,
ord_member/2]).
:- use_module(library('clpbn/xbif'), [clpbn2xbif/3]).
:- use_module(library('clpbn/graphviz'), [clpbn2gviz/4]).
:- use_module(library('clpbn/dists'),
[
dist/4,
get_dist_domain_size/2,
get_dist_matrix/5]).
:- use_module(library('clpbn/utils'), [
clpbn_not_var_member/2]).
:- use_module(library('clpbn/display'), [
clpbn_bind_vals/3]).
:- use_module(library('clpbn/connected'),
[
init_influences/3,
influences/5
]).
:- use_module(library('clpbn/matrix_cpt_utils'),
[project_from_CPT/3,
reorder_CPT/5,
multiply_CPTs/4,
normalise_CPT/2,
sum_out_from_CPT/4,
list_from_CPT/2]).
:- use_module(library(lists),
[
append/3
]).
:- use_module(library('clpbn/aggregates'),
[check_for_agg_vars/2]).
check_if_vel_done(Var) :-
get_atts(Var, [size(_)]), !.
%
% implementation of the well known variable elimination algorithm
%
vel([[]],_,_) :- !.
vel([LVs],Vs0,AllDiffs) :-
init_vel_solver([LVs], Vs0, AllDiffs, State),
% variable elimination proper
run_vel_solver([LVs], [LPs], State),
% bind Probs back to variables so that they can be output.
clpbn_bind_vals([LVs],[LPs],AllDiffs).
init_vel_solver(Qs, Vs0, _, LVis) :-
check_for_agg_vars(Vs0, Vs1),
% LVi will have a list of CLPBN variables
% Tables0 will have the full data on each variable
init_influences(Vs1, G, RG),
init_vel_solver_for_questions(Qs, G, RG, _, LVis).
init_vel_solver_for_questions([], _, _, [], []).
init_vel_solver_for_questions([Vs|MVs], G, RG, [NVs|MNVs0], [NVs|LVis]) :-
influences(Vs, _, NVs0, G, RG),
sort(NVs0, NVs),
%clpbn_gviz:clpbn2gviz(user_error, test, NVs, Vs),
init_vel_solver_for_questions(MVs, G, RG, MNVs0, LVis).
% use a findall to recover space without needing for GC
run_vel_solver(LVs, LPs, LNVs) :-
findall(Ps, solve_vel(LVs, LNVs, Ps), LPs).
solve_vel([LVs|_], [NVs0|_], Ps) :-
length(NVs0, L), (L > 64 -> clpbn_gviz:clpbn2gviz(user_error,sort,NVs0,LVs) ; true ),
find_all_clpbn_vars(NVs0, NVs0, LV0, LVi, Tables0),
sort(LV0, LV),
% construct the graph
find_all_table_deps(Tables0, LV),
process(LVi, LVs, tab(Dist,_,_)),
% move from potentials back to probabilities
normalise_CPT(Dist,MPs),
list_from_CPT(MPs, Ps).
solve_vel([_|MoreLVs], [_|MoreLVis], Ps) :-
solve_vel(MoreLVs, MoreLVis, Ps).
keys([],[]).
keys([V|NVs0],[K:E|Ks]) :-
clpbn:get_atts(V,[key(K),evidence(E)]), !,
keys(NVs0,Ks).
keys([V|NVs0],[K|Ks]) :-
clpbn:get_atts(V,[key(K)]),
keys(NVs0,Ks).
%
% just get a list of variables plus associated tables
%
find_all_clpbn_vars([], _, [], [], []) :- !.
find_all_clpbn_vars([V|Vs], NVs0, [Var|LV], ProcessedVars, [table(I,Table,Parents,Sizes)|Tables]) :-
var_with_deps(V, NVs0, Table, Parents, Sizes, Ev, Vals), !,
% variables with evidence should not be processed.
(var(Ev) ->
Var = var(V,I,Sz,Vals,Parents,Ev,_,_),
vel_get_dist_size(V,Sz),
ProcessedVars = [Var|ProcessedVars0]
;
ProcessedVars = ProcessedVars0
),
find_all_clpbn_vars(Vs, NVs0, LV, ProcessedVars0, Tables).
var_with_deps(V, NVs0, Table, Deps, Sizes, Ev, Vals) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
get_dist_matrix(Id,Parents,_,Vals,TAB0),
(
clpbn:get_atts(V, [evidence(Ev)])
->
true
;
true
), !,
% set CPT in canonical form
reorder_CPT([V|Parents],TAB0,Deps0,TAB1,Sizes1),
% remove evidence.
simplify_evidence(Deps0, NVs0, TAB1, Deps0, Sizes1, Table, Deps, Sizes).
find_all_table_deps(Tables0, LV) :-
find_dep_graph(Tables0, DepGraph0),
sort(DepGraph0, DepGraph),
add_table_deps_to_variables(LV, DepGraph).
find_dep_graph([], []) :- !.
find_dep_graph([table(I,Tab,Deps,Sizes)|Tables], DepGraph) :-
add_table_deps(Deps, I, Deps, Tab, Sizes, DepGraph0, DepGraph),
find_dep_graph(Tables, DepGraph0).
add_table_deps([], _, _, _, _, DepGraph, DepGraph).
add_table_deps([V|Deps], I, Deps0, Table, Sizes, DepGraph0, [V-tab(Table,Deps0,Sizes)|DepGraph]) :-
add_table_deps(Deps, I, Deps0, Table, Sizes, DepGraph0, DepGraph).
add_table_deps_to_variables([], []).
add_table_deps_to_variables([var(V,_,_,_,_,_,Deps,K)|LV], DepGraph) :-
steal_deps_for_variable(DepGraph, V, NDepGraph, Deps),
compute_size(Deps,[],K),
% ( clpbn:get_atts(V,[key(Key)]) -> format('~w:~w~n',[Key,K]) ; true),
add_table_deps_to_variables(LV, NDepGraph).
steal_deps_for_variable([V-Info|DepGraph], V0, NDepGraph, [Info|Deps]) :-
V == V0, !,
steal_deps_for_variable(DepGraph, V0, NDepGraph, Deps).
steal_deps_for_variable(DepGraph, _, DepGraph, []).
compute_size([],Vs,K) :-
% use sizes now
% length(Vs,K).
multiply_sizes(Vs,1,K).
compute_size([tab(_,Vs,_)|Tabs],Vs0,K) :-
ord_union(Vs,Vs0,VsI),
compute_size(Tabs,VsI,K).
multiply_sizes([],K,K).
multiply_sizes([V|Vs],K0,K) :-
vel_get_dist_size(V, Sz),
KI is K0*Sz,
multiply_sizes(Vs,KI,K).
process(LV0, InputVs, Out) :-
find_best(LV0, V0, -1, V, WorkTables, LVI, InputVs),
V \== V0, !,
% format('1 ~w: ~w~n',[V,WorkTables]),
multiply_tables(WorkTables, tab(Tab0,Deps0,_)),
reorder_CPT(Deps0,Tab0,Deps,Tab,Sizes),
Table = tab(Tab,Deps,Sizes),
% format('2 ~w: ~w~n',[V,Table]),
project_from_CPT(V,Table,NewTable),
% format('3 ~w: ~w~n',[V,NewTable]),
include(LVI,NewTable,V,LV2),
process(LV2, InputVs, Out).
process(LV0, _, Out) :-
fetch_tables(LV0, WorkTables),
multiply_tables(WorkTables, Out).
find_best([], V, _TF, V, _, [], _).
%:-
% clpbn:get_atts(V,[key(K)]), writeln(chosen:K:_TF).
% root_with_single_child
%find_best([var(V,I,_,_,[],Ev,[Dep],K)|LV], _, _, V, [Dep], LVF, Inputs) :- !.
find_best([var(V,I,Sz,Vals,Parents,Ev,Deps,K)|LV], _, Threshold, VF, NWorktables, LVF, Inputs) :-
( K < Threshold ; Threshold < 0),
clpbn_not_var_member(Inputs, V), !,
find_best(LV, V, K, VF, WorkTables,LV0, Inputs),
(V == VF ->
LVF = LV0, Deps = NWorktables
;
LVF = [var(V,I,Sz,Vals,Parents,Ev,Deps,K)|LV0], WorkTables = NWorktables
).
find_best([V|LV], V0, Threshold, VF, WorkTables, [V|LVF], Inputs) :-
find_best(LV, V0, Threshold, VF, WorkTables, LVF, Inputs).
multiply_tables([Table], Table) :- !. %, Table = tab(T,D,S),matrix:matrix_to_list(T,L),writeln(D:S:L).
multiply_tables([TAB1, TAB2| Tables], Out) :-
%TAB1 = tab(T,_,_),matrix:matrix_to_list(T,L),writeln(doing:L),
multiply_CPTs(TAB1, TAB2, TAB, _),
multiply_tables([TAB| Tables], Out).
simplify_evidence([], _, Table, Deps, Sizes, Table, Deps, Sizes).
simplify_evidence([V|VDeps], NVs0, Table0, Deps0, Sizes0, Table, Deps, Sizes) :-
clpbn:get_atts(V, [evidence(_)]), !,
project_from_CPT(V,tab(Table0,Deps0,Sizes0),tab(NewTable,Deps1,Sizes1)),
simplify_evidence(VDeps, NVs0, NewTable, Deps1, Sizes1, Table, Deps, Sizes).
simplify_evidence([V|VDeps], NVs0, Table0, Deps0, Sizes0, Table, Deps, Sizes) :-
ord_member(V, NVs0), !,
simplify_evidence(VDeps, NVs0, Table0, Deps0, Sizes0, Table, Deps, Sizes).
simplify_evidence([V|VDeps], NVs0, Table0, Deps0, Sizes0, Table, Deps, Sizes) :-
project_from_CPT(V,tab(Table0,Deps0,Sizes0),tab(NewTable,Deps1,Sizes1)),
simplify_evidence(VDeps, NVs0, NewTable, Deps1, Sizes1, Table, Deps, Sizes).
fetch_tables([], []).
fetch_tables([var(_,_,_,_,_,_,Deps,_)|LV0], Tables) :-
append(Deps,Tables0,Tables),
fetch_tables(LV0, Tables0).
include([],_,_,[]).
include([var(V,P,VSz,D,Parents,Ev,Tabs,Est)|LV],tab(T,Vs,Sz),V1,[var(V,P,VSz,D,Parents,Ev,Tabs,Est)|NLV]) :-
clpbn_not_var_member(Vs,V), !,
include(LV,tab(T,Vs,Sz),V1,NLV).
include([var(V,P,VSz,D,Parents,Ev,Tabs,_)|LV],Table,NV,[var(V,P,VSz,D,Parents,Ev,NTabs,NEst)|NLV]) :-
update_tables(Tabs,NTabs,Table,NV),
compute_size(NTabs, [], NEst),
include(LV,Table,NV,NLV).
update_tables([],[Table],Table,_).
update_tables([tab(Tab0,Vs,Sz)|Tabs],[tab(Tab0,Vs,Sz)|NTabs],Table,V) :-
clpbn_not_var_member(Vs,V), !,
update_tables(Tabs,NTabs,Table,V).
update_tables([_|Tabs],NTabs,Table,V) :-
update_tables(Tabs,NTabs,Table,V).
vel_get_dist_size(V,Sz) :-
get_atts(V, [size(Sz)]), !.
vel_get_dist_size(V,Sz) :-
clpbn:get_atts(V,dist(Id,_)), !,
get_dist_domain_size(Id,Sz),
put_atts(V, [size(Sz)]).

235
packages/CLPBN/clpbn/viterbi.yap Normal file
View File

@ -0,0 +1,235 @@
%:- style_check(all).
:- module(viterbi, [viterbi/4]).
:- use_module(library(lists),
[nth/3,
member/2]).
:- use_module(library(assoc)).
:- use_module(library(dgraphs)).
:- use_module(library(matrix)).
:- use_module(library(clpbn), []).
:- ensure_loaded(library('clpbn/hmm')).
:- use_module(library('clpbn/dists'), [
get_dist_params/2]).
:- meta_predicate viterbi(:,:,+,-).
viterbi(Start,End,String,Trace) :-
init_hmm,
Start,
mk_graph(NOfNodes, Map, ViterbiCode),
compile_trace(String, Emissions),
get_id(Start, Map, SI),
get_id(End, Map, EI),
% add a random symbol in front (for the c/1 state).
compiled_viterbi(NOfNodes, SI, ViterbiCode, Emissions, Dump, L),
backtrace(Dump, EI, Map, L, Trace).
state_from_goal(_:Start,S) :-
state_from_goal(Start,S).
state_from_goal(Start,S) :-
functor(Start, N, Ar),
% get rid of position and random var
NAr is Ar-2,
functor(S, N, NAr).
mk_graph(NOfNodes, Map, ViterbiCode) :-
attributes:all_attvars(Vars0),
empty_assoc(KeyMap0),
get_graph(Vars0, Nodes, Edges, KeyMap0, KeyMap),
dgraph_new(G0),
dgraph_add_vertices(G0, Nodes, G1),
dgraph_add_edges(G1, Edges, G2),
dgraph_top_sort(G2, SortedNodes),
compile_viterbi(SortedNodes, KeyMap, NOfNodes, Map, ViterbiCode).
get_graph([V|Vs], [NKey|Keys], EdgesF, KeyMap0, KeyMap) :-
clpbn:get_atts(V,[key(Key), dist(Id,Parents)]),
( Key =.. [N,2|More] ; Key = s(0), N=s, More=[] ), !,
NKey =.. [N|More],
fetch_edges(Parents, NKey, EdgesF, Edges0, PKeys),
get_emission(V, Key, EmissionProb),
put_assoc(NKey,KeyMap0,nodeinfo(_,Id,EmissionProb,PKeys),KeyMapI),
get_graph(Vs, Keys, Edges0, KeyMapI, KeyMap).
get_graph([_|Vs], Keys, Edges, KeyMap0, KeyMap) :-
get_graph(Vs, Keys, Edges, KeyMap0, KeyMap).
get_graph([], [], [], KeyMap, KeyMap).
get_emission(V, Key, EmissionProbs) :-
hmm:get_atts(V,[emission(_)]), !,
user:emission_cpt(Key, EmissionProbs).
get_emission(_, _, []).
fetch_edges([V|Parents], Key0, EdgesF, Edges0, [Slice-AKey|PKeys]) :-
var(V), !,
clpbn:get_atts(V,[key(Key)]),
abstract_key(Key, AKey, Slice),
(
Slice < 3
->
EdgesF = [Key0-AKey|EdgesI]
;
EdgesF = EdgesI
),
fetch_edges(Parents, Key0, EdgesI, Edges0, PKeys).
fetch_edges([Key|Parents], Key0, EdgesF, Edges0, [Slice-AKey|PKeys]) :-
abstract_key(Key, AKey, Slice),
(
Slice < 3
->
EdgesF = [Key0-AKey|EdgesI]
;
EdgesF = EdgesI
),
fetch_edges(Parents, Key0, EdgesI, Edges0, PKeys).
fetch_edges([], _, Edges, Edges, []).
abstract_key(Key, NKey, Slice) :-
Key =.. [N,Slice|More],
NKey =.. [N|More].
compile_viterbi(Keys, KeyMap, Nodes, Map, ViterbiCode) :-
enum_keys(Keys, KeyMap, 0, Nodes, Map),
compile_keys(Keys, KeyMap, ViterbiCode).
% just enumerate keys
enum_keys([], _, I, I, []).
enum_keys([Key|Keys], KeyMap, I0, Nodes, [I0-Key|Map]) :-
get_assoc(Key,KeyMap,nodeinfo(I0,_,_,_)),
I is I0+1,
enum_keys(Keys, KeyMap, I, Nodes, Map).
compile_keys([Key|Keys], KeyMap, ViterbiCodeF) :-
get_assoc(Key,KeyMap,nodeinfo(IKey,Id,Emission,PKeys)),
compile_emission(Emission,IKey,ViterbiCodeF,ViterbiCodeI),
get_dist_params(Id,Probs),
compile_propagation(PKeys,Probs,IKey,KeyMap,ViterbiCodeI,ViterbiCode0),
compile_keys(Keys, KeyMap, ViterbiCode0).
compile_keys([], _, []).
% add a random symbol to the end.
compile_emission([],_) --> !, [].
compile_emission(EmissionTerm,IKey) --> [emit(IKey,EmissionTerm)].
compile_propagation([],[],_,_) --> [].
compile_propagation([0-PKey|Ps], [Prob|Probs], IKey, KeyMap) -->
[prop_same(IKey,Parent,Prob)],
{ get_assoc(PKey,KeyMap,nodeinfo(Parent,_,_,_)) },
compile_propagation(Ps, Probs, IKey, KeyMap).
compile_propagation([2-PKey|Ps], [Prob|Probs], IKey, KeyMap) -->
[prop_same(IKey,Parent,Prob)],
{ get_assoc(PKey,KeyMap,nodeinfo(Parent,_,_,_)) },
compile_propagation(Ps, Probs, IKey, KeyMap).
compile_propagation([3-PKey|Ps], [Prob|Probs], IKey, KeyMap) -->
[prop_next(IKey,Parent,Prob)],
{ get_assoc(PKey,KeyMap,nodeinfo(Parent,_,_,_)) },
compile_propagation(Ps, Probs, IKey, KeyMap).
get_id(_:S, Map, SI) :- !,
get_id(S, Map, SI).
get_id(S, Map, SI) :-
functor(S,N,A),
A2 is A-2,
functor(S2,N,A2),
once(member(SI-S2,Map)).
compile_trace(Trace, Emissions) :-
user:hmm_domain(Domain),
(atom(Domain) ->
hmm:cvt_vals(Domain, Vals)
;
Vals = Domain
),
compile_trace(Trace, Vals, Emissions).
compile_trace([], _, []).
compile_trace([El|Trace], Vals, [N|Emissions]) :-
once(nth(N, Vals, El)),
compile_trace(Trace, Vals, Emissions).
compiled_viterbi(Nodes, S, Commands, Input, Trace, L) :-
length(Input,L),
prolog_flag(min_tagged_integer, Min),
matrix_new_set(ints,[Nodes], Min, Current),
matrix_new_set(ints,[Nodes], Min, Next),
L1 is L+1,
matrix_new(ints,[L1,Nodes], Trace),
matrix_set(Current, [S], 0),
run_commands(Input, Commands, 0, Current, Next, Trace, Min).
run_commands([], _, _, _, _, _, _).
run_commands([E|Input], Commands, I, Current, Next, Trace, Min) :-
run_code(Commands, E, I, Current, Next, Trace),
matrix_get(Current, [32], M10),
matrix_get(Current, [34], C),
matrix_set_all(Current,Min),
I1 is I+1,
run_commands(Input, Commands, I1, Next, Current, Trace, Min).
run_code([], _, _, _, _, Trace).
run_code([Inst|Input], E, I, Current, Next, Trace) :-
run_inst(Inst, E, I, Current, Next, Trace) ,
run_code(Input, E, I, Current, Next, Trace).
run_inst(emit(Id,T), E, _SP, Current, _, Trace) :-
arg(E,T,P),
matrix_add(Current, [Id], P).
run_inst(prop_same(I,P,Prob), _, SP, Current, _, Trace) :-
matrix_get(Current, [I], PI),
NP is PI+Prob,
matrix_get(Current, [P], P0),
(NP > P0 ->
matrix_set(Current, [P], NP),
matrix_set(Trace, [SP,P], I)
;
true
).
run_inst(prop_next(I,P,Prob), _, SP, Current, Next, Trace) :-
matrix_get(Current, [I], PI),
NP is PI+Prob,
matrix_get(Next, [P], P0),
(NP > P0 ->
matrix_set(Next, [P], NP),
SP1 is SP+1,
IN is -I,
matrix_set(Trace, [SP1,P], IN)
;
true
).
backtrace(Dump, EI, Map, L, Trace) :-
L1 is L-1,
Pos = [L1,EI],
matrix_get(Dump,Pos,Next),
trace(L1,Next,Dump,Map,[],Trace).
trace(0,0,_,_,Trace,Trace) :- !.
trace(L1,Next,Dump,Map,Trace0,Trace) :-
(Next < 0 ->
NL is L1-1,
P is -Next
;
NL = L1,
P = Next
),
once(member(P-AKey,Map)),
AKey=..[N|Args],
Key=..[N,NL|Args],
matrix_get(Dump,[NL,P],New),
trace(NL,New,Dump,Map,[Key|Trace0],Trace).

119
packages/CLPBN/clpbn/xbif.yap Normal file
View File

@ -0,0 +1,119 @@
%
% XMLBIF support for CLP(BN)
%
:- module(xbif, [clpbn2xbif/3]).
:- use_module(library('clpbn/dists'), [
get_dist_domain/2]).
clpbn2xbif(Stream, Name, Network) :-
format(Stream, '<?xml version="1.0" encoding="US-ASCII"?>
<!--
Bayesian network in XMLBIF v0.3 (BayesNet Interchange Format)
Produced by CLP(BN)
-->
<!-- DTD for the XMLBIF 0.3 format -->
<!DOCTYPE BIF [
<!ELEMENT BIF ( NETWORK )*>
<!ATTLIST BIF VERSION CDATA #REQUIRED>
<!ELEMENT NETWORK ( NAME, ( PROPERTY | VARIABLE | DEFINITION )* )>
<!ELEMENT NAME (#PCDATA)>
<!ELEMENT VARIABLE ( NAME, ( OUTCOME | PROPERTY )* ) >
<!ATTLIST VARIABLE TYPE (nature|decision|utility) "nature">
<!ELEMENT OUTCOME (#PCDATA)>
<!ELEMENT DEFINITION ( FOR | GIVEN | TABLE | PROPERTY )* >
<!ELEMENT FOR (#PCDATA)>
<!ELEMENT GIVEN (#PCDATA)>
<!ELEMENT TABLE (#PCDATA)>
<!ELEMENT PROPERTY (#PCDATA)>
]>
<BIF VERSION="0.3">
<NETWORK>
<NAME>~w</NAME>
<!-- Variables -->',[Name]),
output_vars(Stream, Network),
output_dists(Stream, Network),
format(Stream, '</NETWORK>
</BIF>
',[]).
output_vars(_, []).
output_vars(Stream, [V|Vs]) :-
output_var(Stream, V),
output_vars(Stream, Vs).
output_var(Stream, V) :-
clpbn:get_atts(V,[key(Key),dist(Id,_)]),
get_dist_domain(Id, Domain),
format(Stream, '<VARIABLE TYPE="nature">
<NAME>',[]),
output_key(Stream,Key),
format('</NAME>~n',[]),
output_domain(Stream, Domain),
format(Stream, '</VARIABLE>~n~n',[]).
output_domain(_, []).
output_domain(Stream, [El|Domain]) :-
format(Stream, ' <OUTCOME>~q</OUTCOME>~n',[El]),
output_domain(Stream, Domain).
output_dists(_, []).
output_dists(Stream, [V|Network]) :-
output_dist(Stream, V),
output_dists(Stream, Network).
output_dist(Stream, V) :-
clpbn:get_atts(V,[key(Key),dist(_,CPT,Parents)]),
format(Stream, '<DEFINITION>
<FOR>',[]),
output_key(Stream, Key),
format('</FOR>~n',[]),
output_parents(Stream,Parents),
output_cpt(Stream,CPT),
format(Stream, '</DEFINITION>~n~n',[]).
output_parents(_,[]).
output_parents(Stream,[P1|Ps]) :-
clpbn:get_atts(P1,[key(Key)]),
format(Stream, '<GIVEN>',[]),
output_key(Stream,Key),
format('</GIVEN>~n',[]),
output_parents(Stream,Ps).
output_cpt(Stream,CPT) :-
format(Stream, ' <TABLE> ', []),
output_els(Stream, CPT),
format(Stream, '</TABLE>~n', []).
output_els(_, []).
output_els(Stream, [El|Els]) :-
format(Stream,'~f ',[El]),
output_els(Stream, Els).
output_key(Stream, Key) :-
output_key(Stream, 0, Key).
output_key(Stream, _, Key) :-
primitive(Key), !,
write(Stream, Key).
output_key(Stream, I0, Key) :-
Key =.. [Name|Args],
write(Stream, Name),
I is I0+1,
output_key_args(Stream, I, Args).
output_key_args(_, _, []).
output_key_args(Stream, I, [Arg|Args]) :-
format(Stream, '~*c', [I,0'_]),
output_key(Stream, I, Arg),
output_key_args(Stream, I, Args).

306
packages/CLPBN/learning/aleph_params.yap Normal file
View File

@ -0,0 +1,306 @@
%
% Interface the Aleph ILP system to CLP(BN)
%
% Relies on the Aleph cost function.
% It assumes Aleph work as usual, but some variables are of type random.
%
:- module(clpbn_aleph,
[init_clpbn_cost/0,
random_type/2]).
:- dynamic rt/2, inited/1.
:- use_module(library('clpbn'),
[{}/1,
clpbn_flag/2,
clpbn_flag/3,
set_clpbn_flag/2]).
:- use_module(library('clpbn/learning/em')).
:- use_module(library('clpbn/matrix_cpt_utils'),
[uniform_CPT_as_list/2]).
:- use_module(library('clpbn/dists'),
[reset_all_dists/0,
get_dist_key/2,
get_dist_params/2
]).
:- use_module(library('clpbn/table'),
[clpbn_tabled_abolish/1,
clpbn_tabled_asserta/1,
clpbn_tabled_asserta/2,
clpbn_tabled_assertz/1,
clpbn_tabled_clause/2,
clpbn_tabled_number_of_clauses/2,
clpbn_is_tabled/1,
clpbn_tabled_dynamic/1]).
%
% Tell Aleph not to use default solver during saturation
%
% all work will be done by EM
:- set_clpbn_flag(solver,none).
%
% This is the Aleph interface
% examples are stored as example(Id, Type, Example)
% CPT domains are stored as random_type(KeySkeleton, ListOfValues).
%
:- use_module(library(lists),[append/3]).
:- multifile user:cost/3.
% handle uninstantiated examples as hidden variables.
:- user:set(skolem_examples, false).
% avoid doing CLP(BN) stuff except at start
:- user:set(sat_start_hook, clpbn_aleph:disable_solver).
:- user:set(sat_stop_hook, clpbn_aleph:enable_solver).
:- user:set(reduce_start_hook, clpbn_aleph:disable_solver).
:- user:set(reduce_stop_hook, clpbn_aleph:enable_solver).
:- user:set(record_testclause_hook, clpbn_aleph:do_nothing).
:- user:set(newbest_hook, clpbn_aleph:store_theory).
disable_solver(_) :-
clpbn_flag(solver, Old, none),
nb_setval(old_clpbn_solver, Old).
disable_solver(_,_) :-
clpbn_flag(solver, Old, none),
nb_setval(old_clpbn_solver, Old).
enable_solver :-
nb_getval(old_clpbn_solver, Old),
set_clpbn_flag(solver, Old).
enable_solver(_,_) :-
nb_getval(old_clpbn_solver, Old),
set_clpbn_flag(solver, Old).
do_nothing(_).
% backup current best theory in DB.
store_theory(_,_,_) :-
eraseall(best_theory),
fail.
store_theory(_,(H:-_),_) :-
clpbn_is_tabled(user:H), !,
store_tabled_theory(H).
store_theory(_,(H:-_),_) :-
store_theory(H).
store_tabled_theory(H) :-
clpbn_tabled_clause(user:H,B),
add_correct_cpt(B,NB),
store_cl((H:-NB)),
fail.
store_tabled_theory(_).
store_theory(H) :-
clause(user:H,B),
add_correct_cpt(B,NB),
store_cl((H:-NB)),
fail.
store_theory(_).
add_correct_cpt((G,B),(G,NB)) :- !,
add_correct_cpt(B,NB).
add_correct_cpt((clpbn:{V = K with Tab }), ({V = K with NTab})) :-
correct_tab(Tab,K,NTab).
add_correct_cpt(({V = K with Tab }), ({V = K with NTab})) :-
correct_tab(Tab,K,NTab).
correct_tab(p(Vs,_),K,p(Vs,TDist)) :-
get_dist_key(Id, K),
get_dist_params(Id, TDist).
correct_tab(p(Vs,_,Ps),K,p(Vs,TDist,Ps)) :-
get_dist_key(Id, K),
get_dist_params(Id, TDist).
store_cl(Cl) :-
recordz(best_theory, Cl, _).
:- user:set(best_clause_hook, clpbn_aleph:add_new_clause).
add_new_clause(_,(_ :- true),_,_) :- !.
add_new_clause(_,(H :- B),_,_) :-
user:db_usage,
user:db_dynamic,
domain(H, K, V, D),
rewrite_body(B, IB, Vs, _, ( !, { V = K with p(D, CPTList, Vs) })),
% need to remember which CPT we want
get_dist_key(Id, K),
get_dist_params(Id, CPTList),
(
clpbn_is_tabled(user:H)
->
clpbn_tabled_asserta(user:(H :- IB))
;
asserta(user:(H :- IB))
),
user:setting(verbosity,V),
( V >= 1 ->
user:p_message('CLP(BN) Theory'),
functor(H,N,Ar), listing(user:N/Ar)
;
true
).
% user-defined cost function, Aleph knows about this (and only about this).
user:cost((H :- B),Inf,Score) :- !,
domain(H, K, V, D),
check_info(Inf),
rewrite_body(B, IB, Vs, Ds, ( !, { V = K with p(D, CPTList, Vs) })),
uniform_cpt([D|Ds], CPTList),
(
clpbn_is_tabled(user:H)
->
clpbn_tabled_asserta(user:(H :- IB), R)
;
asserta(user:(H :- IB), R)
),
(
cpt_score(Score0)
->
erase(R),
Score is -Score0
;
% illegal clause, just get out of here.
erase(R),
fail
).
user:cost(H,_Inf,Score) :- !,
init_clpbn_cost(H, Score0),
Score is -Score0.
% this is here so that Aleph will actually compute coverage. Aleph computes
% coverage only if cost actually checks Inf.
check_info(_).
init_clpbn_cost(_, Score) :-
inited(Score), !.
init_clpbn_cost(H, Score) :-
functor(H,N,A),
% get rid of Aleph crap
(
clpbn_is_tabled(user:H)
->
clpbn_tabled_abolish(user:N/A),
clpbn_tabled_dynamic(user:N/A)
;
abolish(user:N/A),
% make it easy to add and remove clauses.
dynamic(user:N/A)
),
domain(H, K, V, D),
uniform_cpt([D], CPTList),
% This will be the default cause, called when the other rules fail.
(
clpbn_is_tabled(user:H)
->
clpbn_tabled_assertz(user:(H :- !, { V = K with p(D, CPTList) }))
;
assert(user:(H :- !, { V = K with p(D, CPTList) }))
),
cpt_score(Score),
assert(inited(Score)).
% receives H, and generates a key K, a random variable RV, and a domain D.
domain(H, K, RV, D) :-
functor(H,Name,Arity),
functor(Pred,Name,Arity),
(
recorded(aleph,modeh(_,Pred),_)
->
true
;
user:'$aleph_global'(modeh,modeh(_,Pred))
),
arg(Arity,Pred,+RType),
rt(RType,D), !,
key_from_head(H,K,RV).
domain(H, K, V, D) :-
current_predicate(_,user:domain(_)),
key_from_head(H,K,V),
user:domain(K,D).
key_from_head(H,K,V) :-
H =.. [Name|Args],
(
clpbn_is_tabled(user:H)
->
clpbn_tabled_number_of_clauses(user:H,NClauses)
;
predicate_property(user:H,number_of_clauses(NClauses))
),
atomic_concat(Name,NClauses,NName),
append(H0L,[V],Args),
K =.. [NName|H0L].
% transforms_body into something that is going to be called
% receives G0, and generates a list of goals, a list of variables, and a list of domains.
% receives also a Tail with the constraint to append at the end.
rewrite_body((A,B), (user:NA,NB), [V|Vs], [D|Ds], Tail) :-
rewrite_goal(A, V, D, NA), !,
rewrite_body(B, NB, Vs, Ds, Tail).
rewrite_body((A,B), (user:A,NB), Vs, Ds, Tail) :-
rewrite_body(B,NB, Vs, Ds, Tail).
rewrite_body(A,(user:NA,Tail), [V], [D], Tail) :-
rewrite_goal(A, V, D, NA), !.
rewrite_body(A, (user:A,Tail), [], [], Tail).
% so they need not be rewritten.
rewrite_goal(A,V,D,NA) :-
functor(A,Name,Arity),
functor(Pred,Name,Arity),
(
recorded(aleph,modeb(_,Pred),_)
->
true
;
user:'$aleph_global'(modeb,modeb(_,Pred))
),
arg(Arity,Pred,-RType),
rt(RType,D), !,
A =.. [Name|Args],
replace_last_var(Args,V,NArgs),
NA =.. [Name|NArgs].
replace_last_var([_],V,[V]) :- !.
replace_last_var([A|Args],V,[A|NArgs]) :-
replace_last_var(Args,V,NArgs).
%
% This is the key
%
cpt_score(Lik) :-
findall(user:Ex, user:example(_,pos,Ex), Exs),
clpbn_flag(solver, Solver),
clpbn_flag(em_solver, EMSolver),
set_clpbn_flag(solver, EMSolver),
reset_all_dists,
em(Exs, 0.01, 10, _Tables, Lik),
set_clpbn_flag(solver, Solver).
complete_clpbn_cost(_AlephClause).
random_type(A,B) :-
assert(rt(A,B)).
uniform_cpt(Ds, CPTList) :-
lengths(Ds, Ls),
uniform_CPT_as_list(Ls, CPTList).
lengths([], []).
lengths([D|Ds], [L|Ls]) :-
length(D, L),
lengths(Ds, Ls).

121
packages/CLPBN/learning/bnt_parms.yap Normal file
View File

@ -0,0 +1,121 @@
%
% Learn parameters using the BNT toolkit
%
:- yap_flag(unknown,error).
:- style_check(all).
:- module(bnt_parameters, [learn_parameters/2]).
:- use_module(library('clpbn'), [
clpbn_flag/3]).
:- use_module(library('clpbn/bnt'), [
create_bnt_graph/2]).
:- use_module(library('clpbn/display'), [
clpbn_bind_vals/3]).
:- use_module(library('clpbn/dists'), [
get_dist_domain/2
]).
:- use_module(library(matlab), [matlab_initialized_cells/4,
matlab_call/2,
matlab_get_variable/2
]).
:- dynamic bnt_em_max_iter/1.
bnt_em_max_iter(10).
% syntactic sugar for matlab_call.
:- op(800,yfx,<--).
G <-- Y :-
matlab_call(Y,G).
learn_parameters(Items, Tables) :-
run_all(Items),
clpbn_flag(solver, OldSolver, bnt),
clpbn_flag(bnt_model, Old, tied),
attributes:all_attvars(AVars),
% sort and incorporte evidence
clpbn_vars(AVars, AllVars),
length(AllVars,NVars),
create_bnt_graph(AllVars, Reps),
mk_sample(AllVars,NVars,EvVars),
bnt_learn_parameters(NVars,EvVars),
get_parameters(Reps, Tables),
clpbn_flag(solver, bnt, OldSolver),
clpbn_flag(bnt_model, tied, Old).
run_all([]).
run_all([G|Gs]) :-
call(user:G),
run_all(Gs).
clpbn_vars(Vs,BVars) :-
get_clpbn_vars(Vs,CVs),
keysort(CVs,KVs),
merge_vars(KVs,BVars).
get_clpbn_vars([],[]).
get_clpbn_vars([V|GVars],[K-V|CLPBNGVars]) :-
clpbn:get_atts(V, [key(K)]), !,
get_clpbn_vars(GVars,CLPBNGVars).
get_clpbn_vars([_|GVars],CLPBNGVars) :-
get_clpbn_vars(GVars,CLPBNGVars).
merge_vars([],[]).
merge_vars([K-V|KVs],[V|BVars]) :-
get_var_has_same_key(KVs,K,V,KVs0),
merge_vars(KVs0,BVars).
get_var_has_same_key([K-V|KVs],K,V,KVs0) :- !,
get_var_has_same_key(KVs,K,V,KVs0).
get_var_has_same_key(KVs,_,_,KVs).
mk_sample(AllVars,NVars, LL) :-
add2sample(AllVars, LN),
length(LN,LL),
matlab_initialized_cells( NVars, 1, LN, sample).
add2sample([], []).
add2sample([V|Vs],[val(VId,1,Val)|Vals]) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,_)]), !,
bnt:get_atts(V,[bnt_id(VId)]),
get_dist_domain(Id, Domain),
evidence_val(Ev,1,Domain,Val),
add2sample(Vs, Vals).
add2sample([_V|Vs],Vals) :-
add2sample(Vs, Vals).
evidence_val(Ev,Val,[Ev|_],Val) :- !.
evidence_val(Ev,I0,[_|Domain],Val) :-
I1 is I0+1,
evidence_val(Ev,I1,Domain,Val).
bnt_learn_parameters(_,_) :-
engine <-- jtree_inf_engine(bnet),
% engine <-- var_elim_inf_engine(bnet),
% engine <-- gibbs_sampling_inf_engine(bnet),
% engine <-- belprop_inf_engine(bnet),
% engine <-- pearl_inf_engine(bnet),
bnt_em_max_iter(MaxIters),
[new_bnet, trace] <-- learn_params_em(engine, sample, MaxIters).
get_parameters([],[]).
get_parameters([Rep-v(_,_,_)|Reps],[CPT|CPTs]) :-
get_new_table(Rep,CPT),
get_parameters(Reps,CPTs).
get_new_table(Rep,CPT) :-
s <-- struct(new_bnet.'CPD'({Rep})),
matlab_get_variable( s.'CPT', CPT).

229
packages/CLPBN/learning/em.yap Normal file
View File

@ -0,0 +1,229 @@
%
% The world famous EM algorithm, in a nutshell
%
:- module(clpbn_em, [em/5]).
:- use_module(library(lists),
[append/3]).
:- use_module(library(clpbn),
[clpbn_init_solver/5,
clpbn_run_solver/4,
clpbn_flag/2]).
:- use_module(library('clpbn/dists'),
[get_dist_domain_size/2,
empty_dist/2,
dist_new_table/2,
get_dist_key/2,
randomise_all_dists/0,
uniformise_all_dists/0]).
:- use_module(library('clpbn/connected'),
[clpbn_subgraphs/2]).
:- use_module(library('clpbn/learning/learn_utils'),
[run_all/1,
clpbn_vars/2,
normalise_counts/2,
compute_likelihood/3,
soften_sample/2]).
:- use_module(library(lists),
[member/2]).
:- use_module(library(matrix),
[matrix_add/3,
matrix_to_list/2]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_insert/4,
rb_lookup/3]).
:- use_module(library('clpbn/utils'),
[
check_for_hidden_vars/3,
sort_vars_by_key/3]).
:- meta_predicate em(:,+,+,-,-), init_em(:,-).
em(Items, MaxError, MaxIts, Tables, Likelihood) :-
catch(init_em(Items, State),Error,handle_em(Error)),
em_loop(0, 0.0, State, MaxError, MaxIts, Likelihood, Tables),
assert(em_found(Tables, Likelihood)),
fail.
% get rid of new random variables the easy way :)
em(_, _, _, Tables, Likelihood) :-
retract(em_found(Tables, Likelihood)).
handle_em(error(repeated_parents)) :-
assert(em_found(_, -inf)),
fail.
% This gets you an initial configuration. If there is a lot of evidence
% tables may be filled in close to optimal, otherwise they may be
% close to uniform.
% it also gets you a run for random variables
% state collects all Info we need for the EM algorithm
% it includes the list of variables without evidence,
% the list of distributions for which we want to compute parameters,
% and more detailed info on distributions, namely with a list of all instances for the distribution.
init_em(Items, state( AllDists, AllDistInstances, MargVars, SolverVars)) :-
run_all(Items),
% randomise_all_dists,
uniformise_all_dists,
attributes:all_attvars(AllVars0),
sort_vars_by_key(AllVars0,AllVars,[]),
% remove variables that do not have to do with this query.
% check_for_hidden_vars(AllVars1, AllVars1, AllVars),
different_dists(AllVars, AllDists, AllDistInstances, MargVars),
clpbn_flag(em_solver, Solver),
clpbn_init_solver(Solver, MargVars, AllVars, _, SolverVars).
% loop for as long as you want.
em_loop(Its, Likelihood0, State, MaxError, MaxIts, LikelihoodF, FTables) :-
estimate(State, LPs),
maximise(State, Tables, LPs, Likelihood),
% writeln(Likelihood:Its:Likelihood0:Tables),
(
(
abs((Likelihood - Likelihood0)/Likelihood) < MaxError
;
Its == MaxIts
)
->
ltables(Tables, FTables),
LikelihoodF = Likelihood
;
Its1 is Its+1,
em_loop(Its1, Likelihood, State, MaxError, MaxIts, LikelihoodF, FTables)
).
ltables([], []).
ltables([Id-T|Tables], [Key-LTable|FTables]) :-
matrix_to_list(T,LTable),
get_dist_key(Id, Key),
ltables(Tables, FTables).
% collect the different dists we are going to learn next.
different_dists(AllVars, AllDists, AllInfo, MargVars) :-
all_dists(AllVars, Dists0),
sort(Dists0, Dists1),
group(Dists1, AllDists, AllInfo, MargVars0, []),
sort(MargVars0, MargVars).
all_dists([], []).
all_dists([V|AllVars], [i(Id, [V|Parents], Cases, Hiddens)|Dists]) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
sort([V|Parents], Sorted),
length(Sorted, LengSorted),
length(Parents, LengParents),
(
LengParents+1 =:= LengSorted
->
true
;
throw(error(repeated_parents))
),
generate_hidden_cases([V|Parents], CompactCases, Hiddens),
uncompact_cases(CompactCases, Cases),
all_dists(AllVars, Dists).
generate_hidden_cases([], [], []).
generate_hidden_cases([V|Parents], [P|Cases], Hiddens) :-
clpbn:get_atts(V, [evidence(P)]), !,
generate_hidden_cases(Parents, Cases, Hiddens).
generate_hidden_cases([V|Parents], [Cases|MoreCases], [V|Hiddens]) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id, Sz),
gen_cases(0, Sz, Cases),
generate_hidden_cases(Parents, MoreCases, Hiddens).
gen_cases(Sz, Sz, []) :- !.
gen_cases(I, Sz, [I|Cases]) :-
I1 is I+1,
gen_cases(I1, Sz, Cases).
uncompact_cases(CompactCases, Cases) :-
findall(Case, is_case(CompactCases, Case), Cases).
is_case([], []).
is_case([A|CompactCases], [A|Case]) :-
integer(A), !,
is_case(CompactCases, Case).
is_case([L|CompactCases], [C|Case]) :-
member(C, L),
is_case(CompactCases, Case).
group([], [], []) --> [].
group([i(Id,Ps,Cs,[])|Dists1], [Id|Ids], [Id-[i(Id,Ps,Cs,[])|Extra]|AllInfo]) --> !,
same_id(Dists1, Id, Extra, Rest),
group(Rest, Ids, AllInfo).
group([i(Id,Ps,Cs,Hs)|Dists1], [Id|Ids], [Id-[i(Id,Ps,Cs,Hs)|Extra]|AllInfo]) -->
[Hs],
same_id(Dists1, Id, Extra, Rest),
group(Rest, Ids, AllInfo).
same_id([i(Id,Vs,Cases,[])|Dists1], Id, [i(Id, Vs, Cases, [])|Extra], Rest) --> !,
same_id(Dists1, Id, Extra, Rest).
same_id([i(Id,Vs,Cases,Hs)|Dists1], Id, [i(Id, Vs, Cases, Hs)|Extra], Rest) --> !,
[Hs],
same_id(Dists1, Id, Extra, Rest).
same_id(Dists, _, [], Dists) --> [].
compact_mvars([], []).
compact_mvars([X1,X2|MargVars], CMVars) :- X1 == X2, !,
compact_mvars([X2|MargVars], CMVars).
compact_mvars([X|MargVars], [X|CMVars]) :- !,
compact_mvars(MargVars, CMVars).
estimate(state(_, _, Margs, SolverState), LPs) :-
clpbn_flag(em_solver, Solver),
clpbn_run_solver(Solver, Margs, LPs, SolverState).
maximise(state(_,DistInstances,MargVars,_), Tables, LPs, Likelihood) :-
rb_new(MDistTable0),
create_mdist_table(MargVars, LPs, MDistTable0, MDistTable),
compute_parameters(DistInstances, Tables, MDistTable, 0.0, Likelihood, LPs:MargVars).
create_mdist_table([],[],MDistTable,MDistTable).
create_mdist_table([Vs|MargVars],[Ps|LPs],MDistTable0,MDistTable) :-
rb_insert(MDistTable0, Vs, Ps, MDistTableI),
create_mdist_table(MargVars, LPs, MDistTableI ,MDistTable).
compute_parameters([], [], _, Lik, Lik, _).
compute_parameters([Id-Samples|Dists], [Id-NewTable|Tables], MDistTable, Lik0, Lik, LPs:MargVars) :-
empty_dist(Id, Table0),
add_samples(Samples, Table0, MDistTable),
soften_sample(Table0, SoftenedTable),
matrix:matrix_sum(Table0,TotM),
normalise_counts(SoftenedTable, NewTable),
compute_likelihood(Table0, NewTable, DeltaLik),
dist_new_table(Id, NewTable),
NewLik is Lik0+DeltaLik,
compute_parameters(Dists, Tables, MDistTable, NewLik, Lik, LPs:MargVars).
add_samples([], _, _).
add_samples([i(_,_,[Case],[])|Samples], Table, MDistTable) :- !,
matrix_add(Table,Case,1.0),
add_samples(Samples, Table, MDistTable).
add_samples([i(_,_,Cases,Hiddens)|Samples], Table, MDistTable) :-
rb_lookup(Hiddens, Ps, MDistTable),
run_sample(Cases, Ps, Table),
add_samples(Samples, Table, MDistTable).
run_sample([], [], _).
run_sample([C|Cases], [P|Ps], Table) :-
matrix_add(Table, C, P),
run_sample(Cases, Ps, Table).

46
packages/CLPBN/learning/example/school_params.yap Normal file
View File

@ -0,0 +1,46 @@
% learn distribution for school database.
% we do not consider the aggregates yet.
:- [pos:train].
:- ['~/Yap/work/CLPBN/clpbn/examples/School/school_32'].
:- ['~/Yap/work/CLPBN/learning/em'].
main :-
findall(X,goal(X),L),
em(L,0.01,10,CPTs,Lik),
writeln(Lik:CPTs).
%
% change to 0.05, 0.1, 0.2 to make things simpler/harder
%
missing(0.3).
% miss 30% of the examples.
goal(professor_ability(P,V)) :-
pos:professor_ability(P,V1),
missing(X),
( random > X -> V = V1 ; true).
% miss 10% of the examples.
goal(professor_popularity(P,V)) :-
pos:professor_popularity(P,V1),
missing(X),
( random > X -> V = V1 ; true).
goal(registration_grade(P,V)) :-
pos:registration_grade(P,V1),
missing(X),
( random > X -> V = V1 ; true).
goal(student_intelligence(P,V)) :-
pos:student_intelligence(P,V1),
missing(X),
( random > X -> V = V1 ; true).
goal(course_difficulty(P,V)) :-
pos:course_difficulty(P,V1),
missing(X),
( random > X -> V = V1 ; true).
goal(registration_satisfaction(P,V)) :-
pos:registration_satisfaction(P,V1),
missing(X),
( random > X -> V = V1 ; true).

2433
packages/CLPBN/learning/example/train.yap Normal file
View File

File diff suppressed because it is too large Load Diff

100
packages/CLPBN/learning/learn_utils.yap Normal file
View File

@ -0,0 +1,100 @@
%
% Utilities for learning
%
:- module(clpbn_learn_utils, [run_all/1,
clpbn_vars/2,
normalise_counts/2,
compute_likelihood/3,
soften_sample/2,
soften_sample/3]).
:- use_module(library(clpbn),
[clpbn_flag/2]).
:- use_module(library('clpbn/table'),
[clpbn_reset_tables/0]).
:- use_module(library(matrix),
[matrix_agg_lines/3,
matrix_op_to_lines/4,
matrix_agg_cols/3,
matrix_op_to_cols/4,
matrix_to_logs/2,
matrix_op/4,
matrix_sum/2,
matrix_to_list/2,
matrix_op_to_all/4]).
:- meta_predicate run_all(:).
run_all([]).
run_all([G|Gs]) :-
call(G),
run_all(Gs).
run_all(M:Gs) :-
clpbn_reset_tables,
run_all(Gs,M).
run_all([],_).
run_all([G|Gs],M) :-
( call(M:G) -> true ; writeln(bad:M:G), break),
run_all(Gs,M).
clpbn_vars(Vs,BVars) :-
get_clpbn_vars(Vs,CVs),
keysort(CVs,KVs),
merge_vars(KVs,BVars).
get_clpbn_vars([],[]).
get_clpbn_vars([V|GVars],[K-V|CLPBNGVars]) :-
clpbn:get_atts(V, [key(K)]), !,
get_clpbn_vars(GVars,CLPBNGVars).
get_clpbn_vars([_|GVars],CLPBNGVars) :-
get_clpbn_vars(GVars,CLPBNGVars).
merge_vars([],[]).
merge_vars([K-V|KVs],[V|BVars]) :-
get_var_has_same_key(KVs,K,V,KVs0),
merge_vars(KVs0,BVars).
get_var_has_same_key([K-V|KVs],K,V,KVs0) :- !,
get_var_has_same_key(KVs,K,V,KVs0).
get_var_has_same_key(KVs,_,_,KVs).
soften_sample(T0,T) :-
clpbn_flag(parameter_softening, Soften),
soften_sample(Soften, T0, T).
soften_sample(no,T,T).
soften_sample(m_estimate(M), T0, T) :-
matrix_agg_cols(T0,+,Cols),
matrix_op_to_all(Cols, *, M, R),
matrix_op_to_cols(T0,R,+,T).
soften_sample(auto_m, T0,T) :-
matrix_agg_cols(T0,+,Cols),
matrix_sum(Cols,TotM),
M is sqrt(TotM),
matrix_op_to_all(Cols, *, M, R),
matrix_op_to_cols(T0,R,+,T).
soften_sample(laplace,T0,T) :-
matrix_op_to_all(T0, +, 1, T).
normalise_counts(MAT,NMAT) :-
matrix_agg_lines(MAT, +, Sum),
matrix_op_to_lines(MAT, Sum, /, NMAT).
compute_likelihood(Table0, NewTable, DeltaLik) :-
matrix_to_logs(NewTable, Logs),
matrix_to_list(Table0,L1),
matrix_to_list(Logs,L2),
sum_prods(L1,L2,0,DeltaLik).
sum_prods([],[],DeltaLik,DeltaLik).
sum_prods([0.0|L1],[_|L2],DeltaLik0,DeltaLik) :- !,
sum_prods(L1,L2,DeltaLik0,DeltaLik).
sum_prods([Count|L1],[Log|L2],DeltaLik0,DeltaLik) :- !,
DeltaLik1 is DeltaLik0+Count*Log,
sum_prods(L1,L2,DeltaLik1,DeltaLik).

113
packages/CLPBN/learning/mle.yap Normal file
View File

@ -0,0 +1,113 @@
%
% Maximum likelihood estimator and friends.
%
%
% This assumes we have a single big example.
%
:- module(clpbn_mle, [learn_parameters/2,
learn_parameters/3,
parameters_from_evidence/3]).
:- use_module(library('clpbn')).
:- use_module(library('clpbn/learning/learn_utils'),
[run_all/1,
clpbn_vars/2,
normalise_counts/2,
soften_table/2,
normalise_counts/2]).
:- use_module(library('clpbn/dists'),
[empty_dist/2,
dist_new_table/2]).
:- use_module(library(matrix),
[matrix_inc/2]).
learn_parameters(Items, Tables) :-
learn_parameters(Items, Tables, []).
%
% full evidence learning
%
learn_parameters(Items, Tables, Extras) :-
run_all(Items),
attributes:all_attvars(AVars),
% sort and incorporate evidence
clpbn_vars(AVars, AllVars),
mk_sample(AllVars, Sample),
compute_tables(Extras, Sample, Tables).
parameters_from_evidence(AllVars, Sample, Extras) :-
mk_sample_from_evidence(AllVars, Sample),
compute_tables(Extras, Sample, Tables).
mk_sample_from_evidence(AllVars, SortedSample) :-
add_evidence2sample(AllVars, Sample),
msort(Sample, SortedSample).
mk_sample(AllVars, SortedSample) :-
add2sample(AllVars, Sample),
msort(Sample, SortedSample).
%
% assumes we have full data, meaning evidence for every variable
%
add2sample([], []).
add2sample([V|Vs],[val(Id,[Ev|EParents])|Vals]) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,Parents)]),
get_eparents(Parents, EParents),
add2sample(Vs, Vals).
get_eparents([P|Parents], [E|EParents]) :-
clpbn:get_atts(P, [evidence(E)]),
get_eparents(Parents, EParents).
get_eparents([], []).
%
% assumes we ignore variables without evidence or without evidence
% on a parent!
%
add_evidence2sample([], []).
add_evidence2sample([V|Vs],[val(Id,[Ev|EParents])|Vals]) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,Parents)]),
get_eveparents(Parents, EParents), !,
add_evidence2sample(Vs, Vals).
add_evidence2sample([_|Vs],Vals) :-
add_evidence2sample(Vs, Vals).
get_eveparents([P|Parents], [E|EParents]) :-
clpbn:get_atts(P, [evidence(E)]),
get_eparents(Parents, EParents).
get_eveparents([], []).
compute_tables(Parameters, Sample, NewTables) :-
estimator(Sample, Tables),
add_priors(Parameters, Tables, NewTables).
estimator([], []).
estimator([val(Id,Sample)|Samples], [NewDist|Tables]) :-
empty_dist(Id, NewTable),
id_samples(Id, Samples, IdSamples, MoreSamples),
mle([Sample|IdSamples], NewTable),
soften_table(NewTable, SoftenedTable),
normalise_counts(SoftenedTable, NewDist),
% replace matrix in distribution
dist_new_table(Id, NewDist),
estimator(MoreSamples, Tables).
id_samples(_, [], [], []).
id_samples(Id, [val(Id,Sample)|Samples], [Sample|IdSamples], MoreSamples) :- !,
id_samples(Id, Samples, IdSamples, MoreSamples).
id_samples(_, Samples, [], Samples).
mle([Sample|IdSamples], Table) :-
matrix_inc(Table, Sample),
mle(IdSamples, Table).
mle([], _).

159
packages/MYDDAS/myddas.h Normal file
View File

@ -0,0 +1,159 @@
#ifndef __MYDDAS_H__
#define __MYDDAS_H__
#include "config.h"
#include <stdio.h>
#ifdef MYDDAS_ODBC
#include <sql.h>
#endif
#ifdef MYDDAS_MYSQL
#include <mysql/mysql.h>
#endif
/* MYDDAS TYPES */
/* sizeof(MyddasPointer) Equal to the size of a integer on the given architecture */
/* sizeof(MyddasInt32) = 4 (Always) */
/* sizeof(MyddasUInt32) = 4 (Always) */
#if SIZEOF_INT_P==4
# if SIZEOF_INT==4
/* */ typedef int MyddasInt;
/* */ typedef unsigned int MyddasUInt;
/* */ typedef unsigned int MyddasPointer;
/* */ typedef int MyddasInt32;
/* */ typedef unsigned int MyddasUInt32;
# elif SIZEOF_LONG_INT==4
/* */ typedef long int MyddasInt;
/* */ typedef unsigned long int MyddasUInt;
/* */ typedef unsigned long int MyddasPointer;
/* */ typedef long int MyddasInt32;
/* */ typedef unsigned long int MyddasUInt32;
# else
# error MYDDAS require integer types of the same size as a pointer
# endif
# if SIZEOF_SHORT_INT==2
/* */ typedef short int MyddasSInt;
/* */ typedef unsigned short int MyddasUSInt;
# else
# error MYDDAS requires integer types half the size of a pointer
# endif
# if SIZEOF_LONG_INT==8
/* */ typedef long int MyddasLInt;
/* */ typedef unsigned long int MyddasULInt;
# elif SIZEOF_LONG_LONG_INT==8
/* */ typedef long long int MyddasLInt;
/* */ typedef unsigned long long int MyddasULInt;
# else
# error MYDDAS requires integer types double the size of a pointer
# endif
#elif SIZEOF_INT_P==8
# if SIZEOF_INT==8
/* */ typedef int MyddasInt;
/* */ typedef unsigned int MyddasUInt;
/* */ typedef int MyddasLInt;
/* */ typedef unsigned int MyddasULInt;
/* */ typedef unsigned int MyddasPointer;
# elif SIZEOF_LONG_INT==8
/* */ typedef long int MyddasInt;
/* */ typedef unsigned long int MyddasUInt;
/* */ typedef int MyddasLInt;
/* */ typedef unsigned int MyddasULInt;
/* */ typedef unsigned long int MyddasPointer;
# elif SIZEOF_LONG_LONG_INT==8
/* */ typedef long long int MyddasInt;
/* */ typedef unsigned long long int MyddasUInt;
/* */ typedef int MyddasLInt;
/* */ typedef unsigned int MyddasULInt;
/* */ typedef unsigned long long int MyddasPointer;
# else
# error MYDDAS requires integer types of the same size as a pointer
# endif
# if SIZEOF_SHORT_INT==4
/* */ typedef short int MyddasSInt;
/* */ typedef unsigned short int MyddasUSInt;
/* */ typedef short int MyddasInt32;
/* */ typedef unsigned short int MyddasUInt32;
# elif SIZEOF_INT==4
/* */ typedef int MyddasSInt;
/* */ typedef unsigned int MyddasUSInt;
/* */ typedef int MyddasInt32;
/* */ typedef unsigned int MyddasUInt32;
# else
# error MYDDAS requires integer types half the size of a pointer
# endif
#else
# error MYDDAS requires pointers of size 4 or 8
#endif
/* Passar para o myddas_statictics.h ???????? */
#ifdef MYDDAS_STATS
#include <time.h>
#include <sys/time.h>
#endif
typedef struct myddas_global *MYDDAS_GLOBAL;
typedef struct myddas_util_query *MYDDAS_UTIL_QUERY;
typedef struct myddas_list_connection *MYDDAS_UTIL_CONNECTION;
typedef struct myddas_list_preds *MYDDAS_UTIL_PREDICATE;
#ifdef MYDDAS_STATS
typedef struct myddas_stats_time_struct *MYDDAS_STATS_TIME;
typedef struct myddas_global_stats *MYDDAS_GLOBAL_STATS;
typedef struct myddas_stats_struct *MYDDAS_STATS_STRUCT;
#endif
#ifdef DEBUG
#define MYDDAS_MALLOC(POINTER,TYPE) \
{ \
POINTER = (TYPE *) malloc(sizeof(TYPE)); \
Yap_REGS.MYDDAS_GLOBAL_POINTER->memory_allocated+=sizeof(TYPE); \
/*printf ("MALLOC %p %s %d\n",POINTER,__FILE__,__LINE__);*/ \
Yap_REGS.MYDDAS_GLOBAL_POINTER->malloc_called++; \
}
#else
#define MYDDAS_MALLOC(POINTER,TYPE) \
{ \
POINTER = (TYPE *) malloc(sizeof(TYPE)); \
}
#endif
#ifdef DEBUG
#define MYDDAS_FREE(POINTER,TYPE) \
{ \
Yap_REGS.MYDDAS_GLOBAL_POINTER->memory_freed+=sizeof(TYPE); \
Yap_REGS.MYDDAS_GLOBAL_POINTER->free_called++; \
/*printf ("FREE %p %s %d\n",POINTER,__FILE__,__LINE__);*/ \
free(POINTER); \
}
#else
#define MYDDAS_FREE(POINTER,TYPE) \
{ \
free(POINTER); \
}
#endif
#ifdef DEBUG
#define MYDDAS_MEMORY_MALLOC_NR(NUMBER) \
NUMBER = Yap_REGS.MYDDAS_GLOBAL_POINTER->malloc_called;
#define MYDDAS_MEMORY_MALLOC_SIZE(NUMBER) \
NUMBER = Yap_REGS.MYDDAS_GLOBAL_POINTER->memory_allocated;
#define MYDDAS_MEMORY_FREE_NR(NUMBER) \
NUMBER = Yap_REGS.MYDDAS_GLOBAL_POINTER->free_called;
#define MYDDAS_MEMORY_FREE_SIZE(NUMBER) \
NUMBER = Yap_REGS.MYDDAS_GLOBAL_POINTER->memory_freed;
#endif
#endif /*__MYDDAS_H__*/

112
packages/MYDDAS/myddas_initialization.c Normal file
View File

@ -0,0 +1,112 @@
#if defined MYDDAS_ODBC || defined MYDDAS_MYSQL
#include "Yap.h"
#include <stdio.h>
#include <stdlib.h>
#include "myddas.h"
#include "myddas_structs.h"
#ifdef MYDDAS_STATS
#include "myddas_statistics.h"
#endif
MYDDAS_GLOBAL
myddas_init_initialize_myddas(void){
MYDDAS_GLOBAL global = NULL;
/* We cannot call MYDDAS_MALLOC were because the global
register isn't yet initialized */
global = (MYDDAS_GLOBAL) malloc (sizeof(struct myddas_global));
#ifdef DEBUG
printf ("MALLOC %p %s %d\n",global,__FILE__,__LINE__);
#endif
global->myddas_top_connections = NULL;
#ifdef MYDDAS_TOP_LEVEL
global->myddas_top_level_connection = NULL;
#endif
#ifdef MYDDAS_STATS
global->myddas_statistics = (MYDDAS_GLOBAL_STATS) malloc (sizeof(struct myddas_global_stats));
#ifdef DEBUG
printf ("MALLOC %p %s %d\n",global->myddas_statistics,__FILE__,__LINE__);
#endif
global->myddas_statistics->stats = NULL;
#endif
#ifdef DEBUG
/* We first malloc for this struct and the stats struct */
#ifdef MYDDAS_STATS
global->malloc_called = 2;
global->memory_allocated = sizeof(struct myddas_global) + sizeof(struct myddas_global_stats);
#else
global->malloc_called = 1;
global->memory_allocated = sizeof(struct myddas_global);
#endif /* MYDDAS_STATS */
global->free_called = 0;
global->memory_freed = 0;
#endif
return global;
}
/* Inserts the new node on the front of the list */
MYDDAS_UTIL_CONNECTION
myddas_init_initialize_connection(void *conn,void *enviromment,
MYDDAS_UTIL_CONNECTION next){
MYDDAS_UTIL_CONNECTION new = NULL;
MYDDAS_MALLOC(new,struct myddas_list_connection);
if (new == NULL)
{
return NULL;
}
new->predicates=NULL;
new->connection=conn;
new->odbc_enviromment=enviromment;
/* It saves n queries, doing at once n+1 queries */
new->total_number_queries=0; //Default
new->actual_number_queries=0;
new->queries = NULL;
/* List integrity */
new->next=next;
new->previous=NULL;
/* If there's already at least one node
on the list */
if (next != NULL)
next->previous=new;
#ifdef MYDDAS_STATS
new->stats = NULL;
new->stats = myddas_stats_initialize_connection_stats();
#endif
return new;
}
MYDDAS_UTIL_PREDICATE
myddas_init_initialize_predicate(char *pred_name, int pred_arity,
char *pred_module, MYDDAS_UTIL_PREDICATE next){
MYDDAS_UTIL_PREDICATE new = NULL;
MYDDAS_MALLOC(new,struct myddas_list_preds);
if (new == NULL)
{
return NULL;
}
new->pred_name=pred_name;
new->pred_arity=pred_arity;
new->pred_module=pred_module;
/* List integrity */
new->next=next;
new->previous=NULL;
/* If there's already at least one node
on the list */
if (next != NULL)
next->previous=new;
return new;
}
#endif

725
packages/MYDDAS/myddas_mysql.c Executable file
View File

@ -0,0 +1,725 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: myddas_mysql.c *
* Last rev: 22/03/05 *
* mods: *
* comments: Predicates for comunicating with a mysql database system *
* *
*************************************************************************/
#if defined MYDDAS_MYSQL
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <mysql/mysql.h>
#include "Yap.h"
#include "Yatom.h"
#include "cut_c.h"
#include "myddas.h"
#ifdef MYDDAS_STATS
#include "myddas_structs.h"
#include "myddas_statistics.h"
#endif
#include "myddas_wkb2prolog.h"
#define IS_SQL_INT(FIELD) FIELD == FIELD_TYPE_INT24 || \
FIELD == FIELD_TYPE_LONG || \
FIELD == FIELD_TYPE_LONGLONG || \
FIELD == FIELD_TYPE_SHORT || \
FIELD == FIELD_TYPE_TINY
#define IS_SQL_FLOAT(FIELD) FIELD == FIELD_TYPE_DECIMAL || \
FIELD == FIELD_TYPE_DOUBLE || \
FIELD == FIELD_TYPE_FLOAT
#define IS_SQL_GEOMETRY(FIELD) FIELD == FIELD_TYPE_GEOMETRY
static Int null_id = 0;
STATIC_PROTO(Int c_db_my_connect,(void));
STATIC_PROTO(Int c_db_my_disconnect,(void));
STATIC_PROTO(Int c_db_my_number_of_fields,(void));
STATIC_PROTO(Int c_db_my_get_attributes_types,(void));
STATIC_PROTO(Int c_db_my_query,(void));
STATIC_PROTO(Int c_db_my_table_write,(void));
STATIC_PROTO(Int c_db_my_row,(void));
STATIC_PROTO(Int c_db_my_row_cut,(void));
STATIC_PROTO(Int c_db_my_get_fields_properties,(void));
STATIC_PROTO(Int c_db_my_get_next_result_set,(void));
STATIC_PROTO(Int c_db_my_get_database,(void));
STATIC_PROTO(Int c_db_my_change_database,(void));
void Yap_InitMYDDAS_MySQLPreds(void)
{
/* db_connect: Host x User x Passwd x Database x Connection x ERROR_CODE */
Yap_InitCPred("c_db_my_connect", 7, c_db_my_connect, 0);
/* db_number_of_fields: Relation x Connection x NumberOfFields */
Yap_InitCPred("c_db_my_number_of_fields",3, c_db_my_number_of_fields, 0);
/* db_get_attributes_types: Relation x TypesList */
Yap_InitCPred("c_db_my_get_attributes_types", 3, c_db_my_get_attributes_types, 0);
/* db_query: SQLQuery x ResultSet x Connection */
Yap_InitCPred("c_db_my_query", 5, c_db_my_query, 0);
/* db_disconnect: Connection */
Yap_InitCPred("c_db_my_disconnect", 1,c_db_my_disconnect, 0);
/* db_table_write: Result Set */
Yap_InitCPred("c_db_my_table_write", 1, c_db_my_table_write, 0);
/* db_get_fields_properties: PredName x Connnection x PropertiesList*/
Yap_InitCPred("c_db_my_get_fields_properties",3,c_db_my_get_fields_properties,0);
Yap_InitCPred("c_db_my_get_next_result_set",2,c_db_my_get_next_result_set,0);
/* c_db_my_get_database: Connnection x DataBaseName */
Yap_InitCPred("c_db_my_get_database",2,c_db_my_get_database,0);
/* c_db_my_change_database: Connnection x DataBaseName */
Yap_InitCPred("c_db_my_change_database",2,c_db_my_change_database,0);
}
void Yap_InitBackMYDDAS_MySQLPreds(void)
{
/* db_row: ResultSet x Arity x ListOfArgs */
Yap_InitCPredBackCut("c_db_my_row", 3, sizeof(Int),
c_db_my_row,
c_db_my_row,
c_db_my_row_cut, 0);
}
static Int
c_db_my_connect(void) {
Term arg_host = Deref(ARG1);
Term arg_user = Deref(ARG2);
Term arg_passwd = Deref(ARG3);
Term arg_database = Deref(ARG4);
Term arg_port = Deref(ARG5);
Term arg_socket = Deref(ARG6);
Term arg_conn = Deref(ARG7);
MYSQL *conn;
MYDDAS_UTIL_CONNECTION new = NULL;
char *host = AtomName(AtomOfTerm(arg_host));
char *user = AtomName(AtomOfTerm(arg_user));
char *passwd = AtomName(AtomOfTerm(arg_passwd));
char *database = AtomName(AtomOfTerm(arg_database));
Int port = IntegerOfTerm(arg_port);
char *socket;
if (IsNonVarTerm(arg_socket))
socket = AtomName(AtomOfTerm(arg_socket));
else
socket = NULL;
conn = mysql_init(NULL);
if (conn == NULL) {
#ifdef DEBUG
printf("ERROR: ** c_db_my_connect ** error on init\n");
#endif
return FALSE;
}
if (mysql_real_connect(conn, host, user, passwd, database, port, socket, CLIENT_MULTI_STATEMENTS) == NULL) {
#ifdef DEBUG
printf("ERROR: ** c_db_my_connect ** error on connect\n");
#endif
return FALSE;
}
if (!Yap_unify(arg_conn, MkIntegerTerm((Int)conn)))
return FALSE;
else
{
/* Criar um novo no na lista de ligacoes*/
new = myddas_util_add_connection(conn,NULL);
if (new == NULL){
#ifdef DEBUG
printf("ERROR: ** c_db_my_connect ** Error allocating memory\n");
#endif
return FALSE;
}
return TRUE;
}
}
/* db_query: SQLQuery x ResultSet x Connection */
static Int
c_db_my_query(void) {
Term arg_sql_query = Deref(ARG1);
Term arg_result_set = Deref(ARG2);
Term arg_conn = Deref(ARG3);
Term arg_mode = Deref(ARG4);
Term arg_arity = Deref(ARG5);
char *sql = AtomName(AtomOfTerm(arg_sql_query));
char *mode = AtomName(AtomOfTerm(arg_mode));
MYSQL *conn = (MYSQL *) (IntegerOfTerm(arg_conn));
MYSQL_RES *res_set;
MyddasInt length=strlen(sql);
#ifdef MYDDAS_STATS
MYDDAS_UTIL_CONNECTION node = myddas_util_search_connection(conn);
MyddasULInt count = 0;
/* Count the number of querys made to the server */
MyddasULInt number_querys;
MYDDAS_STATS_CON_GET_NUMBER_QUERIES_MADE(node,number_querys);
MYDDAS_STATS_CON_SET_NUMBER_QUERIES_MADE(node,++number_querys);
MYDDAS_STATS_CON_GET_NUMBER_QUERIES_MADE_COUNT(node,count);
MYDDAS_STATS_CON_SET_NUMBER_QUERIES_MADE_COUNT(node,++count);
/* Measure time spent by the MySQL Server
processing the SQL Query */
MYDDAS_STATS_TIME start,end,total_time,diff;
start = myddas_stats_walltime();
#endif
/* Send query to server and process it */
if (mysql_real_query(conn, sql, length) != 0)
{
#ifdef DEBUG
printf("ERROR: **c_db_my_query** Error on query! %s\n",sql);
#endif
return FALSE;
}
#ifdef MYDDAS_STATS
/* Measure time spent by the MySQL Server
processing the SQL Query */
end = myddas_stats_walltime();
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(diff,time_copy);
myddas_stats_subtract_time(diff,end,start);
diff = myddas_stats_time_copy_to_final(diff);
MYDDAS_FREE(end,struct myddas_stats_time_struct);
MYDDAS_FREE(start,struct myddas_stats_time_struct);
MYDDAS_STATS_CON_GET_TOTAL_TIME_DBSERVER(node,total_time);
/* Automacally updates the MYDDAS_STRUCTURE */
myddas_stats_add_time(total_time,diff,total_time);
MYDDAS_STATS_CON_GET_TOTAL_TIME_DBSERVER_COUNT(node,count);
MYDDAS_STATS_CON_SET_TOTAL_TIME_DBSERVER_COUNT(node,++count);
MYDDAS_STATS_TIME time = NULL;
MYDDAS_STATS_CON_GET_LAST_TIME_DBSERVER(node,time);
myddas_stats_move_time(diff,time);
MYDDAS_STATS_CON_GET_LAST_TIME_DBSERVER_COUNT(node,count);
MYDDAS_STATS_CON_SET_LAST_TIME_DBSERVER_COUNT(node,++count);
#endif
/* guardar os tuplos do lado do cliente */
if (strcmp(mode,"store_result")!=0) //True
res_set = mysql_use_result(conn);
else{
#ifdef MYDDAS_STATS
/* Measure time spent by the MySQL Server
transferring the result of the last query
back to the client */
start = myddas_stats_walltime();
#endif
res_set = mysql_store_result(conn);
#ifdef MYDDAS_STATS
/* Measure time spent by the MySQL Server
transferring the result of the last query
back to the client */
end = myddas_stats_walltime();
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(diff,time_copy);
myddas_stats_subtract_time(diff,end,start);
diff = myddas_stats_time_copy_to_final(diff);
MYDDAS_FREE(end,struct myddas_stats_time_struct);
MYDDAS_FREE(start,struct myddas_stats_time_struct);
MYDDAS_STATS_CON_GET_TOTAL_TIME_TRANSFERING(node,total_time);
/* Automacally updates the MYDDAS_STRUCTURE */
myddas_stats_add_time(total_time,diff,total_time);
MYDDAS_STATS_CON_GET_TOTAL_TIME_TRANSFERING_COUNT(node,count);
MYDDAS_STATS_CON_SET_TOTAL_TIME_TRANSFERING_COUNT(node,++count);
time = NULL;
MYDDAS_STATS_CON_GET_LAST_TIME_TRANSFERING(node,time);
MYDDAS_STATS_CON_GET_LAST_TIME_TRANSFERING_COUNT(node,count);
MYDDAS_STATS_CON_SET_LAST_TIME_TRANSFERING_COUNT(node,++count);
myddas_stats_move_time(diff,time);
/* Measure the number of Rows returned from the server */
if (res_set != NULL)
{
/* With an INSERT statement, mysql_(use or store)_result()
returns a NULL pointer*/
/* This is only works if we use mysql_store_result */
MyddasUInt numberRows = mysql_num_rows(res_set);
MyddasUInt rows;
MYDDAS_STATS_CON_GET_TOTAL_ROWS(node,rows);
numberRows = numberRows + rows;
MYDDAS_STATS_CON_SET_TOTAL_ROWS(node,numberRows);
MYDDAS_STATS_CON_GET_TOTAL_ROWS_COUNT(node,count);
MYDDAS_STATS_CON_SET_TOTAL_ROWS_COUNT(node,++count);
/* Calculate the ammount of data sent by the server */
MyddasUInt total,number_fields = mysql_num_fields(res_set);
MYSQL_ROW row;
MyddasULInt i;
total=0;
while ((row = mysql_fetch_row(res_set)) != NULL){
mysql_field_seek(res_set,0);
for(i=0;i<number_fields;i++){
if (row[i] != NULL)
total = total + strlen(row[i]);
}
}
MYDDAS_STATS_CON_SET_LAST_BYTES_TRANSFERING_FROM_DBSERVER(node,total);
MYDDAS_STATS_CON_GET_LAST_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(node,count);
MYDDAS_STATS_CON_SET_LAST_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(node,++count);
MyddasUInt bytes = 0;
MYDDAS_STATS_CON_GET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER(node,bytes);
total = total + bytes;
MYDDAS_STATS_CON_SET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER(node,total);
MYDDAS_STATS_CON_GET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(node,count);
MYDDAS_STATS_CON_SET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(node,++count);
mysql_data_seek(res_set,0);
}
#endif
}
if (res_set == NULL)
{
//INSERT statements don't return any res_set
if (mysql_field_count(conn) == 0)
return TRUE;
#ifdef DEBUG
printf("Empty Query!\n");
#endif
return FALSE;
}
if (!Yap_unify(arg_arity, MkIntegerTerm(mysql_num_fields(res_set)))){
return FALSE;
}
if (!Yap_unify(arg_result_set, MkIntegerTerm((Int) res_set)))
{
mysql_free_result(res_set);
return FALSE;
}
else
{
return TRUE;
}
}
static Int
c_db_my_number_of_fields(void) {
Term arg_relation = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term arg_fields = Deref(ARG3);
char *relation = AtomName(AtomOfTerm(arg_relation));
MYSQL *conn = (MYSQL *) (IntegerOfTerm(arg_conn));
char sql[256];
MYSQL_RES *res_set;
sprintf(sql,"DESCRIBE `%s`",relation);
/* executar a query SQL */
if (mysql_query(conn, sql) != 0)
{
#ifdef DEBUG
printf("ERROR: **c_db_my_number_of_fields** Error on the query! %s\n",sql);
#endif
return FALSE;
}
/* guardar os tuplos do lado do cliente */
if ((res_set = mysql_store_result(conn)) == NULL)
{
#ifdef DEBUG
printf("ERROR: **c_db_my_number_of_fields** Error storing the query! %s\n",sql);
#endif
return FALSE;
}
if (!Yap_unify(arg_fields, MkIntegerTerm(mysql_num_rows(res_set)))){
mysql_free_result(res_set);
return FALSE;
}
mysql_free_result(res_set);
return TRUE;
}
/* db_get_attributes_types: RelName x Connection -> TypesList */
static Int
c_db_my_get_attributes_types(void) {
Term arg_relation = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term arg_types_list = Deref(ARG3);
char *relation = AtomName(AtomOfTerm(arg_relation));
MYSQL *conn = (MYSQL *) IntegerOfTerm(arg_conn);
char sql[256];
MYSQL_RES *res_set;
MYSQL_ROW row;
Term head, list;
sprintf(sql,"DESCRIBE `%s`",relation);
Int length = strlen(sql);
/* executar a query SQL */
if (mysql_real_query(conn, sql, length) != 0)
{
#ifdef DEBUG
printf("Erro na query! %s\n",sql);
#endif
return FALSE;
}
/* guardar os tuplos do lado do cliente */
if ((res_set = mysql_store_result(conn)) == NULL)
{
#ifdef DEBUG
printf("Query vazia!\n");
#endif
return FALSE;
}
list = arg_types_list;
while ((row = mysql_fetch_row(res_set)) != NULL)
{
head = HeadOfTerm(list);
Yap_unify(head, MkAtomTerm(Yap_LookupAtom(row[0])));
list = TailOfTerm(list);
head = HeadOfTerm(list);
list = TailOfTerm(list);
if (strncmp(row[1], "smallint",8) == 0 || strncmp(row[1],"int",3) == 0 ||
strncmp(row[1], "mediumint",9) == 0 || strncmp(row[1], "tinyint",7) == 0 ||
strncmp(row[1], "bigint",6) == 0 || strcmp(row[1], "year") == 0)
Yap_unify(head, MkAtomTerm(Yap_LookupAtom("integer")));
else if (strcmp(row[1], "float") == 0 || strncmp(row[1], "double",6) == 0
|| strcmp(row[1], "real") == 0)
Yap_unify(head, MkAtomTerm(Yap_LookupAtom("real")));
else Yap_unify(head, MkAtomTerm(Yap_LookupAtom("string")));
}
mysql_free_result(res_set);
return TRUE;
}
/* db_disconnect */
static Int
c_db_my_disconnect(void) {
Term arg_conn = Deref(ARG1);
MYSQL *conn = (MYSQL *) IntegerOfTerm(arg_conn);
if ((myddas_util_search_connection(conn)) != NULL)
{
myddas_util_delete_connection(conn);
mysql_close(conn);
return TRUE;
}
else
{
return FALSE;
}
}
/* db_table_write: Result Set */
static Int
c_db_my_table_write(void) {
Term arg_res_set = Deref(ARG1);
MYSQL_RES *res_set = (MYSQL_RES *) IntegerOfTerm(arg_res_set);
myddas_util_table_write(res_set);
mysql_free_result(res_set);
return TRUE;
}
static Int
c_db_my_row_cut(void) {
MYSQL_RES *mysql_res=NULL;
mysql_res = (MYSQL_RES *) IntegerOfTerm(EXTRA_CBACK_CUT_ARG(Term,1));
mysql_free_result(mysql_res);
return TRUE;
}
/* db_row: ResultSet x Arity_ListOfArgs x ListOfArgs -> */
static Int
c_db_my_row(void) {
#ifdef MYDDAS_STATS
/* Measure time used by the */
/* c_db_my_row function */
MYDDAS_STATS_TIME start,end,total_time,diff;
MyddasULInt count = 0;
start = myddas_stats_walltime();
#endif
Term arg_result_set = Deref(ARG1);
Term arg_arity = Deref(ARG2);
Term arg_list_args = Deref(ARG3);
MYSQL_RES *res_set = (MYSQL_RES *) IntegerOfTerm(arg_result_set);
EXTRA_CBACK_ARG(3,1)=(CELL) MkIntegerTerm((Int)res_set);
MYSQL_ROW row;
MYSQL_FIELD *field;
Term head, list, null_atom[1];
Int i, arity;
arity = IntegerOfTerm(arg_arity);
while(TRUE)
{
if ((row = mysql_fetch_row(res_set)) != NULL)
{
mysql_field_seek(res_set,0);
list = arg_list_args;
for (i = 0; i < arity; i++)
{
/* Aqui serão feitas as conversões de tipos de dados */
field = mysql_fetch_field(res_set);
head = HeadOfTerm(list);
list = TailOfTerm(list);
if (row[i] == NULL)
{
null_atom[0] = MkIntegerTerm(null_id++);
if (!Yap_unify(head, Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("null"),1),1,null_atom)))
continue;
}
else
{
if (IS_SQL_INT(field->type))
{
if (!Yap_unify(head, MkIntegerTerm(atoi(row[i]))))
continue;
}
else if (IS_SQL_FLOAT(field->type))
{
if (!Yap_unify(head, MkFloatTerm(atof(row[i]))))
continue;
}
else if (IS_SQL_GEOMETRY(field->type))
{
if (!Yap_unify(head, wkb2prolog(row[i])))
continue;
}
else
{
if (!Yap_unify(head, MkAtomTerm(Yap_LookupAtom(row[i]))))
continue;
}
}
}
#ifdef MYDDAS_STATS
end = myddas_stats_walltime();
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(diff,time_copy);
myddas_stats_subtract_time(diff,end,start);
diff = myddas_stats_time_copy_to_final(diff);
MYDDAS_FREE(end,struct myddas_stats_time_struct);
MYDDAS_FREE(start,struct myddas_stats_time_struct);
MYDDAS_STATS_GET_DB_ROW_FUNCTION(total_time);
myddas_stats_add_time(total_time,diff,total_time);
MYDDAS_STATS_GET_DB_ROW_FUNCTION_COUNT(count);
MYDDAS_STATS_SET_DB_ROW_FUNCTION_COUNT(++count);
MYDDAS_FREE(diff,struct myddas_stats_time_struct);
#endif /* MYDDAS_STATS */
return TRUE;
}
else
{
mysql_free_result(res_set);
#ifdef MYDDAS_STATS
end = myddas_stats_walltime();
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(diff,time_copy);
myddas_stats_subtract_time(diff,end,start);
diff = myddas_stats_time_copy_to_final(diff);
MYDDAS_FREE(end,struct myddas_stats_time_struct);
MYDDAS_FREE(start,struct myddas_stats_time_struct);
MYDDAS_STATS_GET_DB_ROW_FUNCTION(total_time);
myddas_stats_add_time(total_time,diff,total_time);
MYDDAS_STATS_GET_DB_ROW_FUNCTION_COUNT(count);
MYDDAS_STATS_SET_DB_ROW_FUNCTION_COUNT(++count);
MYDDAS_FREE(diff,struct myddas_stats_time_struct);
#endif /* MYDDAS_STATS */
cut_fail(); /* This macro already does a return FALSE */
}
}
}
static Int
c_db_my_get_fields_properties(void) {
Term nome_relacao = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term fields_properties_list = Deref(ARG3);
Term head, list;
char *relacao = AtomName(AtomOfTerm(nome_relacao));
char sql[256];
Int num_fields,i;
MYSQL_FIELD *fields;
MYSQL_RES *res_set;
MYSQL *conn = (MYSQL *) (IntegerOfTerm(arg_conn));
/* LIMIT 0 -> We only need the meta information about the fields
to know their properties, we don't need the results of the
query*/
sprintf (sql,"SELECT * FROM `%s` LIMIT 0",relacao);
Int length=strlen(sql);
/* executar a query SQL */
if (mysql_real_query(conn, sql, length) != 0)
{
#ifdef DEBUG
printf("Erro na query! %s\n",sql);
#endif
return FALSE;
}
Functor functor = Yap_MkFunctor(Yap_LookupAtom("property"),4);
Term properties[4];
/* guardar os tuplos do lado do cliente */
/* nao precisamos do resultado, mas apenas no res_set */
/* para obter a informação através do mysql_fetch_fields*/
res_set = mysql_store_result(conn);
num_fields = mysql_num_fields(res_set);
fields = mysql_fetch_fields(res_set);
list = fields_properties_list;
for (i=0;i<num_fields;i++)
{
head = HeadOfTerm(list);
properties[0] = MkAtomTerm(Yap_LookupAtom(fields[i].name));
if (fields[i].flags & NOT_NULL_FLAG)
properties[1] = MkIntegerTerm(1); //Can't be NULL
else
properties[1] = MkIntegerTerm(0);
if (fields[i].flags & PRI_KEY_FLAG)
properties[2] = MkIntegerTerm(1); //It''s a primary key
else
properties[2] = MkIntegerTerm(0);
if (fields[i].flags & AUTO_INCREMENT_FLAG)
properties[3] = MkIntegerTerm(1); //It's auto_incremented field
else
properties[3] = MkIntegerTerm(0);
list = TailOfTerm(list);
if (!Yap_unify(head, Yap_MkApplTerm(functor,4,properties))){
return FALSE;
}
}
mysql_free_result(res_set);
return TRUE;
}
/* c_db_my_get_next_result_set: Connection * NextResSet */
static Int
c_db_my_get_next_result_set(void) {
Term arg_conn = Deref(ARG1);
Term arg_next_res_set = Deref(ARG2);
MYSQL *conn = (MYSQL *) (IntegerOfTerm(arg_conn));
MYSQL_RES *res_set=NULL;
if (mysql_next_result(conn) == 0){
res_set = mysql_store_result(conn);
Yap_unify(arg_next_res_set, MkIntegerTerm((Int) res_set));
}
return TRUE;
}
static Int
c_db_my_get_database(void) {
Term arg_con = Deref(ARG1);
Term arg_database = Deref(ARG2);
MYSQL *con = (MYSQL *) (IntegerOfTerm(arg_con));
if (!Yap_unify(arg_database,MkAtomTerm(Yap_LookupAtom(con->db))))
return FALSE;
return TRUE;
}
static Int
c_db_my_change_database(void) {
Term arg_con = Deref(ARG1);
Term arg_database = Deref(ARG2);
MYSQL *con = (MYSQL *) (IntegerOfTerm(arg_con));
char *database = AtomName(AtomOfTerm(arg_database));
if (mysql_select_db(con,database)!=0)
return FALSE;
return TRUE;
}
#endif /* MYDDAS_MYSQL */

745
packages/MYDDAS/myddas_odbc.c Executable file
View File

@ -0,0 +1,745 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: myddas_odbc.c *
* Last rev: 22/03/05 *
* mods: *
* comments: Predicates for comunicating with ODBC drivers *
* *
*************************************************************************/
#if defined MYDDAS_ODBC && defined CUT_C
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "Yap.h"
#include "Yatom.h"
#include "myddas.h"
#include "cut_c.h"
#include <sql.h>
#include <sqlucode.h>
static Int null_id = 0;
STATIC_PROTO(Int c_db_odbc_connect,(void));
STATIC_PROTO(Int c_db_odbc_disconnect,(void));
STATIC_PROTO(Int c_db_odbc_number_of_fields,(void));
STATIC_PROTO(Int c_db_odbc_get_attributes_types,(void));
STATIC_PROTO(Int c_db_odbc_query,(void));
STATIC_PROTO(Int c_db_odbc_row,(void));
STATIC_PROTO(Int c_db_odbc_row_cut,(void));
STATIC_PROTO(Int c_db_odbc_get_fields_properties,(void));
STATIC_PROTO(Int c_db_odbc_number_of_fields_in_query,(void));
#define SQLALLOCHANDLE(A,B,C,print) \
{ \
SQLRETURN retcode; \
retcode = SQLAllocHandle(A,B,C); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLAllocHandle(ENV) %s\n",print); \
return FALSE; \
} \
}
#define SQLSETENVATTR(A,B,C,D,print) \
{ \
SQLRETURN retcode; \
retcode = SQLSetEnvAttr(A,B,C,D); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLSetEnvAttr %s\n",print); \
return FALSE; \
} \
}
#define SQLCONNECT(A,B,C,D,E,F,G,print) \
{ \
SQLRETURN retcode; \
retcode = SQLConnect(A,B,C,D,E,F,G); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLConnect %s\n",print); \
return FALSE; \
} \
}
#define SQLEXECDIRECT(A,B,C,print) \
{ \
SQLRETURN retcode; \
retcode = SQLExecDirect(A,B,C); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLExecDirect %s \n",print); \
return FALSE; \
} \
}
#define SQLDESCRIBECOL(A,B,C,D,E,F,G,H,I,print) \
{ \
SQLRETURN retcode; \
retcode = SQLDescribeCol(A,B,C,D,E,F,G,H,I); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLDescribeCol %s\n",print); \
return FALSE; \
} \
}
#define SQLSETCONNECTATTR(A,B,C,D,print) \
{ \
SQLRETURN retcode; \
retcode = SQLSetConnectAttr(A,B,C,D); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLSetConnectAttr %s\n",print); \
return FALSE; \
} \
}
#define SQLBINDCOL(A,B,C,D,E,F,print) \
{ \
SQLRETURN retcode; \
retcode = SQLBindCol(A,B,C,D,E,F); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLbindCol %s\n",print); \
return FALSE; \
} \
}
#define SQLFREESTMT(A,B,print) \
{ \
SQLRETURN retcode; \
retcode = SQLFreeStmt(A,B); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLFreeStmt %s\n",print); \
return FALSE; \
} \
}
#define SQLNUMRESULTCOLS(A,B,print) \
{ \
SQLRETURN retcode; \
retcode = SQLNumResultCols(A,B); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLNumResultCols %s\n",print); \
return FALSE; \
} \
}
#define SQLCLOSECURSOR(A,print) \
{ \
SQLRETURN retcode; \
retcode = SQLCloseCursor(A); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLCloseCursor %s\n",print); \
return FALSE; \
} \
}
/* no db_odbc_row não é utilizada esta macro*/
#define SQLFETCH(A,print) \
{ \
SQLRETURN retcode; \
retcode = SQLFetch(A); \
if (retcode == SQL_NO_DATA) \
break; \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLFETCH %s\n",print); \
return FALSE; \
} \
}
#define SQLGETDATA(A,B,C,D,E,F,print) \
{ \
SQLRETURN retcode; \
retcode = SQLGetData(A,B,C,D,E,F); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLgetdata %s\n",print); \
return FALSE; \
} \
}
#define SQLDISCONNECT(A,print) \
{ \
SQLRETURN retcode; \
retcode = SQLDisconnect(A); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLDisconnect %s\n",print); \
return FALSE; \
} \
}
#define SQLFREEHANDLE(A,B,print) \
{ \
SQLRETURN retcode; \
retcode = SQLFreeHandle(A,B); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLFreeHandle %s\n",print); \
return FALSE; \
} \
}
#define SQLPRIMARYKEYS(A,B,C,D,E,F,G,print) \
{ \
SQLRETURN retcode; \
retcode = SQLPrimaryKeys(A,B,C,D,E,F,G); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLPrimaryKeys %s\n",print); \
return FALSE; \
} \
}
#define SQLGETTYPEINFO(A,B,print) \
{ \
SQLRETURN retcode; \
retcode = SQLGetTypeInfo(A,B); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLGetTypeInfo %s\n",print); \
return FALSE; \
} \
}
#define SQLCOLATTRIBUTE(A,B,C,D,E,F,G,print) \
{ \
SQLRETURN retcode; \
retcode = SQLColAttribute(A,B,C,D,E,F,G); \
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO) \
{ \
printf("erro no SQLColAttribute %s\n",print); \
return FALSE; \
} \
}
/* Verificar tipo de dados*/
#define IS_SQL_INT(FIELD) FIELD == SQL_DECIMAL || \
FIELD == SQL_NUMERIC || \
FIELD == SQL_SMALLINT || \
FIELD == SQL_INTEGER || \
FIELD == SQL_TINYINT || \
FIELD == SQL_BIGINT
#define IS_SQL_FLOAT(FIELD) FIELD == SQL_FLOAT || \
FIELD == SQL_DOUBLE || \
FIELD == SQL_REAL
static Int
c_db_odbc_connect(void) {
Term arg_driver = Deref(ARG1);
Term arg_user = Deref(ARG2);
Term arg_passwd = Deref(ARG3);
Term arg_conn = Deref(ARG4);
MYDDAS_UTIL_CONNECTION new = NULL;
char *driver = AtomName(AtomOfTerm(arg_driver));
char *user = AtomName(AtomOfTerm(arg_user));
char *passwd = AtomName(AtomOfTerm(arg_passwd));
SQLHENV henv;
SQLHDBC hdbc;
/*Allocate environment handle */
SQLALLOCHANDLE(SQL_HANDLE_ENV, SQL_NULL_HANDLE, &henv, "connect");
/* Set the ODBC version environment attribute */
SQLSETENVATTR(henv, SQL_ATTR_ODBC_VERSION, (SQLPOINTER)SQL_OV_ODBC3, 0, "connect");
/* Allocate connection handle */
SQLALLOCHANDLE(SQL_HANDLE_DBC, henv, &hdbc, "connect");
/* Set login timeout to 6 seconds. */
SQLSETCONNECTATTR(hdbc, SQL_LOGIN_TIMEOUT,(SQLPOINTER) 6, 0, "connect");
/* Connect to data source */
SQLCONNECT(hdbc,
(SQLCHAR*) driver, SQL_NTS,
(SQLCHAR*) user, SQL_NTS,
(SQLCHAR*) passwd, SQL_NTS, "connect");
if (!Yap_unify(arg_conn, MkIntegerTerm((Int)(hdbc))))
return FALSE;
else
{
/* Criar um novo no na lista de ligacoes*/
//new = add_connection(&TOP,hdbc,henv);
new = myddas_util_add_connection(hdbc,henv);
if (new == NULL){
printf("Erro ao alocar memoria para lista\n");
return FALSE;
}
return TRUE;
}
}
/* db_query: SQLQuery x ResultSet x Arity x BindList x Connection */
static Int
c_db_odbc_query(void) {
Term arg_sql_query = Deref(ARG1);
Term arg_result_set = Deref(ARG2);
Term arg_arity = Deref(ARG3);
Term arg_bind_list = Deref(ARG4);
Term arg_conn = Deref(ARG5);
SQLCHAR *sql = AtomName(AtomOfTerm(arg_sql_query));
SQLHDBC hdbc =(SQLHDBC) (IntegerOfTerm(arg_conn));
SQLHSTMT hstmt;
SQLSMALLINT type;
/*Allocate an handle for the query*/
SQLALLOCHANDLE(SQL_HANDLE_STMT, hdbc, &hstmt, "db_query");
/* Executes the query*/
SQLEXECDIRECT(hstmt,sql,SQL_NTS, "db_query");
Int arity;
Int i;
if (IsNonVarTerm(arg_arity)){
arity = IntegerOfTerm(arg_arity);
char *bind_space=NULL;
//const Int functor_arity=3;
const Short functor_arity=3;
Functor functor = Yap_MkFunctor(Yap_LookupAtom("bind"),functor_arity);
Term properties[functor_arity];
Term head,list=arg_bind_list;
SQLUINTEGER ColumnSizePtr;
SQLINTEGER *data_info=NULL;
for (i=1;i<=arity;i++)
{
head = HeadOfTerm(list);
list = TailOfTerm(list);
SQLDESCRIBECOL(hstmt,i,NULL,0,NULL,&type,&ColumnSizePtr,NULL,NULL,"db_query");
/* +1 because of '\0' */
bind_space = malloc(sizeof(char)*(ColumnSizePtr+1));
data_info = malloc(sizeof(SQLINTEGER));
SQLBINDCOL(hstmt,i,SQL_C_CHAR,bind_space,(ColumnSizePtr+1),data_info,"db_query");
properties[0] = MkIntegerTerm((Int)bind_space);
properties[2] = MkIntegerTerm((Int)data_info);
if (IS_SQL_INT(type))
properties[1]=MkAtomTerm(Yap_LookupAtom("integer"));
else if (IS_SQL_FLOAT(type))
properties[1]=MkAtomTerm(Yap_LookupAtom("real"));
else
properties[1]=MkAtomTerm(Yap_LookupAtom("string"));
Yap_unify(head,Yap_MkApplTerm(functor,functor_arity,properties));
continue;
}
}
if (!Yap_unify(arg_result_set, MkIntegerTerm((Int) hstmt)))
{
SQLCLOSECURSOR(hstmt,"db_query");
SQLFREESTMT(hstmt,SQL_CLOSE,"db_query");
return FALSE;
}
return TRUE;
}
static Int
c_db_odbc_number_of_fields(void) {
Term arg_relation = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term arg_fields = Deref(ARG3);
char *relation = AtomName(AtomOfTerm(arg_relation));
SQLHDBC hdbc =(SQLHDBC) (IntegerOfTerm(arg_conn));
SQLHSTMT hstmt;
char sql[256];
SQLSMALLINT number_fields;
sprintf(sql,"DESCRIBE %s",relation);
SQLALLOCHANDLE(SQL_HANDLE_STMT, hdbc, &hstmt, "db_number_of_fields");
SQLEXECDIRECT(hstmt,sql,SQL_NTS, "db_number_of_fields");
/* Calcula o numero de campos*/
number_fields=0;
while(TRUE) {
SQLFETCH(hstmt,"db_number_of_fields");
number_fields++;
}
SQLCLOSECURSOR(hstmt,"db_number_of_fields");
SQLFREESTMT(hstmt,SQL_CLOSE,"db_number_of_fields");
if (!Yap_unify(arg_fields, MkIntegerTerm(number_fields)))
return FALSE;
return TRUE;
}
/* db_get_attributes_types: RelName x Connection -> TypesList */
static Int
c_db_odbc_get_attributes_types(void) {
Term arg_relation = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term arg_types_list = Deref(ARG3);
char *relation = AtomName(AtomOfTerm(arg_relation));
SQLHDBC hdbc =(SQLHDBC) (IntegerOfTerm(arg_conn));
SQLHSTMT hstmt;
char sql[256];
Term head, list;
list = arg_types_list;
sprintf(sql,"DESCRIBE %s",relation);
SQLALLOCHANDLE(SQL_HANDLE_STMT, hdbc, &hstmt, "db_get_attributes_types");
SQLEXECDIRECT(hstmt,sql,SQL_NTS, "db_get_attributes_types");
while (TRUE)
{
SQLFETCH(hstmt, "db_get_attributes_types");
/* Tentar fazer de uma maneira que a gente consiga calcular o tamanho que o
nome do campo vai ocupar, assim podemos alocar memoria dinamicamente*/
sql[0]='\0';
SQLGETDATA(hstmt, 1, SQL_C_CHAR, sql, 256, NULL, "db_get_attributes_types");
head = HeadOfTerm(list);
Yap_unify(head, MkAtomTerm(Yap_LookupAtom(sql)));
list = TailOfTerm(list);
head = HeadOfTerm(list);
list = TailOfTerm(list);
sql[0]='\0';
SQLGETDATA(hstmt, 2, SQL_C_CHAR, sql, 256, NULL, "db_get_attributes_types");
if (strncmp(sql, "smallint",8) == 0 || strncmp(sql,"int",3) == 0 ||
strncmp(sql, "mediumint",9) == 0 || strncmp(sql, "tinyint",7) == 0 ||
strncmp(sql, "bigint",6) == 0 || strcmp(sql, "year") == 0)
Yap_unify(head, MkAtomTerm(Yap_LookupAtom("integer")));
else
if (strcmp(sql, "float") == 0 || strncmp(sql, "double",6) == 0
|| strcmp(sql, "real") == 0)
Yap_unify(head, MkAtomTerm(Yap_LookupAtom("real")));
else
Yap_unify(head, MkAtomTerm(Yap_LookupAtom("string")));
}
SQLCLOSECURSOR(hstmt,"db_get_attributes_types");
SQLFREESTMT(hstmt,SQL_CLOSE, "db_get_attributes_types");
return TRUE;
}
/* db_disconnect */
static Int
c_db_odbc_disconnect(void) {
Term arg_conn = Deref(ARG1);
SQLHDBC conn = (SQLHDBC) (IntegerOfTerm(arg_conn));
SQLHENV henv = myddas_util_get_odbc_enviromment(conn);
if ((myddas_util_search_connection(conn)) != NULL)
{
myddas_util_delete_connection(conn);
/* More information about this process on
msdn.microsoft.com*/
SQLDISCONNECT(conn,"db_disconnect");
SQLFREEHANDLE(SQL_HANDLE_DBC,conn,"db_disconnect");
SQLFREEHANDLE(SQL_HANDLE_ENV,henv,"db_disconnect");
return TRUE;
}
else
return FALSE;
}
static Int
c_db_odbc_row_cut(void) {
SQLHSTMT hstmt = (SQLHSTMT) IntegerOfTerm(EXTRA_CBACK_CUT_ARG(Term,1));
SQLCLOSECURSOR(hstmt,"db_row_cut");
SQLFREESTMT(hstmt,SQL_CLOSE,"db_row_cut");
return TRUE;
}
/* db_row: ResultSet x BindList x ListOfArgs -> */
static Int
c_db_odbc_row(void) {
Term arg_result_set = Deref(ARG1);
Term arg_bind_list = Deref(ARG2);
Term arg_list_args = Deref(ARG3);
SQLHSTMT hstmt = (SQLHSTMT) IntegerOfTerm(arg_result_set);
/* EXTRA_CBACK_ARG(ARIDADE,LOCAL_ONDE_COLOCAR_VALOR)*/
EXTRA_CBACK_ARG(3,1)=(CELL) MkIntegerTerm((Int)hstmt);
Term head, list, null_atom[1];
Term head_bind, list_bind;
SQLRETURN retcode = SQLFetch(hstmt);
if (retcode == SQL_NO_DATA)
{
SQLCLOSECURSOR(hstmt,"db_row");
SQLFREESTMT(hstmt,SQL_CLOSE,"db_row");
cut_fail();
return FALSE;
}
if (retcode != SQL_SUCCESS && retcode != SQL_SUCCESS_WITH_INFO)
{
printf("erro no SQLFETCH number of fields\n");
return FALSE;
}
char *bind_value=NULL;
Term type;
list = arg_list_args;
list_bind = arg_bind_list;
SQLINTEGER *data_info=NULL;
while (IsPairTerm(list_bind))
{
head = HeadOfTerm(list);
list = TailOfTerm(list);
head_bind = HeadOfTerm(list_bind);
list_bind = TailOfTerm(list_bind);
bind_value = (char *)IntegerOfTerm(ArgOfTerm(1,head_bind));
type = ArgOfTerm(2,head_bind);
data_info = (SQLINTEGER *)IntegerOfTerm(ArgOfTerm(3,head_bind));
if ((*data_info) == SQL_NULL_DATA){
null_atom[0] = MkIntegerTerm(null_id++);
if (!Yap_unify(head, Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("null"),1),1,null_atom)))
continue;
}
else
{
if (!strcmp(AtomName(AtomOfTerm(type)),"integer"))
{
if (!Yap_unify(head, MkIntegerTerm(atoi(bind_value))))
continue;
}
else if (!strcmp(AtomName(AtomOfTerm(type)),"real"))
{
if (!Yap_unify(head, MkFloatTerm(atof(bind_value))))
continue;
}
else if (!strcmp(AtomName(AtomOfTerm(type)),"string"))
{
if (!Yap_unify(head, MkAtomTerm(Yap_LookupAtom(bind_value))))
continue;
}
}
}
return TRUE;
}
/* Mudar esta funcao de forma a nao fazer a consulta, pois
no predicate db_sql_selet vai fazer duas vezes a mesma consutla*/
static Int
c_db_odbc_number_of_fields_in_query(void) {
Term arg_query = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term arg_fields = Deref(ARG3);
char *sql = AtomName(AtomOfTerm(arg_query));
SQLHDBC hdbc =(SQLHDBC) (IntegerOfTerm(arg_conn));
SQLHSTMT hstmt;
SQLSMALLINT number_cols=0;
SQLALLOCHANDLE(SQL_HANDLE_STMT, hdbc, &hstmt,
"db_number_of_fields_in_query");
SQLEXECDIRECT(hstmt,sql,SQL_NTS,
"db_number_of_fields_in_query");
SQLNUMRESULTCOLS(hstmt,&number_cols,
"db_number_of_fields_in_query");
if (!Yap_unify(arg_fields, MkIntegerTerm(number_cols))){
return FALSE;
}
SQLCLOSECURSOR(hstmt,"db_number_of_fields_in_query");
SQLFREESTMT(hstmt,SQL_CLOSE, "db_number_of_fields_in_query");
return TRUE;
}
static Int
c_db_odbc_get_fields_properties(void) {
Term nome_relacao = Deref(ARG1);
Term arg_conn = Deref(ARG2);
Term fields_properties_list = Deref(ARG3);
Term head, list;
char *relacao = AtomName(AtomOfTerm(nome_relacao));
char sql[256];
char name[200];
Int i;
SQLSMALLINT num_fields=0;
SQLSMALLINT NullablePtr=0;
SQLSMALLINT AutoIncrementPointer=0;
SQLHSTMT hstmt,hstmt2;
SQLHDBC hdbc =(SQLHDBC) (IntegerOfTerm(arg_conn));
/* LIMIT 0 -> We don't need the results of the query,
only the information about the fields of the relation*/
sprintf (sql,"SELECT * FROM `%s` LIMIT 0",relacao);
/*Allocate an handle for the query*/
SQLALLOCHANDLE(SQL_HANDLE_STMT, hdbc, &hstmt, "db_get_fields_properties");
/* Executes the query*/
SQLEXECDIRECT(hstmt,sql,SQL_NTS, "db_get_fields_properties");
Functor functor = Yap_MkFunctor(Yap_LookupAtom("property"),4);
Term properties[4];
SQLNUMRESULTCOLS(hstmt,&num_fields,
"db_get_fields_properties");
list = fields_properties_list;
SQLSMALLINT bind_prim_key;
//por causa de as rows em odbc começam em 1 :)
Short *null=malloc(sizeof(Short)*(1+num_fields));
SQLALLOCHANDLE(SQL_HANDLE_STMT, hdbc, &hstmt2, "db_get_fields_properties");
/* Executes the query*/
SQLPRIMARYKEYS(hstmt2,NULL,0,NULL,0,relacao,SQL_NTS, "db_get_fields_properties");
/* Associates bind value for the 5 column*/
SQLBINDCOL(hstmt2,5,SQL_C_SSHORT,&bind_prim_key,sizeof(SQLSMALLINT),NULL,
"db_get_fields_properties");
while(1)
{
SQLFETCH(hstmt2,"db_get_fields_properties");
null[bind_prim_key]=1;
}
SQLCLOSECURSOR(hstmt2,"db_get_fields_properties");
SQLFREESTMT(hstmt2,SQL_CLOSE,"db_get_fields_properties");
for (i=1;i<=num_fields;i++)
{
head = HeadOfTerm(list);
name[0]='\0';
SQLDESCRIBECOL(hstmt,i,name,200,NULL,NULL,NULL,NULL,&NullablePtr,
"db_get_fields_properties");
SQLCOLATTRIBUTE(hstmt,i,SQL_DESC_AUTO_UNIQUE_VALUE,NULL,0,NULL,&AutoIncrementPointer,
"db_get_fields_properties");
properties[0] = MkAtomTerm(Yap_LookupAtom(name));
if (NullablePtr & SQL_NULLABLE)
properties[1] = MkIntegerTerm(1); //Can't be NULL
else
properties[1] = MkIntegerTerm(0);
if (null[i] == 1)
properties[2] = MkIntegerTerm(1); //It''s a primary key
else
properties[2] = MkIntegerTerm(0);
if (AutoIncrementPointer & SQL_TRUE)
properties[3] = MkIntegerTerm(1); //It's auto_incremented field
else
properties[3] = MkIntegerTerm(0);
list = TailOfTerm(list);
if (!Yap_unify(head, Yap_MkApplTerm(functor,4,properties))){
return FALSE;
}
}
SQLCLOSECURSOR(hstmt,"db_get_fields_properties");
SQLFREESTMT(hstmt,SQL_CLOSE,"db_get_fields_properties");
return TRUE;
}
void Yap_InitMYDDAS_ODBCPreds(void)
{
/* db_connect: Host x User x Passwd x Database x Connection */
Yap_InitCPred("c_db_odbc_connect", 4, c_db_odbc_connect, 0);
/* db_number_of_fields: Relation x Connection x NumberOfFields */
Yap_InitCPred("c_db_odbc_number_of_fields",3, c_db_odbc_number_of_fields, 0);
/* db_number_of_fields_in_query: SQLQuery x Connection x NumberOfFields */
Yap_InitCPred("c_db_odbc_number_of_fields_in_query",3, c_db_odbc_number_of_fields_in_query, 0);
/* db_get_attributes_types: Relation x TypesList */
Yap_InitCPred("c_db_odbc_get_attributes_types", 3, c_db_odbc_get_attributes_types, 0);
/* db_query: SQLQuery x ResultSet x Connection */
Yap_InitCPred("c_db_odbc_query", 5, c_db_odbc_query, 0);
/* db_disconnect: Connection */
Yap_InitCPred("c_db_odbc_disconnect", 1,c_db_odbc_disconnect, 0);
/* db_get_fields_properties: PredName x Connnection x PropertiesList */
Yap_InitCPred("c_db_odbc_get_fields_properties",3,c_db_odbc_get_fields_properties,0);
}
void Yap_InitBackMYDDAS_ODBCPreds(void)
{
/* db_row: ResultSet x ListOfArgs */
Yap_InitCPredBackCut("c_db_odbc_row", 3, sizeof(Int),
c_db_odbc_row,
c_db_odbc_row,
c_db_odbc_row_cut, 0);
}
#endif /*MYDDAS_ODBC*/

700
packages/MYDDAS/myddas_shared.c Normal file
View File

@ -0,0 +1,700 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: myddas_shared.c *
* Last rev: 22/03/05 *
* mods: *
* comments: Predicates for maintaining MYDDAS *
* *
*************************************************************************/
#if defined MYDDAS_MYSQL || defined MYDDAS_ODBC
#include "Yap.h"
#include "Yatom.h"
#include "cut_c.h"
#include "myddas.h"
#include <stdlib.h>
#include "myddas_structs.h"
#ifdef MYDDAS_STATS
#include "myddas_statistics.h"
#endif
STATIC_PROTO(Int c_db_initialize_myddas,(void));
STATIC_PROTO(Int c_db_connection_type,(void));
STATIC_PROTO(Int c_db_add_preds,(void));
STATIC_PROTO(Int c_db_preds_conn_start ,(void));
STATIC_PROTO(Int c_db_preds_conn_continue ,(void));
STATIC_PROTO(Int c_db_connection_start ,(void));
STATIC_PROTO(Int c_db_connection_continue ,(void));
STATIC_PROTO(Int c_db_check_if_exists_pred,(void));
STATIC_PROTO(Int c_db_delete_predicate,(void));
STATIC_PROTO(Int c_db_multi_queries_number,(void));
#ifdef MYDDAS_STATS
STATIC_PROTO(Int c_db_stats,(void));
STATIC_PROTO(Int c_db_stats_walltime,(void));
STATIC_PROTO(Int c_db_stats_translate,(void));
STATIC_PROTO(Int c_db_stats_time,(void));
#endif
#ifdef DEBUG
STATIC_PROTO(Int c_db_check,(void));
#endif
void Yap_InitMYDDAS_SharedPreds(void)
{
/* c_db_initialize_myddas */
Yap_InitCPred("c_db_initialize_myddas",0,c_db_initialize_myddas, 0);
/* c_db_connection_type: Connection x Type */
Yap_InitCPred("c_db_connection_type",2,c_db_connection_type, 0);
/* CORRECT THIS: db_add_preds : PredName * Arity * Connection */
Yap_InitCPred("c_db_add_preds",4,c_db_add_preds, 0);
/* c_db_check_if_exists_pred : PredName * Arity * Connection */
Yap_InitCPred("c_db_check_if_exists_pred",3,c_db_check_if_exists_pred, 0);
/* c_db_delete_pred : Module * PredName * Arity */
Yap_InitCPred("c_db_delete_predicate",3,c_db_delete_predicate, 0);
/* c_db_delete_pred : Module * PredName * Arity */
Yap_InitCPred("c_db_multi_queries_number",2,c_db_multi_queries_number, 0);
#ifdef MYDDAS_STATS
/* c_db_stats: Connection * Stats */
Yap_InitCPred("c_db_stats",2, c_db_stats, 0);
/* c_db_stats_walltime */
Yap_InitCPred("c_db_stats_walltime",1, c_db_stats_walltime, 0);
/* c_db_stats_translate */
Yap_InitCPred("c_db_stats_translate",2,c_db_stats_translate, 0);
/* c_db_stats_time */
Yap_InitCPred("c_db_stats_time",2,c_db_stats_time, 0);
#endif
#ifdef DEBUG
Yap_InitCPred("c_db_check",0, c_db_check, 0);
#endif
}
void Yap_InitBackMYDDAS_SharedPreds(void)
{
/* Gives all the predicates associated to a given connection */
Yap_InitCPredBack("c_db_preds_conn", 4, sizeof(Int),
c_db_preds_conn_start,
c_db_preds_conn_continue, 0);
/* Gives all the connections stored on the MYDDAS Structure*/
Yap_InitCPredBack("c_db_connection", 1, sizeof(Int),
c_db_connection_start,
c_db_connection_continue, 0);
}
/* Initialize all of the MYDDAS global structures */
static Int
c_db_initialize_myddas(void){
Yap_REGS.MYDDAS_GLOBAL_POINTER = myddas_init_initialize_myddas();
#ifdef MYDDAS_STATS
Yap_REGS.MYDDAS_GLOBAL_POINTER = myddas_stats_initialize_global_stats(Yap_REGS.MYDDAS_GLOBAL_POINTER);
#endif /* MYDDAS_STATS */
return TRUE;
}
/* Gives the type of a given connection,
in other words, type will be mysql or odbc
NOTE: In order to use this predicate, the connection*/
/* c_db_connection_type: +Connection * ?Type */
static Int
c_db_connection_type (void){
Term arg_con = Deref(ARG1);
Term arg_type = Deref(ARG2);
Int *con = (Int *) IntegerOfTerm(arg_con);
Int type = myddas_util_connection_type(con);
if (type == 1) /* MYSQL Connection */
Yap_unify(arg_type, MkAtomTerm(Yap_LookupAtom("mysql")));
else if (type ==2) /* ODBC Connection */
Yap_unify(arg_type, MkAtomTerm(Yap_LookupAtom("odbc")));
else /* Not a valid connection*/
return FALSE;
return TRUE;
}
/* db_add_preds: PredName * Arity * Module * Connection*/
static Int
c_db_add_preds (void){
Term arg_nome = Deref(ARG1);
Term arg_aridade = Deref(ARG2);
Term arg_module = Deref(ARG3);
Term arg_conn = Deref(ARG4);
/* PredEntry *pe; */
/* pe = RepPredProp(PredPropByFunc(FunctorOfTerm(arg_pred),arg_module)); */
char *nome = AtomName(AtomOfTerm(arg_nome));
char *module = AtomName(AtomOfTerm(arg_module));
Int aridade = IntegerOfTerm(arg_aridade);
Int *conn = (Int *) IntegerOfTerm(arg_conn);
if (myddas_util_add_predicate(nome,aridade,module,conn) == NULL)
{
#ifdef DEBUG
printf ("ERROR : Could not add Predicate: Line: %d File: %s\n",__LINE__,__FILE__);
#endif
return FALSE;
}
return TRUE;
}
static Int
c_db_check_if_exists_pred (void){
Term arg_nome = Deref(ARG1);
Term arg_aridade = Deref(ARG2);
Term arg_module = Deref(ARG3);
char *nome = AtomName(AtomOfTerm(arg_nome));
char *module = AtomName(AtomOfTerm(arg_module));
Int aridade = IntegerOfTerm(arg_aridade);
if (myddas_util_search_predicate(nome,aridade,module) == NULL)
return FALSE;
else
return TRUE;
}
static Int
c_db_delete_predicate(void){
Term arg_module = Deref(ARG1);
Term arg_name = Deref(ARG2);
Term arg_arity = Deref(ARG3);
char *module = AtomName(AtomOfTerm(arg_module));
char *name = AtomName(AtomOfTerm(arg_name));
Int arity = IntegerOfTerm(arg_arity);
MYDDAS_UTIL_PREDICATE predicate =
myddas_util_search_predicate(name,arity,module);
if (predicate == NULL)
return FALSE;
myddas_util_delete_predicate(predicate);
return TRUE;
}
static Int
c_db_multi_queries_number(void){
Term arg_conn = Deref(ARG1);
Term arg_number = Deref(ARG2);
Int *conn = (Int *) IntegerOfTerm(arg_conn);
MYDDAS_UTIL_CONNECTION node =
myddas_util_search_connection(conn);
if (node == NULL)
return FALSE;
if (IsVarTerm(arg_number)){
Yap_unify(arg_number,MkIntegerTerm(((Int)myddas_util_get_total_multi_queries_number(node))+1));
}
else {
Int number = IntegerOfTerm(arg_number);
number--;
myddas_util_set_total_multi_queries_number(node,number);
}
return TRUE;
}
static Int
c_db_connection_start(void){
MYDDAS_UTIL_CONNECTION node =
Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
EXTRA_CBACK_ARG(1,1)=(CELL) MkIntegerTerm((Int)node);
return (c_db_connection_continue());
}
static Int
c_db_connection_continue(void){
Term arg_conn = Deref(ARG1);
MYDDAS_UTIL_CONNECTION node;
node = (MYDDAS_UTIL_CONNECTION) IntegerOfTerm(EXTRA_CBACK_ARG(1,1));
/* There is no connections */
if (node == NULL)
{
cut_fail();
return FALSE;
}
Yap_unify(arg_conn, MkIntegerTerm((Int)(node->connection)));
EXTRA_CBACK_ARG(1,1)=(CELL) MkIntegerTerm((Int)(node->next));
return TRUE;
}
/* db_preds_conn : Connection(+) * Pred_name(-) * Pred_arity */
static Int
c_db_preds_conn_start (void){
Term arg_conn = Deref(ARG1);
Int *conn = (Int *) IntegerOfTerm(arg_conn);
MYDDAS_UTIL_CONNECTION node =
myddas_util_search_connection(conn);
/* Caso a ligacao já tenha sido apagada*/
if (node == NULL)
{
cut_fail();
return FALSE;
}
void *pointer = myddas_util_get_list_pred(node);
EXTRA_CBACK_ARG(4,1)=(CELL) MkIntegerTerm((Int)pointer);
return (c_db_preds_conn_continue());
}
/* db_preds_conn : Connection(+) * Pred_name(-) * Pred_arity*/
static Int
c_db_preds_conn_continue (void){
Term module = Deref(ARG2);
Term name = Deref(ARG3);
Term arity = Deref(ARG4);
void *pointer;
pointer = (void *) IntegerOfTerm(EXTRA_CBACK_ARG(4,1));
if (pointer != NULL)
{
EXTRA_CBACK_ARG(4,1)=(CELL) MkIntegerTerm((Int)myddas_util_get_pred_next(pointer));
if (!Yap_unify(module, MkAtomTerm(Yap_LookupAtom(myddas_util_get_pred_module(pointer))))){
return FALSE;
}
if (!Yap_unify(name,MkAtomTerm(Yap_LookupAtom(myddas_util_get_pred_name(pointer))))){
return FALSE;
}
if (!Yap_unify(arity, MkIntegerTerm((Int)myddas_util_get_pred_arity(pointer)))){
return FALSE;
}
return TRUE;
}
else
{
cut_fail();
return FALSE;
}
}
#ifdef DEBUG
static Int
c_db_check(void){
check_int();
return TRUE;
}
#endif /*DEBUG*/
#ifdef MYDDAS_STATS
static Int
c_db_stats_walltime(void){
Term arg_time = Deref(ARG1);
#ifdef DEBUG
if (IsVarTerm(arg_time)){
#endif
Yap_unify(arg_time,MkIntegerTerm((Int)myddas_stats_walltime()));
return TRUE;
#ifdef DEBUG
}
else{
printf ("ERROR: c_db_stats_walltime got a variable\n");
return FALSE;
}
#endif
}
static Int
c_db_stats_translate(void){
Term arg_start = Deref(ARG1);
Term arg_end = Deref(ARG2);
MYDDAS_STATS_TIME start;
MYDDAS_STATS_TIME end;
MYDDAS_STATS_TIME total_time,diff;
#ifdef DEBUG
//Both args must be instanciated
if (IsNonVarTerm(arg_start) && IsNonVarTerm(arg_end)){
#endif
start = (MYDDAS_STATS_TIME) IntegerOfTerm(arg_start);
end = (MYDDAS_STATS_TIME) IntegerOfTerm(arg_end);
MYDDAS_STATS_GET_TRANSLATE(total_time);
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(diff,time_copy);
myddas_stats_subtract_time(diff,end,start);
diff = myddas_stats_time_copy_to_final(diff);
myddas_stats_add_time(total_time,diff,total_time);
MyddasULInt count;
MYDDAS_STATS_GET_TRANSLATE_COUNT(count);
MYDDAS_STATS_SET_TRANSLATE_COUNT(++count);
MYDDAS_FREE(diff,struct myddas_stats_time_struct);
MYDDAS_FREE(start, struct myddas_stats_time_struct);
MYDDAS_FREE(end, struct myddas_stats_time_struct);
return TRUE;
#ifdef DEBUG
}
else{
printf ("ERROR: c_db_stats_translate got a variable\n");
return FALSE;
}
#endif
}
static Int
c_db_stats_time(void){
Term arg_reference = Deref(ARG1);
Term arg_time = Deref(ARG2);
Term final_term;
MYDDAS_STATS_STRUCT struc = (MYDDAS_STATS_STRUCT)IntegerOfTerm(arg_reference);
Functor functor_count = Yap_MkFunctor(Yap_LookupAtom("count"),1);
Term count_number[1];
Functor unit;
Term number[1];
switch(struc->type){
case integer:
{
Functor functor = Yap_MkFunctor(Yap_LookupAtom("myddas_integer"),2);
Term integer_number[1];
MyddasULInt integer;
unit = Yap_MkFunctor(Yap_LookupAtom("number"),1);
integer = struc->u.integer.integer;
number[0] = MkIntegerTerm(integer);
integer_number[0] = Yap_MkApplTerm(unit,1,number);;
count_number[0] = MkIntegerTerm(struc->count);
integer_number[1] = Yap_MkApplTerm(functor_count,1,count_number);
final_term = Yap_MkApplTerm(functor,2,integer_number);
break;
}
case time_str:
{
MYDDAS_STATS_TIME time = struc->u.time_str.time_str;
Functor functor = Yap_MkFunctor(Yap_LookupAtom("myddas_time"),6);
Term time_numbers[6];
MyddasUInt time_number;
unit = Yap_MkFunctor(Yap_LookupAtom("hours"),1);
time_number = MYDDAS_STATS_TIME_HOURS(time);
number[0] = MkIntegerTerm(time_number);
time_numbers[0] = Yap_MkApplTerm(unit,1,number);;
unit = Yap_MkFunctor(Yap_LookupAtom("minutes"),1);
time_number = MYDDAS_STATS_TIME_MINUTES(time);
number[0] = MkIntegerTerm(time_number);
time_numbers[1] = Yap_MkApplTerm(unit,1,number);;
unit = Yap_MkFunctor(Yap_LookupAtom("seconds"),1);
time_number = MYDDAS_STATS_TIME_SECONDS(time);
number[0] = MkIntegerTerm(time_number);
time_numbers[2] = Yap_MkApplTerm(unit,1,number);;
unit = Yap_MkFunctor(Yap_LookupAtom("miliseconds"),1);
time_number = MYDDAS_STATS_TIME_MILISECONDS(time);
number[0] = MkIntegerTerm(time_number);
time_numbers[3] = Yap_MkApplTerm(unit,1,number);;
unit = Yap_MkFunctor(Yap_LookupAtom("microseconds"),1);
time_number = MYDDAS_STATS_TIME_MICROSECONDS(time);
number[0] = MkIntegerTerm(time_number);
time_numbers[4] = Yap_MkApplTerm(unit,1,number);;
count_number[0] = MkIntegerTerm(struc->count);
time_numbers[5] = Yap_MkApplTerm(functor_count,1,count_number);
final_term = Yap_MkApplTerm(functor,6,time_numbers);
break;
}
default:
#ifdef DEBUG
printf ("ERROR: c_db_stats_time unknow option\n");
#endif
return FALSE;
break;
}
if (!Yap_unify(arg_time,final_term )){
return FALSE;
}
return TRUE;
}
//Returns the stats of this module in a list
static Int
c_db_stats(void) {
Term arg_conn = Deref(ARG1);
Term arg_list = Deref(ARG2);
MyddasPointer *conn = (MyddasPointer *) (IntegerOfTerm(arg_conn));
// TODO
if (get_myddas_top() == 0 ){ /* We want all the statistics */
return FALSE;
}
MYDDAS_STATS_STRUCT str;
MYDDAS_UTIL_CONNECTION
node = myddas_util_search_connection(conn);
Term head, list;
list = arg_list;
#ifdef DEBUG
MYDDAS_STATS_TIME time = NULL;
#endif
//[Index 1] -> Total Number of Rows by connection
//Total number of Rows returned by the server
//WARNING: only works with store_result
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,5);
Yap_unify(head, MkIntegerTerm((MyddasInt)str));
#ifdef DEBUG
MyddasUInt number = 0;
MYDDAS_STATS_CON_GET_TOTAL_ROWS(node,number);
printf ("Total Number of Rows returned from the Server\n");
printf ("%lu\n\n",(unsigned long)number);
#endif
//[Index 2] -> Total of Time Spent by the DB Server
// processing all the SQL Querys
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,1);
Yap_unify(head, MkIntegerTerm((MyddasInt)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_TOTAL_TIME_DBSERVER(node,time);
printf ("Reference to time Spent by the Server, on all the SQL Querys\n");
MYDDAS_STATS_PRINT_TIME_STRUCT(time);
printf ("\n\n");
#endif
//[Index 3] -> Total of Time Spent by the DB Server
// processing a the last SQL Query
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,2);
Yap_unify(head, MkIntegerTerm((MyddasInt)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_LAST_TIME_DBSERVER(node,time);
printf ("Reference to time Spent by the Server, on the last SQL Query\n");
MYDDAS_STATS_PRINT_TIME_STRUCT(time);
printf ("\n\n");
#endif
//[Index 4] -> Total of Time Spent by the DB Server
// transfering all the results of the SQL Querys
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,3);
Yap_unify(head, MkIntegerTerm((MyddasInt)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_TOTAL_TIME_TRANSFERING(node,time);
printf ("Refence to time Spent by the Server, transfering all the results SQL Query\n");
MYDDAS_STATS_PRINT_TIME_STRUCT(time);
printf ("\n\n");
#endif
//[Index 5] -> Total of Time Spent by the DB Server
// transfering the result of the last SQL Query
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,4);
Yap_unify(head, MkIntegerTerm((MyddasInt)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_LAST_TIME_TRANSFERING(node,time);
printf ("Reference to time Spent by the Server, transfering the result of the last SQL Query\n");
MYDDAS_STATS_PRINT_TIME_STRUCT(time);
printf ("\n\n");
#endif
//[Index 6] -> Total of Time Spent by the
// db_row_function
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,1);
Yap_unify(head, MkIntegerTerm((MyddasInt)str));
#ifdef DEBUG
MYDDAS_STATS_GET_DB_ROW_FUNCTION(time);
printf ("Reference to time Spent by the db_row_function\n");
MYDDAS_STATS_PRINT_TIME_STRUCT(time);
printf ("\n\n");
#endif
//[Index 7] -> Total of Bytes Transfered by the
// DB Server on all SQL Querys
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,6);
Yap_unify(head, MkIntegerTerm((MyddasPointer)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER(node,number);
printf ("Bytes Transfered by the DB Server from all querys\n");
printf ("%llu\n\n",(MyddasULInt)number);
#endif
//[Index 8] -> Total of Bytes Transfered by the
// DB Server on the last SQL Query
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,7);
Yap_unify(head, MkIntegerTerm((MyddasPointer)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_LAST_BYTES_TRANSFERING_FROM_DBSERVER(node,number);
printf ("Bytes Transfered by the DB Server on the last query\n");
printf ("%llu\n\n",(MyddasULInt)number);
#endif
//[Index 9] -> Number of querys made to the DBserver
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(node->stats,8);
Yap_unify(head, MkIntegerTerm((MyddasPointer)str));
#ifdef DEBUG
MYDDAS_STATS_CON_GET_NUMBER_QUERIES_MADE(node,number);
printf ("Number of Querys made to the server\n");
printf ("%llu\n\n",(MyddasULInt)number);
#endif
//[Index 10] -> Total of Time Spent by the
// translate predicate
head = HeadOfTerm(list);
list = TailOfTerm(list);
str = myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,2);
Yap_unify(head, MkIntegerTerm((Int)str));
#ifdef DEBUG
MYDDAS_STATS_GET_TRANSLATE(time);
printf ("Reference to time Spent by the translate predicate\n");
MYDDAS_STATS_PRINT_TIME_STRUCT(time);
printf ("\n\n");
#endif
/* Memory management */
#ifdef DEBUG
MyddasULInt nr;
MYDDAS_MEMORY_MALLOC_NR(nr);
printf ("Number of times malloc was called in MYDDAS: %lu \n",nr);
MYDDAS_MEMORY_FREE_NR(nr);
printf ("Number of times free was called in MYDDAS : %lu \n",nr);
MYDDAS_MEMORY_MALLOC_SIZE(nr);
printf ("Total memory allocated in MYDDAS: %lu \n",nr);
MYDDAS_MEMORY_FREE_SIZE(nr);
printf ("Total memory freed in MYDDAS : %lu \n",nr);
#endif
return TRUE;
}
#endif /* MYDDAS_STATS */
/* Function to delete all the temporary tables */
/* from the mysql server */
void Yap_MYDDAS_delete_all_myddas_structs(void)
{
/* NAO ESQUECER DE FAZER ISTO TB PARA O DB_CLOSE*/
MYDDAS_GLOBAL global =
Yap_REGS.MYDDAS_GLOBAL_POINTER;
/* In case that the MYDDAS module isn't loaded */
if (global == NULL)
return;
MYDDAS_UTIL_CONNECTION connections =
global->myddas_top_connections;
/* Delete all connections */
for(;connections!=NULL;connections=connections->next)
myddas_util_delete_connection(connections->connection);
#ifdef MYDDAS_STATS
myddas_stats_delete_stats_list(global->myddas_statistics->stats);
MYDDAS_FREE(global->myddas_statistics,struct myddas_global_stats);
#endif
MYDDAS_FREE(global,struct myddas_global);
#ifdef DEBUG
MyddasULInt nr;
MYDDAS_MEMORY_MALLOC_NR(nr);
printf ("Number of times malloc was called in MYDDAS: %lu \n",nr);
MYDDAS_MEMORY_FREE_NR(nr);
printf ("Number of times free was called in MYDDAS : %lu \n",nr);
MYDDAS_MEMORY_MALLOC_SIZE(nr);
printf ("Total memory allocated in MYDDAS: %lu \n",nr);
MYDDAS_MEMORY_FREE_SIZE(nr);
printf ("Total memory freed in MYDDAS : %lu \n",nr);
#endif
}
#endif /*CUT_C && (MYDDAS_MYSQL || MYDDAS_ODBC)*/

356
packages/MYDDAS/myddas_statistics.c Normal file
View File

@ -0,0 +1,356 @@
#include "myddas_structs.h"
#include "myddas_statistics.h"
#include "Yap.h"
#include <stdlib.h>
#include <sys/time.h>
#if defined MYDDAS_STATS
/* Documentation: Time Units
------------------------------------------------------------------------
*****| Second(s) | MiliSeconds(ms) | MicroSeconds(us) | NanoSecond(ns) |
-----|-----------|-----------------|------------------|----------------|
s | 1 | 0.001 | 0.000001 | 1e-9 |
ms | 1000 | 1 | 0.001 | 0.000001 |
us | 10000000 | 1000 | 1 | 0.001 |
ns |1000000000 | 1000000 | 1000 | 1 |
------------------------------------------------------------------------
------
The struct timeval structure represents an elapsed time. It is
declared in `sys/time.h' and has the following members:
long int tv_sec -> This represents the number of whole seconds of
elapsed time.
long int tv_usec -> This is the rest of the elapsed time (a fraction
of a second), represented as the number of microseconds. It is
always less than one million.
------
The struct timespec structure represents an elapsed time. It is
declared in `time.h' and has the following members:
long int tv_sec -> This represents the number of whole seconds of
elapsed time.
long int tv_nsec -> This is the rest of the elapsed time (a fraction
of a second), represented as the number of nanoseconds. It is
always less than one billion.
-----
The gettimeofday() function shall obtain the current time,
expressed as seconds and microseconds since the Epoch, and store
it in the timeval structure pointed to by tp. The resolution of
the system clock is unspecified.
If tzp is not a null pointer, the behavior is unspecified.
*/
static void
myddas_stats_time_subtract (unsigned long *, unsigned long *, MYDDAS_STATS_TIME, MYDDAS_STATS_TIME);
static void
myddas_stats_add_seconds_time(MYDDAS_STATS_TIME,unsigned long, unsigned long);
static void
myddas_stats_integrity_of_time(MYDDAS_STATS_TIME);
/* Be shore to delete MYDDAS_STATS_TIME structure */
MYDDAS_STATS_TIME
myddas_stats_walltime(void) {
MYDDAS_STATS_TIME myddas_time = NULL;
MYDDAS_MALLOC(myddas_time,struct myddas_stats_time_struct);
myddas_time->type = time_copy;
struct timeval *time = NULL;
MYDDAS_MALLOC(time,struct timeval);
gettimeofday(time,NULL);
myddas_time->u.time_copy.tv_sec = time->tv_sec;
myddas_time->u.time_copy.tv_usec = time->tv_usec;
MYDDAS_FREE(time,struct timeval);
return myddas_time;
}
void
myddas_stats_add_time(MYDDAS_STATS_TIME sum, MYDDAS_STATS_TIME time1,MYDDAS_STATS_TIME time2){
if (sum->type == time_final){
sum->u.time_final.microseconds =
time1->u.time_final.microseconds +
time2->u.time_final.microseconds;
sum->u.time_final.miliseconds =
time1->u.time_final.miliseconds +
time2->u.time_final.miliseconds;
sum->u.time_final.seconds =
time1->u.time_final.seconds +
time2->u.time_final.seconds;
sum->u.time_final.minutes =
time1->u.time_final.minutes +
time2->u.time_final.minutes;
sum->u.time_final.hours =
time1->u.time_final.hours +
time2->u.time_final.hours;
} else {
sum->u.time_copy.tv_sec =
time1->u.time_copy.tv_sec +
time2->u.time_copy.tv_sec;
sum->u.time_copy.tv_usec =
time1->u.time_copy.tv_usec +
time2->u.time_copy.tv_usec;
}
myddas_stats_integrity_of_time(sum);
}
void
myddas_stats_subtract_time(MYDDAS_STATS_TIME result, MYDDAS_STATS_TIME t1,MYDDAS_STATS_TIME t2){
if (result->type == time_copy){
unsigned long sec;
unsigned long usec;
myddas_stats_time_subtract(&sec,&usec,t1,t2);
result->u.time_copy.tv_sec = sec;
result->u.time_copy.tv_usec = usec;
} else {
}
}
void
myddas_stats_move_time(MYDDAS_STATS_TIME from,
MYDDAS_STATS_TIME to)
{
if (from->type == time_copy)
{
to->type = time_copy;
to->u.time_copy.tv_sec = from->u.time_copy.tv_sec;
to->u.time_copy.tv_usec = from->u.time_copy.tv_usec;
}
else if (from->type == time_final)
{
to->u.time_final.hours = from->u.time_final.hours;
to->u.time_final.minutes = from->u.time_final.minutes;
to->u.time_final.seconds = from->u.time_final.seconds;
to->u.time_final.miliseconds = from->u.time_final.miliseconds;
to->u.time_final.microseconds = from->u.time_final.microseconds;
}
MYDDAS_FREE(from,struct myddas_stats_time_struct);
}
MYDDAS_STATS_TIME
myddas_stats_time_copy_to_final(MYDDAS_STATS_TIME t_copy){
MYDDAS_STATS_TIME t_final;
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(t_final,time_final);
myddas_stats_add_seconds_time(t_final,
t_copy->u.time_copy.tv_sec,
t_copy->u.time_copy.tv_usec);
MYDDAS_FREE(t_copy,struct myddas_stats_time_struct);
return t_final;
}
static void
myddas_stats_add_seconds_time(MYDDAS_STATS_TIME myddas_time,
unsigned long sec,
unsigned long usec){
short hours = sec / 3600;
sec %= 3600;
short minutes = sec / 60;
sec %= 60;
short milisec = usec / 1000;
usec %= 1000;
myddas_time->u.time_final.microseconds += usec ;
myddas_time->u.time_final.miliseconds += milisec;
myddas_time->u.time_final.seconds += sec ;
myddas_time->u.time_final.minutes += minutes ;
myddas_time->u.time_final.hours += hours;
myddas_stats_integrity_of_time(myddas_time);
}
static void
myddas_stats_time_subtract(unsigned long *sec,unsigned long *usec,
MYDDAS_STATS_TIME start, MYDDAS_STATS_TIME end){
/* Perform the carry for the later subtraction by updating y. */
if (start->u.time_copy.tv_usec < end->u.time_copy.tv_usec) {
int nsec = (end->u.time_copy.tv_usec - start->u.time_copy.tv_usec) / 1000000 + 1;
end->u.time_copy.tv_usec -= 1000000 * nsec;
end->u.time_copy.tv_sec += nsec;
}
if (start->u.time_copy.tv_usec - end->u.time_copy.tv_usec > 1000000) {
int nsec = (start->u.time_copy.tv_usec - end->u.time_copy.tv_usec) / 1000000;
end->u.time_copy.tv_usec += 1000000 * nsec;
end->u.time_copy.tv_sec -= nsec;
}
/* Compute the time remaining to wait.
tv_usec is certainly positive. */
*sec = start->u.time_copy.tv_sec - end->u.time_copy.tv_sec;
*usec = start->u.time_copy.tv_usec - end->u.time_copy.tv_usec;
}
static void
myddas_stats_integrity_of_time(MYDDAS_STATS_TIME myddas_time){
if (myddas_time->u.time_final.microseconds > 999)
{
myddas_time->u.time_final.microseconds -= 1000;
myddas_time->u.time_final.miliseconds++;
}
if (myddas_time->u.time_final.miliseconds > 999)
{
myddas_time->u.time_final.miliseconds -= 1000;
myddas_time->u.time_final.seconds++;
}
if (myddas_time->u.time_final.seconds > 59)
{
myddas_time->u.time_final.seconds -= 60;
myddas_time->u.time_final.minutes++;
}
if (myddas_time->u.time_final.minutes > 59)
{
myddas_time->u.time_final.minutes -= 60;
myddas_time->u.time_final.hours++;
}
}
MYDDAS_GLOBAL
myddas_stats_initialize_global_stats(MYDDAS_GLOBAL global){
MYDDAS_STATS_STRUCT stats = NULL;
short i;
/* For the time statistics */
/*
Stats [1] - Total Time spent on the db_row function
Stats [2] - Total Time spent on the translate/3 predicate
*/
/* First */
stats = myddas_stats_initialize_stat(stats,time_str);
(global->myddas_statistics)->stats = stats;
for(i=0;i<1;i++){
myddas_stats_initialize_stat(stats,time_str);
}
return global;
}
MYDDAS_STATS_STRUCT
myddas_stats_initialize_connection_stats(){
/*
Stats [1] - Total of Time Spent by the DB Server processing all the SQL Querys
Stats [2] - Total of Time Spent by the DB Server processing the last SQL Query
Stats [3] - Total of Time Spent by the DB Server transfering all the results of the SQL Querys
Stats [4] - Total of Time Spent by the DB Server transfering the result of the last SQL Query
Stats [5] - Total number of Rows returned by the server
Stats [6] - Total of Bytes Transfered by the DB Server on all SQL Querys
Stats [7] - Total of Bytes Transfered by the DB Server on the last SQL Query
Stats [8] - Number of querys made to the DBserver
*/
short i;
MYDDAS_STATS_STRUCT new = NULL ;
MYDDAS_STATS_STRUCT first;
/* For the time statistics */
/* First */
new = myddas_stats_initialize_stat(new,time_str);
first = new;
for(i=0;i<3;i++){
new = myddas_stats_initialize_stat(new,time_str);
}
/* For number statistics*/
for (i=0;i<4;i++){
new = myddas_stats_initialize_stat(new,integer);
}
return first;
}
MYDDAS_STATS_STRUCT
myddas_stats_initialize_stat(MYDDAS_STATS_STRUCT stat,int type){
MYDDAS_STATS_STRUCT temp_str = stat;
if (stat == NULL){
MYDDAS_MALLOC(stat,struct myddas_stats_struct);
temp_str = stat;
} else {
for (;temp_str->nxt != NULL;temp_str = temp_str->nxt);
MYDDAS_MALLOC(temp_str->nxt,struct myddas_stats_struct);
temp_str = temp_str->nxt;
}
if (type == time_str){
MYDDAS_STATS_INITIALIZE_TIME_STRUCT(temp_str->u.time_str.time_str,time_final);
} else {
temp_str->u.integer.integer = 0;
}
temp_str->type = type;
temp_str->count = 0;
temp_str->nxt = NULL;
return temp_str;
}
MYDDAS_STATS_STRUCT
myddas_stats_get_stat(MYDDAS_STATS_STRUCT stat,int index){
MYDDAS_STATS_STRUCT temp = stat;
for (;index>1;index--){
temp = temp->nxt;
}
return temp;
}
void
myddas_stats_delete_stats_list(MYDDAS_STATS_STRUCT list){
MYDDAS_STATS_STRUCT to_delete = list;
for (;to_delete!=NULL;){
list = list->nxt;
if (to_delete->type == time_str){
MYDDAS_FREE(to_delete->u.time_str.time_str,struct myddas_stats_time_struct);
}
MYDDAS_FREE(to_delete,struct myddas_stats_struct);
to_delete = list;
}
}
#endif /* MYDDAS_STATS || MYDDAS_TOP_LEVEL */

135
packages/MYDDAS/myddas_statistics.h Normal file
View File

@ -0,0 +1,135 @@
#ifndef __MYDDAS_STATISTICS_H__
#define __MYDDAS_STATISTICS_H__
#ifdef MYDDAS_STATS
#define MYDDAS_STATS_TIME_HOURS(TIME) TIME->u.time_final.hours;
#define MYDDAS_STATS_TIME_MINUTES(TIME) TIME->u.time_final.minutes;
#define MYDDAS_STATS_TIME_SECONDS(TIME) TIME->u.time_final.seconds;
#define MYDDAS_STATS_TIME_MILISECONDS(TIME) TIME->u.time_final.miliseconds;
#define MYDDAS_STATS_TIME_MICROSECONDS(TIME) TIME->u.time_final.microseconds;
#ifdef DEBUG
#define MYDDAS_STATS_PRINT_TIME_STRUCT(TIME) \
if (TIME->type == time_final) { \
printf ("%d Hours, %d Minutes, %d Seconds, %d Miliseconds, %d Microseconds", \
TIME->u.time_final.hours, \
TIME->u.time_final.minutes, \
TIME->u.time_final.seconds, \
TIME->u.time_final.miliseconds, \
TIME->u.time_final.microseconds); \
} else { \
printf ("%lu Seconds, %lu Microseconds", \
TIME->u.time_copy.tv_sec, \
TIME->u.time_copy.tv_usec); \
}
#endif
#define MYDDAS_STATS_INITIALIZE_TIME_STRUCT(TIME,TYPE) \
MYDDAS_MALLOC(TIME,struct myddas_stats_time_struct); \
\
if (TYPE == time_copy){ \
TIME->type = TYPE; \
TIME->u.time_copy.tv_sec = 0; \
TIME->u.time_copy.tv_usec = 0; \
} else { \
TIME->type = TYPE; \
TIME->u.time_final.hours = 0; \
TIME->u.time_final.minutes = 0; \
TIME->u.time_final.seconds = 0; \
TIME->u.time_final.miliseconds = 0; \
TIME->u.time_final.microseconds = 0; \
}
#define MYDDAS_STATS_CON_GET_TOTAL_TIME_DBSERVER(NODE,TIME) \
TIME = myddas_stats_get_stat(NODE->stats,1)->u.time_str.time_str;
#define MYDDAS_STATS_CON_GET_TOTAL_TIME_DBSERVER_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,1)->count;
#define MYDDAS_STATS_CON_SET_TOTAL_TIME_DBSERVER_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,1)->count = COUNT;
#define MYDDAS_STATS_CON_GET_LAST_TIME_DBSERVER(NODE,TIME) \
TIME = myddas_stats_get_stat(NODE->stats,2)->u.time_str.time_str;
#define MYDDAS_STATS_CON_GET_LAST_TIME_DBSERVER_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,2)->count;
#define MYDDAS_STATS_CON_SET_LAST_TIME_DBSERVER_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,2)->count = COUNT;
#define MYDDAS_STATS_CON_GET_TOTAL_TIME_TRANSFERING(NODE,TIME) \
TIME = myddas_stats_get_stat(NODE->stats,3)->u.time_str.time_str;
#define MYDDAS_STATS_CON_GET_TOTAL_TIME_TRANSFERING_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,3)->count;
#define MYDDAS_STATS_CON_SET_TOTAL_TIME_TRANSFERING_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,3)->count = COUNT;
#define MYDDAS_STATS_CON_GET_LAST_TIME_TRANSFERING(NODE,TIME) \
TIME = myddas_stats_get_stat(NODE->stats,4)->u.time_str.time_str;
#define MYDDAS_STATS_CON_GET_LAST_TIME_TRANSFERING_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,4)->count;
#define MYDDAS_STATS_CON_SET_LAST_TIME_TRANSFERING_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,4)->count = COUNT;
#define MYDDAS_STATS_CON_GET_TOTAL_ROWS(NODE,NUMBER) \
NUMBER = myddas_stats_get_stat(NODE->stats,5)->u.integer.integer;
#define MYDDAS_STATS_CON_SET_TOTAL_ROWS(NODE,NUMBER) \
myddas_stats_get_stat(NODE->stats,5)->u.integer.integer = NUMBER;
#define MYDDAS_STATS_CON_GET_TOTAL_ROWS_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,5)->count;
#define MYDDAS_STATS_CON_SET_TOTAL_ROWS_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,5)->count = COUNT;
#define MYDDAS_STATS_CON_GET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER(NODE,NUMBER) \
NUMBER = myddas_stats_get_stat(NODE->stats,6)->u.integer.integer;
#define MYDDAS_STATS_CON_SET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER(NODE,NUMBER) \
myddas_stats_get_stat(NODE->stats,6)->u.integer.integer = NUMBER;
#define MYDDAS_STATS_CON_GET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,6)->count;
#define MYDDAS_STATS_CON_SET_TOTAL_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,6)->count = COUNT;
#define MYDDAS_STATS_CON_GET_LAST_BYTES_TRANSFERING_FROM_DBSERVER(NODE,NUMBER) \
NUMBER = myddas_stats_get_stat(NODE->stats,7)->u.integer.integer;
#define MYDDAS_STATS_CON_SET_LAST_BYTES_TRANSFERING_FROM_DBSERVER(NODE,NUMBER) \
myddas_stats_get_stat(NODE->stats,7)->u.integer.integer = NUMBER;
#define MYDDAS_STATS_CON_GET_LAST_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,7)->count;
#define MYDDAS_STATS_CON_SET_LAST_BYTES_TRANSFERING_FROM_DBSERVER_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,7)->count = COUNT;
#define MYDDAS_STATS_CON_GET_NUMBER_QUERIES_MADE(NODE,NUMBER) \
NUMBER = myddas_stats_get_stat(NODE->stats,8)->u.integer.integer;
#define MYDDAS_STATS_CON_SET_NUMBER_QUERIES_MADE(NODE,NUMBER) \
myddas_stats_get_stat(NODE->stats,8)->u.integer.integer = NUMBER;
#define MYDDAS_STATS_CON_GET_NUMBER_QUERIES_MADE_COUNT(NODE,COUNT) \
COUNT = myddas_stats_get_stat(NODE->stats,8)->count;
#define MYDDAS_STATS_CON_SET_NUMBER_QUERIES_MADE_COUNT(NODE,COUNT) \
myddas_stats_get_stat(NODE->stats,8)->count = COUNT;
#define MYDDAS_STATS_GET_DB_ROW_FUNCTION(TIME) \
TIME = myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,1)->u.time_str.time_str;
#define MYDDAS_STATS_GET_DB_ROW_FUNCTION_COUNT(COUNT) \
COUNT = myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,1)->count;
#define MYDDAS_STATS_SET_DB_ROW_FUNCTION_COUNT(COUNT) \
myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,1)->count = COUNT;
#define MYDDAS_STATS_GET_TRANSLATE(TIME) \
TIME = myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,2)->u.time_str.time_str;
#define MYDDAS_STATS_GET_TRANSLATE_COUNT(COUNT) \
COUNT = myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,2)->count;
#define MYDDAS_STATS_SET_TRANSLATE_COUNT(COUNT) \
myddas_stats_get_stat(Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_statistics->stats,2)->count = COUNT;
MYDDAS_STATS_TIME myddas_stats_walltime(void);
void myddas_stats_add_time(MYDDAS_STATS_TIME, MYDDAS_STATS_TIME,MYDDAS_STATS_TIME);
void myddas_stats_subtract_time(MYDDAS_STATS_TIME, MYDDAS_STATS_TIME,MYDDAS_STATS_TIME);
void myddas_stats_move_time(MYDDAS_STATS_TIME,MYDDAS_STATS_TIME);
MYDDAS_STATS_TIME myddas_stats_time_copy_to_final(MYDDAS_STATS_TIME);
/* Related to the statistics linked list */
MYDDAS_STATS_STRUCT myddas_stats_initialize_stat(MYDDAS_STATS_STRUCT,int);
MYDDAS_STATS_STRUCT myddas_stats_get_stat(MYDDAS_STATS_STRUCT,int);
#endif /* MYDDAS_STATS */
#endif

50
packages/MYDDAS/myddas_statistics_structs.h Normal file
View File

@ -0,0 +1,50 @@
#ifndef __MYDDAS_STATISTICS_STRUCTS_H__
#define __MYDDAS_STATISTICS_STRUCTS_H__
#ifdef MYDDAS_STATS
/* This strucuture holds some global statistics*/
struct myddas_global_stats {
MYDDAS_STATS_STRUCT stats;
};
/* Structure to hold any kind of statistics */
struct myddas_stats_struct{
enum {time_str,
integer} type;
union {
struct {
MYDDAS_STATS_TIME time_str;
} time_str;
struct {
MyddasULInt integer;
} integer;
} u;
MyddasULInt count;
MYDDAS_STATS_STRUCT nxt;
};
/* Time structure for the MYDDAS Interface */
struct myddas_stats_time_struct{
enum {time_copy,
time_final} type;
union {
struct {
unsigned long tv_sec;
unsigned long tv_usec;
} time_copy;
struct {
MyddasUSInt hours;
MyddasUSInt minutes; //Max 59
MyddasUSInt seconds; //Max 59
MyddasUSInt miliseconds; //Max 999
MyddasUSInt microseconds; //Max 999
} time_final;
} u;
};
#endif /* MYDDAS_STATS */
#endif

67
packages/MYDDAS/myddas_structs.h Normal file
View File

@ -0,0 +1,67 @@
#ifndef __MYDDAS_STRUCTS_H__
#define __MYDDAS_STRUCTS_H__
#include "myddas.h"
#ifdef MYDDAS_STATS
#include "myddas_statistics_structs.h"
#endif
struct myddas_global {
MYDDAS_UTIL_CONNECTION myddas_top_connections;
#ifdef MYDDAS_TOP_LEVEL
MYDDAS_UTIL_CONNECTION myddas_top_level_connection;
#endif
#ifdef MYDDAS_STATS
MYDDAS_GLOBAL_STATS myddas_statistics;
#endif
#ifdef DEBUG
/* Number times malloc was called */
MyddasULInt malloc_called;
/* Memory allocated by MYDDAS */
MyddasULInt memory_allocated;
/* Number times free was called */
MyddasULInt free_called;
/* Memory freed by MYDDAS */
MyddasULInt memory_freed;
#endif
};
struct myddas_list_preds {
char *pred_module;
char *pred_name;
short pred_arity;
//void *pe;
MYDDAS_UTIL_PREDICATE next;
MYDDAS_UTIL_PREDICATE previous;
};
struct myddas_list_connection {
void *connection;
/*If variable env is NULL, then it's a
MySQL connection, if not then it as the pointer
to the ODBC enviromment variable */
void *odbc_enviromment;
#ifdef MYDDAS_STATS
MYDDAS_STATS_STRUCT stats;
#endif
MYDDAS_UTIL_PREDICATE predicates;
/* Multi Queries Section */
unsigned long total_number_queries;
unsigned long actual_number_queries;
MYDDAS_UTIL_QUERY *queries;
/* List Integrety */
MYDDAS_UTIL_CONNECTION next;
MYDDAS_UTIL_CONNECTION previous;
};
struct myddas_util_query{
char *query;
MYDDAS_UTIL_QUERY next;
};
#endif

93
packages/MYDDAS/myddas_top_level.c Normal file
View File

@ -0,0 +1,93 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: myddas_top_level.c *
* Last rev: 27/01/06 *
* mods: *
* comments: Top Level of the MYDDAS Interface *
* *
*************************************************************************/
#if defined MYDDAS_TOP_LEVEL && defined MYDDAS_MYSQL
#include "Yap.h"
#include "Yatom.h"
#include "myddas.h"
#include "myddas_structs.h"
#include "myddas_statistics.h"
#include <mysql/mysql.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#if defined HAVE_LIBREADLINE
#include <readline/readline.h>
#include <readline/history.h>
#endif
#include <sys/times.h>
STATIC_PROTO(Int c_db_tl_readline,(void));
void Yap_InitMYDDAS_TopLevelPreds(void)
{
/* c_db_readline: +Prompt x -Line */
Yap_InitCPred("c_db_tl_readline", 2, c_db_tl_readline, SafePredFlag|SyncPredFlag|HiddenPredFlag);
}
typedef struct {
const char *name; /* User printable name of the function. */
char cmd_char; /* msql command character */
Int (*func)(char *str,char *); /* Function to call to do the job. */
//bool takes_params; /* Max parameters for command */
const char *doc; /* Documentation for this function. */
} COMMANDS;
static Int
c_db_tl_readline(void) {
Term arg_prompt = Deref(ARG1);
Term arg_line = Deref(ARG2);
char *prompt = AtomName(AtomOfTerm(arg_prompt));
char *line;
while (strlen(line = readline(prompt)) == 0) {
free(line);
}
add_history(line);
Term line_read = MkAtomTerm(Yap_LookupAtom(line));
free(line);
if (!Yap_unify(arg_line,line_read))
return FALSE;
return TRUE;
}
static void
myddas_top_level_print_time(MYDDAS_STATS_TIME time){
//TODO test for big queries, and see the output of mysql
printf("(");
printf("%d",time->u.time_final.seconds);
//MiliSeconds 2 decimal points
printf(".%d",time->u.time_final.miliseconds/10);
printf (" sec)");
}
#endif

399
packages/MYDDAS/myddas_util.c Executable file
View File

@ -0,0 +1,399 @@
#if defined MYDDAS_ODBC || defined MYDDAS_MYSQL
#include "Yap.h"
#include <string.h>
#include <stdlib.h>
#include "cut_c.h"
#include "myddas.h"
#include "myddas_structs.h"
#ifdef MYDDAS_STATS
#include "myddas_statistics.h"
#endif
#ifdef MYDDAS_ODBC
#include <sql.h>
#endif /*MYDDAS_ODBC*/
#ifdef MYDDAS_MYSQL
#include <mysql/mysql.h>
#endif /*MYDDAS_MYSQL*/
/* Search for the predicate in the given predicate list*/
static MYDDAS_UTIL_PREDICATE
myddas_util_find_predicate(char *, Int , char *, MYDDAS_UTIL_PREDICATE);
/* Deletes a predicate list */
static void
myddas_util_delete_predicate_list(MYDDAS_UTIL_PREDICATE);
/* Prints a error message */
static void
myddas_util_error_message(char *,Int,char *);
#ifdef MYDDAS_MYSQL
/* Auxilary function to table_write*/
static void
n_print(Int , char );
#endif
/* Type: MYSQL->1 ODBC->2*/
Short
myddas_util_connection_type(void *con){
MYDDAS_UTIL_CONNECTION con_node =
myddas_util_search_connection(con);
if (con_node == NULL)
return 0;
if (con_node->odbc_enviromment != NULL) /* ODBC */
return 2;
else
return 1;
}
MYDDAS_UTIL_PREDICATE
myddas_util_search_predicate(char *pred_name, Int pred_arity,
char *pred_module){
MYDDAS_UTIL_PREDICATE pred=NULL;
MYDDAS_UTIL_CONNECTION top = Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
for (;top!=NULL;top=top->next)
{
if ((pred=myddas_util_find_predicate(pred_name,pred_arity,pred_module,top->predicates)))
return pred;
}
return NULL;
}
/* When using this function, we must guarante that this predicate
it's unique */
MYDDAS_UTIL_CONNECTION
myddas_util_add_predicate(char *pred_name, Int pred_arity,
char *pred_module, void *con){
MYDDAS_UTIL_CONNECTION node_con =
myddas_util_search_connection(con);
MYDDAS_UTIL_PREDICATE new =
myddas_init_initialize_predicate(pred_name,pred_arity,pred_module,node_con->predicates);
if (new == NULL)
{
myddas_util_error_message("Could not initialize predicate node",__LINE__,__FILE__);
return NULL;
}
node_con->predicates=new;
return node_con;
}
void
myddas_util_delete_predicate(MYDDAS_UTIL_PREDICATE to_delete){
if (to_delete->next != NULL)
to_delete->next->previous = to_delete->previous;
if (to_delete->previous != NULL)
to_delete->previous->next = to_delete->next;
else //First predicate of the predicate list
{
MYDDAS_UTIL_CONNECTION con_node = Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
for(;con_node != NULL; con_node = con_node->next)
if (con_node->predicates == to_delete)
break;
con_node->predicates = to_delete->next;
}
MYDDAS_FREE(to_delete,struct myddas_list_preds);
}
void
myddas_util_delete_connection(void *conn){
MYDDAS_UTIL_CONNECTION to_delete = myddas_util_search_connection(conn);
if (to_delete == NULL)
return;
else
{
/* Removes the predicates list */
myddas_util_delete_predicate_list(to_delete->predicates);
#ifdef MYDDAS_STATS
/* Removes the stats list */
myddas_stats_delete_stats_list(to_delete->stats);
#endif
/* List Integrety */
/* Is the last element of the list */
if ((to_delete->next) != NULL)
to_delete->next->previous = to_delete->previous;
/* Is the first element of the list */
if (to_delete == (Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections))
Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections = to_delete->next;
else
to_delete->previous->next=to_delete->next;
MYDDAS_FREE(to_delete,struct myddas_list_connection);
return;
}
}
MYDDAS_UTIL_CONNECTION
myddas_util_search_connection(void *conn){
MYDDAS_UTIL_CONNECTION list = Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
#ifdef MYDDAS_STATS
if (conn == 0) { /* We want all the statistics */
return list;
}
#endif
for (;list!=NULL;list=list->next)
if (list->connection == conn)
return list;
return NULL;
}
MYDDAS_UTIL_CONNECTION
myddas_util_add_connection(void *conn, void *enviromment){
MYDDAS_UTIL_CONNECTION node=NULL;
MYDDAS_UTIL_CONNECTION temp=NULL;
if ((node = myddas_util_search_connection(conn)) != NULL)
{
return node;
}
//put the new connection node on the top of the list
temp = myddas_init_initialize_connection(conn,enviromment,Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections);
if (temp == NULL)
{
#ifdef DEBUG
myddas_util_error_message("Could not initialize connection node",__LINE__,__FILE__);
#endif
return NULL;
}
Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections = temp;
return Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
}
#ifdef MYDDAS_ODBC
/* This function searches the MYDDAS list for odbc connections
If there isn't any, it returns NULL. This is a nice way to know
if there is any odbc connections left on the list*/
SQLHENV
myddas_util_get_odbc_enviromment(SQLHDBC connection){
MYDDAS_UTIL_CONNECTION top = Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
for (;top != NULL;top=top->next)
if (top->connection == ((void *)connection))
return top->odbc_enviromment;
return NULL;
}
#endif
UInt
myddas_util_get_total_multi_queries_number(MYDDAS_UTIL_CONNECTION con){
return con->total_number_queries;
}
void
myddas_util_set_total_multi_queries_number(MYDDAS_UTIL_CONNECTION con,
UInt number){
con->total_number_queries = number;
}
#ifdef MYDDAS_MYSQL
/* Auxilary function to table_write*/
static void
n_print(Int n, char c)
{
for(;n>0;n--) printf("%c",c);
}
#endif
static
void myddas_util_error_message(char *message ,Int line,char *file){
#ifdef DEBUG
printf ("ERROR: %s at line %d in file %s\n",message,(int)line,file);
#else
printf ("ERROR: %s\n",message);
#endif
}
static MYDDAS_UTIL_PREDICATE
myddas_util_find_predicate(char *pred_name, Int pred_arity,
char *pred_module, MYDDAS_UTIL_PREDICATE list){
for(;list != NULL ; list = list->next)
if (pred_arity == list->pred_arity &&
!strcmp(pred_name,list->pred_name) &&
!strcmp(pred_module,list->pred_module))
return list;
return NULL;
}
static void
myddas_util_delete_predicate_list(MYDDAS_UTIL_PREDICATE preds_list){
MYDDAS_UTIL_PREDICATE to_delete = NULL;
for (;preds_list != NULL;)
{
to_delete = preds_list;
preds_list = preds_list->next;
MYDDAS_FREE(to_delete,struct myddas_list_preds);
}
return;
}
#ifdef MYDDAS_MYSQL
void
myddas_util_table_write(MYSQL_RES *res_set){
MYSQL_ROW row;
MYSQL_FIELD *fields;
Int i,f;
if (mysql_num_rows(res_set) == 0)
{
printf ("Empty Set\n");
return;
}
f = mysql_num_fields(res_set);
fields = mysql_fetch_field(res_set);
for(i=0;i<f;i++)
{
printf("+");
if (strlen(fields[i].name)>fields[i].max_length) fields[i].max_length=strlen(fields[i].name);
n_print(fields[i].max_length+2,'-');
}
printf("+\n");
for(i=0;i<f;i++)
{
printf("|");
printf(" %s ",fields[i].name);
n_print(fields[i].max_length - strlen(fields[i].name),' ');
}
printf("|\n");
for(i=0;i<f;i++)
{
printf("+");
n_print(fields[i].max_length+2,'-');
}
printf("+\n");
while ((row = mysql_fetch_row(res_set)) != NULL)
{
for(i=0;i<f;i++)
{
printf("|");
if (row[i] != NULL)
{
printf(" %s ",row[i]);
n_print(fields[i].max_length - strlen(row[i]),' ');
}
else
{
printf(" NULL ");
n_print(fields[i].max_length - 4,' ');
}
}
printf("|\n");
}
for(i=0;i<f;i++)
{
printf("+");
n_print(fields[i].max_length+2,'-');
}
printf("+\n");
}
#endif
//DELETE THIS WHEN DB_STATS IS COMPLETED
MyddasInt
get_myddas_top(){
if (Yap_REGS.MYDDAS_GLOBAL_POINTER == NULL)
return 0;
return (Int)Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
}
void *
myddas_util_get_pred_next(void *pointer){
MYDDAS_UTIL_PREDICATE temp = (MYDDAS_UTIL_PREDICATE) pointer;
return (void *) (temp->next);
}
MyddasInt
myddas_util_get_pred_arity(void *pointer){
MYDDAS_UTIL_PREDICATE temp = (MYDDAS_UTIL_PREDICATE) pointer;
return temp->pred_arity;
}
char *
myddas_util_get_pred_name(void *pointer){
MYDDAS_UTIL_PREDICATE temp = (MYDDAS_UTIL_PREDICATE) pointer;
return temp->pred_name;
}
char *
myddas_util_get_pred_module(void *pointer){
MYDDAS_UTIL_PREDICATE temp = (MYDDAS_UTIL_PREDICATE) pointer;
return temp->pred_module;
}
void *
myddas_util_get_list_pred(MYDDAS_UTIL_CONNECTION node){
return (void *)(node->predicates);
}
#ifdef DEBUG
void check_int(){
Int i;
MYDDAS_UTIL_PREDICATE pred = NULL;
MYDDAS_UTIL_CONNECTION top = Yap_REGS.MYDDAS_GLOBAL_POINTER->myddas_top_connections;
for (i=1 ; top!=NULL ; top=top->next)
{
printf ("***************\n");
printf ("===== top =====\n");
printf ("======= %p =====\n",top);
printf ("CONN: = %p =====\n",top->connection);
printf ("ENV : = %p =====\n",top->odbc_enviromment);
printf ("PRED: = %p =====\n",top->predicates);
printf ("======= %p =====\n",top->previous);
printf ("======= %p =====\n",top->next);
if (top->predicates != NULL)
{
printf ("\t******\n");
printf ("\t===== PREDICADOS =====\n");
for (pred = top->predicates ; pred != NULL ; pred = pred->next)
{
printf ("\t--------------\n");
printf ("\t===== %p =====\n",pred);
printf ("\t===== %s =====\n",pred->pred_name);
printf ("\t===== %d =====\n",pred->pred_arity);
printf ("\t===== %s =====\n",pred->pred_module);
printf ("\t===== %p =====\n",pred->previous);
printf ("\t===== %p =====\n",pred->next);
}
}
}
return;
}
#endif
#endif /*defined MYDDAS_ODBC || defined MYDDAS_MYSQL*/

25
packages/MYDDAS/myddas_wkb.h Normal file
View File

@ -0,0 +1,25 @@
#ifndef MYDDAS_WKB_H_
#define MYDDAS_WKB_H_
typedef char byte;
typedef unsigned int uint32;
#define WKBXDR 0
#define WKBNDR 1
#define WKBMINTYPE 1
#define WKBPOINT 1
#define WKBLINESTRING 2
#define WKBPOLYGON 3
#define WKBMULTIPOINT 4
#define WKBMULTILINESTRING 5
#define WKBMULTIPOLYGON 6
#define WKBGEOMETRYCOLLECTION 7
#define WKBMAXTYPE 7
#define WKBGEOMETRY 0
#endif /* MYDDAS_WKB_H_ */

380
packages/MYDDAS/myddas_wkb2prolog.c Normal file
View File

@ -0,0 +1,380 @@
#if defined MYDDAS_MYSQL
#include <stdio.h>
#include <stdlib.h>
#include "Yap.h"
#include <netinet/in.h>
#include "myddas_wkb.h"
#include "myddas_wkb2prolog.h"
static void readswap4(uint32 *buf);
static void readswap8(double *buf);
static byte get_hostbyteorder(void);
static byte get_inbyteorder(void);
static uint32 get_wkbType(void);
static Term get_point(char *functor);
static Term get_linestring(char *functor);
static Term get_polygon(char *functor);
static Term get_geometry(uint32 type);
static int swaporder;
static byte inbyteorder, hostbyteorder;
static byte *cursor;
Term wkb2prolog(char *wkb) {
uint32 type;
cursor = wkb;
/*ignore the SRID 4 bytes*/
cursor += 4;
/*byteorder*/
hostbyteorder = get_hostbyteorder();
inbyteorder = get_inbyteorder();
swaporder = 0;
if ( hostbyteorder != inbyteorder )
swaporder = 1;
type = get_wkbType();
return get_geometry(type);
}
static byte get_hostbyteorder(void){
uint16_t host = 5;
uint16_t net;
net = htons(host);
if ( net == host )
return(WKBXDR);
else
return(WKBNDR);
}
static byte get_inbyteorder(void){
byte b = cursor[0];
if (b != WKBNDR && b != WKBXDR) {
fprintf(stderr, "Unknown byteorder: %d\n",b);
exit(0);
}
cursor++;
return(b);
}
static uint32 get_wkbType(void){
uint32 u;
/* read the type */
readswap4(&u);
if (u > WKBMAXTYPE || u < WKBMINTYPE) {
fprintf(stderr, "Unknown type: %d\n",u);
exit(0);
}
return(u);
}
static void readswap4(uint32 *buf){
((byte *) buf)[0] = cursor[0];
((byte *) buf)[1] = cursor[1];
((byte *) buf)[2] = cursor[2];
((byte *) buf)[3] = cursor[3];
if ( swaporder ) {
if ( inbyteorder == WKBXDR ) {
*buf = (uint32)ntohl((u_long)*buf);
} else {
byte u[4];
u[0] = ((byte *) buf)[3];
u[1] = ((byte *) buf)[2];
u[2] = ((byte *) buf)[1];
u[3] = ((byte *) buf)[0];
((byte *) buf)[0] = u[0];
((byte *) buf)[1] = u[1];
((byte *) buf)[2] = u[2];
((byte *) buf)[3] = u[3];
}
}
cursor += 4;
}
static void readswap8(double *buf) {
((byte *) buf)[0] = cursor[0];
((byte *) buf)[1] = cursor[1];
((byte *) buf)[2] = cursor[2];
((byte *) buf)[3] = cursor[3];
((byte *) buf)[4] = cursor[4];
((byte *) buf)[5] = cursor[5];
((byte *) buf)[6] = cursor[6];
((byte *) buf)[7] = cursor[7];
if ( swaporder ) {
if ( inbyteorder == WKBXDR ) {
u_long u[2];
u[0] = ((u_long *) buf)[0];
u[1] = ((u_long *) buf)[1];
((u_long *) buf)[1] = ntohl(u[0]);
((u_long *) buf)[0] = ntohl(u[1]);
} else {
byte u[8];
u[0] = ((byte *) buf)[7];
u[1] = ((byte *) buf)[6];
u[2] = ((byte *) buf)[5];
u[3] = ((byte *) buf)[4];
u[4] = ((byte *) buf)[3];
u[5] = ((byte *) buf)[2];
u[6] = ((byte *) buf)[1];
u[7] = ((byte *) buf)[0];
((byte *) buf)[0] = u[0];
((byte *) buf)[1] = u[1];
((byte *) buf)[2] = u[2];
((byte *) buf)[3] = u[3];
((byte *) buf)[4] = u[4];
((byte *) buf)[5] = u[5];
((byte *) buf)[6] = u[6];
((byte *) buf)[7] = u[7];
}
}
cursor += 8;
}
static Term get_point(char *func){
Term args[2];
Functor functor;
double d;
if(func == NULL)
/*functor "," => (_,_)*/
functor = Yap_MkFunctor(Yap_LookupAtom(","), 2);
else
functor = Yap_MkFunctor(Yap_LookupAtom(func), 2);
/* read the X */
readswap8(&d);
args[0] = MkFloatTerm(d);
/* read the Y */
readswap8(&d);
args[1] = MkFloatTerm(d);
return Yap_MkApplTerm(functor, 2, args);
}
static Term get_linestring(char *func){
Term *c_list;
Term list;
Functor functor;
uint32 n;
int i;
/* read the number of vertices */
readswap4(&n);
/* space for arguments */
c_list = (Term *) calloc(sizeof(Term),n);
for ( i = 0; i < n; i++) {
c_list[i] = get_point(NULL);
}
list = MkAtomTerm(Yap_LookupAtom("[]"));
for (i = n - 1; i >= 0; i--) {
list = MkPairTerm(c_list[i],list);
}
if(func == NULL)
return list;
else{
functor = Yap_MkFunctor(Yap_LookupAtom(func), 1);
return Yap_MkApplTerm(functor, 1, &list);
}
}
static Term get_polygon(char *func){
uint32 r;
int i;
Functor functor;
Term *c_list;
Term list;
/* read the number of rings */
readswap4(&r);
/* space for rings */
c_list = (Term *) calloc(sizeof(Term),r);
for ( i = 0; i < r; i++ ) {
c_list[i] = get_linestring(NULL);
}
list = MkAtomTerm(Yap_LookupAtom("[]"));
for (i = r - 1; i >= 0; i--) {
list = MkPairTerm(c_list[i],list);
}
if(func == NULL)
return list;
else{
functor = Yap_MkFunctor(Yap_LookupAtom("polygon"), 1);
return Yap_MkApplTerm(functor, 1, &list);
}
}
static Term get_geometry(uint32 type){
switch(type) {
case WKBPOINT:
return get_point("point");
case WKBLINESTRING:
return get_linestring("linestring");
case WKBPOLYGON:
return get_polygon("polygon");
case WKBMULTIPOINT:
{
byte b;
uint32 n, u;
int i;
Functor functor;
Term *c_list;
Term list;
/* read the number of points */
readswap4(&n);
/* space for points */
c_list = (Term *) calloc(sizeof(Term),n);
for ( i = 0; i < n; i++ ) {
/* read (and ignore) the byteorder and type */
b = get_inbyteorder();
u = get_wkbType();
c_list[i] = get_point(NULL);
}
list = MkAtomTerm(Yap_LookupAtom("[]"));
for (i = n - 1; i >= 0; i--) {
list = MkPairTerm(c_list[i],list);
}
functor = Yap_MkFunctor(Yap_LookupAtom("multipoint"), 1);
return Yap_MkApplTerm(functor, 1, &list);
}
case WKBMULTILINESTRING:
{
byte b;
uint32 n, u;
int i;
Functor functor;
Term *c_list;
Term list;
/* read the number of polygons */
readswap4(&n);
/* space for polygons*/
c_list = (Term *) calloc(sizeof(Term),n);
for ( i = 0; i < n; i++ ) {
/* read (and ignore) the byteorder and type */
b = get_inbyteorder();
u = get_wkbType();
c_list[i] = get_linestring(NULL);
}
list = MkAtomTerm(Yap_LookupAtom("[]"));
for (i = n - 1; i >= 0; i--) {
list = MkPairTerm(c_list[i],list);
}
functor = Yap_MkFunctor(Yap_LookupAtom("multilinestring"), 1);
return Yap_MkApplTerm(functor, 1, &list);
}
case WKBMULTIPOLYGON:
{
byte b;
uint32 n, u;
int i;
Functor functor;
Term *c_list;
Term list;
/* read the number of polygons */
readswap4(&n);
/* space for polygons*/
c_list = (Term *) calloc(sizeof(Term),n);
for ( i = 0; i < n; i++ ) {
/* read (and ignore) the byteorder and type */
b = get_inbyteorder();
u = get_wkbType();
c_list[i] = get_polygon(NULL);
}
list = MkAtomTerm(Yap_LookupAtom("[]"));
for (i = n - 1; i >= 0; i--) {
list = MkPairTerm(c_list[i],list);
}
functor = Yap_MkFunctor(Yap_LookupAtom("multipolygon"), 1);
return Yap_MkApplTerm(functor, 1, &list);
}
case WKBGEOMETRYCOLLECTION:
{
byte b;
uint32 n;
int i;
Functor functor;
Term *c_list;
Term list;
/* read the number of geometries */
readswap4(&n);
/* space for geometries*/
c_list = (Term *) calloc(sizeof(Term),n);
for ( i = 0; i < n; i++ ) {
b = get_inbyteorder();
c_list[i] = get_geometry(get_wkbType());
}
list = MkAtomTerm(Yap_LookupAtom("[]"));
for (i = n - 1; i >= 0; i--) {
list = MkPairTerm(c_list[i],list);
}
functor = Yap_MkFunctor(Yap_LookupAtom("geometrycollection"), 1);
return Yap_MkApplTerm(functor, 1, &list);
}
}
return MkAtomTerm(Yap_LookupAtom("[]"));
}
#endif /*MYDDAS_MYSQL*/

6
packages/MYDDAS/myddas_wkb2prolog.h Normal file
View File

@ -0,0 +1,6 @@
#ifndef MYDDAS_WKB2PROLOG_H_
# define MYDDAS_WKB2PROLOG_H_
Term wkb2prolog(char *wkb) ;
#endif /* !MYDDAS_WKB2PROLOG_H_ */

14
packages/ProbLog/Makefile.in Normal file
View File

@ -0,0 +1,14 @@
default:
@(cd simplecudd; \
echo Making simplecudd...; \
make)
pwd
cp simplecudd/ProblogBDD .
clean:
@(cd simplecudd; \
echo Cleaning simplecudd...; \
make clean; \
cd ..)
rm -rf ProblogBDD output queries

7
packages/ProbLog/README Normal file
View File

@ -0,0 +1,7 @@
To compile ProbLog call
make
To clean the directory call
make clean
The make file will recursively call the make file of SimpleCudd and Cudd.
And it will finally copy the binary executable ProblogBDD to the main directory.

86
packages/ProbLog/examples/graph.pl Normal file
View File

@ -0,0 +1,86 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ProbLog program describing a probabilistic graph
% (running example from ProbLog presentations)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module('../problog').
%%%%
% background knowledge
%%%%
% definition of acyclic path using list of visited nodes
path(X,Y) :- path(X,Y,[X],_).
path(X,X,A,A).
path(X,Y,A,R) :-
X\==Y,
edge(X,Z),
absent(Z,A),
path(Z,Y,[Z|A],R).
% using directed edges in both directions
edge(X,Y) :- dir_edge(Y,X).
edge(X,Y) :- dir_edge(X,Y).
% checking whether node hasn't been visited before
absent(_,[]).
absent(X,[Y|Z]):-X \= Y, absent(X,Z).
%%%%
% probabilistic facts
%%%%
0.9::dir_edge(1,2).
0.8::dir_edge(2,3).
0.6::dir_edge(3,4).
0.7::dir_edge(1,6).
0.5::dir_edge(2,6).
0.4::dir_edge(6,5).
0.7::dir_edge(5,3).
0.2::dir_edge(5,4).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% example queries about path(1,4)
%
%%% explanation probability (and facts involved)
% ?- problog_max(path(1,4),Prob,FactsUsed).
% FactsUsed = [dir_edge(1,2),dir_edge(2,3),dir_edge(3,4)],
% Prob = 0.432 ?
% yes
%%% success probability
% ?- problog_exact(path(1,4),Prob,Status).
% 8 proofs
% Prob = 0.53864,
% Status = ok ?
% yes
%%% lower bound using 4 best proofs
% ?- problog_kbest(path(1,4),4,Prob,Status).
% 4 proofs
% Prob = 0.517344,
% Status = ok ?
% yes
%%% approximation using monte carlo, to reach 95%-confidence interval width 0.01
% ?- problog_montecarlo(path(1,4),0.01,Prob).
% Prob = 0.537525 ?
% yes
%%% upper and lower bound using iterative deepening, final interval width 0.01
% ?- problog_delta(path(1,4),0.01,Bound_low,Bound_up,Status).
% Bound_low = 0.5354096,
% Bound_up = 0.53864,
% Status = ok ?
% yes
%%% upper and lower bound obtained cutting the sld tree at probability 0.1 for each branch
% ?- problog_threshold(path(1,4),0.1,Bound_low,Bound_up,Status).
% 4 proofs
% Bound_low = 0.517344,
% Bound_up = 0.563728,
% Status = ok ?
% yes
%%% lower bound obtained cutting the sld tree at probability 0.2 for each branch
% ?- problog_low(path(1,4),0.2,Bound_low,Status).
% 1 proofs
% Bound_low = 0.432,
% Status = ok ?
% yes
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

96
packages/ProbLog/examples/learn_graph.pl Normal file
View File

@ -0,0 +1,96 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ProbLog program describing a probabilistic graph
% (running example from ProbLog presentations)
%
% example for parameter learning with LeProbLog
%
% training and test examples are included at the end of the file
%
% query ?- do_learning(20).
% will run 20 iterations of learning with default settings
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module('../learning').
%%%%
% background knowledge
%%%%
% definition of acyclic path using list of visited nodes
path(X,Y) :- path(X,Y,[X],_).
path(X,X,A,A).
path(X,Y,A,R) :-
X\==Y,
edge(X,Z),
absent(Z,A),
path(Z,Y,[Z|A],R).
% using directed edges in both directions
edge(X,Y) :- dir_edge(Y,X).
edge(X,Y) :- dir_edge(X,Y).
% checking whether node hasn't been visited before
absent(_,[]).
absent(X,[Y|Z]):-X \= Y, absent(X,Z).
%%%%
% probabilistic facts
% - probability represented by t/1 term means learnable parameter
% - argument of t/1 is real value (used to compare against in evaluation when known), use t(_) if unknown
%%%%
t(0.9)::dir_edge(1,2).
t(0.8)::dir_edge(2,3).
t(0.6)::dir_edge(3,4).
t(0.7)::dir_edge(1,6).
t(0.5)::dir_edge(2,6).
t(0.4)::dir_edge(6,5).
t(0.7)::dir_edge(5,3).
t(0.2)::dir_edge(5,4).
%%%%%%%%%%%%%%
% training examples of form example(ID,Query,DesiredProbability)
%%%%%%%%%%%%%%
example(1,path(1,2),0.94).
example(2,path(1,3),0.81).
example(3,path(1,4),0.54).
example(4,path(1,5),0.70).
example(5,path(1,6),0.87).
example(6,path(2,3),0.85).
example(7,path(2,4),0.57).
example(8,path(2,5),0.72).
example(9,path(2,6),0.86).
example(10,path(3,4),0.66).
example(11,path(3,5),0.80).
example(12,path(3,6),0.75).
example(13,path(4,5),0.57).
example(14,path(4,6),0.51).
example(15,path(5,6),0.69).
% some examples for learning from proofs:
example(16,(dir_edge(2,3),dir_edge(2,6),dir_edge(6,5),dir_edge(5,4)),0.032).
example(17,(dir_edge(1,6),dir_edge(2,6),dir_edge(2,3),dir_edge(3,4)),0.168).
example(18,(dir_edge(5,3),dir_edge(5,4)),0.14).
example(19,(dir_edge(2,6),dir_edge(6,5)),0.2).
example(20,(dir_edge(1,2),dir_edge(2,3),dir_edge(3,4)),0.432).
%%%%%%%%%%%%%%
% test examples of form test_example(ID,Query,DesiredProbability)
% note: ID namespace is shared with training example IDs
%%%%%%%%%%%%%%
test_example(21,path(2,1),0.94).
test_example(22,path(3,1),0.81).
test_example(23,path(4,1),0.54).
test_example(24,path(5,1),0.70).
test_example(25,path(6,1),0.87).
test_example(26,path(3,2),0.85).
test_example(27,path(4,2),0.57).
test_example(28,path(5,2),0.72).
test_example(29,path(6,2),0.86).
test_example(30,path(4,3),0.66).
test_example(31,path(5,3),0.80).
test_example(32,path(6,3),0.75).
test_example(33,path(5,4),0.57).
test_example(34,path(6,4),0.51).
test_example(35,path(6,5),0.69).

1147
packages/ProbLog/learning.yap Normal file
View File

File diff suppressed because it is too large Load Diff

311
packages/ProbLog/learning/logger.yap Normal file
View File

@ -0,0 +1,311 @@
%%% -*- Mode: Prolog; -*-
:- module(logger,[logger_define_variable/2,
logger_define_variables/2,
logger_set_filename/1,
logger_set_delimiter/1,
logger_set_variable/2,
logger_set_variable_again/2,
logger_get_variable/2,
logger_start_timer/1,
logger_stop_timer/1,
logger_write_data/0,
logger_write_header/0]).
:- use_module(library(system),[datime/1,mktime/2]).
:- use_module(library(lists),[append/3,member/2]).
:- yap_flag(unknown,error).
:- style_check(single_var).
:- bb_put(logger_filename,'out.dat').
:- bb_put(logger_delimiter,';').
:- bb_put(logger_variables,[]).
%========================================================================
%= Defines a new variable, possible types are: int, float and time
%=
%= +Name, +Type
%========================================================================
logger_define_variable(Name,int) :-
!,
is_variable_already_defined(Name),
bb_delete(logger_variables,OldVariables),
append(OldVariables,[(Name,int)],NewVariables),
bb_put(logger_variables,NewVariables),
atom_concat(logger_data_,Name,Key),
bb_put(Key,null).
logger_define_variable(Name,float) :-
!,
is_variable_already_defined(Name),
bb_delete(logger_variables,OldVariables),
append(OldVariables,[(Name,float)],NewVariables),
bb_put(logger_variables,NewVariables),
atom_concat(logger_data_,Name,Key),
bb_put(Key,null).
logger_define_variable(Name,time) :-
!,
is_variable_already_defined(Name),
bb_delete(logger_variables,OldVariables),
append(OldVariables,[(Name,time)],NewVariables),
bb_put(logger_variables,NewVariables),
atom_concat(logger_data_,Name,Key),
atom_concat(logger_start_time_,Name,Key2),
bb_put(Key,null),
bb_put(Key2,null).
logger_define_variable(Name,Unknown) :-
is_variable_already_defined(Name),
write('logger_define_variable, unknown type '),
write(Unknown),
write(' for variable '),
write(Name),
nl,
fail.
is_variable_already_defined(Name) :-
bb_get(logger_variables,Variables),
member((Name,_),Variables),!,
write('logger_define_variable, Variable '),
write(Name),
write(' is already defined!\n'),
fail;
true.
%========================================================================
%=
%=
%= +ListOfNames, +Type
%========================================================================
logger_define_variables([],_).
logger_define_variables([H|T],Type) :-
logger_define_variable(H,Type),
logger_define_variables(T,Type).
%========================================================================
%= Set the filename, to which the output should be appended
%=
%= +Name
%========================================================================
logger_set_filename(Name) :-
bb_put(logger_filename,Name).
%========================================================================
%= Set the delimiter for the fields
%=
%= +Delimiter
%========================================================================
logger_set_delimiter(Delimiter) :-
bb_put(logger_delimiter,Delimiter).
%========================================================================
%= Set the value of the variable name. If the value is already set or
%= if the variable does not exists, an error will be displayed and the
%= Prolog will be halted.
%=
%= +Name, +Value
%========================================================================
logger_set_variable(Name,Value) :-
atom_concat(logger_data_,Name,Key),
(
bb_get(Key,null)
->
(
bb_put(Key,Value)
);(
bb_get(Key,_)
->
(
write('logger_set_variable, Variable '),
write(Name),
write(' is already set'),
nl,
fail
) ; (
write('logger_set_variable, unknown variable '),
write(Name),
nl,
fail
)
)
),!.
%========================================================================
%= Set the value of the variable name. If the value is already set or
%= the old value is overwritten. If the variable does not exists, an
%= error will be displayed and the Prolog will be halted.
%=
%= +Name, +Value
%========================================================================
logger_set_variable_again(Name,Value) :-
atom_concat(logger_data_,Name,Key),
(
bb_get(Key,_)
->
(
bb_put(Key,Value)
);(
write('logger_set_variable, unknown variable '),
write(Name),
nl,
fail
)
),!.
logger_variable_is_set(Name) :-
atom_concat(logger_data_,Name,Key),
bb_get(Key,X),
X \= null.
%========================================================================
%= Get the value of the variable name. If the value is not yet set or
%= if the variable does not exists, an error will be displayed and the
%= Prolog will be halted.
%=
%= +Name, +Value
%========================================================================
logger_get_variable(Name,Value) :-
atom_concat(logger_data_,Name,Key),
(
bb_get(Key,null)
->
(
write('logger_get_variable, Variable '),
write(Name),
write(' is not yet set'),
nl,
fail
);(
bb_get(Key,Value)
;
(
write('logger_set_variable, unknown variable '),
write(Name),
nl,
fail
)
)
),!.
%========================================================================
%=
%=
%= +Name
%========================================================================
logger_start_timer(Name) :-
atom_concat(logger_start_time_,Name,Key),
(
bb_get(Key,null)
->
(
statistics(walltime,[StartTime,_]),
bb_put(Key,StartTime)
);(
bb_get(Key,_)
->
(
write('logger_start_timer, timer '),
write(Name),
write(' is already started'),
nl,
fail
);(
write('logger_start_timer, timer '),
write(Name),
write(' is not defined'),
nl,
fail
)
)
),!.
logger_stop_timer(Name) :-
atom_concat(logger_start_time_,Name,Key),
bb_delete(Key,StartTime),
statistics(walltime,[StopTime,_]),
bb_put(Key,null),
Duration is StopTime-StartTime,
(
logger_variable_is_set(Name)
->
(
logger_get_variable(Name,OldDuration),
NewDuration is Duration+OldDuration,
logger_set_variable_again(Name,NewDuration)
); logger_set_variable(Name,Duration)
),!.
%========================================================================
%= write a new line to the log file, which contains all the
%= values of the variables. afterwards, reset all variables to null.
%=
%========================================================================
logger_write_data :-
bb_get(logger_filename,FName),
bb_get(logger_variables,Variables),
open(FName,'append',Handle),
logger_write_data_intern(Variables,Handle),
close(Handle),
% reset variables
findall(_,(member((Name,_),Variables),atom_concat(logger_data_,Name,Key),bb_put(Key,null)),_),
findall(_,(member((Name,time),Variables),atom_concat(logger_start_time_,Name,Key2),bb_put(Key2,null)),_).
logger_write_data_intern([],_).
logger_write_data_intern([(Name,_Type)],Handle) :-
variablevalue_with_nullcheck(Name,Value),
write(Handle,Value),
write(Handle,'\n').
logger_write_data_intern([(Name,_Type),Next|T],Handle) :-
variablevalue_with_nullcheck(Name,Value),
bb_get(logger_delimiter,D),
write(Handle,Value),
write(Handle,D),
logger_write_data_intern([Next|T],Handle).
variablevalue_with_nullcheck(Name,Result) :-
atom_concat(logger_data_,Name,Key),
bb_get(Key,Value),
(
Value=null
->
Result = '' ;
Result=Value
).
%========================================================================
%=
%=
%=
%========================================================================
logger_write_header :-
bb_get(logger_filename,FName),
bb_get(logger_variables,Variables),
open(FName,'append',Handle),
write(Handle,'# '),
logger_write_header_intern(Variables,Handle),
write(Handle,'\n'),
close(Handle).
logger_write_header_intern([],_).
logger_write_header_intern([(Name,_Type)],Handle) :-
write(Handle,Name).
logger_write_header_intern([(Name,_Type),Next|T],Handle) :-
bb_get(logger_delimiter,D),
write(Handle,Name),
write(Handle,D),
logger_write_header_intern([Next|T],Handle).

958
packages/ProbLog/problog.yap Normal file
View File

@ -0,0 +1,958 @@
%%% -*- Mode: Prolog; -*-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ProbLog inference
%
% assumes probabilistic facts as Prob::Fact and clauses in normal Prolog format
%
% provides following inference modes (16/12/2008):
% - approximation with interval width Delta (IJCAI07): problog_delta(+Query,+Delta,-Low,-High,-Status)
% - bounds based on single probability threshold: problog_threshold(+Query,+Threshold,-Low,-High,-Status)
% - as above, but lower bound only: problog_low(+Query,+Threshold,-Low,-Status)
% - lower bound based on K most likely proofs: problog_kbest(+Query,+K,-Low,-Status)
% - explanation probability (ECML07): problog_max(+Query,-Prob,-FactsUsed)
% - exact probability: problog_exact(+Query,-Prob,-Status)
% - sampling: problog_montecarlo(+Query,+Delta,-Prob)
%
%
% angelika.kimmig@cs.kuleuven.be
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(problog, [problog_delta/5,
problog_threshold/5,
problog_low/4,
problog_kbest/4,
problog_kbest_save/6,
problog_max/3,
problog_exact/3,
problog_montecarlo/3,
get_fact_probability/2,
set_fact_probability/2,
get_fact/2,
tunable_fact/2,
export_facts/1,
problog_help/0,
problog_dir/1,
set_problog_flag/2,
problog_flag/2,
problog_flags/0]).
:- style_check(all).
:- yap_flag(unknown,error).
% problog related modules
:- use_module('problog/flags',[set_problog_flag/2,
problog_flag/2,
problog_flags/0]).
:- use_module('problog/print', [print_sep_line/0,
print_inference/2]).
:- use_module('problog/tptree',[init_ptree/1,
delete_ptree/1,
insert_ptree/2,
count_ptree/2,
prune_check_ptree/2,
merge_ptree/3,
bdd_ptree_map/4,
bdd_ptree/3]).
% general yap modules
:- ensure_loaded(library(lists)).
:- ensure_loaded(library(terms)).
:- ensure_loaded(library(random)).
:- ensure_loaded(library(system)).
:- ensure_loaded(library(rbtrees)).
% op attaching probabilities to facts
:- op( 550, yfx, :: ).
%%%%%%%%%%%%%%%%%%%%%%%%
% control predicates on various levels
%%%%%%%%%%%%%%%%%%%%%%%%
% global over all inference methods, internal use only
:- dynamic problog_predicate/2.
% global over all inference methods, exported
:- dynamic tunable_fact/2.
:- dynamic problog_dir/1.
% global, manipulated via problog_control/2
:- dynamic up/0.
:- dynamic limit/0.
:- dynamic mc/0.
:- dynamic remember/0.
% local to problog_delta
:- dynamic low/2.
:- dynamic up/2.
:- dynamic stopDiff/1.
% local to problog_kbest
:- dynamic current_kbest/3.
% local to problog_max
:- dynamic max_probability/1.
:- dynamic max_proof/1.
% local to problog_montecarlo
:- dynamic mc_prob/1.
% directory where ProblogBDD executable is located
% automatically set during loading -- assumes it is in same place as this file (problog.yap)
:- getcwd(PD),retractall(problog_dir(_)),assert(problog_dir(PD)).
%%%%%%%%%%%%%%%%%%%%%%%%
% help
%%%%%%%%%%%%%%%%%%%%%%%%
problog_help :-
format('~2nProbLog inference currently offers the following inference methods:~n',[]),
show_inference,
format('~2nThe following global parameters are available:~n',[]),
problog_flags,
print_sep_line,
format('~n use problog_help/0 to display this information~n',[]),
format('~n use problog_flags/0 to display current parameter values~2n',[]),
print_sep_line,
nl,
flush_output.
show_inference :-
format('~n',[]),
print_sep_line,
print_inference(call,description),
print_sep_line,
print_inference('problog_delta(+Query,+Delta,-Low,-High,-Status)','approximation with interval width Delta (IJCAI07)'),
print_inference('problog_threshold(+Query,+Threshold,-Low,-High,-Status)','bounds based on single probability threshold'),
print_inference('problog_low(+Query,+Threshold,-Low,-Status)','lower bound based on single probability threshold'),
print_inference('problog_kbest(+Query,+K,-Low,-Status)','lower bound based on K most likely proofs'),
print_inference('problog_max(+Query,-Prob,-FactsUsed)','explanation probability (ECML07)'),
print_inference('problog_exact(+Query,-Prob,-Status)','exact probability'),
print_inference('problog_montecarlo(+Query,+Delta,-Prob)','sampling with 95\%-confidence-interval-width Delta'),
print_sep_line.
%%%%%%%%%%%%%%%%%%%%%%%%
% initialization of global parameters
%%%%%%%%%%%%%%%%%%%%%%%%
init_global_params :-
set_problog_flag(bdd_time,60),
set_problog_flag(first_threshold,0.1),
L is 10**(-30),
set_problog_flag(last_threshold,L),
set_problog_flag(id_stepsize,0.5),
set_problog_flag(prunecheck,off),
set_problog_flag(maxsteps,1000),
set_problog_flag(mc_batchsize,1000),
set_problog_flag(mc_logfile,'log.txt'),
set_problog_flag(bdd_file,example_bdd),
set_problog_flag(dir,output),
set_problog_flag(save_bdd,false),
% problog_flags,
print_sep_line,
format('~n use problog_help/0 for information~n',[]),
format('~n use problog_flags/0 to display current parameter values~2n',[]),
print_sep_line,
nl,
flush_output.
% parameter initialization to be called after returning to user's directory:
:- initialization(init_global_params).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% internal control flags
% if on
% - up: collect stopped derivations to build upper bound
% - limit: iterative deepening reached limit -> should go to next level
% - mc: using problog_montecarlo, i.e. proving with current sample instead of full program
% - remember: save BDD files containing script, params and mapping
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_control(on,X) :-
call(X),!.
problog_control(on,X) :-
assert(X).
problog_control(off,X) :-
retractall(X).
problog_control(check,X) :-
call(X).
:- problog_control(off,up).
:- problog_control(off,mc).
:- problog_control(off,limit).
:- problog_control(off,remember).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% nice user syntax Prob::Fact
% automatic translation to internal hardware access format
%
% probabilities =1 are dropped -> normal Prolog fact
%
% internal fact representation
% - prefixes predicate name with problog_
% - adds unique ID as first argument
% - adds logarithm of probability as last argument
% - keeps original arguments in between
%
% for each predicate appearing as probabilistic fact, wrapper clause is introduced:
% - head is most general instance of original fact
% - body is corresponding version of internal fact plus call to add_to_proof/2 to update current state during proving
% example: edge(A,B) :- problog_edge(ID,A,B,LogProb), add_to_proof(ID,LogProb).
%
% dynamic predicate problog_predicate(Name,Arity) keeps track of predicates that already have wrapper clause
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
user:term_expansion(_P::( _Goal :- _Body ), _Error) :-
throw(error('we do not support this (yet?)!')).
user:term_expansion(P::Goal,Goal) :-
P \= t(_),
P =:= 1,
!.
user:term_expansion(P::Goal, problog:ProbFact) :-
functor(Goal, Name, Arity),
atomic_concat([problog_,Name],ProblogName),
Goal =.. [Name|Args],
append(Args,[LProb],L1),
probclause_id(IDName),
term_variables(Goal,GVars),
(GVars=[] -> ID=IDName; ID=..[IDName|GVars]),
ProbFact =.. [ProblogName,ID|L1],
(P = t(TrueProb) ->
assert(tunable_fact(ID,TrueProb)),
LProb is log(0.5)
;
LProb is log(P)
),
problog_predicate(Name, Arity, ProblogName).
% introduce wrapper clause if predicate seen first time
problog_predicate(Name, Arity, _) :-
problog_predicate(Name, Arity), !.
problog_predicate(Name, Arity, ProblogName) :-
functor(OriginalGoal, Name, Arity),
OriginalGoal =.. [_|Args],
append(Args,[Prob],L1),
ProbFact =.. [ProblogName,ID|L1],
prolog_load_context(module,Mod),
assert((Mod:OriginalGoal :- ProbFact, add_to_proof(ID,Prob))),
assert(problog_predicate(Name, Arity)),
ArityPlus2 is Arity+2,
dynamic(problog:ProblogName/ArityPlus2).
% generate next global identifier
probclause_id(ID) :-
nb_getval(probclause_counter,ID), !,
C1 is ID+1,
nb_setval(probclause_counter,C1), !.
probclause_id(0) :-
nb_setval(probclause_counter,1).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% access/update the probability of ID's fact
% hardware-access version: naively scan all problog-predicates
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
get_fact_probability(ID,Prob) :-
get_internal_fact(ID,ProblogTerm,_ProblogName,ProblogArity),
arg(ProblogArity,ProblogTerm,Log),
Prob is exp(Log).
set_fact_probability(ID,Prob) :-
get_internal_fact(ID,ProblogTerm,ProblogName,ProblogArity),
retract(ProblogTerm),
ProblogTerm =.. [ProblogName|ProblogTermArgs],
nth(ProblogArity,ProblogTermArgs,_,KeepArgs),
NewLogProb is log(Prob),
nth(ProblogArity,NewProblogTermArgs,NewLogProb,KeepArgs),
NewProblogTerm =.. [ProblogName|NewProblogTermArgs],
assert(NewProblogTerm).
get_internal_fact(ID,ProblogTerm,ProblogName,ProblogArity) :-
problog_predicate(Name,Arity),
atomic_concat([problog_,Name],ProblogName),
ProblogArity is Arity+2,
functor(ProblogTerm,ProblogName,ProblogArity),
arg(1,ProblogTerm,ID),
call(ProblogTerm).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% writing those facts with learnable parameters to File
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
export_facts(File) :-
tell(File),
export_facts,
flush_output,
told.
export_facts :-
tunable_fact(ID,_),
once(write_tunable_fact(ID)),
fail.
export_facts.
write_tunable_fact(ID) :-
get_internal_fact(ID,ProblogTerm,ProblogName,ProblogArity),
ProblogTerm =.. [_Functor,ID|Args],
atomic_concat('problog_',OutsideFunctor,ProblogName),
Last is ProblogArity-1,
nth(Last,Args,LogProb,OutsideArgs),
OutsideTerm =.. [OutsideFunctor|OutsideArgs],
Prob is exp(LogProb),
format('~w :: ~q.~n',[Prob,OutsideTerm]).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% recover fact for given id
% list version not exported (yet?)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
get_fact(ID,OutsideTerm) :-
get_internal_fact(ID,ProblogTerm,ProblogName,ProblogArity),
ProblogTerm =.. [_Functor,ID|Args],
atomic_concat('problog_',OutsideFunctor,ProblogName),
Last is ProblogArity-1,
nth(Last,Args,_LogProb,OutsideArgs),
OutsideTerm =.. [OutsideFunctor|OutsideArgs].
get_fact_list([],[]).
get_fact_list([ID|IDs],[Fact|Facts]) :-
get_fact(ID,Fact),
get_fact_list(IDs,Facts).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ProbLog inference, core methods
%
% state of proving saved in two backtrackable global variables
% - problog_current_proof holds list of IDs of clauses used
% - problog_probability holds the sum of their log probabilities
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% called "inside" probabilistic facts to update current state of proving:
% if number of steps exceeded, fail
% if fact used before, succeed and keep status as is
% if not prunable, calculate probability and
% if threshold exceeded, add stopped derivation to upper bound and fail
% else update state and succeed
add_to_proof(ID,Prob) :-
montecarlo_check(ID),
b_getval(problog_steps,MaxSteps),
b_getval(problog_probability, CurrentP),
nb_getval(problog_threshold, CurrentThreshold),
b_getval(problog_current_proof, IDs),
( MaxSteps =< 0 ->
fail
;
( memberchk(ID, IDs) ->
true
;
\+ prune_check([ID|IDs],1),
multiply_probabilities(CurrentP, Prob, NProb),
( NProb < CurrentThreshold ->
upper_bound([ID|IDs]),
fail
;
b_setval(problog_probability, NProb),
b_setval(problog_current_proof, [ID|IDs])
)
),
Steps is MaxSteps-1,
b_setval(problog_steps,Steps)
).
% if in monte carlo mode, check array to see if fact can be used
montecarlo_check(ID) :-
(
problog_control(check,mc)
->
(
array_element(mc_sample,ID,V),
(
V == 1 -> true
;
V == 2 -> fail
;
new_sample(ID)
)
)
;
true
).
new_sample(ID) :-
get_fact_probability(ID,Prob),
random(R),
R<Prob,
!,
update_array(mc_sample,ID,1).
new_sample(ID) :-
update_array(mc_sample,ID,2),
fail.
% if threshold reached, remember this by setting limit to on, then
% if up is on, store stopped derivation in second trie
%
% List always length>=1 -> don't need []=true-case for tries
upper_bound(List) :-
problog_control(on,limit),
problog_control(check,up),
reverse(List,R),
(prune_check(R,2) -> true; insert_ptree(R,2)).
multiply_probabilities(CurrentLogP, LogProb, NLogProb) :-
NLogProb is CurrentLogP+LogProb.
% this is called by all inference methods before the actual ProbLog goal
% to set up environment for proving
init_problog(Threshold) :-
LT is log(Threshold),
b_setval(problog_probability, 0.0),
b_setval(problog_current_proof, []),
nb_setval(problog_threshold, LT),
problog_flag(maxsteps,MaxS),
b_setval(problog_steps, MaxS),
problog_control(off,limit).
% idea: proofs that are refinements of known proof can be pruned as they don't add probability mass
% note that current ptree implementation doesn't provide the check as there's no efficient method known so far...
prune_check(Proof,TreeID) :-
problog_flag(prunecheck,on),
prune_check_ptree(Proof,TreeID).
% to call a ProbLog goal, patch all subgoals with the user's module context
% (as logical part is there, but probabilistic part in problog)
problog_call(Goal) :-
yap_flag(typein_module,Module),
put_module(Goal,Module,ModGoal),
call(ModGoal).
put_module((Mod:Goal,Rest),Module,(Mod:Goal,Transformed)) :-
!,
put_module(Rest,Module,Transformed).
put_module((Goal,Rest),Module,(Module:Goal,Transformed)) :-
!,
put_module(Rest,Module,Transformed).
put_module((Mod:Goal),_Module,(Mod:Goal)) :-
!.
put_module(Goal,Module,Module:Goal).
% end of core
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% evaluating a DNF given as trie using BDD
% input: ID of trie to be used
% output: probability and status (to catch potential failures/timeouts from outside)
%
% with internal BDD timeout (set using problog flag bdd_time)
%
% bdd_ptree/3 constructs files for ProblogBDD from the trie
%
% if calling ProblogBDD doesn't exit successfully, status will be timeout
%
% writes number of proofs in trie and BDD time to standard user output
%
% if remember is on, input files for ProblogBDD will be saved
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
eval_dnf(ID,Prob,Status) :-
((ID = 1, problog_flag(save_bdd,true)) -> problog_control(on,remember); problog_control(off,remember)),
count_ptree(ID,NX),
format(user,'~w proofs~n',[NX]),
problog_flag(dir,DirFlag),
problog_flag(bdd_file,BDDFileFlag),
atomic_concat([DirFlag,BDDFileFlag],BDDFile),
problog_flag(bdd_par_file,BDDParFileFlag),
atomic_concat([DirFlag,BDDParFileFlag],BDDParFile),
(problog_control(check,remember) ->
bdd_ptree_map(ID,BDDFile,BDDParFile,Mapping),
atomic_concat([DirFlag,'save_map'],MapFile),
tell(MapFile),
format('mapping(~q).~n',[Mapping]),
flush_output,
told
;
bdd_ptree(ID,BDDFile,BDDParFile)
),
problog_flag(bdd_time,BDDTime),
problog_flag(bdd_result,ResultFileFlag),
atomic_concat([DirFlag,ResultFileFlag],ResultFile),
problog_dir(PD),
atomic_concat([PD,'/ProblogBDD -l ',BDDFile,' -i ',BDDParFile,' -m p -t ', BDDTime,' > ', ResultFile],Command),
statistics(walltime,_),
shell(Command,Return),
(
Return =\= 0
->
Status = timeout
;
(
statistics(walltime,[_,E3]),
format(user,'~w ms BDD processing~n',[E3]),
see(ResultFile),
read(probability(Prob)),
seen,
delete_file(ResultFile),
Status = ok
)
),
(problog_control(check,remember) ->
atomic_concat([DirFlag,'save_script'],SaveBDDFile),
rename_file(BDDFile,SaveBDDFile),
atomic_concat([DirFlag,'save_params'],SaveBDDParFile),
rename_file(BDDParFile,SaveBDDParFile)
;
true
),
problog_control(off,remember).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% different inference methods
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% approximate inference: bounds based on single probability threshold
% problog_threshold(+Goal,+Threshold,-LowerBound,-UpperBound,-Status)
%
% use backtracking over problog_call to get all solutions
%
% trie 1 collects proofs, trie 2 collects stopped derivations, trie 3 is used to unit them for the upper bound
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_threshold(Goal, Threshold, _, _, _) :-
problog_control(on,up),
init_problog_threshold(Threshold),
problog_call(Goal),
add_solution,
fail.
problog_threshold(_, _, LP, UP, Status) :-
compute_bounds(LP, UP, Status).
init_problog_threshold(Threshold) :-
init_ptree(1),
init_ptree(2),
init_problog(Threshold).
add_solution :-
b_getval(problog_current_proof, IDs),
(IDs == [] -> R = true ; reverse(IDs,R)),
insert_ptree(R,1).
compute_bounds(LP, UP, Status) :-
eval_dnf(1,LP,StatusLow),
(StatusLow \== ok ->
Status = StatusLow
;
merge_ptree(1,2,3),
eval_dnf(3,UP,Status)),
delete_ptree(1),
delete_ptree(2),
delete_ptree(3).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% approximate inference: lower bound based on all proofs above probability threshold
% problog_low(+Goal,+Threshold,-LowerBound,-Status)
%
% same as problog_threshold/5, but lower bound only (no stopped derivations stored)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_low(Goal, Threshold, _, _) :-
problog_control(off,up),
init_problog_low(Threshold),
problog_call(Goal),
add_solution,
fail.
problog_low(_, _, LP, Status) :-
eval_dnf(1,LP,Status),
delete_ptree(1).
init_problog_low(Threshold) :-
init_ptree(1),
init_problog(Threshold).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% approximate inference: bounds by iterative deepening up to interval width Delta
% problog_delta(+Goal,+Delta,-LowerBound,-UpperBound,-Status)
%
% wraps iterative deepening around problog_threshold, i.e.
% - starts with threshold given by first_threshold flag
% - if Up-Low >= Delta, multiply threshold by factor given in id_stepsize flag and iterate
% (does not use problog_threshold as trie 1 is kept over entire search)
%
% local dynamic predicates low/2, up/2, stopDiff/1
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_delta(Goal, Delta, Low, Up, Status) :-
problog_control(on,up),
problog_flag(first_threshold,InitT),
init_problog_delta(InitT,Delta),
problog_delta_id(Goal,Status),
delete_ptree(1),
delete_ptree(2),
(retract(low(_,Low)) -> true; true),
(retract(up(_,Up)) -> true; true).
init_problog_delta(Threshold,Delta) :-
retractall(low(_,_)),
retractall(up(_,_)),
retractall(stopDiff(_)),
init_ptree(1),
init_ptree(2),
assert(low(0,0.0)),
assert(up(0,1.0)),
assert(stopDiff(Delta)),
init_problog(Threshold).
problog_delta_id(Goal, _) :-
problog_call(Goal),
add_solution, % reused from problog_threshold
fail.
problog_delta_id(Goal, Status) :-
evaluateStep(Ans,StatusE),
problog_flag(last_threshold_log,Stop),
nb_getval(problog_threshold,Min),
(StatusE \== ok ->
Status = StatusE
;
(
Ans = 1 ->
Status = ok
;
Min =< Stop ->
Status = stopreached
;
problog_control(check,limit) ->
problog_control(off,limit),
problog_flag(id_stepsize_log,Step),
New is Min+Step,
nb_setval(problog_threshold,New),
problog_delta_id(Goal, Status)
;
true
)).
% call the dnf evaluation where needed
evaluateStep(Ans,Status) :- once(evalStep(Ans,Status)).
evalStep(Ans,Status) :-
stopDiff(Delta),
count_ptree(1,NProofs),
count_ptree(2,NCands),
format(user,'~w proofs, ~w stopped derivations~n',[NProofs,NCands]),
flush_output(user),
eval_lower(NProofs,Low,StatusLow),
(StatusLow \== ok ->
Status = StatusLow
;
up(_,OUP),
IntDiff is OUP-Low,
((IntDiff < Delta; IntDiff =:= 0) ->
Up=OUP, StatusUp = ok
;
eval_upper(NCands,Up,StatusUp),
delete_ptree(2),
init_ptree(2),
delete_ptree(3)
),
(StatusUp \== ok ->
Status = StatusUp
;
Diff is Up-Low,
format(user,'difference: ~6f~n',[Diff]),
flush_output(user),
((Diff < Delta; Diff =:= 0) -> Ans = 1; Ans = 0),
Status = ok)).
% no need to re-evaluate if no new proofs found on this level
eval_lower(N,P,ok) :-
low(N,P).
% evaluate if there are proofs
eval_lower(N,P,Status) :-
N > 0,
low(OldN,_),
N \= OldN,
eval_dnf(1,P,Status),
(Status = ok ->
retract(low(_,_)),
assert(low(N,P)),
format(user,'lower bound: ~6f~n',[P]),
flush_output(user)
;
true).
% if no stopped derivations, up=low
eval_upper(0,P,ok) :-
retractall(up(_,_)),
low(N,P),
assert(up(N,P)).
% else merge proofs and stopped derivations to get upper bound
% in case of timeout or other problems, skip and use bound from last level
eval_upper(N,UpP,ok) :-
N > 0,
merge_ptree(1,2,3),
eval_dnf(3,UpP,StatusUp),
(StatusUp = ok ->
retract(up(_,_)),
assert(up(N,UpP))
;
format(user,'~w - continue using old up~n',[StatusUp]),
flush_output(user),
up(_,UpP)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% explanation probability - returns list of facts used or constant 'unprovable' as third argument
% problog_max(+Goal,-Prob,-Facts)
%
% uses iterative deepening with samw parameters as bounding algorithm
% threshold gets adapted whenever better proof is found
%
% uses local dynamic predicates max_probability/1 and max_proof/1
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_max(Goal, Prob, Facts) :-
problog_control(off,up),
problog_flag(first_threshold,InitT),
init_problog_max(InitT),
problog_max_id(Goal, Prob, FactIDs),
( FactIDs == unprovable -> Facts = unprovable;
get_fact_list(FactIDs,Facts)).
init_problog_max(Threshold) :-
retractall(max_probability(_)),
retractall(max_proof(_)),
assert(max_probability(-999999)),
assert(max_proof(unprovable)),
init_problog(Threshold).
update_max :-
b_getval(problog_probability,CurrP),
max_probability(MaxP),
(CurrP =< MaxP ->
fail
;
b_getval(problog_current_proof, IDs),
reverse(IDs,R),
retractall(max_proof(_)),
assert(max_proof(R)),
nb_setval(problog_threshold, CurrP),
retractall(max_probability(_)),
assert(max_probability(CurrP))).
problog_max_id(Goal, _Prob, _Clauses) :-
problog_call(Goal),
update_max,
fail.
problog_max_id(Goal, Prob, Clauses) :-
max_probability(MaxP),
nb_getval(problog_threshold, LT),
problog_flag(last_threshold_log,ToSmall),
((MaxP >= LT ; \+ problog_control(check,limit); LT < ToSmall) ->
max_proof(Clauses),
Prob is exp(MaxP)
;
problog_flag(id_stepsize_log,Step),
NewLT is LT+Step,
nb_setval(problog_threshold, NewLT),
problog_control(off,limit),
problog_max_id(Goal, Prob, Clauses)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% lower bound using k best proofs
% problog_kbest(+Goal,+K,-Prob,-Status)
%
% does iterative deepening search similar to problog_max, but for k(>=1) most likely proofs
% afterwards uses BDD evaluation to calculate probability (also for k=1 -> uniform treatment in learning)
%
% uses dynamic local predicate current_kbest/3 to collect proofs,
% only builds trie at the end (as probabilities of single proofs are important here)
%
% note: >k proofs will be used if the one at position k shares its probability with others,
% as all proofs with that probability will be included
%
% version with _save at the end renames files for ProblogBDD to keep them
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_kbest_save(Goal, K, Prob, Status, BDDFile, ParamFile) :-
problog_kbest(Goal, K, Prob, Status),
( Status=ok ->
problog_flag(bdd_file,InternBDDFlag),
problog_flag(bdd_par_file,InternParFlag),
problog_flag(dir,DirFlag),
atomic_concat([DirFlag,InternBDDFlag],InternBDD),
atomic_concat([DirFlag,InternParFlag],InternPar),
rename_file(InternBDD,BDDFile),
rename_file(InternPar,ParamFile)
;
true).
problog_kbest(Goal, K, Prob, Status) :-
problog_control(off,up),
problog_flag(first_threshold,InitT),
init_problog_kbest(InitT),
problog_kbest_id(Goal, K),
retract(current_kbest(_,ListFound,_NumFound)),
build_prefixtree(ListFound),
eval_dnf(1,Prob,Status),
delete_ptree(1).
init_problog_kbest(Threshold) :-
retractall(current_kbest(_,_,_)),
assert(current_kbest(-999999,[],0)), %(log-threshold,proofs,num_proofs)
init_ptree(1),
init_problog(Threshold).
problog_kbest_id(Goal, K) :-
problog_call(Goal),
update_kbest(K),
fail.
problog_kbest_id(Goal, K) :-
current_kbest(CurrentBorder,_,Found),
nb_getval(problog_threshold, Min),
problog_flag(last_threshold_log,ToSmall),
((Found>=K ; \+ problog_control(check,limit) ; Min < CurrentBorder ; Min < ToSmall) ->
true
;
problog_flag(id_stepsize_log,Step),
NewLT is Min+Step,
nb_setval(problog_threshold, NewLT),
problog_control(off,limit),
problog_kbest_id(Goal, K)).
update_kbest(K) :-
b_getval(problog_probability,NewLogProb),
current_kbest(LogThreshold,_,_),
(NewLogProb>=LogThreshold ->
b_getval(problog_current_proof,RevProof),
reverse(RevProof,Proof),
update_current_kbest(K,NewLogProb,Proof)
;
fail).
update_current_kbest(_,NewLogProb,Cl) :-
current_kbest(_,List,_),
memberchk(NewLogProb-Cl,List),
!.
update_current_kbest(K,NewLogProb,Cl) :-
retract(current_kbest(OldThres,List,Length)),
sorted_insert(NewLogProb-Cl,List,NewList),
NewLength is Length+1,
(NewLength < K ->
assert(current_kbest(OldThres,NewList,NewLength))
;
(NewLength>K ->
First is NewLength-K+1,
cutoff(NewList,NewLength,First,FinalList,FinalLength)
; FinalList=NewList, FinalLength=NewLength),
FinalList=[NewThres-_|_],
nb_setval(problog_threshold,NewThres),
assert(current_kbest(NewThres,FinalList,FinalLength))).
sorted_insert(A,[],[A]).
sorted_insert(A-LA,[B1-LB1|B], [A-LA,B1-LB1|B] ) :-
A =< B1.
sorted_insert(A-LA,[B1-LB1|B], [B1-LB1|C] ) :-
A > B1,
sorted_insert(A-LA,B,C).
% keeps all entries with lowest probability, even if implying a total of more than k
cutoff(List,Len,1,List,Len) :- !.
cutoff([P-L|List],Length,First,[P-L|List],Length) :-
nth(First,[P-L|List],PF-_),
PF=:=P,
!.
cutoff([_|List],Length,First,NewList,NewLength) :-
NextFirst is First-1,
NextLength is Length-1,
cutoff(List,NextLength,NextFirst,NewList,NewLength).
build_prefixtree([]).
build_prefixtree([_-[]|_List]) :-
!,
insert_ptree(true,1).
build_prefixtree([_-L|List]) :-
insert_ptree(L,1),
build_prefixtree(List).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% exact probability
% problog_exact(+Goal,-Prob,-Status)
%
% using all proofs = using all proofs with probability > 0
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_exact(Goal,Prob,Status) :-
problog_low(Goal,0,Prob,Status).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% probability by sampling:
% running another N samples until 95percentCI-width<Delta
% lazy sampling using three-valued array indexed by internal fact IDs
%
% still collects actual proofs found in samples in ptree, though this is no longer used
% by method itself, only to write number to log-file
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_montecarlo(Goal,Delta,Prob) :-
nb_getval(probclause_counter,ID), !,
C is ID+1,
static_array(mc_sample,C,char),
problog_control(off,up),
problog_flag(mc_batchsize,N),
problog_flag(mc_logfile,File1),
problog_flag(dir,Dir),
atomic_concat([Dir,File1],File),
montecarlo(Goal,Delta,N,File),
retract(mc_prob(Prob)).
montecarlo(Goal,Delta,K,File) :-
reset_static_array(mc_sample),
problog_control(on,mc),
open(File,write,Log),
format(Log,'# goal: ~q~n#delta: ~w~n',[Goal,Delta]),
format(Log,'# num_programs prob low high diff time cache_size num_pos~2n',[]),
close(Log),
statistics(walltime,[T1,_]),
init_ptree(1),
format('search for ~q~n',[Goal]),
montecarlo(Goal,Delta,K,0,File,0,T1),
problog_control(off,mc),
delete_ptree(1).
% calculate values after K samples
montecarlo(Goal,Delta,K,SamplesSoFar,File,PositiveSoFar,InitialTime) :-
SamplesNew is SamplesSoFar+1,
SamplesNew mod K =:= 0,
!,
copy_term(Goal,GoalC),
(mc_prove(GoalC) -> Next is PositiveSoFar+1; Next=PositiveSoFar),
Prob is Next/SamplesNew,
Epsilon is 2*sqrt(Prob*(1-Prob)/SamplesNew),
Low is Prob-Epsilon,
High is Prob+Epsilon,
Diff is 2*Epsilon,
statistics(walltime,[T2,_]),
Time is (T2-InitialTime)/1000,
count_ptree(1,CacheSize),
format('~n~w samples~nestimated probability ~w~n95 percent confidence interval [~w,~w]~n',[SamplesNew,Prob,Low,High]),
open(File,append,Log),
format(Log,'~w ~8f ~8f ~8f ~8f ~3f ~w ~w~n',[SamplesNew,Prob,Low,High,Diff,Time,CacheSize,Next]),
close(Log),
((Diff<Delta; Diff =:= 0) -> format('Runtime ~w sec~2n',[Time]),assert(mc_prob(Prob))
;
montecarlo(Goal,Delta,K,SamplesNew,File,Next,InitialTime)).
% continue until next K samples done
montecarlo(Goal,Delta,K,SamplesSoFar,File,PositiveSoFar,InitialTime) :-
SamplesNew is SamplesSoFar+1,
copy_term(Goal,GoalC),
(mc_prove(GoalC) -> Next is PositiveSoFar+1; Next=PositiveSoFar),
montecarlo(Goal,Delta,K,SamplesNew,File,Next,InitialTime).
mc_prove(A) :- !,
(get_some_proof(A) ->
clean_sample
;
clean_sample,fail
).
clean_sample :-
reset_static_array(mc_sample),
fail.
clean_sample.
% find new proof
get_some_proof(Goal) :-
init_problog(0),
problog_call(Goal),
b_getval(problog_current_proof,Used),
(Used == [] -> Proof=true; reverse(Used,Proof)),
insert_ptree(Proof,1).

284
packages/ProbLog/problog/flags.yap Normal file
View File

@ -0,0 +1,284 @@
%%% -*- Mode: Prolog; -*-
:- module(flags, [set_problog_flag/2,
problog_flag/2,
problog_flags/0]).
:- style_check(all).
:- yap_flag(unknown,error).
:- use_module(print, [print_param/4,
print_sep_line/0]).
:- ensure_loaded(library(system)).
:- dynamic bdd_time/1, first_threshold/1, last_threshold/1, id_stepsize/1, prunecheck/1, maxsteps/1, mc_batchsize/1, mc_logfile/1, bdd_file/1, bdd_par_file/1, bdd_result/1, work_dir/1, save_bdd/1.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% global parameters that can be set using set_problog_flag/2
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
problog_flag(Flag,Option) :-
get_problog_flag(Flag,Option).
get_problog_flag(bdd_time,X) :-
bdd_time(X).
get_problog_flag(first_threshold,X) :-
first_threshold(X).
get_problog_flag(last_threshold,X) :-
last_threshold(L),
X is exp(L).
get_problog_flag(last_threshold_log,X) :-
last_threshold(X).
get_problog_flag(id_stepsize,X) :-
id_stepsize(L),
X is exp(L).
get_problog_flag(id_stepsize_log,X) :-
id_stepsize(X).
get_problog_flag(prunecheck,X) :-
prunecheck(X).
get_problog_flag(maxsteps,X) :-
maxsteps(X).
get_problog_flag(mc_batchsize,X) :-
mc_batchsize(X).
get_problog_flag(mc_logfile,X) :-
mc_logfile(X).
get_problog_flag(bdd_file,X) :-
bdd_file(X).
get_problog_flag(bdd_par_file,X) :-
bdd_par_file(X).
get_problog_flag(bdd_result,X) :-
bdd_result(X).
get_problog_flag(dir,X) :-
work_dir(X).
get_problog_flag(save_bdd,X) :-
save_bdd(X).
%%%%%%%%%%%%
% BDD timeout in seconds, used as option in BDD tool
%%%%%%%%%%%%
set_problog_flag(bdd_time,X) :-
(\+ integer(X); X<0),
!,
format(user,'\% ERROR: value must be positive integer!~n',[]),
flush_output(user),
fail.
set_problog_flag(bdd_time,X) :-
retractall(bdd_time(_)),
assert(bdd_time(X)).
%%%%%%%%%%%%
% iterative deepening on minimal probabilities (delta, max, kbest):
% - first threshold (not in log-space as only used to retrieve argument for init_threshold/1, which is also used with user-supplied argument)
% - last threshold to ensure termination in case infinite search space (saved in log-space for easy comparison with current values during search)
% - factor used to decrease threshold for next level, NewMin=Factor*OldMin (saved in log-space)
%%%%%%%%%%%%
set_problog_flag(first_threshold,X) :-
(\+ number(X); X<0 ; X>1),
!,
format(user,'\% ERROR: value must be in [0,1]!~n',[]),
flush_output(user),
fail.
set_problog_flag(first_threshold,X) :-
retractall(first_threshold(_)),
assert(first_threshold(X)).
set_problog_flag(last_threshold,X) :-
(\+ number(X); X<0 ; X>1),
!,
format(user,'\% ERROR: value must be in [0,1]!~n',[]),
flush_output(user),
fail.
set_problog_flag(last_threshold,X) :-
retractall(last_threshold(_)),
L is log(X),
assert(last_threshold(L)).
set_problog_flag(id_stepsize,X) :-
(\+ number(X); X=<0 ; X>=1),
!,
format(user,'\% ERROR: value must be in ]0,1[!~n',[]),
flush_output(user),
fail.
set_problog_flag(id_stepsize,X) :-
retractall(id_stepsize(_)),
L is log(X),
assert(id_stepsize(L)).
%%%%%%%%%%%%
% prune check stops derivations if they use a superset of facts already known to form a proof
% (very) costly test, can be switched on/off here
%%%%%%%%%%%%
set_problog_flag(prunecheck,on) :-
!,
format(user,'WARNING: prune check not implemented, will fail~n',[]),
flush_output(user),
retractall(prunecheck(_)),
assert(prunecheck(on)).
set_problog_flag(prunecheck,off) :-
!,
retractall(prunecheck(_)),
assert(prunecheck(off)).
set_problog_flag(prunecheck,_) :-
format(user,'\% ERROR: value must be \'on\' or \'off\'!~n',[]),
flush_output(user),
fail.
%%%%%%%%%%%%
% max number of calls to probabilistic facts per derivation (to ensure termination)
%%%%%%%%%%%%
set_problog_flag(maxsteps,X) :-
(\+ integer(X); X<0),
!,
format(user,'\% ERROR: value must be positive integer!~n',[]),
flush_output(user),
fail.
set_problog_flag(maxsteps,X) :-
retractall(maxsteps(_)),
assert(maxsteps(X)).
%%%%%%%%%%%%
% montecarlo: recalculate current approximation after N samples
%%%%%%%%%%%%
set_problog_flag(mc_batchsize,X) :-
(\+ integer(X); X<0),
!,
format(user,'\% ERROR: value must be positive integer!~n',[]),
flush_output(user),
fail.
set_problog_flag(mc_batchsize,X) :-
retractall(mc_batchsize(_)),
assert(mc_batchsize(X)).
%%%%%%%%%%%%
% montecarlo: write log to this file
%%%%%%%%%%%%
set_problog_flag(mc_logfile,X) :-
\+ atom(X),
!,
format(user,'\% ERROR: value must be atom!~n',[]),
flush_output(user),
fail.
set_problog_flag(mc_logfile,X) :-
retractall(mc_logfile(_)),
assert(mc_logfile(X)).
%%%%%%%%%%%%
% files to write BDD script and pars
% bdd_file overwrites bdd_par_file with matching extended name
% if different name wanted, respect order when setting
%%%%%%%%%%%%
set_problog_flag(bdd_file,X) :-
\+ atom(X),
!,
format(user,'\% ERROR: value must be atom!~n',[]),
flush_output(user),
fail.
set_problog_flag(bdd_file,X) :-
retractall(bdd_file(_)),
atomic_concat(X,'_probs',Y),
set_problog_flag(bdd_par_file,Y),
atomic_concat(X,'_res',Z),
set_problog_flag(bdd_result,Z),
assert(bdd_file(X)).
set_problog_flag(bdd_par_file,X) :-
\+ atom(X),
!,
format(user,'\% ERROR: value must be atom!~n',[]),
flush_output(user),
fail.
set_problog_flag(bdd_par_file,X) :-
retractall(bdd_par_file(_)),
assert(bdd_par_file(X)).
set_problog_flag(bdd_result,X) :-
\+ atom(X),
!,
format(user,'\% ERROR: value must be atom!~n',[]),
flush_output(user),
fail.
set_problog_flag(bdd_result,X) :-
retractall(bdd_result(_)),
assert(bdd_result(X)).
%%%%%%%%%%%%
% working directory: all the temporary and output files will be located there
%%%%%%%%%%%%
set_problog_flag(dir,X) :-
\+ atom(X),
!,
format(user,'\% ERROR: value must be atom!~n',[]),
flush_output(user),
fail.
set_problog_flag(dir,X) :-
retractall(work_dir(_)),
atomic_concat([X,'/'],D),
atomic_concat(['mkdir ',D],Mkdir),
(file_exists(X) -> true; shell(Mkdir)),
assert(work_dir(D)).
%%%%%%%%%%%%
% save BDD information for the (last) lower bound BDD used during inference
% produces three files named save_script, save_params, save_map
% located in the directory given by problog_flag dir
%%%%%%%%%%%%
set_problog_flag(save_bdd,true) :-
!,
retractall(save_bdd(_)),
assert(save_bdd(true)).
set_problog_flag(save_bdd,false) :-
!,
retractall(save_bdd(_)),
assert(save_bdd(false)).
set_problog_flag(save_bdd,_) :-
format(user,'\% ERROR: value must be \'true\' or \'false\'!~n',[]),
flush_output(user),
fail.
%%%%%%%%%%%%%%%%%%%%%%%%
% show values
%%%%%%%%%%%%%%%%%%%%%%%%
problog_flags :-
format('~n',[]),
print_sep_line,
format('problog flags: use set_problog_flag(Flag,Option) to change, problog_flag(Flag,Option) to view~n',[]),
print_sep_line,
print_param(description,value,flag,option),
print_sep_line,
problog_flag(bdd_time,StopBDD),
print_param('BDD computation timeout in seconds',StopBDD,'bdd_time','positive integer'),
problog_flag(first_threshold,First),
print_param('starting threshold iterative deepening',First,'first_threshold','0 =< Option =< 1'),
problog_flag(last_threshold,Last),
print_param('stopping threshold iterative deepening',Last,'last_threshold','0 =< Option =< 1'),
problog_flag(id_stepsize,Decrease),
print_param('threshold shrinking factor iterative deepening',Decrease,'id_stepsize','0 < Option < 1'),
problog_flag(prunecheck,Check),
print_param('stop derivations including all facts of known proof',Check,'prunecheck','on/off'),
problog_flag(maxsteps,Steps),
print_param('max. number of prob. steps per derivation',Steps,'maxsteps','positive integer'),
problog_flag(mc_batchsize,MCBatch),
print_param('number of samples before update in montecarlo',MCBatch,'mc_batchsize','positive integer'),
problog_flag(mc_logfile,MCFile),
print_param('logfile for montecarlo',MCFile,'mc_logfile','atom'),
problog_flag(bdd_file,BDDFile),
print_param('file for BDD script',BDDFile,'bdd_file','atom'),
problog_flag(dir,WorkDir),
print_param('directory for files',WorkDir,'dir','atom'),
problog_flag(save_bdd,Save),
print_param('save BDD files for (last) lower bound',Save,'save_bdd','true/false'),
print_sep_line,
format('~n',[]),
flush_output.

24
packages/ProbLog/problog/print.yap Normal file
View File

@ -0,0 +1,24 @@
%%% -*- Mode: Prolog; -*-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% printing functions used for problog_help and problog_flags
% collected here to have formatting at one place
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(print, [print_param/4,
print_sep_line/0,
print_inference/2]).
print_param(Keyword,Value,Function,Legal) :-
format(user,'~w~55+~q~15+~w~30+~w~25+~n',[Keyword,Value,Function,Legal]).
print_sep_line :-
sep_line(125).
sep_line(0) :-
!,
format('~n',[]).
sep_line(N) :-
format('-',[]),
NN is N-1,
sep_line(NN).
print_inference(Call,Description) :-
format(user,'~w~65+~w~60+~n',[Call,Description]).

500
packages/ProbLog/problog/tptree.yap Normal file
View File

@ -0,0 +1,500 @@
%%% -*- Mode: Prolog; -*-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% prefix-trees for managing a DNF
% remembers shortest prefix of a conjunction only (i.e. a*b+a*b*c results in a*b only, but b*a+a*b*c is not reduced)
% children are sorted, but branches aren't (to speed up search while keeping structure sharing from proof procedure)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(ptree,[init_ptree/1,
delete_ptree/1,
rename_ptree/2,
member_ptree/2,
enum_member_ptree/2,
insert_ptree/2,
delete_ptree/2,
edges_ptree/2,
count_ptree/2,
prune_check_ptree/2,
empty_ptree/1,
merge_ptree/3,
bdd_ptree/3,
bdd_ptree_map/4
]).
:- use_module(library(tries),
[
trie_open/1,
trie_close/1,
trie_stats/4,
trie_check_entry/3,
trie_get_entry/2,
trie_put_entry/3,
trie_remove_entry/1,
trie_usage/4,
trie_dup/2,
trie_join/2,
trie_traverse/2
]).
:- use_module(library(ordsets),
[
ord_subset/2
]).
:- style_check(all).
:- yap_flag(unknown,error).
:- use_module(flags,[problog_flag/2]).
:- ensure_loaded(library(lists)).
:- ensure_loaded(library(system)).
% name lexicon external - internal
sym(1,tree1) :- !.
sym(2,tree2) :- !.
sym(3,tree3) :- !.
sym(N,AN) :- atomic_concat([tree,N],AN).
%%%%%%%%%%%%%%%%%%%%%%%%
% ptree basics
%%%%%%%%%%%%%%%%%%%%%%%%
init_ptree(ID) :-
sym(ID,Sym),
trie_open(Trie),
nb_setval(Sym, Trie).
delete_ptree(ID) :-
sym(ID,Sym),
nb_getval(Sym, Trie), !,
trie_close(Trie),
trie_open(NewTrie),
nb_setval(Sym, NewTrie).
delete_ptree(_).
rename_ptree(OldID,NewID) :-
sym(OldID,OldSym),
sym(NewID,NewSym),
nb_getval(OldSym, Trie),
nb_set_shared_val(NewSym, Trie).
empty_ptree(ID) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_usage(Trie, 0, 0, 0).
%%%%%%%%%%%%%%%%%%%%%%%%
% member
%%%%%%%%%%%%%%%%%%%%%%%%
% non-backtrackable (to check)
member_ptree(List,ID) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_check_entry(Trie, List, _).
% backtrackable (to list)
enum_member_ptree(ID,List) :-
sym(ID,Sym),
nb_getval(Sym, Tree),
trie_path(Tree, List).
trie_path(Tree, List) :-
trie_traverse(Tree,Ref),
trie_get_entry(Ref, List).
%%%%%%%%%%%%%%%%%%%%%%%%
% insert conjunction
%%%%%%%%%%%%%%%%%%%%%%%%
insert_ptree(true,ID) :-
sym(ID,Sym),
!,
nb_getval(Sym, Trie),
trie_close(Trie),
trie_open(NTrie),
trie_put_entry(NTrie, true, _).
insert_ptree(List,ID) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_put_entry(Trie, List, _).
%%%%%%%%%%%%%%%%%%%%%%%%
% delete conjunction
%%%%%%%%%%%%%%%%%%%%%%%%
delete_ptree(List,ID) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_check_entry(Trie, List, Ref),
trie_remove_entry(Ref).
%%%%%%%%
% return list -Edges of all edge labels in ptree
% doesn't use any heuristic to order those for the BDD
% (automatic reordering has to do the job)
%%%%%%%%%
edges_ptree(ID,[]) :-
empty_ptree(ID),
!.
edges_ptree(ID,[]) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_check_entry(Trie, true, _),
!.
edges_ptree(ID,Edges) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
setof(X, trie_literal(Trie, X), Edges).
trie_literal(Trie, X) :-
trie_traverse(Trie,Ref),
trie_get_entry(Ref, List),
member(X, List).
%%%%%%%%
% number of conjunctions in the tree
%%%%%%%%%
count_ptree(ID,N) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_usage(Trie, N, _, _).
%%%%%%%%
% check whether some branch of ptree is a subset of conjunction List
% useful for pruning the search for proofs (optional due to time overhead)
% currently not implemented, just fails
%%%%%%%
prune_check_ptree(_List,_TreeID) :-
format(user,'FAIL: prune check currently not supported~n',[]),
flush_output(user),
fail.
%%%%%%%%%%%%%
% merge two ptrees
% - take care not to loose proper prefixes that are proofs!
%%%%%%%%%%%%%%%
merge_ptree(ID1,_,ID3) :-
sym(ID1,Sym1),
sym(ID3,Sym3),
nb_getval(Sym1, T1),
trie_check_entry(T1, true, _),
!,
trie_open(T3),
trie_put_entry(T3, true, _),
nb_setval(Sym3, T3).
merge_ptree(_,ID2,ID3) :-
sym(ID2,Sym2),
sym(ID3,Sym3),
nb_getval(Sym2, T2),
trie_check_entry(T2, true, _),
!,
trie_open(T3),
trie_put_entry(T3, true, _),
nb_setval(Sym3, T3).
merge_ptree(ID1,ID2,ID3) :-
sym(ID1,Sym1),
sym(ID2,Sym2),
sym(ID3,Sym3),
nb_getval(Sym1, T1),
nb_getval(Sym2, T2),
trie_dup(T1, T3),
trie_join(T3,T2),
nb_setval(Sym3, T3).
%%%%%%%%%%%%%%%%%%%%%%%%
% write BDD info for given ptree to file
% - initializes leaf BDDs (=variables) first
% - then compresses ptree to exploit subtree sharing
% - bdd_pt/1 does the work on the structure itself
%%%%%%%%%%%%%%%%%%%%%%%%
bdd_ptree(ID,FileBDD,FileParam) :-
bdd_ptree_script(ID,FileBDD,FileParam),
eraseall(map).
% version returning variable mapping
bdd_ptree_map(ID,FileBDD,FileParam,Mapping) :-
bdd_ptree_script(ID,FileBDD,FileParam),
findall(X,recorded(map,X,_),Map),
add_probs(Map,Mapping),
eraseall(map).
add_probs([],[]).
add_probs([m(A,Name)|Map],[m(A,Name,Prob)|Mapping]) :-
problog:get_fact_probability(A,Prob),
add_probs(Map,Mapping).
% number of variables may be to high:
% counted on trie, but conversion to old tree representation
% transforms A*B+A to A (prefix-test)
bdd_ptree_script(ID,FileBDD,FileParam) :-
edges_ptree(ID,Edges),
tell(FileParam),
bdd_vars_script(Edges),
flush_output,
told,
length(Edges,VarCount),
assert(c_num(1)),
bdd_pt(ID,CT),
c_num(NN),
IntermediateSteps is NN-1,
tell(FileBDD),
format('@BDD1~n~w~n~w~n~w~n',[VarCount,0,IntermediateSteps]),
output_compressed_script(CT),
told,
retractall(c_num(_)),
retractall(compression(_,_)).
% write parameter file by iterating over all var/not(var) occuring in the tree
bdd_vars_script(Edges) :-
bdd_vars_script(Edges,0).
bdd_vars_script([],_).
bdd_vars_script([A|B],N) :-
problog:get_fact_probability(A,P),
get_var_name(A,NameA),
format('@~w~n~12f~n',[NameA,P]),
NN is N+1,
bdd_vars_script(B,NN).
%%%%%%%%%%%%%%%%%%%%%%%%
% find top level symbol for script
%%%%%%%%%%%%%%%%%%%%%%%%
% special cases: variable-free formulae
bdd_pt(ID,false) :-
empty_ptree(ID),
!,
once(retractall(c_num(_))),
once(assert(c_num(2))).
bdd_pt(ID,true) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_check_entry(Trie, true, _),
!,
once(retractall(c_num(_))),
once(assert(c_num(2))).
% general case: transform trie to nested tree structure for compression
bdd_pt(ID,CT) :-
sym(ID,Sym),
nb_getval(Sym, Trie),
trie_to_tree(Trie, Tree),
compress_pt(Tree,CT).
trie_to_tree(Trie, Tree) :-
findall(Path,trie_path(Trie, Path), Paths),
add_trees(Paths, [], Tree).
add_trees([], Tree, Tree).
add_trees([List|Paths], Tree0, Tree) :-
ins_pt(List, Tree0, TreeI),
add_trees(Paths, TreeI, Tree).
ins_pt([],_T,[]) :- !.
ins_pt([A|B],[s(A1,AT)|OldT],NewT) :-
compare(Comp, A1, A),
(Comp == = ->
(AT == [] ->
NewT=[s(A1,AT)|OldT]
;
NewT = [s(A1,NewAT)|OldT],
ins_pt(B, AT, NewAT))
;
Comp == > ->
NewT = [s(A1,AT)|Tree],
ins_pt([A|B], OldT, Tree)
;
NewT = [s(A,BTree),s(A1,AT)|OldT],
ins_pt(B,[],BTree)
).
ins_pt([A|B],[],[s(A,NewAT)]) :-
ins_pt(B,[],NewAT).
%%%%%%%%%%%%
% BDD compression: alternates and- and or-levels to build BDD bottom-up
% each sub-BDD will be either a conjunction of a one-node BDD with some BDD or a disjunction of BDDs
% uses the internal database to temporarily store a map of components
%%%%%%%%%%%%
% T is completely compressed and contains single variable
% i.e. T of form x12
compress_pt(T,TT) :-
atom(T),
test_var_name(T),
!,
get_next_name(TT),
assertz(compression(TT,[T])).
% T is completely compressed and contains subtrees
% i.e. T of form 'L56'
compress_pt(T,T) :-
atom(T).
% T not yet compressed
% i.e. T is a tree-term (nested list & s/2 structure)
% -> execute one layer of compression, then check again
compress_pt(T,CT) :-
\+ atom(T),
and_or_compression(T,IT),
compress_pt(IT,CT).
% transform tree-term T into tree-term CT where last two layers have been processed
% i.e. introduce names for subparts (-> Map) and replace (all occurrenes of) subparts by this names
and_or_compression(T,CT) :-
and_comp(T,AT),
or_comp(AT,CT).
% replace leaves that are single child by variable representing father-AND-child
and_comp(T,AT) :-
all_leaves_pt(T,Leaves),
compression_mapping(Leaves,Map),
replace_pt(T,Map,AT).
% replace list of siblings by variable representing their disjunction
or_comp(T,AT) :-
all_leaflists_pt(T,Leaves),
compression_mapping(Leaves,Map),
replace_pt(T,Map,AT).
all_leaves_pt(T,L) :-
all(X,some_leaf_pt(T,X),L).
some_leaf_pt([s(A,[])|_],s(A,[])).
some_leaf_pt([s(A,L)|_],s(A,L)) :-
atom(L).
some_leaf_pt([s(_,L)|_],X) :-
some_leaf_pt(L,X).
some_leaf_pt([_|L],X) :-
some_leaf_pt(L,X).
all_leaflists_pt(L,[L]) :-
atomlist(L),!.
all_leaflists_pt(T,L) :-
all(X,some_leaflist_pt(T,X),L),!.
all_leaflists_pt(_,[]).
some_leaflist_pt([s(_,L)|_],L) :-
atomlist(L).
some_leaflist_pt([s(_,L)|_],X) :-
some_leaflist_pt(L,X).
some_leaflist_pt([_|L],X) :-
some_leaflist_pt(L,X).
atomlist([]).
atomlist([A|B]) :-
atom(A),
atomlist(B).
% for each subtree that will be compressed, add its name
% only introduce 'L'-based names when subtree composes elements, store these in compression/2 for printing the script
compression_mapping([],[]).
compression_mapping([First|B],[N-First|BB]) :-
(
First = s(A,[]) % subtree is literal -> use variable's name x17 from map
->
recorded(map,m(A,N),_)
;
(First = s(A,L),atom(L)) % subtree is node with single completely reduced child -> use next 'L'-based name
-> (get_next_name(N),
assertz(compression(N,s(A,L))))
;
(First = [L],atom(L)) % subtree is an OR with a single completely reduced element -> use element's name
-> N=L
;
(atomlist(First), % subtree is an OR with only (>1) completely reduced elements -> use next 'L'-based name
get_next_name(N),
assertz(compression(N,First)))
),
compression_mapping(B,BB).
% replace_pt(+T,+Map,-NT)
% given the tree-term T and the Map of Name-Subtree entries, replace each occurence of Subtree in T with Name -> result NT
replace_pt(T,[],T).
replace_pt([],_,[]).
replace_pt(L,M,R) :-
atomlist(L),
member(R-L,M),
!.
replace_pt([L|LL],[M|MM],R) :-
replace_pt_list([L|LL],[M|MM],R).
replace_pt_list([T|Tree],[M|Map],[C|Compr]) :-
replace_pt_single(T,[M|Map],C),
replace_pt_list(Tree,[M|Map],Compr).
replace_pt_list([],_,[]).
replace_pt_single(s(A,T),[M|Map],Res) :-
atomlist(T),
member(Res-s(A,T),[M|Map]),
!.
replace_pt_single(s(A,T),[M|Map],s(A,Res)) :-
atomlist(T),
member(Res-T,[M|Map]),
!.
replace_pt_single(s(A,T),[M|Map],Res) :-
member(Res-s(A,T),[M|Map]),
!.
replace_pt_single(s(A,T),[M|Map],s(A,TT)) :-
replace_pt_list(T,[M|Map],TT).
replace_pt_single(A,_,A) :-
atom(A).
%%%%%%%%%%%%
% output for script
% input argument is compressed tree, i.e. true/false or name assigned in last compression step
%%%%%%%%%%%%
output_compressed_script(false) :-
!,
format('L1 = FALSE~nL1~n',[]).
output_compressed_script(true) :-
!,
format('L1 = TRUE~nL1~n',[]).
% for each name-subtree pair, write corresponding line to script, e.g. L17 = x4 * L16
% stop after writing definition of root (last entry in compression/2), add it's name to mark end of script
output_compressed_script(T) :-
once(retract(compression(Short,Long))),
(T = Short ->
format('~w = ',[Short]),
format_compression_script(Long),
format('~w~n',[Short])
;
format('~w = ',[Short]),
format_compression_script(Long),
output_compressed_script(T)).
format_compression_script(s(A,B)) :-
recorded(map,m(A,C),_),
format('~w * ~w~n',[C,B]).
format_compression_script([A]) :-
format('~w~n',[A]).
format_compression_script([A,B|C]) :-
format('~w + ',[A]),
format_compression_script([B|C]).
%%%%%%%%%%%%%%%%%%%%%%%%
% auxiliaries for translation to BDD
%%%%%%%%%%%%%%%%%%%%%%%%
% prefix the current counter with "L"
get_next_name(Name) :-
retract(c_num(N)),
NN is N+1,
assert(c_num(NN)),
atomic_concat('L',N,Name).
% create BDD-var as fact id prefixed by x
% learning.yap relies on this format!
% when changing, also adapt test_var_name/1 below
get_var_name(A,NameA) :-
atomic_concat([x,A],NameA),
recorda(map,m(A,NameA),_).
% test used by base case of compression mapping to detect single-variable tree
% has to match above naming scheme
test_var_name(T) :-
atomic_concat(x,_,T).

281
packages/ProbLog/simplecudd/Example.c Normal file
View File

@ -0,0 +1,281 @@
/******************************************************************************\
* *
* SimpleCUDD library (www.cs.kuleuven.be/~theo/tools/simplecudd.html) *
* SimpleCUDD was developed at Katholieke Universiteit Leuven(www.kuleuven.be) *
* *
* Copyright T. Mantadelis and Katholieke Universiteit Leuven 2008 *
* *
* Author: Theofrastos Mantadelis *
* File: Example.c *
* *
********************************************************************************
* *
* The "Artistic License" *
* *
* Preamble *
* *
* The intent of this document is to state the conditions under which a *
* Package may be copied, such that the Copyright Holder maintains some *
* semblance of artistic control over the development of the package, *
* while giving the users of the package the right to use and distribute *
* the Package in a more-or-less customary fashion, plus the right to make *
* reasonable modifications. *
* *
* Definitions: *
* *
* "Package" refers to the collection of files distributed by the *
* Copyright Holder, and derivatives of that collection of files *
* created through textual modification. *
* *
* "Standard Version" refers to such a Package if it has not been *
* modified, or has been modified in accordance with the wishes *
* of the Copyright Holder as specified below. *
* *
* "Copyright Holder" is whoever is named in the copyright or *
* copyrights for the package. *
* *
* "You" is you, if you're thinking about copying or distributing *
* this Package. *
* *
* "Reasonable copying fee" is whatever you can justify on the *
* basis of media cost, duplication charges, time of people involved, *
* and so on. (You will not be required to justify it to the *
* Copyright Holder, but only to the computing community at large *
* as a market that must bear the fee.) *
* *
* "Freely Available" means that no fee is charged for the item *
* itself, though there may be fees involved in handling the item. *
* It also means that recipients of the item may redistribute it *
* under the same conditions they received it. *
* *
* 1. You may make and give away verbatim copies of the source form of the *
* Standard Version of this Package without restriction, provided that you *
* duplicate all of the original copyright notices and associated disclaimers. *
* *
* 2. You may apply bug fixes, portability fixes and other modifications *
* derived from the Public Domain or from the Copyright Holder. A Package *
* modified in such a way shall still be considered the Standard Version. *
* *
* 3. You may otherwise modify your copy of this Package in any way, provided *
* that you insert a prominent notice in each changed file stating how and *
* when you changed that file, and provided that you do at least ONE of the *
* following: *
* *
* a) place your modifications in the Public Domain or otherwise make them *
* Freely Available, such as by posting said modifications to Usenet or *
* an equivalent medium, or placing the modifications on a major archive *
* site such as uunet.uu.net, or by allowing the Copyright Holder to include *
* your modifications in the Standard Version of the Package. *
* *
* b) use the modified Package only within your corporation or organization. *
* *
* c) rename any non-standard executables so the names do not conflict *
* with standard executables, which must also be provided, and provide *
* a separate manual page for each non-standard executable that clearly *
* documents how it differs from the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 4. You may distribute the programs of this Package in object code or *
* executable form, provided that you do at least ONE of the following: *
* *
* a) distribute a Standard Version of the executables and library files, *
* together with instructions (in the manual page or equivalent) on where *
* to get the Standard Version. *
* *
* b) accompany the distribution with the machine-readable source of *
* the Package with your modifications. *
* *
* c) give non-standard executables non-standard names, and clearly *
* document the differences in manual pages (or equivalent), together *
* with instructions on where to get the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 5. You may charge a reasonable copying fee for any distribution of this *
* Package. You may charge any fee you choose for support of this *
* Package. You may not charge a fee for this Package itself. However, *
* you may distribute this Package in aggregate with other (possibly *
* commercial) programs as part of a larger (possibly commercial) software *
* distribution provided that you do not advertise this Package as a *
* product of your own. You may embed this Package's interpreter within *
* an executable of yours (by linking); this shall be construed as a mere *
* form of aggregation, provided that the complete Standard Version of the *
* interpreter is so embedded. *
* *
* 6. The scripts and library files supplied as input to or produced as *
* output from the programs of this Package do not automatically fall *
* under the copyright of this Package, but belong to whoever generated *
* them, and may be sold commercially, and may be aggregated with this *
* Package. If such scripts or library files are aggregated with this *
* Package via the so-called "undump" or "unexec" methods of producing a *
* binary executable image, then distribution of such an image shall *
* neither be construed as a distribution of this Package nor shall it *
* fall under the restrictions of Paragraphs 3 and 4, provided that you do *
* not represent such an executable image as a Standard Version of this *
* Package. *
* *
* 7. C subroutines (or comparably compiled subroutines in other *
* languages) supplied by you and linked into this Package in order to *
* emulate subroutines and variables of the language defined by this *
* Package shall not be considered part of this Package, but are the *
* equivalent of input as in Paragraph 6, provided these subroutines do *
* not change the language in any way that would cause it to fail the *
* regression tests for the language. *
* *
* 8. Aggregation of this Package with a commercial distribution is always *
* permitted provided that the use of this Package is embedded; that is, *
* when no overt attempt is made to make this Package's interfaces visible *
* to the end user of the commercial distribution. Such use shall not be *
* construed as a distribution of this Package. *
* *
* 9. The name of the Copyright Holder may not be used to endorse or promote *
* products derived from this software without specific prior written *
* permission. *
* *
* 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR *
* IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED *
* WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. *
* *
* The End *
* *
\******************************************************************************/
#include "simplecudd.h"
typedef struct _extmanager {
DdManager *manager;
DdNode *t, *f;
hisqueue *his;
namedvars varmap;
} extmanager;
void DFS(extmanager MyManager, DdNode *Current);
int compexpand(extmanager MyManager, DdNode *Current, extmanager MyManager2, DdNode *Current2);
int bufstrcat(char *targetstr, int targetmem, const char *srcstr);
void getalltruepaths(extmanager MyManager, DdNode *Current, const char *startpath, const char *prevvar);
int main(int argc, char **arg) {
extmanager MyManager;
DdNode *bdd;
bddfileheader fileheader;
int code;
char yn;
code = -1;
if (argc != 2) {
fprintf(stderr, "\nUsage: %s [filename]\nGenerates and traverses a BDD from file\n", arg[0]);
fprintf(stderr, "\nUsage: %s -online\nGenerates and traverses a BDD online mode\n", arg[0]);
return code;
}
RAPIDLOADON;
if (strcmp("-online", arg[1]) == 0) {
MyManager.manager = simpleBDDinit(0);
MyManager.t = HIGH(MyManager.manager);
MyManager.f = LOW(MyManager.manager);
MyManager.varmap = InitNamedVars(1, 0);
bdd = OnlineGenerateBDD(MyManager.manager, &MyManager.varmap);
} else {
fileheader = ReadFileHeader(arg[1]);
switch(fileheader.filetype) {
case BDDFILE_SCRIPT:
MyManager.manager = simpleBDDinit(fileheader.varcnt);
MyManager.t = HIGH(MyManager.manager);
MyManager.f = LOW(MyManager.manager);
MyManager.varmap = InitNamedVars(fileheader.varcnt, fileheader.varstart);
bdd = FileGenerateBDD(MyManager.manager, MyManager.varmap, fileheader);
break;
case BDDFILE_NODEDUMP:
MyManager.manager = simpleBDDinit(fileheader.varcnt);
MyManager.t = HIGH(MyManager.manager);
MyManager.f = LOW(MyManager.manager);
MyManager.varmap = InitNamedVars(fileheader.varcnt, fileheader.varstart);
bdd = LoadNodeDump(MyManager.manager, MyManager.varmap, fileheader.inputfile);
break;
default:
fprintf(stderr, "Error: not a valid file format to load.\n");
return code;
break;
}
}
if (bdd != NULL) {
printf("Do you want to load parameter values from testdata.txt [y]? "); yn = getchar(); getchar();
if (yn == 'y') LoadVariableData(MyManager.varmap, "testdata.txt");
code = 0;
MyManager.his = InitHistory(GetVarCount(MyManager.manager));
if (strcmp("-online", arg[1]) != 0) {
DFS(MyManager, bdd);
printf("Do you need an export [y]? "); yn = getchar(); getchar();
if (yn == 'y') simpleNamedBDDtoDot(MyManager.manager, MyManager.varmap, bdd, "SimpleCUDDExport.dot");
printf("Do you want a save [y]? "); yn = getchar(); getchar();
if (yn == 'y') SaveNodeDump(MyManager.manager, MyManager.varmap, bdd, "SimpleCUDDSave.sav");
printf("Do you want to see all true paths [y]? "); yn = getchar(); getchar();
if (yn == 'y') {
ReInitHistory(MyManager.his, GetVarCount(MyManager.manager));
getalltruepaths(MyManager, bdd, "", "");
}
} else {
onlinetraverse(MyManager.manager, MyManager.varmap, MyManager.his, bdd);
}
}
if (MyManager.manager != NULL) KillBDD(MyManager.manager);
return code;
}
void DFS(extmanager MyManager, DdNode *Current) {
DdNode *h, *l;
hisnode *Found;
char *curnode;
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
if (GetIndex(Current) < MyManager.varmap.varcnt) {
printf("%s(%f,%i,%s)\n", curnode, MyManager.varmap.dvalue[GetIndex(Current)], MyManager.varmap.ivalue[GetIndex(Current)], MyManager.varmap.dynvalue[GetIndex(Current)]);
} else {
printf("%s\n", curnode);
}
if ((Current != MyManager.t) && (Current != MyManager.f) &&
((Found = GetNode(MyManager.his, MyManager.varmap.varstart, Current)) == NULL)) {
l = LowNodeOf(MyManager.manager, Current);
h = HighNodeOf(MyManager.manager, Current);
printf("l(%s)->", curnode);
DFS(MyManager, l);
printf("h(%s)->", curnode);
DFS(MyManager, h);
AddNode(MyManager.his, MyManager.varmap.varstart, Current, 0.0, 0, NULL);
}
}
void getalltruepaths(extmanager MyManager, DdNode *Current, const char *startpath, const char *prevvar) {
DdNode *h, *l;
char *curnode, *curpath;
int pathmaxsize = 1024;
curpath = (char *) malloc(sizeof(char) * pathmaxsize);
curpath[0] = '\0';
pathmaxsize = bufstrcat(curpath, pathmaxsize, startpath);
pathmaxsize = bufstrcat(curpath, pathmaxsize, prevvar);
pathmaxsize = bufstrcat(curpath, pathmaxsize, "*");
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
if (Current == MyManager.t) {
printf("%s\n", curpath);
} else if (Current != MyManager.f) {
h = HighNodeOf(MyManager.manager, Current);
if (h != MyManager.f) {
getalltruepaths(MyManager, h, curpath, curnode);
}
l = LowNodeOf(MyManager.manager, Current);
if (l != MyManager.f) {
pathmaxsize = bufstrcat(curpath, pathmaxsize, "~");
getalltruepaths(MyManager, l, curpath, curnode);
}
}
free(curpath);
}
int bufstrcat(char *targetstr, int targetmem, const char *srcstr) {
int strinc = strlen(srcstr), strsize = strlen(targetstr);
while ((strsize + strinc) > (targetmem - 1)) {
targetmem *= 2;
targetstr = (char *) realloc(targetstr, sizeof(char) * targetmem);
}
strcat(targetstr, srcstr);
return targetmem;
}

131
packages/ProbLog/simplecudd/LICENCE Normal file
View File

@ -0,0 +1,131 @@
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions:
"Package" refers to the collection of files distributed by the
Copyright Holder, and derivatives of that collection of files
created through textual modification.
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
"You" is you, if you're thinking about copying or distributing
this Package.
"Reasonable copying fee" is whatever you can justify on the
basis of media cost, duplication charges, time of people involved,
and so on. (You will not be required to justify it to the
Copyright Holder, but only to the computing community at large
as a market that must bear the fee.)
"Freely Available" means that no fee is charged for the item
itself, though there may be fees involved in handling the item.
It also means that recipients of the item may redistribute it
under the same conditions they received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A Package
modified in such a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided
that you insert a prominent notice in each changed file stating how and
when you changed that file, and provided that you do at least ONE of the
following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or
an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include
your modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict
with standard executables, which must also be provided, and provide
a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where
to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent), together
with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this
Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
product of your own. You may embed this Package's interpreter within
an executable of yours (by linking); this shall be construed as a mere
form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever generated
them, and may be sold commercially, and may be aggregated with this
Package. If such scripts or library files are aggregated with this
Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall
neither be construed as a distribution of this Package nor shall it
fall under the restrictions of Paragraphs 3 and 4, provided that you do
not represent such an executable image as a Standard Version of this
Package.
7. C subroutines (or comparably compiled subroutines in other
languages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
regression tests for the language.
8. Aggregation of this Package with a commercial distribution is always
permitted provided that the use of this Package is embedded; that is,
when no overt attempt is made to make this Package's interfaces visible
to the end user of the commercial distribution. Such use shall not be
construed as a distribution of this Package.
9. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End

34
packages/ProbLog/simplecudd/Makefile.in Normal file
View File

@ -0,0 +1,34 @@
CUDD = cudd-2.4.1
DYNAMIC =
FLAGS =
INCLUDE = -I $(CUDD)/include
LINKFLAGS = -lm
LINKLIBS = $(CUDD)/cudd/libcudd.a $(CUDD)/mtr/libmtr.a $(CUDD)/st/libst.a $(CUDD)/util/libutil.a $(CUDD)/epd/libepd.a
default: makecudd example problog
example: Example.o simplecudd.o general.o
@echo Making Example...
@echo Copyright T. Mantadelis and Katholieke Universiteit Leuven 2008
gcc Example.o simplecudd.o general.o $(LINKLIBS) $(LINKFLAGS) -o Example
problog: ProblogBDD.o simplecudd.o general.o
@echo Making ProblogBDD...
@echo Copyright T. Mantadelis, A. Kimmig, B. Gutmann and Katholieke Universiteit Leuven 2008
gcc ProblogBDD.o simplecudd.o general.o $(LINKLIBS) $(LINKFLAGS) -o ProblogBDD
makecudd:
@(cd $(CUDD); \
echo Making cudd...; \
make)
%.o : %.c
gcc $(FLAGS) $(INCLUDE) $(DYNAMIC) -c $<
clean: cleancudd
rm -f *.o ProblogBDD Example
cleancudd:
@(cd $(CUDD); \
echo Cleaning cudd...; \
make clean)

670
packages/ProbLog/simplecudd/ProblogBDD.c Normal file
View File

@ -0,0 +1,670 @@
/******************************************************************************\
* *
* SimpleCUDD library (www.cs.kuleuven.be/~theo/tools/simplecudd.html) *
* SimpleCUDD was developed at Katholieke Universiteit Leuven(www.kuleuven.be) *
* *
* Copyright T. Mantadelis, A. Kimmig, B. Gutmann *
* and Katholieke Universiteit Leuven 2008 *
* *
* Author: Theofrastos Mantadelis, Angelika Kimmig, Bernd Gutmann *
* File: ProblogBDD.c *
* *
********************************************************************************
* *
* The "Artistic License" *
* *
* Preamble *
* *
* The intent of this document is to state the conditions under which a *
* Package may be copied, such that the Copyright Holder maintains some *
* semblance of artistic control over the development of the package, *
* while giving the users of the package the right to use and distribute *
* the Package in a more-or-less customary fashion, plus the right to make *
* reasonable modifications. *
* *
* Definitions: *
* *
* "Package" refers to the collection of files distributed by the *
* Copyright Holder, and derivatives of that collection of files *
* created through textual modification. *
* *
* "Standard Version" refers to such a Package if it has not been *
* modified, or has been modified in accordance with the wishes *
* of the Copyright Holder as specified below. *
* *
* "Copyright Holder" is whoever is named in the copyright or *
* copyrights for the package. *
* *
* "You" is you, if you're thinking about copying or distributing *
* this Package. *
* *
* "Reasonable copying fee" is whatever you can justify on the *
* basis of media cost, duplication charges, time of people involved, *
* and so on. (You will not be required to justify it to the *
* Copyright Holder, but only to the computing community at large *
* as a market that must bear the fee.) *
* *
* "Freely Available" means that no fee is charged for the item *
* itself, though there may be fees involved in handling the item. *
* It also means that recipients of the item may redistribute it *
* under the same conditions they received it. *
* *
* 1. You may make and give away verbatim copies of the source form of the *
* Standard Version of this Package without restriction, provided that you *
* duplicate all of the original copyright notices and associated disclaimers. *
* *
* 2. You may apply bug fixes, portability fixes and other modifications *
* derived from the Public Domain or from the Copyright Holder. A Package *
* modified in such a way shall still be considered the Standard Version. *
* *
* 3. You may otherwise modify your copy of this Package in any way, provided *
* that you insert a prominent notice in each changed file stating how and *
* when you changed that file, and provided that you do at least ONE of the *
* following: *
* *
* a) place your modifications in the Public Domain or otherwise make them *
* Freely Available, such as by posting said modifications to Usenet or *
* an equivalent medium, or placing the modifications on a major archive *
* site such as uunet.uu.net, or by allowing the Copyright Holder to include *
* your modifications in the Standard Version of the Package. *
* *
* b) use the modified Package only within your corporation or organization. *
* *
* c) rename any non-standard executables so the names do not conflict *
* with standard executables, which must also be provided, and provide *
* a separate manual page for each non-standard executable that clearly *
* documents how it differs from the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 4. You may distribute the programs of this Package in object code or *
* executable form, provided that you do at least ONE of the following: *
* *
* a) distribute a Standard Version of the executables and library files, *
* together with instructions (in the manual page or equivalent) on where *
* to get the Standard Version. *
* *
* b) accompany the distribution with the machine-readable source of *
* the Package with your modifications. *
* *
* c) give non-standard executables non-standard names, and clearly *
* document the differences in manual pages (or equivalent), together *
* with instructions on where to get the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 5. You may charge a reasonable copying fee for any distribution of this *
* Package. You may charge any fee you choose for support of this *
* Package. You may not charge a fee for this Package itself. However, *
* you may distribute this Package in aggregate with other (possibly *
* commercial) programs as part of a larger (possibly commercial) software *
* distribution provided that you do not advertise this Package as a *
* product of your own. You may embed this Package's interpreter within *
* an executable of yours (by linking); this shall be construed as a mere *
* form of aggregation, provided that the complete Standard Version of the *
* interpreter is so embedded. *
* *
* 6. The scripts and library files supplied as input to or produced as *
* output from the programs of this Package do not automatically fall *
* under the copyright of this Package, but belong to whoever generated *
* them, and may be sold commercially, and may be aggregated with this *
* Package. If such scripts or library files are aggregated with this *
* Package via the so-called "undump" or "unexec" methods of producing a *
* binary executable image, then distribution of such an image shall *
* neither be construed as a distribution of this Package nor shall it *
* fall under the restrictions of Paragraphs 3 and 4, provided that you do *
* not represent such an executable image as a Standard Version of this *
* Package. *
* *
* 7. C subroutines (or comparably compiled subroutines in other *
* languages) supplied by you and linked into this Package in order to *
* emulate subroutines and variables of the language defined by this *
* Package shall not be considered part of this Package, but are the *
* equivalent of input as in Paragraph 6, provided these subroutines do *
* not change the language in any way that would cause it to fail the *
* regression tests for the language. *
* *
* 8. Aggregation of this Package with a commercial distribution is always *
* permitted provided that the use of this Package is embedded; that is, *
* when no overt attempt is made to make this Package's interfaces visible *
* to the end user of the commercial distribution. Such use shall not be *
* construed as a distribution of this Package. *
* *
* 9. The name of the Copyright Holder may not be used to endorse or promote *
* products derived from this software without specific prior written *
* permission. *
* *
* 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR *
* IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED *
* WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. *
* *
* The End *
* *
\******************************************************************************/
#include "simplecudd.h"
#include <signal.h>
typedef struct _parameters {
int loadfile;
int savedfile;
int exportfile;
int inputfile;
int debug;
int errorcnt;
int *error;
int method;
int queryid;
int timeout;
double sigmoid_slope;
int online;
int maxbufsize;
char *ppid;
} parameters;
typedef struct _gradientpair {
double probability;
double gradient;
} gradientpair;
typedef struct _extmanager {
DdManager *manager;
DdNode *t, *f;
hisqueue *his;
namedvars varmap;
} extmanager;
int argtype(const char *arg);
void printhelp(int argc, char **arg);
parameters loadparam(int argc, char **arg);
parameters params;
void handler(int num);
void pidhandler(int num);
void termhandler(int num);
double sigmoid(double x, double slope);
void myexpand(extmanager MyManager, DdNode *Current);
double CalcProbability(extmanager MyManager, DdNode *Current);
double CalcProbabilitySigmoid(extmanager MyManager, DdNode *Current);
gradientpair CalcGradient(extmanager MyManager, DdNode *Current, int TargetVar, char *TargetPattern);
int patterncalculated(char *pattern, extmanager MyManager, int loc);
char * extractpattern(char *thestr);
int main(int argc, char **arg) {
extmanager MyManager;
DdNode *bdd;
bddfileheader fileheader;
int i, ivarcnt, code;
gradientpair tvalue;
double probability = -1.0;
char *varpattern;
varpattern = NULL;
code = -1;
params = loadparam(argc, arg);
if (params.errorcnt > 0) {
printhelp(argc, arg);
for (i = 0; i < params.errorcnt; i++) {
fprintf(stderr, "Error: not known or error at parameter %s.\n", arg[params.error[i]]);
}
return -1;
}
if (params.online == 0 && params.loadfile == -1) {
printhelp(argc, arg);
fprintf(stderr, "Error: you must specify a loading file.\n");
return -1;
}
if (params.method != 0 && arg[params.method][0] != 'g' && arg[params.method][0] != 'p' && arg[params.method][0] != 'o') {
printhelp(argc, arg);
fprintf(stderr, "Error: you must choose a calculation method beetween [p]robability, [g]radient, [o]nline.\n");
return -1;
}
if (params.debug) DEBUGON;
RAPIDLOADON;
SETMAXBUFSIZE(params.maxbufsize);
signal(SIGINT, termhandler);
if (params.ppid != NULL) {
signal(SIGALRM, pidhandler);
alarm(5);
} else {
signal(SIGALRM, handler);
alarm(params.timeout);
}
if (params.online) {
MyManager.manager = simpleBDDinit(0);
MyManager.t = HIGH(MyManager.manager);
MyManager.f = LOW(MyManager.manager);
MyManager.varmap = InitNamedVars(1, 0);
bdd = OnlineGenerateBDD(MyManager.manager, &MyManager.varmap);
ivarcnt = GetVarCount(MyManager.manager);
} else {
fileheader = ReadFileHeader(arg[params.loadfile]);
switch(fileheader.filetype) {
case BDDFILE_SCRIPT:
if (params.inputfile == -1) {
printhelp(argc, arg);
fprintf(stderr, "Error: an input file is necessary for this type of loading file.\n");
return -1;
}
MyManager.manager = simpleBDDinit(fileheader.varcnt);
MyManager.t = HIGH(MyManager.manager);
MyManager.f = LOW(MyManager.manager);
MyManager.varmap = InitNamedVars(fileheader.varcnt, fileheader.varstart);
bdd = FileGenerateBDD(MyManager.manager, MyManager.varmap, fileheader);
ivarcnt = fileheader.varcnt;
break;
case BDDFILE_NODEDUMP:
if (params.inputfile == -1) {
printhelp(argc, arg);
fprintf(stderr, "Error: an input file is necessary for this type of loading file.\n");
return -1;
}
MyManager.manager = simpleBDDinit(fileheader.varcnt);
MyManager.t = HIGH(MyManager.manager);
MyManager.f = LOW(MyManager.manager);
MyManager.varmap = InitNamedVars(fileheader.varcnt, fileheader.varstart);
bdd = LoadNodeDump(MyManager.manager, MyManager.varmap, fileheader.inputfile);
ivarcnt = fileheader.varcnt;
break;
default:
fprintf(stderr, "Error: not a valid file format to load.\n");
return -1;
break;
}
}
alarm(0);
// problem specifics
if (bdd != NULL) {
ivarcnt = RepairVarcnt(&MyManager.varmap);
code = 0;
if (params.inputfile != -1) {
if (LoadVariableData(MyManager.varmap, arg[params.inputfile]) == -1) return -1;
if (!all_loaded(MyManager.varmap, 1)) return -1;
}
MyManager.his = InitHistory(ivarcnt);
if (params.method != 0) {
switch(arg[params.method][0]) {
case 'g':
for (i = 0; i < MyManager.varmap.varcnt; i++) {
if (MyManager.varmap.vars[i] != NULL) {
varpattern = extractpattern(MyManager.varmap.vars[i]);
if ((varpattern == NULL) || (!patterncalculated(varpattern, MyManager, i))) {
tvalue = CalcGradient(MyManager, bdd, i + MyManager.varmap.varstart, varpattern);
probability = tvalue.probability;
double factor = sigmoid(MyManager.varmap.dvalue[i], params.sigmoid_slope) * (1 - sigmoid(MyManager.varmap.dvalue[i], params.sigmoid_slope)) * params.sigmoid_slope;
if (varpattern == NULL) {
printf("query_gradient(%s,%s,%1.12f).\n", arg[params.queryid], MyManager.varmap.vars[i], tvalue.gradient * factor);
} else {
varpattern[strlen(varpattern) - 2] = '\0';
printf("query_gradient(%s,%s,%1.12f).\n", arg[params.queryid], varpattern, tvalue.gradient * factor);
}
ReInitHistory(MyManager.his, MyManager.varmap.varcnt);
}
if (varpattern != NULL) free(varpattern);
} else {
fprintf(stderr, "Error: no variable name given for parameter.\n");
}
}
if (probability < 0.0) {
// no nodes, so we have to calculate probability ourself
tvalue = CalcGradient(MyManager, bdd, 0 + MyManager.varmap.varstart, NULL);
probability = tvalue.probability;
}
printf("query_probability(%s,%1.12f).\n", arg[params.queryid], probability);
break;
case 'p':
printf("probability(%1.12f).\n", CalcProbability(MyManager, bdd));
break;
case 'o':
onlinetraverse(MyManager.manager, MyManager.varmap, MyManager.his, bdd);
break;
default:
myexpand(MyManager, bdd);
break;
}
} else {
myexpand(MyManager, bdd);
}
if (params.savedfile > -1) SaveNodeDump(MyManager.manager, MyManager.varmap, bdd, arg[params.savedfile]);
if (params.exportfile > -1) simpleNamedBDDtoDot(MyManager.manager, MyManager.varmap, bdd, arg[params.exportfile]);
ReInitHistory(MyManager.his, MyManager.varmap.varcnt);
free(MyManager.his);
}
if (MyManager.manager != NULL) {
KillBDD(MyManager.manager);
free(MyManager.varmap.dvalue);
free(MyManager.varmap.ivalue);
free(MyManager.varmap.dynvalue);
for (i = 0; i < MyManager.varmap.varcnt; i++)
free(MyManager.varmap.vars[i]);
free(MyManager.varmap.vars);
}
if (params.error != NULL) free(params.error);
return code;
}
/* Shell Parameters handling */
int argtype(const char *arg) {
if (strcmp(arg, "-l") == 0 || strcmp(arg, "--load") == 0) return 0;
if (strcmp(arg, "-e") == 0 || strcmp(arg, "--export") == 0) return 2;
if (strcmp(arg, "-m") == 0 || strcmp(arg, "--method") == 0) return 3;
if (strcmp(arg, "-i") == 0 || strcmp(arg, "--input") == 0) return 4;
if (strcmp(arg, "-h") == 0 || strcmp(arg, "--help") == 0) return 5;
if (strcmp(arg, "-d") == 0 || strcmp(arg, "--debug") == 0) return 6;
if (strcmp(arg, "-id") == 0 || strcmp(arg, "--queryid") == 0) return 7;
if (strcmp(arg, "-t") == 0 || strcmp(arg, "--timeout") == 0) return 8;
if (strcmp(arg, "-sd") == 0 || strcmp(arg, "--savedump") == 0) return 9;
if (strcmp(arg, "-sl") == 0 || strcmp(arg, "--slope") == 0) return 10;
if (strcmp(arg, "-o") == 0 || strcmp(arg, "--online") == 0) return 11;
if (strcmp(arg, "-bs") == 0 || strcmp(arg, "--bufsize") == 0) return 12;
if (strcmp(arg, "-pid") == 0 || strcmp(arg, "--pid") == 0) return 13;
return -1;
}
void printhelp(int argc, char **arg) {
fprintf(stderr, "\nUsage: %s -l [filename] -i [filename] -o (-s(d) [filename] -e [filename] -m [method] -id [queryid] -sl [double]) (-t [seconds] -d -h)\n", arg[0]);
fprintf(stderr, "Generates and traverses a BDD\nMandatory parameters:\n");
fprintf(stderr, "\t-l [filename]\t->\tfilename to load supports two formats:\n\t\t\t\t\t\t1. script with generation instructions\n\t\t\t\t\t\t2. node dump saved file\n");
fprintf(stderr, "\t-i [filename]\t->\tfilename to input problem specifics (mandatory with file formats 1, 2)\n");
fprintf(stderr, "\t-o\t\t->\tgenerates the BDD in online mode instead from a file can be used instead of -l\n");
fprintf(stderr, "Optional parameters:\n");
fprintf(stderr, "\t-sd [filename]\t->\tfilename to save generated BDD in node dump format (fast loading, traverse valid only)\n");
fprintf(stderr, "\t-e [filename]\t->\tfilename to export generated BDD in dot format\n");
fprintf(stderr, "\t-m [method]\t->\tthe calculation method to be used: none(default), [p]robability, [g]radient, [o]nline\n");
fprintf(stderr, "\t-id [queryid]\t->\tthe queries identity name (used by gradient) default: %s\n", arg[0]);
fprintf(stderr, "\t-sl [double]\t->\tthe sigmoid slope (used by gradient) default: 1.0\n");
fprintf(stderr, "Extra parameters:\n");
fprintf(stderr, "\t-t [seconds]\t->\tthe seconds (int) for BDD generation timeout default 0 = no timeout\n");
fprintf(stderr, "\t-pid [pid]\t->\ta process id (int) to check for termination default 0 = no process to check works only under POSIX OS\n");
fprintf(stderr, "\t-bs [bytes]\t->\tthe bytes (int) to use as a maximum buffer size to read files default 0 = no max\n");
fprintf(stderr, "\t-d\t\t->\tRun in debug mode (gives extra messages in stderr)\n");
fprintf(stderr, "\t-h\t\t->\tHelp (displays this message)\n\n");
fprintf(stderr, "Example: %s -l testbdd -i input.txt -m g -id testbdd\n", arg[0]);
}
parameters loadparam(int argc, char **arg) {
int i;
parameters params;
params.loadfile = -1;
params.savedfile = -1;
params.exportfile = -1;
params.method = 0;
params.inputfile = -1;
params.debug = 0;
params.errorcnt = 0;
params.queryid = 0;
params.timeout = 0;
params.sigmoid_slope = 1.0;
params.online = 0;
params.maxbufsize = 0;
params.ppid = NULL;
params.error = (int *) malloc(argc * sizeof(int));
for (i = 1; i < argc; i++) {
switch(argtype(arg[i])) {
case 0:
if (argc > i + 1) {
i++;
params.loadfile = i;
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 2:
if (argc > i + 1) {
i++;
params.exportfile = i;
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 3:
if (argc > i + 1) {
i++;
params.method = i;
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 4:
if (argc > i + 1) {
i++;
params.inputfile = i;
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 5:
printhelp(argc, arg);
break;
case 6:
params.debug = 1;
break;
case 7:
if (argc > i + 1) {
i++;
params.queryid = i;
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 8:
if ((argc > i + 1) && (IsPosNumber(arg[i + 1]))) {
i++;
params.timeout = atoi(arg[i]);
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 9:
if (argc > i + 1) {
i++;
params.savedfile = i;
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 10:
if ((argc > i + 1) && (IsRealNumber(arg[i + 1]))) {
i++;
params.sigmoid_slope = atof(arg[i]);
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 11:
params.online = 1;
break;
case 12:
if ((argc > i + 1) && (IsPosNumber(arg[i + 1]))) {
i++;
params.maxbufsize = atoi(arg[i]);
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
case 13:
if ((argc > i + 1) && (IsPosNumber(arg[i + 1]))) {
i++;
params.ppid = (char *) malloc(sizeof(char) * (strlen(arg[i]) + 1));
strcpy(params.ppid, arg[i]);
} else {
params.error[params.errorcnt] = i;
params.errorcnt++;
}
break;
default:
params.error[params.errorcnt] = i;
params.errorcnt++;
break;
}
}
return params;
}
/* Error Handlers */
void handler(int num) {
fprintf(stderr, "Error: Timeout %i exceeded.\n", params.timeout);
exit(-1);
}
void pidhandler(int num) {
char *s;
if (params.timeout > 0) {
params.timeout -= 5;
if (params.timeout <= 0) {
fprintf(stderr, "Error: Timeout exceeded.\n");
exit(-1);
}
}
s = (char *) malloc(sizeof(char) * (19 + strlen(params.ppid)));
strcpy(s, "ps "); strcat(s, params.ppid); strcat(s, " >/dev/null");
if (system(s) != 0) exit(4);
signal(SIGALRM, pidhandler);
alarm(5);
free(s);
}
void termhandler(int num) {
exit(3);
}
/* General Functions */
double sigmoid(double x, double slope) {
return 1 / (1 + exp(-x * slope));
}
/* Debugging traverse function */
void myexpand(extmanager MyManager, DdNode *Current) {
DdNode *h, *l;
hisnode *Found;
char *curnode;
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
printf("%s\n", curnode);
if ((Current != MyManager.t) && (Current != MyManager.f) &&
((Found = GetNode(MyManager.his, MyManager.varmap.varstart, Current)) == NULL)) {
l = LowNodeOf(MyManager.manager, Current);
h = HighNodeOf(MyManager.manager, Current);
printf("l(%s)->", curnode);
myexpand(MyManager, l);
printf("h(%s)->", curnode);
myexpand(MyManager, h);
AddNode(MyManager.his, MyManager.varmap.varstart, Current, 0.0, 0, NULL);
}
}
/* Angelikas Algorithm */
double CalcProbability(extmanager MyManager, DdNode *Current) {
DdNode *h, *l;
hisnode *Found;
char *curnode;
double lvalue, hvalue, tvalue;
if (params.debug) {
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
fprintf(stderr, "%s\n", curnode);
}
if (Current == MyManager.t) return 1.0;
if (Current == MyManager.f) return 0.0;
if ((Found = GetNode(MyManager.his, MyManager.varmap.varstart, Current)) != NULL) return Found->dvalue;
l = LowNodeOf(MyManager.manager, Current);
h = HighNodeOf(MyManager.manager, Current);
if (params.debug) fprintf(stderr, "l(%s)->", curnode);
lvalue = CalcProbability(MyManager, l);
if (params.debug) fprintf(stderr, "h(%s)->", curnode);
hvalue = CalcProbability(MyManager, h);
tvalue = MyManager.varmap.dvalue[GetIndex(Current) - MyManager.varmap.varstart];
tvalue = tvalue * hvalue + lvalue * (1.0 - tvalue);
AddNode(MyManager.his, MyManager.varmap.varstart, Current, tvalue, 0, NULL);
return tvalue;
}
/* Bernds Algorithm */
gradientpair CalcGradient(extmanager MyManager, DdNode *Current, int TargetVar, char *TargetPattern) {
DdNode *h, *l;
hisnode *Found;
char *curnode;
gradientpair lvalue, hvalue, tvalue;
double this_probability;
double *gradient;
if (params.debug) {
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
fprintf(stderr, "%s\n", curnode);
}
if (Current == MyManager.t) {
tvalue.probability = 1.0;
tvalue.gradient = 0.0;
return tvalue;
}
if (Current == MyManager.f) {
tvalue.probability = 0.0;
tvalue.gradient = 0.0;
return tvalue;
}
if ((Found = GetNode(MyManager.his, MyManager.varmap.varstart, Current)) != NULL) {
tvalue.probability = Found->dvalue;
tvalue.gradient = *((double *) Found->dynvalue);
return tvalue;
}
l = LowNodeOf(MyManager.manager, Current);
h = HighNodeOf(MyManager.manager, Current);
if (params.debug) fprintf(stderr, "l(%s)->", curnode);
lvalue = CalcGradient(MyManager, l, TargetVar, TargetPattern);
if (params.debug) fprintf(stderr, "h(%s)->", curnode);
hvalue = CalcGradient(MyManager, h, TargetVar, TargetPattern);
this_probability = sigmoid(MyManager.varmap.dvalue[GetIndex(Current) - MyManager.varmap.varstart], params.sigmoid_slope);
tvalue.probability = this_probability * hvalue.probability + (1 - this_probability) * lvalue.probability;
tvalue.gradient = this_probability * hvalue.gradient + (1 - this_probability) * lvalue.gradient;
if ((GetIndex(Current) == TargetVar) ||
((TargetPattern != NULL) && patternmatch(TargetPattern, MyManager.varmap.vars[GetIndex(Current)]))) {
tvalue.gradient += hvalue.probability - lvalue.probability;
}
gradient = (double *) malloc(sizeof(double));
*gradient = tvalue.gradient;
AddNode(MyManager.his, MyManager.varmap.varstart, Current, tvalue.probability, 0, gradient);
return tvalue;
}
char * extractpattern(char *thestr) {
char *p;
int i = 0, sl = strlen(thestr);
while((thestr[i] != '_') && (i < sl)) i++;
if (i == sl) return NULL;
i++;
p = (char *) malloc(sizeof(char) * (i + 2));
strncpy(p, thestr, i);
p[i] = '*';
p[i + 1] = '\0';
return p;
}
int patterncalculated(char *pattern, extmanager MyManager, int loc) {
int i;
if (pattern == NULL) return 0;
for (i = loc - 1; i > -1; i--)
if (patternmatch(pattern, MyManager.varmap.vars[i])) return 1;
return 0;
}

141
packages/ProbLog/simplecudd/SimpleCUDD.pl Normal file
View File

@ -0,0 +1,141 @@
:-use_module(library(system)).
%:-use_module(library(clib)).
bdd_init(FDO, FDI, PID):-
exec('/home/theo/BDDs/SimpleCUDD/Version4/Example -online', [pipe(FDO), pipe(FDI), std], PID).
%process_create('/home/theo/BDDs/SimpleCUDD/Version3/Example', ['-online'], [stdin(pipe(FDI)), stdout(pipe(FDO)), process(PID)]).
bdd_commit(FDO, LINE):-
write(FDO, LINE),
write(FDO, '\n').
bdd_kill(FDO, FDI, PID, S):-
bdd_commit(FDO, '@e'),
wait(PID, S),
%process_wait(PID, S),
close(FDO),
close(FDI).
bdd_line([], X, _, L):-
atomic(X),
X \= [],
(bdd_curinter(N) ->
retract(bdd_curinter(N))
;
N = 1
),
M is N + 1,
assert(bdd_curinter(M)),
atomic_concat(['L', N, '=', X], L).
bdd_line(L, X, O, NL):-
atomic(X),
X \= [],
atom(L),
L \= [],
atomic_concat([L, O, X], NL).
bdd_line(L, [], _, L):-!.
bdd_line(L, [X|T], O, R):-
bdd_line(L, X, O, NL),
bdd_line(NL, T, O, R).
bdd_AND(L, X, NL):-
bdd_line(L, X, '*', NL).
bdd_OR(L, X, NL):-
bdd_line(L, X, '+', NL).
bdd_XOR(L, X, NL):-
bdd_line(L, X, '#', NL).
bdd_NAND(L, X, NL):-
bdd_line(L, X, '~*', NL).
bdd_NOR(L, X, NL):-
bdd_line(L, X, '~+', NL).
bdd_XNOR(L, X, NL):-
bdd_line(L, X, '~#', NL).
bdd_not(X, NX):-
atomic(X),
atomic_concat(['~', X], NX).
bdd_laststep(L):-
bdd_curinter(N),
M is N - 1,
atomic_concat(['L', M], L),
!.
bdd_nextDFS(FDO):-
bdd_commit(FDO, '@n').
bdd_nextBFS(FDO):-
bdd_commit(FDO, '@n,BFS').
bdd_current(FDO, FDI, N, Qcnt):-
bdd_commit(FDO, '@c'),
read(FDI, F),
assert(F),
bdd_temp_value(N, Qcnt),
retract(F).
bdd_highnodeof(FDO, FDI, H):-
bdd_commit(FDO, '@h'),
read(FDI, F),
assert(F),
bdd_temp_value(H),
retract(F).
bdd_lownodeof(FDO, FDI, L):-
bdd_commit(FDO, '@l'),
read(FDI, F),
assert(F),
bdd_temp_value(L),
retract(F).
bdd_nodevaluesof(FDO, FDI, N, V):-
atomic_concat(['@v,', N], Q),
bdd_commit(FDO, Q),
read(FDI, F),
assert(F),
bdd_temp_value(V),
retract(F).
/*
bdd_addnodetohis(FDO, N, [D, I, Dyn]):-
atomic_concat(['@a,', N, ',', D, ',', I, ',', Dyn], Q),
bdd_commit(FDO, Q).
bdd_getnodefromhis(FDO, FDI, N, V):-
atomic_concat(['@g,', N], Q),
bdd_commit(FDO, Q),
read(FDI, F),
assert(F),
bdd_temp_value(V),
retract(F).
*/
runme:-
bdd_init(FDO, FDI, PID),
bdd_AND([], ['A', 'B', 'C', 'D', 'E'], L1),
bdd_laststep(L1S),
bdd_commit(FDO, L1),
bdd_AND([], ['A', 'F', 'G', '~B'], L2),
bdd_laststep(L2S),
bdd_commit(FDO, L2),
bdd_AND([], ['A', 'F', 'G', '~C'], L3),
bdd_laststep(L3S),
bdd_commit(FDO, L3),
bdd_OR([], [L1S, L2S, L3S], L4),
bdd_laststep(L4S),
bdd_commit(FDO, L4),
bdd_commit(FDO, L4S),
repeat,
bdd_current(FDO, FDI, N, I),
write(1),nl,
bdd_nodevaluesof(FDO, FDI, N, V),
write(N), write(' ('), write(V), write(')'), nl,
bdd_next(FDO),
I = 0, (N = 'TRUE' ; N = 'FALSE'),
bdd_kill(FDO, FDI, PID, S),
write('BDD terminated with state: '), write(S), nl.

234
packages/ProbLog/simplecudd/general.c Normal file
View File

@ -0,0 +1,234 @@
/******************************************************************************\
* *
* SimpleCUDD library (www.cs.kuleuven.be/~theo/tools/simplecudd.html) *
* SimpleCUDD was developed at Katholieke Universiteit Leuven(www.kuleuven.be) *
* *
* Copyright T. Mantadelis and Katholieke Universiteit Leuven 2008 *
* *
* Author: Theofrastos Mantadelis *
* File: general.c *
* *
********************************************************************************
* *
* The "Artistic License" *
* *
* Preamble *
* *
* The intent of this document is to state the conditions under which a *
* Package may be copied, such that the Copyright Holder maintains some *
* semblance of artistic control over the development of the package, *
* while giving the users of the package the right to use and distribute *
* the Package in a more-or-less customary fashion, plus the right to make *
* reasonable modifications. *
* *
* Definitions: *
* *
* "Package" refers to the collection of files distributed by the *
* Copyright Holder, and derivatives of that collection of files *
* created through textual modification. *
* *
* "Standard Version" refers to such a Package if it has not been *
* modified, or has been modified in accordance with the wishes *
* of the Copyright Holder as specified below. *
* *
* "Copyright Holder" is whoever is named in the copyright or *
* copyrights for the package. *
* *
* "You" is you, if you're thinking about copying or distributing *
* this Package. *
* *
* "Reasonable copying fee" is whatever you can justify on the *
* basis of media cost, duplication charges, time of people involved, *
* and so on. (You will not be required to justify it to the *
* Copyright Holder, but only to the computing community at large *
* as a market that must bear the fee.) *
* *
* "Freely Available" means that no fee is charged for the item *
* itself, though there may be fees involved in handling the item. *
* It also means that recipients of the item may redistribute it *
* under the same conditions they received it. *
* *
* 1. You may make and give away verbatim copies of the source form of the *
* Standard Version of this Package without restriction, provided that you *
* duplicate all of the original copyright notices and associated disclaimers. *
* *
* 2. You may apply bug fixes, portability fixes and other modifications *
* derived from the Public Domain or from the Copyright Holder. A Package *
* modified in such a way shall still be considered the Standard Version. *
* *
* 3. You may otherwise modify your copy of this Package in any way, provided *
* that you insert a prominent notice in each changed file stating how and *
* when you changed that file, and provided that you do at least ONE of the *
* following: *
* *
* a) place your modifications in the Public Domain or otherwise make them *
* Freely Available, such as by posting said modifications to Usenet or *
* an equivalent medium, or placing the modifications on a major archive *
* site such as uunet.uu.net, or by allowing the Copyright Holder to include *
* your modifications in the Standard Version of the Package. *
* *
* b) use the modified Package only within your corporation or organization. *
* *
* c) rename any non-standard executables so the names do not conflict *
* with standard executables, which must also be provided, and provide *
* a separate manual page for each non-standard executable that clearly *
* documents how it differs from the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 4. You may distribute the programs of this Package in object code or *
* executable form, provided that you do at least ONE of the following: *
* *
* a) distribute a Standard Version of the executables and library files, *
* together with instructions (in the manual page or equivalent) on where *
* to get the Standard Version. *
* *
* b) accompany the distribution with the machine-readable source of *
* the Package with your modifications. *
* *
* c) give non-standard executables non-standard names, and clearly *
* document the differences in manual pages (or equivalent), together *
* with instructions on where to get the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 5. You may charge a reasonable copying fee for any distribution of this *
* Package. You may charge any fee you choose for support of this *
* Package. You may not charge a fee for this Package itself. However, *
* you may distribute this Package in aggregate with other (possibly *
* commercial) programs as part of a larger (possibly commercial) software *
* distribution provided that you do not advertise this Package as a *
* product of your own. You may embed this Package's interpreter within *
* an executable of yours (by linking); this shall be construed as a mere *
* form of aggregation, provided that the complete Standard Version of the *
* interpreter is so embedded. *
* *
* 6. The scripts and library files supplied as input to or produced as *
* output from the programs of this Package do not automatically fall *
* under the copyright of this Package, but belong to whoever generated *
* them, and may be sold commercially, and may be aggregated with this *
* Package. If such scripts or library files are aggregated with this *
* Package via the so-called "undump" or "unexec" methods of producing a *
* binary executable image, then distribution of such an image shall *
* neither be construed as a distribution of this Package nor shall it *
* fall under the restrictions of Paragraphs 3 and 4, provided that you do *
* not represent such an executable image as a Standard Version of this *
* Package. *
* *
* 7. C subroutines (or comparably compiled subroutines in other *
* languages) supplied by you and linked into this Package in order to *
* emulate subroutines and variables of the language defined by this *
* Package shall not be considered part of this Package, but are the *
* equivalent of input as in Paragraph 6, provided these subroutines do *
* not change the language in any way that would cause it to fail the *
* regression tests for the language. *
* *
* 8. Aggregation of this Package with a commercial distribution is always *
* permitted provided that the use of this Package is embedded; that is, *
* when no overt attempt is made to make this Package's interfaces visible *
* to the end user of the commercial distribution. Such use shall not be *
* construed as a distribution of this Package. *
* *
* 9. The name of the Copyright Holder may not be used to endorse or promote *
* products derived from this software without specific prior written *
* permission. *
* *
* 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR *
* IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED *
* WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. *
* *
* The End *
* *
\******************************************************************************/
#include "general.h"
/* Number Handling */
int IsRealNumber(char *c) {
int i, l;
l = strlen(c);
if (l <= 0) return 0;
if (l == 1) return IsNumberDigit(c[0]);
for(i = 1; i < strlen(c); i++) {
if (c[i] == '.') return IsPosNumber(&c[i + 1]);
if (!IsNumberDigit(c[i])) return 0;
}
return (IsNumberDigit(c[0]) || IsSignDigit(c[0]));
}
int IsPosNumber(const char *c) {
int i, l;
l = strlen(c);
if (l <= 0) return 0;
for(i = 0; i < strlen(c); i++) {
if (!IsNumberDigit(c[i])) return 0;
}
return 1;
}
int IsNumber(const char *c) {
int i, l;
l = strlen(c);
if (l <= 0) return 0;
if (l == 1) return IsNumberDigit(c[0]);
for(i = 1; i < strlen(c); i++) {
if (!IsNumberDigit(c[i])) return 0;
}
return (IsNumberDigit(c[0]) || IsSignDigit(c[0]));
}
/* File Handling */
char * freadstr(FILE *fd, const char *separators) {
char *str;
int buf, icur = 0, max = 10;
str = (char *) malloc(sizeof(char) * max);
str[0] = '\0';
do {
if ((buf = fgetc(fd)) != EOF) {
if (icur == (max - 1)) {
max = max * 2;
str = (char *) realloc(str, sizeof(char) * max);
}
if (!CharIn((char) buf, separators)) {
str[icur] = (char) buf;
icur++;
str[icur] = '\0';
}
}
} while(!CharIn(buf, separators) && !feof(fd));
return str;
}
int CharIn(const char c, const char *in) {
int i;
for (i = 0; i < strlen(in); i++)
if (c == in[i]) return 1;
return 0;
}
/* string handling */
int patternmatch(char *pattern, char *thestr) {
int i, j = -1, pl = strlen(pattern), sl = strlen(thestr);
for(i = 0; i < pl; i++) {
if (pattern[i] == '*') {
do {
i++;
if (i == pl) return 1;
} while(pattern[i] == '*');
do {
j++;
if (j >= sl) return 0;
if ((thestr[j] == pattern[i]) && patternmatch(pattern + i, thestr + j)) return 1;
} while(1);
} else {
j++;
if (j >= sl) return 0;
if (pattern[i] != thestr[j]) return 0;
}
}
return (pl == sl);
}

159
packages/ProbLog/simplecudd/general.h Normal file
View File

@ -0,0 +1,159 @@
/******************************************************************************\
* *
* SimpleCUDD library (www.cs.kuleuven.be/~theo/tools/simplecudd.html) *
* SimpleCUDD was developed at Katholieke Universiteit Leuven(www.kuleuven.be) *
* *
* Copyright T. Mantadelis and Katholieke Universiteit Leuven 2008 *
* *
* Author: Theofrastos Mantadelis *
* File: general.h *
* *
********************************************************************************
* *
* The "Artistic License" *
* *
* Preamble *
* *
* The intent of this document is to state the conditions under which a *
* Package may be copied, such that the Copyright Holder maintains some *
* semblance of artistic control over the development of the package, *
* while giving the users of the package the right to use and distribute *
* the Package in a more-or-less customary fashion, plus the right to make *
* reasonable modifications. *
* *
* Definitions: *
* *
* "Package" refers to the collection of files distributed by the *
* Copyright Holder, and derivatives of that collection of files *
* created through textual modification. *
* *
* "Standard Version" refers to such a Package if it has not been *
* modified, or has been modified in accordance with the wishes *
* of the Copyright Holder as specified below. *
* *
* "Copyright Holder" is whoever is named in the copyright or *
* copyrights for the package. *
* *
* "You" is you, if you're thinking about copying or distributing *
* this Package. *
* *
* "Reasonable copying fee" is whatever you can justify on the *
* basis of media cost, duplication charges, time of people involved, *
* and so on. (You will not be required to justify it to the *
* Copyright Holder, but only to the computing community at large *
* as a market that must bear the fee.) *
* *
* "Freely Available" means that no fee is charged for the item *
* itself, though there may be fees involved in handling the item. *
* It also means that recipients of the item may redistribute it *
* under the same conditions they received it. *
* *
* 1. You may make and give away verbatim copies of the source form of the *
* Standard Version of this Package without restriction, provided that you *
* duplicate all of the original copyright notices and associated disclaimers. *
* *
* 2. You may apply bug fixes, portability fixes and other modifications *
* derived from the Public Domain or from the Copyright Holder. A Package *
* modified in such a way shall still be considered the Standard Version. *
* *
* 3. You may otherwise modify your copy of this Package in any way, provided *
* that you insert a prominent notice in each changed file stating how and *
* when you changed that file, and provided that you do at least ONE of the *
* following: *
* *
* a) place your modifications in the Public Domain or otherwise make them *
* Freely Available, such as by posting said modifications to Usenet or *
* an equivalent medium, or placing the modifications on a major archive *
* site such as uunet.uu.net, or by allowing the Copyright Holder to include *
* your modifications in the Standard Version of the Package. *
* *
* b) use the modified Package only within your corporation or organization. *
* *
* c) rename any non-standard executables so the names do not conflict *
* with standard executables, which must also be provided, and provide *
* a separate manual page for each non-standard executable that clearly *
* documents how it differs from the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 4. You may distribute the programs of this Package in object code or *
* executable form, provided that you do at least ONE of the following: *
* *
* a) distribute a Standard Version of the executables and library files, *
* together with instructions (in the manual page or equivalent) on where *
* to get the Standard Version. *
* *
* b) accompany the distribution with the machine-readable source of *
* the Package with your modifications. *
* *
* c) give non-standard executables non-standard names, and clearly *
* document the differences in manual pages (or equivalent), together *
* with instructions on where to get the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 5. You may charge a reasonable copying fee for any distribution of this *
* Package. You may charge any fee you choose for support of this *
* Package. You may not charge a fee for this Package itself. However, *
* you may distribute this Package in aggregate with other (possibly *
* commercial) programs as part of a larger (possibly commercial) software *
* distribution provided that you do not advertise this Package as a *
* product of your own. You may embed this Package's interpreter within *
* an executable of yours (by linking); this shall be construed as a mere *
* form of aggregation, provided that the complete Standard Version of the *
* interpreter is so embedded. *
* *
* 6. The scripts and library files supplied as input to or produced as *
* output from the programs of this Package do not automatically fall *
* under the copyright of this Package, but belong to whoever generated *
* them, and may be sold commercially, and may be aggregated with this *
* Package. If such scripts or library files are aggregated with this *
* Package via the so-called "undump" or "unexec" methods of producing a *
* binary executable image, then distribution of such an image shall *
* neither be construed as a distribution of this Package nor shall it *
* fall under the restrictions of Paragraphs 3 and 4, provided that you do *
* not represent such an executable image as a Standard Version of this *
* Package. *
* *
* 7. C subroutines (or comparably compiled subroutines in other *
* languages) supplied by you and linked into this Package in order to *
* emulate subroutines and variables of the language defined by this *
* Package shall not be considered part of this Package, but are the *
* equivalent of input as in Paragraph 6, provided these subroutines do *
* not change the language in any way that would cause it to fail the *
* regression tests for the language. *
* *
* 8. Aggregation of this Package with a commercial distribution is always *
* permitted provided that the use of this Package is embedded; that is, *
* when no overt attempt is made to make this Package's interfaces visible *
* to the end user of the commercial distribution. Such use shall not be *
* construed as a distribution of this Package. *
* *
* 9. The name of the Copyright Holder may not be used to endorse or promote *
* products derived from this software without specific prior written *
* permission. *
* *
* 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR *
* IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED *
* WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. *
* *
* The End *
* *
\******************************************************************************/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#define IsNumberDigit(c) ('0' <= c && c <= '9')
#define IsSignDigit(c) (c == '+' || c == '-')
#define isOperator(x) (x == '+' || x == '*' || x == '#' || x == '=')
#define freadline(fd) freadstr(fd, "\n");
int IsRealNumber(char *c);
int IsPosNumber(const char *c);
int IsNumber(const char *c);
char * freadstr(FILE *fd, const char *separators);
int CharIn(const char c, const char *in);
int patternmatch(char *pattern, char *thestr);

1620
packages/ProbLog/simplecudd/simplecudd.c Normal file
View File

File diff suppressed because it is too large Load Diff

287
packages/ProbLog/simplecudd/simplecudd.h Normal file
View File

@ -0,0 +1,287 @@
/******************************************************************************\
* *
* SimpleCUDD library (www.cs.kuleuven.be/~theo/tools/simplecudd.html) *
* SimpleCUDD was developed at Katholieke Universiteit Leuven(www.kuleuven.be) *
* *
* Copyright T. Mantadelis and Katholieke Universiteit Leuven 2008 *
* *
* Author: Theofrastos Mantadelis *
* File: simplecudd.h *
* *
********************************************************************************
* *
* The "Artistic License" *
* *
* Preamble *
* *
* The intent of this document is to state the conditions under which a *
* Package may be copied, such that the Copyright Holder maintains some *
* semblance of artistic control over the development of the package, *
* while giving the users of the package the right to use and distribute *
* the Package in a more-or-less customary fashion, plus the right to make *
* reasonable modifications. *
* *
* Definitions: *
* *
* "Package" refers to the collection of files distributed by the *
* Copyright Holder, and derivatives of that collection of files *
* created through textual modification. *
* *
* "Standard Version" refers to such a Package if it has not been *
* modified, or has been modified in accordance with the wishes *
* of the Copyright Holder as specified below. *
* *
* "Copyright Holder" is whoever is named in the copyright or *
* copyrights for the package. *
* *
* "You" is you, if you're thinking about copying or distributing *
* this Package. *
* *
* "Reasonable copying fee" is whatever you can justify on the *
* basis of media cost, duplication charges, time of people involved, *
* and so on. (You will not be required to justify it to the *
* Copyright Holder, but only to the computing community at large *
* as a market that must bear the fee.) *
* *
* "Freely Available" means that no fee is charged for the item *
* itself, though there may be fees involved in handling the item. *
* It also means that recipients of the item may redistribute it *
* under the same conditions they received it. *
* *
* 1. You may make and give away verbatim copies of the source form of the *
* Standard Version of this Package without restriction, provided that you *
* duplicate all of the original copyright notices and associated disclaimers. *
* *
* 2. You may apply bug fixes, portability fixes and other modifications *
* derived from the Public Domain or from the Copyright Holder. A Package *
* modified in such a way shall still be considered the Standard Version. *
* *
* 3. You may otherwise modify your copy of this Package in any way, provided *
* that you insert a prominent notice in each changed file stating how and *
* when you changed that file, and provided that you do at least ONE of the *
* following: *
* *
* a) place your modifications in the Public Domain or otherwise make them *
* Freely Available, such as by posting said modifications to Usenet or *
* an equivalent medium, or placing the modifications on a major archive *
* site such as uunet.uu.net, or by allowing the Copyright Holder to include *
* your modifications in the Standard Version of the Package. *
* *
* b) use the modified Package only within your corporation or organization. *
* *
* c) rename any non-standard executables so the names do not conflict *
* with standard executables, which must also be provided, and provide *
* a separate manual page for each non-standard executable that clearly *
* documents how it differs from the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 4. You may distribute the programs of this Package in object code or *
* executable form, provided that you do at least ONE of the following: *
* *
* a) distribute a Standard Version of the executables and library files, *
* together with instructions (in the manual page or equivalent) on where *
* to get the Standard Version. *
* *
* b) accompany the distribution with the machine-readable source of *
* the Package with your modifications. *
* *
* c) give non-standard executables non-standard names, and clearly *
* document the differences in manual pages (or equivalent), together *
* with instructions on where to get the Standard Version. *
* *
* d) make other distribution arrangements with the Copyright Holder. *
* *
* 5. You may charge a reasonable copying fee for any distribution of this *
* Package. You may charge any fee you choose for support of this *
* Package. You may not charge a fee for this Package itself. However, *
* you may distribute this Package in aggregate with other (possibly *
* commercial) programs as part of a larger (possibly commercial) software *
* distribution provided that you do not advertise this Package as a *
* product of your own. You may embed this Package's interpreter within *
* an executable of yours (by linking); this shall be construed as a mere *
* form of aggregation, provided that the complete Standard Version of the *
* interpreter is so embedded. *
* *
* 6. The scripts and library files supplied as input to or produced as *
* output from the programs of this Package do not automatically fall *
* under the copyright of this Package, but belong to whoever generated *
* them, and may be sold commercially, and may be aggregated with this *
* Package. If such scripts or library files are aggregated with this *
* Package via the so-called "undump" or "unexec" methods of producing a *
* binary executable image, then distribution of such an image shall *
* neither be construed as a distribution of this Package nor shall it *
* fall under the restrictions of Paragraphs 3 and 4, provided that you do *
* not represent such an executable image as a Standard Version of this *
* Package. *
* *
* 7. C subroutines (or comparably compiled subroutines in other *
* languages) supplied by you and linked into this Package in order to *
* emulate subroutines and variables of the language defined by this *
* Package shall not be considered part of this Package, but are the *
* equivalent of input as in Paragraph 6, provided these subroutines do *
* not change the language in any way that would cause it to fail the *
* regression tests for the language. *
* *
* 8. Aggregation of this Package with a commercial distribution is always *
* permitted provided that the use of this Package is embedded; that is, *
* when no overt attempt is made to make this Package's interfaces visible *
* to the end user of the commercial distribution. Such use shall not be *
* construed as a distribution of this Package. *
* *
* 9. The name of the Copyright Holder may not be used to endorse or promote *
* products derived from this software without specific prior written *
* permission. *
* *
* 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR *
* IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED *
* WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. *
* *
* The End *
* *
\******************************************************************************/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <time.h>
#include "util.h"
#include "cudd.h"
#include "cuddInt.h"
#include "general.h"
#define IsHigh(manager, node) HIGH(manager) == node
#define IsLow(manager, node) LOW(manager) == node
#define HIGH(manager) Cudd_ReadOne(manager)
#define LOW(manager) Cudd_Not(Cudd_ReadOne(manager))
#define NOT(node) Cudd_Not(node)
#define GetIndex(node) Cudd_NodeReadIndex(node)
#define GetVar(manager, index) Cudd_bddIthVar(manager, index)
#define NewVar(manager) Cudd_bddNewVar(manager)
#define KillBDD(manager) Cudd_Quit(manager)
#define GetVarCount(manager) Cudd_ReadSize(manager)
#define DEBUGON _debug = 1
#define DEBUGOFF _debug = 0
#define RAPIDLOADON _RapidLoad = 1
#define RAPIDLOADOFF _RapidLoad = 0
#define SETMAXBUFSIZE(size) _maxbufsize = size
#define BDDFILE_ERROR -1
#define BDDFILE_OTHER 0
#define BDDFILE_SCRIPT 1
#define BDDFILE_NODEDUMP 2
extern int _RapidLoad;
extern int _debug;
extern int _maxbufsize;
typedef struct _bddfileheader {
FILE *inputfile;
int version;
int varcnt;
int varstart;
int intercnt;
int filetype;
} bddfileheader;
typedef struct _namedvars {
int varcnt;
int varstart;
char **vars;
int *loaded;
double *dvalue;
int *ivalue;
void **dynvalue;
} namedvars;
typedef struct _hisnode {
DdNode *key;
double dvalue;
int ivalue;
void *dynvalue;
} hisnode;
typedef struct _hisqueue {
int cnt;
hisnode *thenode;
} hisqueue;
typedef struct _nodeline {
char *varname;
char *truevar;
char *falsevar;
int nodenum;
int truenode;
int falsenode;
} nodeline;
/* Initialization */
DdManager* simpleBDDinit(int varcnt);
/* BDD Generation */
DdNode* D_BDDAnd(DdManager *manager, DdNode *bdd1, DdNode *bdd2);
DdNode* D_BDDNand(DdManager *manager, DdNode *bdd1, DdNode *bdd2);
DdNode* D_BDDOr(DdManager *manager, DdNode *bdd1, DdNode *bdd2);
DdNode* D_BDDNor(DdManager *manager, DdNode *bdd1, DdNode *bdd2);
DdNode* D_BDDXor(DdManager *manager, DdNode *bdd1, DdNode *bdd2);
DdNode* D_BDDXnor(DdManager *manager, DdNode *bdd1, DdNode *bdd2);
DdNode* FileGenerateBDD(DdManager *manager, namedvars varmap, bddfileheader fileheader);
DdNode* OnlineGenerateBDD(DdManager *manager, namedvars *varmap);
DdNode* LineParser(DdManager *manager, namedvars varmap, DdNode **inter, int maxinter, char *function, int iline);
DdNode* OnlineLineParser(DdManager *manager, namedvars *varmap, DdNode **inter, int maxinter, char *function, int iline);
DdNode* BDD_Operator(DdManager *manager, DdNode *bdd1, DdNode *bdd2, char Operator, int inegoper);
int getInterBDD(char *function);
char* getFileName(const char *function);
int GetParam(char *inputline, int iParam);
int LoadVariableData(namedvars varmap, char *filename);
/* Named variables */
namedvars InitNamedVars(int varcnt, int varstart);
void EnlargeNamedVars(namedvars *varmap, int newvarcnt);
int AddNamedVarAt(namedvars varmap, const char *varname, int index);
int AddNamedVar(namedvars varmap, const char *varname);
void SetNamedVarValuesAt(namedvars varmap, int index, double dvalue, int ivalue, void *dynvalue);
int SetNamedVarValues(namedvars varmap, const char *varname, double dvalue, int ivalue, void *dynvalue);
int GetNamedVarIndex(const namedvars varmap, const char *varname);
int RepairVarcnt(namedvars *varmap);
char* GetNodeVarName(DdManager *manager, namedvars varmap, DdNode *node);
char* GetNodeVarNameDisp(DdManager *manager, namedvars varmap, DdNode *node);
int all_loaded(namedvars varmap, int disp);
/* Traversal */
DdNode* HighNodeOf(DdManager *manager, DdNode *node);
DdNode* LowNodeOf(DdManager *manager, DdNode *node);
/* Traversal - History */
hisqueue* InitHistory(int varcnt);
void ReInitHistory(hisqueue *HisQueue, int varcnt);
void AddNode(hisqueue *HisQueue, int varstart, DdNode *node, double dvalue, int ivalue, void *dynvalue);
hisnode* GetNode(hisqueue *HisQueue, int varstart, DdNode *node);
int GetNodeIndex(hisqueue *HisQueue, int varstart, DdNode *node);
void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, DdNode *bdd);
/* Save-load */
bddfileheader ReadFileHeader(char *filename);
int CheckFileVersion(const char *version);
DdNode * LoadNodeDump(DdManager *manager, namedvars varmap, FILE *inputfile);
DdNode * LoadNodeRec(DdManager *manager, namedvars varmap, hisqueue *Nodes, FILE *inputfile, nodeline current);
DdNode * GetIfExists(DdManager *manager, namedvars varmap, hisqueue *Nodes, char *varname, int nodenum);
int SaveNodeDump(DdManager *manager, namedvars varmap, DdNode *bdd, char *filename);
void SaveExpand(DdManager *manager, namedvars varmap, hisqueue *Nodes, DdNode *Current, FILE *outputfile);
void ExpandNodes(hisqueue *Nodes, int index, int nodenum);
/* Export */
int simpleBDDtoDot(DdManager *manager, DdNode *bdd, char *filename);
int simpleNamedBDDtoDot(DdManager *manager, namedvars varmap, DdNode *bdd, char *filename);

201
packages/cplint/Artistic Normal file
View File

@ -0,0 +1,201 @@
The Artistic License 2.0
Copyright (c) 2000-2006, The Perl Foundation.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
This license establishes the terms under which a given free software
Package may be copied, modified, distributed, and/or redistributed.
The intent is that the Copyright Holder maintains some artistic
control over the development of that Package while still keeping the
Package available as open source and free software.
You are always permitted to make arrangements wholly outside of this
license directly with the Copyright Holder of a given Package. If the
terms of this license do not permit the full use that you propose to
make of the Package, you should contact the Copyright Holder and seek
a different licensing arrangement.
Definitions
"Copyright Holder" means the individual(s) or organization(s)
named in the copyright notice for the entire Package.
"Contributor" means any party that has contributed code or other
material to the Package, in accordance with the Copyright Holder's
procedures.
"You" and "your" means any person who would like to copy,
distribute, or modify the Package.
"Package" means the collection of files distributed by the
Copyright Holder, and derivatives of that collection and/or of
those files. A given Package may consist of either the Standard
Version, or a Modified Version.
"Distribute" means providing a copy of the Package or making it
accessible to anyone else, or in the case of a company or
organization, to others outside of your company or organization.
"Distributor Fee" means any fee that you charge for Distributing
this Package or providing support for this Package to another
party. It does not mean licensing fees.
"Standard Version" refers to the Package if it has not been
modified, or has been modified only in ways explicitly requested
by the Copyright Holder.
"Modified Version" means the Package, if it has been changed, and
such changes were not explicitly requested by the Copyright
Holder.
"Original License" means this Artistic License as Distributed with
the Standard Version of the Package, in its current version or as
it may be modified by The Perl Foundation in the future.
"Source" form means the source code, documentation source, and
configuration files for the Package.
"Compiled" form means the compiled bytecode, object code, binary,
or any other form resulting from mechanical transformation or
translation of the Source form.
Permission for Use and Modification Without Distribution
(1) You are permitted to use the Standard Version and create and use
Modified Versions for any purpose without restriction, provided that
you do not Distribute the Modified Version.
Permissions for Redistribution of the Standard Version
(2) You may Distribute verbatim copies of the Source form of the
Standard Version of this Package in any medium without restriction,
either gratis or for a Distributor Fee, provided that you duplicate
all of the original copyright notices and associated disclaimers. At
your discretion, such verbatim copies may or may not include a
Compiled form of the Package.
(3) You may apply any bug fixes, portability changes, and other
modifications made available from the Copyright Holder. The resulting
Package will still be considered the Standard Version, and as such
will be subject to the Original License.
Distribution of Modified Versions of the Package as Source
(4) You may Distribute your Modified Version as Source (either gratis
or for a Distributor Fee, and with or without a Compiled form of the
Modified Version) provided that you clearly document how it differs
from the Standard Version, including, but not limited to, documenting
any non-standard features, executables, or modules, and provided that
you do at least ONE of the following:
(a) make the Modified Version available to the Copyright Holder
of the Standard Version, under the Original License, so that the
Copyright Holder may include your modifications in the Standard
Version.
(b) ensure that installation of your Modified Version does not
prevent the user installing or running the Standard Version. In
addition, the Modified Version must bear a name that is different
from the name of the Standard Version.
(c) allow anyone who receives a copy of the Modified Version to
make the Source form of the Modified Version available to others
under
(i) the Original License or
(ii) a license that permits the licensee to freely copy,
modify and redistribute the Modified Version using the same
licensing terms that apply to the copy that the licensee
received, and requires that the Source form of the Modified
Version, and of any works derived from it, be made freely
available in that license fees are prohibited but Distributor
Fees are allowed.
Distribution of Compiled Forms of the Standard Version
or Modified Versions without the Source
(5) You may Distribute Compiled forms of the Standard Version without
the Source, provided that you include complete instructions on how to
get the Source of the Standard Version. Such instructions must be
valid at the time of your distribution. If these instructions, at any
time while you are carrying out such distribution, become invalid, you
must provide new instructions on demand or cease further distribution.
If you provide valid instructions or cease distribution within thirty
days after you become aware that the instructions are invalid, then
you do not forfeit any of your rights under this license.
(6) You may Distribute a Modified Version in Compiled form without
the Source, provided that you comply with Section 4 with respect to
the Source of the Modified Version.
Aggregating or Linking the Package
(7) You may aggregate the Package (either the Standard Version or
Modified Version) with other packages and Distribute the resulting
aggregation provided that you do not charge a licensing fee for the
Package. Distributor Fees are permitted, and licensing fees for other
components in the aggregation are permitted. The terms of this license
apply to the use and Distribution of the Standard or Modified Versions
as included in the aggregation.
(8) You are permitted to link Modified and Standard Versions with
other works, to embed the Package in a larger work of your own, or to
build stand-alone binary or bytecode versions of applications that
include the Package, and Distribute the result without restriction,
provided the result does not expose a direct interface to the Package.
Items That are Not Considered Part of a Modified Version
(9) Works (including, but not limited to, modules and scripts) that
merely extend or make use of the Package, do not, by themselves, cause
the Package to be a Modified Version. In addition, such works are not
considered parts of the Package itself, and are not subject to the
terms of this license.
General Provisions
(10) Any use, modification, and distribution of the Standard or
Modified Versions is governed by this Artistic License. By using,
modifying or distributing the Package, you accept this license. Do not
use, modify, or distribute the Package, if you do not accept this
license.
(11) If your Modified Version has been derived from a Modified
Version made by someone other than you, you are nevertheless required
to ensure that your Modified Version complies with the requirements of
this license.
(12) This license does not grant you the right to use any trademark,
service mark, tradename, or logo of the Copyright Holder.
(13) This license includes the non-exclusive, worldwide,
free-of-charge patent license to make, have made, use, offer to sell,
sell, import and otherwise transfer the Package with respect to any
patent claims licensable by the Copyright Holder that are necessarily
infringed by the Package. If you institute patent litigation
(including a cross-claim or counterclaim) against any party alleging
that the Package constitutes direct or contributory patent
infringement, then this Artistic License to you shall terminate on the
date that such litigation is filed.
(14) Disclaimer of Warranty:
THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

18
packages/cplint/COPYRIGHT_SLG Normal file
View File

@ -0,0 +1,18 @@
Copyright (C) 1993 Southern Methodist University,
1993 SUNY at Stony Brook
Everyone is granted permission to use, copy, and distribute this
software free of charge provided that the notices in all files that
refer to file COPYRIGHT are kept intact and that file COPYRIGHT is
kept in all copies. Modification of this software is permitted
provided that all modified files carry prominent notices stating who
changed such files and the date of any change.
This software is provided "as is" with absolutely NO warranties,
including the implied warranties of merchantability and fitness for a
particular purpose. In no event shall Southern Methodist University,
SUNY at Stony Brook, the authors, and/or any other party who may
modify and redistribute this software be liable to you for any damages
whatsoever arising out of or in connection with the use or performance
of this software.

168
packages/cplint/Makefile.in Normal file
View File

@ -0,0 +1,168 @@
#
# default base directory for YAP installation
# (EROOT for architecture-dependent files)
#
prefix = @prefix@
ROOTDIR = $(prefix)
EROOTDIR = @exec_prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share/Yap
#
#
CC=@CC@
CFLAGS= @CFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I$(srcdir)/../include
#
#
# 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@
SHLIB_CFLAGS=@SHLIB_CFLAGS@
SHLIB_SUFFIX=@SHLIB_SUFFIX@
CPLINT_CFLAGS=@CPLINT_CFLAGS@
CPLINT_LDFLAGS=@CPLINT_LDFLAGS@
CPLINT_LIBS=@CPLINT_LIBS@
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
CWD=$(PWD)
#
OBJS=cplint_yap.o cplint_Prob.o
SOBJS=cplint@SHLIB_SUFFIX@
CPLINT_SRCDIR = $(srcdir)
CPLINT_EXDIR = $(srcdir)/examples
CPLINT_DOCDIR = $(srcdir)/doc
CPLINT_PROGRAMS= \
$(CPLINT_SRCDIR)/lpadvel.pl \
$(CPLINT_SRCDIR)/lpadclpbn.pl \
$(CPLINT_SRCDIR)/lpadsld.pl \
$(CPLINT_SRCDIR)/lpad.pl \
$(CPLINT_SRCDIR)/cpl.pl
CPLINT_SEMANTICS_PROGRAMS= \
$(CPLINT_SRCDIR)/semlpadsld.pl \
$(CPLINT_SRCDIR)/semlpad.pl \
$(CPLINT_SRCDIR)/semcpl.pl \
$(CPLINT_SRCDIR)/slg.pl
CPLINT_TEST_PROGRAMS= \
$(CPLINT_SRCDIR)/testlpadvel.pl \
$(CPLINT_SRCDIR)/testlpadclpbn.pl \
$(CPLINT_SRCDIR)/testlpadsld_gbtrue.pl \
$(CPLINT_SRCDIR)/testlpadsld_gbfalse.pl \
$(CPLINT_SRCDIR)/testlpad.pl \
$(CPLINT_SRCDIR)/testcpl.pl \
$(CPLINT_SRCDIR)/testsemlpadsld.pl \
$(CPLINT_SRCDIR)/testsemlpad.pl \
$(CPLINT_SRCDIR)/testsemcpl.pl
CPLINT_EXAMPLES= \
$(CPLINT_EXDIR)/dice.cpl \
$(CPLINT_EXDIR)/dice.uni \
$(CPLINT_EXDIR)/mendel.cpl \
$(CPLINT_EXDIR)/mendels.cpl \
$(CPLINT_EXDIR)/mendels.uni \
$(CPLINT_EXDIR)/alarm.cpl \
$(CPLINT_EXDIR)/coin.cpl \
$(CPLINT_EXDIR)/coin.uni \
$(CPLINT_EXDIR)/coin2.cpl \
$(CPLINT_EXDIR)/coin2.uni \
$(CPLINT_EXDIR)/student.cpl \
$(CPLINT_EXDIR)/student.uni \
$(CPLINT_EXDIR)/exapprox.cpl \
$(CPLINT_EXDIR)/exapprox.uni \
$(CPLINT_EXDIR)/exrange.cpl \
$(CPLINT_EXDIR)/exrange.uni \
$(CPLINT_EXDIR)/ex.cpl \
$(CPLINT_EXDIR)/ex.uni \
$(CPLINT_EXDIR)/school_simple.cpl \
$(CPLINT_EXDIR)/school_simple.uni \
$(CPLINT_EXDIR)/school.cpl \
$(CPLINT_EXDIR)/paper_ref.cpl \
$(CPLINT_EXDIR)/paper_ref_not.cpl \
$(CPLINT_EXDIR)/paper_ref_simple.cpl \
$(CPLINT_EXDIR)/threesideddice.cpl \
$(CPLINT_EXDIR)/threesideddice.uni \
$(CPLINT_EXDIR)/twosideddice.cpl \
$(CPLINT_EXDIR)/female.cpl \
$(CPLINT_EXDIR)/hiv.cpl \
$(CPLINT_EXDIR)/hiv.uni \
$(CPLINT_EXDIR)/invalid.cpl \
$(CPLINT_EXDIR)/invalid.uni \
$(CPLINT_EXDIR)/light.cpl \
$(CPLINT_EXDIR)/light.uni \
$(CPLINT_EXDIR)/throws.cpl \
$(CPLINT_EXDIR)/throws.uni \
$(CPLINT_EXDIR)/trigger.cpl \
$(CPLINT_EXDIR)/trigger.uni \
$(CPLINT_EXDIR)/win.cpl \
$(CPLINT_EXDIR)/win.uni \
$(CPLINT_EXDIR)/exist.cpl \
$(CPLINT_EXDIR)/exist.uni \
$(CPLINT_EXDIR)/exist1.cpl \
$(CPLINT_EXDIR)/exist1.uni
CPLINT_DOCS=\
$(CPLINT_DOCDIR)/manual.bbl \
$(CPLINT_DOCDIR)/manual.tex \
$(CPLINT_DOCDIR)/manual.pdf \
$(CPLINT_DOCDIR)/manual.html \
$(CPLINT_DOCDIR)/manual.css \
$(CPLINT_DOCDIR)/manual0x.png \
$(CPLINT_DOCDIR)/Makefile
all: $(SOBJS)
cplint_yap.o: $(srcdir)/cplint_yap.c $(srcdir)/cplint.h
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(CPLINT_CFLAGS) $(srcdir)/cplint_yap.c -o cplint_yap.o
cplint_Prob.o: $(srcdir)/cplint_Prob.c $(srcdir)/cplint.h
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(CPLINT_CFLAGS) $(srcdir)/cplint_Prob.c -o cplint_Prob.o
@DO_SECOND_LD@cplint@SHLIB_SUFFIX@: cplint_yap.o cplint_Prob.o
@DO_SECOND_LD@ @CPLINT_SHLIB_LD@ -o cplint@SHLIB_SUFFIX@ $(CPLINT_LDFLAGS) cplint_yap.o cplint_Prob.o $(CPLINT_LIBS)
clean:
rm -f *.o *~ $(OBJS) $(SOBJS) *.BAK
install: all
mkdir -p $(DESTDIR)$(SHAREDIR)/cplint
mkdir -p $(DESTDIR)$(SHAREDIR)/cplint/examples
mkdir -p $(DESTDIR)$(SHAREDIR)/cplint/doc
for h in $(CPLINT_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done
for h in $(CPLINT_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/cplint/examples; done
for h in $(CPLINT_DOCS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/cplint/doc; done
for h in $(CPLINT_TEST_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/cplint; done
for h in $(CPLINT_SEMANTICS_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done
$(INSTALL_PROGRAM) $(SOBJS) $(DESTDIR)$(LIBDIR)
installcheck:
for h in ${CPLINT_TEST_PROGRAMS}; do echo "t. halt." | yap -l $$h; done
# use the following target to run individual tests, e.g. make testlpad
test%:
echo "t. halt." | yap -l $(CPLINT_SRCDIR)/$@.pl

40
packages/cplint/README Normal file
View File

@ -0,0 +1,40 @@
This directory contains the code of the LPAD anc CP-logic interpreter cplint
COMPILATION:
This package requires GLU (a subpackage of VIS) and GLIB version 1.2.
You can download GLU from http://vlsi.colorado.edu/~vis/getting_VIS_2.1.html
You can download GLIB from http://www.gtk.org/. This is a standard Linux package
so it is easy to install using the package management software of your Linux
distribution
INSTALLATION:
Install glu:
1) downlad glu-2.1.tar.gz
2) decompress it
3) cd glu-2.1
3) mkdir arch
4) cd arch
5) ../configure
6) make
7) su
8) make install
This will install glu into /usr/local, if you want to install to a different DIR
use ../configure --prefix DIR
Installation of cplint:
When compiling Yap, use
configure --enable-cplint
Under Windows, you have to use cygwin (glu does not compile under MinGW), so
configure --enable-cplint --enable-cygwin
If you installed glu in DIR, use --enable-cplint=DIR
FEEDBACK:
Send feedback to:
Fabrizio Riguzzi
University of Ferrara
Dept. of Engineering
fabrizio.riguzzi@unife.it
http://www.ing.unife.it/Docenti/FabrizioRiguzzi/

157
packages/cplint/cpl.pl Normal file
View File

@ -0,0 +1,157 @@
/*
LPAD and CP-Logic reasoning suite
File cpl.pl
Computes the semantics of CP-logic programs
Copyright (c) 2007, Fabrizio Riguzzi
*/
:-use_module(lpad,[slg/3,setting/2,set/2]).
:-use_module(semcpl,[build/0,print/0]).
:-use_module(library(lists)).
p(File):-
lpad:p(File).
sc(Goals,Evidences,Prob,CPUTime1,0.0,WallTime1,0.0):-
statistics(cputime,[_,_]),
statistics(walltime,[_,_]),
lpad:convert_to_goal(Goals,Goal),
lpad:convert_to_goal(Evidences,Evidence),
solve_cond(Goal,Evidence,Prob),
statistics(cputime,[_,CT1]),
CPUTime1 is CT1/1000,
statistics(walltime,[_,WT1]),
WallTime1 is WT1/1000.
sc(Goals,Evidences,Prob):-
lpad:convert_to_goal(Goals,Goal),
lpad:convert_to_goal(Evidences,Evidence),
solve_cond(Goal,Evidence,Prob).
solve_cond(Goal,Evidence,Prob):-
(setof((DerivE,D),slg(Evidence,DerivE,D),LCouplesE)->
separate(LCouplesE,LCDupE,LDefClE),
lpad:rem_dup_lists(LCDupE,[],LCE),
lpad:build_formula(LCE,FormulaE,[],VarE),
lpad:var2numbers(VarE,0,NewVarE),
lpad:compute_prob(NewVarE,FormulaE,ProbE,0),
solve_cond_goals(Goal,LCE,ProbGE,LGE,LDefClGE),
(setof((R,S),N^(member(C,LGE),member((N,R,S),C)),LDisClGE)->
true
;
LDisClGE=[]
),
append(LDefClGE,LDefClE,LDefDup),
remove_duplicates(LDefDup,LDef),
append(LDisClGE,LDef,LCl),
test_validity(LCl),
Prob is ProbGE/ProbE
;
format("P(Evidence)=0~n",[]),
Prob=undefined
).
solve_cond_goals(Goals,LE,ProbGE,LGE,LDefClGE):-
(setof((DerivGE,D),find_deriv_GE(LE,Goals,DerivGE,D),LCouplesGE)->
separate(LCouplesGE,LCDupGE,LDefClGE),
lpad:rem_dup_lists(LCDupGE,[],LGE),
lpad:build_formula(LGE,FormulaGE,[],VarGE),
lpad:var2numbers(VarGE,0,NewVarGE),
lpad:call_compute_prob(NewVarGE,FormulaGE,ProbGE)
;
ProbGE=0
).
find_deriv_GE(LD,GoalsList,Deriv,Def):-
member(D,LD),
lpad:slg(GoalsList,D,DerivDup,[],Def),
remove_duplicates(DerivDup,Deriv).
s(GoalsList,Prob):-
lpad:convert_to_goal(GoalsList,Goal),
solve(Goal,Prob).
s(GoalsList,Prob,CPUTime1,0.0,WallTime1,0.0):-
statistics(cputime,[_,_]),
statistics(walltime,[_,_]),
lpad:convert_to_goal(GoalsList,Goal),
solve(Goal,Prob),
statistics(cputime,[_,CT1]),
CPUTime1 is CT1/1000,
statistics(walltime,[_,WT1]),
WallTime1 is WT1/1000.
solve(Goal,Prob):-
(setof((C,D),slg(Goal,C,D),LCouples)->
separate(LCouples,LCDup,LDefCl),
(member(unsound,LCDup)->
format("Unsound program ~n",[]),
Prob=unsound
;
lpad:rem_dup_lists(LCDup,[],L),
(ground(L)->
lpad:build_formula(L,Formula,[],Var),
lpad:var2numbers(Var,0,NewVar),
(setting(savedot,true)->
format("Variables: ~p~n",[Var]),
lpad:compute_prob(NewVar,Formula,_Prob,1)
;
lpad:compute_prob(NewVar,Formula,Prob,0)
),
(setof((R,S),N^(member(C,LCDup),member((N,R,S),C)),LDisCl)->
true
;
LDisCl=[]
),
append(LDisCl,LDefCl,LCl),
test_validity(LCl)
;
format("It requires the choice of a head atom from a non ground head~n~p~n",[L]),
Prob=non_ground
)
)
;
Prob=0
).
test_validity(L):-
retractall(semcpl:root(_)),
retractall(semcpl:clauses(_)),
retractall(semcpl:herbrand_base(_)),
retractall(semcpl:node(_,_,_,_,_)),
retractall(semcpl:new_number(_)),
assert(semcpl:new_number(0)),
get_clauses_hb(L,LC,HBDup),
remove_duplicates(HBDup,HB0),
delete(HB0, '' ,HB),
assert(semcpl:herbrand_base(HB)),
assert(semcpl:clauses(LC)),
build.
get_clauses_hb([],[],[]):-!.
get_clauses_hb([(R,S)|T],[r(Head,Body)|TR],HB):-
lpad:rule(R,S,_,Head,Body),!,
get_atoms(Head,Atoms),
append(Atoms,HB0,HB),
get_clauses_hb(T,TR,HB0).
get_clauses_hb([(R,S)|T],[r([Head:1],Body)|TR],HB):-
lpad:def_rule(R,S,Head,Body),
append([Head],HB0,HB),
get_clauses_hb(T,TR,HB0).
get_atoms([],[]):-!.
get_atoms([H:_P|T],[H|TA]):-
get_atoms(T,TA).
separate([],[],[]):-!.
separate([(C,D)|T],[C|TC],Cl):-
append(D,Cl0,Cl),
separate(T,TC,Cl0).

49
packages/cplint/cplint.h Normal file
View File

@ -0,0 +1,49 @@
/*
LPAD and CP-Logic interpreter
Copyright (c) 2007, Fabrizio Riguzzi
This package uses the library cudd, see http://vlsi.colorado.edu/~fabio/CUDD/
for the relative license.
*/
#include "util.h"
#include "cuddInt.h"
#include "array.h"
#include "mtr.h"
#include "avl.h"
#include "YapInterface.h"
#include <glib.h>
typedef struct
{
int var,value;
} factor;
typedef struct
{
int nVal,nBit;
array_t * probabilities;
array_t * booleanVars;
} variable;
void createVars(array_t * vars, YAP_Term t,DdManager * mgr, array_t * bVar2mVar,int create_dot, char inames[1000][20]);
void createExpression(array_t * expression, YAP_Term t);
void init_my_predicates(void);
int compare(char *a, char *b);
gint my_equal(gconstpointer v,gconstpointer v2);
guint my_hash(gconstpointer key);
void dealloc(gpointer key,gpointer value,gpointer user_data);
DdNode * retFunction(DdManager * mgr, array_t * expression,array_t * v);
DdNode * retTerm(DdManager * mgr,array_t *factors,array_t * v);
DdNode * retFactor(DdManager * mgr, factor f, array_t * v);
double Prob(DdNode *node, array_t * vars,array_t * bVar2mVar, GHashTable * nodes);
double ProbBool(DdNode *node, int bits, int nBit,int posBVar,variable v,
array_t * vars,array_t * bVar2mVar, GHashTable * nodes);

209
packages/cplint/cplint_Prob.c Normal file
View File

@ -0,0 +1,209 @@
/*
LPAD and CP-Logic interpreter
Copyright (c) 2007, Fabrizio Riguzzi
This package uses the library cudd, see http://vlsi.colorado.edu/~fabio/CUDD/
for the relative license.
This file contains the definition of Prob and ProbBool plus the functions
for building the BDD
*/
#include "cplint.h"
#include <stdlib.h>
int correctPosition(int index,variable v, DdNode * node,int posBVar);
DdNode * retFunction(DdManager * mgr,array_t *expression, array_t *v)
/* given an expression term1+term2+...+termn, returns the BDD that implements that function */
{
array_t * term;
DdNode * tNode, * tmp, *tmp1;
int i;
i=0;
tNode=Cudd_ReadLogicZero(mgr);
Cudd_Ref(tNode);
while(i<array_n(expression))
{
term=array_fetch(array_t * ,expression,i);
tmp=retTerm(mgr,term,v);
Cudd_Ref(tmp);
tmp1=Cudd_bddOr(mgr,tNode,tmp);
Cudd_Ref(tmp1);
Cudd_RecursiveDeref(mgr,tNode);
tNode=tmp1;
i++;
}
return tNode;
}
DdNode * retTerm(DdManager * mgr,array_t *term, array_t * v)
/* given a term V1=v1 and V2=v2 ... Vn=vn, returns the BDD that implements that function */
{
factor f;
DdNode * fNode, * tmp, *tmp1;
int i;
i=0;
fNode=Cudd_ReadOne(mgr);
Cudd_Ref(fNode);
while (i<array_n(term))
{
f=array_fetch(factor, term, i);
tmp=retFactor(mgr,f,v);
Cudd_Ref(tmp);
tmp1= Cudd_bddAnd(mgr,fNode,tmp);
Cudd_Ref(tmp1);
Cudd_RecursiveDeref(mgr,fNode);
fNode=tmp1;
i++;
}
return fNode;
}
DdNode * retFactor(DdManager * mgr, factor f, array_t * vars)
/* given a factor V=v, returns the BDD that implements that function */
{
int varIndex;
int value;
int i;
int bit;
variable v;
DdNode * node, *booleanVar, * tmp;
array_t * booleanVars;
varIndex=f.var;
value=f.value;
v=array_fetch(variable, vars, varIndex);
booleanVars=v.booleanVars;
i=v.nBit-1;
node=Cudd_ReadOne(mgr);
Cudd_Ref(node);
/* booelan var with index 0 in v.booleanVars is the most significant */
do {
booleanVar=array_fetch(DdNode *,booleanVars,i);
bit=value & 01;
if (bit)
{
tmp=Cudd_bddAnd(mgr,node,booleanVar);
Cudd_Ref(tmp);
}
else
{
tmp=Cudd_bddAnd(mgr,node,Cudd_Not(booleanVar));
Cudd_Ref(tmp);
}
value=value>>1;
i--;
Cudd_RecursiveDeref(mgr,node);
node=tmp;
} while (i>=0);
return node;
}
double Prob(DdNode *node, array_t * vars,array_t * bVar2mVar, GHashTable * nodes)
/* compute the probability of the expression rooted at node
nodes is used to store nodes for which the probability has alread been computed
so that it is not recomputed
*/
{
int index,mVarIndex,nBit;
variable v;
double res;
double value;
double * value_p;
DdNode **key;
double *rp;
index=node->index;
if (Cudd_IsConstant(node))
{
value=node->type.value;
return value;
}
else
{
value_p=g_hash_table_lookup(nodes,&node);
if (value_p!=NULL)
{
return *value_p;
}
else
{
mVarIndex=array_fetch(int,bVar2mVar,index);
v=array_fetch(variable,vars,mVarIndex);
nBit=v.nBit;
res=ProbBool(node,0,nBit,0,v,vars,bVar2mVar,nodes);
key=(DdNode **)malloc(sizeof(DdNode *));
*key=node;
rp=(double *)malloc(sizeof(double));
*rp=res;
g_hash_table_insert(nodes, key, rp);
return res;
}
}
}
double ProbBool(DdNode *node, int bits, int nBit,int posBVar,variable v,
array_t * vars,array_t * bVar2mVar, GHashTable * nodes)
/* explores a group of binary variables making up the multivalued variable v */
{
DdNode *T,*F;
double p,res;
array_t * probs;
probs=v.probabilities;
if (nBit==0)
{
if (bits>=array_n(probs))
return 0;
else
{
p=array_fetch(double,probs,bits);
res=p*Prob(node,vars,bVar2mVar,nodes);
return res;
}
}
else
{
if (correctPosition(node->index,v,node,posBVar))
{
T = node->type.kids.T;
F = node->type.kids.E;
bits=bits<<1;
res=ProbBool(T,bits+1,nBit-1,posBVar+1,v,vars,bVar2mVar,nodes)+
ProbBool(F,bits,nBit-1,posBVar+1,v,vars,bVar2mVar,nodes);
return res;
}
else
{
bits=bits<<1;
res=ProbBool(node,bits+1,nBit-1,posBVar+1,v,vars,bVar2mVar,nodes)+
ProbBool(node,bits,nBit-1,posBVar+1,v,vars,bVar2mVar,nodes);
return res;
}
}
}
int correctPosition(int index,variable v, DdNode * node,int posBVar)
/* returns 1 is the boolean variable with index posBVar is in the correct position
currently explored by ProbBool */
{
DdNode * bvar;
bvar=array_fetch(DdNode *,v.booleanVars,posBVar);
return bvar->index==index;
}

256
packages/cplint/cplint_yap.c Normal file
View File

@ -0,0 +1,256 @@
/*
LPAD and CP-Logic interpreter
Copyright (c) 2007, Fabrizio Riguzzi
This package uses the library cudd, see http://vlsi.colorado.edu/~fabio/CUDD/
for the relative license.
This file contains the functions for interfacing Yap and C
The arguments of the predicate compute_prob are parsed and translated into C data
structures
*/
#include "cplint.h"
#include <math.h>
#include <stdlib.h>
#include <string.h>
unsigned long dividend;
FILE *open_file (char *filename, const char *mode);
void reverse(char s[]);
static int compute_prob(void);
void createVars(array_t * vars, YAP_Term t,DdManager * mgr, array_t * bVar2mVar,int create_dot, char inames[1000][20])
/* adds the boolean variables to the BDD and returns
an array_t containing them (array_t is defined in the util library of glu)
returns also the names of the variables to be used to save the ADD in dot format
*/
{
YAP_Term varTerm,probTerm;
int varIndex,nVal,i,b;
variable v;
char numberVar[10],numberBit[10];
double p;
b=0;
while(YAP_IsPairTerm(t))
{
varTerm=YAP_HeadOfTerm(t);
varIndex=YAP_IntOfTerm(YAP_HeadOfTerm(varTerm));
varTerm=YAP_TailOfTerm(varTerm);
nVal=YAP_IntOfTerm(YAP_HeadOfTerm(varTerm));
varTerm=YAP_TailOfTerm(varTerm);
probTerm=YAP_HeadOfTerm(varTerm);
v.nVal=nVal;
v.nBit=(int)ceil(log(nVal)/log(2));
v.probabilities=array_alloc(double,0);
v.booleanVars=array_alloc(DdNode *,0);
for (i=0;i<nVal;i++)
{
if (create_dot)
{
strcpy(inames[b+i],"X");
sprintf(numberVar,"%d",varIndex);
strcat(inames[b+i],numberVar);
strcat(inames[b+i],"_");
sprintf(numberBit,"%d",i);
strcat(inames[b+i],numberBit);
}
p=YAP_FloatOfTerm(YAP_HeadOfTerm(probTerm));
array_insert(double,v.probabilities,i,p);
probTerm=YAP_TailOfTerm(probTerm);
array_insert(DdNode *,v.booleanVars,i,Cudd_bddIthVar(mgr,b+i));
array_insert(int,bVar2mVar,b+i,varIndex);
}
Cudd_MakeTreeNode(mgr,b,nVal,MTR_FIXED);
b=b+nVal;
array_insert(variable,vars,varIndex,v);
t=YAP_TailOfTerm(t);
}
}
void createExpression(array_t * expression, YAP_Term t)
/* returns the expression as an array_t of terms (cubes) starting from the prolog lists of terms
each term is an array_t of factors obtained from a prolog list of factors
each factor is a couple (index of variable, index of value) obtained from a prolog list containing
two integers
*/
{
YAP_Term termTerm,factorTerm;
factor f;
int i,j;
array_t * term;
i=0;
while(YAP_IsPairTerm(t))
{
term=array_alloc(factor,0);
termTerm=YAP_HeadOfTerm(t);
j=0;
while(YAP_IsPairTerm(termTerm))
{
factorTerm=YAP_HeadOfTerm(termTerm);
f.var=YAP_IntOfTerm(YAP_HeadOfTerm(factorTerm));
f.value=YAP_IntOfTerm(YAP_HeadOfTerm(YAP_TailOfTerm(factorTerm)));
array_insert(factor,term,j,f);
termTerm=YAP_TailOfTerm(termTerm);
j++;
}
array_insert(array_t *,expression,i,term);
t=YAP_TailOfTerm(t);
i++;
}
}
static int compute_prob(void)
/* this is the function that implements the compute_prob predicate used in pp.pl
*/
{
YAP_Term out,arg1,arg2,arg3,arg4;
array_t * variables,* expression, * bVar2mVar;
DdNode * function, * add;
DdManager * mgr;
int nBVar,i,j,intBits,create_dot;
FILE * file;
DdNode * array[1];
char * onames[1];
char inames[1000][20];
char * names[1000];
GHashTable * nodes; /* hash table that associates nodes with their probability if already
computed, it is defined in glib */
Cudd_ReorderingType order;
arg1=YAP_ARG1;
arg2=YAP_ARG2;
arg3=YAP_ARG3;
arg4=YAP_ARG4;
mgr=Cudd_Init(0,0,CUDD_UNIQUE_SLOTS,CUDD_CACHE_SLOTS,0);
variables=array_alloc(variable,0);
bVar2mVar=array_alloc(int,0);
create_dot=YAP_IntOfTerm(arg4);
createVars(variables,arg1,mgr,bVar2mVar,create_dot,inames);
//Cudd_PrintInfo(mgr,stderr);
/* automatic variable reordering, default method CUDD_REORDER_SIFT used */
//printf("status %d\n",Cudd_ReorderingStatus(mgr,&order));
//printf("order %d\n",order);
Cudd_AutodynEnable(mgr,CUDD_REORDER_SAME);
/* Cudd_AutodynEnable(mgr, CUDD_REORDER_RANDOM_PIVOT);
printf("status %d\n",Cudd_ReorderingStatus(mgr,&order));
printf("order %d\n",order);
printf("%d",CUDD_REORDER_RANDOM_PIVOT);
*/
expression=array_alloc(array_t *,0);
createExpression(expression,arg2);
function=retFunction(mgr,expression,variables);
/* the BDD build by retFunction is converted to an ADD (algebraic decision diagram)
because it is easier to interpret and to print */
add=Cudd_BddToAdd(mgr,function);
//Cudd_PrintInfo(mgr,stderr);
if (create_dot)
/* if specified by the user, a dot file for the BDD is written to cpl.dot */
{
nBVar=array_n(bVar2mVar);
for(i=0;i<nBVar;i++)
names[i]=inames[i];
array[0]=add;
onames[0]="Out";
file = open_file("cpl.dot", "w");
Cudd_DumpDot(mgr,1,array,names,onames,file);
fclose(file);
}
nodes=g_hash_table_new(my_hash,my_equal);
intBits=sizeof(unsigned int)*8;
/* dividend is a global variable used by my_hash
it is equal to an unsigned int with binary representation 11..1 */
dividend=1;
for(j=1;j<intBits;j++)
{
dividend=(dividend<<1)+1;
}
out=YAP_MkFloatTerm(Prob(add,variables,bVar2mVar,nodes));
g_hash_table_foreach (nodes,dealloc,NULL);
g_hash_table_destroy(nodes);
Cudd_Quit(mgr);
array_free(variables);
array_free(bVar2mVar);
array_free(expression);
return(YAP_Unify(out,arg3));
}
/*
int compare(char *a, char *b)
{
int aval,bval;
aval=(int) *((DdNode **)a);
aval=(int) *((DdNode **)b);
if (aval<bval)
return -1;
else
if (aval>bval)
return 1;
else
return 0;
}
*/
void init_my_predicates()
/* function required by YAP for intitializing the predicates defined by a C function*/
{
YAP_UserCPredicate("compute_prob",compute_prob,4);
}
FILE *
open_file(char *filename, const char *mode)
/* opens a file */
{
FILE *fp;
if ((fp = fopen(filename, mode)) == NULL) {
perror(filename);
exit(1);
}
return fp;
}
void reverse(char s[])
/* reverses a string */
{
int i,c,j;
for (i=0,j=strlen(s)-1;i<j;i++,j--)
{
c=s[i];
s[i]=s[j];
s[j]=c;
}
}
gint my_equal(gconstpointer v,gconstpointer v2)
/* function used by GHashTable to compare two keys */
{
DdNode *a,*b;
a=*(DdNode **)v;
b=*(DdNode **)v2;
return (a==b);
}
guint my_hash(gconstpointer key)
/* function used by GHashTable to hash a key */
{
unsigned int h;
h=(unsigned int)((unsigned long) *((DdNode **)key) % dividend);
return h;
}
void dealloc(gpointer key,gpointer value,gpointer user_data)
{
free(key);
free(value);
}

90
packages/cplint/doc/manual.bbl Normal file
View File

@ -0,0 +1,90 @@
\begin{thebibliography}{10}
\bibitem{DBLP:journals/ngc/AptB91}
K.~R. Apt and M.~Bezem.
\newblock Acyclic programs.
\newblock {\em New Generation Comput.}, 9(3/4):335--364, 1991.
\bibitem{Blo04-ILP04WIP-IC}
H.~Blockeel.
\newblock Probabilistic logical models for mendel's experiments: An exercise.
\newblock In {\em Inductive Logic Programming ({ILP} 2004), Work in Progress
Track}, 2004.
\bibitem{DBLP:journals/jacm/ChenW96}
Weidong Chen and David~Scott Warren.
\newblock Tabled evaluation with delaying for general logic programs.
\newblock {\em J. ACM}, 43(1):20--74, 1996.
\bibitem{DBLP:conf/ijcai/RaedtKT07}
L.~De~Raedt, A.~Kimmig, and H.~Toivonen.
\newblock Problog: A probabilistic prolog and its application in link
discovery.
\newblock In {\em Proceedings of the 20th International Joint Conference on
Artificial Intelligence}, pages 2462--2467, 2007.
\bibitem{GetFri01-BC}
L.~Getoor, N.~Friedman, D.~Koller, and A.~Pfeffer.
\newblock Learning probabilistic relational models.
\newblock In Saso Dzeroski and Nada Lavrac, editors, {\em Relational Data
Mining}. Springer-Verlag, Berlin, 2001.
\bibitem{Getoor+al:JMLR02}
L.~Getoor, N.~Friedman, D.~Koller, and B.~Taskar.
\newblock Learning probabilistic models of relational structure.
\newblock {\em Journal of Machine Learning Research}, 3:679--707, December
2002.
\bibitem{Rig-AIIA07-IC}
Fabrizio Riguzzi.
\newblock A top down interpreter for lpad and cp-logic.
\newblock In {\em 10th Congress of the Italian Association for Artificial
Intelligence}. Springer, 2007.
\newblock
\href{http://www.ing.unife.it/docenti/FabrizioRiguzzi/Papers/Rig-AIIA07.pdf}%
{http://www.ing.unife.it/docenti/FabrizioRiguzzi/Papers/Rig-AIIA07.pdf}.
\bibitem{Rig-RCRA07-IC}
Fabrizio Riguzzi.
\newblock A top down interpreter for lpad and cp-logic.
\newblock In {\em The 14th RCRA workshop Experimental Evaluation of Algorithms
for Solving Problems with Combinatorial Explosion}, 2007.
\newblock
\href{http://pst.istc.cnr.it/RCRA07/articoli/P19-riguzzi-RCRA07.pdf}{http://%
pst.istc.cnr.it/RCRA07/articoli/P19-riguzzi-RCRA07.pdf}.
\bibitem{SanPagQaz03-UAI-IC}
V.~Santos~Costa, D.~Page, M.~Qazi, and J.~Cussens.
\newblock {CLP(BN)}: Constraint logic programming for probabilistic knowledge.
\newblock In {\em Uncertainty in Artificial Intelligence ({UAI} 2003)}, 2003.
\bibitem{VenDenBru-JELIA06}
J.~Vennekens, M.~Denecker, and M.~Bruynooghe.
\newblock Representing causal information about a probabilistic process.
\newblock In {\em 10th European Conference on Logics in Artificial
Intelligence, JELIA 2006}, LNAI. Springer, September 2006.
\bibitem{VenVer03-TR}
J.~Vennekens and S.~Verbaeten.
\newblock Logic programs with annotated disjunctions.
\newblock Technical Report CW386, K. U. Leuven, 2003.
\newblock
\href{http://www.cs.kuleuven.ac.be/~joost/techrep.ps}{http://www.cs.kuleuven%
.ac.be/$\sim$joost/techrep.ps}.
\bibitem{VenVer04-ICLP04-IC}
J.~Vennekens, S.~Verbaeten, and M.~Bruynooghe.
\newblock Logic programs with annotated disjunctions.
\newblock In {\em The 20th International Conference on Logic Programming
({ICLP} 2004)}, 2004.
\newblock
\href{http://www.cs.kuleuven.ac.be/~joost/}{http://www.cs.kuleuven.ac.be/$\sim$joost/}.
\bibitem{CP-logic-unp}
Joost Vennekens, Marc Denecker, and Maurice Bruynooge.
\newblock Extending the role of causality in probabilistic modeling.
\newblock
\href{http://www.cs.kuleuven.ac.be/~joost/cplogic.pdf}{http://www.cs.kuleuve%
n.ac.be/$\sim$joost/cplogic.pdf}, 2006.
\end{thebibliography}

113
packages/cplint/doc/manual.css Normal file
View File

@ -0,0 +1,113 @@
/* start css.sty */
.cmr-7{font-size:70%;}
.cmmi-7{font-size:70%;font-style: italic;}
.cmmi-10{font-style: italic;}
.cmr-17{font-size:170%;}
.cmtt-12x-x-144{font-size:172%;font-family: monospace;}
.cmtt-12x-x-144{font-family: monospace;}
.cmr-12{font-size:120%;}
.cmtt-10{font-family: monospace;}
.cmtt-10{font-family: monospace;}
.cmti-10{ font-style: italic;}
p.noindent { text-indent: 0em }
p.nopar { text-indent: 0em; }
p.indent{ text-indent: 1.5em }
@media print {div.crosslinks {visibility:hidden;}}
a img { border-top: 0; border-left: 0; border-right: 0; }
center { margin-top:1em; margin-bottom:1em; }
td center { margin-top:0em; margin-bottom:0em; }
.Canvas { position:relative; }
img.math{vertical-align:middle;}
li p.indent { text-indent: 0em }
.enumerate1 {list-style-type:decimal;}
.enumerate2 {list-style-type:lower-alpha;}
.enumerate3 {list-style-type:lower-roman;}
.enumerate4 {list-style-type:upper-alpha;}
div.newtheorem { margin-bottom: 2em; margin-top: 2em;}
.obeylines-h,.obeylines-v {white-space: nowrap; }
div.obeylines-v p { margin-top:0; margin-bottom:0; }
.overline{ text-decoration:overline; }
.overline img{ border-top: 1px solid black; }
td.displaylines {text-align:center; white-space:nowrap;}
.centerline {text-align:center;}
.rightline {text-align:right;}
div.verbatim {font-family: monospace; white-space: nowrap; }
table.verbatim {width:100%;}
.fbox {padding-left:3.0pt; padding-right:3.0pt; text-indent:0pt; border:solid black 0.4pt; }
div.center div.fbox {text-align:center; clear:both; padding-left:3.0pt; padding-right:3.0pt; text-indent:0pt; border:solid black 0.4pt; }
table.minipage{width:100%;}
div.center, div.center div.center {text-align: center; margin-left:1em; margin-right:1em;}
div.center div {text-align: left;}
div.flushright, div.flushright div.flushright {text-align: right;}
div.flushright div {text-align: left;}
div.flushleft {text-align: left;}
.underline{ text-decoration:underline; }
.underline img{ border-bottom: 1px solid black; margin-bottom:1pt; }
.framebox-c, .framebox-l, .framebox-r { padding-left:3.0pt; padding-right:3.0pt; text-indent:0pt; border:solid black 0.4pt; }
.framebox-c {text-align:center;}
.framebox-l {text-align:left;}
.framebox-r {text-align:right;}
span.thank-mark{ vertical-align: super }
span.footnote-mark sup.textsuperscript, span.footnote-mark a sup.textsuperscript{ font-size:80%; }
div.tabular, div.center div.tabular {text-align: center; margin-top:0.5em; margin-bottom:0.5em; }
table.tabular td p{margin-top:0em;}
table.tabular {margin-left: auto; margin-right: auto;}
div.td00{ margin-left:0pt; margin-right:0pt; }
div.td01{ margin-left:0pt; margin-right:5pt; }
div.td10{ margin-left:5pt; margin-right:0pt; }
div.td11{ margin-left:5pt; margin-right:5pt; }
table[rules] {border-left:solid black 0.4pt; border-right:solid black 0.4pt; }
td.td00{ padding-left:0pt; padding-right:0pt; }
td.td01{ padding-left:0pt; padding-right:5pt; }
td.td10{ padding-left:5pt; padding-right:0pt; }
td.td11{ padding-left:5pt; padding-right:5pt; }
table[rules] {border-left:solid black 0.4pt; border-right:solid black 0.4pt; }
.hline hr, .cline hr{ height : 1px; margin:0px; }
.tabbing-right {text-align:right;}
span.TEX {letter-spacing: -0.125em; }
span.TEX span.E{ position:relative;top:0.5ex;left:-0.0417em;}
a span.TEX span.E {text-decoration: none; }
span.LATEX span.A{ position:relative; top:-0.5ex; left:-0.4em; font-size:85%;}
span.LATEX span.TEX{ position:relative; left: -0.4em; }
div.float img, div.float .caption {text-align:center;}
div.figure img, div.figure .caption {text-align:center;}
.marginpar {width:20%; float:right; text-align:left; margin-left:auto; margin-top:0.5em; font-size:85%; text-decoration:underline;}
.marginpar p{margin-top:0.4em; margin-bottom:0.4em;}
table.equation {width:100%;}
.equation td{text-align:center; }
td.equation { margin-top:1em; margin-bottom:1em; }
td.equation-label { width:5%; text-align:center; }
td.eqnarray4 { width:5%; white-space: normal; }
td.eqnarray2 { width:5%; }
table.eqnarray-star, table.eqnarray {width:100%;}
div.eqnarray{text-align:center;}
div.array {text-align:center;}
div.pmatrix {text-align:center;}
table.pmatrix {width:100%;}
span.pmatrix img{vertical-align:middle;}
div.pmatrix {text-align:center;}
table.pmatrix {width:100%;}
img.cdots{vertical-align:middle;}
.partToc a, .partToc, .likepartToc a, .likepartToc {line-height: 200%; font-weight:bold; font-size:110%;}
.caption td.id{font-weight: bold; white-space: nowrap; }
table.caption {text-align:center;}
h1.partHead{text-align: center}
p.bibitem { text-indent: -2em; margin-left: 2em; margin-top:0.6em; margin-bottom:0.6em; }
p.bibitem-p { text-indent: 0em; margin-left: 2em; margin-top:0.6em; margin-bottom:0.6em; }
.paragraphHead, .likeparagraphHead { margin-top:2em; font-weight: bold;}
.subparagraphHead, .likesubparagraphHead { font-weight: bold;}
.quote {margin-bottom:0.25em; margin-top:0.25em; margin-left:1em; margin-right:1em; text-align:justify;}
.verse{white-space:nowrap; margin-left:2em}
div.maketitle {text-align:center;}
h2.titleHead{text-align:center;}
div.maketitle{ margin-bottom: 2em; }
div.author, div.date {text-align:center;}
div.thanks{text-align:left; margin-left:10%; font-size:85%; font-style:italic; }
div.author{white-space: nowrap;}
.quotation {margin-bottom:0.25em; margin-top:0.25em; margin-left:1em; }
.abstract p {margin-left:5%; margin-right:5%;}
table.abstract {width:100%;}
.figure img.graphics {margin-left:10%;}
/* end css.sty */

1047
packages/cplint/doc/manual.html Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
packages/cplint/doc/manual.pdf Normal file
View File

Binary file not shown.

458
packages/cplint/doc/manual.tex Normal file
View File

@ -0,0 +1,458 @@
\ifnum\pdfoutput>0 % pdflatex compilation
\documentclass[a4paper,12pt]{article}
\usepackage[pdftex]{graphicx}
\DeclareGraphicsExtensions{.pdf,.png,.jpg}
\RequirePackage[hyperindex]{hyperref}
\else % htlatex compilation
\documentclass{article}
\usepackage{graphicx}
\DeclareGraphicsExtensions{.png, .gif, .jpg}
\newcommand{\href}[2]{\Link[#1]{}{} #2 \EndLink}
\newcommand{\hypertarget}[2]{\Link[]{}{#1} #2 \EndLink}
\newcommand{\hyperlink}[2]{\Link[]{#1}{} #2 \EndLink}
\fi
\begin{document}
\title{\texttt{cplint} Version beta2.0 Manual}
\author{Fabrizio Riguzzi\\
fabrizio.riguzzi@unife.it}
\maketitle
\section{Introduction}
\texttt{cplint} is a suite of programs for reasoning with LPADs \cite{VenVer03-TR,VenVer04-ICLP04-IC} and CP-logic programs \cite{VenDenBru-JELIA06,CP-logic-unp}.
It consists of three Prolog modules for answering queries using goal-oriented procedures plus
three
Prolog modules for answering queries using the definition of the semantics of LPADs and CP-logic.
The modules for answering queries using using goal-oriented procedures are \texttt{lpadsld.pl}, \texttt{lpad.pl} and
\texttt{cpl.pl}:
\begin{itemize}
\item \texttt{lpadsld.pl}: computes the probability of a query using the top-down procedure described in
in \cite{Rig-AIIA07-IC} and \cite{Rig-RCRA07-IC}. It is based on SLDNF resolution and is an adaptation of the interpreter for ProbLog \cite{DBLP:conf/ijcai/RaedtKT07}.
It was proved correct \cite{Rig-RCRA07-IC} with respect to the semantics of LPADs for range restricted acyclic programs \cite{DBLP:journals/ngc/AptB91} without function symbols.
It is also able to deal with extensions of LPADs and CP-logic: the clause bodies can contain \texttt{setof} and \texttt{bagof}, the probabilities in the head may be depend on variables in the body and it is possible to specify a uniform distribution in the head with reference to a \texttt{setof} or \texttt{bagof} operator. These extended features have been introduced in order to represent CLP(BN) \cite{SanPagQaz03-UAI-IC} programs and PRM models \cite{Getoor+al:JMLR02}:
\texttt{setof} and \texttt{bagof} allow to express dependency of an attribute from an aggregate function of another attribute, as in CLP(BN) and PRM, while the possibility of specifying a uniform distribution allows the use of the reference uncertainty feature of PRM.
\item \texttt{lpad.pl}: computes the probability of a query using a top-down procedure based on SLG resolution \cite{DBLP:journals/jacm/ChenW96}. As a consequence, it works for any sound LPADs, i.e., any LPAD such that each of its instances has a two valued well founded model.
\item \texttt{cpl.pl}: computes the probability of a query using a top-down procedure based on SLG resolution and moreover checks that the CP-logic program is valid, i.e., that it has at least an execution model.
\end{itemize}
The modules for answering queries using the definition of the semantics of LPADs and CP-logic are \texttt{semlpadsld.pl}, \texttt{semlpad.pl} and
\texttt{semcpl.pl}:
\begin{itemize}
\item \texttt{semlpadsld.pl}: given an LPAD $P$, it generates all the instances of $P$. The probability of a query $Q$ is computed by identifying all the instances where $Q$ is derivable by SLDNF resolution.
\item \texttt{semlpad.pl}: given an LPAD $P$, it generates all the instances of $P$. The probability of a query $Q$ is computed by identifying all the instances where $Q$ is derivable by SLG resolution.
\item \texttt{semlcpl.pl}: given an LPAD $P$, it builds an execution model of $P$, i.e., a probabilistic process that satisfy the principles of universal causation, sufficient causation, independent causation, no deus ex machina events and temporal precedence. It uses the definition of the semantics given in \cite{CP-logic-unp}.
\end{itemize}
%For program with function symbols, the semantics of LPADs and CP-logic are not defined. However, the interpreter accepts programs with function symbols and, if it does not go into a loop, it returns an answer. What is the meaning of this answer is subject of current study.
\section{Installation}
\texttt{cplint} is distributed in source code in the CVS version of Yap. It includes Prolog and C files. Download it by following the instruction in \href{http://www.ncc.up.pt/~vsc/Yap/downloads.html}{http://www.ncc.up.pt/$\sim$vsc/Yap/downloads.html}.
\texttt{cplint} requires glu (a subpackage of vis) and glib-2.0.
You can download glu from \href{http://vlsi.colorado.edu/~vis/getting_VIS_2.1.html}{http://vlsi.colorado.edu/$\sim$vis/getting\_VIS\_2.1.html}
You can download glib-2.0 (version $\geq 2.0$) from \href{http://www.gtk.org/}{http://www.gtk.org/}. This is a standard GNU package
so it is easy to install it using the package management software of your Linux or Cygwin
distribution.
Install glu:
\begin{enumerate}
\item downlad \texttt{glu-2.1.tar.gz}
\item decompress it
\item \texttt{cd glu-2.1}
\item \texttt{mkdir arch}
\item \texttt{cd arch}
\item \texttt{../configure}
\item \texttt{make}
\item \texttt{su}
\item \texttt{make install}
\end{enumerate}
This will install glu into \texttt{/usr/local}, if you want to install to a different \texttt{DIR}
use \texttt{../configure --prefix DIR}
Install Yap together with \texttt{cplint}:
when compiling Yap following the instuction of the \texttt{INSTALL} file in the root of the Yap folder, use
\begin{verbatim}
configure --enable-cplint
\end{verbatim}
Under Windows, you have to use Cygwin (glu does not compile under MinGW), so\\
\begin{verbatim}
configure --enable-cplint --enable-cygwin
\end{verbatim}
If you installed glu in \texttt{DIR}, use \texttt{--enable-cplint=DIR}
After having performed \texttt{make install} you can do \texttt{make installcheck} that will execute a suite of tests of the various programs. If no error is reported you have a working installation of \texttt{cplint}.
\section{Syntax}
Disjunction in the head is represented with a semicolon and atoms in the head are separated from probabilities by a colon. For the rest, the usual syntax of Prolog is used.
For example, the CP-logic clause
$$h_1:p_1\vee \ldots \vee h_n:p_n\leftarrow b_1,\dots,b_m ,\neg c_1,\ldots,\neg c_l$$
is represented by
\begin{verbatim}
h1:p1 ; ... ; hn:pn :- b1,...,bm,\+ c1,....,\+ cl
\end{verbatim}
No parentheses are necessary. The \texttt{pi} are numeric expressions. It is up to the user to ensure that the numeric expressions are legal, i.e. that they sum up to less than one.
If the clause has an empty body, it can be represented like this
\begin{verbatim}
h1:p1 ; ... ;hn:pn.
\end{verbatim}
If the clause has a single head with probability 1, the annotation can be omitted and the clause takes the form of a normal prolog clause, i.e.
\begin{verbatim}
h1:- b1,...,bm,\+ c1,...,\+ cl.
\end{verbatim}
stands for
\begin{verbatim}
h1:1 :- b1,...,bm,\+ c1,...,\+ cl.
\end{verbatim}
The coin example of \cite{VenVer04-ICLP04-IC} is represented as (see file \texttt{coin.cpl})
\begin{verbatim}
heads(Coin):1/2 ; tails(Coin):1/2:-
toss(Coin),\+biased(Coin).
heads(Coin):0.6 ; tails(Coin):0.4:-
toss(Coin),biased(Coin).
fair(Coin):0.9 ; biased(Coin):0.1.
toss(coin).
\end{verbatim}
The first clause states that if we toss a coin that is not biased it has equal probability of landing heads and tails. The second states that if the coin is biased it has a slightly higher probability of landing heads. The third states that the coin is fair with probability 0.9 and biased with probability 0.1 and the last clause states that we toss a coin with certainty.
\section{Commands}
All six modules accept the same commands for reading in files and answering queries.
The LPAD or CP-logic program must be stored in a text file with extension \texttt{.cpl}. Suppose you have stored the example above in file \texttt{coin.cpl}.
In order to answer queries from this program, you have to run Yap,
load one of the modules (such as for example \texttt{lpad.pl}) by issuing the command
\begin{verbatim}
use_module(library(lpad)).
\end{verbatim}
at the command prompt.
Then you must parse the source file \texttt{coin.cpl} with the command
\begin{verbatim}
p(coin).
\end{verbatim}
if \texttt{coin.cpl} is in the current directory, or
\begin{verbatim}
p('path_to_coin/coin').
\end{verbatim}
if \texttt{coin.cpl} is in a different directory.
At this point you can pose query to the program by using the predicate \texttt{s/2} (for solve) that takes as its first argument a conjunction of goals in the form of a list and returns the computed probability as its second argument. For example, the probability of the conjunction \texttt{head(coin),biased(coin)} can be asked with the query
\begin{verbatim}
s([head(coin),biased(coin)],P).
\end{verbatim}
For computing the probability of a conjunction given another conjunction you can use the predicate \texttt{sc/3} (for solve conditional) that take takes as input the query conjunction as its first argument, the evidence conjunction as its second argument and returns the probability in its third argument.
For example, the probability of the query \texttt{heads(coin)} given the evidence \texttt{biased(coin)} can be asked with the query
\begin{verbatim}
sc([heads(coin)],[biased(coin)],P).
\end{verbatim}
After having parsed a program, in order to read in a new program you must restart Yap when using
\texttt{semlpadsld.pl} and \texttt{semlpad.pl}. With the other modules, you can directly parse a new program.
When using \texttt{lpad.pl}, the system can print the message ``Uunsound program'' in the case in which an instance with a three valued well founded model is found. Moreover, it can print the message ``It requires the choice of a head atom from a non ground head'': in this case, in order to answer the query, all the groundings of the culprit clause must be generated, which may be impossible for programs with function symbols.
When using \texttt{semcpl.pl}, you can print the execution process by using the command \texttt{print.}
after \texttt{p(file).} Moreover, you can build an execution process given a context by issuing the command \texttt{parse(file)}. and then
\texttt{build(context).} where \texttt{context} is a list of atoms that are true in the context.
\texttt{semcpl.pl} can print ``Invalid program'' in the case in which no execution process exists.
When using \texttt{cpl.pl} you can print a partial execution model including all the clauses involved in the query issued with \texttt{print.} \texttt{cpl.pl} can print the messages ``Uunsound program'', ``It requires the choice of a head atom from a non ground head'' and ``Invalid program''.
The modules make use of a number of parameters in order to control their behavior. They that can be set with the command
\begin{verbatim}
set(parameter,value).
\end{verbatim}
from the Yap prompt after having loaded the module.
The current value can be read with
\begin{verbatim}
setting(parameter,Value).
\end{verbatim}
from the Yap prompt.
The available parameters are:
\begin{itemize}
\item
\verb|epsilon_parsing| (valid for all six modules): if (1 - the sum of the probabilities of all the head atoms) is smaller than
\verb|epsilon_parsing|
then \texttt{cplint} adds the null events to the head. Default value 0.00001
\item \verb|save_dot| (valid for all goal-oriented modules): if \texttt{true} a graph representing the BDD is saved in the file \texttt{cpl.dot} in the current directory in dot format.
The variables names are of the form \verb|Xn_m| where \texttt{n} is the number of the multivalued
variable and \texttt{m} is the number of the binary variable. The correspondence between variables and
clauses can be evinced from the message printed on the screen, such as
\begin{verbatim}
Variables: [(2,[X=2,X1=1]),(2,[X=1,X1=0]),(1,[])]
\end{verbatim}
where the first element of each couple is the clause number of the input file (starting from 1).
In the example above variable \texttt{X0} corresponds to clause \texttt{2} with the substitutions \texttt{X=2,X1=1},
variable \texttt{X1} corresponds to clause \texttt{2} with the substitutions \texttt{X=1,X1=0} and
variable \texttt{X2} corresponds to clause \texttt{1} with the empty substitution.
You can view the graph with \texttt{graphviz} (\href{www.graphviz.org}{www.graphviz.org}) using the
command
\begin{verbatim}
dotty cpl.dot &
\end{verbatim}
\item \verb|ground_body| (valid for \texttt{lpadsld.pl} and all semantic modules): determines how non ground clauses are treated: if \texttt{true}, ground clauses are obtained from a non ground clause by replacing each variable with a constant, if \texttt{false}, ground clauses are obtained by replacing only variables in the head with a constant. In the case where the body contains variables not in the head, setting it to false means that the body represents an existential event.
\end{itemize}
\section{Semantic Modules}
The three semantic modules need to produce a grounding of the program in order to compute the semantics.
They require an extra file with extension \texttt{.uni} (for universe) in the same directory where the \texttt{.cpl} file is.
There are two ways to specify how to ground a program. The first consists in providing the list of constants to which each variable can be instantiated. For example, in our case the current directory will contain a file \texttt{coin.uni} that is a Prolog file containing facts of the form
\begin{verbatim}
universe(var_list,const_list).
\end{verbatim}
where \verb|var_list| is a list of variables names (each must be included in single quotes) and \verb|const_list| is a list of constants. The semantic modules generate the grounding by instantiating in all possible ways the variables of \verb|var_list| with the constants of \verb|const_list|. Note that the variables are identified by name, so a variable with the same name in two different clauses will be instantiated with the same constants.
The other way to specify how to ground a program consists in using mode and type information. For each predicate, the file \texttt{.uni} must contain a fact of the form
\begin{verbatim}
mode(predicate(t1,...,tn)).
\end{verbatim}
that specifies the number and types of each argument of the predicate. Then, the list of constants that
are in the domain of each type \texttt{ti} must be specified with a fact of the form
\begin{verbatim}
type(ti,list_of_constants).
\end{verbatim}
The file \texttt{.uni} can contain both universe and mode declaration, the ones to be used depend on the value of the parameter \texttt{grounding}: with value \texttt{variables}, the universe declarations are used, with value \texttt{modes} the mode declarations are used.
With \texttt{semcpl.pl} only mode declarations can be used.
\section{Extensions}
In this section we will present the extensions to the syntax of LPADs and CP-logic programs that \texttt{cplint} can handle.
The first is the use of some standard Prolog predicates.
The bodies can contain the built-in predicates:
\begin{verbatim}
is/2
>/2
</2
>=/2
=</2
=:=/2
=\=/2
true/0
false/0
=/2
==/2
\=/2
\==/2
length/2
\end{verbatim}
The bodies can also contain the following
library predicates:
\begin{verbatim}
member/2
max_list/2
min_list/2
nth0/3
nth/3
\end{verbatim}
plus the predicate
\begin{verbatim}
average/2
\end{verbatim}
that, given a list of numbers, computes its arithmetic mean.
When using \texttt{lpadsld.pl}, the bodies can contain the predicates \texttt{setof/3} and \texttt{bagof/3} with the same meaning as in Prolog. Existential quantifiers are allowed in both, so for example the query
\begin{verbatim}
setof(Z, (term(X,Y))^foo(X,Y,Z), L).
\end{verbatim}
returns all the instantiations of \texttt{Z} such that there exists an instantiation of \texttt{X} and \texttt{Y} for which \texttt{foo(X,Y,Z)} is true.
An example of the use of \texttt{setof} and \texttt{bagof} is in the file \texttt{female.cpl}:
\begin{verbatim}
male(C):M/P ; female(C):F/P:-
person(C),
setof(Male,known_male(Male),LM),
length(LM,M),
setof(Female,known_female(Female),LF),
length(LF,F),
P is F+M.
person(f).
known_female(a).
known_female(b).
known_female(c).
known_male(d).
known_male(e).
\end{verbatim}
The disjunctive rule expresses the probability of a person of unknown sex of being male or female depending on the number of males and females that are known.
This is an example of the use of expressions in the probabilities in the head that depend on variables in the body. The probabilities are well defined because they always sum to 1 (unless \texttt{P} is 0).
Another use of \texttt{setof} and \texttt{bagof} is to have an attribute depend on an aggregate function of another attribute, similarly to what is done in PRM and CLP(BN).
So, in the classical school example (available in \texttt{student.cpl}) you can find the following
clauses:
\begin{verbatim}
student_rank(S,h):0.6 ; student_rank(S,l):0.4:-
bagof(G,R^(registr_stu(R,S),registr_gr(R,G)),L),
average(L,Av),Av>1.5.
student_rank(S,h):0.4 ; student_rank(S,l):0.6:-
bagof(G,R^(registr_stu(R,S),registr_gr(R,G)),L),
average(L,Av),Av =< 1.5.
\end{verbatim}
where \verb|registr_stu(R,S)| expresses that registration \texttt{R} refers to student \texttt{S} and \verb|registr_gr(R,G)| expresses that registration \texttt{R} reports grade \texttt{G} which is a natural number. The two clauses express a dependency of the rank of the student from the average of her grades.
Another extension can be used with \texttt{lpadsld.pl} in order to be able to represent reference uncertainty of PRMs. Reference uncertainty means that the link structure of a relational model is not fixed but is uncertain: this is represented by having the instance referenced in a relationship be chosen uniformly from a set. For example, consider a domain modeling scientific papers: you have a single entity, paper, and a relationship, cites, between paper and itself that connects the citing paper to the cited paper. To represent the fact that the cited paper and the citing paper are selected uniformly from certain sets, the following clauses can be used (see file \verb|paper_ref_simple.cpl|):
\begin{verbatim}
uniform(cites_cited(C,P),P,L):-
bagof(Pap,paper_topic(Pap,theory),L).
uniform(cites_citing(C,P),P,L):-
bagof(Pap,paper_topic(Pap,ai),L).
\end{verbatim}
The first clauses states that the paper \texttt{P} cited in a citation \texttt{C} is selected uniformly from the set of all papers with topic theory.
The second clauses expresses that the citing paper is selected uniformly from the papers with
topic ai.
These clauses make use of the predicate
\begin{verbatim}
uniform(Atom,Variable,List)
\end{verbatim}
in the head, where \texttt{Atom} must contain \texttt{Variable}. The meaning is the following: the set of all the atoms obtained by instantiating \texttt{Variable} of \texttt{Atom} with a term taken from \texttt{List} is generated and the head is obtained by having a disjunct for each instantiation with probability $1/N$ where $N$ is the length of \texttt{List}.
A more elaborate example is present in file \verb|paper_ref.cpl|:
\begin{verbatim}
uniform(cites_citing(C,P),P,L):-
setof(Pap,paper(Pap),L).
cites_cited_group(C,theory):0.9 ; cites_cited_group(C,ai):0.1:-
cites_citing(C,P),paper_topic(P,theory).
cites_cited_group(C,theory):0.01;cites_cited_group(C,ai):0.99:-
cites_citing(C,P),paper_topic(P,ai).
uniform(cites_cited(C,P),P,L):-
cites_cited_group(C,T),bagof(Pap,paper_topic(Pap,T),L).
\end{verbatim}
where the cited paper depends on the topic of the citing paper. In particular, if the topic is theory, the cited paper is selected uniformly from the papers about theory with probability 0.9 and from the papers about ai with probability 0.1. if the topic is ai, the cited paper is selected uniformly from the papers about theory with probability 0.01 and from the papers about ai with probability 0.99.
PRMs take into account as well existence uncertainty, where the existence of instances is also probabilistic. For example, in the paper domain, the total number of citations may be unknown and a citation between any two paper may have a probability of existing. For example, a citation between two paper may be more probable if they are about the same topic:
\begin{verbatim}
cites(X,Y):0.005 :-
paper_topic(X,theory),paper_topic(Y,theory).
cites(X,Y):0.001 :-
paper_topic(X,theory),paper_topic(Y,ai).
cites(X,Y):0.003 :-
paper_topic(X,ai),paper_topic(Y,theory).
cites(X,Y):0.008 :-
paper_topic(X,ai),paper_topic(Y,ai).
\end{verbatim}
This is an example where the probabilities in the head do not sum up to one so the null event is automatically added to the head.
The first clause states that, if the topic of a paper \texttt{X} is theory and of paper \texttt{Y} is theory, there is a probability of 0.005 that there is a citation from \texttt{X} to \texttt{Y}. The other clauses consider the remaining cases for the topics.
\section{Additional Files}
In the directory where Yap keeps the library files (usually \texttt{/usr/local/share/ Yap}) you can find the directory \texttt{cplint} that contains the files:
\begin{itemize}
\item \verb|testlpadsld_gbtrue.pl, testlpadsld_gbfalse.pl, testlpad.pl,|
\verb|testcpl.pl, testsemlpadsld.pl, testsemlpad.pl testsemcpl.pl|: Prolog programs for testing the modules. They are executed when issuing the command \texttt{make installcheck} during the installation. To execute them afterwords, load the file and issue the command \texttt{t.}
\item Subdirectory \texttt{examples}:
\begin{itemize}
\item \texttt{alarm.cpl}: representation of the Bayesian network in Figure 2 of
\cite{VenVer04-ICLP04-IC}.
\item \texttt{coin.cpl}: coin example from \cite{VenVer04-ICLP04-IC}.
\item \texttt{coin2.cpl}: coin example with two coins.
\item \texttt{dice.cpl}: dice example from \cite{VenVer04-ICLP04-IC}.
\item \verb|twosideddice.cpl, threesideddice.cpl| game with idealized dice with two or three sides. Used in the experiments in \cite{Rig-RCRA07-IC}.
\item \texttt{ex.cpl}: first example in \cite{Rig-RCRA07-IC}.
\item \texttt{exapprox.cpl}: example showing the problems of approximate inference (see \cite{Rig-RCRA07-IC}).
\item \texttt{exrange.cpl}: example showing the problems with non range restricted programs (see \cite{Rig-RCRA07-IC}).
\item \texttt{female.cpl}: example showing the dependence of probabilities in the head from variables in the body (from \cite{VenVer04-ICLP04-IC}).
\item \texttt{mendel.cpl, mendels.cpl}: programs describing the Mendelian rules of inheritance, taken from \cite{Blo04-ILP04WIP-IC}.
\item \verb|paper_ref.cpl, paper_ref_simple.cpl|: paper citations examples, showing reference uncertainty, inspired by \cite{Getoor+al:JMLR02}.
\item \verb|paper_ref_not.cpl|: paper citations example showing that negation can be used also for predicates defined by clauses with \texttt{uniform} in the head.
\item \texttt{school.cpl}: example inspired by the example \verb|school_32.yap| from the
source distribution of Yap in the \texttt{CLPBN} directory.
\item \verb|school_simple.cpl|: simplified version of \texttt{school.cpl}.
\item \verb|student.cpl|: student example from Figure 1.3 of \cite{GetFri01-BC}.
\item \texttt{win.cpl, light.cpl, trigger.cpl, throws.cpl, hiv.cpl,}\\ \texttt{ invalid.cpl}: programs taken from \cite{CP-logic-unp}. \texttt{invalid.cpl} is an example of a program that is invalid but sound.
\end{itemize}
The files \texttt{*.uni} that are present for some of the examples are used by the semantical modules. Some of the example files contain in an initial comment some queries together with their result.
\item Subdirectory \texttt{doc}: contains this manual in latex, html and pdf.
\end{itemize}
\section{License}
\label{license}
\texttt{cplint}, as Yap, follows the Artistic License 2.0 that you can find in Yap CVS root dir. The copyright is by Fabrizio Riguzzi.
\vspace{3mm}
The program uses the library \href{http://vlsi.colorado.edu/~fabio/}{CUDD} for manipulating BDDs that is included in glu.
For the use of CUDD, the following license must be accepted:
\vspace{3mm}
Copyright (c) 1995-2004, Regents of the University of Colorado
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
\begin{itemize}
\item
Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
\item
Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
\item
Neither the name of the University of Colorado nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
\end{itemize}
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
CAU-SED
\\ 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.
\texttt{lpad.pl}, \texttt{semlpad.pl} and \texttt{cpl.pl} are based on the SLG system
by \href{http://engr.smu.edu/~wchen/}{Weidong Chen} and \href{http://www.cs.sunysb.edu/~warren/}{David Scott Warren},
Copyright (C) 1993 Southern Methodist University, 1993 SUNY at Stony Brook, see the file COYPRIGHT\_SLG for detailed information on this copyright.
\bibliographystyle{plain}
\bibliography{bib}
\end{document}

BIN
packages/cplint/doc/manual0x.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

7
packages/cplint/examples/alarm.cpl Normal file
View File

@ -0,0 +1,7 @@
burg(t):0.1; burg(f):0.9.
earthq(t):0.2; earthq(f):0.8.
alarm(t):-burg(t),earthq(t).
alarm(t):0.8 ; alarm(f):0.2:-burg(t),earthq(f).
alarm(t):0.8 ; alarm(f):0.2:-burg(f),earthq(t).
alarm(t):0.1 ; alarm(f):0.9:-burg(f),earthq(f).

17
packages/cplint/examples/coin.cpl Normal file
View File

@ -0,0 +1,17 @@
/*
s([heads(C)],P).
C = coin
P = 0.51 ?;
no
s([tails(C)],P).
C = coin
P = 0.49 ?;
no
*/
heads(Coin): 1/2; tails(Coin) : 1/2:-toss(Coin),\+biased(Coin).
heads(Coin): 0.6 ; tails(Coin) : 0.4:-toss(Coin),biased(Coin).
fair(Coin):0.9 ; biased(Coin):0.1.
toss(coin).

0
packages/cplint/examples/coin.uni Normal file
View File

23
packages/cplint/examples/coin2.cpl Normal file
View File

@ -0,0 +1,23 @@
/*
?- s([heads(C)],P).
C = coin1
P = 0.51 ? ;
C = coin2
P = 0.51 ? ;
no
?- s([tails(C)],P).
C = coin1
P = 0.49 ? ;
C = coin2
P = 0.49 ? ;
no
s([tails(coin1)],P).
P = 0.49 ?
*/
heads(Coin): 0.5; tails(Coin) : 0.5:-toss(Coin),fair(Coin).
heads(Coin): 0.6 ; tails(Coin) : 0.4:-toss(Coin),biased(Coin).
fair(Coin):0.9 ; biased(Coin):0.1.
toss(coin1).
toss(coin2).

9
packages/cplint/examples/coin2.uni Normal file
View File

@ -0,0 +1,9 @@
universe(['Coin'],[coin1,coin2]).
mode(heads(coin)).
mode(tails(coin)).
mode(toss(coin)).
mode(fair(coin)).
mode(biased(coin)).
type(coin,[coin1,coin2]).

29
packages/cplint/examples/dice.cpl Normal file
View File

@ -0,0 +1,29 @@
/*
s([on(0,1)],P).
P = 0.166666666666667 ?;
s([\+ on(0,6)],P).
P = 0.833333333333333 ?;
s([on(1,1)],P).
P = 0.138888888888889 ?
s([on(1,6)],P).
P = 0.138888888888889 ?
s([on(2,1)],P).
out of memory
s([on(0,1),on(1,1)],P).
P = 0.0277777777777778 ?
s([on(0,1),on(1,1),on(2,1)],P).
P = 0.00462962962962963 ?
*/
on(0,1):1/6;on(0,2):1/6;on(0,3):1/6;
on(0,4):1/6;on(0,5):1/6;on(0,6):1/6.
on(X,1):1/6;on(X,2):1/6;on(X,3):1/6;
on(X,4):1/6;on(X,5):1/6;on(X,6):1/6:-
X1 is X-1,X1>=0,on(X1,_),
\+ on(X1,6).

2
packages/cplint/examples/dice.uni Normal file
View File

@ -0,0 +1,2 @@
universe(['X'],[1,2]).
universe(['X1'],[0,1]).

13
packages/cplint/examples/ex.cpl Normal file
View File

@ -0,0 +1,13 @@
/*
s([a],P).
Variables: [(1,[]),(2,[]),(3,[])]
P = 0.226 ?
*/
a:0.1.
b:0.3;c:0.6.
a:0.2:- \+ b.

6
packages/cplint/examples/ex.uni Normal file
View File

@ -0,0 +1,6 @@
mode(a).
mode(b).
mode(c).

17
packages/cplint/examples/exapprox.cpl Normal file
View File

@ -0,0 +1,17 @@
/*
set(ground_body,true).
s([a],P).
Variables: [(1,[]),(2,[]),(3,[])]
P = 0.1719 ? ;
set(ground_body,false).
?- s([a],P).
P = 0.099 ?
*/
a:0.1:-p(X).
p(1):0.9.
p(2):0.9.

9
packages/cplint/examples/exapprox.uni Normal file
View File

@ -0,0 +1,9 @@
universe(['X'],[1,2]).
mode(a).
mode(p(int)).
type(int,[1,2]).

32
packages/cplint/examples/exist.cpl Normal file
View File

@ -0,0 +1,32 @@
/*
semlpad.pl
ground_body(false)
?- s([a],P).
P = 0.18 ?
ground_body(true)
?- s([a],P).
P = 0.19 ?
yes
yes
lpad.pl
ground_body(false)
?- s([a],P).
P = 0.02 ?
yes
ground_body(true)
?- s([a],P).
P = 0.19 ?
yes
*/
a:0.5 :- p(X).
p(X):0.2 :- c(X).
c(1).
c(2).

8
packages/cplint/examples/exist.uni Normal file
View File

@ -0,0 +1,8 @@
mode(a).
mode(p(int)).
mode(c(int)).
type(int,[1,2]).

31
packages/cplint/examples/exist1.cpl Normal file
View File

@ -0,0 +1,31 @@
/*
semlpad.pl
ground_body(false)
?- s([a],P).
P = 0.276 ?
ground_body(true)
?- s([a],P).
P = 0.3115 ?
yes
lpad.pl
ground_body(false)
?- s([a],P).
P = 0.276 ?
ground_body(true)
?- s([a],P).
P = 0.3115 ?
*/
a:0.5 :- p(X).
p(3):0.3.
p(X):0.2 :- c(X).
c(1).
c(2).

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