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/ground_factors.yap

184 lines
3.8 KiB
Plaintext
Raw Normal View History

2012-01-10 17:01:06 +00:00
%parfactor(
% [ability(P),grade(C,S), satisfaction(C,S,P)],
% \phi = [....],
% [P,C,S],
% [P \in [p1,p2,p4], C \in [c1,c3], S \in [s2,s3]]).
% [S \= s2])
2012-08-15 22:01:45 +01:00
:- module(pfl_ground_factors, [
generate_network/5,
f/3
]).
2012-01-10 17:01:06 +00:00
:- use_module(library(bhash), [
b_hash_new/1,
b_hash_lookup/3,
2012-08-09 04:16:37 +01:00
b_hash_insert/4,
b_hash_to_list/2]).
2012-01-10 17:01:06 +00:00
2012-04-03 15:01:35 +01:00
:- use_module(library(lists), [
delete/3,
2012-04-03 17:12:58 +01:00
nth0/3,
2012-04-03 15:01:35 +01:00
member/2]).
2012-08-29 02:21:14 +01:00
:- use_module(library(maplist)).
2012-01-10 17:01:06 +00:00
:- use_module(library(pfl), [
2012-04-03 15:01:35 +01:00
factor/6,
defined_in_factor/2,
2012-01-10 17:01:06 +00:00
skolem/2]).
:- use_module(library(clpbn/dists), [
dist/4]).
2012-08-15 22:01:45 +01:00
:- dynamic currently_defined/1, queue/1, f/4.
2012-01-10 17:01:06 +00:00
2012-08-09 04:16:37 +01:00
%
% as you add query vars the network grows
% until you reach the last variable.
%
2012-08-15 22:01:45 +01:00
generate_network(QueryVars, QueryKeys, Keys, Factors, EList) :-
2012-08-09 04:16:37 +01:00
init_global_search,
attributes:all_attvars(AVars),
b_hash_new(Evidence0),
2012-08-29 22:36:46 +01:00
foldl(include_evidence,AVars, Evidence0, Evidence1),
static_evidence(Evidence1, Evidence),
b_hash_to_list(Evidence, EList0),
maplist(pair_to_evidence,EList0, EList),
maplist(queue_evidence, EList),
foldl(run_through_query(Evidence), QueryVars, [], QueryKeys),
2012-08-15 22:01:45 +01:00
propagate,
2012-08-09 04:16:37 +01:00
collect(Keys, Factors).
%
% clean global stateq
%
init_global_search :-
2012-08-15 22:01:45 +01:00
retractall(queue(_)),
2012-08-09 04:16:37 +01:00
retractall(currently_defined(_)),
2012-08-15 22:01:45 +01:00
retractall(f(_,_,_)).
2012-08-09 04:16:37 +01:00
2012-08-29 22:36:46 +01:00
pair_to_evidence(K-E, K=E).
2012-08-09 04:16:37 +01:00
2012-08-29 22:36:46 +01:00
include_evidence(V, Evidence0, Evidence) :-
2012-08-09 04:16:37 +01:00
clpbn:get_atts(V,[key(K),evidence(E)]), !,
(
b_hash_lookup(K, E1, Evidence0)
->
2012-08-29 22:36:46 +01:00
(E \= E1 -> throw(clpbn:incompatible_evidence(K,E,E1)) ; Evidence = Evidence0)
2012-08-09 04:16:37 +01:00
;
2012-08-29 22:36:46 +01:00
b_hash_insert(Evidence0, K, E, Evidence)
).
include_evidence(_, Evidence, Evidence).
static_evidence(Evidence0, Evidence) :-
findall(Sk=Var, pfl:evidence(Sk,Var), Evs),
foldl(include_static_evidence, Evs, Evidence0, Evidence).
2012-08-09 04:16:37 +01:00
2012-08-29 22:36:46 +01:00
include_static_evidence(K=E, Evidence0, Evidence) :-
2012-08-09 04:16:37 +01:00
(
b_hash_lookup(K, E1, Evidence0)
->
2012-08-29 22:36:46 +01:00
(E \= E1 -> throw(incompatible_evidence(K,E,E1)) ; Evidence = Evidence0)
2012-08-09 04:16:37 +01:00
;
2012-08-29 22:36:46 +01:00
b_hash_insert(Evidence0, K, E, Evidence)
).
2012-08-09 04:16:37 +01:00
2012-08-29 22:36:46 +01:00
queue_evidence(K=_) :-
queue_in(K).
2012-08-09 04:16:37 +01:00
2012-08-29 22:36:46 +01:00
run_through_query(Evidence, V, QueryKeys, QueryKeys) :-
2012-08-09 04:16:37 +01:00
clpbn:get_atts(V,[key(K)]),
2012-08-29 22:36:46 +01:00
b_hash_lookup(K, _, Evidence), !.
run_through_query(_Evidence, V, QueryKeys, [K|QueryKeys]) :-
2012-08-09 04:16:37 +01:00
clpbn:get_atts(V,[key(K)]),
2012-08-29 22:36:46 +01:00
queue_in(K).
2012-08-09 04:16:37 +01:00
collect(Keys, Factors) :-
2012-04-03 15:01:35 +01:00
findall(K, currently_defined(K), Keys),
2012-08-15 22:01:45 +01:00
findall(f(FType,FId,FKeys), f(FType,FId,FKeys), Factors).
2012-04-03 16:22:40 +01:00
ground_all_keys([], _).
ground_all_keys([V|GVars], AllKeys) :-
clpbn:get_atts(V,[key(Key)]),
\+ ground(Key), !,
member(Key, AllKeys),
ground_all_keys(GVars, AllKeys).
ground_all_keys([_V|GVars], AllKeys) :-
ground_all_keys(GVars, AllKeys).
2012-06-01 13:17:39 +01:00
2012-04-03 16:22:40 +01:00
keys([], []).
keys([Var|QueryVars], [Key|QueryKeys]) :-
clpbn:get_atts(Var,[key(Key)]),
keys(QueryVars, QueryKeys).
2012-01-10 17:01:06 +00:00
2012-04-03 15:01:35 +01:00
initialize_evidence([]).
initialize_evidence([V|EVars]) :-
clpbn:get_atts(V, [key(K)]),
ground(K),
2012-08-15 22:01:45 +01:00
queue_in(K),
2012-04-03 15:01:35 +01:00
initialize_evidence(EVars).
2012-01-10 17:01:06 +00:00
2012-08-15 22:01:45 +01:00
2012-01-10 17:01:06 +00:00
%
2012-04-03 15:01:35 +01:00
% gets key K, and collects factors that define it
2012-08-15 22:01:45 +01:00
queue_in(K) :-
queue(K), !.
queue_in(K) :-
2012-08-29 02:21:14 +01:00
writeln(+K),
assert(queue(K)),
fail.
queue_in(_).
2012-08-15 22:01:45 +01:00
propagate :-
retract(queue(K)),!,
do_propagate(K).
propagate.
2012-08-29 22:36:46 +01:00
do_propagate(agg(_)) :- !,
propagate.
2012-08-15 22:01:45 +01:00
do_propagate(K) :-
%writeln(-K),
2012-04-03 17:12:58 +01:00
\+ currently_defined(K),
( ground(K) -> assert(currently_defined(K)) ; true),
2012-08-15 22:01:45 +01:00
(
defined_in_factor(K, ParFactor),
add_factor(ParFactor, Ks)
*->
true
;
throw(error(no_defining_factor(K)))
)
,
2012-08-29 22:36:46 +01:00
writeln(Ks),
2012-04-03 15:01:35 +01:00
member(K1, Ks),
\+ currently_defined(K1),
2012-08-15 22:01:45 +01:00
queue_in(K1),
fail.
2012-08-29 02:21:14 +01:00
do_propagate(_K) :-
2012-08-15 22:01:45 +01:00
propagate.
2012-04-03 15:01:35 +01:00
2012-08-29 22:36:46 +01:00
add_factor(factor(Type, Id, Ks, _, _Phi, Constraints), NKs) :-
( Ks = [K,agg(Els)]
->
NKs=[K|Els]
;
NKs = Ks
),
2012-08-15 22:01:45 +01:00
run(Constraints), !,
2012-08-29 22:36:46 +01:00
\+ f(Type, Id, NKs),
assert(f(Type, Id, NKs)).
fetch_list((A,agg(B)), A, B).
2012-04-03 15:01:35 +01:00
run([Goal|Goals]) :-
call(user:Goal),
run(Goals).
run([]).