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

introduce CLPBN in system

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1094 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2004-07-15 16:23:44 +00:00
parent 08b9f55f9c
commit ab1cd9bb60
4 changed files with 1470 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

404
CLPBN/clpbn.yap Normal file
View File

@ -0,0 +1,404 @@
:- module(clpbn, [{}/1,
clpbn_findall/3,
clpbn_setof/3]).
:- use_module(library(atts)).
:- use_module(library(lists)).
:- use_module(library(terms)).
:- op(1200, xfx, '<--').
:- op(1200, fx, '<--').
:- op( 500, xfx, '=>').
:- op( 500, xfy, with).
%
% avoid the overhead of using goal_expansion/2.
%
:- multifile
user:term_expansion/2.
:- dynamic
user:term_expansion/2.
:- multifile
user:term_expansion/2.
:- attribute key/1, dist/1, evidence/1, done/1, starter/0.
:- use_module('clpbn/bnt', [dump_as_bnt/2,
check_if_bnt_done/1
]).
:- use_module('clpn/vel', [vel/3,
check_if_vel_done/1
]).
:- use_module('clpbn/evidence', [add_to_evidence/1,
execute_pre_evidence/0
]).
:- include('clpbn/aggs').
use(vel).
{Var = Key with Dist} :-
% key_entry(Key,Indx),
% array_element(clpbn,Indx,El),
% attributes:put_att(El,3,indx(Indx)),
clpbn:put_atts(El,[key(Key),dist(E=>Domain)]),
extract_dist(Dist, E, Domain),
add_evidence(Var,El).
extract_dist(V, (Tab.Inps), Domain) :- var(V), !,
V = p(Domain, Tab, Inps).
extract_dist(p(Domain, Tab, []), Tab, Domain) :- !.
extract_dist(p(Domain, Tab, Inps), (Tab.Inps), Domain).
extract_dist(p(Domain, Tab), Tab, Domain).
key_entry(Key, I) :-
hash_table_size(Size),
term_hash(Key, -1, Size, Hash),
collision(Hash, Size, I),
( array_element(keys, I, El) ->
update_array(keys, I, Key)
;
El = Key),
!.
% go from beginning
collision(Size, Size, I) :- !,
collision(0, Size, I).
collision(Hash, _, Hash).
collision(Hash, Size, I) :-
Hash1 is Hash+1,
collision(Hash1, Size, I).
%
% just fetch skolems so that we can process them carefully.
%
fetch_skolems(A, A) --> { var(A) }, !. %meta-calls
fetch_skolems((A,B), (NA,NB)) --> !,
fetch_skolems(A, NA),
fetch_skolems(B, NB).
% do not allow disjunctive clauses, at least for now.
fetch_skolems((A;B), (A;B)) --> !.
fetch_skolems((A|B), (A|B)) --> !.
fetch_skolems((A->B), (NA->NB)) --> !,
fetch_skolems(A, NA),
fetch_skolems(B, NB).
fetch_skolems(M:A, M:NA) --> !,
fetch_skolems(A, NA).
fetch_skolems(X = { Constraints }, true) --> !,
[ [X|Constraints] ].
fetch_skolems(G, G) --> [].
%
% just fetch skolems so that we can process them carefully.
%
handle_body_goals((A,B), (NA,NB)) :- !,
handle_body_goals(A, NA),
handle_body_goals(B, NB).
% do not allow disjunctive clauses, at least for now.
handle_body_goals((A;B), (A;B)) :- !.
handle_body_goals((A|B), (A|B)) :- !.
handle_body_goals((A->B), (NA->NB)) :- !,
handle_body_goals(A, NA),
handle_body_goals(B, NB).
handle_body_goals(M:A, M:NA) :- !,
handle_body_goals(A, NA).
handle_body_goals(findall(V,G,L), (findall(V,G,L), aggs:fix_vars(L))) :- !.
handle_body_goals(setof(V,G,L), (setof(V,G,L),aggs:fix_vars(L))) :- !.
handle_body_goals(bagof(V,G,L), (bagof(V,G,L),aggs:fix_vars(L))) :- !.
handle_body_goals(G, G).
compile_skolems([[X|Constraints]], Vars, NVars, A, Code) :- !,
compile_skolem(X, Vars, NVars, A, Code, Constraints).
compile_skolems([[X|Constraints]|Cs], Vars, NVars, A, (Code, RCode)) :-
compile_skolem(X, Vars, NVars, A, Code, Constraints),
compile_skolems(Cs, Vars, NVars, A, RCode).
compile_skolem(EVar, Vars, NVars, Head, Code, Constraints) :-
compile_constraints(Constraints, Vars, NVars, Head, Code, EVar).
compile_constraints((A : B), Vars, NVars, Head, (CA , CB), EVar) :- !,
compile_first_constraint(A, Head, CA, EVar),
compile_second_constraint(B, Vars, NVars, CB, EVar).
compile_first_constraint(SkKey, Head, (KeyGoal, /* cycle(Key,EVar), */ array_element(clpbn, Id, EVar), clpbn:put_atts(EVar,[key(KeyDesc),indx(Id)])), EVar) :-
functor(SkKey, Name, _),!,
SkKey =.. [_|Key],
generate_key_goal(Head, Name, Key, KeyGoal, KeyDesc, Id).
compile_second_constraint(Constraint, Vars, NVars, clpbn:put_atts(EVar,[dist(NC)]), EVar) :-
check_constraint(Constraint, Vars, NVars, NC).
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).
generate_key_goal(Head, Name, Key, clpbn_aux:KeyGoal, KeyDesc, Id) :-
functor(Head, _, Ar),
atom_chars(Name, NaS),
number_codes(Ar, ArS),
append("/", ArS, S1),
append(NaS, S1, S2),
append("key_", S2, SNNa),
atom_chars(NNa, SNNa),
append(Key,[Id],LArgs),
KeyGoal =.. [NNa|LArgs],
KeyDesc =.. [Name|Key],
length(Key, N),
NAr is N+1,
abolish(clpbn_aux:(NNa/NAr)),
reset_clpbn,
dynamic_predicate(clpbn_aux:(NNa/NAr), logical),
assert((clpbn_aux:KeyGoal :- new_key(Id), asserta(clpbn_aux:(KeyGoal :- !)))).
new_key(Key) :-
get_value(clpbn_key, Key),
X is Key+1,
set_value(clpbn_key, X).
skolem_vars([], []).
skolem_vars([[V|_]|LV], [V|NLV]) :-
skolem_vars(LV, NLV).
skolem_new_vars([], [], []).
skolem_new_vars([[_|B]|Sks], [NV|Vs], [[NV|B]|NSks]) :-
skolem_new_vars(Sks, Vs, NSks).
fresh_vars([], [], B, B).
fresh_vars([V|LV], [NV|NLV], (clpbn:add_evidence(V,NV),B), B0) :-
fresh_vars(LV, NLV, B, B0).
add_evidence(V,NV) :-
nonvar(V), !,
clpbn:put_atts(NV,evidence(V)).
add_evidence(V,V).
%
% called by top-level
%
project_attributes(GVars, AVars) :-
AVars = [_|_], !,
execute_pre_evidence,
sort_vars_by_key(AVars,SortedAVars,DiffVars),
get_clpbn_vars(GVars,CLPBNGVars),
write_out(CLPBNGVars, SortedAVars,DiffVars).
project_attributes(_, _).
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).
sort_vars_by_key(AVars,SortedAVars, UnifiableVars) :-
get_keys(AVars, KeysVars),
keysort(KeysVars, KVars),
merge_same_key(KVars, SortedAVars, [], UnifiableVars).
get_keys([], []).
get_keys([V|AVars], [K-V|KeysVars]) :-
get_atts(V, [key(K)]),
get_keys(AVars, KeysVars).
merge_same_key([], [], _, []).
merge_same_key([K1-V1,K2-V2|Vs], SortedAVars, Ks, UnifiableVars) :-
K1 == K2, !, 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]).
write_out(GVars, AVars, DiffVars) :-
use(vel),
vel(GVars, AVars, DiffVars).
write_out(GVars, AVars, _) :-
use(bnt),
dump_as_bnt(GVars, AVars).
% starter_vars(GVars).
starter_vars([]).
starter_vars([Var|Vs]) :-
get_atts(Var, [key(_)]),
put_atts(Var, [starter]),
starter_vars(Vs).
/* attribute_goal(Var, Goal) :-
get_atts(Var, [key(_)]),
get_bnode(Var, Goal).
get_value(clpbn_key, Max),
Max1 is Max-1,
run_through_array(0, Max1, Goal).
run_through_array(Max,Max,Goal) :- !,
array_element(clpbn, Max, V),
get_bnode(V, Goal).
run_through_array(I,Max,(G,Goal)) :- !,
array_element(clpbn, I, V),
get_bnode(V, G),
I1 is I+1,
run_through_array(I1,Max,Goal).
*/
get_bnode(Var, Goal) :-
get_atts(Var, [key(Key),dist(X)]),
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(norm(M,V), Key, (Key=norm(M,V))) :- !.
dist_goal(avg(L), Key, (Key=avg(L))) :- !.
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)]), !,
/* oops, someone trying to bind a clpbn constrained variable */
Goals = [],
bind_clpbn(T, Var, Key, Dist).
verify_attributes(_, _, []).
bind_clpbn(T, _, Key, Dist) :- var(T),
get_atts(T, [key(Key1),dist(Dist1)]), !,
bind_clpbns(Key, Dist, Key1, Dist1).
bind_clpbn(_, Var, _, _) :-
use(bnt),
check_if_bnt_done(Var), !.
bind_clpbn(_, Var, _, _) :-
use(vel),
check_if_vel_done(Var), !.
bind_clpbn(T, Var, Key0, _) :-
get_atts(Var, [key(Key0)]), !,
(
Key = Key0 -> true
;
format(user_error, "trying to force evidence ~w through unification with key ~w~n",[T, Key])
).
fresh_attvar(Var, NVar) :-
get_atts(Var, LAtts),
put_atts(NVar, LAtts).
bind_clpbns(Key, Dist, Key, Dist1) :- !,
( Dist = Dist1 -> true ; throw(error(domain_error(bayesian_domain),bind_clpbns))).
bind_clpbns(_, _, _, _, _) :-
format(user_error, "unification of two bayesian vars not supported~n").
:- yap_flag(toplevel_hook,clpbn:init_clpbn).
hash_table_size(300000).
init_clpbn :-
reset_clpbn,
fail.
%init_clpbn :-
% hash_table_size(HashTableSize),
% array(clpbn,HashTableSize),
% catch(static_array(keys,HashTableSize,term),_,true).
random_tmp_number(I) :-
get_value(clpbn_random_tmp_number,I),
I1 is I+1,
set_value(clpbn_random_tmp_number,I1).
reset_clpbn :-
current_predicate(_, clpbn_aux:P),
retract(clpbn_aux:(P :- !)),
fail.
reset_clpbn :-
set_value(clpbn_key, 0), fail.
reset_clpbn :-
set_value(clpbn_random_tmp_number, 0), fail.
reset_clpbn.
user:term_expansion((A :- {}), ( :- true )) :- !, % evidence
prolog_load_context(module, M),
add_to_evidence(M:A).
user:term_expansion((A :- B), (A :- (LCs,NB))) :- % expands heads
fetch_skolems(B, B0, Skolems, []),
Skolems \= [],
skolem_vars(Skolems, Vars),
copy_term(Vars+A, NVars+NA),
skolem_new_vars(Skolems, NVars, NSkolems),
compile_skolems(NSkolems, Vars, NVars, NA, LCs),
handle_body_goals(B0, B1),
fresh_vars(Vars, NVars, NB, B1).

546
CLPBN/clpbn/bnt.yap Normal file
View File

@ -0,0 +1,546 @@
:- module(bnt, [dump_as_bnt/2,
check_if_bnt_done/1]).
:- use_module(library(terms), [term_variables/2
]).
:- use_module(library(ordsets), [ord_subtract/3,
ord_add_element/3
]).
:- use_module(library(lists), [reverse/2
]).
:- use_module(library(atts)).
:- use_module(library(heaps), [empty_heap/1,
add_to_heap/4,
heap_to_list/2
]).
:- use_module(library(system), [exec/3
]).
:- attribute topord/1, map/1.
check_if_bnt_done(Var) :-
get_atts(Var, [map(_)]).
dump_as_bnt(GVars, [_|_]) :-
exec('matlab -nojvm -nosplash',[pipe(CommandStream),pipe(Answer),pipe(Answer)],_),
wait_for_matlab_prompt(Answer),
get_value(clpbn_key, Key),
send_command(CommandStream, Answer, 'cd /u/vitor/sw/BNT;~n', []),
% send_command(CommandStream, Answer, 'cd /home/vitor/Yap/CLPBN/BNT;~n', []),
send_command(CommandStream, Answer, 'add_BNT_to_path;~n', []),
send_command(CommandStream, Answer, '~w = ~w;~n', ['$VAR'(Key), Key]),
send_command(CommandStream, Answer, 'dag = zeros(~w,~w);~n', ['$VAR'(Key), '$VAR'(Key)]),
Key1 is Key-1,
dump_variable_indices(Key1, Vs, Heap, CommandStream, Answer),
write_deps(Heap, CommandStream, Answer),
find_observables(GVars, Observables),
mknet(Vs, Key, Observables, CommandStream, Answer),
dump_cpds(Vs, CommandStream, Answer),
inf_engine(Vs, Key, CommandStream, Answer),
output_answer(Observables, CommandStream, Answer),
close(CommandStream),
close(Answer).
dump_variable_indices(I, LF, HF, CommandStream, Answer) :-
all_vars_with_deps(I, LDeps, LNoDeps),
sort(LNoDeps, S0),
empty_heap(H0),
topsort(LDeps, S0, LNoDeps, LF, H0, HF),
reverse(LF, Vs),
dump_vlist(Vs, 0, CommandStream, Answer).
all_vars_with_deps(0, LDeps, LNoDeps) :- !,
var_with_deps(0, LDeps, [], LNoDeps, []).
all_vars_with_deps(I, LDeps, LNoDeps) :-
var_with_deps(I, LDeps, LDeps0, LNoDeps, LNoDeps0),
I1 is I-1,
all_vars_with_deps(I1, LDeps0, LNoDeps0).
var_with_deps(Indx, Deps, Deps0, NoDeps, NoDeps0) :-
array_element(clpbn, Indx, V),
clpbn:get_atts(V, [dist(D)]), !,
term_variables(D, VDeps),
(VDeps = [] ->
NoDeps = [V|NoDeps0], Deps = Deps0 ;
sort(VDeps,SVDeps),
Deps = [[V|SVDeps]|Deps0], NoDeps = NoDeps0 ).
%
% this is a silly quadratic algorithm for topological sorting.
% it will have to do for now.
%
% to speedup things a bit I keep a sorted and unsorted version
% of the variables sorted so far.
%
topsort([], _, S, S, H, H) :- !.
topsort(LDeps, Sorted0, S0, SF, H, HF) :- !,
delete_all(LDeps, Sorted0, S0, LI, SI, Sorted, H, HI),
topsort(LI, Sorted, SI, SF, HI, HF).
delete_all([], SS, S, [], S, SS, H, H).
delete_all([[V|VDeps]|LDeps], SS, S, LF, SF, SSF, H0, HF) :-
ord_subtract(VDeps, SS, VDepsI),
ord_subtract(VDeps, VDepsI, Parents),
add_parents_to_heap(Parents, V, H0, HI),
( VDepsI = [] ->
LF = LI, ord_add_element(SS,V,SSI), SI = [V|S];
LF = [[V|VDepsI]|LI], SI = S, SSI = SS),
delete_all(LDeps, SSI, SI, LI, SF, SSF, HI, HF).
add_parents_to_heap([], _, H, H).
add_parents_to_heap([P|Parents], V, H0, HF) :-
add_to_heap(H0, P, V, HI), % if I put a HF here I get the debugger to loop
add_parents_to_heap(Parents, V, HI, HF).
dump_vlist([], _, _, _).
dump_vlist([V|Vs], I, CommandStream, Answer) :-
I1 is I+1,
clpbn:get_atts(V,[key(_)]),
send_command(CommandStream, Answer, '~w = ~w;~n', ['$VAR'(I), I1]),
put_atts(V, [topord(I)]),
I1 is I+1,
dump_vlist(Vs, I1, CommandStream, Answer).
write_deps(H, CommandStream, Answer) :-
heap_to_list(H,L),
write_list_deps(L, CommandStream, Answer).
write_list_deps([], _, _).
write_list_deps([V-A|L], CommandStream, Answer) :-
fetch_same_key(L, V, SK, LN),
write_dep_relation([A|SK], V, CommandStream, Answer),
write_list_deps(LN, CommandStream, Answer).
fetch_same_key([], _, [], []) :- !.
fetch_same_key([V1-A|L], V, [A|SK], LN) :- V1 == V, !,
fetch_same_key(L, V, SK, LN).
fetch_same_key(L, _, [], L).
write_dep_relation([], _, _) :- !.
write_dep_relation([V], D, CommandStream, Answer) :- !,
get_atts(V, [topord(IV)]),
get_atts(D, [topord(ID)]),
send_command(CommandStream, Answer, "dag(~w,~w) = 1;~n", ['$VAR'(ID),'$VAR'(IV)]).
write_dep_relation(Vs, D, CommandStream, Answer) :-
get_atts(D, [topord(ID)]),
my_format(CommandStream, "dag(~w,[",['$VAR'(ID)]),
write_anc_list(Vs, start, CommandStream),
send_command(CommandStream, Answer, "]) = 1;~n", []).
write_anc_list([], _, _).
write_anc_list([V|Vs], start, CommandStream) :- !,
get_atts(V, [topord(I)]),
my_format(CommandStream, "~w",['$VAR'(I)]),
write_anc_list(Vs, cont, CommandStream).
write_anc_list([V|Vs], cont, CommandStream) :-
get_atts(V, [topord(I)]),
my_format(CommandStream, " ~w",['$VAR'(I)]),
write_anc_list(Vs, cont, CommandStream).
mknet(Vs, Key, Observables, CommandStream, Answer) :-
mknet_all_discrete(Vs, Key, Observables, CommandStream, Answer).
mknet_all_discrete(Vs, Key, Observables, CommandStream, Answer) :-
send_command(CommandStream, Answer, "discrete_nodes = 1:~w;~n",['$VAR'(Key)]),
my_format(CommandStream, "ns = [", []),
reverse(Vs, RVs),
send_var_sizes(RVs, CommandStream),
send_command(CommandStream, Answer, "];~n", []),
my_format(CommandStream, "onodes = [", []),
dump_observables(Observables, start, CommandStream),
send_command(CommandStream, Answer, "];~n", []),
send_command(CommandStream, Answer, "bnet = mk_bnet(dag, ns, 'discrete', discrete_nodes, 'observed', onodes);~n", []).
send_var_sizes([V], CommandStream) :- !,
clpbn:get_atts(V, [dist(D)]),
dist_size(D, 1, Sz),
my_format(CommandStream, "~w", [Sz]).
send_var_sizes([V|Vs], CommandStream) :-
clpbn:get_atts(V, [dist(D)]),
dist_size(D, 1, Sz),
my_format(CommandStream, "~w ", [Sz]),
send_var_sizes(Vs, CommandStream).
dist_size((_=>Vs), _, L) :- !,
length(Vs,L).
dist_size((_._=Vs), I0, If) :- !,
length(Vs,L),
If is I0+(L-1).
dist_size((A;B), I0, If) :- !,
dist_size(A, I0, I1),
I2 is I1+1,
dist_size(B, I2, If).
dist_size(_, I, I).
dump_observables([], _, _) :- !.
dump_observables([Observable|Observables], start, CommandStream) :- !,
get_atts(Observable, [topord(I)]),
my_format(CommandStream, "~w",['$VAR'(I)]),
dump_observables(Observables, mid, CommandStream).
dump_observables([Observable|Observables], mid, CommandStream) :-
get_atts(Observable, [topord(I)]),
my_format(CommandStream, " ~w",['$VAR'(I)]),
dump_observables(Observables, mid, CommandStream).
dump_cpds([], _, _).
dump_cpds([V|Vs], CommandStream, Answer) :-
clpbn:get_atts(V, [dist(D)]),
dump_cpds(Vs, CommandStream, Answer),
dump_dist(D, V, CommandStream, Answer).
%
% this is a discrete distribution
%
dump_dist((average.Ss)=>Vs, V, CommandStream, Answer) :- !,
vals_map(Vs, 1, Map),
get_atts(V, [topord(I)]),
my_format(CommandStream, "bnet.CPD{~w} = deterministic_CPD(bnet, ~w, inline('round(mean([",['$VAR'(I),'$VAR'(I)]),
put_atts(V, [map(Map)]),
length(Ss, Len),
dump_indices(0,Len,CommandStream),
send_command(CommandStream, Answer, "]))'));~n",[]).
dump_dist((sum.Ss)=>Vs, V, CommandStream, Answer) :- !,
vals_map(Vs, 1, Map),
get_atts(V, [topord(I)]),
my_format(CommandStream, "bnet.CPD{~w} = deterministic_CPD(bnet, ~w, inline('sum([",['$VAR'(I),'$VAR'(I)]),
put_atts(V, [map(Map)]),
length(Ss, Len),
dump_indices(0,Len,CommandStream),
send_command(CommandStream, Answer, "])'));~n",[]).
dump_dist((normalised_average(N).Ss)=>Vs, V, CommandStream, Answer) :- !,
vals_map(Vs, 1, Map),
get_atts(V, [topord(I)]),
my_format(CommandStream, "bnet.CPD{~w} = deterministic_CPD(bnet, ~w, inline('round((sum([",['$VAR'(I),'$VAR'(I)]),
put_atts(V, [map(Map)]),
length(Ss, Len),
dump_indices(0,Len,CommandStream),
N2 is N//2,
send_command(CommandStream, Answer, "])+~d)/~d)'));~n",[N2,N]).
dump_dist(([H|T].Ss0)=>Vs, V, CommandStream, Answer) :- !,
Ds = [H|T],
vals_map(Vs, 1, Map),
get_atts(V, [topord(I)]),
my_format(CommandStream, "bnet.CPD{~w} = tabular_CPD(bnet, ~w, [ ",['$VAR'(I),'$VAR'(I)]),
put_atts(V, [map(Map)]),
reverse([V|Ss0], Ss),
get_numbers_for_vars(Ss, Ns),
calculate_new_numbers(Ds,Ns,0,KDs0),
keysort(KDs0,KDs),
dump_elements(KDs, CommandStream),
send_command(CommandStream, Answer, "]);~n",[]).
dump_dist(([H|T]=>Vs), V, CommandStream, Answer) :-
vals_map(Vs, 1, Map),
get_atts(V, [topord(I)]),
my_format(CommandStream, "bnet.CPD{~w} = tabular_CPD(bnet, ~w, [ ",['$VAR'(I),'$VAR'(I)]),
put_atts(V, [map(Map)]),
dump_problist([H|T], CommandStream),
send_command(CommandStream, Answer, "]);~n",[]).
dump_dist((D1;D2), V, CommandStream, Answer) :-
get_atts(V, [topord(I)]),
my_format(CommandStream, "bnet.CPD{~w} = tabular_CPD(bnet, ~w, [ ",['$VAR'(I),'$VAR'(I)]),
find_map((D1;D2), 1, _, Map, []),
put_atts(V, [map(Map)]),
dump_dlist((D1;D2), start, CommandStream),
send_command(CommandStream, Answer, "]);~n",[]).
vals_map([], _, []).
vals_map([V|Vs], I, [[V|I]|Map]) :-
I1 is I+1,
vals_map(Vs, I1, Map).
get_numbers_for_vars(Ss, Ns) :-
numb_vars(Ss, 0, 1, VPs0),
keysort(VPs0, VPs),
compute_new_factors(VPs, 1, Int0),
keysort(Int0, Int),
select_factors(Int, [], Ns).
numb_vars([], _, _, []).
numb_vars([V|Vs], I, A0, [T-p(I,A0,L)|VPs]) :-
get_atts(V, [map(Map),topord(T)]),
length(Map,L),
I1 is I+1,
Ai is A0*L,
numb_vars(Vs, I1, Ai, VPs).
compute_new_factors([], _, []).
compute_new_factors([_-p(I,Siz,L)|VPs], Div, [I-f(Siz,Div)|Os]) :-
NDiv is Div*L,
compute_new_factors(VPs, NDiv, Os).
select_factors([], L, L).
select_factors([_-Fac|Int], Ns0, Nsf) :-
select_factors(Int, [Fac|Ns0], Nsf).
calculate_new_numbers([],_, _,[]).
calculate_new_numbers([P|Ps], Ls, I0, [Pos-P|KDs]) :-
compute_new_position(Ls, I0, 0, Pos),
I is I0+1,
calculate_new_numbers(Ps, Ls, I, KDs).
compute_new_position([], _, P, P).
compute_new_position([f(Siz,Div)|Ls], I0, P0, Pf) :-
A is I0 // Siz,
I1 is I0 mod Siz,
B is A*Div,
Pi is P0+B,
compute_new_position(Ls, I1, Pi, Pf).
dump_indices(Len,Len,_) :- !.
dump_indices(I0,Len,CommandStream) :-
I is I0+1,
my_format(CommandStream, "x(~d) ",[I]),
dump_indices(I,Len,CommandStream).
dump_elements([], _).
dump_elements([_-P|KDs], CommandStream) :-
my_format(CommandStream, "~w~n",[P]),
dump_elements(KDs, CommandStream).
dump_problist([], _).
dump_problist([P|KDs], CommandStream) :-
my_format(CommandStream, "~w~n",[P]),
dump_problist(KDs, CommandStream).
dump_dlist((D1;D2), Start, CommandStream) :- !,
dump_dlist(D1, Start, CommandStream),
dump_dlist(D2, mid, CommandStream).
dump_dlist((_ = V), Pos, CommandStream) :- !,
dump_dlist(V, Pos, CommandStream).
dump_dlist((_ -> V), Pos, CommandStream) :- !,
dump_dlist(V, Pos, CommandStream).
dump_dlist(V, start, CommandStream) :- !,
my_format(CommandStream, "~w~n",[V]).
dump_dlist(V, mid, CommandStream) :-
my_format(CommandStream, "~w~n",[V]).
find_map((D1;D2), I0, N, LF, L0) :- !,
find_map(D1, I0, I, LF, LI),
find_map(D2, I, N, LI, L0).
find_map((M->_), I, I1, [[M|I]|L0], L0) :-
I1 is I+1.
inf_engine(Vs, Key, CommandStream, Answer) :-
send_command(CommandStream, Answer, "engine = jtree_inf_engine(bnet)~n", []),
% send_command(CommandStream, Answer, "engine = var_elim_inf_engine(bnet)~n", []),
send_command(CommandStream, Answer, "evidence = cell(1,~w)~n", ['$VAR'(Key)]),
dump_evidence(Vs, CommandStream, Answer),
send_command(CommandStream, Answer, "[engine, loglik] = enter_evidence(engine, evidence)~n",[]).
dump_evidence([], _, _).
dump_evidence([V|Vs], CommandStream, Answer) :-
clpbn:get_atts(V, [evidence(Ev)]), !,
get_atts(V, [topord(I),map(M)]), !,
follow_map(M,Ev,NEv),
send_command(CommandStream, Answer, "evidence{~w} = ~w~n", ['$VAR'(I),NEv]),
dump_evidence(Vs, CommandStream, Answer).
dump_evidence([_|Vs], CommandStream, Answer) :-
dump_evidence(Vs, CommandStream, Answer).
follow_map([[K|V]|_], K, V) :- !.
follow_map([_|Map], K, V) :- !,
follow_map(Map, K, V).
find_observables([], []).
find_observables([Var|GVars], [Var|Observables]) :-
clpbn:get_atts(Var, [dist(_)]), !,
find_observables(GVars, Observables).
find_observables([_|GVars], Observables) :-
find_observables(GVars, Observables).
output_answer(Observables, CommandStream, Answer) :-
split_by_cliques(Observables, Cliques),
output_cliques(Cliques, CommandStream, Answer).
split_by_cliques([], []).
split_by_cliques([V|Vs], Cliques) :-
split_by_cliques(Vs, Cliques0),
add_to_cliques(Cliques0, V, Cliques).
add_to_cliques([], V, [[V]]).
add_to_cliques([Cl|L], V, [[V|Cl]|L]) :-
in_clique(Cl,V), !.
add_to_cliques([Cl|L], V, [Cl|LN]) :-
add_to_cliques(L, V, LN).
in_clique([], _).
in_clique([V1|L], V) :-
child(V, V1), !,
in_clique(L, V).
in_clique([V1|L], V) :-
child(V1, V),
in_clique(L,V).
child(V,V1) :-
clpbn:get_atts(V, [dist(T)]),
term_variables(T,LVs),
varmember(LVs, V1).
varmember([H|_], V1) :- H == V1, !.
varmember([_|L], V1) :-
varmember(L, V1).
output_cliques([], _, _).
output_cliques([Observables|Cliques], CommandStream, Answer) :-
marginal(Observables, CommandStream, Answer),
read_answer(Answer, -1, MargDis),
parse_observables(Observables, MargDis),
output_cliques(Cliques, CommandStream, Answer).
marginal(Margs, CommandStream, Answer) :-
my_format(CommandStream, "marg = marginal_nodes(engine, ", []),
write_margs(Margs, CommandStream),
send_command(CommandStream, Answer, ")~n", []),
my_format(CommandStream, "p = marg.T~n", []).
write_margs([], _) :- !.
write_margs([V], CommandStream) :- !,
get_atts(V, [topord(IV)]),
my_format(CommandStream, "~w", ['$VAR'(IV)]).
write_margs(Vs, CommandStream) :-
my_format(CommandStream, "[", []),
write_anc_list(Vs, start, CommandStream),
my_format(CommandStream, "]", []).
read_answer(Answer, C0, [C1|L]) :-
get0(Answer, C1),
put(user_error, C1),
( (( C0 = 10 ; C0 = 85) ,C1 = 62) ->
L = []
;
read_answer(Answer, C1, L)
).
wait_for_matlab_prompt(Answer) :-
fetch_prompt(Answer, -1).
fetch_prompt(Answer, C0) :-
get0(Answer, C1),
put(user_error, C1),
( ((C0 = 62 ; C0 = 85) ,C1 = 62) ->
true
;
fetch_prompt(Answer, C1)
).
send_command(OStream, IStream, String, Args) :-
my_format(OStream, String, Args),
wait_for_matlab_prompt(IStream).
parse_observables([Obs], MargDis) :- !,
get_atts(Obs, [map(Map)]),
skip_to_eq(MargDis, L1),
fetch_map(Map, L1, Out),
clpbn:get_atts(Obs, [key(Key)]),
Obs = {Key:Out}.
parse_observables(LObs, MargDis) :-
joint_map(LObs, Map),
skip_to_eq(MargDis, L1),
fetch_maps(Map, L1, Out),
bind_lobs(LObs, Key, Key, Out).
fetch_map([[Name|_]], L, (Name -> P)) :- !,
get_next_float(L, P, _).
fetch_map([[Name|_]|Names], L0, (Name->P ; Rest)) :-
get_next_float(L0, P, Lf),
fetch_map(Names, Lf, Rest).
get_next_float(L0, P, Lf) :-
skip_spaces(L0, Li),
fetch_float(Li,Ls, Lf),
number_codes(P, Ls).
skip_to_eq([61|L], L) :- !.
skip_to_eq([_|L], LF) :-
skip_to_eq(L, LF).
skip_spaces([10|L], LF) :- !, skip_spaces(L, LF).
skip_spaces([32|L], LF) :- !, skip_spaces(L, LF).
skip_spaces(L, L).
fetch_float([10|L], [], L) :- !.
fetch_float([32|L], [], L) :- !.
fetch_float([C|Li], [C|Ls], Lf) :-
fetch_float(Li, Ls, Lf).
joint_map(Vars,FMap) :-
fetch_maps(Vars,Maps),
join_maps(Maps, FMap).
fetch_maps([], []).
fetch_maps([V|Vs], [M|Ms]) :-
get_atts(V, [map(M)]),
fetch_maps(Vs, Ms).
join_maps([], [[]]).
join_maps([Map|Maps], Rf) :-
join_maps(Maps, R1),
add(Map, R1, Rf).
add([], _, []).
add([[Name|_]|R], R1, RsF) :-
add_head(R1, Name, RsF, Rs0),
add(R, R1, Rs0).
add_head([], _, Rs, Rs).
add_head([H|L], A, [[A|H]|Rs], Rs0) :-
add_head(L, A, Rs, Rs0).
fetch_maps([Name1], L, (Name2 -> P)) :- !,
generate_name(Name1, Name2),
get_next_float(L, P, _).
fetch_maps([Name1|Names], L0, (Name2->P ; Rest)) :-
generate_name(Name1, Name2),
get_next_float(L0, P, Lf),
fetch_maps(Names, Lf, Rest).
generate_name([Name], Name) :- !.
generate_name([Name|Names], (Name,New)) :-
generate_name(Names, New).
bind_lobs([Obs], Key, FullKey, Out) :- !,
clpbn:get_atts(Obs, [key(Key)]),
Obs = {FullKey:Out}.
bind_lobs([Obs|Lobs], (Key,Rest), FullKey, Out) :-
clpbn:get_atts(Obs, [key(Key)]),
Obs = {FullKey:Out},
bind_lobs(Lobs, Rest, FullKey, Out).
/* cartesian product
cart([], [[]]).
cart([L|R], Rf) :-
cart(R, R1),
add(L, R1, Rf).
add([], _, []).
add([A|R], R1, RsF) :-
add_head(R1, A, RsF, Rs0),
add(R, R1, Rs0).
add_head([], _, Rs, Rs).
add_head([H|L], A, [[A|H]|Rs], Rs0) :-
add_head(L, A, Rs, Rs0).
*/
my_format(Stream, String, Args) :-
format(user_error, String, Args),
format(Stream, String, Args).

25
CLPBN/clpbn/evidence.yap Normal file
View File

@ -0,0 +1,25 @@
:- module(evidence, [add_to_evidence/1,
execute_pre_evidence/0
]).
% declare some new evidence.
add_to_evidence(G2) :-
recordzifnot('$evidence',G2,_),
fail.
add_to_evidence(_).
% use it at query evaluation time.
execute_pre_evidence :-
findall(G, recorded('$evidence', G, _), LGs),
execute_all(LGs).
execute_all([]).
execute_all([M:G|Gs]) :-
call(M:G),
execute_all(Gs).

495
CLPBN/clpbn/vel.yap Normal file
View File

@ -0,0 +1,495 @@
/***********************************
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(vel, [vel/3,
check_if_vel_done/1]).
:- attribute size/1, posterior/4, all_diffs/1.
:- use_module(library(ordsets), [ord_union/3
]).
:- use_module(library(lists),
[
append/3,
member/2
]).
check_if_vel_done(Var) :-
get_atts(Var, [size(_)]), !.
vel(LVs,Vs0,AllDiffs) :-
check_for_hidden_vars(Vs0, Vs0, Vs1),
sort(Vs1,Vs),
find_all_clpbn_vars(Vs, LV0, Tables0),
find_all_table_deps(Tables0, LV0),
process(LV0, LVs, tab(Dist,_,_)),
Dist =.. [_|Ps0],
normalise(Ps0,Ps),
bind_vals(LVs,Ps,AllDiffs).
%
% 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) :-
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) :-
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).
find_all_clpbn_vars([], [], []) :- !.
find_all_clpbn_vars([V|Vs], [var(V,I,Sz,Vals,_,_)|LV], [table(I,Table,Deps,Sizes)|Tables]) :-
var_with_deps(V, Table, Deps, Sizes, Vals), !,
get_dist_els(V,Sz),
find_all_clpbn_vars(Vs, LV, Tables).
var_with_deps(V, Table, Deps, Sizes, Vals) :-
clpbn:get_atts(V, [dist(D=>Vals)]),
from_dist_get(D,Vals,OTable,VDeps),
reorder_table([V|VDeps],Sizes,OTable,Deps,Table).
from_dist_get(average.Vs0,Vals,Lf,Vs) :- !,
handle_average(Vs0,Vals,Lf,Vs).
from_dist_get(sum.Vs0,Vals,Lf,Vs) :- !,
handle_sum(Vs0, Vals, Lf, Vs).
from_dist_get(normalised_average(Max).Vs0,Vals,Lf,Vs) :- !,
handle_normalised_average(Max,Vs0,Vals,Lf,Vs).
from_dist_get(([A|B].[C|D]),_,[A|B],[C|D]) :- !.
from_dist_get([A|B],_,[A|B],[]).
handle_average(Vs0,Vals,Lf,Vs) :-
sort(Vs0,Vs),
generate_indices(Vals,Inds,0,Av),
combine_all(Vs, Inds, Cs),
length(Vs, Max),
average_possible_cases(0,Av,Max,Cs,Lf).
handle_sum(Vs0, Vals, Lf, Vs) :-
sort(Vs0,Vs),
length(Vals,Sz),
combine_all(Vs, Cs),
sum_possible_cases(0,Sz,Cs,Lf).
handle_normalised_average(Max,Vs0,Vals,Lf,Vs) :-
sort(Vs0,Vs),
generate_indices(Vals,_,0,Sz),
combine_all(Vs, Cs),
average_possible_cases(0,Sz,Max,Cs,Lf).
generate_indices([],[],Av,Av).
generate_indices([_|Ls],[I|Inds],I,Av) :-
I1 is I+1,
generate_indices(Ls,Inds,I1,Av).
combine_all([], [[]]).
combine_all([V|LV], Cs) :-
combine_all(LV, Cs0),
get_dist_els(V,Sz),
generate_indices(0, Sz, Vals),
add_vals(Vals, Cs0, Cs).
combine_all([], _, [[]]).
combine_all([_|LV], Vals, Cs) :-
combine_all(LV, Vals, Cs0),
add_vals(Vals, Cs0, Cs).
generate_indices(Sz,Sz,[]) :- !.
generate_indices(I0,Sz,[I0|Vals]) :-
I is I0+1,
generate_indices(I,Sz,Vals).
add_vals([], _, []).
add_vals([V|Vs], Cs0, Csf) :-
add_vals(Vs, Cs0, Cs),
add_val_to_cases(Cs0, V, Cs, Csf).
add_val_to_cases([], _, Cs, Cs).
add_val_to_cases([C|Cs], V, Cs0, [[V|C]|Csf]) :-
add_val_to_cases(Cs, V, Cs0, Csf).
sum_all([],N,N).
sum_all([C|Cs],N0,N) :-
X is C+N0,
sum_all(Cs,X,N).
average_possible_cases(Av,Av,_,_,[]) :- !.
average_possible_cases(I,Av,Max,Cs,Lf) :-
average_cases2(Cs,I,Max,Lf,L0),
I1 is I+1,
average_possible_cases(I1,Av,Max,Cs,L0).
average_cases2([], _, _, L, L).
average_cases2([C|Cs], I, Av, [P|Lf], L0) :-
calculate_avg_prob(C, I, Av, P),
average_cases2(Cs, I, Av, Lf, L0).
calculate_avg_prob(C, I, Av, 1.0) :-
sum_all(C,0,N),
I =:= integer(round(N/Av)), !.
calculate_avg_prob(_, _, _, 0.0).
sum_possible_cases(Av,Av,_,[]) :- !.
sum_possible_cases(I,Av,Cs,Lf) :-
sum_cases2(Cs,I,Lf,L0),
I1 is I+1,
sum_possible_cases(I1,Av,Cs,L0).
sum_cases2([], _, L, L).
sum_cases2([C|Cs], I, [P|Lf], L0) :-
calculate_sum_prob(C, I, P),
sum_cases2(Cs, I, Lf, L0).
calculate_sum_prob(C, I, 1.0) :-
sum_all(C,0,N),
I =:= N, !.
calculate_sum_prob(_, _, 0.0).
get_sizes([], []).
get_sizes([V|Deps], [Sz|Sizes]) :-
get_dist_els(V,Sz),
get_sizes(Deps, Sizes).
get_dist_els(V,Sz) :-
get_atts(V, [size(Sz)]), !.
get_dist_els(V,Sz) :-
clpbn:get_atts(V, [dist(_=>Vals)]), !,
length(Vals,Sz),
put_atts(V, [size(Sz)]).
reorder_table(Vs0, Sizes, T0, Vs, TF) :-
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).
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.
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.
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),
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) :-
get_dist_els(V, Sz),
KI is K0*Sz,
multiply_sizes(Vs,KI,K).
process(LV0, InputVs, Out) :-
find_best(LV0, V0, 10000, V, WorkTables, LVI, InputVs),
V \== V0, !,
multiply_tables(WorkTables, Table),
propagate_evidence(V, Evs),
project(V,Table,NewTable,Evs),
include(LVI,NewTable,V,LV2),
process(LV2, InputVs, Out).
process(LV0, _, Out) :-
fetch_tables(LV0, WorkTables),
multiply_tables(WorkTables, Out).
find_best([], V, _, V, _, [], _).
find_best([var(V,I,Sz,Vals,Deps,K)|LV], _, Threshold, VF, NWorktables, LVF, Inputs) :-
K < Threshold,
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,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) :- !.
multiply_tables([tab(Tab1,Deps1,Szs1), tab(Tab2,Deps2,Sz2)| Tables], Out) :-
multiply_table(Tab1, Deps1, Szs1, Tab2, Deps2, Sz2, NTab, NDeps, NSz),
multiply_tables([tab(NTab,NDeps,NSz)| Tables], Out).
propagate_evidence(V, Evs) :-
clpbn:get_atts(V, [evidence(Ev),dist(_=>Out)]), !,
generate_szs_with_evidence(Out,Ev,Evs).
propagate_evidence(_, _).
generate_szs_with_evidence([],_,[]).
generate_szs_with_evidence([Ev|Out],Ev,[ok|Evs]) :- !,
generate_szs_with_evidence(Out,Ev,Evs).
generate_szs_with_evidence([_|Out],Ev,[not_ok|Evs]) :-
generate_szs_with_evidence(Out,Ev,Evs).
fetch_tables([], []).
fetch_tables([var(_,_,_,_,Deps,_)|LV0], Tables) :-
append(Deps,Tables0,Tables),
fetch_tables(LV0, Tables0).
not_var_member([], _).
not_var_member([V1|Vs], V) :- V1 \== V,
not_var_member(Vs, V).
multiply_table(Tab1, Deps1, Szs1, Tab2, Deps2, Szs2, NTab, NDeps, NSzs) :-
deps_union(Deps1,Szs1,Fs10,Deps2,Szs2,Fs20,NDeps,NSzs),
factors(NSzs, Fs, Total),
factors(Fs10, Fs1, _),
factors(Fs20, Fs2, _),
elements(0, Total, Fs, Fs1, Fs2, Tab1, Tab2, LTab),
NTab =.. [t|LTab].
deps_union([],[],[],[],[],[],[],[]) :- !.
deps_union([],[],Fs1,[V2|Deps2],[Sz|Szs2],[Sz|Szs2],[V2|Deps2],[Sz|Szs2]) :- !,
mk_zeros([Sz|Szs2],Fs1).
deps_union([V1|Deps1],[Sz|Szs1],[Sz|Szs1],[],[],Fs2,[V1|Deps1],[Sz|Szs1]) :- !,
mk_zeros([Sz|Szs1],Fs2).
deps_union([V1|Deps1],[Sz|Szs1],[Sz|Fs1],[V2|Deps2],[Sz|Szs2],[Sz|Fs2],[V1|NDeps],[Sz|NSzs]) :- V1 == V2, !,
deps_union(Deps1,Szs1,Fs1,Deps2,Szs2,Fs2,NDeps,NSzs).
deps_union([V1|Deps1],[Sz1|Szs1],[Sz1|Fs1],[V2|Deps2],Szs2,[0|Fs2],[V1|NDeps],[Sz1|NSzs]) :- V1 @< V2, !,
deps_union(Deps1,Szs1,Fs1,[V2|Deps2],Szs2,Fs2,NDeps,NSzs).
deps_union([V1|Deps1],Szs1,[0|Fs1],[V2|Deps2],[Sz|Szs2],[Sz|Fs2],[V2|NDeps],[Sz|NSzs]) :-
deps_union([V1|Deps1],Szs1,Fs1,Deps2,Szs2,Fs2,NDeps,NSzs).
mk_zeros([],[]).
mk_zeros([_|Szs],[0|Fs]) :-
mk_zeros(Szs,Fs).
factors([], [], 1).
factors([0|Ls], [0|NLs], Prod) :- !,
factors(Ls, NLs, Prod).
factors([N|Ls], [Prod0|NLs], Prod) :-
factors(Ls, NLs, Prod0),
Prod is Prod0*N.
elements(Total, Total, _, _, _, _, _, []) :- !.
elements(I, Total, Fs, Fs1, Fs2, Tab1, Tab2, [El|Els]) :-
element(Fs, I, 1, Fs1, 1, Fs2, Tab1, Tab2, El),
I1 is I+1,
elements(I1, Total, Fs, Fs1, Fs2, Tab1, Tab2, Els).
element([], _, P1, [], P2, [], Tab1, Tab2, El) :-
arg(P1, Tab1, El1),
arg(P2, Tab2, El2),
El is El1*El2.
element([F|Fs], I, P1, [F1|Fs1], P2, [F2|Fs2], Tab1, Tab2, El) :-
FF is I // F,
NP1 is P1+F1*FF,
NP2 is P2+F2*FF,
NI is I mod F,
element(Fs, NI, NP1, Fs1, NP2, Fs2, Tab1, Tab2, El).
%
project(V,tab(Table,Deps,Szs),tab(NewTable,NDeps,NSzs),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].
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).
include([],_,_,[]).
include([var(V,P,VSz,D,Tabs,Est)|LV],tab(T,Vs,Sz),V1,[var(V,P,VSz,D,Tabs,Est)|NLV]) :-
not_var_member(Vs,V), !,
include(LV,tab(T,Vs,Sz),V1,NLV).
include([var(V,P,VSz,D,Tabs,_)|LV],Table,NV,[var(V,P,VSz,D,NTabs,NEst)|NLV]) :-
update_tables(Tabs,NTabs,Table,NV,[],NEst),
include(LV,Table,NV,NLV).
update_tables([],[Table],Table,_,AVs,NS) :-
Table = tab(_,Vs,_),
ord_union(Vs,AVs,TVs),
length(TVs,NS).
update_tables([tab(Tab0,Vs,Sz)|Tabs],[tab(Tab0,Vs,Sz)|NTabs],Table,V,AVs0,NS) :-
not_var_member(Vs,V), !,
ord_union(Vs,AVs0,AVsI),
update_tables(Tabs,NTabs,Table,V,AVsI,NS).
update_tables([_|Tabs],NTabs,Table,V,AVs0,NS) :-
update_tables(Tabs,NTabs,Table,V,AVs0,NS).
bind_vals([],_,_) :- !.
% 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 ?
bind_vals(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(_=>D)]),
get_all_doms(Vs, Ds).
ms([], []).
ms([H|L], [El|Els]) :-
member(El,H),
ms(L, Els).
normalise(Ps0,Ps) :-
add_all(Ps0,0.0,Sum),
divide_by_sum(Ps0,Sum,Ps).
add_all([],Sum,Sum).
add_all([P|Ps0],Sum0,Sum) :-
SumI is Sum0+P,
add_all(Ps0,SumI,Sum).
divide_by_sum([],_,[]).
divide_by_sum([P|Ps0],Sum,[PN|Ps]) :-
PN is P/Sum,
divide_by_sum(Ps0,Sum,Ps).
attribute_goal(V, G) :-
get_atts(V, [posterior(Vs,Vals,Ps,AllDiffs)]),
massage_out(Vs, Vals, Ps, G, AllDiffs).
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) :-
gen_eqs(Vs,D,Eqs),
add_alldiffs(AllDiffs,Eqs,CEqs),
massage_out(Vs, Ds, Ps, G, AllDiffs).
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))).