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

new ve

Browse Source
This commit is contained in:
Costa Vitor 2012-08-28 20:21:14 -05:00
parent fcfc0e52d7
commit 62ab5b3dcb
10 changed files with 399 additions and 251 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
packages/CLPBN/Makefile.in
View File

@ -63,6 +63,7 @@ CLPBN_PROGRAMS= \
$(CLPBN_SRCDIR)/utils.yap \
$(CLPBN_SRCDIR)/ve.yap \
$(CLPBN_SRCDIR)/viterbi.yap \
$(CLPBN_SRCDIR)/vmap.yap \
$(CLPBN_SRCDIR)/xbif.yap
CLPBN_LEARNING_PROGRAMS= \
@ -94,7 +95,7 @@ CLPBN_HMMER_EXAMPLES= \
$(CLPBN_EXDIR)/HMMer/score.yap
CLPBN_LEARNING_EXAMPLES= \
$(CLPBN_EXDIR)/learning/profz_params.pfl \
$(CLPBN_EXDIR)/learning/prof_params.pfl \
$(CLPBN_EXDIR)/learning/school_params.pfl \
$(CLPBN_EXDIR)/learning/sprinkler_params.yap \
$(CLPBN_EXDIR)/learning/train.yap

60
packages/CLPBN/clpbn.yap
View File

@ -19,6 +19,7 @@
:- use_module(library(bhash)).
:- use_module(library(lists)).
:- use_module(library(terms)).
:- use_module(library(maplist)).
%
% avoid the overhead of using goal_expansion/2.
@ -320,58 +321,47 @@ call_ground_solver(bp, GVars, GoalKeys, Keys, Factors, Evidence) :- !,
call_ground_solver(Solver, GVars, _GoalKeys, Keys, Factors, Evidence) :-
% traditional solver
b_hash_new(Hash0),
gvars_in_hash(GVars,Hash0, HashI),
keys_to_vars(Keys, AllVars, HashI, Hash1),
evidence_to_vars(Evidence, _EVars, Hash1, Hash),
factors_to_dists(Factors, Hash),
foldl(gvar_in_hash, GVars, Hash0, HashI),
foldl(key_to_var, Keys, AllVars, HashI, Hash1),
foldl(evidence_to_v, Evidence, _EVars, Hash1, Hash),
writeln(Keys:AllVars),
maplist(factor_to_dist(Hash), Factors),
% evidence
retract(use_parfactors(on)),
write_out(Solver, [GVars], AllVars, _),
assert(use_parfactors(on)).
%
% convert a PFL network (without constriants)
% convert a PFL network (without constraints)
% into CLP(BN) for evaluation
%
gvars_in_hash([V|GVars],Hash0, Hash) :-
gvar_in_hash(V, Hash0, Hash) :-
get_atts(V, [key(K)]),
b_hash_insert(Hash0, K, V, HashI),
gvars_in_hash(GVars,HashI, Hash).
gvars_in_hash([],Hash, Hash).
b_hash_insert(Hash0, K, V, Hash).
key_to_var(K, V, Hash0, Hash0) :-
b_hash_lookup(K, V, Hash0), !.
key_to_var(K, V,Hash0, Hash) :-
put_atts(V, [key(K)]),
b_hash_insert(Hash0, K, V, Hash).
keys_to_vars([], [], Hash, Hash).
keys_to_vars([K|Keys], [V|Vs], Hash0, Hash) :-
evidence_to_v(K=E, V, Hash0, Hash0) :-
b_hash_lookup(K, V, Hash0), !,
keys_to_vars(Keys, Vs, Hash0, Hash).
keys_to_vars([K|Keys], [V|Vs],Hash0, Hash) :-
b_hash_insert(Hash0, K, V, HashI),
keys_to_vars(Keys, Vs, HashI, Hash).
clpbn:put_atts(V,[evidence(E)]).
evidence_to_v(K=E, V, Hash0, Hash) :-
b_hash_insert(Hash0, K, V, Hash),
clpbn:put_atts(V,[evidence(E)]).
evidence_to_vars([], [], Hash, Hash).
evidence_to_vars([K=E|Keys], [V|Vs], Hash0, Hash) :-
b_hash_lookup(K, V, Hash0), !,
clpbn:put_atts(V,[evidence(E)]),
evidence_to_vars(Keys, Vs, Hash0, Hash).
evidence_to_vars([K=E|Keys], [V|Vs],Hash0, Hash) :-
b_hash_insert(Hash0, K, V, HashI),
clpbn:put_atts(V,[evidence(E)]),
evidence_to_vars(Keys, Vs, HashI, Hash).
factors_to_dists([], _Hash).
factors_to_dists([f(bayes,_Id,Ks,CPT)|Factors], Hash) :-
keys_to_vars(Ks, Hash, [V|Parents]),
factor_to_dist(Hash, f(bayes, Id, Ks)) :-
maplist(key_to_var(Hash), Ks, [V|Parents]),
Ks =[Key|_],
pfl:skolem(Key, Domain),
pfl:get_pfl_parameters(Id, CPT),
dist(p(Domain,CPT,Parents), DistInfo, Key, Parents),
put_atts(V,[dist(DistInfo,Parents)]),
factors_to_dists(Factors, Hash).
keys_to_vars([], _Hash, []).
keys_to_vars([K|Ks], Hash, [V|Vs]) :-
b_hash_lookup(K,V,Hash),
keys_to_vars(Ks, Hash, Vs).
put_atts(V,[dist(DistInfo,Parents)]).
key_to_var(Hash, K, V) :-
b_hash_lookup(K, V, Hash).
get_bnode(Var, Goal) :-
get_atts(Var, [key(Key),dist(Dist,Parents)]),

2
packages/CLPBN/clpbn/aggregates.yap
View File

@ -38,7 +38,7 @@ 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([V|Vs0], [V|Vs1]) :-
check_for_agg_vars(Vs0, Vs1).
% transform aggregate distribution into tree

2
packages/CLPBN/clpbn/discrete_utils.yap
View File

@ -8,7 +8,7 @@
%
% remove columns from a table
%
project_from_CPT(V,tab(Table,Deps,Szs),tab(NewTable,NDeps,NSzs)) :-
project_from_CPT(V,f(Table,Deps,Szs),f(NewTable,NDeps,NSzs)) :-
propagate_evidence(V,Evs),
functor(Table,_,Max),
find_projection_factor(Deps, V, NDeps, Szs, NSzs, F, Sz),

27
packages/CLPBN/clpbn/ground_factors.yap
View File

@ -23,6 +23,8 @@
nth0/3,
member/2]).
:- use_module(library(maplist)).
:- use_module(library(pfl), [
factor/6,
defined_in_factor/2,
@ -44,7 +46,7 @@ generate_network(QueryVars, QueryKeys, Keys, Factors, EList) :-
include_evidence(AVars, Evidence0, Evidence),
b_hash_to_list(Evidence, EList0), list_to_evlist(EList0, EList),
run_through_evidence(EList),
run_through_queries(QueryVars, QueryKeys, Evidence),
run_through_query(Evidence, QueryVars, QueryKeys),
propagate,
collect(Keys, Factors).
@ -88,20 +90,15 @@ include_static_evidence([K=E|AVars], Evidence0, Evidence) :-
include_evidence(AVars, EvidenceI, Evidence).
run_through_queries([QVars|QueryVars], [GKs|GKeys], E) :-
run_through_query(QVars, GKs, E),
run_through_queries(QueryVars, GKeys, E).
run_through_queries([], [], _).
run_through_query([], [], _).
run_through_query([V|QueryVars], QueryKeys, Evidence) :-
run_through_query(_, [], []).
run_through_query(Evidence, [V|QueryVars], QueryKeys) :-
clpbn:get_atts(V,[key(K)]),
b_hash_lookup(K, _, Evidence), !,
run_through_query(QueryVars, QueryKeys, Evidence).
run_through_query([V|QueryVars], [K|QueryKeys], Evidence) :-
run_through_query(Evidence, QueryVars, QueryKeys).
run_through_query(Evidence, [V|QueryVars], [K|QueryKeys]) :-
clpbn:get_atts(V,[key(K)]),
queue_in(K),
run_through_query(QueryVars, QueryKeys, Evidence).
run_through_query(Evidence, QueryVars, QueryKeys).
collect(Keys, Factors) :-
findall(K, currently_defined(K), Keys),
@ -142,8 +139,10 @@ initialize_evidence([V|EVars]) :-
queue_in(K) :-
queue(K), !.
queue_in(K) :-
%writeln(+K),
assert(queue(K)).
writeln(+K),
assert(queue(K)),
fail.
queue_in(_).
propagate :-
retract(queue(K)),!,
@ -167,7 +166,7 @@ do_propagate(K) :-
\+ currently_defined(K1),
queue_in(K1),
fail.
do_propagate(K) :-
do_propagate(_K) :-
propagate.
add_factor(factor(Type, Id, Ks, _, Phi, Constraints), Ks) :-

27
packages/CLPBN/clpbn/matrix_cpt_utils.yap
View File

@ -1,10 +1,13 @@
:- module(clpbn_matrix_utils,
[init_CPT/2,
[init_CPT/3,
project_from_CPT/3,
sum_out_from_CPT/5,
project_from_CPT/6,
reorder_CPT/5,
get_CPT_sizes/2,
normalise_CPT/2,
multiply_CPTs/4,
multiply_CPTs/6,
divide_CPTs/3,
expand_CPT/4,
reset_CPT_that_disagrees/5,
@ -51,6 +54,20 @@ init_CPT(List, Sizes, TAB) :-
init_possibly_deterministic_CPT(List, Sizes, TAB) :-
matrix_new(floats, Sizes, List, TAB).
%
% select elements of matrix Table such that V=Pos
%
project_from_CPT(V, Pos, Table, Deps, NewTable, NDeps) :-
vnth(Deps, 0, V, N, NDeps),
matrix_select(Table, N, Pos, NewTable).
%
% sum-out varibale V from Table
%
sum_out_from_CPT(V, Table, Deps, NewTable, NDeps) :-
vnth(Deps, 0, V, N, NDeps),
matrix_sum_logs_out(Table, N, NewTable).
project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
evidence(V,Pos), !,
vnth(Deps, 0, V, N, NDeps),
@ -133,6 +150,14 @@ multiply_CPTs(tab(Tab1, Deps1, Sz1), tab(Tab2, Deps2, Sz2), tab(OT, NDeps, NSz),
matrix_op(NTab1,NTab2,+,OT),
matrix_dims(OT,NSz).
multiply_CPTs(Tab1, Deps1, Tab2, Deps2, OT, NDeps) :-
matrix_dims(Tab1, Sz1),
matrix_dims(Tab2, Sz2),
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).
expand_tabs([], [], [], [], [], [], []).
expand_tabs([V1|Deps1], [S1|Sz1], [], [], [0|Map1], [S1|Map2], [V1|NDeps]) :-

471
packages/CLPBN/clpbn/ve.yap
View File

@ -33,6 +33,8 @@
[
dist/4,
get_dist_domain_size/2,
get_dist_params/2,
get_dist_domain_size/2,
get_dist_matrix/5]).
:- use_module(library('clpbn/utils'), [
@ -47,243 +49,322 @@
influences/4
]).
:- 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(clpbn/matrix_cpt_utils)).
:- use_module(library(lists),
[
append/3
member/2,
append/3,
delete/3
]).
:- use_module(library(maplist)).
:- use_module(library(rbtrees)).
:- use_module(library(clpbn/vmap)).
:- use_module(library('clpbn/aggregates'),
[check_for_agg_vars/2]).
%
% uses a bipartite graph where bigraph(Vs, NFs, Fs)
% Vs=map variables to lists of factors
% NFs=number of factors
% Fs=map factor id -> f(Id, Vars, Table)
%
check_if_ve_done(Var) :-
get_atts(Var, [size(_)]), !.
%
%
% implementation of the well known variable elimination algorithm
%
ve([[]],_,_) :- !.
ve([LVs],Vs0,AllDiffs) :-
init_ve_solver([LVs], Vs0, AllDiffs, State),
ve(LLVs,Vs0,AllDiffs) :-
init_ve_solver(LLVs, Vs0, AllDiffs, State),
% variable elimination proper
run_ve_solver([LVs], [LPs], State),
run_ve_solver(LLVs, LLPs, State),
% bind Probs back to variables so that they can be output.
clpbn_bind_vals([LVs],[LPs],AllDiffs).
clpbn_bind_vals(LLVs,LLPs,AllDiffs).
init_ve_solver(Qs, Vs0, _, LVis) :-
%
% Qs is a list of lists with all query vars (marginals)
% IQs is the corresponding list of integers
% LVis is a list of lists with all variables reachable from the query
% ILVis is the corresponding list of integers
% Vmap is the map V->I
%
init_ve_solver(Qs, Vs0, _, state(IQs, LVIs, VMap, Bigraph, Ev)) :-
check_for_agg_vars(Vs0, Vs1),
% LVi will have a list of CLPBN variables
init_influences(Vs1, G, RG),
init_ve_solver_for_questions(Qs, G, RG, _, LVis).
init_influences(Vs1, Graph, TGraph),
maplist(init_ve_solver_for_question(Graph, TGraph), Qs, LVs),
init_vmap(VMap0),
lvars_to_numbers(LVs, LVIs, VMap0, VMap1),
lvars_to_numbers(Qs, IQs, VMap1, VMap),
vars_to_bigraph(VMap, Bigraph, Ev).
init_ve_solver_for_questions([], _, _, [], []).
init_ve_solver_for_questions([Vs|MVs], G, RG, [NVs|MNVs0], [NVs|LVis]) :-
init_ve_solver_for_question(G, RG, Vs, NVs) :-
influences(Vs, G, RG, NVs0),
sort(NVs0, NVs),
%clpbn_gviz:clpbn2gviz(user_error, test, NVs, Vs),
init_ve_solver_for_questions(MVs, G, RG, MNVs0, LVis).
sort(NVs0, NVs).
%
% construct a bipartite graph with vars and factors
% the nodes of the var graph just contain pointer to the factors
% the nodes of the factors contain alist of variables and a matrix
% also provide a matrix with evidence
%
vars_to_bigraph(VMap, bigraph(VInfo, IF, Fs), Evs) :-
rb_new(Fs0),
vmap_to_list(VMap, VIds),
foldl3(id_to_factor(VMap), VIds, 0, IF, Fs0, Fs, [], Evs),
factors_to_vs(Fs, VInfo).
id_to_factor(VMap, V-I, IF0, IF, Fs0, Fs, Evs0, Evs) :-
% process evidence for variable
clpbn:get_atts(V, [evidence(E), dist(_,Ps)]),
checklist(noparent_of_interest(VMap), Ps), !,
% I don't need to get a factor here
Evs = [I=E|Evs0],
IF = IF0,
Fs = Fs0.
id_to_factor(VMap, V-I, IF0, IF, Fs0, Fs, Evs0, Evs) :-
% process distribution/factors
(
clpbn:get_atts(V, [evidence(E)])
->
Evs = [I=E|Evs0]
;
Evs = Evs0
),
clpbn:get_atts(V, [dist(D, Ps)]),
get_dist_params(D, Pars0),
get_dist_domain_size(D, DS),
maplist(parent_to_id(VMap), Ps, Sizes, IPs),
init_CPT(Pars0, [DS|Sizes], CPT0),
reorder_CPT([I|IPs], CPT0, FIPs, CPT, _),
rb_insert(Fs0, IF0, f(IF0, FIPs, CPT), Fs),
IF is IF0+1.
noparent_of_interest(VMap, P) :-
\+ get_from_vmap(P, _, VMap).
parent_to_id(VMap, V, DS, I) :-
clpbn:get_atts(V, [dist(D, _Ps)]),
get_dist_domain_size(D, DS),
get_from_vmap(V, I, VMap).
factors_to_vs(Fs, VInfo) :-
rb_visit(Fs, L),
foldl(fsvs, L, FVs, []),
sort(FVs, SFVs),
rb_new(VInfo0),
add_vs(SFVs, Fs, VInfo0, VInfo).
fsvs(F-f(_, IVs, _)) -->
fvs(IVs, F).
fvs([], _F) --> [].
fvs([I|IVs], F) -->
[I-F],
fvs(IVs, F).
%
% construct variable nodes
%
add_vs([], _, VInfo, VInfo).
add_vs([V-F|SFVs], Fs, VInfo0, VInfo) :-
rb_lookup(F, FInfo, Fs),
collect_factors(SFVs, Fs, V, Fs0, R),
rb_insert(VInfo0, V, [FInfo|Fs0], VInfoI),
add_vs(R, Fs, VInfoI, VInfo).
collect_factors([], _Fs, _V, [], []).
collect_factors([V-F|SFVs], Fs, V, [FInfo|FInfos], R):-
!,
rb_lookup(F, FInfo, Fs),
collect_factors(SFVs, Fs, V, FInfos, R).
collect_factors(SFVs, _Fs, _V, [], SFVs).
% solve each query independently
% use a findall to recover space without needing for GC
run_ve_solver(LVs, LPs, LNVs) :-
findall(Ps, solve_ve(LVs, LNVs, Ps), LPs).
run_ve_solver(_, LLPs, state(LQVs, LVs, _VMap, Bigraph, Ev)) :-
findall(LPs, solve_ve(LQVs, LVs, Bigraph, Ev, LPs), LLPs).
solve_ve([LVs|_], [NVs0|_], Ps) :-
% length(NVs0, L), (L > 10 -> clpbn_gviz:clpbn2gviz(user_error,sort,NVs0,LVs) ; true ),
% length(NVs0, L), writeln(+L),
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,_,_)),
%
% IQVs are the current marginal,
% IVs are all variables related to that
% IFVs are the factors
% SVs are the variables
%
solve_ve([IQVs|_], [IVs|_], bigraph(OldVs, IF, _Fs), Ev, Ps) :-
% get only what is relevant to query,
project_to_query_related(IVs, OldVs, SVs, Fs1),
% and also prune using evidence
foldl2(clean_v_ev, Ev, Fs1, Fs2, SVs, EVs),
% eliminate
eliminate(IQVs, digraph(EVs, IF, Fs2), Dist),
% writeln(m:Dist),matrix:matrix_to_list(Dist,LD),writeln(LD),
%exps(LD,LDE),writeln(LDE),
% move from potentials back to probabilities
normalise_CPT(Dist,MPs),
list_from_CPT(MPs, Ps).
solve_ve([_|MoreLVs], [_|MoreLVis], Ps) :-
solve_ve(MoreLVs, MoreLVis, Ps).
exps([],[]).
exps([L|LD],[O|LDE]) :-
O is exp(L),
exps(LD,LDE).
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).
solve_ve([_|MoreLVs], [_|MoreLVis], Digraph, Ev, Ps) :-
solve_ve(MoreLVs, MoreLVis, Digraph, Ev, Ps).
%
% just get a list of variables plus associated tables
% given our input queries, sort them and obtain the subgraphs of vars and facs.
%
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,_,_),
ve_get_dist_size(V,Sz),
ProcessedVars = [Var|ProcessedVars0]
;
ProcessedVars = ProcessedVars0
),
find_all_clpbn_vars(Vs, NVs0, LV, ProcessedVars0, Tables).
project_to_query_related(IVs0, OldVs, NVs, NFs) :-
sort(IVs0, IVs),
rb_new(Vs0),
foldl(cp_to_vs, IVs, Vs0, AuxVs),
rb_new(NFs0),
foldl(simplify_graph_node(OldVs, AuxVs), IVs, VFs, NFs0, NFs),
list_to_rbtree(VFs, NVs).
var_with_deps(V, NVs0, Table, Deps, Sizes, Ev, Vals) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
get_dist_matrix(Id,Parents,_,Vals,TAB0),
%
% auxiliary tree for fast access to vars.
%
cp_to_vs(V, Vs0, Vs) :-
rb_insert(Vs0, V, _, Vs).
%
% construct a new, hopefully much smaller, graph
%
simplify_graph_node(OldVs, NVs, V, V-RemFs, NFs0, NFs) :-
rb_lookup(V, Fs, OldVs),
foldl2(check_factor(V, NVs), Fs, NFs0, NFs, [], RemFs).
%
% check if a factor belongs to the subgraph.
%
%
% Two cases: first time factor comes up: all its vars must be in subgraph
% second case: second time it comes up, it must be already in graph
%
% args: +Factor F, +current V (int), +rbtree with all Vs,
% -Factors in new Graph, +factors in current graph, -rbtree of factors
%
%
check_factor(V, NVs, F, NFs0, NFs, RemFs, NewRemFs) :-
F = f(IF, [V|More], _), !,
(
clpbn:get_atts(V, [evidence(Ev)])
checklist(check_v(NVs), More)
->
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).
rb_insert(NFs0, IF, F, NFs),
NewRemFs = [F|RemFs]
;
NFs0 = NFs,
NewRemFs = RemFs
).
check_factor(_V, _NVs, F, NFs, NFs, RemFs, NewRemFs) :-
F = f(Id, _, _),
(
rb_lookup(Id, F, NFs)
->
NewRemFs = [F|RemFs]
;
NewRemFs = RemFs
).
find_all_table_deps(Tables0, LV) :-
find_dep_graph(Tables0, DepGraph0),
sort(DepGraph0, DepGraph),
add_table_deps_to_variables(LV, DepGraph).
check_v(NVs, V) :-
rb_lookup(V, _, NVs).
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).
%
% simplify a variable with evidence
%
clean_v_ev(V=E, FVs0, FVs, Vs0, Vs) :-
rb_delete(Vs0, V, Fs, Vs1),
foldl2(simplify_f_ev(V, E), Fs, FVs0, FVs, Vs1, Vs).
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).
%
%
% tricky: clean a factor means also cleaning all back references.
%
simplify_f_ev(V, E, F, Fs0, Fs, Vs0, Vs) :-
F = f(Id, FVs, CPT),
NF = f(Id, NFVs, NCPT),
project_from_CPT(V, E, CPT, FVs, NCPT, NFVs),
% update factor
rb_update(Fs0, Id, NF, Fs),
foldl(update_factors(F,NF), NFVs, Vs0, Vs).
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, []).
% update all instances of F in var graph
update_factors(F, NF, V, Vs0, Vs) :-
rb_update(Vs0, V, Fs, NFs, Vs),
maplist(replace_factor(F,NF), Fs, NFs).
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).
replace_factor(F, NF, F, NF) :- !.
replace_factor(_F,_NF,OF, OF).
multiply_sizes([],K,K).
multiply_sizes([V|Vs],K0,K) :-
ve_get_dist_size(V, Sz),
KI is K0*Sz,
multiply_sizes(Vs,KI,K).
eliminate(QVs, digraph(Vs0, I, Fs0), Dist) :-
find_best(Vs0, QVs, BestV, VFs), !,
%writeln(best:BestV:QVs),
% delete all factors that touched the variable
foldl2(del_fac, VFs, Fs0, Fs1, Vs0, Vs1),
% delete current variable
rb_delete(Vs1, BestV, Vs2),
I1 is I+1,
% construct new table
multiply_and_delete(VFs, BestV, NewFVs, NewCPT),
% insert new factor in graph
insert_fac(I, NewFVs, NewCPT, Fs1, Fs, Vs2, Vs),
eliminate(QVs, digraph(Vs, I1, Fs), Dist).
eliminate(_QVs, digraph(_, _, Fs), Dist) :-
combine_factors(Fs, Dist).
process(LV0, InputVs, Out) :-
find_best(LV0, V0, -1, V, WorkTables, LVI, InputVs),
V \== V0, !,
% clpbn:get_atts(V,[key(K)]), writeln(chosen:K),
% format('1 ~w: ~w~n',[V,WorkTables]), write_tables(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]), write_tables([NewTable]),
include(LVI,NewTable,V,LV2),
process(LV2, InputVs, Out).
process(LV0, _, Out) :-
fetch_tables(LV0, WorkTables0),
sort(WorkTables0, WorkTables),
% format('4 ~w: ~w~n',[LV0,WorkTables]), write_tables(WorkTables),
multiply_tables(WorkTables, Out).
find_best(Vs, QVs, BestV, VFs) :-
rb_key_fold(best_var(QVs), Vs, i(+inf,-1,[]), i(_Cost,BestV,VFs)),
BestV \= -1, !.
% do not eliminate marginalised variables
best_var(QVs, I, _Node, Info, Info) :-
member(I, QVs),
!.
% pick the variable with less factors
best_var(_Qs, I, Node, i(ValSoFar,_,_), i(NewVal,I,Node)) :-
length(Node, NewVal),
NewVal < ValSoFar,
!.
best_var(_, _I, _Node, Info, Info).
% delete one factor, need to also touch all variables
del_fac(f(I,FVs,_), Fs0, Fs, Vs0, Vs) :-
rb_delete(Fs0, I, Fs),
foldl(delete_fac_from_v(I), FVs, Vs0, Vs).
delete_fac_from_v(I, FV, Vs0, Vs) :-
rb_update(Vs0, FV, Fs, NFs, Vs),
exclude(factor_name(I), Fs, NFs).
factor_name(I, f(I,_,_)).
% insert one factor, need to touch all corresponding variables
insert_fac(I, FVs, CPT, Fs0, Fs, Vs0, Vs) :-
F = f(I, FVs, CPT),
rb_insert(Fs0, I, F, Fs),
foldl(insert_fac_in_v(F), FVs, Vs0, Vs).
insert_fac_in_v(F, FV, Vs0, Vs) :-
rb_update(Vs0, FV, Fs, [F|Fs], Vs).
combine_factors(Fs, Dist) :-
rb_visit(Fs,Els),
maplist(extract_factor,Els,Factors),
multiply(Factors, _, Dist).
extract_factor(_-Factor, Factor).
multiply_and_delete([f(I,Vs0,T0)|Fs], V, Vs, T) :-
foldl(multiply_factor, Fs, f(I,Vs0,T0), f(_,Vs1,T1)),
sum_out_from_CPT(V, T1, Vs1, T, Vs).
multiply([F0|Fs], Vs, T) :-
foldl(multiply_factor, Fs, F0, f(_,Vs,T)).
multiply_factor(f(_,Vs1,T1), f(_,Vs0,T0), f(_,Vs,T)) :-
multiply_CPTs(T1, Vs1, T0, Vs0, T, Vs).
write_tables([]).
write_tables([tab(Mat,_,_)|WorkTables]) :-
matrix:matrix_to_list(Mat,L),
writeln(L),
write_tables(WorkTables).
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).
ve_get_dist_size(V,Sz) :-
get_atts(V, [size(Sz)]), !.
ve_get_dist_size(V,Sz) :-
clpbn:get_atts(V,dist(Id,_)), !,
get_dist_domain_size(Id,Sz),
put_atts(V, [size(Sz)]).

44
packages/CLPBN/clpbn/vmap.yap Normal file
View File

@ -0,0 +1,44 @@
:- module(clpbn_vmap,
[
init_vmap/1, % init_vmap(-Vmap)
add_to_vmap/4, % add_to_vmap(+V,-I,+VMap0,VMapF)
get_from_vmap/3, % add_to_vmap(+V,-I,+VMap0)
vars_to_numbers/4, % vars_to_numbers(+Vs,-Is,+VMap0,VMapF)
lvars_to_numbers/4, % lvars_to_numbers(+LVs,-LIs,+VMap0,VMapF)
vmap_to_list/2
]).
:- use_module(library(rbtrees)).
:- use_module(library(maplist)).
%
% vmap: map V->I
% contiguous Vs to contiguous integers
%
init_vmap(vmap(0,Empty)) :-
rb_new(Empty).
get_from_vmap(V, I, VMap0) :-
VMap0 = vmap(_I,Map0),
rb_lookup(V, I, Map0).
add_to_vmap(V, I, VMap0, VMap0) :-
VMap0 = vmap(_I,Map0),
rb_lookup(V, I, Map0), !.
add_to_vmap(V, I0, vmap(I0,Map0), vmap(I, Map)) :-
I is I0+1,
rb_insert(Map0, V, I0, Map).
vars_to_numbers(Vs, Is, VMap0, VMap) :-
foldl(add_to_vmap, Vs, Is, VMap0, VMap).
lvars_to_numbers(LVs, LIs, VMap0, VMap) :-
foldl(vars_to_numbers, LVs, LIs, VMap0, VMap).
vmap_to_list(vmap(_,Map), L) :-
rb_visit(Map, L).

12
packages/CLPBN/examples/School/parschema.yap
View File

@ -29,7 +29,7 @@ bayes grade(C,S)::[a,b,c,d], int(S), diff(C) ; grade_table ; [registration(_,C,S
bayes satisfaction(C,S)::[h,m,l], abi(P), grade(C,S) ; sat_table ; [reg_satisfaction(C,S,P)].
bayes rat(C) :: [h,m,l], avg(Sats) ; avg ; [course_rating(C, Sats)].
bayes rat(C) :: [h,m,l], avg(Sats) ; avg ; [course_rat(C, Sats)].
bayes rank(S) :: [a,b,c,d], avg(Grades) ; avg ; [student_ranking(S,Grades)].
@ -42,7 +42,7 @@ reg_satisfaction(CKey, SKey, PKey) :-
registration(_Key, CKey, SKey),
course(CKey, PKey).
course_rating(CKey, Sats) :-
course_rat(CKey, Sats) :-
course(CKey, _),
setof(satisfaction(CKey,SKey,PKey),
reg_satisfaction(CKey, SKey, PKey),
@ -72,6 +72,14 @@ student_intelligence(P,A) :- int(P, A).
course_difficulty(P,A) :- diff(P, A).
registration_course(R,C) :-
registration(R, C, _).
registration_student(R,S) :-
registration(R, _, S).
course_rating(C,X) :- rat(C,X).
%
% evidence
%

2
packages/CLPBN/learning/em.yap
View File

@ -104,7 +104,7 @@ setup_em_network(Solver, state( AllDists, AllDistInstances, MargVars, SolverStat
sort_vars_by_key(AllVars0,AllVars,[]),
% no, we are in trouble because we don't know the network yet.
% get the ground network
generate_network([AllVars], _, Keys, Factors, EList),
generate_network(AllVars, _, Keys, Factors, EList),
% get the EM CPT connections info from the factors
generate_dists(Factors, EList, AllDists, AllDistInstances, MargVars),
% setup solver, if necessary