% 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

% Modified to work with Sicstus Prolog 4.0.
% (B. Ross, Jan 2008)


?- op(200, fy, 'not').

?- dynamic asked/1, fact/3, rule/1, multivalued/1, askable/1.

?- unknown(_, fail).

main :-
	do_over,
	super.

% The main command loop

super :-
	repeat,
	write('consult, restart, load, list, trace_on, trace_off, how, exit'),nl,
	write('> '),
	read(X),
	doit(X),
	X == exit.

doit(consult) :- top_goals, !.
doit(restart) :- do_over, !.
doit(load) :- load_kb, !.
doit(list) :- list_facts, !.
doit(trace_on) :- set_trace(on), !.
doit(trace_off) :- set_trace(off), !.
doit(how(Y)) :- how(Y), !.
doit(exit).
doit(X) :-
	write('invalid command : '),
	write(X),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) :-
	\+ 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_line2(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(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(not-Val,Val,-100) :- !.
get_vcf(not-Val-CF,Val,NCF) :- NCF is -CF, !.
get_vcf(no,yes,-100) :- !.
get_vcf(no-CF,yes,NCF) :- NCF is -CF, !.
get_vcf(Val-CF,Val,CF) :- !.
get_vcf(Val,Val,100).

% 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).
combine(CF1,CF2,CF) :-
	(CF1 < 0; CF2 < 0),
	(CF1 > 0; CF2 > 0),
	abs_minimum(CF1,CF2,MCF),
	X is 100 * (CF1 + CF2) / (100 - MCF),
	int_round(X,CF).

abs_minimum(A,B,X) :-
	absolute(A, AA),
	absolute(B, BB),
	minimum(AA,BB,X).

absolute(X, X) :- X >= 0.
absolute(X, Y) :- X < 0, Y is -X.

%minimum(A,B,A) :- A =< B.
%minimum(A,B,B) :- B > A.

%min([],X,X).
%min([H|T],Z,X) :-
%	H < Z,
%	min(T,H,X).
%min([H|T],Z,X) :-
%	H >= Z,
%	min(T,Z,X).

minimum(X,Y,X) :- X =< Y,!.
minimum(X,Y,Y) :- Y =< X.

int_round(X,I) :-
	X >= 0,
	I is integer(X + 0.5).
int_round(X,I) :-
	X < 0,
	I is integer(X - 0.5).

set_trace(off) :-
	ruletrace,
	retract( ruletrace ).
set_trace(on) :-
	\+ ruletrace,
	asserta( ruletrace ).
set_trace(_).

single_valued(A) :-multivalued(A),!,fail.
single_valued(A) :-true.

list_facts :-
	fact(X,Y,_),
	write(fact(X,Y)),nl,
	fail.
list_facts :-true.

do_over :-
	abolish(asked/1),
	abolish(fact/3).

clear :-
	abolish(asked/1),
	abolish(fact/3),
	abolish(rule/1),
	abolish(multivalued/1),
	abolish(askable/1),
	abolish(ghoul/1).
	
blank_lines(0).
blank_lines(N) :-
	nl,
	NN is N - 1,
	blank_lines(NN).

bugdisp(L) :-
	ruletrace,
	write_line(L), !.
bugdisp(_).

write_line(L) :-
	flatten(L,LF),
	write_lin(LF).
	
write_lin([]) :- nl.
write_lin([H|T]) :-
	write(H), tab(1),
	write_lin(T).

flatten([],[]) :- !.
flatten([[]|T],T2) :-
	flatten(T,T2), !.
flatten([[X|Y]|T], L) :-
	flatten([X|[Y|T]],L), !.
flatten([H|T],[H|T2]) :-
	flatten(T,T2).                   

load_kb :-
        write('Enter file name in single quotes (ex. \'car2.ckb\'.): '),
        read(F),
        my_consult(F).

my_consult(Files) :-
        load_files(Files, [load_type(source),compilation_mode(assert_all)]).

clear_db :-
	abolish(cf_model/1),
	abolish(ghoul/1),
	abolish(askable/4),
	abolish(output/3),
	abolish(rule/3).

bug(cf_model(X)) :- write(cf_model(X)),nl,!.
bug(ghoul(X)):- write(ghoul(X)),nl,!.
bug(askable(A,_,_,_)):- write('askable '),write(A),nl,!.
bug(output(A,V,PL)):- write('output '),write(V),nl,!.
bug(rule(N,_,_)):- write('rule '),write(N),nl,!.
bug(X) :- write(X),nl.

tab(N) :- N =< 0, !.
tab(N) :-
        write(' '),
        M is N-1,
        !,
        tab(M).