Merge branch 'master' of ssh://yap.git.sourceforge.net/gitroot/yap/yap-6.3
This commit is contained in:
Joao
commit
af30eb80c9
@ -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),
|
||||
|
||||
@ -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)));
|
||||
}
|
||||
|
||||
@ -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 */
|
||||
|
||||
@ -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).
|
||||
|
||||
|
||||
@ -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) :-
|
||||
|
||||
@ -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),
|
||||
|
||||
@ -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).
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
|
||||
:- style_check(all).
|
||||
|
||||
:- ensure_loaded(library(clpbn)).
|
||||
|
||||
wet_grass(W) :-
|
||||
|
||||
@ -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,
|
||||
|
||||
Reference in New Issue
Block a user