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

new version of viterbi implementation

Browse Source 
fix all:atvars reporting bad info
fix bad S info in x86_64


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1968 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2007-10-28 00:54:09 +00:00
parent b6b281684d
commit 9e9c260f7e
11 changed files with 469 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
C/absmi.c
View File

@ -10,8 +10,11 @@
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2007-10-17 09:18:26 $,$Author: vsc $ *
* Last rev: $Date: 2007-10-28 00:54:09 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.225 2007/10/17 09:18:26 vsc
* growtrail assumed SREG meant ASP?
*
* Revision 1.224 2007/09/24 09:02:31 vsc
* minor bug fixes
*
@ -7355,6 +7358,9 @@ Yap_absmi(int inp)
saveregs();
d0 = (f)();
setregs();
#if SHADOW_S
SREG = Yap_REGS.S_;
#endif
if (!d0) {
FAIL();
}

21
C/attvar.c
View File

@ -418,16 +418,21 @@ AllAttVars(attvar_record *attv) {
return 0L;
}
if (IsVarTerm(attv->Done) && IsUnboundVar(&attv->Done)) {
if (IsVarTerm(attv->Atts) && VarOfTerm(attv->Atts) < (CELL *)attv) {
/* skip call residue(s) */
attv = (attvar_record *)(attv->Atts);
} else {
if (H != h0) {
H[-1] = AbsPair(H);
if (IsVarTerm(attv->Atts)) {
if (VarOfTerm(attv->Atts) < (CELL *)attv) {
/* skip call residue(s) */
attv = (attvar_record *)(attv->Atts);
continue;
} else if (IsUnboundVar(&attv->Atts)) {
/* ignore arena */
continue;
}
H[0] = (CELL)attv;
H += 2;
}
if (H != h0) {
H[-1] = AbsPair(H);
}
H[0] = (CELL)attv;
H += 2;
}
}
if (H != h0) {

59
C/c_interface.c
View File

@ -10,8 +10,11 @@
* File: c_interface.c *
* comments: c_interface primitives definition *
* *
* Last rev: $Date: 2007-10-16 18:57:17 $,$Author: vsc $ *
* Last rev: $Date: 2007-10-28 00:54:09 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.99 2007/10/16 18:57:17 vsc
* get rid of debug statement.
*
* Revision 1.98 2007/10/15 23:48:46 vsc
* unset var
*
@ -412,6 +415,38 @@ static int do_yap_putc(int streamno,wchar_t ch) {
return(ch);
}
static int
dogc(void)
{
UInt arity;
if (P && PREVOP(P,sla)->opc == Yap_opcode(_call_usercpred)) {
arity = PREVOP(P,sla)->u.sla.sla_u.p->ArityOfPE;
} else {
arity = 0;
}
if (!Yap_gc(arity, ENV, CP)) {
return FALSE;
}
return TRUE;
}
static int
doexpand(UInt sz)
{
UInt arity;
if (P && PREVOP(P,sla)->opc == Yap_opcode(_call_usercpred)) {
arity = PREVOP(P,sla)->u.sla.sla_u.p->ArityOfPE;
} else {
arity = 0;
}
if (!Yap_gcl(sz, arity, ENV, CP)) {
return FALSE;
}
return TRUE;
}
X_API Term
YAP_A(int i)
{
@ -539,8 +574,10 @@ YAP_MkBlobTerm(unsigned int sz)
BACKUP_H();
I = AbsAppl(H);
if (H+(sz+sizeof(MP_INT)/sizeof(CELL)+2) > ASP-1024)
return TermNil;
while (H+(sz+sizeof(MP_INT)/sizeof(CELL)+2) > ASP-1024) {
if (!doexpand((sz+sizeof(MP_INT)/sizeof(CELL)+2)*sizeof(CELL)))
return TermNil;
}
H[0] = (CELL)FunctorBigInt;
dst = (MP_INT *)(H+1);
dst->_mp_size = 0L;
@ -1103,22 +1140,6 @@ YAP_BufferToString(char *s)
return t;
}
static int
dogc(void)
{
UInt arity;
if (P && PREVOP(P,sla)->opc == Yap_opcode(_call_usercpred)) {
arity = PREVOP(P,sla)->u.sla.sla_u.p->ArityOfPE;
} else {
arity = 0;
}
if (!Yap_gc(arity, ENV, CP)) {
return FALSE;
}
return TRUE;
}
/* copy a string to a buffer */
X_API Term
YAP_ReadBuffer(char *s, Term *tp)

156
C/globals.c
View File

@ -912,6 +912,64 @@ CopyTermToArena(Term t, Term arena, int share, UInt arity, Term *newarena, Term
goto restart;
}
static Term
CreateTermInArena(Term arena, Atom Na, UInt Nar, UInt arity, Term *newarena, Term init)
{
UInt old_size = ArenaSz(arena);
CELL *oldH = H;
CELL *oldHB = HB;
CELL *oldASP = ASP;
Term tf;
CELL *HB0;
Functor f = Yap_MkFunctor(Na, Nar);
UInt i;
restart:
H = HB = ArenaPt(arena);
ASP = ArenaLimit(arena);
HB0 = H;
tf = AbsAppl(H);
H[0] = (CELL)f;
H += 1+ArityOfFunctor(f);
if (H > ASP-128) {
/* overflow */
H = HB;
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
XREGS[arity+1] = arena;
XREGS[arity+2] = (CELL)newarena;
{
CELL *old_top = ArenaLimit(*newarena);
ASP = oldASP;
H = oldH;
HB = oldHB;
if (arena == GlobalArena)
GlobalArenaOverflows++;
if (!GrowArena(arena, old_top, old_size, Nar*sizeof(CELL), arity+2)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, "while creating large global term");
return 0L;
}
}
oldH = H;
oldHB = HB;
oldASP = ASP;
newarena = (CELL *)XREGS[arity+2];
arena = Deref(XREGS[arity+1]);
old_size = ArenaSz(arena);
goto restart;
}
if (init == 0L) {
for (i=1; i<=Nar; i++) {
RESET_VARIABLE(HB0+i);
}
} else {
for (i=1; i<=Nar; i++) {
HB0[i] = init;
}
}
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
return tf;
}
inline static GlobalEntry *
FindGlobalEntry(Atom at)
/* get predicate entry for ap/arity; create it if neccessary. */
@ -1108,10 +1166,10 @@ p_nb_linkval(void)
Term t = Deref(ARG1), to;
GlobalEntry *ge;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"nb_setval");
Yap_Error(INSTANTIATION_ERROR,t,"nb_linkval");
return (TermNil);
} else if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM,t,"nb_setval");
Yap_Error(TYPE_ERROR_ATOM,t,"nb_linkval");
return (FALSE);
}
ge = GetGlobalEntry(AtomOfTerm(t));
@ -1264,6 +1322,98 @@ p_nb_delete(void)
return TRUE;
}
static Int
p_nb_create(void)
{
Term t = Deref(ARG1);
Term tname = Deref(ARG2);
Term tarity = Deref(ARG3);
Term to;
GlobalEntry *ge;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"nb_create");
return FALSE;
} else if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM,t,"nb_create");
return FALSE;
}
ge = GetGlobalEntry(AtomOfTerm(t));
if (!ge)
return FALSE;
if (IsVarTerm(tarity)) {
Yap_Error(INSTANTIATION_ERROR,tarity,"nb_create");
return FALSE;
} else if (!IsIntegerTerm(tarity)) {
Yap_Error(TYPE_ERROR_INTEGER,tarity,"nb_create");
return FALSE;
}
if (IsVarTerm(tname)) {
Yap_Error(INSTANTIATION_ERROR,tname,"nb_create");
return FALSE;
} else if (!IsAtomTerm(tname)) {
Yap_Error(TYPE_ERROR_ATOM,tname,"nb_create");
return FALSE;
}
to = CreateTermInArena(GlobalArena, AtomOfTerm(tname), IntegerOfTerm(tarity), 3, &GlobalArena, 0L);
if (!to)
return FALSE;
WRITE_LOCK(ge->GRWLock);
ge->global=to;
WRITE_UNLOCK(ge->GRWLock);
return TRUE;
}
static Int
p_nb_create2(void)
{
Term t = Deref(ARG1);
Term tname = Deref(ARG2);
Term tarity = Deref(ARG3);
Term tinit = Deref(ARG4);
Term to;
GlobalEntry *ge;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"nb_create");
return FALSE;
} else if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM,t,"nb_create");
return FALSE;
}
ge = GetGlobalEntry(AtomOfTerm(t));
if (!ge)
return FALSE;
if (IsVarTerm(tarity)) {
Yap_Error(INSTANTIATION_ERROR,tarity,"nb_create");
return FALSE;
} else if (!IsIntegerTerm(tarity)) {
Yap_Error(TYPE_ERROR_INTEGER,tarity,"nb_create");
return FALSE;
}
if (IsVarTerm(tname)) {
Yap_Error(INSTANTIATION_ERROR,tname,"nb_create");
return FALSE;
} else if (!IsAtomTerm(tname)) {
Yap_Error(TYPE_ERROR_ATOM,tname,"nb_create");
return FALSE;
}
if (IsVarTerm(tinit)) {
Yap_Error(INSTANTIATION_ERROR,tname,"nb_create");
return FALSE;
} else if (!IsAtomTerm(tinit)) {
Yap_Error(TYPE_ERROR_ATOM,tname,"nb_create");
return FALSE;
}
to = CreateTermInArena(GlobalArena, AtomOfTerm(tname), IntegerOfTerm(tarity), 4, &GlobalArena, tinit);
if (!to)
return FALSE;
WRITE_LOCK(ge->GRWLock);
ge->global=to;
WRITE_UNLOCK(ge->GRWLock);
return TRUE;
}
/* a non-backtrackable queue is a term of the form $array(Arena,Start,End,Size) plus an Arena. */
static Int
@ -2403,6 +2553,8 @@ void Yap_InitGlobals(void)
Yap_InitCPred("nb_set_shared_arg", 3, p_nb_set_shared_arg, 0L);
Yap_InitCPred("nb_linkarg", 3, p_nb_linkarg, 0L);
Yap_InitCPred("nb_delete", 1, p_nb_delete, 0L);
Yap_InitCPred("nb_create", 3, p_nb_create, 0L);
Yap_InitCPred("nb_create", 4, p_nb_create2, 0L);
Yap_InitCPredBack("$nb_current", 1, 1, init_current_nb, cont_current_nb, SafePredFlag);
CurrentModule = GLOBALS_MODULE;
Yap_InitCPred("nb_queue", 1, p_nb_queue, 0L);

2
C/tracer.c
View File

@ -58,7 +58,7 @@ send_tracer_message(char *start, char *name, Int arity, char *mname, CELL *args)
if (i > 0) fprintf(Yap_stderr, ",");
#if DEBUG
#if COROUTINING
/* Yap_Portray_delays = TRUE; */
Yap_Portray_delays = TRUE;
#endif
#endif
omax_depth = max_depth;

1
CLPBN/clpbn/examples/School/evidence_128.yap
View File

@ -7,6 +7,7 @@ professor_popularity(p5,l) :- {}.
professor_popularity(p45,h) :- {}.
professor_popularity(p15,m) :- {}.
:- start_low_level_trace.
course_rating(c0, h) :- {}.
course_rating(c1, m) :- {}.
course_rating(c2, l) :- {}.

54
CLPBN/clpbn/hmm.yap
View File

@ -2,13 +2,21 @@
:- module(hmm, [init_hmm/0,
hmm_state/1,
emission/4]).
emission/1]).
:- ensure_loaded(library(clpbn)).
:- use_module(library(lists),
[nth/3]).
:- use_module(library(nbhash),
[nb_hash_new/2,
nb_hash_lookup/3,
nb_hash_insert/3
]).
:- ensure_loaded(library(tries)).
:- meta_predicate hmm_state(:).
:- dynamic hmm_tabled/1.
@ -18,7 +26,10 @@
:- ensure_loaded(library('clpbn/viterbi')).
init_hmm :-
retractall(hmm_tabled(_)).
% retractall(hmm_tabled(_)).
% eraseall(hmm_tabled).
% nb_hash_new(hmm_table, 1000000).
trie_open(Trie), nb_setval(trie,Trie).
hmm_state(Mod:A) :- !, hmm_state(A,Mod).
hmm_state(A) :- prolog_flag(typein_module,Mod), hmm_state(A,Mod).
@ -31,40 +42,35 @@ hmm_state((A,B),Mod) :- !,
hmm_state(N/A,Mod) :-
atom_codes(N,[TC|_]),
atom_codes(T,[TC]),
build_args(A,LArgs,KArgs,Last),
build_args(A,LArgs,KArgs,First,Last),
Key =.. [T|KArgs],
Head =.. [N|LArgs],
asserta_static( Mod:(Head :-
(
hmm:hmm_tabled(Key)
asserta_static( (Mod:Head :-
( First > 2 ->
Last = Key, !
;
% hmm:hmm_tabled(Key)
% nb_hash:nb_hash_lookup(hmm_table, Key, [])
nb_getval(trie, Trie), trie_check_entry(Trie, Key, _)
->
% leave work for solver!
%
%format(' ~w~n',[Key]),
Last = Key, !
% clpbn:put_atts(Last,[key(Key)]), !
;
% first time we saw this entry
%format('+~w~n',[Key]),
%write(Key),nl,
%(Key = d(30,46) -> start_low_level_trace ; stop_low_level_trace),
assert(hmm:hmm_tabled(Key)), fail
)
% assert(hmm:hmm_tabled(Key)),
% nb_hash:nb_hash_insert(hmm_table,Key,[]),
nb_getval(trie, Trie), trie_put_entry(Trie, Key, _),
fail
)
)
).
build_args(3,[A,B,C],[A,B],C).
build_args(2,[A,B],[A],B).
build_args(4,[A,B,C,D],[A,B,C],A,D).
build_args(3, [A,B,C], [A,B],A,C).
build_args(2, [A,B], [A],A,B).
find_var(Key,Last) :-
array_element(hmm_tree,1,Tree),
lookup(Key, Tree, Last).
emission(Vals,CPT,Ev,V) :-
cvt_vals(Vals,LVals),
once(nth(Nth, LVals, Ev)),
find_probs(CPT,Nth,Prob),
emission(V) :-
put_atts(V,[emission(Prob)]).
cvt_vals(aminoacids,[a, c, d, e, f, g, h, i, k, l, m, n, p, q, r, s, t, v, w, y]).

342
CLPBN/clpbn/viterbi.yap
View File

@ -1,149 +1,235 @@
%:- style_check(all).
:- module(viterbi, [viterbi/5]).
:- module(viterbi, [viterbi/4]).
:- use_module(library(lists),
[nth/3]).
[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]).
:- attribute prob/1, emission/1, backp/1, ancestors/1.
:- meta_predicate viterbi(:,:,+,-).
viterbi(Start,End,Trace,Ticks,Slices) :-
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),
group_vars_by_key_and_parents(Vars0,Ticks,Slices),
init_viterbi(Start),
viterbi_alg([Start|R],R),
backtrace(Start,End,[],Trace).
empty_assoc(KeyMap0),
get_graph(Vars0, Nodes, Edges, KeyMap0, KeyMap),
dgraph_new(G0),
dgraph_add_vertices(Nodes, G0, G1),
dgraph_add_edges(Edges, G1, G2),
dgraph_top_sort(G2, SortedNodes),
compile_viterbi(SortedNodes, KeyMap, NOfNodes, Map, ViterbiCode).
group_vars_by_key_and_parents(AVars, NTicks, Slices) :-
NTicks1 is NTicks+2,
functor(Hashes,slots,NTicks1),
NSlices is Slices+2,
build_slices(0,NTicks1,NSlices,Hashes),
get_keys(AVars, Hashes),
get_parents(AVars, Hashes).
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).
build_slices(NTicks,NTicks,_,_) :- !.
build_slices(I0,NTicks,NSlices,Hashes) :-
functor(Slice,slices,NSlices),
I is I0+1,
arg(I,Hashes,Slice),
build_slices(I,NTicks,NSlices,Hashes).
get_emission(V, Key, EmissionProbs) :-
hmm:get_atts(V,[emission(_)]), !,
user:emission_cpt(Key, EmissionProbs).
get_emission(_, _, []).
get_keys([], _).
get_keys([V|AVars], Trees) :-
clpbn:get_atts(V, [key(K)]), !,
arg(1,K,Time0),
Time is Time0+1,
arg(Time, Trees, Tree),
make_key(K, TKey),
arg(TKey, Tree, List),
lookup(List, K, V),
get_keys(AVars, Trees).
get_keys([_|AVars], Trees) :- % may be non-CLPBN vars.
get_keys(AVars, Trees).
get_parents([], _).
get_parents([V|AVars], Trees) :-
clpbn:get_atts(V, [dist(Id,Parents)]), !,
%clpbn:get_atts(V, [key(K)]), format('~w (~w): ~w~n',[V,K,Parents]),
add_parents(Parents,V,Id,Trees),
get_parents(AVars, Trees).
get_parents([_|AVars], Trees) :- % may be non-CLPBN vars.
get_parents(AVars, Trees).
add_parents(Parents,V,Id,Trees) :-
transform_parents(Parents,NParents,Copy,Trees),
( var(Copy) -> true ; clpbn:put_atts(V, [dist(Id,NParents)]) ).
transform_parents([],[],_,_).
transform_parents([P|Parents0],[P|NParents],Copy,Trees) :-
var(P), !,
inc_ancestors(P),
transform_parents(Parents0,NParents,Copy,Trees).
transform_parents([P|Parents0],[V|NParents],copy,Trees) :-
arg(1,P,Time0),
Time is Time0+1,
arg(Time, Trees, Tree),
make_key(P, TKey),
arg(TKey, Tree, List),
lookup(List, P, V),
inc_ancestors(V),
transform_parents(Parents0,NParents,copy,Trees).
inc_ancestors(P) :-
get_atts(P,[ancestors(N)]), !,
N1 is N+1,
%format(' ~w->~d:~n',[P,N1]),
put_atts(P,[ancestors(N1)]).
inc_ancestors(P) :-
%format(' ~w->1:~n',[P]),
put_atts(P,[ancestors(1)]).
make_key(T,K) :-
arg(2,T,I), !,
K is I+2.
make_key(_,1).
lookup(Tree, K, V) :- var(Tree), !,
Tree = [[K|V]|_].
lookup([[K1|V]|_],K2,V) :- K1 == K2, !.
lookup([_|List],K,V) :-
lookup(List,K,V).
init_viterbi(V) :-
put_atts(V,[prob(0)]).
viterbi_alg(L0, Lf) :- L0 == Lf, !.
viterbi_alg([V|Vs], Rs) :-
% format('<< ~w~n',[V]),
% get the current status
get_atts(V,[prob(P0)]), !,
clpbn:get_atts(V,[dist(Id,States)]),
get_dist_params(Id,Probs),
% adjust to consider emission probabilities
adjust_for_emission(V, P0, Pf),
propagate(Probs,States,Pf,V,Rs,NRs),
viterbi_alg(Vs,NRs).
adjust_for_emission(V, P0, Pf) :-
hmm:get_atts(V,[emission(P)]), !,
Pf is P+P0,
put_atts(V,[prob(Pf)]).
adjust_for_emission(_, P, P).
propagate([],[],_,_,Rs,Rs).
propagate([Prob|Probs],[State|States],Pf,V,Rs,Rs0) :-
%format(' ~w~n',[State]),
get_atts(State,[prob(P0),ancestors(N)]), !,
mprob(Pf,Prob,P),
N1 is N-1,
(P > P0 ->
put_atts(State,[prob(P),backp(V),ancestors(N1)])
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]
;
put_atts(State,[ancestors(N1)])
EdgesF = EdgesI
),
(N1 == 0 -> Rs = [State|NRs] ; Rs = NRs),
propagate(Probs,States,Pf,V,NRs,Rs0).
propagate([Prob|Probs],[State|States],Pf,V,Rs,Rs0) :-
get_atts(State,[ancestors(N)]), !,
N1 is N-1,
mprob(Pf,Prob,P),
put_atts(State,[prob(P),backp(V),ancestors(N1)]),
(N1 == 0 -> Rs = [State|NRs] ; Rs = NRs),
propagate(Probs,States,Pf,V,NRs,Rs0).
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, []).
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).
abstract_key(Key, NKey, Slice) :-
Key =.. [N,Slice|More],
NKey =.. [N|More].
mprob(P0,P1,Pf) :- Pf is P0+P1.
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).

9
H/absmi.h
View File

@ -87,6 +87,7 @@ register struct yami* P1REG asm ("bp"); /* can't use yamop before Yap.h */
#define SHADOW_P 1
#define SHADOW_REGS 1
#define SHADOW_S 1
#define S_IN_MEM 1
#define Y_IN_MEM 1
#define TR_IN_MEM 1
#endif /* __x86_64__ */
@ -628,10 +629,10 @@ typedef CELL label;
set_pc(); \
set_y()
#define saveregs() \
save_hb(); \
save_cp(); \
save_pc(); \
#define saveregs() \
save_hb(); \
save_cp(); \
save_pc(); \
save_y()
#if BP_FREE

4
docs/yap.tex
View File

@ -8041,8 +8041,8 @@ True when @var{Numbers} is a list of numbers, and @var{Min} is the minimum.
@end table
@node matrix, MATLAB, Lists, Library
@section MATLAB Package Interface
@cindex Matlab Interface
@section Matrix Library
@cindex Matrix Library
This package provides a fast implementation of multi-dimensional
matrices of integers and floats. In contrast to dynamic arrays, these

4
library/matrix.yap
View File

@ -74,10 +74,10 @@ typedef enum {
matrix_new(ints,Dims,Matrix) :-
length(Dims,NDims),
new_ints_matrix(NDims, Dims, [], Matrix).
new_ints_matrix_set(NDims, Dims, 0, Matrix).
matrix_new(floats,Dims,Matrix) :-
length(Dims,NDims),
new_float_matrix(NDims, Dims, [], Matrix).
new_float_matrix_set(NDims, Dims, 0.0, Matrix).
matrix_new(ints,Dims,Data,Matrix) :-