From b8f1beec7406b0cb9b5bb5619443e7cc2a0ebb1c Mon Sep 17 00:00:00 2001 From: vsc Date: Tue, 2 Aug 2005 03:09:52 +0000 Subject: [PATCH] fix debugger to do well nonsource predicates. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1354 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/absmi.c | 7 +- C/amasm.c | 6 +- C/cdmgr.c | 9 +- C/exec.c | 67 +++++++- C/index.c | 17 +- CLPBN/clpbn/aggregates.yap | 4 +- CLPBN/clpbn/discrete_utils.yap | 2 +- CLPBN/clpbn/gibbs.yap | 290 ++++++++++++++++++++++++--------- CLPBN/clpbn/vel.yap | 11 +- pl/arith.yap | 1 + pl/debug.yap | 6 +- 11 files changed, 326 insertions(+), 94 deletions(-) diff --git a/C/absmi.c b/C/absmi.c index 751ac6913..3f0a55568 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -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); diff --git a/C/amasm.c b/C/amasm.c index 9a4b40008..dc94ad320 100644 --- a/C/amasm.c +++ b/C/amasm.c @@ -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; } diff --git a/C/cdmgr.c b/C/cdmgr.c index 9be4d9306..b666b71da 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -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) { diff --git a/C/exec.c b/C/exec.c index 0b9e7a387..ea8802e4a 100644 --- a/C/exec.c +++ b/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); diff --git a/C/index.c b/C/index.c index 2a99bac30..7852ef629 100644 --- a/C/index.c +++ b/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)) diff --git a/CLPBN/clpbn/aggregates.yap b/CLPBN/clpbn/aggregates.yap index 0c4923410..8589d1a27 100644 --- a/CLPBN/clpbn/aggregates.yap +++ b/CLPBN/clpbn/aggregates.yap @@ -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), diff --git a/CLPBN/clpbn/discrete_utils.yap b/CLPBN/clpbn/discrete_utils.yap index 478c9e732..dd684984c 100644 --- a/CLPBN/clpbn/discrete_utils.yap +++ b/CLPBN/clpbn/discrete_utils.yap @@ -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), diff --git a/CLPBN/clpbn/gibbs.yap b/CLPBN/clpbn/gibbs.yap index 07ff85c64..e1d017171 100644 --- a/CLPBN/clpbn/gibbs.yap +++ b/CLPBN/clpbn/gibbs.yap @@ -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). diff --git a/CLPBN/clpbn/vel.yap b/CLPBN/clpbn/vel.yap index 68c92aab2..5f76fb4b8 100644 --- a/CLPBN/clpbn/vel.yap +++ b/CLPBN/clpbn/vel.yap @@ -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), diff --git a/pl/arith.yap b/pl/arith.yap index 18fd618d3..54ac14ec8 100644 --- a/pl/arith.yap +++ b/pl/arith.yap @@ -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 !, diff --git a/pl/debug.yap b/pl/debug.yap index d62f37700..488b5119f 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -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),