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

ops

Browse Source
This commit is contained in:
Tiago Gomes 2012-04-12 18:46:21 +01:00
commit 15c8f3abc6
18 changed files with 336 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
C/adtdefs.c
View File

@ -490,7 +490,6 @@ Yap_HasOp(Atom a)
OpEntry *
Yap_OpPropForModule(Atom a, Term mod)
{ /* look property list of atom a for kind */
CACHE_REGS
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
OpEntry *info = NULL;
@ -767,6 +766,7 @@ ExpandPredHash(void)
Prop
Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
{
CACHE_REGS
PredEntry *p = (PredEntry *) Yap_AllocAtomSpace(sizeof(*p));
if (p == NULL) {
@ -902,6 +902,7 @@ Yap_NewThreadPred(PredEntry *ap USES_REGS)
Prop
Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
{
CACHE_REGS
Prop p0;
PredEntry *p = (PredEntry *) Yap_AllocAtomSpace(sizeof(*p));

1
C/amasm.c
View File

@ -2053,6 +2053,7 @@ a_try(op_numbers opcode, CELL lab, CELL opr, int nofalts, int hascut, yamop *cod
yamop *newcp;
/* emit a special instruction and then a label for backpatching */
if (pass_no) {
CACHE_REGS
UInt size = (UInt)NEXTOP((yamop *)NULL,OtaLl);
if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) {
/* OOOPS, got in trouble, must do a longjmp and recover space */

5
C/c_interface.c
View File

@ -2706,7 +2706,6 @@ YAP_InitConsult(int mode, char *filename)
X_API IOSTREAM *
YAP_TermToStream(Term t)
{
CACHE_REGS
IOSTREAM *s;
BACKUP_MACHINE_REGS();
@ -3622,8 +3621,10 @@ YAP_ListToFloats(Term t, double *dblp, size_t sz)
dblp[i++] = IntOfTerm(hd);
else if (IsLongIntTerm(hd))
dblp[i++] = LongIntOfTerm(hd);
#if USE_GMP
else if (IsBigIntTerm(hd))
dblp[i++] = Yap_gmp_to_float(hd);
#endif
else
return -1;
}
@ -4122,6 +4123,8 @@ YAP_ImportTerm(char * buf) {
X_API int
YAP_RequiresExtraStack(size_t sz) {
CACHE_REGS
if (sz < 16*1024)
sz = 16*1024;
if (H <= ASP-sz) {

5
C/cdmgr.c
View File

@ -5107,6 +5107,8 @@ p_continue_static_clause( USES_REGS1 )
static void
add_code_in_lu_index(LogUpdIndex *cl, PredEntry *pp)
{
CACHE_REGS
char *code_end = (char *)cl + cl->ClSize;
Yap_inform_profiler_of_clause(cl, code_end, pp, GPROF_LU_INDEX);
cl = cl->ChildIndex;
@ -5119,6 +5121,7 @@ add_code_in_lu_index(LogUpdIndex *cl, PredEntry *pp)
static void
add_code_in_static_index(StaticIndex *cl, PredEntry *pp)
{
CACHE_REGS
char *code_end = (char *)cl + cl->ClSize;
Yap_inform_profiler_of_clause(cl, code_end, pp, GPROF_STATIC_INDEX);
cl = cl->ChildIndex;
@ -5131,6 +5134,7 @@ add_code_in_static_index(StaticIndex *cl, PredEntry *pp)
static void
add_code_in_pred(PredEntry *pp) {
CACHE_REGS
yamop *clcode;
PELOCK(49,pp);
@ -5202,6 +5206,7 @@ add_code_in_pred(PredEntry *pp) {
void
Yap_dump_code_area_for_profiler(void) {
CACHE_REGS
ModEntry *me = CurrentModules;
while (me) {

1
C/dbase.c
View File

@ -1887,6 +1887,7 @@ Yap_new_ludbe(Term t, PredEntry *pe, UInt nargs)
static LogUpdClause *
record_lu(PredEntry *pe, Term t, int position)
{
CACHE_REGS
LogUpdClause *cl;
if ((cl = new_lu_db_entry(t, pe)) == NULL) {

27
C/gprof.c
View File

@ -168,6 +168,7 @@ RBfree(rb_red_blk_node *ptr)
static rb_red_blk_node *
RBTreeCreate(void) {
CACHE_REGS
rb_red_blk_node* temp;
/* see the comment in the rb_red_blk_tree structure in red_black_tree.h */
@ -210,6 +211,7 @@ RBTreeCreate(void) {
static void
LeftRotate(rb_red_blk_node* x) {
CACHE_REGS
rb_red_blk_node* y;
rb_red_blk_node* nil=LOCAL_ProfilerNil;
@ -266,6 +268,7 @@ LeftRotate(rb_red_blk_node* x) {
static void
RightRotate(rb_red_blk_node* y) {
CACHE_REGS
rb_red_blk_node* x;
rb_red_blk_node* nil=LOCAL_ProfilerNil;
@ -318,6 +321,7 @@ RightRotate(rb_red_blk_node* y) {
static void
TreeInsertHelp(rb_red_blk_node* z) {
CACHE_REGS
/* This function should only be called by InsertRBTree (see above) */
rb_red_blk_node* x;
rb_red_blk_node* y;
@ -369,6 +373,7 @@ TreeInsertHelp(rb_red_blk_node* z) {
static rb_red_blk_node *
RBTreeInsert(yamop *key, yamop *lim) {
CACHE_REGS
rb_red_blk_node * y;
rb_red_blk_node * x;
rb_red_blk_node * newNode;
@ -440,6 +445,7 @@ RBTreeInsert(yamop *key, yamop *lim) {
static rb_red_blk_node*
RBExactQuery(yamop* q) {
CACHE_REGS
rb_red_blk_node* x;
rb_red_blk_node* nil=LOCAL_ProfilerNil;
@ -460,6 +466,7 @@ RBExactQuery(yamop* q) {
static rb_red_blk_node*
RBLookup(yamop *entry) {
CACHE_REGS
rb_red_blk_node *current;
if (!LOCAL_ProfilerRoot)
@ -495,6 +502,7 @@ RBLookup(yamop *entry) {
/***********************************************************************/
static void RBDeleteFixUp(rb_red_blk_node* x) {
CACHE_REGS
rb_red_blk_node* root=LOCAL_ProfilerRoot->left;
rb_red_blk_node *w;
@ -574,6 +582,7 @@ static void RBDeleteFixUp(rb_red_blk_node* x) {
static rb_red_blk_node*
TreeSuccessor(rb_red_blk_node* x) {
CACHE_REGS
rb_red_blk_node* y;
rb_red_blk_node* nil=LOCAL_ProfilerNil;
rb_red_blk_node* root=LOCAL_ProfilerRoot;
@ -612,6 +621,7 @@ TreeSuccessor(rb_red_blk_node* x) {
static void
RBDelete(rb_red_blk_node* z){
CACHE_REGS
rb_red_blk_node* y;
rb_red_blk_node* x;
rb_red_blk_node* nil=LOCAL_ProfilerNil;
@ -664,7 +674,8 @@ RBDelete(rb_red_blk_node* z){
char *set_profile_dir(char *);
char *set_profile_dir(char *name){
int size=0;
CACHE_REGS
int size=0;
if (name!=NULL) {
size=strlen(name)+1;
@ -687,8 +698,9 @@ return LOCAL_DIRNAME;
char *profile_names(int);
char *profile_names(int k) {
static char *FNAME=NULL;
int size=200;
CACHE_REGS
static char *FNAME=NULL;
int size=200;
if (LOCAL_DIRNAME==NULL) set_profile_dir(NULL);
size=strlen(LOCAL_DIRNAME)+40;
@ -709,6 +721,7 @@ int size=200;
void del_profile_files(void);
void del_profile_files() {
CACHE_REGS
if (LOCAL_DIRNAME!=NULL) {
remove(profile_names(PROFPREDS_FILE));
remove(profile_names(PROFILING_FILE));
@ -717,6 +730,7 @@ void del_profile_files() {
void
Yap_inform_profiler_of_clause__(void *code_start, void *code_end, PredEntry *pe,gprof_info index_code) {
CACHE_REGS
buf_ptr b;
buf_extra e;
LOCAL_ProfOn = TRUE;
@ -742,6 +756,7 @@ static Int profend( USES_REGS1 );
static void
clean_tree(rb_red_blk_node* node) {
CACHE_REGS
if (node == LOCAL_ProfilerNil)
return;
clean_tree(node->left);
@ -751,6 +766,7 @@ clean_tree(rb_red_blk_node* node) {
static void
reset_tree(void) {
CACHE_REGS
clean_tree(LOCAL_ProfilerRoot);
Yap_FreeCodeSpace((char *)LOCAL_ProfilerNil);
LOCAL_ProfilerNil = LOCAL_ProfilerRoot = NULL;
@ -760,6 +776,7 @@ reset_tree(void) {
static int
InitProfTree(void)
{
CACHE_REGS
if (LOCAL_ProfilerRoot)
reset_tree();
while (!(LOCAL_ProfilerRoot = RBTreeCreate())) {
@ -773,6 +790,7 @@ InitProfTree(void)
static void RemoveCode(CODEADDR clau)
{
CACHE_REGS
rb_red_blk_node* x, *node;
PredEntry *pp;
UInt count;
@ -958,6 +976,7 @@ prof_alrm(int signo, siginfo_t *si, void *scv)
void
Yap_InformOfRemoval(void *clau)
{
CACHE_REGS
LOCAL_ProfOn = TRUE;
if (LOCAL_FPreds != NULL) {
/* just store info about what is going on */
@ -1048,6 +1067,7 @@ static Int profinit( USES_REGS1 )
static Int start_profilers(int msec)
{
CACHE_REGS
struct itimerval t;
struct sigaction sa;
@ -1157,6 +1177,7 @@ static Int profres0( USES_REGS1 ) {
void
Yap_InitLowProf(void)
{
CACHE_REGS
#if LOW_PROF
LOCAL_ProfCalls = 0;
LOCAL_ProfilerOn = FALSE;

1
C/index.c
View File

@ -1888,6 +1888,7 @@ emit_single_switch_case(ClauseDef *min, struct intermediates *cint, int first, i
static UInt
suspend_indexing(ClauseDef *min, ClauseDef *max, PredEntry *ap, struct intermediates *cint)
{
CACHE_REGS
UInt tcls = ap->cs.p_code.NOfClauses;
UInt cls = (max-min)+1;

1
C/sysbits.c
View File

@ -1619,6 +1619,7 @@ InteractSIGINT(int ch) {
static int
ProcessSIGINT(void)
{
CACHE_REGS
int ch, out;
LOCAL_PrologMode |= AsyncIntMode;

12
C/utilpreds.c
View File

@ -4255,7 +4255,7 @@ p_is_list_or_partial_list( USES_REGS1 )
}
static Term
numbervar(Int id)
numbervar(Int id USES_REGS)
{
Term ts[1];
ts[0] = MkIntegerTerm(id);
@ -4263,7 +4263,7 @@ numbervar(Int id)
}
static Term
numbervar_singleton(void)
numbervar_singleton(USES_REGS1)
{
Term ts[1];
ts[0] = MkIntegerTerm(-1);
@ -4356,9 +4356,9 @@ static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end
derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
/* do or pt2 are unbound */
if (singles)
*ptd0 = numbervar_singleton();
*ptd0 = numbervar_singleton( PASS_REGS1 );
else
*ptd0 = numbervar(numbv++);
*ptd0 = numbervar(numbv++ PASS_REGS);
/* leave an empty slot to fill in later */
if (H+1024 > ASP) {
goto global_overflow;
@ -4450,10 +4450,10 @@ Yap_NumberVars( Term inp, Int numbv, int handle_singles ) /* numbervariables in
CELL *ptd0 = VarOfTerm(t);
TrailTerm(TR++) = (CELL)ptd0;
if (handle_singles) {
*ptd0 = numbervar_singleton();
*ptd0 = numbervar_singleton( PASS_REGS1 );
return numbv;
} else {
*ptd0 = numbervar(numbv);
*ptd0 = numbervar(numbv PASS_REGS);
return numbv+1;
}
} else if (IsPrimitiveTerm(t)) {

16
packages/CLPBN/clpbn.yap
View File

@ -44,7 +44,7 @@
check_if_bp_done/1,
init_bp_solver/4,
run_bp_solver/3,
call_bp_ground/5,
call_bp_ground/6,
finalize_bp_solver/1
]).
@ -69,10 +69,10 @@
run_bdd_solver/3
]).
:- use_module('clpbn/bnt',
[do_bnt/3,
check_if_bnt_done/1
]).
%% :- use_module('clpbn/bnt',
%% [do_bnt/3,
%% check_if_bnt_done/1
%% ]).
:- use_module('clpbn/gibbs',
[gibbs/3,
@ -238,7 +238,7 @@ project_attributes(GVars, _AVars0) :-
(ground(GVars) ->
true
;
call_ground_solver(Solver, GKeys, Keys, Factors, Evidence, Answ)
call_ground_solver(Solver, GVars, GKeys, Keys, Factors, Evidence, _Avars0)
).
project_attributes(GVars, AVars) :-
suppress_attribute_display(false),
@ -312,8 +312,8 @@ write_out(fove, GVars, AVars, DiffVars) :-
fove(GVars, AVars, DiffVars).
% call a solver with keys, not actual variables
call_ground_solver(bp, GoalKeys, Keys, Factors, Evidence, Answ) :-
call_bp_ground(GoalKeys, Keys, Factors, Evidence, Answ).
call_ground_solver(bp, GVars, GoalKeys, Keys, Factors, Evidence, Answ) :-
call_bp_ground(GVars, GoalKeys, Keys, Factors, Evidence, Answ).
get_bnode(Var, Goal) :-

329
packages/CLPBN/clpbn/bdd.yap
View File

@ -31,6 +31,7 @@ Va <- P*X1*Y1 + Q*X2*Y2 + ...
[dist/4,
get_dist_domain/2,
get_dist_domain_size/2,
get_dist_all_sizes/2,
get_dist_params/2
]).
@ -54,6 +55,10 @@ Va <- P*X1*Y1 + Q*X2*Y2 + ...
:- use_module(library(rbtrees)).
:- use_module(library(bhash)).
:- use_module(library(matrix)).
:- dynamic network_counting/1.
:- attribute order/1.
@ -120,15 +125,16 @@ get_vars_info([_|MoreVs], Vs0, VsF, Ps0, PsF, VarsInfo, Lvs, Outs) :-
%
% let's have some fun with avg
%
get_var_info(V, avg(Domain), Parents0, Vs, Vs2, Ps, Ps, Lvs, Outs, DIST) :- !,
reorder_vars(Parents0, Parents),
get_var_info(V, avg(Domain), Parents, Vs, Vs2, Ps, Ps, Lvs, Outs, DIST) :- !,
length(Domain, DSize),
% run_though_avg(V, DSize, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST).
bup_avg(V, DSize, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST).
top_down_with_tabling(V, DSize, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST).
% bup_avg(V, DSize, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST).
% standard random variable
get_var_info(V, DistId, Parents, Vs, Vs2, Ps, Ps1, Lvs, Outs, DIST) :-
get_var_info(V, DistId, Parents0, Vs, Vs2, Ps, Ps1, Lvs, Outs, DIST) :-
% clpbn:get_atts(V, [key(K)]), writeln(V:K:DistId:Parents),
check_p(DistId, Parms, _ParmVars, Ps, Ps1),
reorder_vars(Parents0, Parents, Map),
check_p(DistId, Map, Parms, _ParmVars, Ps, Ps1),
unbound_parms(Parms, ParmVars),
check_v(V, DistId, DIST, Vs, Vs1),
DIST = info(V, Tree, Ev, Values, Formula, ParmVars, Parms),
@ -139,27 +145,34 @@ get_var_info(V, DistId, Parents, Vs, Vs2, Ps, Ps1, Lvs, Outs, DIST) :-
get_evidence(V, Tree, Ev, Formula0, Formula, Lvs, Outs).
%, (numbervars(Formula,0,_),writeln(formula:Formula), fail ; true)
reorder_vars(Vs, OVs) :-
add_pos(Vs, PVs),
%
% reorder all variables and make sure we get a
% map of how the transfer was done.
%
% position zero is output
%
reorder_vars(Vs, OVs, Map) :-
add_pos(Vs, 1, PVs),
keysort(PVs, SVs),
remove_key(SVs, OVs1),
reverse(OVs1, OVs).
remove_key(SVs, OVs, Map).
add_pos([], []).
add_pos([V|Vs], [K-V|PVs]) :-
add_pos([], _, []).
add_pos([V|Vs], I0, [K-(I0,V)|PVs]) :-
get_atts(V,[order(K)]),
add_pos(Vs, PVs).
I is I0+1,
add_pos(Vs, I, PVs).
remove_key([], []).
remove_key([_-V|SVs], [V|OVs]) :-
remove_key(SVs, OVs).
remove_key([], [], []).
remove_key([_-(I,V)|SVs], [V|OVs], [I|Map]) :-
remove_key(SVs, OVs, Map).
%%%%%%%%%%%%%%%%%%%%%%%%%
%
% use top-down to generate average
%
run_though_avg(V, 3, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST) :-
check_v(V, avg(Domain,Parents), DIST, Vs, Vs1),
run_though_avg(V, 3, Domain, Parents0, Vs, Vs2, Lvs, Outs, DIST) :-
reorder_vars(Parents0, Parents, _Map),
check_v(V, avg(Domain,Parents0), DIST, Vs, Vs1),
DIST = info(V, Tree, Ev, [V0,V1,V2], Formula, [], []),
get_parents(Parents, PVars, Vs1, Vs2),
length(Parents, N),
@ -167,7 +180,8 @@ run_though_avg(V, 3, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST) :-
simplify_exp(F00, F0),
% generate_3tree(F1, PVars, 0, 0, 0, N, N0, N1, N2, R, ((N1+2*(N2+R) > N/2, N1+2*N2 < (3*N)/2))),
generate_3tree(F20, PVars, 0, 0, 0, N, N0, N1, N2, R, (N1+2*(N2+R) >= (3*N)/2), N1+2*N2 >= (3*N)/2),
simplify_exp(F20, F2),
% simplify_exp(F20, F2),
F20=F2,
Formula0 = [V0=F0*Ev0,V2=F2*Ev2,V1=not(F0+F2)*Ev1],
Ev = [Ev0,Ev1,Ev2],
get_evidence(V, Tree, Ev, Formula0, Formula, Lvs, Outs).
@ -229,15 +243,81 @@ not_satisf(I0, I1, I2, IR, N0, N1, N2, R, Exp) :-
%%%%%%%%%%%%%%%%%%%%%%%%%
%
% use bottom-up dynamic programming to generate average
% use top-down to generate average
%
bup_avg(V, Size, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST) :-
top_down_with_tabling(V, Size, Domain, Parents0, Vs, Vs2, Lvs, Outs, DIST) :-
reorder_vars(Parents0, Parents, _Map),
check_v(V, avg(Domain,Parents), DIST, Vs, Vs1),
DIST = info(V, Tree, Ev, OVs, Formula, [], []),
get_parents(Parents, PVars, Vs1, Vs2),
generate_sums(PVars, Size, Max, Sums, F0),
% length(Parents, N),
% Max is (Size-1)*N, % This should be true
length(Parents, N),
Max is (Size-1)*N, % This should be true
avg_borders(0, Size, Max, Borders),
b_hash_new(H0),
avg_trees(0, Max, PVars, Size, F1, 0, Borders, OVs, Ev, H0, H),
generate_avg_code(H, Formula, F),
% Formula0 = [V0=F0*Ev0,V2=F2*Ev2,V1=not(F0+F2)*Ev1],
% Ev = [Ev0,Ev1,Ev2],
get_evidence(V, Tree, Ev, F1, F, Lvs, Outs).
avg_trees(Size, _, _, Size, F0, _, F0, [], [], H, H) :- !.
avg_trees(I0, Max, PVars, Size, [V=O*E|F0], Im, [IM|Borders], [V|OVs], [E|Ev], H0, H) :-
I is I0+1,
avg_tree(PVars, 0, Max, Im, IM, Size, O, H0, HI),
Im1 is IM+1,
avg_trees(I, Max, PVars, Size, F0, Im1, Borders, OVs, Ev, HI, H).
avg_tree( _PVars, P, _, Im, IM, _Size, O, H0, H0) :-
b_hash_lookup(k(P,Im,IM), O=_Exp, H0), !.
avg_tree([], _P, _Max, _Im, _IM, _Size, 1, H, H).
avg_tree([Vals|PVars], P, Max, Im, IM, Size, O, H0, HF) :-
b_hash_insert(H0, k(P,Im,IM), O=Simp, HI),
MaxI is Max-(Size-1),
avg_exp(Vals, PVars, 0, P, MaxI, Size, Im, IM, HI, HF, Exp),
simplify_exp(Exp, Simp).
avg_exp([], _, _, _P, _Max, _Size, _Im, _IM, H, H, 0).
avg_exp([Val|Vals], PVars, I0, P0, Max, Size, Im, IM, HI, HF, O) :-
(Vals = [] -> O=O1 ; O = Val*O1+not(Val)*O2 ),
Im1 is max(0, Im-I0),
IM1 is IM-I0,
( IM1 < 0 -> O1 = 0, H2 = HI; /* we have exceed maximum */
Im1 > Max -> O1 = 0, H2 = HI; /* we cannot make to minimum */
Im1 = 0, IM1 > Max -> O1 = 1, H2 = HI; /* we cannot exceed maximum */
P is P0+1,
avg_tree(PVars, P, Max, Im1, IM1, Size, O1, HI, H2)
),
I is I0+1,
avg_exp(Vals, PVars, I, P0, Max, Size, Im, IM, H2, HF, O2).
generate_avg_code(H, Formula, Formula0) :-
b_hash_to_list(H,L),
sort(L, S),
strip_and_add(S, Formula0, Formula).
strip_and_add([], F, F).
strip_and_add([_-Exp|S], F0, F) :-
strip_and_add(S, [Exp|F0], F).
%%%%%%%%%%%%%%%%%%%%%%%%%
%
% use bottom-up dynamic programming to generate average
%
bup_avg(V, Size, Domain, Parents0, Vs, Vs2, Lvs, Outs, DIST) :-
reorder_vars(Parents0, Parents, _),
check_v(V, avg(Domain,Parents), DIST, Vs, Vs1),
DIST = info(V, Tree, Ev, OVs, Formula, [], []),
get_parents(Parents, PVars, Vs1, Vs2),
length(Parents, N),
Max is (Size-1)*N, % This should be true
ArraySize is Max+1,
functor(Protected, protected, ArraySize),
avg_domains(0, Size, 0, Max, LDomains),
Domains =.. [d|LDomains],
Reach is (Size-1),
generate_sums(PVars, Size, Max, Reach, Protected, Domains, ArraySize, Sums, F0),
% bin_sums(PVars, Sums, F00),
% reverse(F00,F0),
% easier to do recursion on lists
Sums =.. [_|LSums],
generate_avg(0, Size, 0, Max, LSums, OVs, Ev, F1, []),
@ -245,47 +325,148 @@ bup_avg(V, Size, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST) :-
get_evidence(V, Tree, Ev, F1, F2, Lvs, Outs),
append(RF0, F2, Formula).
generate_sums([PVals], Size, Max, Sum, []) :- !,
%
% use binary approach, like what is standard
%
bin_sums(Vs, Sums, F) :-
vs_to_sums(Vs, Sums0),
bin_sums(Sums0, Sums, F, []).
vs_to_sums([], []).
vs_to_sums([V|Vs], [Sum|Sums0]) :-
Sum =.. [sum|V],
vs_to_sums(Vs, Sums0).
bin_sums([Sum], Sum) --> !.
bin_sums(LSums, Sum) -->
{ halve(LSums, Sums1, Sums2) },
bin_sums(Sums1, Sum1),
bin_sums(Sums2, Sum2),
sum(Sum1, Sum2, Sum).
halve(LSums, Sums1, Sums2) :-
length(LSums, L),
Take is L div 2,
head(Take, LSums, Sums1, Sums2).
head(0, L, [], L) :- !.
head(Take, [H|L], [H|Sums1], Sum2) :-
Take1 is Take-1,
head(Take1, L, Sums1, Sum2).
sum(Sum1, Sum2, Sum) -->
{ functor(Sum1, _, M1),
functor(Sum2, _, M2),
Max is M1+M2-2,
Max1 is Max+1,
Max0 is M2-1,
functor(Sum, sum, Max1),
Sum1 =.. [_|PVals] },
expand_sums(PVals, 0, Max0, Max1, M2, Sum2, Sum).
%
% bottom up step by step
%
%
generate_sums([PVals], Size, Max, _, _Protected, _Domains, _, Sum, []) :- !,
Max is Size-1,
Sum =.. [sum|PVals].
generate_sums([PVals|Parents], Size, Max, NewSums, F) :-
generate_sums(Parents, Size, Max0, Sums, F0),
generate_sums([PVals|Parents], Size, Max, Reach, Protected, Domains, ASize, NewSums, F) :-
NewReach is Reach+(Size-1),
generate_sums(Parents, Size, Max0, NewReach, Protected, Domains, ASize, Sums, F0),
Max is Max0+(Size-1),
Max1 is Max+1,
functor(NewSums, sum, Max1),
expand_sums(PVals, 0, Max0, Max1, Size, Sums, NewSums, F, F0).
protect_avg(0, Max0, Protected, Domains, ASize, Reach),
expand_sums(PVals, 0, Max0, Max1, Size, Sums, Protected, NewSums, F, F0).
protect_avg(Max0,Max0,_Protected, _Domains, _ASize, _Reach) :- !.
protect_avg(I0, Max0, Protected, Domains, ASize, Reach) :-
I is I0+1,
Top is I+Reach,
( Top > ASize ;
arg(I, Domains, CD),
arg(Top, Domains, CD)
), !,
arg(I, Protected, yes),
protect_avg(I, Max0, Protected, Domains, ASize, Reach).
protect_avg(I0, Max0, Protected, Domains, ASize, Reach) :-
I is I0+1,
protect_avg(I, Max0, Protected, Domains, ASize, Reach).
%
% outer loop: generate array of sums at level j= Sum[j0...jMax]
%
expand_sums(_Parents, Max, _, Max, _Size, _Sums, _NewSums, F0, F0) :- !.
expand_sums(Parents, I0, Max0, Max, Size, Sums, NewSums, F, F0) :-
expand_sums(_Parents, Max, _, Max, _Size, _Sums, _P, _NewSums, F0, F0) :- !.
expand_sums(Parents, I0, Max0, Max, Size, Sums, Prot, NewSums, [O=SUM|F], F0) :-
I is I0+1,
arg(I, Prot, P),
var(P), !,
arg(I, NewSums, O),
sum_all(Parents, 0, I0, Max0, Sums, List),
to_disj(List, SUM),
expand_sums(Parents, I, Max0, Max, Size, Sums, NewSums, F, [O=SUM|F0]).
expand_sums(Parents, I, Max0, Max, Size, Sums, Prot, NewSums, F, F0).
expand_sums(Parents, I0, Max0, Max, Size, Sums, Prot, NewSums, F, F0) :-
I is I0+1,
arg(I, Sums, O),
arg(I, NewSums, O),
expand_sums(Parents, I, Max0, Max, Size, Sums, Prot, NewSums, F, F0).
%
%inner loop: find all parents that contribute to A_ji,
% that is generate Pk*Sum_(j-1)l and k+l st k+l = i
%
sum_all([], _, _, _, _, []).
sum_all([V|Vs], Pos, I, Max0, Sums, [V*S0|List]) :-
sum_all([V|Vs], Pos, I, Max0, Sums, [O|List]) :-
J is I-Pos,
J >= 0,
J =< Max0, !,
J1 is J+1,
arg(J1, Sums, S0),
( J < I -> O = V*S0 ; O = S0*V ),
Pos1 is Pos+1,
sum_all(Vs, Pos1, I, Max0, Sums, List).
sum_all([_V|Vs], Pos, I, Max0, Sums, List) :-
Pos1 is Pos+1,
sum_all(Vs, Pos1, I, Max0, Sums, List).
gen_arg(J, Sums, Max, S0) :-
gen_arg(0, Max, J, Sums, S0).
gen_arg(Max, Max, J, Sums, S0) :- !,
I is Max+1,
arg(I, Sums, A),
( Max = J -> S0 = A ; S0 = not(A)).
gen_arg(I0, Max, J, Sums, S) :-
I is I0+1,
arg(I, Sums, A),
( I0 = J -> S = A*S0 ; S = not(A)*S0),
gen_arg(I, Max, J, Sums, S0).
avg_borders(Size, Size, _Max, []) :- !.
avg_borders(I0, Size, Max, [J|Vals]) :-
I is I0+1,
Border is (I*Max)/Size,
J is integer(round(Border)),
avg_borders(I, Size, Max, Vals).
avg_domains(Size, Size, _J, _Max, []).
avg_domains(I0, Size, J0, Max, Vals) :-
I is I0+1,
Border is (I*Max)/Size,
fetch_domain_for_avg(J0, Border, J, I0, Vals, ValsI),
avg_domains(I, Size, J, Max, ValsI).
fetch_domain_for_avg(J, Border, J, _, Vals, Vals) :-
J > Border, !.
fetch_domain_for_avg(J0, Border, J, I0, [I0|LVals], RLVals) :-
J1 is J0+1,
fetch_domain_for_avg(J1, Border, J, I0, LVals, RLVals).
generate_avg(Size, Size, _J, _Max, [], [], [], F, F).
generate_avg(I0, Size, J0, Max, LSums, [O|OVs], [Ev|Evs], [O=Disj*Ev|F], F0) :-
generate_avg(I0, Size, J0, Max, LSums, [O|OVs], [Ev|Evs], [O=Ev*Disj|F], F0) :-
I is I0+1,
Border is (I*Max)/Size,
fetch_for_avg(J0, Border, J, LSums, MySums, RSums),
@ -313,18 +494,25 @@ to_disj2([V,V1|Vs], V0, Out) :-
% look for parameters in the rb-tree, or add a new.
% distid is the key
%
check_p(DistId, Parms, ParmVars, Ps, Ps) :-
rb_lookup(DistId, theta(Parms, ParmVars), Ps), !.
check_p(DistId, Parms, ParmVars, Ps, PsF) :-
check_p(DistId, Map, Parms, ParmVars, Ps, Ps) :-
rb_lookup(DistId-Map, theta(Parms, ParmVars), Ps), !.
check_p(DistId, Map, Parms, ParmVars, Ps, PsF) :-
get_dist_params(DistId, Parms0),
length(Parms0, L0),
get_dist_all_sizes(DistId, Sizes),
swap_parms(Parms0, Sizes, [0|Map], Parms1),
length(Parms1, L0),
get_dist_domain_size(DistId, Size),
L1 is L0 div Size,
L is L0-L1,
initial_maxes(L1, Multipliers),
copy(L, Multipliers, NextMults, NextMults, Parms0, Parms, ParmVars),
copy(L, Multipliers, NextMults, NextMults, Parms1, Parms, ParmVars),
%writeln(t:Size:Parms0:Parms:ParmVars),
rb_insert(Ps, DistId, theta(Parms, ParmVars), PsF).
rb_insert(Ps, DistId-Map, theta(Parms, ParmVars), PsF).
swap_parms(Parms0, Sizes, Map, Parms1) :-
matrix_new(floats, Sizes, Parms0, T0),
matrix_shuffle(T0,Map,TF),
matrix_to_list(TF, Parms1).
%
% we are using switches by two
@ -341,18 +529,19 @@ copy(N, D.Ds, ND.NDs, New, El.Parms0, NEl.Parms, V.ParmVars) :-
N1 is N-1,
(El == 0.0 ->
NEl = 0,
ND = D,
V = NEl
V = NEl,
ND = D
;El == 1.0 ->
NEl = 1,
ND = 0.0,
V = NEl
V = NEl,
ND = 0.0
;El == 0 ->
NEl = 0,
ND = D,
V = NEl
V = NEl,
ND = D
;El =:= 1 ->
NEl = 1,
V = NEl,
ND = 0.0,
V = NEl
;
@ -539,52 +728,6 @@ eval_outs((V=F).Outs) :-
V = NF,
eval_outs(Outs).
%simplify_exp(V,V) :- !.
simplify_exp(V,V) :- var(V), !.
simplify_exp(S1+S2,NS) :- !,
simplify_exp(S1, SS1),
simplify_exp(S2, SS2),
simplify_sum(SS1, SS2, NS).
simplify_exp(S1*S2,NS) :- !,
simplify_exp(S1, SS1),
simplify_exp(S2, SS2),
simplify_prod(SS1, SS2, NS).
simplify_exp(not(S),NS) :- !,
simplify_exp(S, SS),
simplify_not(SS, NS).
simplify_exp(S,S).
simplify_sum(V1, V2, O) :-
( var(V1) ->
( var(V2) ->
( V1 == V2 -> O = V1 ; O = V1+V2 ) ; /* var(V1) , var(V2) */
( V2 == 0 -> O = V1 ; V2 == 1 -> O = 1 ; O = V1+V2 ) /* var(V1) , nonvar(V2) */
) ;
( var(V2) ->
( V1 == 0 -> O = V2 ; V1 == 1 -> O = 1 ; O = V1+V2 ) ; /* nonvar(V1) , var(V2) */
( V2 == 0 -> O = V1 ; V2 == 1 -> O = 1 ; V1 == 0 -> O = V2 ; V1 == 1 -> O = 1; O = V1+V2 ) /* nonvar(V1) , nonvar(V2) */
)
).
simplify_prod(V1, V2, O) :-
( var(V1) ->
( var(V2) ->
( V1 == V2 -> O = V1 ; O = V1*V2 ) ; /* var(V1) , var(V2) */
( V2 == 0 -> O = 0 ; V2 == 1 -> O = V1 ; O = V1*V2 ) /* var(V1) , nonvar(V2) */
) ;
( var(V2) ->
( V1 == 0 -> O = 0 ; V1 == 1 -> O = V2 ; O = V1*V2 ) ; /* nonvar(V1) , var(V2) */
( V2 == 0 -> O = 0 ; V2 == 1 -> O = V1 ; V1 == 0 -> O = 0 ; V1 == 1 -> O = V2; V1 == V2 -> O = V1 ; O = V1*V2 ) /* nonvar(V1) , nonvar(V2) */
)
).
simplify_not(V, not(V)) :- var(V), !.
simplify_not(0, 1) :- !.
simplify_not(1, 0) :- !.
simplify_not(SS, not(SS)).
run_bdd_solver([[V]], LPs, bdd(Term, _Leaves, Nodes)) :-
build_out_node(Nodes, Node),
findall(Prob, get_prob(Term, Node, V, Prob),TermProbs),
@ -612,9 +755,9 @@ get_prob(Term, Node, V, SP) :-
build_bdd(Bindings, NVs, VTheta, Theta, Bdd) :-
bdd_from_list(Bindings, NVs, Bdd),
bdd_size(Bdd, Len),
% number_codes(Len,Codes),
% atom_codes(Name,Codes),
% bdd_print(Bdd, Name),
number_codes(Len,Codes),
atom_codes(Name,Codes),
bdd_print(Bdd, Name),
writeln(length=Len),
VTheta = Theta.

21
packages/CLPBN/clpbn/bp.yap
View File

@ -10,7 +10,7 @@
check_if_bp_done/1,
init_bp_solver/4,
run_bp_solver/3,
call_bp_ground/5,
call_bp_ground/6,
finalize_bp_solver/1
]).
@ -57,7 +57,8 @@
]).
call_bp_ground(QueryKeys, AllKeys, Factors, Evidence, Output) :-
call_bp_ground(QueryVars, QueryKeys, AllKeys, Factors, Evidence, Output) :-
writeln(here:Factors),
b_hash_new(Hash0),
keys_to_ids(AllKeys, 0, Hash0, Hash),
get_factors_type(Factors, Type),
@ -73,8 +74,13 @@ call_bp_ground(QueryKeys, AllKeys, Factors, Evidence, Output) :-
%get_vars_information(AllKeys, StatesNames),
%set_vars_information(AllKeys, StatesNames),
run_solver(ground(Network,Hash), QueryKeys, Solutions),
<<<<<<< HEAD
%writeln(answer:Solutions),
%clpbn_bind_vals([QueryKeys], Solutions, Output).
=======
writeln(answer:Solutions),
clpbn_bind_vals([QueryVars], Solutions, Output),
>>>>>>> 5a8cc421d2ea7a8135f84d935752e5ecb453fe99
free_ground_network(Network).
@ -95,8 +101,8 @@ keys_to_ids([Key|AllKeys], I0, Hash0, Hash) :-
keys_to_ids(AllKeys, I, HashI, Hash).
get_factors_type([f(bayes, _, _)|_], bayes) :- ! .
get_factors_type([f(markov, _, _)|_], markov) :- ! .
get_factors_type([f(bayes, _, _, _)|_], bayes) :- ! .
get_factors_type([f(markov, _, _, _)|_], markov) :- ! .
list_of_keys_to_ids([], _, []).
@ -106,9 +112,8 @@ list_of_keys_to_ids([Key|QueryKeys], Hash, [Id|QueryIds]) :-
factors_to_ids([], _, []).
factors_to_ids([f(_, Keys, CPT)|Fs], Hash, [f(Ids, Ranges, CPT, DistId)|NFs]) :-
factors_to_ids([f(_, DistId, Keys, CPT)|Fs], Hash, [f(Ids, Ranges, CPT, DistId)|NFs]) :-
list_of_keys_to_ids(Keys, Hash, Ids),
DistId = 0,
get_ranges(Keys, Ranges),
factors_to_ids(Fs, Hash, NFs).
@ -145,8 +150,8 @@ bp([QueryVars], AllVars, Output) :-
init_bp_solver(_, AllVars0, _, bp(BayesNet, DistIds)) :-
%check_for_agg_vars(AllVars0, AllVars),
get_vars_info(AllVars, VarsInfo, DistIds0),
%check_for_agg_vars(AllVars0, AllVars),
get_vars_info(AllVars0, VarsInfo, DistIds0),
sort(DistIds0, DistIds),
create_ground_network(VarsInfo, BayesNet),
true.

2
packages/CLPBN/clpbn/bp/examples/city.yap
View File

@ -2,7 +2,7 @@
:- clpbn_horus:set_solver(fove).
%:- clpbn_horus:set_solver(hve).
%:- clpbn_horus:set_solver(bp).
:- clpbn_horus:set_solver(bp).
%:- clpbn_horus:set_solver(cbp).

10
packages/CLPBN/clpbn/display.yap
View File

@ -8,6 +8,8 @@
:- use_module(library(clpbn/dists), [get_dist_domain/2]).
:- use_module(library(clpbn), [use_parfactors/1]).
:- attribute posterior/4.
@ -44,9 +46,11 @@ clpbn_bind_vals([Vs|MoreVs],[Ps|MorePs],AllDiffs) :-
clpbn_bind_vals2([],_,_) :- !.
% simple case, we want a distribution on a single variable.
%bind_vals([V],Ps) :- !,
% clpbn:get_atts(V, [dist(Vals,_,_)]),
% put_atts(V, posterior([V], Vals, Ps)).
bind_vals([V],Ps) :-
use_parfactors(on), !,
clpbn:get_atts(V, [key(K)]),
pfl:skolem(K,Vals),
put_atts(V, posterior([V], Vals, Ps)).
% complex case, we want a joint distribution, do it on a leader.
% should split on cliques ?
clpbn_bind_vals2(Vs,Ps,AllDiffs) :-

18
packages/CLPBN/clpbn/dists.yap
View File

@ -15,6 +15,7 @@
get_dist_domain_size/2,
get_dist_params/2,
get_dist_key/2,
get_dist_all_sizes/2,
get_evidence_position/3,
get_evidence_from_position/3,
dist_to_term/2,
@ -177,21 +178,21 @@ add_dist(Domain, Type, CPT, Parents, Key, Id) :-
length(CPT, CPTSize),
length(Domain, DSize),
new_id(Id),
record_parent_sizes(Parents, Id, PSizes, [DSize|PSizes]),
find_parent_sizes(Parents, Id, PSizes, [DSize|PSizes]),
recordz(clpbn_dist_db,db(Id, Key, CPT, Type, Domain, CPTSize, DSize),_).
record_parent_sizes([], Id, [], DSizes) :-
find_parent_sizes([], Id, [], DSizes) :-
recordz(clpbn_dist_psizes,db(Id, DSizes),_).
record_parent_sizes([P|Parents], Id, [Size|Sizes], DSizes) :-
find_parent_sizes([P|Parents], Id, [Size|Sizes], DSizes) :-
integer(P), !,
Size = P,
record_parent_sizes(Parents, Id, Sizes, DSizes).
record_parent_sizes([P|Parents], Id, [Size|Sizes], DSizes) :-
find_parent_sizes(Parents, Id, Sizes, DSizes).
find_parent_sizes([P|Parents], Id, [Size|Sizes], DSizes) :-
clpbn:get_atts(P,dist(Dist,_)), !,
get_dist_domain_size(Dist, Size),
record_parent_sizes(Parents, Id, Sizes, DSizes).
record_parent_sizes([_|_], _, _, _).
find_parent_sizes(Parents, Id, Sizes, DSizes).
find_parent_sizes([_|_], _, _, _).
%
% Often, * is used to code empty in HMMs.
@ -228,6 +229,9 @@ get_dsizes([P|Parents], [Sz|Sizes], Sizes0) :-
get_dist_params(Id, Parms) :-
recorded(clpbn_dist_db, db(Id, _, Parms, _, _, _, _), _).
get_dist_all_sizes(Id, DSizes) :-
recorded(clpbn_dist_psizes,db(Id, DSizes),_).
get_dist_domain_size(DistId, DSize) :-
use_parfactors(on), !,
pfl:get_pfl_parameters(DistId, Dist),

15
packages/CLPBN/clpbn/ground_factors.yap
View File

@ -28,9 +28,9 @@
:- use_module(library(clpbn/dists), [
dist/4]).
:- dynamic currently_defined/1, f/3.
:- dynamic currently_defined/1, f/4.
generate_network(QueryVars0, QueryKeys0, Keys, Factors, Evidence) :-
generate_network(QueryVars0, QueryKeys, Keys, Factors, Evidence) :-
attributes:all_attvars(AVars),
keys(QueryVars0, QueryKeys0),
check_for_evidence(AVars, EVars, QueryKeys0, QueryVars0, Evidence),
@ -40,11 +40,11 @@ generate_network(QueryVars0, QueryKeys0, Keys, Factors, Evidence) :-
do_network([], _, _, _) :- !.
do_network(QueryVars, EVars, Keys, Factors) :-
retractall(currently_defined(_)),
retractall(f(_,_,_)),
retractall(f(_,_,_,_)),
run_through_factors(QueryVars),
run_through_factors(EVars),
findall(K, currently_defined(K), Keys),
findall(f(FType,FKeys,FCPT), f(FType,FKeys,FCPT), Factors).
findall(f(FType,FId,FKeys,FCPT), f(FType,FId,FKeys,FCPT), Factors).
%
% look for attributed vars with evidence (should also search the DB)
@ -110,10 +110,11 @@ find_factors(K) :-
\+ currently_defined(K1),
find_factors(K1).
add_factor(factor(Type, _Id, Ks, _, CPT, Constraints), Ks) :-
F = f(Type, Ks, CPT),
add_factor(factor(Type, Id, Ks, _, Phi, Constraints), Ks) :-
F = f(Type, Id, Ks, CPT),
( is_list(Phi) -> CPT = Phi ; call(user:Phi, CPT) ),
run(Constraints),
\+ f(Type, Ks, CPT),
\+ f(Type, Id, Ks, CPT),
assert(F).
run([Goal|Goals]) :-

8
packages/CLPBN/examples/School/school32_data.yap
View File

@ -425,7 +425,7 @@ registration(r65,c22,s20).
registration(r66,c43,s20).
registration(r67,c17,s21).
registration(r68,c34,s21).
registration(r69,c0,s21).
%registration(r69,c0,s21).
registration(r70,c42,s22).
registration(r71,c7,s22).
registration(r72,c46,s22).
@ -515,7 +515,7 @@ registration(r155,c57,s46).
registration(r156,c25,s46).
registration(r157,c46,s46).
registration(r158,c15,s46).
registration(r159,c0,s47).
%registration(r159,c0,s47).
registration(r160,c33,s47).
registration(r161,c30,s47).
registration(r162,c55,s47).
@ -544,7 +544,7 @@ registration(r184,c50,s54).
registration(r185,c43,s54).
registration(r186,c55,s54).
registration(r187,c14,s55).
registration(r188,c0,s55).
%registration(r188,c0,s55).
registration(r189,c31,s55).
registration(r190,c47,s55).
registration(r191,c50,s56).
@ -600,7 +600,7 @@ registration(r240,c20,s71).
registration(r241,c18,s71).
registration(r242,c38,s71).
registration(r243,c37,s72).
registration(r244,c0,s72).
%registration(r244,c0,s72).
registration(r245,c62,s72).
registration(r246,c47,s73).
registration(r247,c53,s73).

3
packages/CLPBN/pfl.yap
View File

@ -27,6 +27,9 @@
[clpbn_flag/2 as pfl_flag,
set_clpbn_flag/2 as set_pfl_flag]).
:- reexport(library(clpbn/horus),
[set_solver/1]).
:- ( % if clp(bn) has done loading, we're top-level
predicate_property(set_pfl_flag(_,_), imported_from(clpbn))
->