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/cpl.pl

136 lines
3.2 KiB
Prolog

/*
LPAD and CP-Logic reasoning suite
File cpl.pl
Computes the semantics of CP-logic programs
Copyright (c) 2007, Fabrizio Riguzzi
*/
:-use_module(lpad,[slg/3,setting/2,set/2]).
:-use_module(semcpl,[build/0,print/0]).
:-use_module(library(lists)).
p(File):-
lpad:p(File).
sc(Goals,Evidences,Prob):-
lpad:convert_to_goal(Goals,Goal),
lpad:convert_to_goal(Evidences,Evidence),
solve_cond(Goal,Evidence,Prob).
solve_cond(Goal,Evidence,Prob):-
(setof((DerivE,D),slg(Evidence,DerivE,D),LCouplesE)->
separate(LCouplesE,LCDupE,LDefClE),
lpad:rem_dup_lists(LCDupE,[],LCE),
lpad:build_formula(LCE,FormulaE,[],VarE),
lpad:var2numbers(VarE,0,NewVarE),
lpad:compute_prob(NewVarE,FormulaE,ProbE,0),
solve_cond_goals(Goal,LCE,ProbGE,LGE,LDefClGE),
(setof((R,S),N^(member(C,LGE),member((N,R,S),C)),LDisClGE)->
true
;
LDisClGE=[]
),
append(LDefClGE,LDefClE,LDefDup),
remove_duplicates(LDefDup,LDef),
append(LDisClGE,LDef,LCl),
test_validity(LCl),
Prob is ProbGE/ProbE
;
format("P(Evidence)=0~n",[]),
Prob=undefined
).
solve_cond_goals(Goals,LE,ProbGE,LGE,LDefClGE):-
(setof((DerivGE,D),find_deriv_GE(LE,Goals,DerivGE,D),LCouplesGE)->
separate(LCouplesGE,LCDupGE,LDefClGE),
lpad:rem_dup_lists(LCDupGE,[],LGE),
lpad:build_formula(LGE,FormulaGE,[],VarGE),
lpad:var2numbers(VarGE,0,NewVarGE),
lpad:call_compute_prob(NewVarGE,FormulaGE,ProbGE)
;
ProbGE=0
).
find_deriv_GE(LD,GoalsList,Deriv,Def):-
member(D,LD),
lpad:slg(GoalsList,D,DerivDup,[],Def),
remove_duplicates(DerivDup,Deriv).
s(GoalsList,Prob):-
lpad:convert_to_goal(GoalsList,Goal),
solve(Goal,Prob).
solve(Goal,Prob):-
(setof((C,D),slg(Goal,C,D),LCouples)->
separate(LCouples,LCDup,LDefCl),
(member(unsound,LCDup)->
format("Unsound program ~n",[]),
Prob=unsound
;
lpad:rem_dup_lists(LCDup,[],L),
(ground(L)->
lpad:build_formula(L,Formula,[],Var),
lpad:var2numbers(Var,0,NewVar),
(setting(savedot,true)->
format("Variables: ~p~n",[Var]),
lpad:compute_prob(NewVar,Formula,_Prob,1)
;
lpad:compute_prob(NewVar,Formula,Prob,0)
),
(setof((R,S),N^(member(C,LCDup),member((N,R,S),C)),LDisCl)->
true
;
LDisCl=[]
),
append(LDisCl,LDefCl,LCl),
test_validity(LCl)
;
format("It requires the choice of a head atom from a non ground head~n~p~n",[L]),
Prob=non_ground
)
)
;
Prob=0
).
test_validity(L):-
retractall(semcpl:root(_)),
retractall(semcpl:clauses(_)),
retractall(semcpl:herbrand_base(_)),
retractall(semcpl:node(_,_,_,_,_)),
retractall(semcpl:new_number(_)),
assert(semcpl:new_number(0)),
get_clauses_hb(L,LC,HBDup),
remove_duplicates(HBDup,HB0),
delete(HB0, '' ,HB),
assert(semcpl:herbrand_base(HB)),
assert(semcpl:clauses(LC)),
build.
get_clauses_hb([],[],[]):-!.
get_clauses_hb([(R,S)|T],[r(Head,Body)|TR],HB):-
lpad:rule(R,S,_,Head,Body),!,
get_atoms(Head,Atoms),
append(Atoms,HB0,HB),
get_clauses_hb(T,TR,HB0).
get_clauses_hb([(R,S)|T],[r([Head:1],Body)|TR],HB):-
lpad:def_rule(R,S,Head,Body),
append([Head],HB0,HB),
get_clauses_hb(T,TR,HB0).
get_atoms([],[]):-!.
get_atoms([H:_P|T],[H|TA]):-
get_atoms(T,TA).
separate([],[],[]):-!.
separate([(C,D)|T],[C|TC],Cl):-
append(D,Cl0,Cl),
separate(T,TC,Cl0).