retefoop.pro

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

slot_vals(_,_,[],_).
slot_vals(C,N,[Req|Rest],SlotList) :-
	prep_req(Req,req(C,N,S,F,V)),
	find_slot(req(C,N,S,F,V),SlotList), 
	!, slot_vals(C,N,Rest,SlotList).
slot_vals(C,N, Req, SlotList) :-
	prep_req(Req,req(C,N,S,F,V)),
	find_slot(req(C,N,S,F,V), SlotList).

find_slot(req(C,N,S,F,V), SlotList) :-
	nonvar(V), !,
	find_slot(req(C,N,S,F,Val), SlotList), !,
	(Val = V; list(Val),is_on(V,Val)).
find_slot(req(C,N,S,F,V), SlotList) :-
	is_on(S-FacetList, SlotList), !,
	facet_val(req(C,N,S,F,V),FacetList).
find_slot(req(C,N,S,F,V), SlotList) :-
	is_on(ako-FacetList, SlotList),
	facet_val(req(C,N,ako,val,Ako),FacetList),
	(is_on(X,Ako); X = Ako),
	frame(X, HigherSlots),
	find_slot(req(C,N,S,F,V), HigherSlots), !.
find_slot(Req,_) :-
	message(112,Req),fail.

facet_val(req(C,N,S,F,V),FacetList) :-
	FV =.. [F,V],
	is_on(FV,FacetList), !.
facet_val(req(C,N,S,val,V),FacetList) :-
	is_on(val ValList,FacetList),
	is_on(V,ValList), !.
facet_val(req(C,N,S,val,V),FacetList) :-
	is_on(calc Pred,FacetList),
	CalcPred =.. [Pred,C,N,S-V],
	call(CalcPred), !.
facet_val(req(C,N,S,val,V),FacetList) :-
	is_on(def V,FacetList), !.

% add a list of slot values

add_frame(Class, UList) :-
	old_slots(Class,SlotList),
	add_slots(Class,_,UList,SlotList,NewList),
	retract(frame(Class,_)),
	asserta(frame(Class,NewList)), !.

addf(Class,Nm,UList) :- addf(Class,Nm,UList,TimeStamp).

addf(Class,Nm,UList,TimeStamp) :-
	(var(Nm),genid(Name);Name=Nm),
	add_slots(Class,Name,[ako-Class|UList],SlotList,NewList),
	getchron(TimeStamp),
	asserta( frinst(Class,Name,NewList,TimeStamp) ),
	!.

uptf(Class,Name,UList) :- uptf(Class,Name,UList,TS).

uptf(Class,Name,UList,TimeStamp) :-
	frinst(Class,Name,SlotList,TS),
	add_slots(Class,Name,UList,SlotList,NewList),
	retract( frinst(Class,Name,_,_) ),
	getchron(TimeStamp),
	asserta( frinst(Class,Name,NewList,TimeStamp) ),
	!.
uptf(Class,Name,UList,TimeStamp) :-
	message(113,[Class,Name,UList]).

uptrf(Class,Name,UList) :- uptf(Class,Name,UList,TS).

uptrf(Class,Name,UList,TimeStamp) :-
	frinst(Class,Name,SlotList,TS),
	add_slots(Class,Name,UList,SlotList,NewList),
	delrete(Class,Name,TS),
	retract( frinst(Class,Name,_,_) ),
	getchron(TimeStamp),
	asserta( frinst(Class,Name,NewList,TimeStamp) ),
	!.
uptrf(Class,Name,UList,TimeStamp) :-
	message(113,[Class,Name,UList]).


genid(G) :-
	retract(gid(N)),
	G is N + 1,
	asserta(gid(G)).

gid(100).
	
old_slots(Class,SlotList) :-
	frame(Class,SlotList), !.
old_slots(Class,[]) :-
	asserta(frame(Class,[])).

old_flots(Class,Name,SlotList) :-
	frinst(Class,Name,SlotList,_).

add_slots(_,_,[],X,X).
add_slots(C,N,[U|Rest],SlotList,NewList) :-
	prep_req(U,req(C,N,S,F,V)),
	add_slot(req(C,N,S,F,V),SlotList,Z),
	!, add_slots(C,N,Rest,Z,NewList).
add_slots(C,N,X,SlotList,NewList) :-
	prep_req(X,req(C,N,S,F,V)),
	add_slot(req(C,N,S,F,V),SlotList,NewList).

add_slot(req(C,N,S,F,V),SlotList,[S-FL2|SL2]) :-
	delete(S-FacetList,SlotList,SL2),
	add_facet(req(C,N,S,F,V),FacetList,FL2).

add_facet(req(C,N,S,F,V),FacetList,[FNew|FL2]) :-
	FX =.. [F,OldVal],
	delete(FX,FacetList,FL2),
	add_newval(OldVal,V,NewVal),
	!, check_add_demons(req(C,N,S,F,V),FacetList),
	FNew =.. [F,NewVal].

add_newval(X,Val,Val) :- var(X), !.
add_newval(OldList,ValList,NewList) :-
	list(OldList),
	list(ValList),
	append(ValList,OldList,NewList), !.
add_newval([H|T],Val,[Val,H|T]).
add_newval(_,Val,Val).

check_add_demons(req(C,N,S,F,V),FacetList) :-
	get_frame(C,S-add(Add)), !,
	AddFunc =.. [Add,C,N,S-V],
	call(AddFunc).
check_add_demons(_,_).


% delete a list of slot values

del_frame(Class) :-
	retract(frame(Class,_)).
del_frame(Class) :-
	message(114,Class).

del_frame(Class, UList) :-
	old_slots(Class,SlotList),
	del_slots(Class,_,UList,SlotList,NewList),
	retract(frame(Class,_)),
	asserta(frame(Class,NewList)).

delf(all) :-
	retract( frinst(_,_,_,_) ),
	fail.
delf(all).

delf(Class,Name) :-
	retract( frinst(Class,Name,_,_) ),
	!.
delf(Class,Name) :-
	message(115,Class-Name).

delf(Class,Name,[]) :- !, delf(Class,Name).
delf(Class,Name,UList) :-
	old_flots(Class,Name,SlotList),
	del_slots(Class,Name,UList,SlotList,NewList),
	retract( frinst(Class,Name,_,_) ),
	getchron(TimeStamp),
	asserta( frinst(Class,Name,NewList,TimeStamp) ).

del_slots(_,_,[],X,X).
del_slots(C,N,[U|Rest],SlotList,NewList) :-
	prep_req(U,req(C,N,S,F,V)),
	del_slot(req(C,N,S,F,V),SlotList,Z),
	del_slots(C,N,Rest,Z,NewList).
del_slots(C,N,X,SlotList,NewList) :-
	prep_req(X,req(C,N,S,F,V)),
	del_slot(req(C,N,S,F,V),SlotList,NewList).

del_slot(req(C,N,S,F,V),SlotList,[S-FL2|SL2]) :-
	remove(S-FacetList,SlotList,SL2),
	del_facet(req(C,N,S,F,V),FacetList,FL2).
del_slot(Req,_,_) :-
	message(116,Req).

del_facet(req(C,N,S,F,V),FacetList,FL) :-
	FV =.. [F,V],
	remove(FV,FacetList,FL),
	!, check_del_demons(req(C,N,S,F,V),FacetList).
del_facet(req(C,N,S,F,V),FacetList,[FNew|FL]) :-
	FX =.. [F,OldVal],
	remove(FX,FacetList,FL),
	remove(V,OldVal,NewValList),
	FNew =.. [F,NewValList],	
	!, check_del_demons(req(C,N,S,F,V),FacetList).
del_facet(Req,_,_) :-
	message(117,Req).

check_del_demons(req(C,N,S,F,V),FacetList) :-
	get_frame(C,S-del(Del)), !,
	DelFunc =.. [Del,C,N,S-V],
	call(DelFunc).
check_del_demons(_,_).

% print a frame

print_frames :-
	frame(Class, SlotList),
	print_frame(Class),
	fail.
print_frames.

print_frame(Class) :-
	frame(Class,SlotList),
	write_line(['Frame:',Class]),
	print_slots(SlotList), nl.

printfs :-
	frame(Class,_),
	printf(Class,_),
	fail.
printfs.

printf(Class,Name) :-
	frinst(Class,Name,SlotList,Time),
	write_line(['Frame:',Class,Name,Time]),
	print_slots(SlotList), nl.

printf(Class) :-
	frinst(Class,Name,SlotList,Time),
	write_line(['Frame:',Class,Name,Time]),
	print_slots(SlotList), nl, fail.
printf(_).

print_slots([]).
print_slots([Slot|Rest]) :-
	write_line(['  Slot:',Slot]),
	print_slots(Rest).

% utilities

delete(X,[],[]).
delete(X,[X|Y],Y) :- !.
delete(X,[Y|Z],[Y|W]) :- delete(X,Z,W).

remove(X,[X|Y],Y) :- !.
remove(X,[Y|Z],[Y|W]) :- remove(X,Z,W).

is_on(X,[X|Y]).
is_on(X,[Y|Z]) :- is_on(X,Z).

write_line([]) :- nl.
write_line([H|T]) :-
	write(H),tab(1),
	write_line(T).
	
time_test :-
	write('TT> '),
	read(X),
	timer(T1),
	X,
	timer(T2),
	nl,nl,
	T is (T2 - T1) / 10,
	write(time-T).

append([H|T], W, [H|Z]) :- append(T, W, Z).
append([], W, W).

member(X, [X|_]).
member(X, [_|T]) :- member(X,T).

reverse(L1,L2) :- revzap(L1,[],L2).
revzap([X|L],L2,L3) :-
	revzap(L,[X|L2],L3).
revzap([],L,L).

% Message handling and messages

message(N) :- message(N,'').

message(N,Args) :-
	mess(N,break,Text),
	write(break),tab(1),write(N),write(': '),write(Text),write(Args),nl.
%	break.
message(N,Args) :-
	mess(N,error,Text),
	write(error),tab(1),write(N),write(': '),write(Text),write(Args),nl,
	!, fail.
message(N,Args) :-
	mess(N,Type,Text),
	mess_types(TT),
	member(Type,TT),
	write(Type),tab(1),write(N),write(': '),write(Text),write(Args),nl,
	!.
message(_,_).

mess_types([info,trace,warning,debug]).

set_messtypes :-
	message(123,[info,warn,trace,error,debug]),
	mess_types(X),
	message(124,X),
	read(MT),
	retract( mess_types(_) ),
	asserta( mess_types(MT) ).

mess(101,info , 'Time for command: ').			% retefoops doit
mess(102,error, 'Invalid Command').			% retefoops do
mess(103,error, 'Initialization Error').		% retefoops initialize
mess(104,trace, 'Rule Firing: ').				% retefoops go
mess(105,trace, 'Conflict Set Delete: ').		% retefoops del_confli...
mess(106,trace, 'Failed to CS Delete: ').		% retefoops del_confli...
mess(107,trace, 'Conflict Set Add: ').			% retefoops add_confli...
mess(108,error, 'Update Fails for: ').			% retefoops update_ws
mess(109,trace, 'Asserting: ').				% retefoops add_ws
mess(110,trace, 'Failing Action Part: ').		% retefoops process
mess(111,error, 'Retract Error, no: ').			% retefoops take
mess(112,debugx, 'Frame error looking for: ').	% retefoops find_slot
mess(113,error, 'Frame instance update error: ').	% retefoops uptf
mess(114,error, 'No frame to delete: ').		% retefoops del_frame
mess(115,error, 'No instance to delete: ').		% retefoops delf
mess(116,error, 'Unable to delete slot: ').		% retefoops del_slot
mess(117,error, 'Unable to delete facet: ').		% retefoops del_facet
mess(118,trace, 'Rule Fired: ').				% retefoops process
mess(119,error, 'Premature end to run: ').		% retefoops go
mess(120,info, 'Initializing').				% retefoops initialize
mess(121,info, 'Initialization Complete').		% retefoops initialize
mess(122,debugx, 'Conflict Set').				% retefoops select_rule
mess(123,info, 'Legal Message Types: ').		% retefoops set_message
mess(124,info, 'Current Message Types: ').		% retefoops set_message

mess(201,info, 'Rule Rete Network Complete').	% retecomp rete_compil
mess(202,info, 'Rule: ').					% retecomp rete_comp
mess(203,error, 'Rule Failed to Compile: ').		% retecomp rete_comp