fix debugger to do well nonsource predicates.
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1354 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
dda96dc613
commit
b8f1beec74
@ -10,8 +10,11 @@
|
||||
* *
|
||||
* File: absmi.c *
|
||||
* comments: Portable abstract machine interpreter *
|
||||
* Last rev: $Date: 2005-08-01 15:40:36 $,$Author: ricroc $ *
|
||||
* Last rev: $Date: 2005-08-02 03:09:48 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.171 2005/08/01 15:40:36 ricroc
|
||||
* TABLING NEW: better support for incomplete tabling
|
||||
*
|
||||
* Revision 1.170 2005/07/06 19:33:51 ricroc
|
||||
* TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure.
|
||||
*
|
||||
@ -12157,6 +12160,7 @@ Yap_absmi(int inp)
|
||||
#ifdef YAPOR
|
||||
SCH_check_requests();
|
||||
#endif /* YAPOR */
|
||||
CACHE_A1();
|
||||
ALWAYS_GONext();
|
||||
ALWAYS_END_PREFETCH();
|
||||
|
||||
@ -12170,7 +12174,6 @@ Yap_absmi(int inp)
|
||||
ARG4 = mod;
|
||||
else
|
||||
ARG4 = TermProlog;
|
||||
CACHE_A1();
|
||||
goto execute_end;
|
||||
ENDP(pt1);
|
||||
|
||||
|
||||
@ -11,8 +11,11 @@
|
||||
* File: amasm.c *
|
||||
* comments: abstract machine assembler *
|
||||
* *
|
||||
* Last rev: $Date: 2005-07-06 15:10:02 $ *
|
||||
* Last rev: $Date: 2005-08-02 03:09:49 $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.82 2005/07/06 15:10:02 vsc
|
||||
* improvements to compiler: merged instructions and fixes for ->
|
||||
*
|
||||
* Revision 1.81 2005/06/01 21:23:44 vsc
|
||||
* inline compare
|
||||
*
|
||||
@ -2465,6 +2468,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
|
||||
cl_u->sc.ClFlags = StaticMask;
|
||||
cl_u->sc.ClNext = NULL;
|
||||
cl_u->sc.ClSize = size;
|
||||
cl_u->sc.usc.ClPred = cip->CurrentPred;
|
||||
if (*clause_has_blobsp) {
|
||||
cl_u->sc.ClFlags |= HasBlobsMask;
|
||||
}
|
||||
|
||||
@ -11,8 +11,11 @@
|
||||
* File: cdmgr.c *
|
||||
* comments: Code manager *
|
||||
* *
|
||||
* Last rev: $Date: 2005-08-01 15:40:37 $,$Author: ricroc $ *
|
||||
* Last rev: $Date: 2005-08-02 03:09:49 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.166 2005/08/01 15:40:37 ricroc
|
||||
* TABLING NEW: better support for incomplete tabling
|
||||
*
|
||||
* Revision 1.165 2005/07/06 19:33:52 ricroc
|
||||
* TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure.
|
||||
*
|
||||
@ -4121,6 +4124,10 @@ fetch_next_static_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr
|
||||
} else {
|
||||
Term t;
|
||||
|
||||
if (!(pe->PredFlags & SourcePredFlag)) {
|
||||
rtn = Yap_MkStaticRefTerm(cl);
|
||||
return Yap_unify(tr, rtn);
|
||||
}
|
||||
while ((t = Yap_FetchTermFromDB(cl->usc.ClSource)) == 0L) {
|
||||
if (first_time) {
|
||||
if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
|
||||
|
||||
67
C/exec.c
67
C/exec.c
@ -30,7 +30,13 @@ STATIC_PROTO(Int p_execute0, (void));
|
||||
static Term
|
||||
cp_as_integer(choiceptr cp)
|
||||
{
|
||||
return(MkIntTerm(LCL0-(CELL *)cp));
|
||||
return(MkIntegerTerm(LCL0-(CELL *)cp));
|
||||
}
|
||||
|
||||
static choiceptr
|
||||
cp_from_integer(Term cpt)
|
||||
{
|
||||
return (choiceptr)(LCL0-(CELL *)IntegerOfTerm(cpt));
|
||||
}
|
||||
|
||||
Term
|
||||
@ -242,6 +248,64 @@ p_execute(void)
|
||||
return(do_execute(t, CurrentModule));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_execute_clause(void)
|
||||
{ /* '$execute_clause'(Goal) */
|
||||
Term t = Deref(ARG1);
|
||||
Term mod = Deref(ARG2);
|
||||
StaticClause *cl = Yap_ClauseFromTerm(Deref(ARG3));
|
||||
choiceptr cp = cp_from_integer(Deref(ARG4));
|
||||
unsigned int arity;
|
||||
Prop pe;
|
||||
|
||||
restart_exec:
|
||||
if (IsVarTerm(t)) {
|
||||
Yap_Error(INSTANTIATION_ERROR,ARG3,"call/1");
|
||||
return FALSE;
|
||||
} else if (IsAtomTerm(t)) {
|
||||
Atom a = AtomOfTerm(t);
|
||||
pe = PredPropByAtom(a, mod);
|
||||
} else if (IsApplTerm(t)) {
|
||||
register Functor f = FunctorOfTerm(t);
|
||||
register unsigned int i;
|
||||
register CELL *pt;
|
||||
|
||||
if (IsExtensionFunctor(f))
|
||||
return(FALSE);
|
||||
if (f == FunctorModule) {
|
||||
Term tmod = ArgOfTerm(1,t);
|
||||
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
|
||||
mod = tmod;
|
||||
t = ArgOfTerm(2,t);
|
||||
goto restart_exec;
|
||||
}
|
||||
}
|
||||
pe = PredPropByFunc(f, mod);
|
||||
arity = ArityOfFunctor(f);
|
||||
/* I cannot use the standard macro here because
|
||||
otherwise I would dereference the argument and
|
||||
might skip a svar */
|
||||
pt = RepAppl(t)+1;
|
||||
for (i = 1; i <= arity; ++i) {
|
||||
#if SBA
|
||||
Term d0 = *pt++;
|
||||
if (d0 == 0)
|
||||
XREGS[i] = (CELL)(pt-1);
|
||||
else
|
||||
XREGS[i] = d0;
|
||||
#else
|
||||
XREGS[i] = *pt++;
|
||||
#endif
|
||||
}
|
||||
} else {
|
||||
Yap_Error(TYPE_ERROR_CALLABLE,ARG3,"call/1");
|
||||
return FALSE;
|
||||
}
|
||||
/* N = arity; */
|
||||
/* call may not define new system predicates!! */
|
||||
return CallPredicate(RepPredProp(pe), cp, cl->ClCode);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_execute_in_mod(void)
|
||||
{ /* '$execute'(Goal) */
|
||||
@ -1580,6 +1644,7 @@ Yap_InitExecFs(void)
|
||||
#endif
|
||||
Yap_InitCPred("$execute0", 2, p_execute0, HiddenPredFlag);
|
||||
Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop, HiddenPredFlag);
|
||||
Yap_InitCPred("$execute_clause", 4, p_execute_clause, HiddenPredFlag);
|
||||
Yap_InitCPred("$save_current_choice_point", 1, p_save_cp, HiddenPredFlag);
|
||||
Yap_InitCPred("$pred_goal_expansion_on", 0, p_pred_goal_expansion_on, SafePredFlag|HiddenPredFlag);
|
||||
Yap_InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag|HiddenPredFlag);
|
||||
|
||||
17
C/index.c
17
C/index.c
@ -11,8 +11,11 @@
|
||||
* File: index.c *
|
||||
* comments: Indexing a Prolog predicate *
|
||||
* *
|
||||
* Last rev: $Date: 2005-08-01 15:40:37 $,$Author: ricroc $ *
|
||||
* Last rev: $Date: 2005-08-02 03:09:50 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.142 2005/08/01 15:40:37 ricroc
|
||||
* TABLING NEW: better support for incomplete tabling
|
||||
*
|
||||
* Revision 1.141 2005/07/19 16:54:20 rslopes
|
||||
* fix for older compilers...
|
||||
*
|
||||
@ -6528,9 +6531,15 @@ static_clause(yamop *ipc, PredEntry *ap)
|
||||
while ((c = ClauseCodeToStaticClause(p))) {
|
||||
UInt fls = c->ClFlags & ~HasBlobsMask;
|
||||
if (fls == StaticMask) {
|
||||
if ((char *)c->usc.ClSource < (char *)c+c->ClSize &&
|
||||
valid_instructions(ipc, c->ClCode))
|
||||
return c;
|
||||
if (ap->PredFlags & SourcePredFlag) {
|
||||
if ((char *)c->usc.ClSource < (char *)c+c->ClSize &&
|
||||
valid_instructions(ipc, c->ClCode))
|
||||
return c;
|
||||
} else {
|
||||
if (c->usc.ClPred == ap &&
|
||||
valid_instructions(ipc, c->ClCode))
|
||||
return c;
|
||||
}
|
||||
} else if (fls == (StaticMask|FactMask)) {
|
||||
if (c->usc.ClPred == ap &&
|
||||
valid_instructions(ipc,c->ClCode))
|
||||
|
||||
@ -26,7 +26,9 @@ cpt_min(Vars, Key, Els0, CPT) :-
|
||||
|
||||
build_avg_table(Vars, Domain, SDomain, _, p(Domain, CPT, Vars)) :-
|
||||
int_power(Vars, SDomain, 1, TabSize),
|
||||
TabSize =< 16, !,
|
||||
TabSize =< 16,
|
||||
/* case gmp is not there !! */
|
||||
TabSize > 0, !,
|
||||
average_cpt(Vars, Domain, CPT).
|
||||
build_avg_table(Vars, Domain, _, Key, p(Domain, CPT, [V1,V2])) :-
|
||||
length(Vars,L),
|
||||
|
||||
@ -81,7 +81,7 @@ reorder_CPT(Vs0, T0, Vs, TF, Sizes) :-
|
||||
reorder_CPT(Vs0, T0, Vs, TF, Sizes) :-
|
||||
get_sizes(Vs0, Szs),
|
||||
numb_vars(Vs0, Szs, _, VPs0, VLs0),
|
||||
sort_according_to_parent(Vs,VLs0, VLs),
|
||||
sort_according_to_parent(Vs, VLs0, VLs),
|
||||
compute_new_factors(VLs, _, Vs, Sizes),
|
||||
get_factors(VLs0,Fs),
|
||||
length(T0,L),
|
||||
|
||||
@ -12,13 +12,17 @@
|
||||
|
||||
:- use_module(library(rbtrees),
|
||||
[new/1,
|
||||
insert/4]).
|
||||
insert/4,
|
||||
lookup/3]).
|
||||
|
||||
:- use_module(library(lists),
|
||||
[member/2,
|
||||
append/3,
|
||||
delete/3]).
|
||||
|
||||
:- use_module(library(ordsets),
|
||||
[ord_subtract/3]).
|
||||
|
||||
:- use_module(library('clpbn/discrete_utils'), [
|
||||
project_from_CPT/3,
|
||||
reorder_CPT/5]).
|
||||
@ -28,25 +32,29 @@
|
||||
|
||||
:- dynamic gibbs_params/3.
|
||||
|
||||
:- dynamic implicit/1.
|
||||
|
||||
gibbs([],_,_) :- !.
|
||||
gibbs(LVs,Vs0,_) :-
|
||||
clean_up,
|
||||
check_for_hidden_vars(Vs0, Vs0, Vs1),
|
||||
sort(Vs1,Vs),
|
||||
(clpbn:output(xbif(XBifStream)) -> clpbn2xbif(XBifStream,vel,Vs) ; true),
|
||||
(clpbn:output(gviz(XBifStream)) -> clpbn2gviz(XBifStream,vel,Vs,LVs) ; true),
|
||||
initialise(Vs, Graph, LVs, OutputVars),
|
||||
initialise(Vs, Graph, LVs, OutputVars, VarOrder),
|
||||
% write(Graph),nl,
|
||||
process(Graph, OutputVars, Estimates),
|
||||
process(VarOrder, Graph, OutputVars, Estimates),
|
||||
write(Estimates),nl,
|
||||
clean_up.
|
||||
|
||||
initialise(LVs, Graph, GVs, OutputVars) :-
|
||||
initialise(LVs, Graph, GVs, OutputVars, VarOrder) :-
|
||||
init_keys(Keys0),
|
||||
gen_keys(LVs, 0, VLen, Keys0, Keys),
|
||||
functor(Graph,graph,VLen),
|
||||
graph_representation(LVs, Graph, 0, Keys),
|
||||
graph_representation(LVs, Graph, 0, Keys, TGraph),
|
||||
compile_graph(Graph),
|
||||
listing(mblanket),
|
||||
topsort(TGraph, VarOrder),
|
||||
show_sorted(VarOrder, Graph),
|
||||
add_output_vars(GVs, Keys, OutputVars).
|
||||
|
||||
init_keys(Keys0) :-
|
||||
@ -61,8 +69,8 @@ gen_keys([V|Vs], I0, If, Keys0, Keys) :-
|
||||
insert(Keys0,V,I,KeysI),
|
||||
gen_keys(Vs, I, If, KeysI, Keys).
|
||||
|
||||
graph_representation([],_,_,_).
|
||||
graph_representation([V|Vs], Graph, I0, Keys) :-
|
||||
graph_representation([],_,_,_,[]).
|
||||
graph_representation([V|Vs], Graph, I0, Keys, TGraph) :-
|
||||
clpbn:get_atts(V,[evidence(_)]), !,
|
||||
clpbn:get_atts(V, [dist(Vals,Table,Parents)]),
|
||||
get_sizes(Parents, Szs),
|
||||
@ -70,18 +78,22 @@ graph_representation([V|Vs], Graph, I0, Keys) :-
|
||||
project_evidence_out([V|Parents],[V|Parents],Table,[Sz|Szs],Variables,NewTable),
|
||||
% all variables are parents
|
||||
propagate2parents(Variables, NewTable, Variables, Graph, Keys),
|
||||
graph_representation(Vs, Graph, I0, Keys).
|
||||
graph_representation([V|Vs], Graph, I0, Keys) :-
|
||||
graph_representation(Vs, Graph, I0, Keys, TGraph).
|
||||
graph_representation([V|Vs], Graph, I0, Keys, [I-IParents|TGraph]) :-
|
||||
I is I0+1,
|
||||
clpbn:get_atts(V, [dist(Vals,Table,Parents)]),
|
||||
get_sizes(Parents, Szs),
|
||||
length(Vals,Sz),
|
||||
project_evidence_out([V|Parents],[V|Parents],Table,[Sz|Szs],Variables,NewTable),
|
||||
Variables = [V|NewParents],
|
||||
compact_table(NewTable, RepTable),
|
||||
add2graph(V, Vals, RepTable, NewParents, Graph, Keys),
|
||||
propagate2parents(NewParents, NewTable, Variables, Graph, Keys),
|
||||
graph_representation(Vs, Graph, I, Keys).
|
||||
sort_according_to_indices(NewParents,Keys,SortedNVs,SortedIndices),
|
||||
reorder_CPT(Variables,NewTable,[V|SortedNVs],NewTable2,_),
|
||||
add2graph(V, Vals, NewTable2, SortedIndices, Graph, Keys),
|
||||
propagate2parents(NewParents, NewTable, Variables, Graph,Keys),
|
||||
parent_indices(NewParents, Keys, IVariables0),
|
||||
sort(IVariables0, IParents),
|
||||
arg(I, Graph, var(_,_,_,_,_,_,_,NewTable2,SortedIndices)),
|
||||
graph_representation(Vs, Graph, I, Keys, TGraph).
|
||||
|
||||
get_sizes([], []).
|
||||
get_sizes([V|Parents], [Sz|Szs]) :-
|
||||
@ -89,6 +101,13 @@ get_sizes([V|Parents], [Sz|Szs]) :-
|
||||
length(Vals,Sz),
|
||||
get_sizes(Parents, Szs).
|
||||
|
||||
parent_indices([], _, []).
|
||||
parent_indices([V|Parents], Keys, [I|IParents]) :-
|
||||
lookup(V, I, Keys),
|
||||
parent_indices(Parents, Keys, IParents).
|
||||
|
||||
|
||||
|
||||
%
|
||||
% first, remove nodes that have evidence from tables.
|
||||
%
|
||||
@ -99,26 +118,35 @@ project_evidence_out([V|Parents],Deps,Table,Szs,NewDeps,NewTable) :-
|
||||
project_from_CPT(V,tab(NTab,Deps,Szs),tab(ITable,IDeps,ISzs)),
|
||||
ITable =.. [_|LITable],
|
||||
project_evidence_out(Parents,IDeps,LITable,ISzs,NewDeps,NewTable).
|
||||
project_evidence_out([Par|Parents],Deps,Table,Szs,NewDeps,NewTable) :-
|
||||
project_evidence_out([_Par|Parents],Deps,Table,Szs,NewDeps,NewTable) :-
|
||||
project_evidence_out(Parents,Deps,Table,Szs,NewDeps,NewTable).
|
||||
|
||||
propagate2parents([], _, _, _, _).
|
||||
propagate2parents([V|NewParents], Table, Variables, Graph, Keys) :-
|
||||
delete(Variables,V,NVs),
|
||||
reorder_CPT(Variables,Table,[V|NVs],NewTable,_),
|
||||
add2graph(V, _, NewTable, NVs, Graph, Keys),
|
||||
NewTable =.. [_|LNewTable],
|
||||
propagate2parents(NewParents, LNewTable, Variables, Graph, Keys).
|
||||
sort_according_to_indices(NVs,Keys,SortedNVs,SortedIndices),
|
||||
reorder_CPT(Variables,Table,[V|SortedNVs],NewTable,_),
|
||||
add2graph(V, _, NewTable, SortedIndices, Graph, Keys),
|
||||
propagate2parents(NewParents,Table, Variables, Graph, Keys).
|
||||
|
||||
add2graph(V, Vals, Table, Parents, Graph, Keys) :-
|
||||
add2graph(V, Vals, Table, IParents, Graph, Keys) :-
|
||||
lookup(V, Index, Keys),
|
||||
(var(Vals) -> true ; length(Vals,Sz)),
|
||||
arg(Index, Graph, var(V,Index,_,Vals,Sz,VarSlot,_)),
|
||||
vars2indices(Parents,Keys,IParents),
|
||||
arg(Index, Graph, var(V,Index,_,Vals,Sz,VarSlot,_,_,_)),
|
||||
member(tabular(Table,Index,IParents), VarSlot), !.
|
||||
|
||||
sort_according_to_indices(NVs,Keys,SortedNVs,SortedIndices) :-
|
||||
vars2indices(NVs,Keys,ToSort),
|
||||
keysort(ToSort, Sorted),
|
||||
split_parents(Sorted, SortedNVs,SortedIndices).
|
||||
|
||||
split_parents([], [], []).
|
||||
split_parents([I-V|Sorted], [V|SortedNVs],[I|SortedIndices]) :-
|
||||
split_parents(Sorted, SortedNVs, SortedIndices).
|
||||
|
||||
|
||||
vars2indices([],_,[]).
|
||||
vars2indices([V|Parents],Keys,[I|IParents]) :-
|
||||
vars2indices([V|Parents],Keys,[I-V|IParents]) :-
|
||||
lookup(V, I, Keys),
|
||||
vars2indices(Parents,Keys,IParents).
|
||||
|
||||
@ -134,7 +162,8 @@ compile_graph(Graph) :-
|
||||
compile_vars(VarsInfo,Graph).
|
||||
|
||||
compile_vars([],_).
|
||||
compile_vars([var(_,I,_,Vals,Sz,VarSlot,Parents)|VarsInfo],Graph) :-
|
||||
compile_vars([var(_,I,_,Vals,Sz,VarSlot,Parents,_,_)|VarsInfo],Graph)
|
||||
:-
|
||||
compile_var(I,Vals,Sz,VarSlot,Parents,Graph),
|
||||
compile_vars(VarsInfo,Graph).
|
||||
|
||||
@ -145,32 +174,41 @@ compile_var(I,Vals,Sz,VarSlot,Parents,Graph) :-
|
||||
|
||||
fetch_all_parents([],_,Parents,Parents,Sizes,Sizes).
|
||||
fetch_all_parents([tabular(_,_,Ps)|CPTs],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
|
||||
merge_this_parents(Ps,Graph,Parents0,ParentsI,Sizes0,SizesI),
|
||||
merge_these_parents(Ps,Graph,Parents0,ParentsI,Sizes0,SizesI),
|
||||
fetch_all_parents(CPTs,Graph,ParentsI,ParentsF,SizesI,SizesF).
|
||||
|
||||
merge_this_parents([],_,Parents,Parents,Sizes,Sizes).
|
||||
merge_this_parents([I|Ps],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
|
||||
merge_these_parents([],_,Parents,Parents,Sizes,Sizes).
|
||||
merge_these_parents([I|Ps],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
|
||||
member(I,Parents0), !,
|
||||
merge_this_parents(Ps,Graph,Parents0,ParentsF,Sizes0,SizesF).
|
||||
merge_this_parents([I|Ps],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
|
||||
arg(I,Graph,var(_,I,_,Vals,_,_,_)),
|
||||
merge_these_parents(Ps,Graph,Parents0,ParentsF,Sizes0,SizesF).
|
||||
merge_these_parents([I|Ps],Graph,Parents0,ParentsF,Sizes0,SizesF) :-
|
||||
arg(I,Graph,var(_,I,_,Vals,_,_,_,_,_)),
|
||||
length(Vals, Sz),
|
||||
merge_this_parents(Ps,Graph,[I|Parents0],ParentsF,[Sz|Sizes0],SizesF).
|
||||
add_parent(Parents0,I,ParentsI,Sizes0,Sz,SizesI),
|
||||
merge_these_parents(Ps,Graph,ParentsI,ParentsF,SizesI,SizesF).
|
||||
|
||||
add_parent([],I,[I],[],Sz,[Sz]).
|
||||
add_parent([P|Parents0],I,[I,P|Parents0],Sizes0,Sz,[Sz|Sizes0]) :-
|
||||
P > I, !.
|
||||
add_parent([P|Parents0],I,[P|ParentsI],[S|Sizes0],Sz,[S|SizesI]) :-
|
||||
add_parent(Parents0,I,ParentsI,Sizes0,Sz,SizesI).
|
||||
|
||||
|
||||
mult_list([],Mult,Mult).
|
||||
mult_list([Sz|Sizes],Mult0,Mult) :-
|
||||
MultI is Sz*Mult0,
|
||||
mult_list(Sizes,MultI,Mult).
|
||||
|
||||
% we'd need 32 facts for each case
|
||||
compile_var(_TotSize,I,_Vals,Sz,CPTs,Parents,_Sizes,Graph) :-
|
||||
% TotSize =< 32,
|
||||
% compile node as set of facts, faster execution
|
||||
compile_var(TotSize,I,_Vals,Sz,CPTs,Parents,_Sizes,Graph) :-
|
||||
TotSize < 1024, TotSize > 0, !,
|
||||
multiply_all(I,Parents,CPTs,Sz,Graph).
|
||||
compile_var(_,I,_,_,_,_,_,_) :-
|
||||
assert(implicit(I)).
|
||||
|
||||
multiply_all(I,Parents,CPTs,Sz,Graph) :-
|
||||
markov_blanket_instance(Parents,Graph,Values),
|
||||
multiply_all(CPTs,Sz,Graph,Probs),
|
||||
write(Values:Probs:CPTs),nl,
|
||||
store_mblanket(I,Values,Probs),
|
||||
fail.
|
||||
multiply_all(_,_,_,_,_).
|
||||
@ -179,7 +217,7 @@ multiply_all(_,_,_,_,_).
|
||||
% slot in the graph!
|
||||
markov_blanket_instance([],_,[]).
|
||||
markov_blanket_instance([I|Parents],Graph,[Pos|Values]) :-
|
||||
arg(I,Graph,var(_,I,Pos,Vals,_,_,_)),
|
||||
arg(I,Graph,var(_,I,Pos,Vals,_,_,_,_,_)),
|
||||
fetch_val(Vals,0,Pos),
|
||||
markov_blanket_instance(Parents,Graph,Values).
|
||||
|
||||
@ -200,20 +238,20 @@ init_factors(I0,[1|Factors]) :-
|
||||
I is I0-1,
|
||||
init_factors(I,Factors).
|
||||
|
||||
mult_factors([],_,_,Factors,Factors) :- !.
|
||||
mult_factors([],_,_,Factors,Factors).
|
||||
mult_factors([tabular(Table,_,Parents)|CPTs],Size,Graph,Factors0,Factors) :-
|
||||
factor(Parents,Table,Graph,0,1,Indx0),
|
||||
functor(Table,_,CPTSize),
|
||||
Off is CPTSize//Size,
|
||||
factor(Parents,Table,Graph,0,Off,Indx0),
|
||||
Indx is Indx0+1,
|
||||
mult_with_probs(Factors0,Indx,Off,Table,FactorsI),
|
||||
mult_factors(CPTs,Size,Graph,FactorsI,Factors).
|
||||
|
||||
factor([],_,_,Arg,_,Arg).
|
||||
factor([I|Parents],Table,Graph,Pos0,Weight0,Pos) :-
|
||||
arg(I,Graph,var(_,I,CurPos,_,Sz,_,_)),
|
||||
PosI is Pos0+(Weight0*CurPos),
|
||||
NWeight is Weight0*Sz,
|
||||
arg(I,Graph,var(_,I,CurPos,_,Sz,_,_,_,_)),
|
||||
NWeight is Weight0 // Sz,
|
||||
PosI is Pos0+(NWeight*CurPos),
|
||||
factor(Parents,Table,Graph,PosI,NWeight,Pos).
|
||||
|
||||
mult_with_probs([],_,_,_,[]).
|
||||
@ -239,34 +277,64 @@ add_output_vars([V|LVs], Keys, [I|OutputVars]) :-
|
||||
lookup(V, I, Keys),
|
||||
add_output_vars(LVs, Keys, OutputVars).
|
||||
|
||||
process(Graph,OutputVars,Estimates) :-
|
||||
process(VarOrder, Graph, OutputVars, Estimates) :-
|
||||
gibbs_params(NChains,BurnIn,NSamples),
|
||||
functor(Graph,_,Len),
|
||||
init_chains(NChains,Len,Graph,Chains0),
|
||||
init_chains(NChains,VarOrder,Len,Graph,Chains0),
|
||||
init_estimates(NChains,OutputVars,Graph,Est0),
|
||||
process_chains(BurnIn,BurnedIn,Chains0,Graph,Len,Est0,_),
|
||||
process_chains(NSamples,_,BurnedIn,Graph,Len,Est0,Estimates).
|
||||
process_chains(BurnIn,VarOrder,BurnedIn,Chains0,Graph,Len,Est0,_),
|
||||
process_chains(NSamples,VarOrder,_,BurnedIn,Graph,Len,Est0,Estimates).
|
||||
|
||||
%
|
||||
% I use an uniform distribution to generate the initial sample.
|
||||
%
|
||||
init_chains(0,_,_,[]) :- !.
|
||||
init_chains(I,Len,Graph,[Chain|Chains]) :-
|
||||
init_chain(Len,Graph,Chain),
|
||||
init_chains(0,_,_,_,[]) :- !.
|
||||
init_chains(I,VarOrder,Len,Graph,[Chain|Chains]) :-
|
||||
init_chain(VarOrder,Len,Graph,Chain),
|
||||
I1 is I-1,
|
||||
init_chains(I1,Len,Graph,Chains).
|
||||
init_chains(I1,VarOrder,Len,Graph,Chains).
|
||||
|
||||
|
||||
init_chain(Len,Graph,Chain) :-
|
||||
gen_sample(Len,Graph,LChain),
|
||||
Chain =.. [sample|LChain].
|
||||
init_chain(VarOrder,Len,Graph,Chain) :-
|
||||
functor(Chain,sample,Len),
|
||||
gen_sample(VarOrder,Graph,Chain).
|
||||
|
||||
gen_sample(0,_,[]) :- !.
|
||||
gen_sample(I,Graph,[R|LChain]) :-
|
||||
arg(I,Graph,var(_,I,_,_,Sz,_,_)),
|
||||
R is integer(random*Sz),
|
||||
I1 is I-1,
|
||||
gen_sample(I1,Graph,LChain).
|
||||
gen_sample([],_,_) :- !.
|
||||
gen_sample([I|Vs],Graph,Chain) :-
|
||||
arg(I,Graph,var(_,I,_,_,Sz,_,_,Table,IPars)),
|
||||
functor(Table,_,CPTSize),
|
||||
Off is CPTSize//Sz,
|
||||
iparents_pos_sz(IPars, Chain, IPos, Graph, ISz),
|
||||
R is random,
|
||||
project(IPos, ISz, Table,0,Off,Indx0),
|
||||
Indx is Indx0+1,
|
||||
fetch_from_dist(Table,R,Indx,Off,0,Pos),
|
||||
arg(I,Chain,Pos),
|
||||
gen_sample(Vs,Graph,Chain).
|
||||
|
||||
project([],[],_,Arg,_,Arg).
|
||||
project([CurPos|Parents],[Sz|Sizes],Table,Pos0,Weight0,Pos) :-
|
||||
NWeight is Weight0 // Sz,
|
||||
PosI is Pos0+(NWeight*CurPos),
|
||||
project(Parents,Sizes,Table,PosI,NWeight,Pos).
|
||||
|
||||
fetch_from_dist(Table,R,Indx,Off,IPos,Pos) :-
|
||||
arg(Indx,Table,P),
|
||||
( P >= R ->
|
||||
Pos = IPos
|
||||
;
|
||||
NR is R-P,
|
||||
NIndx is Indx+Off,
|
||||
NPos is IPos+1,
|
||||
fetch_from_dist(Table,NR,NIndx,Off,NPos,Pos)
|
||||
).
|
||||
|
||||
|
||||
iparents_pos_sz([], _, [], _, []).
|
||||
iparents_pos_sz([I|IPars], Chain, [P|IPos], Graph, [Sz|Sizes]) :-
|
||||
arg(I,Chain,P),
|
||||
arg(I,Graph, var(_,I,_,_,Sz,_,_,_,_)),
|
||||
iparents_pos_sz(IPars, Chain, IPos, Graph, Sizes).
|
||||
|
||||
|
||||
init_estimates(0,_,_,[]) :- !.
|
||||
@ -277,7 +345,7 @@ init_estimates(NChains,OutputVars,Graph,[Est|Est0]) :-
|
||||
|
||||
init_estimate([],_,[]).
|
||||
init_estimate([V|OutputVars],Graph,[[I|E0L]|Est]) :-
|
||||
arg(V,Graph,var(_,I,_,_,Sz,_,_)),
|
||||
arg(V,Graph,var(_,I,_,_,Sz,_,_,_,_)),
|
||||
gen_e0(Sz,E0L),
|
||||
init_estimate(OutputVars,Graph,Est).
|
||||
|
||||
@ -286,41 +354,59 @@ gen_e0(Sz,[0|E0L]) :-
|
||||
Sz1 is Sz-1,
|
||||
gen_e0(Sz1,E0L).
|
||||
|
||||
|
||||
process_chains(0,F,F,_,_,Est,Est) :- !.
|
||||
process_chains(ToDo,End,Start,Graph,Len,Est0,Estf) :-
|
||||
process_chains(Start,Int,Graph,Len,Est0,Esti),
|
||||
process_chains(0,_,F,F,_,_,Est,Est) :- !.
|
||||
process_chains(ToDo,VarOrder,End,Start,Graph,Len,Est0,Estf) :-
|
||||
process_chains(Start,VarOrder,Int,Graph,Len,Est0,Esti),
|
||||
%cvt2problist(Esti, Probs), format('done ~d: ~w~n',[ToDo,Probs]),
|
||||
ToDo1 is ToDo-1,
|
||||
process_chains(ToDo1,End,Int,Graph,Len,Esti,Estf).
|
||||
process_chains(ToDo1,VarOrder,End,Int,Graph,Len,Esti,Estf).
|
||||
|
||||
|
||||
process_chains([], [], _, _,[],[]).
|
||||
process_chains([Sample0|Samples0], [Sample|Samples], Graph, SampLen,[E0|E0s],[Ef|Efs]) :-
|
||||
process_chains([], _, [], _, _,[],[]).
|
||||
process_chains([Sample0|Samples0], VarOrder, [Sample|Samples], Graph, SampLen,[E0|E0s],[Ef|Efs]) :-
|
||||
functor(Sample,sample,SampLen),
|
||||
do_sample(0,SampLen,Sample,Sample0,Graph),
|
||||
do_sample(VarOrder,Sample,Sample0,Graph),
|
||||
% format('~w ',[Sample]),
|
||||
update_estimate(E0,Sample,Ef),
|
||||
process_chains(Samples0, Samples, Graph, SampLen,E0s,Efs).
|
||||
process_chains(Samples0, VarOrder, Samples, Graph, SampLen,E0s,Efs).
|
||||
|
||||
do_sample(Len,Len,_,_,_) :- !.
|
||||
do_sample(I0,Len,Sample,Sample0,Graph) :-
|
||||
I is I0+1,
|
||||
do_sample([],_,_,_).
|
||||
do_sample([I|VarOrder],Sample,Sample0,Graph) :-
|
||||
do_var(I,Sample,Sample0,Graph),
|
||||
do_sample(I,Len,Sample,Sample0,Graph).
|
||||
do_sample(VarOrder,Sample,Sample0,Graph).
|
||||
|
||||
do_var(I,Sample,Sample0,Graph) :-
|
||||
arg(I,Graph,var(_,I,_,_,Sz,_,Parents)),
|
||||
length(Vals,Sz),
|
||||
fetch_parents(Parents,I,Sample,Sample0,Args,Vals),
|
||||
Goal =.. [mblanket,I|Args],
|
||||
(call(Goal) -> true ; throw(agg)),
|
||||
arg(I,Graph,var(_,I,_,_,Sz,CPTs,Parents,_,_)),
|
||||
( implicit(I) ->
|
||||
fetch_parents(Parents,I,Sample,Sample0,Bindings,[]),
|
||||
multiply_all_in_context(Parents,Bindings,CPTs,Sz,Graph,Vals)
|
||||
;
|
||||
length(Vals,Sz),
|
||||
fetch_parents(Parents,I,Sample,Sample0,Args,Vals),
|
||||
Goal =.. [mblanket,I|Args],
|
||||
call(Goal)
|
||||
),
|
||||
X is random,
|
||||
pick_new_value(Vals,X,0,Val),
|
||||
arg(I,Sample,Val).
|
||||
|
||||
multiply_all_in_context(Parents,Args,CPTs,Sz,Graph,Vals) :-
|
||||
set_pos(Parents,Args,Graph),
|
||||
multiply_all(CPTs,Sz,Graph,Vals),
|
||||
assert(mall(Vals)),
|
||||
fail.
|
||||
multiply_all_in_context(_,_,_,_,_,Vals) :-
|
||||
retract(mall(Vals)).
|
||||
|
||||
set_pos([],[],_).
|
||||
set_pos([I|Is],[Pos|Args],Graph) :-
|
||||
arg(I,Graph,var(_,I,Pos,_,_,_,_,_,_)),
|
||||
set_pos(Is,Args,Graph).
|
||||
|
||||
fetch_parents([],_,_,_,Args,Args).
|
||||
fetch_parents([P|Parents],I,Sample,Sample0,[VP|Args],Vals) :-
|
||||
P < I, !,
|
||||
arg(P,Sample,VP),
|
||||
nonvar(VP), !,
|
||||
fetch_parents(Parents,I,Sample,Sample0,Args,Vals).
|
||||
fetch_parents([P|Parents],I,Sample,Sample0,[VP|Args],Vals) :-
|
||||
arg(P,Sample0,VP),
|
||||
@ -352,8 +438,54 @@ clean_up :-
|
||||
current_predicate(mblanket,P),
|
||||
retractall(P),
|
||||
fail.
|
||||
clean_up :-
|
||||
retractall(implicit(_)),
|
||||
fail.
|
||||
clean_up.
|
||||
|
||||
|
||||
gibbs_params(5,1000,100000).
|
||||
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),
|
||||
do_probs(E,Sum,Ps),
|
||||
cvt2problist(Est0, Probs) .
|
||||
|
||||
sum_all([],Sum,Sum).
|
||||
sum_all([E|Es],S0,Sum) :-
|
||||
SI is S0+E,
|
||||
sum_all(Es,SI,Sum).
|
||||
|
||||
do_probs([],_,[]).
|
||||
do_probs([E|Es],Sum,[P|Ps]) :-
|
||||
P is E/Sum,
|
||||
do_probs(Es,Sum,Ps).
|
||||
|
||||
show_sorted([], _) :- nl.
|
||||
show_sorted([I|VarOrder], Graph) :-
|
||||
arg(I,Graph,var(V,I,_,_,_,_,_,_,_)),
|
||||
clpbn:get_atts(V,[key(K)]),
|
||||
% format('~w ',[K]),
|
||||
show_sorted(VarOrder, Graph).
|
||||
|
||||
@ -88,6 +88,7 @@ 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).
|
||||
@ -135,8 +136,14 @@ multiply_sizes([V|Vs],K0,K) :-
|
||||
process(LV0, InputVs, Out) :-
|
||||
find_best(LV0, V0, -1, V, WorkTables, LVI, InputVs),
|
||||
V \== V0, !,
|
||||
multiply_tables(WorkTables, Table),
|
||||
%format('1 ~w: ~w~n',[V,WorkTables]),
|
||||
multiply_tables(WorkTables, tab(Tab0,Deps0,_)),
|
||||
Tab0 =.. [_|LTab0],
|
||||
reorder_CPT(Deps0,LTab0,Deps,Tab,Sizes),
|
||||
Table = tab(Tab,Deps,Sizes),
|
||||
%format('2 ~w: ~w~n',[V,Table]),
|
||||
project_from_CPT(V,Table,NewTable),
|
||||
%format('3 ~w: ~w~n',[V,NewTable]),
|
||||
include(LVI,NewTable,V,LV2),
|
||||
process(LV2, InputVs, Out).
|
||||
process(LV0, _, Out) :-
|
||||
@ -256,7 +263,7 @@ bind_vals([],_,_) :- !.
|
||||
bind_vals(Vs,Ps,AllDiffs) :-
|
||||
get_all_combs(Vs, Vals),
|
||||
Vs = [V|_],
|
||||
put_atts(V, posterior(Vs, Vals, Ps,AllDiffs)).
|
||||
put_atts(V, posterior(Vs, Vals, Ps, AllDiffs)).
|
||||
|
||||
get_all_combs(Vs, Vals) :-
|
||||
get_all_doms(Vs,Ds),
|
||||
|
||||
@ -63,6 +63,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
|
||||
).
|
||||
'$do_c_built_in'(once(G), M, ('$save_current_choice_point'(CP),NG,'$$cut_by'(CP))) :- !,
|
||||
'$do_c_built_in'(G,M,NG).
|
||||
'$do_c_built_in'('C'(A,B.C), _, (A=[B|C])) :- !.
|
||||
'$do_c_built_in'(X is Y, _, P) :-
|
||||
nonvar(Y), % Don't rewrite variables
|
||||
!,
|
||||
|
||||
@ -419,8 +419,10 @@ debugging :-
|
||||
'$do_spy'(Cl, M, CP, InControl).
|
||||
'$spycall'(G, M, InControl) :-
|
||||
% I lost control here.
|
||||
'$continue_debugging'(InControl,G,M),
|
||||
'$execute_nonstop'(G, M).
|
||||
CP is '$last_choice_pt',
|
||||
'$static_clause'(G,M,C,R),
|
||||
'$continue_debugging'(InControl, G, M),
|
||||
'$execute_clause'(G, M, R, CP).
|
||||
|
||||
'$trace'(P,G,Module,L) :-
|
||||
flush_output(user_output),
|
||||
|
||||
Reference in New Issue
Block a user