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

preliminary support for viterbi algorithm and HMMs

Browse Source 
some code cleanups


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1363 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2005-08-17 13:34:56 +00:00
parent 46f6a08087
commit a4b79352d5
7 changed files with 221 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CLPBN/Makefile.in
View File

@ -33,8 +33,10 @@ CLPBN_PROGRAMS= \
$(srcdir)/clpbn/gibbs.yap \
$(srcdir)/clpbn/graphs.yap \
$(srcdir)/clpbn/graphviz.yap \
$(srcdir)/clpbn/topsort.yap \
$(srcdir)/clpbn/utils.yap \
$(srcdir)/clpbn/vel.yap \
$(srcdir)/clpbn/viterbi.yap \
$(srcdir)/clpbn/xbif.yap
CLPBN_EXAMPLES=

35
CLPBN/clpbn.yap
View File

@ -44,6 +44,10 @@
incorporate_evidence/2
]).
:- use_module('clpbn/utils', [
sort_vars_by_key/3
]).
:- dynamic solver/1,output/1,use/1.
solver(vel).
@ -116,37 +120,6 @@ get_clpbn_vars([V|GVars],[V|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).
get_keys([_|AVars], KeysVars) :- % may be non-CLPBN vars.
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(vel, GVars, AVars, DiffVars) :-
vel(GVars, AVars, DiffVars).
write_out(gibbs, GVars, AVars, DiffVars) :-

26
CLPBN/clpbn/gibbs.yap
View File

@ -30,6 +30,9 @@
:- use_module(library('clpbn/utils'), [
check_for_hidden_vars/3]).
:- use_module(library('clpbn/topsort'), [
topsort/2]).
:- dynamic gibbs_params/3.
:- dynamic implicit/1.
@ -446,27 +449,6 @@ clean_up.
gibbs_params(5,10000,100000).
/* simple implementation of a topological sorting algorithm */
/* graph is as Node-[Parents] */
topsort([], []) :- !.
topsort(Graph0,Sorted) :-
add_parentless(Graph0, Sorted, IncludedI, Graph1, SortedRest),
sort(IncludedI, Included),
delete_parents(Graph1, Included, NoParents),
topsort(NoParents, SortedRest).
add_parentless([], Sorted, [], [], Sorted).
add_parentless([Node-[]|Graph0], [Node|Sorted], [Node|Included], Graph1, SortedRest) :- !,
add_parentless(Graph0, Sorted, Included, Graph1, SortedRest).
add_parentless([Node|Graph0], Sorted, Included, [Node|Graph1], SortedRest) :-
add_parentless(Graph0, Sorted, Included, Graph1, SortedRest).
delete_parents([], _, []).
delete_parents([Node-Parents|Graph1], Included, [Node-NewParents|NoParents]) :-
ord_subtract(Parents, Included, NewParents),
delete_parents(Graph1, Included, NoParents).
cvt2problist([], []).
cvt2problist([[[_|E]]|Est0], [Ps|Probs]) :-
sum_all(E,0,Sum),
@ -486,6 +468,6 @@ do_probs([E|Es],Sum,[P|Ps]) :-
show_sorted([], _) :- nl.
show_sorted([I|VarOrder], Graph) :-
arg(I,Graph,var(V,I,_,_,_,_,_,_,_)),
clpbn:get_atts(V,[key(K)]),
% clpbn:get_atts(V,[key(K)]),
% format('~w ',[K]),
show_sorted(VarOrder, Graph).

27
CLPBN/clpbn/topsort.yap Normal file
View File

@ -0,0 +1,27 @@
:- module(topsort, [topsort/2]).
:- use_module(library(ordsets),
[ord_subtract/3]).
/* simple implementation of a topological sorting algorithm */
/* graph is as Node-[Parents] */
topsort([], []) :- !.
topsort(Graph0,Sorted) :-
add_parentless(Graph0, Sorted, IncludedI, Graph1, SortedRest),
sort(IncludedI, Included),
delete_parents(Graph1, Included, NoParents),
topsort(NoParents, SortedRest).
add_parentless([], Sorted, [], [], Sorted).
add_parentless([Node-[]|Graph0], [Node|Sorted], [Node|Included], Graph1, SortedRest) :- !,
add_parentless(Graph0, Sorted, Included, Graph1, SortedRest).
add_parentless([Node|Graph0], Sorted, Included, [Node|Graph1], SortedRest) :-
add_parentless(Graph0, Sorted, Included, Graph1, SortedRest).
delete_parents([], _, []).
delete_parents([Node-Parents|Graph1], Included, [Node-NewParents|NoParents]) :-
ord_subtract(Parents, Included, NewParents),
delete_parents(Graph1, Included, NoParents).

35
CLPBN/clpbn/utils.yap
View File

@ -1,7 +1,8 @@
:- module(clpbn_utils, [
clpbn_not_var_member/2,
clpbn_var_member/2,
check_for_hidden_vars/3]).
check_for_hidden_vars/3,
sort_vars_by_key/3]).
%
% It may happen that variables from a previous query may still be around.
@ -34,3 +35,35 @@ clpbn_not_var_member([], _).
clpbn_not_var_member([V1|Vs], V) :- V1 \== V,
clpbn_not_var_member(Vs, V).
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]) :-
clpbn:get_atts(V, [key(K)]), !,
get_keys(AVars, KeysVars).
get_keys([_|AVars], KeysVars) :- % may be non-CLPBN vars.
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]).

1
CLPBN/clpbn/vel.yap
View File

@ -88,7 +88,6 @@ find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Parents,Size
var_with_deps(V, Table, Deps, Sizes, Ev, Vals) :-
clpbn:get_atts(V, [dist(Vals,OTable,Parents)]),
clpbn:get_atts(V, [key(K)]), format('~w(~w) Parents: ~w~n',[V,K,Parents]),
( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true),
reorder_CPT([V|Parents],OTable,Deps0,Table0,Sizes0),
simplify_evidence(Deps0, Table0, Deps0, Sizes0, Table, Deps, Sizes).

150
CLPBN/clpbn/viterbi.yap Normal file
View File

@ -0,0 +1,150 @@
:- style_check(all).
:- module(viterbi, [viterbi/3]).
:- use_module(library(lists),
[nth/3]).
:- use_module(library('clpbn'), []).
:- use_module(library('clpbn/utils'), [
sort_vars_by_key/3]).
:- use_module(library('ugraphs'), [
vertices_edges_to_ugraph/3,
add_edges/3,
top_sort/3]).
:- attribute prob/1, emission/1, backp/1.
viterbi(Start,End,Trace) :-
attributes:all_attvars(Vars0),
sort_vars_by_key(Vars0,Vars,_),
add_emissions(Vars),
topsort_vars(Vars,SortedVars),
init_viterbi(Start),
viterbi_alg(SortedVars),
backtrace(Start,End,[],Trace).
add_emissions([]).
add_emissions([Var|Vars]) :-
add_emission(Var),
add_emissions(Vars).
add_emission(Var) :-
clpbn:get_atts(Var,[evidence(Ev),dist(Vals,emission(CPT),Parents)]), !,
nth(Nth, Vals, Ev),
find_probs(CPT,Nth,Prob),
adde2pars(Parents,Prob).
add_emission(_).
find_probs(log(Logs,_Norms),Nth,Log) :-
arg(Nth,Logs,Log).
% get_norm(Norms,Nth,Norm).
%get_norm(Norms,_,Norms) :- number(Norms), !.
%get_norm(Norms,Nth,Norm) :-
% arg(Nth,Norms,Norm).
adde2pars([],_).
adde2pars([V|Vs],P) :-
put_atts(V,[emission(P)]),
adde2pars(Vs,P).
topsort_vars(Vars,SortedVars) :-
vertices_edges_to_ugraph([],[],Graph0),
sort_vars(Vars, Graph0, SortedVars).
%
% take advantage of the fact that variables can be split by timestamp.
%
sort_vars(Vars, Graph0, SortedVars) :-
fetch_times(Vars,T0Vars),
keysort(T0Vars, TVars),
sort_times(TVars, Graph0, SortedVars).
fetch_times([], []).
fetch_times([V|Vs], [T-V|TVs]) :-
clpbn:get_atts(V,[key(K)]),
arg(1,K,T),
fetch_times(Vs, TVs).
sort_times([], _, []).
sort_times([T-V|TVs], Graph0, SortedVars) :-
fetch_same_time(TVs, T, Vars, NTVs),
fetch_parents([V|Vars],Graph0,Graph),
top_sort(Graph,SortedVars0,SortedVars),
sort_times(NTVs, Graph0, SortedVars0).
fetch_same_time([T-V|TVs], T, [V|Vs], TVs0) :-
fetch_same_time(TVs, T, Vs, TVs0).
fetch_same_time(TVs, _, [], TVs) :- !.
fetch_parents([],Graph,Graph).
fetch_parents([V|Vars],Graph0,GraphF) :-
clpbn:get_atts(V,[dist(_,_,Parents)]),
exp_edges(Parents,V,Graph0,GraphI),
fetch_parents(Vars,GraphI,GraphF).
exp_edges([],_,Graph,Graph).
exp_edges([P|Parents],V,Graph0,GraphF) :-
add_edges(Graph0,[V-P],GraphI),
exp_edges(Parents,V,GraphI,GraphF).
extract_vars([],[]).
extract_vars([_-V|KVars],[V|Vars]) :-
extract_vars(KVars,Vars).
init_viterbi(V) :-
put_atts(V,[prob(0)]).
viterbi_alg([]).
viterbi_alg([V|Vs]) :-
% get the current status
get_atts(V,[prob(P0)]), !,
clpbn:get_atts(V,[dist(_,trans(Probs),States)]),
% adjust to consider emission probabilities
adjust_for_emission(V, P0, Pf),
propagate(Probs,States,Pf,V),
viterbi_alg(Vs).
viterbi_alg([_|Vs]) :-
viterbi_alg(Vs).
adjust_for_emission(V, P0, Pf) :-
get_atts(V,[emission(P)]), !,
mprob(P0,P,Pf),
put_atts(V,[prob(Pf)]).
adjust_for_emission(_, P, P).
propagate([],[],_,_).
propagate([log(Prob,_)|Probs],[State|States],Pf,V) :-
get_atts(State,[prob(P0)]), !,
mprob(Pf,Prob,P),
(P > P0 ->
put_atts(State,[prob(P),backp(V)])
;
true
),
propagate(Probs,States,Pf,V).
propagate([log(Prob,_)|Probs],[State|States],Pf,V) :-
mprob(Pf,Prob,P),
put_atts(State,[prob(P),backp(V)]),
propagate(Probs,States,Pf,V).
backtrace(Start,Var,Trace,Trace) :- Start == Var, !.
backtrace(Start,Var,Trace0,Trace) :-
get_atts(Var,[backp(V)]),
clpbn:get_atts(Var, [key(K)]),
backtrace(Start,V,[K|Trace0],Trace).
mprob(*,P,P) :- !.
mprob(P,*,P) :- !.
mprob(P1,P2,P) :- P is P1+P2.