retefoop.pro

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

% RETEFOOPS - forward chaining, frames, and Rete algorithm, also using
%     LEX and MEA to sort the conflict set.
%
% Copyright (c) Dennis Merritt, 1988

% operator definitions

:-op(800,xfx,==>).          % used to separate LHS and RHS of rule
:-op(500,xfy,#).            % used to separate attributes and values
:-op(810,fx,rule).          % used to define rule
:-op(700,xfy,#).            % used for unification instead of =
:-op(700,xfy,\=).		       % not equal
:-op(600,xfy,with).		    % used for frame instances in rules

main :- welcome, supervisor.

welcome  :-
	write($         RETEFOOP - A Toy Production System$),nl,nl,
	write($This is an interpreter for files containing rules coded in the$),nl,
	write($FOOPS format.$),nl,nl,
	write($The => prompt accepts three commands:$),nl,nl,
	write($   load.       - prompts for name of rules file$),nl,
	write($                 enclose in single quotes$),nl,
	write($   compile.    - compiles rules into a rete net$),nl,
	write($   displaynet. - displays the rete net$),nl,
	write($   list.       - lists stuff$),nl,
	write($   list(X).    - lists things which match X$),nl,
	write($   options.    - allows setting of message levels$),nl,
	write($   go.         -  starts the inference$),nl,
	write($   exit.       - does what you'd expect$),nl,nl.

% the supervisor, uses a repeat fail loop to read and process commands
% from the user

supervisor :-
	repeat,
	write('=>'),
	read(X),
	doit(X),
	X = exit.

doit(X) :-
	timer(T1),
	do(X),
	timer(T2),
	T is (T2 - T1) / 600,
	message(101,T),!.

% actions to take based on commands

do(exit) :- !.
do(go) :-
	initialize,
	go, !.
do(load) :-load,!.
do(compile) :- compile,!.
do(displaynet) :- display_net,!.
do(list) :- lst,!.       % lists all of working storage
do(list(X)) :- lst(X),!. % lists all which match the pattern
do(options) :- set_messtypes,!.
do(_) :- message(102).

% loads the rules (Prolog terms) into the Prolog database

load :-
	write('Enter the file name in single quotes (ex. ''room.rkb''.): '),
	read(F),
	reconsult(F),        % loads a rule file into interpreter work space
	rete_compile.			% ** rete change **

compile :-
	rete_compile.

% assert each of the initial conditions into working storage

initialize :-
	message(120),
	abolish(memory,2),
	abolish(inst,3),
	setchron(1),
	delf(all),
	abolish(conflict_set,1),
	assert(conflict_set([])),
	assert(mea(no)),
	initial_data(X),
	assert_list(X),
	message(121), !.
initialize :-
	message(103).

% working storage is represented frame instances - frinsts and also
% stored in a rete net

assert_list([]) :- !.
assert_list([H|T]) :-
	assert_ws(H),
	!,assert_list(T).

% the main inference loop, find a rule and try it.  if it fired, say so
% and repeat the process.  if not go back and try the next rule.  when
% no rules succeed, stop the inference.

go :-
	conflict_set(CS),
	select_rule(CS,inst(ID,LHS,RHS)),
	message(104,ID),
	(process(ID,RHS,LHS); true),		% action side might fail
	del_conflict_set(ID,LHS,RHS),
	!,go.
go :-
	conflict_set([]),
	finished, !.			% supplied in kb for what to do at end
go :-
	message(119).

del_conflict_set(N,TokenList,Action) :-
	conflict_set(CS),
	remove(inst(N,TokenList,Action),CS,CS2),
	message(105,N),
	retract( conflict_set(_) ),
	asserta( conflict_set(CS2) ).
del_conflict_set(N,TokenList,Action) :-
	message(106,N).

add_conflict_set(N,TokenList,Action) :-
	message(107,N),
	retract( conflict_set(CS) ),
	asserta( conflict_set([inst(N,TokenList,Action)|CS]) ).

select_rule(CS,R) :-
	message(122,CS),
	mea_filter(0,CS,[],CSR),
	lex_sort(CSR,R).

% sort the rest of the conflict set according to the lex strategy

lex_sort(L,R) :-
	build_keys(L,LK),
	sort(LK,X),
	reverse(X,[K-R|_]).

% build lists of time stamps for lex sort keys

build_keys([],[]).
build_keys([inst(N,TokenList,C)|T],[Key-inst(N,TokenList,C)|TR]) :-
	build_chlist(TokenList,ChL),
	sort(ChL,X),
	reverse(X,Key),
	build_keys(T,TR).

% build a list of just the times of the various matched attributes
% for use in rule selection

build_chlist([],[]).
build_chlist([_/Chron|T],[Chron|TC]) :-
	build_chlist(T,TC).	

% add the test for mea if appropriate that emphasizes the first attribute
% selected.

mea_filter(_,X,_,X) :- not mea(yes), !.
mea_filter(_,[],X,X).
mea_filter(Max,[inst(N,[A/T|Z],C)|X],Temp,ML) :-
	T < Max,
	!, mea_filter(Max,X,Temp,ML).
mea_filter(Max,[inst(N,[A/T|Z],C)|X],Temp,ML) :-
	T = Max,
	!, mea_filter(Max,X,[inst(N,[A/T|Z],C)|Temp],ML).
mea_filter(Max,[inst(N,[A/T|Z],C)|X],Temp,ML) :-
	T > Max,
	!, mea_filter(T,X,[inst(N,[A/T|Z],C)],ML).
	
get_ws(Prem,Time) :-
	conv(Prem,Class,Name,ReqList),
	getf(Class,Name,ReqList,Time).

assert_ws(Prem) :-
	message(109,Prem),
	conv(Prem,Class,Name,AList),
	addf(Class,Name,AList,TimeStamp),
	addrete(Class,Name,TimeStamp).
	
update_ws(Prem) :-
	conv(Prem,Class,Name,UList),
	frinst(Class,Name,_,TS),
	uptrf(Class,Name,UList,TimeStamp),		% note - does delrete in uptrf
	addrete(Class,Name,TimeStamp),
	!.
update_ws(Prem) :-
	message(108,Prem).
	
retract_ws(Prem/T) :- retract_ws(Prem).
retract_ws(Prem) :-
	conv(Prem,Class,Name,UList),
	delrete(Class,Name,TimeStamp),
	delf(Class,Name,UList).

conv(Class-Name with List, Class, Name, List).
conv(Class-Name, Class, Name, []).

% various tests allowed on the LHS

test(not(X)) :-
	get_ws(X,_),
	!,fail.
test(not(X)) :- !.
test(X#Y) :- X=Y,!.
test(X>Y) :- X>Y,!.
test(X>=Y) :- X>=Y,!.
test(X<Y) :- X<Y,!.
test(X=<Y) :- X=<Y,!.
test(X \= Y) :- not X=Y, !.
test(X = Y) :- X=Y, !.
test(X = Y) :- X is Y,!.
test(is_on(X,Y)) :- is_on(X,Y),!.
test(call(X)) :- call(X).

% recursively execute each of the actions in the RHS list

process(N,[],_) :- message(118,N), !.
process(N,[Action|Rest],LHS) :-
	take(Action,LHS),
	!,process(N,Rest,LHS).
process(N,[Action|Rest],LHS) :-
	message(110,N), !, fail.

% if its retract, use the reference numbers stored in the Lrefs list,
% otherwise just take the action

take(retract(N),LHS) :-
	(N == all; integer(N)),
	retr(N,LHS),!.
take(A,_) :-take(A),!.

take(retract(X)) :- retract_ws(X), !.
take(assert(X)) :-
	assert_ws(X),
	!.
take(update(X)) :-
	update_ws(X),
	!.
take(X # Y) :- X=Y,!.
take(X = Y) :- X is Y,!.
take(write(X)) :- write(X),!.
take(write_line(X)) :- write_line(X),!.
take(nl) :- nl,!.
take(read(X)) :- read(X),!.
take(prompt(X,Y)) :- nl,write(X),read(Y),!.
take(cls) :- cls, !.
take(is_on(X,Y)) :- is_on(X,Y), !.
take(list(X)) :- lst(X), !.
take(call(X)) :- call(X).

% logic for retraction

retr(all,LHS) :-retrall(LHS),!.
retr(N,[]) :- message(111,N), !.
retr(N,[N#Prem|_]) :- retract_ws(Prem),!.
retr(N,[_|Rest]) :- !,retr(N,Rest).

retrall([]).
retrall([N#Prem|Rest]) :-
	retract_ws(Prem),
	!, retrall(Rest).
retrall([Prem|Rest]) :-
	retract_ws(Prem),
	!, retrall(Rest).
retrall([_|Rest]) :-		% must have been a test
	retrall(Rest).

% list all of the terms in working storage

lst :- printfs.

% lists all of the terms which match the pattern

lst(X) :-
	get_ws(X,_),
	write(X),nl,
	fail.
lst(_) :- !.

% maintain a time counter

setchron(N) :-
	retract( chron(_) ),
	asserta( chron(N) ),!.
setchron(N) :-
	asserta( chron(N) ).

getchron(N) :-
	retract( chron(N) ),
	NN is N + 1,
	asserta( chron(NN) ), !.

% this implements a frame based scheme for knowledge representation

:- op(600,fy,val).
:- op(600,fy,calc).
:- op(600,fy,def).
:- op(600,fy,add).
:- op(600,fy,del).

% prep_req takes a request of the form Slot-Val, and forms it into the
% more accurate req(Class,Slot,Facet,Value).  If no facet was mentioned
% in the original request, then the facet of "any" is used to indicate
% the system should use everything possible to find a value.

prep_req(Slot-X,req(C,N,Slot,val,X)) :- var(X), !.
prep_req(Slot-X,req(C,N,Slot,Facet,Val)) :-
	nonvar(X),
	X =.. [Facet,Val],
	facet_list(FL),
	is_on(Facet,FL), !.
prep_req(Slot-X,req(C,N,Slot,val,X)).

facet_list([val,def,calc,add,del,edit]).


% retrieve a list of slot values

get_frame(Class, ReqList) :-
	frame(Class, SlotList),
	slot_vals(Class,_,ReqList,SlotList).

getf(Class,Name,ReqList) :-
	getf(Class,Name,ReqList,_).
	
getf(Class,Name,ReqList,TimeStamp) :-
	frinst(Class, Name, SlotList, TimeStamp),
	slot_vals(Class, Name, ReqList, SlotList).