This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/packages/CLPBN/pfl.yap

219 lines
5.4 KiB
Plaintext
Raw Normal View History

2012-01-10 17:01:06 +00:00
%
2012-12-17 11:53:57 +00:00
% This module defines PFL, the Prolog Factor Language.
2012-01-10 17:01:06 +00:00
%
%
2012-12-17 11:53:57 +00:00
:- module(pfl,
[op(550,yfx,@),
op(550,yfx,::),
2012-12-17 17:57:00 +00:00
op(1150,fx,bayes),
op(1150,fx,markov),
factor/6,
skolem/2,
defined_in_factor/2,
get_pfl_cpt/5, % given id and keys, return new keys and cpt
get_pfl_parameters/2, % given id return par factor parameter
new_pfl_parameters/2, % given id set new parameters
get_first_pvariable/2, % given id get firt pvar (useful in bayesian)
get_factor_pvariable/2, % given id get any pvar
add_ground_factor/5 %add a new bayesian variable (for now)
]).
2012-01-10 17:01:06 +00:00
:- reexport(library(clpbn),
[clpbn_flag/2 as pfl_flag,
set_clpbn_flag/2 as set_pfl_flag,
set_solver/1,
2012-12-17 21:19:47 +00:00
set_em_solver/1,
conditional_probability/3,
pfl_init_solver/5,
pfl_run_solver/3
]).
2012-01-10 17:01:06 +00:00
2012-09-23 13:25:15 +01:00
:- reexport(library(clpbn/aggregates),
[avg_factors/5]).
2012-09-23 13:25:15 +01:00
2012-04-03 15:01:35 +01:00
:- ( % if clp(bn) has done loading, we're top-level
predicate_property(set_pfl_flag(_,_), imported_from(clpbn))
2012-12-17 11:53:57 +00:00
->
2012-04-03 15:01:35 +01:00
% we're using factor language
% set appropriate flag
set_pfl_flag(use_factors,on)
2012-12-17 11:53:57 +00:00
;
2012-04-03 15:01:35 +01:00
% we're within clp(bn), no need to do anything
true
2012-12-17 11:53:57 +00:00
).
2012-04-03 15:01:35 +01:00
2012-12-17 11:53:57 +00:00
:- use_module(library(atts)).
2012-09-23 13:25:15 +01:00
:- use_module(library(lists),
[nth0/3,
append/3,
member/2
]).
2012-12-17 11:53:57 +00:00
2012-09-23 13:25:15 +01:00
:- dynamic factor/6, skolem_in/2, skolem/2, preprocess/3, evidence/2, id/1.
2012-04-03 15:01:35 +01:00
user:term_expansion( bayes((Formula ; Phi ; Constraints)), pfl:factor(bayes,Id,FList,FV,Phi,Constraints)) :-
2012-03-22 19:10:15 +00:00
!,
term_variables(Formula, FreeVars),
2012-04-11 23:48:59 +01:00
FV =.. [''|FreeVars],
2012-03-22 19:10:15 +00:00
new_id(Id),
process_args(Formula, Id, 0, _, FList, []).
2012-04-03 15:01:35 +01:00
user:term_expansion( markov((Formula ; Phi ; Constraints)), pfl:factor(markov,Id,FList,FV,Phi,Constraints)) :-
2012-01-10 17:01:06 +00:00
!,
term_variables(Formula, FreeVars),
2012-04-11 23:48:59 +01:00
FV =.. [''|FreeVars],
2012-01-10 17:01:06 +00:00
new_id(Id),
process_args(Formula, Id, 0, _, FList, []).
2012-04-03 15:01:35 +01:00
user:term_expansion( Id@N, L ) :-
atom(Id), number(N), !,
2012-06-22 19:00:12 +01:00
N1 is N + 1,
2012-04-11 23:48:59 +01:00
findall(G,generate_entity(1, N1, Id, G), L).
2012-01-10 17:01:06 +00:00
user:term_expansion( Goal, [] ) :-
preprocess(Goal, Sk,Var), !,
(ground(Goal) -> true ; throw(error('non ground evidence',Goal))),
% prolog_load_context(module, M),
2012-03-22 19:10:15 +00:00
assert(pfl:evidence(Sk,Var)).
2012-01-10 17:01:06 +00:00
2012-04-03 15:01:35 +01:00
Id@N :-
generate_entity(0, N, Id, G),
assert_static(user:G),
fail.
_Id@_N.
2012-08-29 22:36:46 +01:00
2012-09-23 13:25:15 +01:00
add_ground_factor(bayes, Domain, Vars, CPT, Id) :-
2012-08-29 22:36:46 +01:00
Vars = [K|_],
( skolem(K,_Domain) -> true ; assert(skolem(K, Domain)) ),
new_id(Id),
2012-09-23 13:25:15 +01:00
asserta(skolem_in(K, Id)),
assert(factor(bayes, Id, Vars, [], CPT, [])).
2012-08-29 22:36:46 +01:00
2012-09-29 11:50:00 +01:00
skolem(_Id:Key,Dom) :- skolem(Key, Dom).
2012-04-03 15:01:35 +01:00
defined_in_factor(Key, Factor) :-
skolem_in(Key, Id),
factor(bayes, Id, [Key|FList], FV, Phi, Constraints), !,
Factor = factor(bayes, Id, [Key|FList], FV, Phi, Constraints).
defined_in_factor(Key, Factor) :-
skolem_in(Key, Id),
factor(markov, Id, FList, FV, Phi, Constraints),
member(Key, FList),
Factor = factor(markov, Id, FList, FV, Phi, Constraints).
generate_entity(N, N, _, _) :- !.
generate_entity(I0, _N, Id, T) :-
2012-04-11 23:48:59 +01:00
atomic_concat(p, I0, P),
2012-04-03 15:01:35 +01:00
T =.. [Id, P].
generate_entity(I0, N, Id, T) :-
I is I0+1,
generate_entity(I, N, Id, T).
2012-01-10 17:01:06 +00:00
id(0).
new_id(Id) :-
retract(id(Id0)),
Id is Id0+1,
assert(id(Id)).
2012-08-29 22:36:46 +01:00
process_args(V, _Id, _I0, _I ) --> { var(V) }, !,
{ throw(error(instantiation_error,pfl:process_args)) }.
2012-09-23 13:25:15 +01:00
process_args((Arg1,V), Id, I0, I ) --> { var(V) }, !,
{ I is I0+1 },
process_arg(Arg1, Id, I),
[V].
2012-01-10 17:01:06 +00:00
process_args((Arg1,Arg2), Id, I0, I ) --> !,
process_args(Arg1, Id, I0, I1),
process_args(Arg2, Id, I1, I).
process_args(Arg1, Id, I0, I ) -->
{ I is I0+1 },
process_arg(Arg1, Id, I).
process_arg(Sk::D, Id, _I) -->
!,
{
2012-12-17 17:57:00 +00:00
new_skolem(Sk,D),
assert(skolem_in(Sk, Id))
},
2012-01-10 17:01:06 +00:00
[Sk].
process_arg(Sk, Id, _I) -->
!,
{
2012-12-17 17:57:00 +00:00
% if :: been used before for this skolem
% just keep on using it,
% otherwise, assume it is t,f
( \+ \+ skolem(Sk,_D) -> true ; new_skolem(Sk,[t,f]) ),
assert(skolem_in(Sk, Id))
},
2012-01-10 17:01:06 +00:00
[Sk].
new_skolem(Sk,D) :-
copy_term(Sk, Sk1),
skolem(Sk1, D1),
Sk1 =@= Sk,
!,
2012-06-22 19:00:12 +01:00
( D1 = D -> true ; throw(pfl(permission_error(redefining_domain(Sk),D:D1)))).
2012-01-10 17:01:06 +00:00
new_skolem(Sk,D) :-
interface_predicate(Sk),
assert(skolem(Sk, D)).
interface_predicate(Sk) :-
Sk =.. SKAs,
append(SKAs, [Var], ESKAs),
ESk =.. ESKAs,
assert(preprocess(ESk, Sk, Var)),
2012-06-01 13:17:39 +01:00
% transform from PFL to CLP(BN) call
2012-01-10 17:01:06 +00:00
assert_static((user:ESk :-
2012-12-17 17:57:00 +00:00
evidence(Sk,Ev) -> Ev = Var;
var(Var) -> insert_atts(Var,Sk) ;
add_evidence(Sk,Var)
)).
2012-01-10 17:01:06 +00:00
insert_atts(Var,Sk) :-
clpbn:put_atts(Var,[key(Sk)]).
add_evidence(Sk,Var) :-
skolem(Sk,D),
once(nth0(E,D,Var)),
clpbn:put_atts(_V,[key(Sk),evidence(E)]).
2012-09-23 13:25:15 +01:00
%% get_pfl_cpt(Id, Keys, Ev, NewKeys, Out) :-
%% factor(_Type,Id,[Key|_],_FV,avg,_Constraints), !,
%% Keys = [Key|Parents],
%% writeln(Key:Parents),
%% avg_factors(Key, Parents, 0.0, Ev, NewKeys, Out).
get_pfl_cpt(Id, Keys, _, Keys, Out) :-
2012-12-17 17:57:00 +00:00
get_pfl_parameters(Id,Out).
2012-09-23 13:25:15 +01:00
2012-03-22 19:10:15 +00:00
get_pfl_parameters(Id,Out) :-
2012-04-03 15:01:35 +01:00
factor(_Type,Id,_FList,_FV,Phi,_Constraints),
2012-09-23 13:25:15 +01:00
( Phi = [_|_] -> Phi = Out ; call(user:Phi, Out) ).
2012-03-22 19:10:15 +00:00
new_pfl_parameters(Id, NewPhi) :-
2012-06-22 19:00:12 +01:00
retract(factor(Type,Id,FList,FV,_Phi,Constraints)),
2012-04-03 15:01:35 +01:00
assert(factor(Type,Id,FList,FV,NewPhi,Constraints)),
2012-03-22 19:10:15 +00:00
fail.
new_pfl_parameters(_Id, _NewPhi).
get_pfl_factor_sizes(Id, DSizes) :-
2012-04-03 15:01:35 +01:00
factor(_Type, Id, FList, _FV, _Phi, _Constraints),
2012-03-22 19:10:15 +00:00
get_sizes(FList, DSizes).
get_sizes([], []).
get_sizes(Key.FList, Sz.DSizes) :-
skolem(Key, Domain),
length(Domain, Sz),
get_sizes(FList, DSizes).
2012-12-17 17:57:00 +00:00
2012-03-22 19:10:15 +00:00
% only makes sense for bayesian networks
get_first_pvariable(Id,Var) :-
2012-04-03 15:01:35 +01:00
factor(_Type, Id,Var._FList,_FV,_Phi,_Constraints).
2012-03-22 19:10:15 +00:00
% only makes sense for bayesian networks
get_factor_pvariable(Id,Var) :-
2012-04-03 15:01:35 +01:00
factor(_Type, Id,FList,_FV,_Phi,_Constraints),
2012-03-22 19:10:15 +00:00
member(Var, FList).