306 lines
7.0 KiB
Prolog
306 lines
7.0 KiB
Prolog
%
|
|
% Interface the Aleph ILP system to CLP(BN)
|
|
%
|
|
% Relies on the Aleph cost function.
|
|
% It assumes Aleph work as usual, but some variables are of type random.
|
|
%
|
|
:- module(clpbn_aleph,
|
|
[init_clpbn_cost/0,
|
|
random_type/2]).
|
|
|
|
:- dynamic rt/2, inited/1.
|
|
|
|
:- use_module(library('clpbn'),
|
|
[{}/1,
|
|
clpbn_flag/2,
|
|
clpbn_flag/3,
|
|
set_clpbn_flag/2]).
|
|
|
|
:- use_module(library('clpbn/learning/em')).
|
|
|
|
:- use_module(library('clpbn/matrix_cpt_utils'),
|
|
[uniform_CPT_as_list/2]).
|
|
|
|
:- use_module(library('clpbn/dists'),
|
|
[reset_all_dists/0,
|
|
get_dist_key/2,
|
|
get_dist_params/2
|
|
]).
|
|
|
|
:- use_module(library('clpbn/table'),
|
|
[clpbn_tabled_abolish/1,
|
|
clpbn_tabled_asserta/1,
|
|
clpbn_tabled_asserta/2,
|
|
clpbn_tabled_assertz/1,
|
|
clpbn_tabled_clause/2,
|
|
clpbn_tabled_number_of_clauses/2,
|
|
clpbn_is_tabled/1,
|
|
clpbn_tabled_dynamic/1]).
|
|
|
|
%
|
|
% Tell Aleph not to use default solver during saturation
|
|
%
|
|
% all work will be done by EM
|
|
:- set_clpbn_flag(solver,none).
|
|
|
|
%
|
|
% This is the Aleph interface
|
|
% examples are stored as example(Id, Type, Example)
|
|
% CPT domains are stored as random_type(KeySkeleton, ListOfValues).
|
|
%
|
|
|
|
:- use_module(library(lists),[append/3]).
|
|
|
|
:- multifile user:cost/3.
|
|
|
|
% handle uninstantiated examples as hidden variables.
|
|
:- user:set(skolem_examples, false).
|
|
|
|
% avoid doing CLP(BN) stuff except at start
|
|
:- user:set(sat_start_hook, clpbn_aleph:disable_solver).
|
|
:- user:set(sat_stop_hook, clpbn_aleph:enable_solver).
|
|
|
|
:- user:set(reduce_start_hook, clpbn_aleph:disable_solver).
|
|
:- user:set(reduce_stop_hook, clpbn_aleph:enable_solver).
|
|
|
|
:- user:set(record_testclause_hook, clpbn_aleph:do_nothing).
|
|
|
|
:- user:set(newbest_hook, clpbn_aleph:store_theory).
|
|
|
|
disable_solver(_) :-
|
|
clpbn_flag(solver, Old, none),
|
|
nb_setval(old_clpbn_solver, Old).
|
|
disable_solver(_,_) :-
|
|
clpbn_flag(solver, Old, none),
|
|
nb_setval(old_clpbn_solver, Old).
|
|
|
|
enable_solver :-
|
|
nb_getval(old_clpbn_solver, Old),
|
|
set_clpbn_flag(solver, Old).
|
|
enable_solver(_,_) :-
|
|
nb_getval(old_clpbn_solver, Old),
|
|
set_clpbn_flag(solver, Old).
|
|
|
|
do_nothing(_).
|
|
|
|
% backup current best theory in DB.
|
|
store_theory(_,_,_) :-
|
|
eraseall(best_theory),
|
|
fail.
|
|
store_theory(_,(H:-_),_) :-
|
|
clpbn_is_tabled(user:H), !,
|
|
store_tabled_theory(H).
|
|
store_theory(_,(H:-_),_) :-
|
|
store_theory(H).
|
|
|
|
store_tabled_theory(H) :-
|
|
clpbn_tabled_clause(user:H,B),
|
|
add_correct_cpt(B,NB),
|
|
store_cl((H:-NB)),
|
|
fail.
|
|
store_tabled_theory(_).
|
|
|
|
store_theory(H) :-
|
|
clause(user:H,B),
|
|
add_correct_cpt(B,NB),
|
|
store_cl((H:-NB)),
|
|
fail.
|
|
store_theory(_).
|
|
|
|
add_correct_cpt((G,B),(G,NB)) :- !,
|
|
add_correct_cpt(B,NB).
|
|
add_correct_cpt((clpbn:{V = K with Tab }), ({V = K with NTab})) :-
|
|
correct_tab(Tab,K,NTab).
|
|
add_correct_cpt(({V = K with Tab }), ({V = K with NTab})) :-
|
|
correct_tab(Tab,K,NTab).
|
|
|
|
correct_tab(p(Vs,_),K,p(Vs,TDist)) :-
|
|
get_dist_key(Id, K),
|
|
get_dist_params(Id, TDist).
|
|
correct_tab(p(Vs,_,Ps),K,p(Vs,TDist,Ps)) :-
|
|
get_dist_key(Id, K),
|
|
get_dist_params(Id, TDist).
|
|
|
|
store_cl(Cl) :-
|
|
recordz(best_theory, Cl, _).
|
|
|
|
:- user:set(best_clause_hook, clpbn_aleph:add_new_clause).
|
|
|
|
add_new_clause(_,(_ :- true),_,_) :- !.
|
|
add_new_clause(_,(H :- B),_,_) :-
|
|
% user:db_usage,
|
|
% user:db_dynamic,
|
|
domain(H, K, V, D),
|
|
rewrite_body(B, IB, Vs, _, ( !, { V = K with p(D, CPTList, Vs) })),
|
|
% need to remember which CPT we want
|
|
get_dist_key(Id, K),
|
|
get_dist_params(Id, CPTList),
|
|
(
|
|
clpbn_is_tabled(user:H)
|
|
->
|
|
clpbn_tabled_asserta(user:(H :- IB))
|
|
;
|
|
asserta(user:(H :- IB))
|
|
),
|
|
user:setting(verbosity,V),
|
|
( V >= 1 ->
|
|
user:p_message('CLP(BN) Theory'),
|
|
functor(H,N,Ar), listing(user:N/Ar)
|
|
;
|
|
true
|
|
).
|
|
|
|
|
|
% user-defined cost function, Aleph knows about this (and only about this).
|
|
user:cost((H :- B),Inf,Score) :- !,
|
|
domain(H, K, V, D),
|
|
check_info(Inf),
|
|
rewrite_body(B, IB, Vs, Ds, ( !, { V = K with p(D, CPTList, Vs) })),
|
|
uniform_cpt([D|Ds], CPTList),
|
|
(
|
|
clpbn_is_tabled(user:H)
|
|
->
|
|
clpbn_tabled_asserta(user:(H :- IB), R)
|
|
;
|
|
asserta(user:(H :- IB), R)
|
|
),
|
|
(
|
|
cpt_score(Score0)
|
|
->
|
|
erase(R),
|
|
Score is -Score0
|
|
;
|
|
% illegal clause, just get out of here.
|
|
erase(R),
|
|
fail
|
|
).
|
|
user:cost(H,_Inf,Score) :- !,
|
|
init_clpbn_cost(H, Score0),
|
|
Score is -Score0.
|
|
|
|
% this is here so that Aleph will actually compute coverage. Aleph computes
|
|
% coverage only if cost actually checks Inf.
|
|
check_info(_).
|
|
|
|
init_clpbn_cost(_, Score) :-
|
|
inited(Score), !.
|
|
init_clpbn_cost(H, Score) :-
|
|
functor(H,N,A),
|
|
% get rid of Aleph crap
|
|
(
|
|
clpbn_is_tabled(user:H)
|
|
->
|
|
clpbn_tabled_abolish(user:N/A),
|
|
clpbn_tabled_dynamic(user:N/A)
|
|
;
|
|
abolish(user:N/A),
|
|
% make it easy to add and remove clauses.
|
|
dynamic(user:N/A)
|
|
),
|
|
domain(H, K, V, D),
|
|
uniform_cpt([D], CPTList),
|
|
% This will be the default cause, called when the other rules fail.
|
|
(
|
|
clpbn_is_tabled(user:H)
|
|
->
|
|
clpbn_tabled_assertz(user:(H :- !, { V = K with p(D, CPTList) }))
|
|
;
|
|
assert(user:(H :- !, { V = K with p(D, CPTList) }))
|
|
),
|
|
cpt_score(Score),
|
|
assert(inited(Score)).
|
|
|
|
% receives H, and generates a key K, a random variable RV, and a domain D.
|
|
domain(H, K, RV, D) :-
|
|
functor(H,Name,Arity),
|
|
functor(Pred,Name,Arity),
|
|
(
|
|
recorded(aleph,modeh(_,Pred),_)
|
|
->
|
|
true
|
|
;
|
|
user:'$aleph_global'(modeh,modeh(_,Pred))
|
|
),
|
|
arg(Arity,Pred,+RType),
|
|
rt(RType,D), !,
|
|
key_from_head(H,K,RV).
|
|
domain(H, K, V, D) :-
|
|
current_predicate(_,user:domain(_)),
|
|
key_from_head(H,K,V),
|
|
user:domain(K,D).
|
|
|
|
key_from_head(H,K,V) :-
|
|
H =.. [Name|Args],
|
|
(
|
|
clpbn_is_tabled(user:H)
|
|
->
|
|
clpbn_tabled_number_of_clauses(user:H,NClauses)
|
|
;
|
|
predicate_property(user:H,number_of_clauses(NClauses))
|
|
),
|
|
atomic_concat(Name,NClauses,NName),
|
|
append(H0L,[V],Args),
|
|
K =.. [NName|H0L].
|
|
|
|
% transforms_body into something that is going to be called
|
|
% receives G0, and generates a list of goals, a list of variables, and a list of domains.
|
|
% receives also a Tail with the constraint to append at the end.
|
|
rewrite_body((A,B), (user:NA,NB), [V|Vs], [D|Ds], Tail) :-
|
|
rewrite_goal(A, V, D, NA), !,
|
|
rewrite_body(B, NB, Vs, Ds, Tail).
|
|
rewrite_body((A,B), (user:A,NB), Vs, Ds, Tail) :-
|
|
rewrite_body(B,NB, Vs, Ds, Tail).
|
|
rewrite_body(A,(user:NA,Tail), [V], [D], Tail) :-
|
|
rewrite_goal(A, V, D, NA), !.
|
|
rewrite_body(A, (user:A,Tail), [], [], Tail).
|
|
|
|
% so they need not be rewritten.
|
|
rewrite_goal(A,V,D,NA) :-
|
|
functor(A,Name,Arity),
|
|
functor(Pred,Name,Arity),
|
|
(
|
|
recorded(aleph,modeb(_,Pred),_)
|
|
->
|
|
true
|
|
;
|
|
user:'$aleph_global'(modeb,modeb(_,Pred))
|
|
),
|
|
arg(Arity,Pred,-RType),
|
|
rt(RType,D), !,
|
|
A =.. [Name|Args],
|
|
replace_last_var(Args,V,NArgs),
|
|
NA =.. [Name|NArgs].
|
|
|
|
replace_last_var([_],V,[V]) :- !.
|
|
replace_last_var([A|Args],V,[A|NArgs]) :-
|
|
replace_last_var(Args,V,NArgs).
|
|
|
|
|
|
%
|
|
% This is the key
|
|
%
|
|
cpt_score(Lik) :-
|
|
findall(user:Ex, user:example(_,pos,Ex), Exs),
|
|
clpbn_flag(solver, Solver),
|
|
clpbn_flag(em_solver, EMSolver),
|
|
set_clpbn_flag(solver, EMSolver),
|
|
reset_all_dists,
|
|
em(Exs, 0.01, 10, _Tables, Lik),
|
|
set_clpbn_flag(solver, Solver).
|
|
|
|
complete_clpbn_cost(_AlephClause).
|
|
|
|
random_type(A,B) :-
|
|
assert(rt(A,B)).
|
|
|
|
|
|
uniform_cpt(Ds, CPTList) :-
|
|
lengths(Ds, Ls),
|
|
uniform_CPT_as_list(Ls, CPTList).
|
|
|
|
lengths([], []).
|
|
lengths([D|Ds], [L|Ls]) :-
|
|
length(D, L),
|
|
lengths(Ds, Ls).
|
|
|