improve bdd support.

packages/CLPBN/clpbn/bdd.yap

@@ -41,6 +41,7 @@ Va <- P*X1*Y1 + Q*X2*Y2 + ...
 :- use_module(library('clpbn/aggregates'),
 	      [check_for_agg_vars/2]).
 
+
 :- use_module(library(atts)).
 
 :- use_module(library(hacks)).
@@ -67,27 +68,25 @@ bdd([QueryVars], AllVars, AllDiffs) :-
 	clpbn_bind_vals([QueryVars], [LPs], AllDiffs).
 
 init_bdd_solver(_, AllVars0, _, bdd(Term, Leaves, Tops)) :-
+%	check_for_agg_vars(AllVars0, AllVars1),
 	sort_vars(AllVars0, AllVars, Leaves),
-	%store_order(AllVars, 0),
+	order_vars(AllVars, 0),
 	rb_new(Vars0),
 	rb_new(Pars0),
 	init_tops(Leaves,Tops),
 	get_vars_info(AllVars, Vars0, _Vars, Pars0, _Pars, Leaves, Tops, Term, []).
 
+order_vars([], _).
+order_vars([V|AllVars], I0) :-
+	put_atts(V, [order(I0)]),
+	I is I0+1,
+	order_vars(AllVars, I).
+
+
 init_tops([],[]).
 init_tops(_.Leaves,_.Tops) :-
 	init_tops(Leaves,Tops).
 
-%
-% keep an attribute for sorting variables
-%
-store_order([], _).
-store_order(V.AllVars, I0) :-
-	put_atts(V,[order(I0)]),
-	I is I0+1,
-	store_order(AllVars, I).
-
-
 sort_vars(AllVars0, AllVars, Leaves) :-
 	dgraph_new(Graph0),
 	build_graph(AllVars0, Graph0, Graph),
@@ -122,10 +121,10 @@ 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),
 	length(Domain, DSize),
-%	reorder(Parents0, Parents),
+%	run_though_avg(V, DSize, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST).
-	Parents = Parents0,
+	bup_avg(V, DSize, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST).
-	run_though_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) :-
 % clpbn:get_atts(V, [key(K)]), writeln(V:K:DistId:Parents),
@@ -140,27 +139,45 @@ 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),
+	keysort(PVs, SVs),
+	remove_key(SVs, OVs1),
+	reverse(OVs1, OVs).
+
+add_pos([], []).
+add_pos([V|Vs], [K-V|PVs]) :-
+	get_atts(V,[order(K)]),
+	add_pos(Vs, PVs).
+
+remove_key([], []).
+remove_key([_-V|SVs], [V|OVs]) :-
+	remove_key(SVs, OVs).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%
+%
+% 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),
 	DIST = info(V, Tree, Ev, [V0,V1,V2], Formula, [], []),
 	get_parents(Parents, PVars, Vs1, Vs2),
 	length(Parents, N),
-	generate_3tree(F00, PVars, 0, 0, 0, N, N0, N1, N2, R, (N1+2*N2 =< N/2), (N1+2*(N2+R) > N/2)),
+	generate_3tree(F00, PVars, 0, 0, 0, N, N0, N1, N2, R, (N1+2*N2 =< N/2), (N1+2*(N2+R) =< N/2)),
 	simplify_exp(F00, F0),
-	writeln(1:PVars=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),
+	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),
-	writeln(3:PVars=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).
 
 generate_3tree(OUT, _, I00, I10, I20, IR0, N0, N1, N2, R, _Exp, ExpF) :-
-	not_satisf(I00, I10, I20, IR0, N0, N1, N2, R, ExpF),
+	IR is IR0-1,
+	satisf(I00, I10, I20, IR, N0, N1, N2, R, ExpF),
 	!,
 	OUT = 1.
-generate_3tree(OUT, [[P0,P1,P2]], I00, I10, I20, IR0, N0, N1, N2, R, Exp, ExpF) :-
+generate_3tree(OUT, [[P0,P1,P2]], I00, I10, I20, IR0, N0, N1, N2, R, Exp, _ExpF) :-
 	IR is IR0-1,
 	( satisf(I00+1, I10, I20, IR, N0, N1, N2, R, Exp) ->
 	  L0 = [P0|L1]
@@ -210,10 +227,87 @@ satisf(I0, I1, I2, IR, N0, N1, N2, R, Exp) :-
 not_satisf(I0, I1, I2, IR, N0, N1, N2, R, Exp) :-
 	\+  ( I0 = N0, I1=N1, I2=N2, IR=R, call(Exp) ).
 
+%%%%%%%%%%%%%%%%%%%%%%%%%
+%
+% use bottom-up dynamic programming to generate average
+%
+bup_avg(V, Size, Domain, Parents, Vs, Vs2, Lvs, Outs, DIST) :-
+	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
+	% easier to do recursion on lists
+	Sums =.. [_|LSums],
+	generate_avg(0, Size, 0, Max, LSums, OVs, Ev, F1, []),
+	reverse(F0, RF0),
+	get_evidence(V, Tree, Ev, F1, F2, Lvs, Outs),
+	append(RF0, F2, Formula).
+
+generate_sums([PVals], Size, Max, Sum, []) :- !,
+	Max is Size-1,
+	Sum =.. [sum|PVals].
+generate_sums([PVals|Parents], Size, Max, NewSums, F) :-
+	generate_sums(Parents, Size, Max0, 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).
+
+%
+% 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) :-
+	I is I0+1,
+	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]).
+
+%
+%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]) :-
+	J is I-Pos,
+	J >= 0,
+	J =< Max0, !,
+	J1 is J+1,
+	arg(J1, Sums, S0),
+	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).
+	
+
+generate_avg(Size, Size, _J, _Max, [], [], [], F, F).
+generate_avg(I0, Size, J0, Max, LSums, [O|OVs], [Ev|Evs], [O=Disj*Ev|F], F0) :-
+	I is I0+1,
+	Border is (I*Max)/Size,
+	fetch_for_avg(J0, Border, J, LSums, MySums, RSums),
+	to_disj(MySums, Disj),
+	generate_avg(I, Size, J, Max, RSums, OVs, Evs, F, F0).
+
+fetch_for_avg(J, Border, J, RSums, [], RSums) :-
+	J > Border, !.
+fetch_for_avg(J0, Border, J, [S|LSums], [S|MySums], RSums) :-
+	J1 is J0+1,
+	fetch_for_avg(J1, Border, J, LSums, MySums, RSums).
+
+
 to_disj([], 0).
 to_disj([V], V).
-to_disj([V,V1|Vs], V+Out) :-
+to_disj([V,V1|Vs], Out) :-
-	to_disj([V1|Vs], Out).
+	to_disj2([V1|Vs], V, Out).
+
+to_disj2([V], V0, V0+V).
+to_disj2([V,V1|Vs], V0, Out) :-
+	to_disj2([V1|Vs], V0+V, Out).
+
 
 %
 % look for parameters in the rb-tree, or add a new.
@@ -345,7 +439,7 @@ apply_parents_second([Value|Values], [E|Ev], Previous, P0, PVars, (Value=Disj*E)
 
 apply_first_parent([Parents], Conj, [Theta]) :- !,
 	parents_to_conj(Parents,Theta,Conj).
-apply_first_parent(Parents.PVars, Disj+Conj, Theta.TheseParents) :-
+apply_first_parent(Parents.PVars, Conj+Disj, Theta.TheseParents) :-
 	parents_to_conj(Parents,Theta,Conj),
 	apply_first_parent(PVars, Disj, TheseParents).
 
@@ -370,18 +464,18 @@ apply_last_parent(Parents.PVars, Other, Conj+Disj) :-
 % simplify stuff, removing process that is cancelled by 0s
 %
 parents_to_conj([], Theta, Theta) :- !.
-parents_to_conj(Ps, Theta, Conj*Theta) :-
+parents_to_conj(Ps, Theta, Theta*Conj) :-
 	parents_to_conj2(Ps, Conj).
 
 parents_to_conj2([P],P) :- !.
-parents_to_conj2(P.Ps,Conj*P) :-
+parents_to_conj2(P.Ps,P*Conj) :-
 	parents_to_conj2(Ps,Conj).
 
 %
 % first case we haven't reached the end of the list so we need
 % to create a new parameter variable
 %
-skim_for_theta([[P|Other]|V], New*not(P), [Other|_], New) :- var(V), !.
+skim_for_theta([[P|Other]|V], not(P)*New, [Other|_], New) :- var(V), !.
 %
 % last theta, it is just negation of the other ones
 %
@@ -389,7 +483,7 @@ skim_for_theta([[P|Other]], not(P), [Other], _) :- !.
 %
 % recursive case, build-up
 %
-skim_for_theta([[P|Other]|More], Ps*not(P), [Other|Left], New ) :-
+skim_for_theta([[P|Other]|More], not(P)*Ps, [Other|Left], New ) :-
 	skim_for_theta(More, Ps, Left, New ).
 
 get_evidence(V, Tree, Ev, F0, F, Leaves, Finals) :-
@@ -432,8 +526,10 @@ insert_output(_.Leaves, V, _.Finals, Top, Outs, SendOut) :-
 
 
 get_outs([V=F], [V=NF|End], End,  V) :- !,
+%	writeln(f0:F),
 	simplify_exp(F,NF).
 get_outs((V=F).Outs, (V=NF).NOuts, End, (F0 + V)) :-
+%	writeln(f0:F),
 	simplify_exp(F,NF),
 	get_outs(Outs, NOuts, End, F0).
 
@@ -441,7 +537,7 @@ eval_outs([]).
 eval_outs((V=F).Outs) :-
 	simplify_exp(F,NF),
 	V = NF,
-	get_outs(Outs).
+	eval_outs(Outs).
 
 %simplify_exp(V,V) :- !.
 simplify_exp(V,V) :- var(V), !.
@@ -515,7 +611,10 @@ get_prob(Term, Node, V, SP) :-
 
 build_bdd(Bindings, NVs, VTheta, Theta, Bdd) :-
 	bdd_from_list(Bindings, NVs, Bdd),
-	bdd_tree(Bdd, bdd(_F,Tree,_Vs)), length(Tree, Len),
+	bdd_size(Bdd, Len),
+%	number_codes(Len,Codes),
+%	atom_codes(Name,Codes),
+%	bdd_print(Bdd, Name),
 	writeln(length=Len),
 	VTheta = Theta.