new version of viterbi implementation

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

C/absmi.c

@@ -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();
       }

C/attvar.c

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

C/c_interface.c

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

C/globals.c

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

C/tracer.c

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

CLPBN/clpbn/examples/School/evidence_128.yap

@@ -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) :- {}.

CLPBN/clpbn/hmm.yap

@@ -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 :-
+	asserta_static( (Mod:Head :-
-		(
+	        ( First > 2 -> 
-		  hmm:hmm_tabled(Key)
+		  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]),
+%		  assert(hmm:hmm_tabled(Key)),
-%write(Key),nl,
+%		  nb_hash:nb_hash_insert(hmm_table,Key,[]),
-%(Key = d(30,46) -> start_low_level_trace ; stop_low_level_trace),
+		  nb_getval(trie, Trie), trie_put_entry(Trie, Key, _),
-		  assert(hmm:hmm_tabled(Key)), fail
+		  fail
 		)
 	      )
 	      ).
 	
-build_args(3,[A,B,C],[A,B],C).
+build_args(4,[A,B,C,D],[A,B,C],A,D).
-build_args(2,[A,B],[A],B).
+build_args(3,  [A,B,C],  [A,B],A,C).
+build_args(2,    [A,B],    [A],A,B).
 
-find_var(Key,Last) :-
+emission(V) :-
-	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),
 	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]).

CLPBN/clpbn/viterbi.yap

@@ -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),
+	empty_assoc(KeyMap0),
-	init_viterbi(Start),
+	get_graph(Vars0, Nodes, Edges, KeyMap0, KeyMap),
-	viterbi_alg([Start|R],R),
+	dgraph_new(G0),
-	backtrace(Start,End,[],Trace).
+	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) :-
+get_graph([V|Vs], [NKey|Keys], EdgesF, KeyMap0, KeyMap) :-
-	NTicks1 is NTicks+2,
+	clpbn:get_atts(V,[key(Key), dist(Id,Parents)]),
-	functor(Hashes,slots,NTicks1),
+	( Key =.. [N,2|More] ; Key = s(0), N=s, More=[] ), !,
-	NSlices is Slices+2,
+	NKey =.. [N|More],
-	build_slices(0,NTicks1,NSlices,Hashes),
+	fetch_edges(Parents, NKey, EdgesF, Edges0, PKeys),
-	get_keys(AVars, Hashes),
+	get_emission(V, Key, EmissionProb),
-	get_parents(AVars, Hashes).
+	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,_,_) :- !.
+get_emission(V, Key, EmissionProbs) :-
-build_slices(I0,NTicks,NSlices,Hashes) :-
+	hmm:get_atts(V,[emission(_)]), !,
-	functor(Slice,slices,NSlices),
+	user:emission_cpt(Key, EmissionProbs).
-	I is I0+1,
+get_emission(_, _, []).
-	arg(I,Hashes,Slice),
-	build_slices(I,NTicks,NSlices,Hashes).
 
-get_keys([], _).
+fetch_edges([V|Parents], Key0, EdgesF, Edges0, [Slice-AKey|PKeys]) :-
-get_keys([V|AVars], Trees) :-
+	var(V), !,
-	clpbn:get_atts(V, [key(K)]), !,
+	clpbn:get_atts(V,[key(Key)]),
-	arg(1,K,Time0),
+	abstract_key(Key, AKey, Slice),
-	Time is Time0+1,
+	(
-	arg(Time, Trees, Tree),
+	 Slice < 3
-	make_key(K, TKey),
+	->
-	arg(TKey, Tree, List),
+	 EdgesF = [Key0-AKey|EdgesI]
-	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)])
 	;
-	    put_atts(State,[ancestors(N1)])
+	 EdgesF = EdgesI
 	),
-	(N1 == 0 -> Rs = [State|NRs] ; Rs = NRs),
+	fetch_edges(Parents, Key0, EdgesI, Edges0, PKeys).
-	propagate(Probs,States,Pf,V,NRs,Rs0).
+fetch_edges([Key|Parents], Key0, EdgesF, Edges0, [Slice-AKey|PKeys]) :-
-propagate([Prob|Probs],[State|States],Pf,V,Rs,Rs0) :-
+	abstract_key(Key, AKey, Slice),
-	get_atts(State,[ancestors(N)]), !,
+	(
-	N1 is N-1,
+	 Slice < 3
-	mprob(Pf,Prob,P),
+	->
-	put_atts(State,[prob(P),backp(V),ancestors(N1)]),
+	 EdgesF = [Key0-AKey|EdgesI]
-	(N1 == 0 -> Rs = [State|NRs] ; Rs = NRs),
+	;
-	propagate(Probs,States,Pf,V,NRs,Rs0).
+	 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).
+
 
-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(P0,P1,Pf) :- Pf is P0+P1.

H/absmi.h

@@ -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__ */

docs/yap.tex

@@ -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
+@section Matrix Library
-@cindex Matlab Interface
+@cindex Matrix Library
 
 This package provides a fast implementation of multi-dimensional
 matrices of integers and floats. In contrast to dynamic arrays, these

library/matrix.yap

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