module for answering queries from CP-logic programs and detecting invalid programs

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2010 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2007-11-15 12:30:57 +00:00 · 2007-11-15 12:30:57 +00:00 · 2ffffffed0
commit 2ffffffed0
parent 8a5020d7c3
1 changed files with 135 additions and 0 deletions
--- a/cplint/cpl.pl
+++ b/cplint/cpl.pl
@ -0,0 +1,135 @@
+/*
+	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).
+