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

236 lines
6.1 KiB
Plaintext
Raw Normal View History

%:- style_check(all).
:- module(viterbi, [viterbi/4]).
:- use_module(library(lists),
[nth/3,
member/2]).
:- use_module(library(assoc)).
:- use_module(library(dgraphs)).
:- use_module(library(matrix)).
:- use_module(library(clpbn), []).
:- ensure_loaded(library('clpbn/hmm')).
:- use_module(library('clpbn/dists'), [
get_dist_params/2]).
:- meta_predicate viterbi(:,:,+,-).
viterbi(Start,End,String,Trace) :-
init_hmm,
Start,
mk_graph(NOfNodes, Map, ViterbiCode),
compile_trace(String, Emissions),
get_id(Start, Map, SI),
get_id(End, Map, EI),
% add a random symbol in front (for the c/1 state).
compiled_viterbi(NOfNodes, SI, ViterbiCode, Emissions, Dump, L),
backtrace(Dump, EI, Map, L, Trace).
state_from_goal(_:Start,S) :-
state_from_goal(Start,S).
state_from_goal(Start,S) :-
functor(Start, N, Ar),
% get rid of position and random var
NAr is Ar-2,
functor(S, N, NAr).
mk_graph(NOfNodes, Map, ViterbiCode) :-
attributes:all_attvars(Vars0),
empty_assoc(KeyMap0),
get_graph(Vars0, Nodes, Edges, KeyMap0, KeyMap),
dgraph_new(G0),
dgraph_add_vertices(G0, Nodes, G1),
dgraph_add_edges(G1, Edges, G2),
dgraph_top_sort(G2, SortedNodes),
compile_viterbi(SortedNodes, KeyMap, NOfNodes, Map, ViterbiCode).
get_graph([V|Vs], [NKey|Keys], EdgesF, KeyMap0, KeyMap) :-
clpbn:get_atts(V,[key(Key), dist(Id,Parents)]),
( Key =.. [N,2|More] ; Key = s(0), N=s, More=[] ), !,
NKey =.. [N|More],
fetch_edges(Parents, NKey, EdgesF, Edges0, PKeys),
get_emission(V, Key, EmissionProb),
put_assoc(NKey,KeyMap0,nodeinfo(_,Id,EmissionProb,PKeys),KeyMapI),
get_graph(Vs, Keys, Edges0, KeyMapI, KeyMap).
get_graph([_|Vs], Keys, Edges, KeyMap0, KeyMap) :-
get_graph(Vs, Keys, Edges, KeyMap0, KeyMap).
get_graph([], [], [], KeyMap, KeyMap).
get_emission(V, Key, EmissionProbs) :-
hmm:get_atts(V,[emission(_)]), !,
user:emission_cpt(Key, EmissionProbs).
get_emission(_, _, []).
fetch_edges([V|Parents], Key0, EdgesF, Edges0, [Slice-AKey|PKeys]) :-
var(V), !,
clpbn:get_atts(V,[key(Key)]),
abstract_key(Key, AKey, Slice),
(
Slice < 3
->
EdgesF = [Key0-AKey|EdgesI]
;
EdgesF = EdgesI
),
fetch_edges(Parents, Key0, EdgesI, Edges0, PKeys).
fetch_edges([Key|Parents], Key0, EdgesF, Edges0, [Slice-AKey|PKeys]) :-
abstract_key(Key, AKey, Slice),
(
Slice < 3
->
EdgesF = [Key0-AKey|EdgesI]
;
EdgesF = EdgesI
),
fetch_edges(Parents, Key0, EdgesI, Edges0, PKeys).
fetch_edges([], _, Edges, Edges, []).
abstract_key(Key, NKey, Slice) :-
Key =.. [N,Slice|More],
NKey =.. [N|More].
compile_viterbi(Keys, KeyMap, Nodes, Map, ViterbiCode) :-
enum_keys(Keys, KeyMap, 0, Nodes, Map),
compile_keys(Keys, KeyMap, ViterbiCode).
% just enumerate keys
enum_keys([], _, I, I, []).
enum_keys([Key|Keys], KeyMap, I0, Nodes, [I0-Key|Map]) :-
get_assoc(Key,KeyMap,nodeinfo(I0,_,_,_)),
I is I0+1,
enum_keys(Keys, KeyMap, I, Nodes, Map).
compile_keys([Key|Keys], KeyMap, ViterbiCodeF) :-
get_assoc(Key,KeyMap,nodeinfo(IKey,Id,Emission,PKeys)),
compile_emission(Emission,IKey,ViterbiCodeF,ViterbiCodeI),
get_dist_params(Id,Probs),
compile_propagation(PKeys,Probs,IKey,KeyMap,ViterbiCodeI,ViterbiCode0),
compile_keys(Keys, KeyMap, ViterbiCode0).
compile_keys([], _, []).
% add a random symbol to the end.
compile_emission([],_) --> !, [].
compile_emission(EmissionTerm,IKey) --> [emit(IKey,EmissionTerm)].
compile_propagation([],[],_,_) --> [].
compile_propagation([0-PKey|Ps], [Prob|Probs], IKey, KeyMap) -->
[prop_same(IKey,Parent,Prob)],
{ get_assoc(PKey,KeyMap,nodeinfo(Parent,_,_,_)) },
compile_propagation(Ps, Probs, IKey, KeyMap).
compile_propagation([2-PKey|Ps], [Prob|Probs], IKey, KeyMap) -->
[prop_same(IKey,Parent,Prob)],
{ get_assoc(PKey,KeyMap,nodeinfo(Parent,_,_,_)) },
compile_propagation(Ps, Probs, IKey, KeyMap).
compile_propagation([3-PKey|Ps], [Prob|Probs], IKey, KeyMap) -->
[prop_next(IKey,Parent,Prob)],
{ get_assoc(PKey,KeyMap,nodeinfo(Parent,_,_,_)) },
compile_propagation(Ps, Probs, IKey, KeyMap).
get_id(_:S, Map, SI) :- !,
get_id(S, Map, SI).
get_id(S, Map, SI) :-
functor(S,N,A),
A2 is A-2,
functor(S2,N,A2),
once(member(SI-S2,Map)).
compile_trace(Trace, Emissions) :-
user:hmm_domain(Domain),
(atom(Domain) ->
hmm:cvt_vals(Domain, Vals)
;
Vals = Domain
),
compile_trace(Trace, Vals, Emissions).
compile_trace([], _, []).
compile_trace([El|Trace], Vals, [N|Emissions]) :-
once(nth(N, Vals, El)),
compile_trace(Trace, Vals, Emissions).
compiled_viterbi(Nodes, S, Commands, Input, Trace, L) :-
length(Input,L),
prolog_flag(min_tagged_integer, Min),
matrix_new_set(ints,[Nodes], Min, Current),
matrix_new_set(ints,[Nodes], Min, Next),
L1 is L+1,
matrix_new(ints,[L1,Nodes], Trace),
matrix_set(Current, [S], 0),
run_commands(Input, Commands, 0, Current, Next, Trace, Min).
run_commands([], _, _, _, _, _, _).
run_commands([E|Input], Commands, I, Current, Next, Trace, Min) :-
run_code(Commands, E, I, Current, Next, Trace),
matrix_get(Current, [32], M10),
matrix_get(Current, [34], C),
matrix_set_all(Current,Min),
I1 is I+1,
run_commands(Input, Commands, I1, Next, Current, Trace, Min).
run_code([], _, _, _, _, Trace).
run_code([Inst|Input], E, I, Current, Next, Trace) :-
run_inst(Inst, E, I, Current, Next, Trace) ,
run_code(Input, E, I, Current, Next, Trace).
run_inst(emit(Id,T), E, _SP, Current, _, Trace) :-
arg(E,T,P),
matrix_add(Current, [Id], P).
run_inst(prop_same(I,P,Prob), _, SP, Current, _, Trace) :-
matrix_get(Current, [I], PI),
NP is PI+Prob,
matrix_get(Current, [P], P0),
(NP > P0 ->
matrix_set(Current, [P], NP),
matrix_set(Trace, [SP,P], I)
;
true
).
run_inst(prop_next(I,P,Prob), _, SP, Current, Next, Trace) :-
matrix_get(Current, [I], PI),
NP is PI+Prob,
matrix_get(Next, [P], P0),
(NP > P0 ->
matrix_set(Next, [P], NP),
SP1 is SP+1,
IN is -I,
matrix_set(Trace, [SP1,P], IN)
;
true
).
backtrace(Dump, EI, Map, L, Trace) :-
L1 is L-1,
Pos = [L1,EI],
matrix_get(Dump,Pos,Next),
trace(L1,Next,Dump,Map,[],Trace).
trace(0,0,_,_,Trace,Trace) :- !.
trace(L1,Next,Dump,Map,Trace0,Trace) :-
(Next < 0 ->
NL is L1-1,
P is -Next
;
NL = L1,
P = Next
),
once(member(P-AKey,Map)),
AKey=..[N|Args],
Key=..[N,NL|Args],
matrix_get(Dump,[NL,P],New),
trace(NL,New,Dump,Map,[Key|Trace0],Trace).