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/cplint/semcpl.pl
2007-11-15 12:32:13 +00:00

569 lines
11 KiB
Prolog

/*
Program for computing the probability of a query directly according to the
semantics
Copyright (c) 2007, Fabrizio Riguzzi
*/
:-module(semcpl,[p/1,s/2,sc/3,build/0,print/0,set/2]).
:-use_module(library(lists)).
:-dynamic setting/2.
%:-set_prolog_flag(unknown,fail).
setting(epsilon_parsing,0.00001).
setting(ground_body,false).
/* available values: true, false
if true, both the head and the body of each clause will be grounded, otherwise
only the head is grounded. In the case in which the body contains variables
not appearing in the head, the body represents an existential event */
sc(G,E,P):-
append(G,E,GE),
s(GE,PGE),
s(E,PE),
(PE\==0->
P is PGE/PE
;
P=undefined
).
s(GoalsList,Prob):-
findall((State,Prob),node(_,_,State,empty,Prob),LL),
sum_prob(LL,GoalsList,0,Prob).
sum_prob([],_GL,P,P):-!.
sum_prob([(State,Prob)|T],GL,P0,P):-
copy_term(GL,GLC),
(body_true(GLC,State)->
P1 is P0+Prob
;
P1 is P0
),
sum_prob(T,GL,P1,P).
/* predicates for build the probabilistic process tree */
build:-
build([]).
build(Context):-
clauses(Cl),
herbrand_base(HB),
deleteall(HB,Context,HB1),
get_new_atom(A),
assert(root(A)),
build(A,Context,1,Cl,HB1).
build(Parent,State,Prob,Clauses,HB):-
get_new_atom(Node),
compute_three_valued(State,Clauses,HB,[],Unknowns),
choose_clause(Clauses,State,Unknowns,RemainingClauses,Clause),
(Clause=empty->
(RemainingClauses=[]->
assert(node(Node,Parent,State,empty,Prob))
;
format("Invalid program.~nInterpretation=~p.~nUnknowns atoms=~p.~nClauses=~p~n",[State,Unknowns,RemainingClauses])
)
;
Clause=r(Head,Body),
assert(node(Node,Parent,State,r(Head,Body),Prob)),
new_states(Node,Head,State,Prob,RemainingClauses,Unknowns)
).
choose_clause([],_True,_Unk,[],empty):-!.
choose_clause([r(Head,Body)|T],True,Unk,RemCl,Clause):-
copy_term(Body,BodyC),
(body_true(BodyC,True,[],Unk)->
Clause=r(Head,Body),
remove_false(T,True,Unk,RemCl)
;
(body_false(BodyC,True,[],Unk)->
RemCl=RemCl0
;
RemCl=[r(Head,Body)|RemCl0]
),
choose_clause(T,True,Unk,RemCl0,Clause)
).
remove_false([],_True,_Unk,[]):-!.
remove_false([r(Head,Body)|T],True,Unk,RemCl):-
copy_term(Body,BodyC),
(body_false(BodyC,True,[],Unk)->
RemCl=RemCl0
;
RemCl=[r(Head,Body)|RemCl0]
),
remove_false(T,True,Unk,RemCl0).
body_true([],_,_,_):-!.
body_true([\+ H|T],True,False,Unk):-
(\+ ground(H)->
format("Floundering ~n",[])
;
true
),
\+ member(H,True),\+ member(H,Unk),!,
body_true(T,True,False,Unk).
body_true([H|T],True,False,Unk):-
H \= (\+ _A),
member(H,True),
body_true(T,True,False,Unk).
body_true([H|T],True,False,Unk):-
builtin(H),
call(H),
body_true(T,True,False,Unk).
body_true([],_):-!.
body_true([\+ H|T],True):-
\+ member(H,True),!,
body_true(T,True).
body_true([H|T],True):-
member(H,True),!,
body_true(T,True).
body_undef([\+ H|T],True,False,Unk):-
member(H,False),!,
body_undef(T,True,False,Unk).
body_undef([\+ H|T],True,False,Unk):-
\+ member(H,True),\+ member(H,Unk),!,
body_undef(T,True,False,Unk).
body_undef([\+ H|T],True,False,Unk):-
member(H,Unk),!,
\+ body_false(T,True,False,Unk).
body_undef([H|T],True,False,Unk):-
member(H,True),!,
body_undef(T,True,False,Unk).
body_undef([H|T],True,False,Unk):-
member(H,Unk),!,
\+ body_false(T,True,False,Unk).
compute_three_valued(State,Clauses,False,Unknowns0,Unknowns):-
choose_clause_three_val(Clauses,State,False,Unknowns0,RemainingClauses,Clause),
(Clause=empty->
Unknowns=Unknowns0
;
Clause=r(Head,_Body),
new_int(Head,False,False1,Unknowns0,Unknowns1),
compute_three_valued(State,RemainingClauses,False1,Unknowns1,Unknowns)
).
choose_clause_three_val([],_True,_False,_Unk,_,empty):-!.
choose_clause_three_val([r(Head,Body)|T],True,False,Unk,RemCl,Clause):-
(\+ body_false(Body,True,False,Unk)->
Clause=r(Head,Body),
RemCl=T
;
RemCl=[r(Head,Body)|RemCl0],
choose_clause_three_val(T,True,False,Unk,RemCl0,Clause)
).
body_false([\+ H|_T],True,_False,_Unk):-
(\+ ground(H)->
format("Floundering ~n",[])
;
true
),
member(H,True),!.
body_false([\+ H|T],True,False,Unk):-
builtin(H),
(call(H)->
true
;
body_false(T,True,False,Unk)
).
body_false([\+ _H|T],True,False,Unk):-!,
body_false(T,True,False,Unk).
body_false([H|T],True,False,Unk):-
builtin(H),
call(H),!,
body_false(T,True,False,Unk).
body_false([H|_T],_True,_False,_Unk):-
builtin(H),
\+ call(H),!.
body_false([H|T],True,False,Unk):-
findall(H,(member(H,True);member(H,Unk)),LH),!,
body_false_list(LH,H,T,True,False,Unk).
body_false_list([],_,_,_,_,_):-!.
body_false_list([H|T],A,Body,True,False,Unk):-
copy_term((A,Body),(AC,BodyC)),
AC=H,
body_false(BodyC,True,False,Unk),
body_false_list(T,A,Body,True,False,Unk).
new_int([],False,False,Unk,Unk):-!.
new_int([H:_P|T],False0,False,Unk0,Unk):-
(member(H,False0)->
delete(False0,H,False1),
append(Unk0,[H],Unk1)
;
False1=False0,
Unk1=Unk0
),
new_int(T,False1,False,Unk1,Unk).
new_states(_,[],_,_,_,_):-!.
new_states(Node,[H:P|T],State,Prob,Clauses,HB):-
Prob1 is P*Prob,
(member(H,State)->
NewState=State
;
append(State,[H],NewState)
),
build(Node,NewState,Prob1,Clauses,HB),
new_states(Node,T,State,Prob,Clauses,HB).
get_new_atom(Atom):-
retract(new_number(N)),
N1 is N+1,
assert(new_number(N1)),
number_atom(N,NA),
atom_concat('n',NA,Atom).
/* predicates for printing the probabilistic process tree */
print:-
root(Root),
print_children(Root,"").
print_children(Parent,Tab):-
findall((Node,State,Clause,Prob),node(Node,Parent,State,Clause,Prob),LC),
print_list(LC,Tab).
print_list([],_Tab):-!.
print_list([(Node,State0,Clause,Prob)|T],Tab):-
delete(State0,'',State),
(Clause=empty-> % leaf
format("~s~p ~f~n",[Tab,State,Prob])
;
format("~s~p ~p ~f~n",[Tab,State,Clause,Prob]),
append(Tab,"| ",Tab1),
print_children(Node,Tab1)
),
print_list(T,Tab).
extract_vars(Var,V0,V):-
var(Var),!,
(member_eq(Var,V0)->
V=V0
;
append(V0,[Var],V)
).
extract_vars(Term,V0,V):-
Term=..[_F|Args],
extract_vars_list(Args,V0,V).
extract_vars_list([],V,V).
extract_vars_list([Term|T],V0,V):-
extract_vars(Term,V0,V1),
extract_vars_list(T,V1,V).
/* predicate for parsing the program file */
p(File):-
parse(File),
build.
parse(File):-
retractall(root(_)),
retractall(clauses(_)),
retractall(herbrand_base(_)),
retractall(node(_,_,_,_,_)),
retractall(new_number(_)),
assert(new_number(0)),
atom_concat(File,'.uni',FileUni),
reconsult(FileUni),
atom_concat(File,'.cpl',FilePl),
open(FilePl,read,S),
read_clauses(S,C),
close(S),
process_clauses(C,ClausesVar),
instantiate(ClausesVar,[],Clauses),
assert(clauses(Clauses)),
build_herbrand_base(HB),
assert(herbrand_base(HB)).
build_herbrand_base(HB):-
findall(A,mode(A),LA),
inst_list(LA,[],HB).
inst_list([],HB,HB):-!.
inst_list([H|T],HB0,HB):-
functor(H,F,Args),
functor(A,F,Args),
findall(A,instantiate_atom_modes(A),LA),
append(HB0,LA,HB1),
inst_list(T,HB1,HB).
instantiate([],C,C).
instantiate([r(_V,H,B)|T],CIn,COut):-
findall(r(H,BOut),instantiate_clause_modes(H,B,BOut),L),
append(CIn,L,C1),
instantiate(T,C1,COut).
instantiate_clause_modes(H,B,BOut):-
instantiate_head_modes(H),
instantiate_body_modes(B,BOut).
instantiate_head_modes([]):-!.
instantiate_head_modes([H:_P|T]):-
instantiate_atom_modes(H),
instantiate_head_modes(T).
instantiate_body_modes(BL,BL):-
setting(ground_body,false),!.
instantiate_body_modes(BL0,BL):-
instantiate_list_modes(BL0,BL).
instantiate_list_modes([],[]).
instantiate_list_modes([H|T0],T):-
builtin(H),!,
call(H),
instantiate_list_modes(T0,T).
instantiate_list_modes([\+ H|T0],T):-
builtin(H),!,
\+ call(H),
instantiate_list_modes(T0,T).
instantiate_list_modes([\+ H|T0],[\+ H|T]):-!,
instantiate_atom_modes(H),
instantiate_list_modes(T0,T).
instantiate_list_modes([H|T0],[H|T]):-
instantiate_atom_modes(H),
instantiate_list_modes(T0,T).
instantiate_atom_modes(''):-!.
instantiate_atom_modes(A):-
functor(A,F,NArgs),
functor(TA,F,NArgs),
A=..[F|Args],
mode(TA),
TA=..[F|Types],
instantiate_args_modes(Args,Types).
instantiate_args_modes([],[]):-!.
instantiate_args_modes([H|T],[TH|TT]):-
type(TH,Constants),
member(H,Constants),
instantiate_args_modes(T,TT).
process_clauses([(end_of_file,[])],[]).
process_clauses([((H:-B),V)|T],[r(V,HL,BL)|T1]):-
H=(_;_),!,
list2or(HL1,H),
list2and(BL,B),
process_head(HL1,0,HL),
process_clauses(T,T1).
process_clauses([((H:-B),V)|T],[r(V,HL,BL)|T1]):-
H=(_:_),!,
list2or(HL1,H),
process_head(HL1,0,HL),
list2and(BL,B),
process_clauses(T,T1).
process_clauses([((H:-B),V)|T],[r(V,[H:1],BL)|T1]):-!,
list2and(BL,B),
process_clauses(T,T1).
process_clauses([(H,V)|T],[r(V,HL,[])|T1]):-
H=(_;_),!,
list2or(HL1,H),
process_head(HL1,0,HL),
process_clauses(T,T1).
process_clauses([(H,V)|T],[r(V,HL,[])|T1]):-
H=(_:_),!,
list2or(HL1,H),
process_head(HL1,0,HL),
process_clauses(T,T1).
process_clauses([(H,V)|T],[r(V,[H:1],[])|T1]):-
process_clauses(T,T1).
process_head([H:PH],P,[H:PH1|Null]):-
PH1 is PH,
PNull is 1-P-PH1,
setting(epsilon_parsing,Eps),
EpsNeg is - Eps,
PNull > EpsNeg,
(PNull>Eps->
Null=['':PNull]
;
Null=[]
).
process_head([H:PH|T],P,[H:PH1|NT]):-
PH1 is PH,
P1 is P+PH1,
process_head(T,P1,NT).
read_clauses(S,Clauses):-
(setting(ground_body,true)->
read_clauses_ground_body(S,Clauses)
;
read_clauses_exist_body(S,Clauses)
).
read_clauses_ground_body(S,[(Cl,V)|Out]):-
read_term(S,Cl,[variable_names(V)]),
(Cl=end_of_file->
Out=[]
;
read_clauses_ground_body(S,Out)
).
read_clauses_exist_body(S,[(Cl,V)|Out]):-
read_term(S,Cl,[variable_names(VN)]),
extract_vars_cl(Cl,VN,V),
(Cl=end_of_file->
Out=[]
;
read_clauses_exist_body(S,Out)
).
extract_vars_cl(end_of_file,[]).
extract_vars_cl(Cl,VN,Couples):-
(Cl=(H:-_B)->
true
;
H=Cl
),
extract_vars(H,[],V),
pair(VN,V,Couples).
pair(_VN,[],[]).
pair([VN= _V|TVN],[V|TV],[VN=V|T]):-
pair(TVN,TV,T).
list2or([X],X):-
X\=;(_,_),!.
list2or([H|T],(H ; Ta)):-!,
list2or(T,Ta).
list2and([],true):-!.
list2and([X],X):-
X\=(_,_),!.
list2and([H|T],(H,Ta)):-!,
list2and(T,Ta).
builtin(_A is _B).
builtin(_A > _B).
builtin(_A < _B).
builtin(_A >= _B).
builtin(_A =< _B).
builtin(_A =:= _B).
builtin(_A =\= _B).
builtin(true).
builtin(false).
builtin(_A = _B).
builtin(_A==_B).
builtin(_A\=_B).
builtin(_A\==_B).
bg(member(_El,_L)).
bg(average(_L,_Av)).
bg(max_list(_L,_Max)).
bg(min_list(_L,_Max)).
average(L,Av):-
sum_list(L,Sum),
length(L,N),
Av is Sum/N.
assert_all([]):-!.
assert_all([(:- G)|T]):-!,
call(G),
assert_all(T).
assert_all([H|T]):-!,
assertz((H)),
assert_all(T).
assert_all(C):-
assertz((C)).
/* set(Par,Value) can be used to set the value of a parameter */
set(Parameter,Value):-
retract(setting(Parameter,_)),
assert(setting(Parameter,Value)).
deleteall(L,[],L).
deleteall(L,[H|T],LOut):-
delete(L,H,L1),
deleteall(L1,T,LOut).
member_eq(A,[H|_T]):-
A==H.
member_eq(A,[_H|T]):-
member_eq(A,T).