481 lines
13 KiB
Prolog
481 lines
13 KiB
Prolog
/***********************************
|
|
|
|
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_ve,
|
|
[ve/3,
|
|
check_if_ve_done/1,
|
|
init_ve_solver/4,
|
|
run_ve_solver/3,
|
|
init_ve_ground_solver/5,
|
|
run_ve_ground_solver/3,
|
|
call_ve_ground_solver/6
|
|
]).
|
|
|
|
:- use_module(library(atts)).
|
|
|
|
:- 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_params/2,
|
|
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/4,
|
|
factor_influences/4
|
|
]).
|
|
|
|
:- use_module(library(clpbn/matrix_cpt_utils)).
|
|
|
|
:- use_module(library(clpbn/numbers)).
|
|
|
|
:- use_module(library(lists),
|
|
[member/2,
|
|
append/3,
|
|
delete/3,
|
|
sum_list/2
|
|
]).
|
|
|
|
:- use_module(library(maplist)).
|
|
|
|
:- use_module(library(rbtrees)).
|
|
|
|
:- use_module(library(clpbn/vmap)).
|
|
|
|
:- use_module(library('clpbn/aggregates'),
|
|
[check_for_agg_vars/2]).
|
|
|
|
:- attribute size/1, all_diffs/1.
|
|
|
|
%
|
|
% 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(_)]), !.
|
|
|
|
|
|
%
|
|
% new PFL like interface...
|
|
%
|
|
call_ve_ground_solver(QueryVars, QueryKeys, AllKeys, Factors, Evidence, Output) :-
|
|
call_ve_ground_solver_for_probabilities([QueryKeys], AllKeys, Factors, Evidence, Solutions),
|
|
clpbn_bind_vals([QueryVars], Solutions, Output).
|
|
|
|
call_ve_ground_solver_for_probabilities(QueryKeys, AllKeys, Factors, Evidence, Solutions) :-
|
|
init_ve_ground_solver(QueryKeys, AllKeys, Factors, Evidence, VE),
|
|
run_ve_ground_solver(QueryKeys, Solutions, VE).
|
|
|
|
simulate_ve_ground_solver(_QueryVars, QueryKeys, AllKeys, Factors, Evidence, Output) :-
|
|
simulate_ve_ground_solver_for_probabilities([QueryKeys], AllKeys, Factors, Evidence, Output).
|
|
|
|
simulate_ve_ground_solver_for_probabilities(QueryKeys, AllKeys, Factors, Evidence, Solutions) :-
|
|
init_ve_ground_solver(QueryKeys, AllKeys, Factors, Evidence, VE),
|
|
simulate_solver(QueryKeys, Solutions, VE).
|
|
|
|
init_ve_ground_solver(_QueryKeys, AllKeys, Factors, Evidence, VE) :-
|
|
keys_to_numbers(AllKeys, Factors, Evidence, Hash4, Id4, FactorIds, EvidenceIds),
|
|
init_ve(FactorIds, EvidenceIds, Hash4, Id4, VE).
|
|
|
|
|
|
%
|
|
% implementation of the well known variable elimination algorithm
|
|
%
|
|
ve([[]],_,_) :- !.
|
|
ve(LLVs,Vs0,AllDiffs) :-
|
|
init_ve_solver(LLVs, Vs0, AllDiffs, State),
|
|
% variable elimination proper
|
|
run_ve_solver(LLVs, LLPs, State),
|
|
% bind Probs back to variables so that they can be output.
|
|
clpbn_bind_vals(LLVs,LLPs,AllDiffs).
|
|
|
|
|
|
init_ve(FactorIds, EvidenceIds, Hash, Id, ve(FactorIds, Hash, Id, Ev)) :-
|
|
rb_new(Ev0),
|
|
foldl(evtotree,EvidenceIds,Ev0,Ev).
|
|
|
|
evtotree(K=V,Ev0,Ev) :-
|
|
rb_insert(Ev0, K, V, Ev).
|
|
|
|
factor_to_graph( fn(Nodes, Sizes, _Pars0, Id, Keys), Factors0, Factors, Edges0, Edges, I0, I) :-
|
|
I is I0+1,
|
|
pfl:get_pfl_parameters(Id, Keys, Pars0),
|
|
init_CPT(Pars0, Sizes, CPT0),
|
|
reorder_CPT(Nodes, CPT0, FIPs, CPT, _),
|
|
F = f(I0, FIPs, CPT),
|
|
rb_insert(Factors0, I0, F, Factors),
|
|
foldl(add_f_to_nodes(I0), Nodes, Edges0, Edges).
|
|
|
|
add_f_to_nodes(I0, Node, Edges, [Node-I0|Edges]).
|
|
|
|
|
|
%
|
|
% 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)) :-
|
|
% LVi will have a list of CLPBN variables
|
|
init_influences(Vs0, 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_question(G, RG, Vs, NVs) :-
|
|
influences(Vs, G, RG, NVs0),
|
|
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 a list 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),
|
|
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_ground_solver(LQVs, LLPs, ve(FactorIds, Hash, Id, Ev)) :-
|
|
rb_new(Fs0),
|
|
foldl3(factor_to_graph, FactorIds, Fs0, Fs, [], FVs, 0, IF),
|
|
sort(FVs, SFVs),
|
|
rb_new(VInfo0),
|
|
add_vs(SFVs, Fs, VInfo0, VInfo),
|
|
BG = bigraph(VInfo, IF, Fs),
|
|
lists_of_keys_to_ids(LQVs, LQIds, Hash, _, Id, _),
|
|
findall(LPs, solve(LQIds, FactorIds, BG, Ev, LPs), LLPs).
|
|
|
|
solve([QVs|_], FIds, Bigraph, Evs, LPs) :-
|
|
factor_influences(FIds, QVs, Evs, LVs),
|
|
do_solve(QVs, LVs, Bigraph, Evs, LPs).
|
|
solve([_|LQVs], FIds, Bigraph, Ev, LPs) :-
|
|
solve(LQVs, FIds, Bigraph, Ev, LPs).
|
|
|
|
do_solve(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
|
|
rb_visit(Ev, EvL),
|
|
foldl2(clean_v_ev, EvL, 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).
|
|
|
|
simulate_solver(LQVs, Choices, ve(FIds, Hash, Id, BG, Evs)) :-
|
|
lists_of_keys_to_ids(LQVs, [QVs], Hash, _, Id, _),
|
|
factor_influences(FIds, QVs, Evs, LVs),
|
|
do_simulate(QVs, LVs, BG, Evs, Choices).
|
|
|
|
do_simulate(IQVs, IVs, bigraph(OldVs, IF, _Fs), Ev, Choices) :-
|
|
% get only what is relevant to query,
|
|
project_to_query_related(IVs, OldVs, SVs, Fs1),
|
|
% and also prune using evidence
|
|
rb_visit(Ev, EvL),
|
|
foldl2(clean_v_ev, EvL, Fs1, Fs2, SVs, EVs),
|
|
% eliminate
|
|
simulate_eiminate(IQVs, digraph(EVs, IF, Fs2), Choices).
|
|
|
|
% solve each query independently
|
|
% use a findall to recover space without needing for GC
|
|
run_ve_solver(_, LLPs, state(LQVs, LVs, _VMap, Bigraph, Ev)) :-
|
|
findall(LPs, solve_ve(LQVs, LVs, Bigraph, Ev, LPs), LLPs).
|
|
|
|
%
|
|
% 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], Digraph, Ev, Ps) :-
|
|
solve_ve(MoreLVs, MoreLVis, Digraph, Ev, Ps).
|
|
|
|
%
|
|
% given our input queries, sort them and obtain the subgraphs of vars and facs.
|
|
%
|
|
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).
|
|
|
|
%
|
|
% 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], _), !,
|
|
(
|
|
checklist(check_v(NVs), More)
|
|
->
|
|
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
|
|
).
|
|
|
|
check_v(NVs, V) :-
|
|
rb_lookup(V, _, NVs).
|
|
|
|
%
|
|
% 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).
|
|
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).
|
|
% The variable is not there
|
|
clean_v_ev(_, FVs, FVs, Vs, Vs).
|
|
|
|
%
|
|
%
|
|
% 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).
|
|
|
|
% 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).
|
|
|
|
replace_factor(F, NF, F, NF) :- !.
|
|
replace_factor(_F,_NF,OF, OF).
|
|
|
|
eliminate(QVs, digraph(Vs0, I, Fs0), Dist) :-
|
|
find_best(Vs0, QVs, BestV, VFs), !,
|
|
%writeln(best:BestV:VFs),
|
|
% 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).
|
|
|
|
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)) :-
|
|
foldl(szfac,Node,1,NewVal),
|
|
%length(Node, NewVal),
|
|
NewVal < ValSoFar,
|
|
!.
|
|
best_var(_, _I, _Node, Info, Info).
|
|
|
|
szfac(f(_,Vs,_), I0, I) :-
|
|
length(Vs,L),
|
|
I is I0*L.
|
|
|
|
% 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).
|
|
|