preliminary support for viterbi algorithm and HMMs

some code cleanups


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1363 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

CLPBN/Makefile.in

@@ -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=

CLPBN/clpbn.yap

@@ -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) :-

CLPBN/clpbn/gibbs.yap

@@ -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).

CLPBN/clpbn/topsort.yap

@@ -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).
+

CLPBN/clpbn/utils.yap

@@ -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]).
+

CLPBN/clpbn/vel.yap

@@ -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).

CLPBN/clpbn/viterbi.yap

@@ -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.
+
+
+