From 24de22eeb5e568aef00d51bc0fa2abcab967850e Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Mon, 29 Jul 2013 17:56:32 -0500 Subject: [PATCH] MLN generative learning --- packages/CLPBN/learning/learn_mln_wgts.yap | 440 ++++++++++++--------- packages/CLPBN/mlns.yap | 74 +++- packages/CLPBN/pfl.yap | 2 +- 3 files changed, 331 insertions(+), 185 deletions(-) diff --git a/packages/CLPBN/learning/learn_mln_wgts.yap b/packages/CLPBN/learning/learn_mln_wgts.yap index 07aea7dd8..1ddcbbde2 100644 --- a/packages/CLPBN/learning/learn_mln_wgts.yap +++ b/packages/CLPBN/learning/learn_mln_wgts.yap @@ -9,22 +9,32 @@ % % +:- module(learn_mlns_generative, + [learn_mln_generative/0, + portray_mln/0]). + :- use_module(library(lists)). +:- use_module(library(tries)). + :- use_module(library(maplist)). :- use_module(library(nb)). -:- use_module(library(mlns)). +:- use_module(library(matrix)). -:- use_module(library(pfl)). +:- reexport(library(mlns)). + +:- reexport(library(pfl)). :- use_module(library(lbfgs)). -:- dynamic diff/4, i/2. +:- yap_flag(tabling_mode,local). + +:- dynamic diff/4, lit/1, i/2. prior_means(_, 0.0). -prior_dev(_, 100.0). +prior_dev(_, 1.0). learn_mln_generative :- compile, @@ -33,43 +43,70 @@ learn_mln_generative :- set_weights :- retract( mln:mln_w(Id, _) ), optimizer_get_x( Id, W), -% writeln(weight:W), + %writeln(weight:W), assert( mln:mln_w(Id, W) ), fail. set_weights. -add_lprior(Id-WI, Lik0, Lik) :- - prior_means(Id, PM), - prior_dev(Id, PV), - Lik is Lik0 + ((WI-PM)*(WI-PM))/(2*PV*PV). - adjust_lprior(Lik0, Lik) :- Lik0 = Lik, !. adjust_lprior(Lik0, Lik) :- findall(I-WI, mln_w(I,WI), WIs), foldl(add_lprior, WIs, Lik0, Lik). +add_lprior(Id-WI, Lik0, Lik) :- + prior_means(Id, PM), + prior_dev(Id, PV), + Lik is Lik0 + ((WI-PM)*(WI-PM))/(2*PV*PV). + likelihood(Lik) :- S = s(0.0), % nb_create_accumulator(0.0, Acc), ( - lmln:p(_Lit,P,_,_), - LogP is log(P), -% writeln(_Lit:P), + recorded(i, [Ref|N], _), + peval(Ref, LogP), + %writeln(N*P), S = s(V), - V1 is V+LogP, + V1 is V+N*LogP, nb_setarg(1, S, V1), % nb_add_to_accumulator( Acc, LogP), fail ; % nb_accumulator_value(Acc, Lik) S = s(Lik0), -writeln(lik:Lik0), +%writeln(lik:Lik0), adjust_lprior(Lik0, Lik1), Lik is -Lik1 ). +derive :- + nb_getval(i2, Mat), + nb_getval(d2, MatD), + matrix_set_all(MatD, 0.0), + recorded(i, [Ref|NI], _), + trie_get_entry(Ref, e(_, Ds, Ps)), + member(n(Id,Occs,DN0,DN1), Ds), + matrix_get(Mat, [Id], N), + matrix_get(MatD, [Id], V), + peval(Ps, P0, P1), + X is Occs*(N-P0*(N+DN0)-P1*(N+DN1)), +%writeln(X is NI*(-P0*(DN0)-P1*(DN1))), + V1 is V-NI*X, + matrix_set(MatD, [Id], V1), + fail. +derive :- + nb_getval(d2, MatD), + mln(Ms), + N1 is Ms-1, + between(0, N1, Id), + matrix_get(MatD, [Id], Sum), + %writeln(d:Id:Sum), + adjust_prior(Sum, Id, NSum), + optimizer_set_g(Id, NSum ), + fail. +derive. + adjust_prior(Lik0, _, Lik) :- Lik0 = Lik, !. adjust_prior(Sum, Id, NSum) :- @@ -78,207 +115,258 @@ adjust_prior(Sum, Id, NSum) :- prior_dev(Id, PV), NSum is Sum+(Wi-PM)/(PV*PV). -derive :- - mln(Id, _, Els, _), - i(Id, N), -%writeln(Id:N), -% nb_create_accumulator(0.0, Acc), - S = s(0.0), -% nb_accumulator_value(Acc, Sum0),writeln(sum0:Sum0), - ( - nth(_L, Els, VId), - p_l(Id, VId, P0, P1), - diff( VId, Id, DN0, DN1), - X is (N-P0*(N+DN0)-P1*(N+DN1)), -%writeln(X is (N-P0*(N+DN0)-P1*(N+DN1))), -% nb_add_to_accumulator(Acc, X), - S = s(V), - V1 is V-X, - nb_setarg(1, S, V1), - fail - ; -% nb_accumulator_value(Acc, Sum), - S = s(Sum), - writeln(d:Id:Sum), - adjust_prior(Sum, Id, NSum), - optimizer_set_g(Id, NSum ), - fail - ). -derive. +:- dynamic old_fx/1. + +old_fx(+inf). % This is the call back function which is invoked to report the progress -% if the last argument is set to anywhting else than 0, the optimizer will +% if the last argument is set to anything else than 0, the optimizer will % stop right now -progress(FX,X_Norm,G_Norm,Step,_N,Iteration,Ls,0) :- +user:progress(FX,X_Norm,G_Norm,Step,_N,Iteration,Ls, Out) :- + ( Iteration mod 100 =:= 0 -> atomic_concat([tmp_,Iteration,'.pfl'], File), open( File, write, S), portray_mln(S), close(S) ; true ), + retract(old_fx(FX0)), + ( Delta is FX-FX0, abs(Delta/FX) < 0.00001 -> Out = 1 ; Out = 0), optimizer_get_x(0,X0), - format('~d. Iteration : w=~4f f(X)=~4f |X|=~4f |X\'|=~4f Step=~4f Ls=~4f~n',[Iteration,X0,FX,X_Norm,G_Norm,Step,Ls]). + assert(old_fx(FX)), + format('/* ~d: w[0]=~10f f(X)=~4f |X|=~4f |X\'|=~4f Step=~4f Ls=~4f */~n',[Iteration,X0,FX,X_Norm,G_Norm,Step,Ls]). -% This is the call back function which evaluates F and the gradient of F -evaluate(FX,_N,_Step) :- - set_weights, - likelihood(FX), - derive. + + % This is the call back function which evaluates F and the gradient of F +user:evaluate(FX,_N,_Step) :- + set_weights, + likelihood(FX), + derive. init_vars(Ev, Pr) :- - mln(N), - N1 is N-1, - format('We start the search at weight=0~2n',[]), - optimizer_initialize(N, Ev, Pr), - between(0, N1, I), - optimizer_set_x(I,0.0), - fail. + mln(N), + N1 is N-1, + format('/* We start the search for ~d weights at weight[_]=0 */~2n',[N]), + optimizer_initialize(N, Ev, Pr), + between(0, N1, I), + optimizer_set_x(I,0.0), + fail. init_vars(_, _). output_stat(BestF, Status) :- - mln(N), - N1 is N-1, - ( between(0,N1,I), - optimizer_get_x(I,BestX0), - format('w[~d] = ~f~n', [I, BestX0]), - fail - ; - Lik is -BestF, - format('Final likelihood=~f~2nLBFGS Status=~w~n',[Lik,Status]) - ). + ( portray_mln, + fail + ; + Lik is -BestF, + format('/* Final likelihood=~f */~n/* LBFGS Status=~w */~n',[Lik,Status]) + ). optimize :- - init_vars(evaluate, progress), - optimizer_run(BestF,Status), - output_stat(BestF, Status), - optimizer_finalize, - format('~2nOptimization done~n',[]). + init_vars(evaluate, progress), + optimizer_run(BestF,Status), + output_stat(BestF, Status), + optimizer_finalize, + format('~2nOptimization done~n',[]). compile :- - init_compiler, - mln(ParFactor, _Type, _Els, _G), - writeln(ParFactor), - factor(markov, ParFactor, Ks, _, _Phi, Constraints), - maplist(call, Constraints), - nth(_L, Ks, VId), - compile_pw(VId, P0, P1, G), - assert((p_l(ParFactor, VId, P0, P1) :- lmln:G)), + init_compiler, + compile_literals, + fail. +/* +compile :- + recorded(i, [Ref|N], _), + trie_get_entry(Ref, E), + writeln(N:E), fail. +*/ compile. init_compiler :- - retractall(i(_,_)), - retractall(i(_,_,_,_)), + mln(HowMany), + D is HowMany+1, + matrix_new(ints, [D], M), + matrix_new(floats, [D], MD), + nb_setval(i2,M), + nb_setval(d2,MD), + collect_literals, + init_trie, retractall(p_l(_,_,_,_)), retractall(lmln:p(_,_,_,_)), fail. init_compiler. -compile_pw(VId, P0, P1, p(VId, _, P0, P1)) :- - clause(lmln:p(VId, _, P0, P1), _), !. -compile_pw(VId, Head0, Head1, G) :- - G = p(VId, Head, Head0, Head1), - compile(VId,Head,Head0,Head1,Bd), - assert( ( lmln:G :- Bd) ). +init_trie :- + catch(nb_getval( mln_trie, Trie ), _, fail), + trie_close( Trie ), + eraseall( i ), + fail. +init_trie :- + trie_open( Trie ), + nb_setval( mln_trie , Trie ). -compile(VId, P, P0, P1, Bd) :- - findall(p(FId,W,P0,P1), find_prob(VId, FId, W, P0, P1), Fs), - (evidence(VId, 1) -> P = P1 ; P = P0), +collect_literals :- + mln(ParFactor, _Type, _Els, _G, _DConstraints), + factor(markov, ParFactor, Ks, _, _Phi, _Constraints), + maplist(add_lit, Ks), + fail. +collect_literals. + +add_lit(K) :- + functor(K, N, A), + functor(K0, N, A), + ( lit(K0) -> true ; assert(lit(K0)) ). + +compile_literals :- + lit(K), + functor(K, N, A), + statistics(runtime,_), + format(user_error, '/** grounding ~a/~d.~45+**/~n',[N,A]), +% evidence(K, 1), + ( ground_lit(K), + %writeln(k:K), + compile_pw(K) + ; + statistics(runtime,[_,T]), + format(user_error, '/** took ~d msec.~45+**/~n',[T]), + fail + ). + + +ground_lit(K) :- + functor(K, _, Ar), + ground_lit(0, Ar, K). + +ground_lit(Ar, Ar, _K). +ground_lit(I0, Ar, K) :- + I is I0+1, + (mln):mln_domain(I, K, G, _A), + user:G, + ground_lit(I, Ar, K). + +compile_pw(VId) :- + (evidence(VId, 1) -> P = 1 ; P = 0), + compile(VId, P). + +compile(VId, Val) :- + findall(p(FId,W,P0,P1,I0,I1), find_prob(VId, Val, FId, W, P0, P1, I0, I1), Fs), ( Fs == [] -> fail ; - Fs = [p(F,W,1,1)] + Fs = [p(FId,W,1,1,I0,I1)] -> - P0 = 0.5, P1 = 0.5, Bd = true - ; Fs = [p(F,W,P0A,P1A)] - -> - Bd = (mln_w(F, W), P0 is P0A/(P0A+P1A), P1 is 1-P0) - ; - Fs = [p(FA,WA,P0A,P1A),p(FB,WB,P0B,P1B)] - -> - Bd = (mln_w(FA, WA), mln_w(FB, WB), P0 is P0A*P0B/(P0A*P0B+P1A*P1B), P1 is 1-P0) - ; - Bd = ( sumps(Fs, V0, 1.0, V1, 1.0), P0 is V1/(V0+V1), P1 is 1-P0) + fail + ; + sort(Fs, FsS), + merge_lits(FsS, FsN, Ws), + nb_getval( mln_trie, Trie ), + store( Trie, e(Val, Ws, FsN) ) ). -find_prob(VId, ParFactor, W, P0, P1) :- - defined_in_factor(VId, ParFactor, L), - factor(markov, ParFactor, Ks, _, _Phi, Constraints), - nth0(L, Ks, VId), - maplist(call,Constraints), - mln(ParFactor, _Type, LP, _Head), - foldl(true_literal, LP, Ks, 0, NTs), - NTs < 2, % >= 2 ignore, always true... - maplist(polarity(VId, Pol), LP), - (NTs == 0 -> - /* We have no true literal */ - ( Pol == (+) -> -% inc_n(ParFactor, L1, 1), - (evidence(VId, 1) -> /* we are */ - assert(diff(VId,ParFactor,-1, 0)) +store( T , E ) :- + trie_check_entry(T, E, R), !, + recorded(i, [R|I], Ref), + erase(Ref), + I1 is I+1, + recorda(i, [R|I1], _). +store( T , E ) :- + trie_put_entry(T, E, R), !, + recorda(i, [R|1], _). + +merge_lits([], [], []). +merge_lits([N*p(F,W,A1,A2,I1,I2), p(F,W,A3,A4,I3,I4)|FsS], FsM, Is) :- + A1 == A3, + A2 == A4, + I1 == I3, + I2 == I4, !, + N1 is N+1, + merge_lits([N1*p(F,W,A3,A4,I3,I4)|FsS], FsM, Is). +merge_lits([p(F,W,A1,A2,I1,I2), p(F,W,A3,A4,I3,I4)|FsS], FsM, Is) :- + A1 == A3, + A2 == A4, + I1 == I3, + I2 == I4, !, + merge_lits([2*p(F,W,A3,A4,I3,I4)|FsS], FsM, Is). +merge_lits([p(F,W,A1,A2,I1,I2) | FsS], [p(F,1,W,A1,A2)|FsM], [n(F,1,I1,I2)|Is]) :- + merge_lits(FsS, FsM, Is). +merge_lits([N*p(F,W,A1,A2,I1,I2) | FsS], [p(F,N,W,A1,A2)|FsM], [n(F,N,I1,I2)|Is]) :- + merge_lits(FsS, FsM, Is). + +find_prob(VId, E, ParFactor, W, P0, P1, I0, I1) :- + mln(ParFactor, _, _Type, _, Constraints), +% maplist(call,Constraints), + deletei(Constraints, VId, ConstraintsF, Pol), + maplist(expand_domain(VId-Pol), ConstraintsF), + % all other literals are false + ( Pol == (+) -> + P0 = 0, P1 = W, + (E == 1 -> /* we are making this true */ + inc(ParFactor), + I0 = -1, I1 = 0 ; - assert(diff(VId, ParFactor, 0, 1)) - ), - P0 = 1, P1 = exp(W) - ; -% inc_n(ParFactor, L1, 0), - (evidence(VId, 1) -> /* we are */ - assert(diff(VId,ParFactor, 1, 0)) - ; - assert(diff(VId, ParFactor, 0, -1)) - ), - P0 = exp(W), P1 = 1 - ) + /* it is false */ + I0 = 0, I1 = 1 + ) ; - /* L == 0: increment true literals once */ - (L == 0 -> inc(ParFactor) ; true ), - /* We have a single true literal */ - ( %are we that literal ? - Pol == (+) -> - (evidence(VId, 1) -> /* we are */ - % inc_n(ParFactor, L1, 1), - assert(diff(VId,ParFactor, -1, 0)), - P0 = 1, P1 = exp(W) ; - /* we are not */ - assert(diff(VId,ParFactor, 0, 0)), - % inc_n(ParFactor, L1, 0), - % inc_n(ParFactor, L1, 1), - P0 = 1, P1 = 1 - ) + P0 = W, P1 = 0, + (E == 1 -> /* we are making this false */ + I0 = 1, I1 = 0 ; - % NEGATIVE polarity - (evidence(VId, 1) -> /* we are not */ - assert(diff(VId,ParFactor, 0, 0)), - % inc_n(ParFactor, L1, 0), - % inc_n(ParFactor, L1, 1), - P0 = 1, P1 = 1 ; - /* we are */ - assert(diff(VId,ParFactor, 0, -1)), - % inc_n(ParFactor, L1, 0), - P0 = exp(W), P1 = 1 + /* it is true */ + inc(ParFactor), + I0 = 0, I1 = -1 ) - ) ). -polarity(L, -, -L) :- !. -polarity(L, +, L) :- !. -polarity(_, _, _). +expand_domain(VIdPol, true - Lits) :- !, + maplist( false_literal(VIdPol), Lits). -true_literal(-L, L, N, N1) :- !, - ( evidence(L, 1) -> N1 = N ; N1 is N+1 ). -true_literal(L, L, N, N1) :- - ( evidence(L, 1) -> N1 is N+1 ; N1 = N ). +expand_domain(VIdPol, Dom-Lits) :- + call(user:Dom), + maplist( true_literal(VIdPol), Lits). + +% we need to check if we have +% L ; L or L ; -L +% in this case skip or it is always true, so fail. +false_literal(L-(-), L). +false_literal(VId-_, L) :- + evidence(L, 1), + L \= VId. + +% L is ground +true_literal(L-(+), L) :- !. +true_literal(VId-_, L) :- + L \= VId, + \+ evidence(L, 1). + +deletei([true-Lits|More], K, [true-NLits|More], -) :- + force_delete(Lits, K, NLits). +deletei([true-Lits|More], K, [true-Lits|NMore], -) :- !, + force_delete(More, K, NMore). +deletei(More, K, NMore, +) :- + deletei(More, K, NMore). + +deletei([Dom-Lits|More], K, [Dom-NLits|More]) :- + force_delete(Lits, K, NLits). +deletei([DomLits|More], K, [DomLits|NMore]) :- + deletei(More, K, NMore). + +force_delete([Elem|List], Elem, List). +force_delete([Head|List], Elem, [Head|Residue]) :- + force_delete(List, Elem, Residue). inc(Id) :- - retract(i(Id, N)), !, - N1 is N+1, - assert(i(Id, N1)). -inc(Id) :- - assert(i(Id, 1)). + nb_getval(i2, M), + matrix_inc(M, [Id]). -% V is f (0) -check(W, V, -V, exp(W), _R, Matters, Matters0) :- !, Matters = Matters0. -check(_W, V, V, R, R, Matters, Matters0) :- !, Matters = Matters0. -check(W, _V, -V, Rf, R0, Matters, Matters0) :- !, - (evidence(V, 1) -> Rf = R0, Matters=Matters0; Rf = exp(W), Matters = not). -check(W, _V, V, Rf, R0, Matters, Matters0) :- - (evidence(V, 1) -> Rf = exp(W), Matters = not ; Rf = R0, Matters=Matters0). +peval(Ref, P) :- + trie_get_entry(Ref, e(Side, _, Ps)), + foldl2(p_eval, Ps, 0.0, P0, 0.0, P1), + logsum(P0, P1, P01), + ( Side == 0 -> P = P0-P01 ; P = P1-P01 ). -complement(W, exp(W), 1). -complement(W, 1, exp(W)). +peval(Ps, P0, P1) :- +%writeln(p:Ds:Ps), + foldl2(p_eval, Ps, 0.0, AP0, 0.0, AP1), + logsum(AP0, AP1, AP01), + P0 is exp( AP0 - AP01 ), + P1 is 1-P0. +p_eval(p(WId, N, W, P0, P1), AP0, A0, AP1, A1) :- + mln_w(WId, W), + A0 is AP0+N*P0, + A1 is AP1+N*P1. diff --git a/packages/CLPBN/mlns.yap b/packages/CLPBN/mlns.yap index f007748a5..e4cb66f72 100644 --- a/packages/CLPBN/mlns.yap +++ b/packages/CLPBN/mlns.yap @@ -4,14 +4,17 @@ mln_domain/1, mln_literal/1, mln/1, - mln/4, - mln_w/2]). + mln/5, + mln_w/2, + portray_mln/0, + portray_mln/1]). :- use_module(library(pfl)). :- use_module(library(maplist)). :- use_module(library(lists)). +:- use_module(library(terms)). -:- dynamic mln/1, mln/2, mln_domain/4, mln/4, mln_w/2, mln_domain/5, mln_type_def/1. +:- dynamic mln/1, mln/2, mln_domain/4, mln/5, mln_w/2, mln_domain/5, mln_type_def/1. user:term_expansion(mln_domain(P),[]) :- expand_domain(P). @@ -84,10 +87,22 @@ translate_to_factor(W, D, Lits, Id, Vs, Phi, Domain) :- new_mln(Id), maplist(new_skolem(Id), Lits), term_variables(Lits, Vs), - create_domain(Lits, Domain), + create_domain(Lits, Domain0), + exclude(ground, Domain0, Domain), make_clause(Id, Do, Vs, Domain, Lits, LP, Head), - assert(mln_w(Id, W)), - assert(mln(Id, Do, LP, Head)). + assert(mln_w(Id, W)), + find_pos(LP, NLP, Pos), + foldl2(merge_domain_lits, Domain, NDomain, [], _, NLP, [] ), + exclude(empty_goal, [true-Pos|NDomain], FDomain), + assert(mln(Id, Do, LP, Head, FDomain)). + +empty_goal(_-[]). + +find_pos([], [], []). +find_pos([-Lit|Lits], LP, [Lit|Pos]) :- !, + find_pos(Lits, LP, Pos). +find_pos([Lit|Lits], [Lit|LP], Pos) :- + find_pos(Lits, LP, Pos). % % naive translation of conj/disjunction into Prolog @@ -101,7 +116,7 @@ make_clause(Id, Do, Vs, Domain, _Lits, Fs, Head) :- order_body(disj, Fs, Bd0) :- order_body(Fs, Bd0). order_body(conj, Fs, Bd0) :- - andder_body(Fs, Bd0), + ander_body(Fs, Bd0), order_body([-G], (\+ G)). @@ -133,6 +148,23 @@ new_mln(Id) :- Id1 is Id+1, assert(mln(Id1)). +merge_domain_lits( Domain, Domain-Gs, Vs, [V|Vs], LP0, LPF) :- + arg(1, Domain, V), + delete_with_v(LP0, [V|Vs], LPF, Gs). + +delete_with_v([], _Vs, [], []). +delete_with_v([G|LP0], Vs, LPF, NGs) :- + new_variables_in_term(Vs, G, NVs), + ( NVs == [] -> + NGs = [G|Gs], + LPF = LP1 + ; + NGs = Gs, + LPF = [G|LP1] + ), + delete_with_v(LP0, Vs, LP1, Gs). + + % % make it easier to manipulate % @@ -284,7 +316,7 @@ clean_cnf(CNF, NCNF) :- % count groundings % all_true(Id, V) :- - mln(Id, _F, _D, Head), + mln(Id, _F, _D, Head, _), nb_create_accumulator(0, Acc), ( call(user:Head), @@ -294,3 +326,29 @@ all_true(Id, V) :- nb_accumulator_value(Acc, V) ). +portray_mln :- + portray_mln( user_error ). + +portray_mln(Stream) :- + mln(Id, _, LP, _, _), + mln_w(Id, W), + format(Stream, 'mln ~4f : ( ', [W] ), + numbervars(LP, 1, _), + portray_lits(Stream, LP), + format(Stream, ' ).~n', [] ), + fail. +portray_mln(_Stream). + +portray_lits(Stream, [L1]) :- !, + portray_lit( Stream, L1 ). +portray_lits(Stream, [L1|Ls]) :- !, + portray_lit( Stream, L1 ), + format(Stream, ' ; ', []), + portray_lits( Stream, Ls ). + +portray_lit( Stream, -L ) :- !, + format( Stream, '\\+ ~q', [L] ). +portray_lit( Stream, L ) :- + format( Stream, '~q', [L] ). + + diff --git a/packages/CLPBN/pfl.yap b/packages/CLPBN/pfl.yap index e26ae3b3e..569faa460 100644 --- a/packages/CLPBN/pfl.yap +++ b/packages/CLPBN/pfl.yap @@ -184,7 +184,7 @@ new_skolem(Sk, D) :- functor(Sk, N, A), functor(NSk, N, A), % [f,t] is special for evidence - ( D = [f,t] -> assert((evidence(NSk, 1) :- call(user:NSk))) ; true ), + ( D = [f,t] -> assert((evidence(NSk, 1) :- user:NSk)) ; true ), interface_predicate(NSk), assert(skolem(NSk, D)).