This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/packages/CLPBN/clpbn/connected.yap

169 lines
4.5 KiB
Plaintext
Raw Normal View History

:- module(clpbn_connected,
[influences/3,
factor_influences/4,
init_influences/3,
influences/4
]).
2012-09-26 00:04:58 +01:00
:- use_module(library(maplist)).
:- use_module(library(dgraphs),
[dgraph_new/1,
dgraph_add_edges/3,
dgraph_add_vertex/3,
dgraph_neighbors/3,
dgraph_edge/3,
dgraph_transpose/2
]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_lookup/3,
rb_insert/4,
rb_visit/2
]).
2012-09-26 00:04:58 +01:00
factor_influences(Vs, QVars, Ev, LV) :-
init_factor_influences(Vs, G, RG),
influences(QVars, Ev, G, RG, LV).
init_factor_influences(Vs, G, RG) :-
dgraph_new(G0),
foldl(factor_to_dgraph, Vs, G0, G),
dgraph_transpose(G, RG).
2011-05-27 21:34:55 +01:00
influences(Vs, QVars, LV) :-
init_influences(Vs, G, RG),
2012-09-26 00:04:58 +01:00
influences(QVars, [], G, RG, LV).
init_influences(Vs, G, RG) :-
dgraph_new(G0),
2011-05-27 21:34:55 +01:00
to_dgraph(Vs, G0, G),
dgraph_transpose(G, RG).
factor_to_dgraph(fn([V|Parents],_,_,_,_), G0, G) :-
2012-09-26 00:04:58 +01:00
dgraph_add_vertex(G0, V, G00),
build_edges(Parents, V, Edges),
dgraph_add_edges(G00, Edges, G).
2011-05-27 21:34:55 +01:00
to_dgraph([], G, G).
to_dgraph([V|Vs], G0, G) :-
clpbn:get_atts(V, [dist(_,Parents)]), !,
dgraph_add_vertex(G0, V, G00),
build_edges(Parents, V, Edges),
dgraph_add_edges(G00, Edges, G1),
to_dgraph(Vs, G1, G).
build_edges([], _, []).
build_edges([P|Parents], V, [P-V|Edges]) :-
build_edges(Parents, V, Edges).
2011-05-27 21:34:55 +01:00
% search for the set of variables that influence V
influences(Vs, G, RG, Vars) :-
2012-12-17 17:57:00 +00:00
influences(Vs, [], G, RG, Vars).
2012-09-26 00:04:58 +01:00
% search for the set of variables that influence V
influences(Vs, Evs, G, RG, Vars) :-
2012-12-17 17:57:00 +00:00
rb_new(Visited0),
foldl(influence(Evs, G, RG), Vs, Visited0, Visited),
all_top(Visited, Evs, Vars).
2012-09-26 00:04:58 +01:00
influence(_, _G, _RG, V, Vs, Vs) :-
rb_lookup(V, [T|B], Vs), T == t, B == b, !.
influence(Ev, G, RG, V, Vs0, Vs) :-
rb_insert(Vs0, V, [t|b], Vs1),
process_new_variable(V, Ev, G, RG, Vs1, Vs).
process_new_variable(V, _Evs, _G, _RG, _Vs0, _Vs1) :-
var(V),
2011-05-27 21:34:55 +01:00
clpbn:get_atts(V,[evidence(Ev)]), !,
throw(error(bound_to_evidence(V/Ev))).
2012-09-26 00:04:58 +01:00
process_new_variable(V, Evs, _G, _RG, _Vs0, _Vs1) :-
rb_lookup(V, Ev, Evs), !,
throw(error(bound_to_evidence(V/Ev))).
process_new_variable(V, Evs, G, RG, Vs0, Vs2) :-
2011-05-27 21:34:55 +01:00
dgraph_neighbors(V, G, Children),
2012-09-26 00:04:58 +01:00
foldl(throw_below(Evs, G, RG), Children, Vs0, Vs1),
2011-05-27 21:34:55 +01:00
dgraph_neighbors(V, RG, Parents),
2012-09-26 00:04:58 +01:00
foldl(throw_above(Evs, G, RG), Parents, Vs1, Vs2).
2011-05-27 21:34:55 +01:00
% visited
2012-09-26 00:04:58 +01:00
throw_below(Evs, G, RG, Child, Vs0, Vs1) :-
rb_lookup(Child, [_|B], Vs0), !,
2012-12-17 17:57:00 +00:00
(
B == b
->
2011-05-27 21:34:55 +01:00
Vs0 = Vs1 % been there before
2012-12-17 17:57:00 +00:00
;
2011-05-27 21:34:55 +01:00
B = b, % mark it
2012-12-17 17:57:00 +00:00
handle_ball_from_above(Child, Evs, G, RG, Vs0, Vs1)
).
2012-09-26 00:04:58 +01:00
throw_below(Evs, G, RG, Child, Vs0, Vs2) :-
rb_insert(Vs0, Child, [_|b], Vs1),
handle_ball_from_above(Child, Evs, G, RG, Vs1, Vs2).
2011-05-27 21:34:55 +01:00
% share this with parents, if we have evidence
2012-09-26 00:04:58 +01:00
handle_ball_from_above(V, Evs, G, RG, Vs0, Vs1) :-
2012-12-17 17:57:00 +00:00
var(V),
clpbn:get_atts(V,[evidence(_)]), !,
dgraph_neighbors(V, RG, Parents),
foldl(throw_above(Evs, G, RG), Parents, Vs0, Vs1).
2012-09-26 00:04:58 +01:00
handle_ball_from_above(V, Evs, G, RG, Vs0, Vs1) :-
2012-12-17 17:57:00 +00:00
nonvar(V),
rb_lookup(V,_,Evs), !,
dgraph_neighbors(V, RG, Parents),
foldl(throw_above(Evs, G, RG), Parents, Vs0, Vs1).
2011-05-27 21:34:55 +01:00
% propagate to kids, if we do not
2012-09-26 00:04:58 +01:00
handle_ball_from_above(V, Evs, G, RG, Vs0, Vs1) :-
2012-12-17 17:57:00 +00:00
dgraph_neighbors(V, G, Children),
foldl(throw_below(Evs, G, RG), Children, Vs0, Vs1).
2011-05-27 21:34:55 +01:00
% visited
2012-09-26 00:04:58 +01:00
throw_above(Evs, G, RG, Parent, Vs0, Vs1) :-
rb_lookup(Parent, [T|_], Vs0), !,
2012-12-17 17:57:00 +00:00
(
T == t
->
2011-05-27 21:34:55 +01:00
Vs1 = Vs0 % been there before
2012-12-17 17:57:00 +00:00
;
2011-05-27 21:34:55 +01:00
T = t, % mark it
2012-12-17 17:57:00 +00:00
handle_ball_from_below(Parent, Evs, G, RG, Vs0, Vs1)
).
2012-09-26 00:04:58 +01:00
throw_above(Evs, G, RG, Parent, Vs0, Vs2) :-
rb_insert(Vs0, Parent, [t|_], Vs1),
handle_ball_from_below(Parent, Evs, G, RG, Vs1, Vs2).
2011-05-27 21:34:55 +01:00
% share this with parents, if we have evidence
2012-09-26 00:04:58 +01:00
handle_ball_from_below(V, _Evs, _, _, Vs, Vs) :-
2012-12-17 17:57:00 +00:00
var(V),
clpbn:get_atts(V,[evidence(_)]), !.
2012-09-26 00:04:58 +01:00
handle_ball_from_below(V, Evs, _, _, Vs, Vs) :-
2012-12-17 17:57:00 +00:00
nonvar(V),
rb_lookup(V, _, Evs), !.
2011-05-27 21:34:55 +01:00
% propagate to kids, if we do not
2012-09-26 00:04:58 +01:00
handle_ball_from_below(V, Evs, G, RG, Vs0, Vs1) :-
2012-12-17 17:57:00 +00:00
dgraph_neighbors(V, RG, Parents),
propagate_ball_from_below(Parents, Evs, V, G, RG, Vs0, Vs1).
2012-09-26 00:04:58 +01:00
propagate_ball_from_below([], Evs, V, G, RG, Vs0, Vs1) :- !,
2012-12-17 17:57:00 +00:00
dgraph_neighbors(V, G, Children),
foldl(throw_below(Evs, G, RG), Children, Vs0, Vs1).
2012-09-26 00:04:58 +01:00
propagate_ball_from_below(Parents, Evs, _V, G, RG, Vs0, Vs1) :-
2012-12-17 17:57:00 +00:00
foldl(throw_above(Evs, G, RG), Parents, Vs0, Vs1).
2012-09-26 00:04:58 +01:00
all_top(T, Evs, Vs) :-
2012-12-17 17:57:00 +00:00
rb_visit(T, Pairs),
foldl( get_top(Evs), Pairs, [], Vs).
2012-09-26 00:04:58 +01:00
get_top(_EVs, V-[T|_], Vs, [V|Vs]) :-
2012-12-17 17:57:00 +00:00
T == t, !.
2012-09-26 00:04:58 +01:00
get_top(_EVs, V-_, Vs, [V|Vs]) :-
2012-12-17 17:57:00 +00:00
var(V),
clpbn:get_atts(V,[evidence(_)]), !.
2012-09-26 00:04:58 +01:00
get_top(EVs, V-_, Vs, [V|Vs]) :-
2012-12-17 17:57:00 +00:00
nonvar(V),
rb_lookup(V, _, EVs), !.
2012-09-29 11:50:00 +01:00
get_top(_, _, Vs, Vs).