yap-6.3/packages/CLPBN/clpbn/bp.yap

/************************************************

  Belief Propagation in CLP(BN)
 
**************************************************/

:- module(clpbn_bp,
          [bp/3,
           check_if_bp_done/1,
           set_solver_parameter/2,
           use_log_space/0,
           init_bp_solver/4,
           run_bp_solver/3,
           finalize_bp_solver/1
          ]).


:- use_module(library('clpbn/dists'),
          [dist/4,
           get_dist_domain/2,
           get_dist_domain_size/2,
           get_dist_params/2
          ]).


:- use_module(library('clpbn/display'),
         [clpbn_bind_vals/3]).

:- use_module(library('clpbn/aggregates'),
	      [check_for_agg_vars/2]).

:- use_module(library(atts)).

:- use_module(library(charsio)).

:- load_foreign_files(['horus'], [], init_predicates).

:- attribute id/1.

:- dynamic network_counting/1.


check_if_bp_done(_Var).

network_counting(0).


:- set_solver_parameter(run_mode, normal).
%:- set_solver_parameter(run_mode, convert).
%: -set_solver_parameter(run_mode, compress).

:- set_solver_parameter(schedule, seq_fixed).
%:- set_solver_parameter(schedule, seq_random).
%:- set_solver_parameter(schedule, parallel).
%:- set_solver_parameter(schedule, max_residual).

:- set_solver_parameter(accuracy, 0.0001).

:- set_solver_parameter(max_iter, 1000).

:- set_solver_parameter(always_loopy_solver, false).

% :- use_log_space.


bp([[]],_,_) :- !.
bp([QueryVars], AllVars, Output) :-
	init_bp_solver(_, AllVars, _, BayesNet),
	run_bp_solver([QueryVars], LPs, BayesNet),
	finalize_bp_solver(BayesNet),
	clpbn_bind_vals([QueryVars], LPs, Output).


init_bp_solver(_, AllVars0, _, bp(BayesNet, DistIds, AllParFactors)) :-
	check_for_agg_vars(AllVars0, AllVars),
	%inc_network_counting,
%writeln_clpbn_vars(AllVars),
	process_ids(AllVars, 0, DistIds0),
%	generate_parfactors(AllVars, AllParFactors),
%writeln(AllParFactors),
	get_vars_info(AllVars, VarsInfo),
	sort(DistIds0, DistIds),
	%(network_counting(0) -> writeln(vars:VarsInfo) ; true),
	%(network_counting(0) -> writeln(distsids:DistIds) ; true),
	create_network(VarsInfo, BayesNet).
	%get_extra_vars_info(AllVars, ExtraVarsInfo),
	%(network_counting(0) -> writeln(extra:ExtraVarsInfo) ; true),
	%set_extra_vars_info(BayesNet, ExtraVarsInfo).

writeln_clpbn_vars(Var.AVars) :-
	clpbn:get_atts(Var, [key(Key),dist(Dist,Parents)]),
	parents_to_keys(Parents, Keys),
	writeln(Var:Key:Dist:Keys),
	writeln_clpbn_vars(AVars).
writeln_clpbn_vars([]).

parents_to_keys([], []).
parents_to_keys(Var.Parents, Key.Keys) :-
	clpbn:get_atts(Var, [key(Key)]),
	parents_to_keys(Parents, Keys).

generate_parfactors(AllVars, ParFactors) :-
	generate_factors(AllVars, Factors),
%writeln(Factors),
	% sort factors by distribution
%	sort(Factors, DistFactors),
%writeln(DistFactors),
	group(DistFactors, ParFactors).
%writeln(ParFactors).

generate_factors(Var.AllVars, f(Dist,[Var|Parents]).AllFactors) :-
	clpbn:get_atts(Var, [dist(Dist,Parents)]),
	generate_factors(AllVars, AllFactors).
generate_factors([], []).

group([], []).
group(f(Dist,Vs).DistFactors, phi(Dist,NConstraints,Domain).ParFactors) :-
	number(Dist),
	grab_similar_factors(Dist, Vs, f(Dist,Vs).DistFactors, RemainingDistFactors, Constraints),
	simplify_constraints(Constraints, NConstraints, Domain), !,
	group(RemainingDistFactors, ParFactors).

group(f(Dist,Vs).DistFactors, phi(Dist,Constraints,[]).ParFactors) :-
	grab_similar_factors(Dist, Vs, f(Dist,Vs).DistFactors, RemainingDistFactors, Constraints),
	group(RemainingDistFactors, ParFactors).

simplify_constraints([[1=El]|Constraints], [NEl], [in(1,NEl,Domain)]) :-
	functor(El,Name,1), !,
	functor(NEl,Name,1),
	constraints_to_domain(1,[[1=El]|Constraints],Domain0),
	sort(Domain0, Domain).
simplify_constraints(Constraints, NewConstraints, Ds) :-
        Constraints = [Constraint|_],
	generate_domains(Constraint, Constraints, Ds), !,
	normalize_constraints(Ds, Constraints, NewConstraints).
simplify_constraints(Constraints, Constraints, []).

normalize_constraints(Ds, Constraints, [T|GeneralizedConstraints]) :-
	unique(Ds, I, T, RemDs), !,
	remove_i(Constraints, I, ConstraintsI),
	normalize_constraints(RemDs, ConstraintsI, GeneralizedConstraints).
normalize_constraints(Ds, Constraints, [(S1,S2)|GeneralizedConstraints]) :-
	equal(Ds, I, J, RemDs, S1, S2),
	arg(1,S1,V),
	arg(1,S2,V),
%writeln(start:Ds:I:J),
	remove_eqs(Constraints, I, J, ConstraintsI), !,
	normalize_constraints(RemDs, ConstraintsI, GeneralizedConstraints).
normalize_constraints(_Ds, Constraints, []) :-
	Constraints = [[_]|_], !.
normalize_constraints(_, Constraints, Constraints).

unique([in(I,T,[_])|Ds], I, T, Ds).	
unique([D|Ds], I, T, D.NewDs) :-
	unique(Ds, I, T, NewDs).	

equal([in(I,S1,Vals)|Ds], I, J, Ds, S1, S2) :-
	equal2(Ds, Vals, J, S2), !.
equal([D|Ds], I, J, D.NewDs, S1, S2) :-
	equal(Ds, I, J, NewDs, S1, S2).	

equal2([in(J,S2,Vals)|Ds], Vals, J, S2).
equal2([D|Ds], Vals, J, S2) :-
	equal2(Ds, Vals, J, S2).	

remove_i([], _I, []).
remove_i(C.Constraints, I, NewC.ConstraintsI) :-
	remove_ic(C,I,NewC),
	remove_i(Constraints, I, ConstraintsI).

remove_ic([I=_|C], I, C) :- !.
remove_ic(El.C, I, El.NewC) :-
	remove_ic(C, I, NewC).

remove_eqs([], _I, _J, []).
remove_eqs(C.Constraints, I, J, NewC.ConstraintsI) :-
	remove_eqs2(C, I, J, NewC),
	remove_eqs(Constraints, I, J, ConstraintsI).

remove_eqs2([I=V|C], I, J, C) :- !,
	arg(1,V,A),
	check_match(C, J, A).
remove_eqs2(El.C, I, J, El.NewC) :-
	remove_eqs2(C, I, J, NewC).

check_match([J=V1|C], J, V) :- !,
	arg(1,V1,V).
check_match(El.C, J, V) :-
	check_match(C, J, V).


generate_domains([], _Constraints, []).
generate_domains([I=El|Constraint], Constraints, in(I,NEl,Domain).Ds) :-
	functor(El,Name,1), !,
	functor(NEl,Name,1),
	constraints_to_domain(I,Constraints,Domain0),
	sort(Domain0, Domain),
	generate_domains(Constraint, Constraints, Ds).	


constraints_to_domain(_,[],[]).
constraints_to_domain(I,[Constraint|Constraints],El.Domain) :-
	add_constraint_to_domain(I, Constraint, El),
	constraints_to_domain(I,Constraints,Domain).

add_constraint_to_domain(I, [I=El|_], A) :- !,
	arg(1, El, A).
add_constraint_to_domain(I, _.Constraint, El) :-
	add_constraint_to_domain(I, Constraint, El).


grab_similar_factors(Dist, Vs, f(Dist,DVs).DistFactors, RemainingDistFactors, Constraint.Constraints) :-
	grab_similar_factor(DVs, 1, Constraint), !,
	grab_similar_factors(Dist, Vs, DistFactors, RemainingDistFactors, Constraints).
grab_similar_factors(_Dist, _Vs, DistFactors, DistFactors, []).

grab_similar_factor([], _Arg, []).
grab_similar_factor(V.VDVs, Arg, (Arg=Key).Constraint) :-
	clpbn:get_atts(V,key(Key)),
	Arg1 is Arg+1,
	grab_similar_factor(VDVs, Arg1, Constraint).


process_ids([], _, []).
process_ids([V|Vs], VarId0, [DistId|DistIds]) :-
	clpbn:get_atts(V, [dist(DistId, _)]), !,
	put_atts(V, [id(VarId0)]),
	VarId is VarId0 + 1,
	process_ids(Vs, VarId, DistIds).
process_ids([_|Vs], VarId, DistIds) :-
	process_ids(Vs, VarId, DistIds).


get_vars_info([], []).
get_vars_info([V|Vs], [var(VarId, DSize, Ev, ParentIds, DistId)|VarsInfo]) :-
	clpbn:get_atts(V, [dist(DistId, Parents)]), !,
	get_atts(V, [id(VarId)]),
	get_dist_domain_size(DistId, DSize),
	get_evidence(V, Ev),
	vars2ids(Parents, ParentIds),
	get_vars_info(Vs, VarsInfo).
get_vars_info([_|Vs], VarsInfo) :-
	get_vars_info(Vs, VarsInfo).


vars2ids([], []).
vars2ids([V|QueryVars], [VarId|Ids]) :-
	get_atts(V, [id(VarId)]),
	vars2ids(QueryVars, Ids).


get_evidence(V, Ev) :-
	clpbn:get_atts(V, [evidence(Ev)]), !.
get_evidence(_V, -1). % no evidence !!!


get_extra_vars_info([], []).
get_extra_vars_info([V|Vs], [v(VarId, Label, Domain)|VarsInfo]) :-
	get_atts(V, [id(VarId)]), !,
	clpbn:get_atts(V, [key(Key),dist(DistId, _)]),
	term_to_atom(Key, Label),
	get_dist_domain(DistId, Domain0),
	numbers2atoms(Domain0, Domain),
	get_extra_vars_info(Vs, VarsInfo).
get_extra_vars_info([_|Vs], VarsInfo) :-
	get_extra_vars_info(Vs, VarsInfo).


numbers2atoms([], []).
numbers2atoms([Atom|L0], [Atom|L]) :-
	atom(Atom), !,
	numbers2atoms(L0, L).
numbers2atoms([Number|L0], [Atom|L]) :-
	number_atom(Number, Atom),
	numbers2atoms(L0, L).


run_bp_solver(QVsL0, LPs, bp(BayesNet, DistIds, _)) :-
	get_dists_parameters(DistIds, DistsParams),
	set_parameters(BayesNet, DistsParams),
	process_query_list(QVsL0, QVsL),
	%(network_counting(0) -> writeln(qvs:QVsL) ; true),
	run_solver(BayesNet, QVsL, LPs).


process_query_list([], []).
process_query_list([[V]|QueryVars], [VarId|Ids]) :- !,
	get_atts(V, [id(VarId)]),
	process_query_list(QueryVars, Ids).
process_query_list([Vs|QueryVars], [VarIds|Ids]) :-
	vars2ids(Vs, VarIds),
	process_query_list(QueryVars, Ids).


get_dists_parameters([],[]).
get_dists_parameters([Id|Ids], [dist(Id, Params)|DistsInfo]) :-
	get_dist_params(Id, Params),
	get_dists_parameters(Ids, DistsInfo).


finalize_bp_solver(bp(BayesNet, _, _)) :-
	free_bayesian_network(BayesNet).


inc_network_counting :-
	retract(network_counting(Count0)),
	Count is Count0 + 1,
	assert(network_counting(Count)).