diff --git a/library/dgraphs.yap b/library/dgraphs.yap index 73e9e7da6..7dfb1d320 100644 --- a/library/dgraphs.yap +++ b/library/dgraphs.yap @@ -210,27 +210,21 @@ delete_remaining_edges(SortedVs,Vs0,Vsf) :- dgraph_transpose(Graph, TGraph) :- rb_visit(Graph, Edges), - rb_clone(Graph, TGraph, NewNodes), - tedges(Edges,UnsortedTEdges), - sort(UnsortedTEdges,TEdges), - fill_nodes(NewNodes,TEdges). + transpose(Edges, Nodes, TEdges, []), + dgraph_new(G0), + % make sure we have all vertices, even if they are unconnected. + dgraph_add_vertices(G0, Nodes, G1), + dgraph_add_edges(G1, TEdges, TGraph). -tedges([],[]). -tedges([V-Vs|Edges],TEdges) :- - fill_tedges(Vs, V, TEdges, TEdges0), - tedges(Edges,TEdges0). +transpose([], []) --> []. +transpose([V-Edges|MoreVs], [V|Vs]) --> + transpose_edges(Edges, V), + transpose(MoreVs, Vs). -fill_tedges([], _, TEdges, TEdges). -fill_tedges([V1|Vs], V, [V1-V|TEdges], TEdges0) :- - fill_tedges(Vs, V, TEdges, TEdges0). - - -fill_nodes([],[]). -fill_nodes([V-[Child|MoreChildren]|Nodes],[V-Child|Edges]) :- !, - get_extra_children(Edges,V,MoreChildren,REdges), - fill_nodes(Nodes,REdges). -fill_nodes([_-[]|Edges],TEdges) :- - fill_nodes(Edges,TEdges). +transpose_edges([], _V) --> []. +transpose_edges(E.Edges, V) --> + [E-V], + transpose_edges(Edges, V). dgraph_compose(T1,T2,CT) :- rb_visit(T1,Nodes), diff --git a/library/tries/core_tries.c b/library/tries/core_tries.c index e7fa6acad..24bb31c6a 100644 --- a/library/tries/core_tries.c +++ b/library/tries/core_tries.c @@ -463,6 +463,7 @@ void core_trie_save(TrNode node, FILE *file, void (*save_function)(TrNode, FILE fprintf(file, "BEGIN_TRIE_v2 "); traverse_and_save(TrNode_child(node), file, 0); fprintf(file, "END_TRIE_v2"); + fflush(file); } return; } @@ -486,6 +487,7 @@ TrNode core_trie_load(TrEngine engine, FILE *file, void (*load_function)(TrNode, fprintf(stderr, "******************************************\n"); fprintf(stderr, " Tries core module: trie file corrupted\n"); fprintf(stderr, "******************************************\n"); + fflush(stderr); return NULL; } if (fsetpos(file, &curpos)) @@ -498,6 +500,7 @@ TrNode core_trie_load(TrEngine engine, FILE *file, void (*load_function)(TrNode, fprintf(stderr, "******************************************\n"); fprintf(stderr, " Tries core module: trie file corrupted\n"); fprintf(stderr, "******************************************\n"); + fflush(stderr); return NULL; } if (fsetpos(file, &curpos)) @@ -507,6 +510,7 @@ TrNode core_trie_load(TrEngine engine, FILE *file, void (*load_function)(TrNode, fprintf(stderr, "****************************************\n"); fprintf(stderr, " Tries core module: invalid trie file\n"); fprintf(stderr, "****************************************\n"); + fflush(stderr); return NULL; } CURRENT_TRIE_ENGINE = engine; @@ -563,6 +567,7 @@ void core_trie_print(TrNode node, void (*print_function)(TrNode)) { traverse_and_print(TrNode_child(node), arity, str, 0, TRIE_PRINT_NORMAL); } else fprintf(stdout, "(empty)\n"); + fflush(stdout); return; } @@ -611,14 +616,15 @@ TrNode put_entry(TrNode node, YAP_Term entry) { } else if (YAP_IsIntTerm(t)) { node = trie_node_check_insert(node, t); } else if (YAP_IsFloatTerm(t)) { - volatile double f; - volatile YAP_Term *p; - f = YAP_FloatOfTerm(t); - p = (YAP_Term *)((void *) &f); /* to avoid gcc warning */ + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ + tf.f = YAP_FloatOfTerm(t); node = trie_node_check_insert(node, FloatInitTag); - node = trie_node_check_insert(node, *p); + node = trie_node_check_insert(node, tf.p[0]); #ifdef TAG_LOW_BITS_32 - node = trie_node_check_insert(node, *(p + 1)); + node = trie_node_check_insert(node, tf.p[1]); #endif /* TAG_LOW_BITS_32 */ node = trie_node_check_insert(node, FloatEndTag); } else if (YAP_IsPairTerm(t)) { @@ -671,6 +677,7 @@ TrNode put_entry(TrNode node, YAP_Term entry) { fprintf(stderr, "***************************************\n"); fprintf(stderr, " Tries core module: unknown type tag\n"); fprintf(stderr, "***************************************\n"); + fflush(stderr); } return node; @@ -698,16 +705,17 @@ TrNode check_entry(TrNode node, YAP_Term entry) { if (!(node = trie_node_check(node, t))) return NULL; } else if (YAP_IsFloatTerm(t)) { - volatile double f; - volatile YAP_Term *p; - f = YAP_FloatOfTerm(t); - p = (YAP_Term *)((void *) &f); /* to avoid gcc warning */ + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ + tf.f = YAP_FloatOfTerm(t); if (!(node = trie_node_check(node, FloatInitTag))) return NULL; - if (!(node = trie_node_check(node, *p))) + if (!(node = trie_node_check(node, tf.p[0]))) return NULL; #ifdef TAG_LOW_BITS_32 - if (!(node = trie_node_check(node, *(p + 1)))) + if (!(node = trie_node_check(node, tf.p[1]))) return NULL; #endif /* TAG_LOW_BITS_32 */ if (!(node = trie_node_check(node, FloatEndTag))) @@ -777,6 +785,7 @@ TrNode check_entry(TrNode node, YAP_Term entry) { fprintf(stderr, "***************************************\n"); fprintf(stderr, " Tries core module: unknown type tag\n"); fprintf(stderr, "***************************************\n"); + fflush(stderr); } return node; @@ -797,6 +806,7 @@ YAP_Term get_entry(TrNode node, YAP_Term *stack_mark, TrNode *cur_node) { fprintf(stderr, "**************************************\n"); fprintf(stderr, " Tries core module: term stack full\n"); fprintf(stderr, "**************************************\n"); + fflush(stderr); } for (i = index; i > CURRENT_INDEX; i--) stack_vars_base[i] = 0; @@ -864,17 +874,18 @@ YAP_Term get_entry(TrNode node, YAP_Term *stack_mark, TrNode *cur_node) { *cur_node = node; return t; } else if (t == FloatEndTag) { - volatile double f; - volatile YAP_Term *p; - p = (YAP_Term *)((void *) &f); /* to avoid gcc warning */ + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ #ifdef TAG_LOW_BITS_32 node = TrNode_parent(node); - *(p + 1) = TrNode_entry(node); + tf.p[1] = TrNode_entry(node); #endif /* TAG_LOW_BITS_32 */ node = TrNode_parent(node); - *p = TrNode_entry(node); + tf.p[0] = TrNode_entry(node); node = TrNode_parent(node); /* ignore FloatInitTag */ - t = YAP_MkFloatTerm(f); + t = YAP_MkFloatTerm(tf.f); PUSH_UP(stack_args, t, stack_vars); } else if (t == FloatInitTag) { } @@ -888,6 +899,7 @@ YAP_Term get_entry(TrNode node, YAP_Term *stack_mark, TrNode *cur_node) { fprintf(stderr, "***************************************\n"); fprintf(stderr, " Tries core module: unknown type tag\n"); fprintf(stderr, "***************************************\n"); + fflush(stderr); } node = TrNode_parent(node); } @@ -1462,7 +1474,7 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m memcpy(arity, current_arity, sizeof(int) * (current_arity[0] + 1)); if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) { /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ - if (str[str_index - 1] != '[') + if (str_index > 0 && str[str_index - 1] != '[') str[str_index - 1] = ','; /* restore possible PairEndTermTag side-effect */ if (str[last_pair_mark] == '|') @@ -1481,7 +1493,7 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m memcpy(arity, current_arity, sizeof(int) * (current_arity[0] + 1)); if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) { /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ - if (str[str_index - 1] != '[') + if (str_index > 0 && str[str_index - 1] != '[') str[str_index - 1] = ','; /* restore possible PairEndTermTag side-effect */ if (str[last_pair_mark] == '|') @@ -1500,19 +1512,21 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m arity[arity[0]] = (YAP_Int) t; mode = TRIE_PRINT_FLOAT2; } else if (mode == TRIE_PRINT_FLOAT2) { - volatile double f; - volatile YAP_Term *p; - p = (YAP_Term *)((void *) &f); /* to avoid gcc warning */ - *(p + 1) = t; - *p = (YAP_Term) arity[arity[0]]; + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ + tf.p[1] = t; + tf.p[0] = (YAP_Term) arity[arity[0]]; arity[arity[0]] = -1; #else /* TAG_64BITS */ - volatile double f; - volatile YAP_Term *p; - p = (YAP_Term *)((void *) &f); /* to avoid gcc warning */ - *p = t; + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ + tf.p[0] = t; #endif /* TAG_SCHEME */ - str_index += sprintf(& str[str_index], "%.15g", f); + str_index += sprintf(& str[str_index], "%.15g", tf.f); mode = TRIE_PRINT_FLOAT_END; } else if (mode == TRIE_PRINT_FLOAT_END) { arity[0]--; @@ -1609,6 +1623,7 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m fprintf(stderr, "***************************************\n"); fprintf(stderr, " Tries core module: unknown type tag\n"); fprintf(stderr, "***************************************\n"); + fflush(stderr); } if (arity[0]) { @@ -1696,6 +1711,7 @@ YAP_Term trie_to_list_node(TrNode node) { fprintf(stderr, "***************************************\n"); fprintf(stderr, " Tries core module: unknown type tag\n"); fprintf(stderr, "***************************************\n"); + fflush(stderr); return YAP_MkAtomTerm(YAP_LookupAtom("fail")); } @@ -1709,7 +1725,7 @@ YAP_Term trie_to_list_node(TrNode node) { #ifdef TAG_LOW_BITS_32 static inline -YAP_Term trie_to_list_floats_tag_low_32(YAP_Term result, TrNode node, volatile YAP_Term **p, volatile double *f) { +YAP_Term trie_to_list_floats_tag_low_32(YAP_Term result, TrNode node, volatile YAP_Term *p, volatile double *f) { if(IS_HASH_NODE(node)) { TrNode *first_bucket, *bucket; TrHash hash = (TrHash) node; @@ -1720,16 +1736,15 @@ YAP_Term trie_to_list_floats_tag_low_32(YAP_Term result, TrNode node, volatile Y do { if(*--bucket) { node = *bucket; - do { - *(*p + 1) = TrNode_entry(node); + p[1] = TrNode_entry(node); PUSH_NEW_FLOAT_TERM(*f); } while((node = TrNode_next(node))); } } while (bucket != first_bucket); } else { do { - *(*p + 1) = TrNode_entry(node); + p[1] = TrNode_entry(node); PUSH_NEW_FLOAT_TERM(*f); } while((node = TrNode_next(node))); } @@ -1741,11 +1756,12 @@ YAP_Term trie_to_list_floats_tag_low_32(YAP_Term result, TrNode node, volatile Y static YAP_Term trie_to_list_floats(TrNode node) { - volatile double f; - volatile YAP_Term *p; + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ YAP_Term result = YAP_MkAtomTerm(YAP_LookupAtom("[]")); - p = (YAP_Term *)((void *) &f); /* to avoid gcc warning */ if (IS_HASH_NODE(node)) { TrNode *first_bucket, *bucket; TrHash hash = (TrHash) node; @@ -1755,22 +1771,22 @@ YAP_Term trie_to_list_floats(TrNode node) { if (*--bucket) { node = *bucket; do { - *p = TrNode_entry(node); + tf.p[0] = TrNode_entry(node); #ifdef TAG_LOW_BITS_32 - result = trie_to_list_floats_tag_low_32(result, TrNode_child(node), &p, &f); + result = trie_to_list_floats_tag_low_32(result, TrNode_child(node), &tf.p, &tf.f); #else - PUSH_NEW_FLOAT_TERM(f); + PUSH_NEW_FLOAT_TERM(tf.f); #endif /* TAG_LOW_BITS_32 */ } while((node = TrNode_next(node))); } } while (bucket != first_bucket); } else { do { - *p = TrNode_entry(node); + tf.p[0] = TrNode_entry(node); #ifdef TAG_LOW_BITS_32 - result = trie_to_list_floats_tag_low_32(result, TrNode_child(node), &p, &f); + result = trie_to_list_floats_tag_low_32(result, TrNode_child(node), &tf.p, &tf.f); #else - PUSH_NEW_FLOAT_TERM(f); + PUSH_NEW_FLOAT_TERM(tf.f); #endif /* TAG_LOW_BITS_32 */ } while((node = TrNode_next(node))); } diff --git a/library/tries/core_tries.h b/library/tries/core_tries.h index f627911be..e9029ed26 100644 --- a/library/tries/core_tries.h +++ b/library/tries/core_tries.h @@ -14,8 +14,10 @@ #include "config.h" #if SIZEOF_INT_P==4 #define TAG_LOW_BITS_32 /* 'Tags_32LowTag.h' tagging scheme */ +#define SIZE_FLOAT_AS_TERM 2 #elif SIZEOF_INT_P==8 #define TAG_64BITS /* 'Tags_64bits.h' tagging scheme */ +#define SIZE_FLOAT_AS_TERM 1 #else #error Unknown tagging scheme #endif /* YAP_SCHEME */ diff --git a/packages/CLPBN/clpbn/connected.yap b/packages/CLPBN/clpbn/connected.yap index 7b0e90860..276184683 100644 --- a/packages/CLPBN/clpbn/connected.yap +++ b/packages/CLPBN/clpbn/connected.yap @@ -1,172 +1,144 @@ :- module(clpbn_connected, - [clpbn_subgraphs/2, - influences/4, + [influences/3, init_influences/3, - influences/5]). + influences/4]). :- use_module(library(dgraphs), [dgraph_new/1, dgraph_add_edges/3, dgraph_add_vertex/3, dgraph_neighbors/3, - dgraph_edge/3]). + dgraph_edge/3, + dgraph_transpose/2]). :- use_module(library(rbtrees), [rb_new/1, + rb_lookup/3, rb_insert/4, - rb_lookup/3]). + rb_visit/2]). -:- attribute component/1. - -% search for connected components, that is, where we know that A influences B or B influences A. -clpbn_subgraphs(Vs, Gs) :- - mark_components(Vs, Components), - keysort(Components, Ordered), - same_key(Ordered, Gs). - -% ignore variables with evidence, -% the others mark the MB. -mark_components([], []). -mark_components([V|Vs], Components) :- - clpbn:get_atts(V, [evidence(_),dist(_,Parents)]), !, - merge_parents(Parents, _), - mark_components(Vs, Components). -mark_components([V|Vs], [Mark-V|Components]) :- - mark_var(V, Mark), - mark_components(Vs, Components). - -mark_var(V, Mark) :- - get_atts(V, [component(Mark)]), !, - clpbn:get_atts(V, [dist(_,Parents)]), !, - merge_parents(Parents, Mark). -mark_var(V, Mark) :- - clpbn:get_atts(V, [dist(_,Parents)]), !, - put_atts(V,[component(Mark)]), - merge_parents(Parents, Mark). - -merge_parents([], _). -merge_parents([V|Parents], Mark) :- - clpbn:get_atts(V,[evidence(_)]), !, - merge_parents(Parents, Mark). -merge_parents([V|Parents], Mark) :- - get_atts(V,[component(Mark)]), !, - merge_parents(Parents, Mark). -merge_parents([V|Parents], Mark) :- - put_atts(V,[component(Mark)]), - merge_parents(Parents, Mark). - - -same_key([],[]). -same_key([K-El|More],[[El|Els]|Gs]) :- - same_keys(More, K, Els, Rest), - same_key(Rest,Gs). - -same_keys([], _, [], []). -same_keys([K1-El|More], K, [El|Els], Rest) :- - K == K1, !, - same_keys(More, K, Els, Rest). -same_keys(Rest, _, [], Rest). - -influences_more([], _, _, Is, Is, Evs, Evs, V2, V2). -influences_more([V|LV], G, RG, Is0, Is, Evs0, Evs, GV0, GV2) :- - rb_lookup(V, _, GV0), !, - influences_more(LV, G, RG, Is0, Is, Evs0, Evs, GV0, GV2). -influences_more([V|LV], G, RG, Is0, Is, Evs0, Evs, GV0, GV3) :- - rb_insert(GV0, V, _, GV1), - follow_dgraph(V, G, RG, [V|Is0], Is1, [V|Evs0], Evs1, GV1, GV2), - influences_more(LV, G, RG, Is1, Is, Evs1, Evs, GV2, GV3). - -% search for the set of variables that influence V -influences(Vs, LV, Is, Evs) :- +influences(Vs, QVars, LV) :- init_influences(Vs, G, RG), - influences(LV, Is, Evs, G, RG). + influences(QVars, G, RG, LV). init_influences(Vs, G, RG) :- dgraph_new(G0), - dgraph_new(RG0), - to_dgraph(Vs, G0, G, RG0, RG). + to_dgraph(Vs, G0, G), + dgraph_transpose(G, RG). -influences([], [], [], _, _). -influences([V|LV], Is, Evs, G, RG) :- - rb_new(V0), - rb_insert(V0, V, _, V1), - follow_dgraph(V, G, RG, [V], Is1, [V], Evs1, V1, V2), - influences_more(LV, G, RG, Is1, Is, Evs1, Evs, V2, _). +to_dgraph([], G, G). +to_dgraph([V|Vs], G0, G) :- + clpbn:get_atts(V, [dist(_,Parents)]), !, + dgraph_add_vertex(G0, V, G00), + build_edges(Parents, V, Edges), + dgraph_add_edges(G00, Edges, G1), + to_dgraph(Vs, G1, G). -to_dgraph([], G, G, RG, RG). -to_dgraph([V|Vs], G0, G, RG0, RG) :- - clpbn:get_atts(V, [evidence(_),dist(_,Parents)]), !, - build_edges(Parents, V, Edges, REdges), - dgraph_add_edges(G0,[V-e|Edges],G1), - dgraph_add_edges(RG0,REdges,RG1), - to_dgraph(Vs, G1, G, RG1, RG). -to_dgraph([V|Vs], G0, G, RG0, RG) :- - clpbn:get_atts(V, [dist(_,Parents)]), - build_edges(Parents, V, Edges, REdges), - dgraph_add_vertex(G0,V,G1), - dgraph_add_edges(G1, Edges, G2), - dgraph_add_vertex(RG0,V,RG1), - dgraph_add_edges(RG1, REdges, RG2), - to_dgraph(Vs, G2, G, RG2, RG). +build_edges([], _, []). +build_edges([P|Parents], V, [P-V|Edges]) :- + build_edges(Parents, V, Edges). +% search for the set of variables that influence V +influences(Vs, G, RG, Vars) :- + rb_new(Visited0), + influences(Vs, G, RG, Visited0, Visited), + all_top(Visited, Vars), +length(Vars,Leng), writeln(done:Leng). -build_edges([], _, [], []). -build_edges([P|Parents], V, [P-V|Edges], [V-P|REdges]) :- - build_edges(Parents, V, Edges, REdges). +influences([], _, _, Visited, Visited). +influences([V|LV], G, RG, Vs, NVs) :- + rb_lookup(V, T.B, Vs), T == t, B == b, !, + influences(LV, G, RG, Vs, NVs). +influences([V|LV], G, RG, Vs0, Vs3) :- + rb_insert(Vs0, V, t.b, Vs1), + process_new_variable(V, G, RG, Vs1, Vs2), + influences(LV, G, RG, Vs2, Vs3). -follow_dgraph(V, G, RG, Is0, IsF, Evs0, EvsF, Visited0, Visited) :- +process_new_variable(V, _G, _RG, _Vs0, _Vs1) :- + clpbn:get_atts(V,[evidence(Ev)]), !, + throw(error(bound_to_evidence(V/Ev))). +process_new_variable(V, G, RG, Vs0, Vs2) :- + dgraph_neighbors(V, G, Children), + throw_all_below(Children, G, RG, Vs0, Vs1), dgraph_neighbors(V, RG, Parents), - add_parents(Parents, G, RG, Is0, IsI, Evs0, EvsI, Visited0, Visited1), - dgraph_neighbors(V, G, Kids), - add_kids(Kids, G, RG, IsI, IsF, EvsI, EvsF, Visited1, Visited). + throw_all_above(Parents, G, RG, Vs1, Vs2). -add_parents([], _, _, Is, Is, Evs, Evs, Visited, Visited). -% been here already, can safely ignore. -add_parents([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :- - rb_lookup(V, _, Visited0), !, - add_parents(Vs, G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF). -% evidence node, -% just say that we visited it -add_parents([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :- - dgraph_edge(V,e,G), !, % has evidence - rb_insert(Visited0, V, _, VisitedI), - add_parents(Vs, G, RG, Is0, IsF, [V|Evs0], EvsF, VisitedI, VisitedF). -% non-evidence node, -% we will need to find its parents. -add_parents([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :- - rb_insert(Visited0, V, _, VisitedI), - follow_dgraph(V, G, RG, [V|Is0], IsI, [V|Evs0], EvsI, VisitedI, VisitedII), - add_parents(Vs, G, RG, IsI, IsF, EvsI, EvsF, VisitedII, VisitedF). - -add_kids([], _, _, Is, Is, Evs, Evs, Visited, Visited). -add_kids([V|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :- - dgraph_edge(V,e,G), % has evidence - % we will go there even if it was visited - ( rb_insert(Visited0, V, _, Visited1) -> - true - ; - % we've been there, but were we there as a father or as a kid? - not_in(Evs0, V), - Visited1 = Visited0 - ), - !, - dgraph_neighbors(V, RG, Parents), - add_parents(Parents, G, RG, Is0, Is1, [V|Evs0], EvsI, Visited1, VisitedI), - (Is1 = Is0 -> - % ignore whatever we did with this node, - % it didn't lead anywhere (all parents have evidence). - add_kids(Vs, G, RG, Is0, IsF, [V|Evs0], EvsF, Visited1, VisitedF) - ; - % insert parents - add_kids(Vs, G, RG, Is1, IsF, EvsI, EvsF, VisitedI, VisitedF) - ). -add_kids([_|Vs], G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF) :- - add_kids(Vs, G, RG, Is0, IsF, Evs0, EvsF, Visited0, VisitedF). +throw_all_below([], _, _, Vs, Vs). +throw_all_below(Child.Children, G, RG, Vs0, Vs2) :- +% clpbn:get_atts(Child,[key(K)]), rb_visit(Vs0, Pairs), writeln(down:Child:K:Pairs), + throw_below(Child, G, RG, Vs0, Vs1), + throw_all_below(Children, G, RG, Vs1, Vs2). + +% visited +throw_below(Child, G, RG, Vs0, Vs1) :- + rb_lookup(Child, _.B, Vs0), !, + ( + B == b -> + Vs0 = Vs1 % been there before + ; + B = b, % mark it + handle_ball_from_above(Child, G, RG, Vs0, Vs1) + ). +throw_below(Child, G, RG, Vs0, Vs2) :- + rb_insert(Vs0, Child, _.b, Vs1), + handle_ball_from_above(Child, G, RG, Vs1, Vs2). + +% share this with parents, if we have evidence +handle_ball_from_above(V, G, RG, Vs0, Vs1) :- + clpbn:get_atts(V,[evidence(_)]), !, + dgraph_neighbors(V, RG, Parents), + throw_all_above(Parents, G, RG, Vs0, Vs1). +% propagate to kids, if we do not +handle_ball_from_above(V, G, RG, Vs0, Vs1) :- + dgraph_neighbors(V, G, Children), + throw_all_below(Children, G, RG, Vs0, Vs1). +throw_all_above([], _, _, Vs, Vs). +throw_all_above(Parent.Parentren, G, RG, Vs0, Vs2) :- +% clpbn:get_atts(Parent,[key(K)]), rb_visit(Vs0, Pairs), writeln(up:Parent:K:Pairs), + throw_above(Parent, G, RG, Vs0, Vs1), + throw_all_above(Parentren, G, RG, Vs1, Vs2). -not_in([V1|_], V) :- V1 == V, !, fail. -not_in([_|Evs0], V) :- - not_in(Evs0, V). +% visited +throw_above(Parent, G, RG, Vs0, Vs1) :- + rb_lookup(Parent, T._, Vs0), !, + ( + T == t -> + Vs1 = Vs0 % been there before + ; + T = t, % mark it + handle_ball_from_below(Parent, G, RG, Vs0, Vs1) + ). +throw_above(Parent, G, RG, Vs0, Vs2) :- + rb_insert(Vs0, Parent, t._, Vs1), + handle_ball_from_below(Parent, G, RG, Vs1, Vs2). +% share this with parents, if we have evidence +handle_ball_from_below(V, _, _, Vs, Vs) :- + clpbn:get_atts(V,[evidence(_)]), !. +% propagate to kids, if we do not +handle_ball_from_below(V, G, RG, Vs0, Vs1) :- + dgraph_neighbors(V, RG, Parents), + propagate_ball_from_below(Parents, V, G, RG, Vs0, Vs1). + +propagate_ball_from_below([], V, G, RG, Vs0, Vs1) :- !, + dgraph_neighbors(V, G, Children), + throw_all_below(Children, G, RG, Vs0, Vs1). +propagate_ball_from_below(Parents, _V, G, RG, Vs0, Vs1) :- + throw_all_above(Parents, G, RG, Vs0, Vs1). + +all_top(T, Vs) :- + rb_visit(T, Pairs), + get_tops(Pairs, Vs). + +get_tops([], []). +get_tops([V-(T._)|Pairs], V.Vs) :- + T == t, !, + get_tops(Pairs, Vs). +get_tops([V-_|Pairs], V.Vs) :- + clpbn:get_atts(V,[evidence(_)]), !, + get_tops(Pairs, Vs). +get_tops(_.Pairs, Vs) :- + get_tops(Pairs, Vs). diff --git a/packages/CLPBN/clpbn/gibbs.yap b/packages/CLPBN/clpbn/gibbs.yap index 5e6323bf5..2a499b302 100644 --- a/packages/CLPBN/clpbn/gibbs.yap +++ b/packages/CLPBN/clpbn/gibbs.yap @@ -51,7 +51,7 @@ :- use_module(library('clpbn/connected'), [ - influences/4 + influences/3 ]). :- dynamic gibbs_params/3. @@ -73,7 +73,7 @@ init_gibbs_solver(GoalVs, Vs0, _, Vs) :- clean_up, term_variables(GoalVs, LVs), check_for_hidden_vars(Vs0, Vs0, Vs1), - influences(Vs1, LVs, _, Vs2), + influences(Vs1, LVs, Vs2), sort(Vs2,Vs). run_gibbs_solver(LVs, LPs, Vs) :- diff --git a/packages/CLPBN/clpbn/jt.yap b/packages/CLPBN/clpbn/jt.yap index bf5aef811..6828a002b 100644 --- a/packages/CLPBN/clpbn/jt.yap +++ b/packages/CLPBN/clpbn/jt.yap @@ -80,7 +80,7 @@ :- use_module(library('clpbn/connected'), [ init_influences/3, - influences/5 + influences/4 ]). @@ -98,7 +98,7 @@ init_jt_solver(LLVs, Vs0, _, State) :- init_jt_solver_for_questions([], _, _, []). init_jt_solver_for_questions([LLVs|MoreLLVs], G, RG, [state(JTree, Evidence)|State]) :- - influences(LLVs, _, NVs0, G, RG), + influences(LLVs, G, RG, NVs0), sort(NVs0, NVs), get_graph(NVs, BayesNet, CPTs, Evidence), build_jt(BayesNet, CPTs, JTree), diff --git a/packages/CLPBN/clpbn/ve.yap b/packages/CLPBN/clpbn/ve.yap index be2696bd1..41ed2b19f 100644 --- a/packages/CLPBN/clpbn/ve.yap +++ b/packages/CLPBN/clpbn/ve.yap @@ -44,7 +44,7 @@ :- use_module(library('clpbn/connected'), [ init_influences/3, - influences/5 + influences/4 ]). :- use_module(library('clpbn/matrix_cpt_utils'), @@ -87,7 +87,7 @@ init_ve_solver(Qs, Vs0, _, LVis) :- init_ve_solver_for_questions([], _, _, [], []). init_ve_solver_for_questions([Vs|MVs], G, RG, [NVs|MNVs0], [NVs|LVis]) :- - influences(Vs, _, NVs0, G, RG), + influences(Vs, G, RG, NVs0), sort(NVs0, NVs), %clpbn_gviz:clpbn2gviz(user_error, test, NVs, Vs), init_ve_solver_for_questions(MVs, G, RG, MNVs0, LVis). diff --git a/packages/CLPBN/examples/sprinkler.yap b/packages/CLPBN/examples/sprinkler.yap index e8cc62742..f0be31fee 100644 --- a/packages/CLPBN/examples/sprinkler.yap +++ b/packages/CLPBN/examples/sprinkler.yap @@ -1,4 +1,6 @@ +:- style_check(all). + :- ensure_loaded(library(clpbn)). wet_grass(W) :- diff --git a/packages/CLPBN/learning/em.yap b/packages/CLPBN/learning/em.yap index 234912f3f..a09eac3f0 100644 --- a/packages/CLPBN/learning/em.yap +++ b/packages/CLPBN/learning/em.yap @@ -22,9 +22,6 @@ randomise_all_dists/0, uniformise_all_dists/0]). -:- use_module(library('clpbn/connected'), - [clpbn_subgraphs/2]). - :- use_module(library('clpbn/learning/learn_utils'), [run_all/1, clpbn_vars/2,