viterbi

This module performs reasoning over Logic Programs with Annotated Disjunctions and CP-Logic programs. It reads probabilistic program and computes the most likely explanation of the query

author: - Stefano Bragaglia and Fabrizio Riguzzi
copyright: - Stefano Bragaglia and Fabrizio Riguzzi
license: - Artistic License 2.0 https://opensource.org/licenses/Artistic-2.0

31viterbi(M:Goals,Prob,Exp):- 32 must_be(nonvar, Goals), 33 must_be(var,Prob), 34 must_be(var,Exp), 35 retractall(M:best_prob(_)), 36 retractall(M:best_exp(_)), 37 retractall(M:best_goal(_)), 38 assert(M:best_prob(0.0)), 39 assert(M:best_exp([])), 40 list2and(GL,Goals), 41 assert(M:best_goal(GL)), 42 (find_exp(GL,M),fail; true), 43 M:best_prob(Prob), 44 M:best_exp(Exp0), 45 M:best_goal(GL), 46 convert_exp(Exp0,M,Exp), 47 retractall(M:best_prob(_)), 48 retractall(M:best_exp(_)). 49 50complete_exp(Exp0,Prob0,M,Exp,Prob):- 51 findall((R,S),(M:rule_by_num(R,S,_,Head,Body),\+ member(rule(R,_,Head,Body),Exp0)),L)-> 52 maplist(find_max(M),L,Exp1), 53 foldl(mult,Exp1,Prob0,Prob), 54 convert_exp(Exp1,M,Exp2), 55 append(Exp0,Exp2,Exp). 56 57mult((_,_,_,P1),P0,P):- 58 P is P0*P1. 59 60find_max(M,(R,S),(R,S,N,P)):- 61 M:rule_by_num(R,S,[_|Numbers],[_:P0|Head],_Body), 62 foldl(get_max,Head,Numbers,(P0,0),(P,N)). 63 64get_max(_:P,N,(P0,N0),(P1,N1)):- 65 (P>P0-> 66 N1=N, 67 P1=P 68 ; 69 N1=N0, 70 P1=P0 71 ). 72 73 74convert_exp([],_M,[]). 75 76convert_exp([(R,S,N,_)|T],M,[rule(R,Head,HeadList,Body)|TDelta]):- 77 M:rule(Head, _, N, R, S, _NH, HeadList, Body),!, 78 convert_exp(T,M,TDelta). 79 80find_exp(GL,M):- 81 solve(GL,M,[],Exp,1,P), 82 retract(M:best_prob(_)), 83 retract(M:best_exp(_)), 84 retract(M:best_goal(_)), 85 assert(M:best_prob(P)), 86 assert(M:best_exp(Exp)), 87 assert(M:best_goal(GL)). 88 89/* EXTERNAL FILE 90 * ------------- 91 * The following libraries are required by the program to work fine. 92 */ 93 94% :- source. 95% :- yap_flag(single_var_warnings, on). 96 97 98solve([],_M,C,C,P,P):-!. 99 100solve([\+ H|T],M,CIn,COut,P0,P):- 101 builtin(H),!, 102 \+ H, 103 solve(T,M,CIn,COut,P0,P). 104 105solve([\+ H |T],M,CIn,COut,P0,P):- 106 !, 107 list2and(HL,H), 108 (setof(D,solve_nob(HL,M,[],D),L)-> 109 choose_clauses(L,CIn,M,C1,P0,P1), 110 solve(T,M,C1,COut,P1,P) 111 ; 112 solve(T,M,CIn,COut,P0,P) 113 ). 114 115solve([H|T],M,CIn,COut,P0,P):- 116 builtin(H),!, 117 call(H), 118 solve(T,M,CIn,COut,P0,P). 119 120solve([H|T],M,CIn,COut,P0,P):- 121 M:def_rule(H,B), 122 append(B,T,NG), 123 solve(NG,M,CIn,COut,P0,P). 124 125solve([H|T],M,CIn,COut,P0,P):- 126 find_rule(H,M,(R,S,N,PR),B,CIn), 127 append(B,T,NG), 128 solve(NG,M,CIn,C1,P0,P1), 129 update_exp(C1,COut,(R,S,N,PR),P1,P), 130 check_bound(P,M). 131 132 133update_exp(C,C,Ch,P,P):- 134 member(Ch,C),!. 135 136update_exp(C0,[(R,S,N,PR)|C0],(R,S,N,PR),P0,P):- 137 P is P0*PR. 138 139check_bound(P,M):- 140 M:best_prob(BP), 141 P>BP. 142 143 144solve_nob([],_M,C,C):-!. 145 146solve_nob([\+ H|T],M,CIn,COut):- 147 builtin(H),!, 148 call(\+ H), 149 solve_nob(T,M,CIn,COut). 150 151solve_nob([\+ H |T],M,CIn,COut):-!, 152 list2and(HL,H), 153 (setof(D,solve_nob(HL,M,[],D),L)-> 154 choose_clauses_nob(L,CIn,M,C1), 155 solve_nob(T,M,C1,COut) 156 ; 157 solve_nob(T,M,CIn,COut) 158 ). 159 160solve_nob([H|T],M,CIn,COut):- 161 builtin(H),!, 162 call(H), 163 solve_nob(T,M,CIn,COut). 164 165solve_nob([H|T],M,CIn,COut):- 166 M:def_rule(H,B), 167 append(B,T,NG), 168 solve_nob(NG,M,CIn,COut). 169 170solve_nob([H|T],M,CIn,COut):- 171 find_rule(H,M,(R,S,N,P),B,CIn), 172 append(B,T,NG), 173 solve_nob(NG,M,CIn,C1), 174 update_exp(C1,COut,(R,S,N,P),1,_P2). 175 176 177find_rule(H, M,(R, S, N,P), Body, C) :- 178 M:rule(H, P, N, R, S, _NH, _Head, Body), 179 not_already_present_with_a_different_head(N, R, S, C). 180 181not_already_present_with_a_different_head(_HeadId, _RuleId, _Subst, []). 182 183not_already_present_with_a_different_head(HeadId, RuleId, Subst, [(HeadId1, RuleId, Subst1,_P)|Tail]) :- 184 not_different(HeadId, HeadId1, Subst, Subst1), !, 185 not_already_present_with_a_different_head(HeadId, RuleId, Subst, Tail). 186 187not_already_present_with_a_different_head(HeadId, RuleId, Subst, [(_HeadId1, RuleId1, _Subst1,_P)|Tail]) :- 188 RuleId \== RuleId1, 189 not_already_present_with_a_different_head(HeadId, RuleId, Subst, Tail). 190 191 192 193not_different(_HeadId, _HeadId1, Subst, Subst1) :- 194 Subst \= Subst1, !. 195 196not_different(HeadId, HeadId1, Subst, Subst1) :- 197 HeadId \= HeadId1, !, 198 dif(Subst, Subst1). 199 200not_different(HeadId, HeadId, Subst, Subst). 201 202 203choose_clauses([],C,_M,C,P,P). 204 205choose_clauses([D|T],CIn,M,COut,P0,P):- 206 member((N,R,S,_P),D), 207 already_present_with_a_different_head(N,R,S,CIn),!, 208 choose_clauses(T,CIn,M,COut,P0,P). 209 210 211choose_clauses([D|T],CIn,M,COut,P0,P):- 212 member((R,S,N,_P),D), 213 new_head(M,N,R,S,N1,PR), 214 \+ already_present(N1,R,S,CIn), 215 P1 is P0*PR, 216 check_bound(P1,M), 217 choose_clauses(T,[(R,S,N1,PR)|CIn],M,COut,P1,P). 218 219choose_clauses_nob([],C,_M,C). 220 221choose_clauses_nob([D|T],CIn,M,COut):- 222 member((R,S,N,_P),D), 223 already_present_with_a_different_head(N,R,S,CIn),!, 224 choose_clauses_nob(T,CIn,M,COut). 225 226 227choose_clauses_nob([D|T],CIn,M,COut):- 228 member((R,S,N,_P),D), 229 new_head(M,N,R,S,N1,PR), 230 \+ already_present(N1,R,S,CIn), 231 choose_clauses_nob(T,[(R,S,N1,PR)|CIn],M,COut). 232 233/* select a head different from N for rule R with 234substitution S, return it in N1 */ 235new_head(M,N,R,S,N1,P):- 236 M:rule_by_num(R,S,Numbers,_Head,_Body), 237 nth0(N, Numbers, _Elem, Rest), 238 member(N1,Rest), 239 M:rule(_H, P, N1, R, _S, _NH, _HL, _B). 240 241 242 243already_present_with_a_different_head(N,R,S,[(NH,R,SH,_P)|_T]):- 244 S=SH,NH \= N. 245 246already_present_with_a_different_head(N,R,S,[_H|T]):- 247 already_present_with_a_different_head(N,R,S,T). 248 249 250/* checks that a rule R with head N and selection S is already 251present in C (or a generalization of it is in C) */ 252already_present(N,R,S,[(N,R,S,_P)|_T]):-!. 253 254already_present(N,R,S,[_H|T]):- 255 already_present(N,R,S,T). 256 257/* SOLVING PREDICATES 258 * ------------------ 259 * The predicates in this section solve any given problem with several class of 260 * algorithms. 261 * 262 * Note: the original predicates (no more need and eligible to be deleted) have 263 * been moved to the end of the file. 264 */ 265 266 267builtin(average(_L,_Av)). 268builtin(prob(_,_)). 269builtin(G):- 270 predicate_property(G,built_in). 271builtin(G):- 272 predicate_property(G,imported_from(lists)). 273 274average(L,Av):- 275 sum_list(L,Sum), 276 length(L,N), 277 Av is Sum/N. 278 279 280listN(N, N, []) :- !. 281 282listN(NIn, N, [NIn|T]) :- 283 N1 is NIn+1, 284 listN(N1, N, T). 285 286/* assert_rules() 287 * -------------- 288 * This tail recursive predicate parses the given list of (Head:Prob) couples 289 * and stores them incrementally as rules along with the other parameters. 290 * 291 * INPUT 292 * - Head: current head part. 293 * - Prob: probability of the current head part. 294 * - Index: index of the current head part. 295 * - Subst: substitution for the current head part. 296 * - Choices: list of current head parts indexes. 297 * - HeadList: complete head or list of its parts. 298 * - BodyList: complete body or list of its parts. 299 */ 300assert_rules([],_M, _Index, _HeadList, _BodyList, _Choices, _Id, _Subst) :- !. % Closing condition. 301 302assert_rules(['':_Prob], _M,_Index, _HeadList, _BodyList, _Choices, _Id, _Subst) :- !. 303 304assert_rules([Head:Prob|Tail],M, Index, HeadList, BodyList, Choices, Id, Subst) :- 305 assertz(M:rule(Head, Prob, Index, Id, Subst, Choices, HeadList, BodyList)), 306 Next is Index + 1, 307 assert_rules(Tail,M, Next, HeadList, BodyList,Choices,Id,Subst). 308 309 310list2and([],true):-!. 311 312list2and([X],X):- 313 X\=(_,_),!. 314 315list2and([H|T],(H,Ta)):-!, 316 list2and(T,Ta). 317 318 319process_head(HeadList, GroundHeadList) :- 320 ground_prob(HeadList), !, 321 process_head_ground(HeadList, 0, GroundHeadList). 322 323process_head(HeadList0, HeadList):- 324 get_probs(HeadList0,PL), 325 foldl(minus,PL,1,PNull), 326 append(HeadList0,['':PNull],HeadList). 327 328minus(A,B,B-A). 329 330prob_ann(_:P,P):-!. 331prob_ann(P::_,P). 332 333 334gen_head(H,P,V,V1,H1:P):-copy_term((H,V),(H1,V1)). 335gen_head_disc(H,V,V1:P,H1:P):-copy_term((H,V),(H1,V1)). 336 337 338/* process_head_ground([Head:ProbHead], Prob, [Head:ProbHead|Null]) 339 * ---------------------------------------------------------------- 340 */ 341process_head_ground([H], Prob, [Head:ProbHead1|Null]) :- 342 (H=Head:ProbHead;H=ProbHead::Head),!, 343 ProbHead1 is float(ProbHead), 344 ProbLast is 1.0 - Prob - ProbHead1, 345 prolog_load_context(module, M),vit_input_mod(M), 346 M:local_viterbi_setting(epsilon_parsing, Eps), 347 EpsNeg is - Eps, 348 ProbLast > EpsNeg, 349 (ProbLast > Eps -> 350 Null = ['':ProbLast] 351 ; 352 Null = [] 353 ). 354 355process_head_ground([H|Tail], Prob, [Head:ProbHead1|Next]) :- 356 (H=Head:ProbHead;H=ProbHead::Head), 357 ProbHead1 is float(ProbHead), 358 ProbNext is Prob + ProbHead1, 359 process_head_ground(Tail, ProbNext, Next). 360 361 362ground_prob([]). 363 364ground_prob([_Head:ProbHead|Tail]) :-!, 365 ground(ProbHead), % Succeeds if there are no free variables in the term ProbHead. 366 ground_prob(Tail). 367 368ground_prob([ProbHead::_Head|Tail]) :- 369 ground(ProbHead), % Succeeds if there are no free variables in the term ProbHead. 370 ground_prob(Tail). 371 372 373get_probs(Head, PL):- 374 maplist(prob_ann,Head,PL). 375 376 377list2or([],true):-!. 378 379list2or([X],X):- 380 X\=;(_,_),!. 381 382list2or([H|T],(H ; Ta)):-!, 383 list2or(T,Ta).

405setting_vit(M:P,V):- 406 M:local_viterbi_setting(P,V). 407 408 409assert_all([],_M,[]). 410 411assert_all([H|T],M,[HRef|TRef]):- 412 assertz(M:H,HRef), 413 assert_all(T,M,TRef). 414 415 416get_next_rule_number(PName,R):- 417 retract(PName:rule_n(R)), 418 R1 is R+1, 419 assert(PName:rule_n(R1)). 420 421 422 423 424vit_expansion((:- begin_plp), []) :- 425 prolog_load_context(module, M), 426 vit_input_mod(M),!, 427 assert(M:vit_on). 428 429vit_expansion((:- end_plp), []) :- 430 prolog_load_context(module, M), 431 vit_input_mod(M),!, 432 retractall(M:vit_on). 433 434vit_expansion((:- begin_lpad), []) :- 435 prolog_load_context(module, M), 436 vit_input_mod(M),!, 437 assert(M:vit_on). 438 439vit_expansion((:- end_lpad), []) :- 440 prolog_load_context(module, M), 441 vit_input_mod(M),!, 442 retractall(M:vit_on). 443 444vit_expansion((Head :- Body), []):- 445 prolog_load_context(module, M),vit_input_mod(M),M:vit_on, 446% disjunctive clause with more than one head atom 447 Head = (_;_), !, 448 list2or(HeadListOr, Head), 449 process_head(HeadListOr, HeadList), 450 list2and(BodyList, Body), 451 length(HeadList, LH), 452 listN(0, LH, NH), 453 get_next_rule_number(M,R), 454 append(HeadList,BodyList,List), 455 term_variables(List,VC), 456 assert_rules(HeadList, M, 0, HeadList, BodyList, NH, R, VC), 457 assertz(M:rule_by_num(R, VC, NH, HeadList, BodyList)). 458 459 460vit_expansion((Head :- Body), []):- 461 prolog_load_context(module, M),vit_input_mod(M),M:vit_on, 462 (Head=(_:_); Head=(_::_)), !, 463 list2or(HeadListOr, Head), 464 process_head(HeadListOr, HeadList), 465 list2and(BodyList, Body), 466 length(HeadList, LH), 467 listN(0, LH, NH), 468 get_next_rule_number(M,R), 469 append(HeadList,BodyList,List), 470 term_variables(List,VC), 471 assert_rules(HeadList, M,0, HeadList, BodyList, NH, R, VC), 472 assertz(M:rule_by_num(R, VC, NH, HeadList, BodyList)). 473 474vit_expansion((Head :- Body), []):- 475 prolog_load_context(module, M),vit_input_mod(M),M:vit_on,!, 476 list2and(BodyList, Body), 477 assert(M:def_rule(Head, BodyList)). 478 479vit_expansion(Head , []):- 480 prolog_load_context(module, M),vit_input_mod(M),M:vit_on, 481 Head=(_;_), !, 482 list2or(HeadListOr, Head), 483 process_head(HeadListOr, HeadList), 484 length(HeadList, LH), 485 listN(0, LH, NH), 486 get_next_rule_number(M,R), 487 term_variables(HeadList,VC), 488 assert_rules(HeadList, M, 0, HeadList, [], NH, R, VC), 489 assertz(M:rule_by_num(R, VC, NH, HeadList, [])). 490 491vit_expansion(Head , []):- 492 prolog_load_context(module, M),vit_input_mod(M),M:vit_on, 493 (Head=(_:_); Head=(_::_)), !, 494 list2or(HeadListOr, Head), 495 process_head(HeadListOr, HeadList), 496 length(HeadList, LH), 497 listN(0, LH, NH), 498 get_next_rule_number(M,R), 499 term_variables(HeadList,VC), 500 assert_rules(HeadList, M, 0, HeadList, [], NH, R, VC), 501 assertz(M:rule_by_num(R, VC, NH, HeadList, [])). 502 503vit_expansion(Head, []):- 504 prolog_load_context(module, M),vit_input_mod(M),M:vit_on,!, 505 assert(M:def_rule(Head, [])). 506 507:- multifile sandbox:safe_meta/2. 508 509sandbox:safe_meta(viterbi:viterbi(_,_,_), []). 510 511:- thread_local vit_file/1. 512 513user:term_expansion((:- viterbi), []) :-!, 514 prolog_load_context(source, Source), 515 asserta(vit_file(Source)), 516 prolog_load_context(module, M), 517 retractall(M:local_viterbi_setting(_,_)), 518 findall(local_viterbi_setting(P,V),default_setting_viterbi(P,V),L), 519 assert_all(L,M,_), 520 assert(vit_input_mod(M)), 521 retractall(M:rule_n(_)), 522 assert(M:rule_n(0)), 523 M:(dynamic rule_by_num/5), 524 M:(dynamic rule/8,def_rule/2), 525 retractall(M:rule_by_num(_,_,_,_,_)), 526 retractall(M:rule(_,_,_,_,_,_,_,_)), 527 style_check(-discontiguous). 528 529user:term_expansion(end_of_file, end_of_file) :- 530 vit_file(Source), 531 prolog_load_context(source, Source), 532 retractall(vit_file(Source)), 533 prolog_load_context(module, M), 534 vit_input_mod(M),!, 535 retractall(vit_input_mod(M)), 536 style_check(+discontiguous). 537 538 539user:term_expansion(In, Out) :- 540 \+ current_prolog_flag(xref, true), 541 vit_file(Source), 542 prolog_load_context(source, Source), 543 vit_expansion(In, Out)