clam.pro

来自「prolog开发工具」· PRO 代码 · 共 643 行 · 第 1/2 页

% Clam - expert system shell with EMYCIN type certainty factors

% This system is an imitation of the EMYCIN imitators.  It does backward
% chaininging (goal directed) inference with uncertainty.  The uncertainty
% is modelled using the MYCIN certainty factors.

% The only data structure is an attribute:value pair.

% NOTE - CF calculation in update only good for positive CF

main :-
	do_over,
	super.

% The main command loop

super :-
	repeat,
	write('consult  restart  load  list  trace on/off  how  exit'),nl,
	write('> '),
	read_line([X|Y]),
	doit([X|Y]),
	X == exit.

doit([consult]) :- top_goals,!.
doit([restart]) :- do_over,!.
doit([load]) :- load_rules,!.
doit([list]) :- list_facts,!.
doit([trace,X]) :- set_trace(X),!.
doit([how|Y]) :- how(Y),!.
doit([exit]).
doit([X|Y]) :-
	write('invalid command : '),
	write([X|Y]),nl.

% top_goals works through each of the goals in sequence

top_goals :-
	ghoul(Attr),
	top(Attr),
	print_goal(Attr),
	fail.
top_goals.

% top starts the backward chaining by looking for rules that reference
% the attribute in the RHS.  If it is known with certainty 100, then
% no other rules are tried, and other candidates are eliminated.  Otherwise
% other rules which might yield different values for the attribute 
% are tried as well

top(Attr) :-
	findgoal(av(Attr,Val),CF,[goal(Attr)]),!.
top(_) :- true.

% prints all hypotheses for a given attribute

print_goal(Attr) :-
	nl,
	fact(av(Attr,X),CF,_),
	CF >= 20,
	outp(av(Attr,X),CF),nl,
	fail.
print_goal(Attr) :-write('done with '),write(Attr),nl,nl.

outp(av(A,V),CF) :-
	output(A,V,PrintList),
	pretty(av(A,V), X),
	printlist(X),
	tab(1),write(cf(CF)),write(': '),
	printlist(PrintList),!.
outp(av(A,V),CF) :-
	pretty(av(A,V), X),
	printlist(X),
	tab(1),write(cf(CF)).

printlist([]).
printlist([H|T]) :-
	write(H),tab(1),
	printlist(T).

% findgoal is the guts of the inference.  It copes with already known
% attribute value pairs, multivalued attributes and single valued
% attributes.  It uses the EMYCIN certainty factor arithmetic to
% propagate uncertainties.

% 1 - if its recorded and the value matches, we're done, if the
%     value doesn't match, but its single valued and known with
%     certainty 100 definitely fail

findgoal(X,Y,_) :- bugdisp(['  ',X]),fail.

findgoal(not Goal,NCF,Hist) :-
	findgoal(Goal,CF,Hist),
	NCF is - CF, !.
findgoal(Goal,CF,Hist) :-
	fact(Goal,CF,_), !.
%findgoal(av(Attr,Val),CF) :-
%	bound(Val),
%	fact(av(Attr,V,_),CF),
%	Val \= V,
%	single_valued(Attr),
%	CF=100,
%	!,fail.

% 2 - if its askable, just ask and record the answer

findgoal(Goal,CF,Hist) :-
	can_ask(Goal,Hist),
	!,
	findgoal(Goal,CF,Hist).

% 3 - find a rule with the required attribute on the RHS.  try to prove
%     the LHS.  If its proved, use the certainty of the LHS combined
%     with the certainty of the RHS to compute the cf of the derived
%     result

findgoal(Goal,CurCF,Hist) :-
	fg(Goal,CurCF,Hist).
	
fg(Goal,CurCF,Hist) :-
	rule(N, lhs(IfList), rhs(Goal,CF)),
	bugdisp(['call rule',N]),
	prove(N,IfList,Tally,Hist),
	bugdisp(['exit rule',N]),
	adjust(CF,Tally,NewCF),
	update(Goal,NewCF,CurCF,N),
	CurCF == 100,!.
fg(Goal,CF,_) :- fact(Goal,CF,_).

% can_ask shows how to query the user for various types of goal patterns

can_ask(av(Attr,Val),Hist) :-
	not asked(av(Attr,_)),
	askable(Attr,Menu,Edit,Prompt),
	query_user(Attr,Prompt,Menu,Edit,Hist),
	asserta( asked(av(Attr,_)) ).

% answer the how question at the top level, to explain how an answer was
% derived.  It can be called successive times to get the whole proof.

how([]) :-
	write('Goal? '),read_line(X),nl,
	pretty(Goal,X),
	how(Goal).
how(X) :-
	pretty(Goal,X),
	nl,
	how(Goal).

how(not Goal) :-
	fact(Goal,CF,Rules),
	CF < -20,
	pretty(not Goal,PG),
	write_line([PG,was,derived,from,'rules: '|Rules]),
	nl,
	list_rules(Rules),
	fail.	
how(Goal) :-
	fact(Goal,CF,Rules),
	CF > 20,
	pretty(Goal,PG),
	write_line([PG,was,derived,from,'rules: '|Rules]),
	nl,
	list_rules(Rules),
	fail.
how(_).

list_rules([]).
list_rules([R|X]) :-
	list_rule(R),
%	how_lhs(R),
	list_rules(X).

list_rule(N) :-
	rule(N, lhs(Iflist), rhs(Goal,CF)),
	write_line(['rule  ',N]),
	write_line(['  If']),
	write_ifs(Iflist),
	write_line(['  Then']),
	pretty(Goal,PG),
	write_line(['   ',PG,CF]),nl.

write_ifs([]).
write_ifs([H|T]) :-
	pretty(H,HP),
	tab(4),write_line(HP),
	write_ifs(T).

pretty(av(A,yes),[A]) :- !.
pretty(not av(A,yes), [not,A]) :- !.
pretty(av(A,no),[not,A]) :- !.
pretty(not av(A,V),[not,A,is,V]).
pretty(av(A,V),[A,is,V]).

how_lhs(N) :-
	rule(N, lhs(Iflist), _),
	!, how_ifs(Iflist).
	
how_ifs([]).
how_ifs([Goal|X]) :-
	how(Goal),
	how_ifs(X).
	
% get input from the user.  either a straight answer from the menu, or
% an answer with cf N appended to it.

query_user(Attr,Prompt,[yes,no],_,Hist) :-
	!,
	write(Prompt),nl,
	get_user(X,Hist),
	get_vcf(X,Val,CF),
	asserta( fact(av(Attr,Val),CF,[user]) ).
query_user(Attr,Prompt,Menu,Edit,Hist) :-
	write(Prompt),nl,
	menu_read(VList,Menu,Hist),
	assert_list(Attr,VList).

menu_read(X,Menu,Hist) :-
	write_list(2,Menu),
	get_user(X,Hist).

get_user(X,Hist) :-
	repeat,
	write(': '),
	read_line(X),
	process_ans(X,Hist).

process_ans([why],Hist) :- nl,write_hist(Hist), !, fail.
process_ans(X,_).	

write_hist([]) :- nl.
write_hist([goal(X)|T]) :-
	write_line([goal,X]),
	!, write_hist(T).
write_hist([N|T]) :-
	list_rule(N),
	!, write_hist(T).

write_list(N,[]).
write_list(N,[H|T]) :-
	tab(N),write(H),nl,
	write_list(N,T).

assert_list(_,[]).
assert_list(Attr,[not,Val,cf,CF|X]) :-
	!,
	NCF is - CF,
	asserta( fact(av(Attr,Val),NCF,[user]) ),
	assert_list(Attr,X).
assert_list(Attr,[not,Val|X]) :-
	!,
	asserta( fact(av(Attr,Val),-100,[user]) ),
	assert_list(Attr,X).
assert_list(Attr,[Val,cf,CF|X]) :-
	!,
	asserta( fact(av(Attr,Val),CF,[user]) ),
	assert_list(Attr,X).
assert_list(Attr,[Val|X]) :-
	asserta( fact(av(Attr,Val),100,[user]) ),
	assert_list(Attr,X).

get_vcf([no],yes,-100).
get_vcf([no,CF],yes,NCF) :- NCF is -CF.
get_vcf([no,cf,CF],yes,NCF) :- NCF is -CF.
get_vcf([Val,CF],Val,CF).
get_vcf([Val,cf,CF],Val,CF).
get_vcf([Val],Val,100).
get_vcf([not,Val],Val,-100).
get_vcf([not,Val,CF],Val,NCF) :- NCF is -CF.
get_vcf([not,Val,cf,CF],Val,NCF) :- NCF is -CF.

% prove works through a LHS list of premises, calling findgoal on
% each one.  the total cf is computed as the minimum cf in the list

prove(N,IfList,Tally,Hist) :-
	prov(IfList,100,Tally,[N|Hist]),!.
prove(N,_,_) :-
	bugdisp(['fail rule',N]),
	fail.

prov([],Tally,Tally,Hist).
prov([H|T],CurTal,Tally,Hist) :-
	findgoal(H,CF,Hist),
	minimum(CurTal,CF,Tal),
	Tal >= 20,
	prov(T,Tal,Tally,Hist).

% update - if its already known with a given cf, here is the formula
% for adding in the new cf.  this is used in those cases where multiple
% RHS reference the same attr :val

update(Goal,NewCF,CF,RuleN) :-
	fact(Goal,OldCF,_),
	combine(NewCF,OldCF,CF),
	retract( fact(Goal,OldCF,OldRules) ),
	asserta( fact(Goal,CF,[RuleN | OldRules]) ),
	(CF == 100, single_valued(Attr), erase_other(Attr);
	 true),!.
update(Goal,CF,CF,RuleN) :-
	asserta( fact(Goal,CF,[RuleN]) ).

erase_other(Attr) :-
	fact(av(Attr,Val),CF,_),
	CF < 100,
	retract( fact(av(Attr,Val),CF,_) ),
	fail.
erase_other(Attr) :-true.

adjust(CF1,CF2,CF) :-
	X is CF1 * CF2 / 100,
	int_round(X,CF).

combine(CF1,CF2,CF) :-
	CF1 >= 0,
	CF2 >= 0,
	X is CF1 + CF2*(100 - CF1)/100,
	int_round(X,CF).
combine(CF1,CF2,CF) :-
	CF1 < 0,
	CF2 < 0,
	X is - ( -CF1 -CF2 * (100 + CF1)/100),
	int_round(X,CF).