1:- module(ccp_handlers, [ goal_expls_tables/3, tables_graph/2, run_incr/1, run_tab/3, run_sampling//2, run_prob//2 2 , expl//1, uniform_sampler//2, make_lookup_sampler/2, fallback_sampler//4 3 ]).

Effect handlers for probabilistic programming

This module provides tabled explanation search and sampling as computational effects using delimited control.

To be done

Goal subsumtion in table lookup
Lazy explanation search (see ccbeam in cclab)

14:- use_module(library(typedef)). 15:- use_module(library(lambdaki)). 16:- use_module(library(data/pair), [ffst/3]). 17:- use_module(library(prob/tagless),[discrete//3, uniform//2]). 18:- use_module(library(delimcc), [p_reset/3, p_shift/2]). 19:- use_module(library(rbutils), [rb_app_or_new/5, rb_in/3]). 20:- use_module(library(ccnbref), [run_nb_ref/1, nbref_new/2, nbref_add_with/3]). 21 22:- type tab ---> tab(rbtree(values, list(list(factor))), list(cont)). 23:- type factor ---> module:head ; \number ; sw(A):=A. 24:- type cont == pred(+values, -values). 25:- type values == list(ground). 26 27:- meta_predicate run_prob(3,0,?,?). 28% run_prob(Handler,Goal) --> run_state_handler(prob, Handler, Goal). 29run_prob(Handler,Goal) --> {p_reset(prob, Goal, Status)}, cont_prob(Status,Handler). 30cont_prob(susp(Req,Cont),H) --> call(H,Req), run_prob(H,Cont). 31cont_prob(done,_) --> []. 32 33% ------------- handlers for sampling without tabling ------------------ 34sample(P,sw(SW,X)) --> !, call(P,SW,X). 35sample(_,dist(Ps,Xs,X)) --> !, discrete(Xs,Ps,X). 36sample(_,uniform(Xs,X)) --> !, uniform(Xs,X). 37sample(_,sample(P,X)) --> call(P,X). 38 39run_notab(Goal) :- p_reset(tab, Goal, Status), cont_notab(Status). 40cont_notab(susp(tcall(_,Head,Head), Cont)) :- run_notab(Cont). 41cont_notab(done). 42 43:- meta_predicate run_sampling(4,0,+,-). 44run_sampling(Sampler,Goal,S1,S2) :- 45 run_notab(run_prob(sample(Sampler),Goal,S1,S2)). 46 47fallback_sampler(S1, S2, SW,X) --> call(S1,SW,X) -> []; call(S2,SW,X). 48uniform_sampler(SW,X) --> {call(SW,_,Xs,[])}, uniform(Xs,X). 49lookup_sampler(Map,SW,X) --> {call(SW,ID,Xs,[]), rb_lookup(ID,Ps,Map)}, discrete(Xs,Ps,X). 50 51:- meta_predicate make_lookup_sampler(:,-). 52make_lookup_sampler(M:Params,ccp_handlers:lookup_sampler(Map)) :- 53 maplist(ffst(switch_id(M)), Params,Params1), 54 list_to_rbtree(Params1, Map). 55 56switch_id(M, SW, ID) :- call(M:SW, ID, _, []). 57 58% -------- handlers for tabled explanation graph building ----------- 59% goal_expls_tables(+Goal,-TopExpls:list(list(factor)), -Tables) is det. 60% 61% Runs goal with tabling and explanation building effects to find all explanations 62% for the top goal, and the tables for everything else, from which the rest of 63% an explanation graph can be built. 64:- meta_predicate goal_expls_tables(0,-,-). 65goal_expls_tables(G,Es,Tabs) :- run_nb_ref(nb_goal_expls_tables(G,Es,Tabs)). 66nb_goal_expls_tables(G,Es,Tabs) :- 67 trie_new(Trie), % could pass Trie in and out to allow reuse... 68 run_tab(findall(E,run_prob(expl,G,E,[]),Es), Trie, Es), 69 trie_tables(Trie, Tabs).

74:- meta_predicate run_incr(0). 75run_incr(Goal) :- 76 trie_new(Trie), term_variables(Goal, Ans), 77 run_nb_ref(run_tab(run_prob(expl, Goal, _, []), Trie, Ans)). 78 79expl(tab(G)) --> {term_to_ground(G,F)}, [F]. 80expl(sw(SW,X)) --> {call(SW,ID,Xs,[]), member(X,Xs)}, [ID:=X]. 81expl(dist(Ps,Xs,X)) --> {member2(P,X,Ps,Xs)}, [\P]. 82expl(uniform(Xs,X)) --> {length(Xs,N), P is 1/N, member(X,Xs)}, [\P]. 83expl(factor(F)) --> [F]. 84 85:- meta_predicate run_tab(0,+,?). 86run_tab(Goal, Trie, Ans) :- p_reset(tab, Goal, Status), cont_tab(Status, Trie, Ans). 87 88cont_tab(done, _, _). 89cont_tab(susp(tcall(TableAs,Work,ccp_handlers:p_shift(prob,tab(TableAs))), Cont), Trie, Ans) :- 90 term_variables(TableAs, Y), K = k(Y,Ans,Cont), 91 ( trie_lookup(Trie, TableAs, tab(SolnTrie,KsRef)) 92 -> nbref_add_with(KsRef, post_prepend, K), 93 trie_gen(SolnTrie, Y, _), 94 run_tab(Cont, Trie, Ans) 95 ; nbref_new([K], KsRef), trie_new(SolnTrie), 96 trie_insert(Trie, TableAs, tab(SolnTrie,KsRef)), 97 run_tab(producer(\Y^Work, KsRef, SolnTrie, Ans), Trie, Ans) 98 ). 99 100producer(Generate, KsRef, SolnTrie, Ans) :- 101 run_prob(expl, call(Generate, Y), E, []), 102 ( trie_lookup(SolnTrie,Y,EsRef) 103 -> nbref_add_with(EsRef, prepend, E), fail 104 ; nbref_new([E], EsRef), trie_insert(SolnTrie,Y,EsRef), 105 nb_getval(KsRef, Ks0), copy_term(Ks0,Ks), 106 member(k(Y,Ans,C), Ks), call(C) 107 ). 108 109trie_tables(Trie, TList) :- 110 findall(Table, trie_table(Trie,Table), TList). 111 112trie_table(Trie, Head-Solns) :- 113 trie_gen(Trie, Head, tab(SolnTrie,_)), 114 findall(Soln, soln_trie_solns(SolnTrie,Soln), Solns). 115 116soln_trie_solns(SolnTrie,Y-Es) :- 117 trie_gen(SolnTrie, Y, EsRef), nb_getval(EsRef, Es). 118 119term_to_ground(T1, T2) :- copy_term_nat(T1,T2), numbervars(T2,0,_). 120member2(X,Y,[X|_],[Y|_]). 121member2(X,Y,[_|XX],[_|YY]) :- member2(X,Y,XX,YY). 122post_prepend(X1,[X0|Xs],[X0,X1|Xs]). 123prepend(X1,Xs,[X1|Xs]).

126tables_graph(Tables, Graph) :- 127 rb_empty(Empty), 128 foldl(goal_expls, Tables, Empty, GMap), 129 rb_visit(GMap, Graph). 130 131goal_expls(Goal-Solns) --> 132 {term_variables(Goal,Vars)}, 133 foldl(soln_expls(Goal,Vars), Solns). 134 135soln_expls(G,Y,Y1-Es) --> 136 {copy_term(G-Y,G1-Y1), numbervars(G1-Y1, 0, _)}, % NB Es is already ground 137 (rb_add(G1,Es) -> []; []). % NB duplicate goals should have the same explanations!