yap-6.3/packages/CLPBN/learning/aleph_params.yap

%
% 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).