/******************************************************************/ /* Fisher's incremental concept formation algorithm */ /* Adapted for Zprolog, 2001 Zdravko Markov */ /******************************************************************/ /* Copyright (c) 1989 Joerg-Uwe Kietz This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License Version 1 as published by the Free Software Foundation. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free SoftwareFoundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ /******************************************************************/ /* impl. by : Joerg-Uwe Kietz */ /* F3-XPS */ /* Gesellschaft fuer Mathematik und Datenver- */ /* arbeitung */ /* Schloss Birlinghoven */ /* 5201 St. Augustin 1 */ /* E-Mail: kietz@gmdzi.gmd.de */ /* 1989 */ /* */ /* reference : Gennari, J.H., Langley, P., Fisher, D. */ /* Models of Incremental Concept Formation */ /* Artifical Intelligence, Vol 40, pp. 11-61, */ /* 1989 */ /* */ /* correction : There is a bracket around the subtraction of */ /* the two double sums missing in formula (3) on */ /* p. 35. */ /* In the case of Split-Node is the best, the call */ /* cobweb(N,I) leads to double incorporation of I */ /* into Node N. */ /* */ /* call : lrn */ /* */ /* side effects: assertz and retracts clauses */ /* */ /* restrictions: Prolog-dialect must allow real arithmetic. */ /* */ /******************************************************************/ ?- format(5,3). /******************************************************************/ /* */ /* call : lrn */ /* */ /* side effects: assertz and retracts clauses */ /* */ /* restrictions: Prolog-dialect must allow real arithmetric. */ /* */ /******************************************************************/ /* With the predicate 'learn' the cobweb algorithm is called in */ /* batch mode. In this mode the data have to be present at call- */ /* time in the internal database. They have to follow the format */ /* shown in the example file. Because, cobweb is an incremental */ /* concept formation system it retrieves first a datum from the */ /* database (in Prolog's processing order) and integrates it in a */ /* growing concept tree. Before the learning process starts the */ /* internal concept tree data structure is initialized. The */ /* concept tree is asserted and modified at runtime. At the */ /* moment a tree-pretty-printer is missing. */ /******************************************************************/ lrn :- initialize, get_case(X), cobweb(X), fail. lrn. initialize :- abolish(node,3), abolish(d_sub,2), abolish(root,2), abolish(root,4), abolish(prediction_counter,2), abolish(gensym_counter,2), !. /******************************************************************/ /* */ /* call : learn_more */ /* */ /* side effects: assertz and retracts clauses */ /* */ /******************************************************************/ /* With the predicate 'learn_more' the cobweb algorithm is called */ /* in batch mode. In this mode the data have to be present at */ /* call-time in the internal database. They have to follow the */ /* format shown in the example file. Because, cobweb is an */ /* incremental concept formation system it retrieves first a */ /* datum from the database (in Prolog's processing order) and */ /* integrates it in a growing concept tree. The data structure of */ /* the internal concept tree data structure is not initialized, */ /* thus allowing to process large datasets in smaller parts. The */ /* concept tree is asserted and modified at runtime. The user has */ /* to take care that the dataset is erased after each batch run, */ /* to avoid that data are processed twice. */ /******************************************************************/ learn_more :- get_case(X), cobweb(X), fail. learn_more. nmember(E,[E|L],1). nmember(E,[_|R],P1) :- nmember(E,R,P), P1 is P + 1. nth1(1,[X|_],X). nth1(P1,[_|R],X) :- P1 > 1, P is P1 - 1, nth1(P,R,X). /******************************************************************/ /* */ /* call : get_case(+Case) */ /* */ /* arguments : Case = unique case identificator */ /* */ /******************************************************************/ /* This is a new version of get_case/1 called by COBWEB. This */ /* version is independent from the data set. Using this version */ /* one can change the data-set (i.e consult a different data file)*/ /* without changing the access operations (especially the number */ /* of arguments) */ /******************************************************************/ get_case(CaseID) :- case([CaseID|_]), nl, nl, write(' Processing case '), write(CaseID), write(' ...'). /******************************************************************/ /* */ /* call : get_case_features(+Case,+Type,-AttVall) */ /* */ /* arguments : Case = unique case identificator */ /* Type = type description of value */ /* AttVal = Attribute-Value Pair */ /* */ /******************************************************************/ /* This is a new version of get_case_features/3 called by COBWEB. */ /* This version is independent from the data set. Using this */ /* version one can change the data-set (i.e consult a different */ /* case file) without changing the access operations (especially */ /* the number of arguments) */ /******************************************************************/ get_case_feature(CaseId,Type,[Feature,Val]):- case([CaseId|CaseDescription]), features(FeatureDescription), /* backtrack through all feature description and */ nmember([Type,Feature],FeatureDescription,Pos), /* get corresponding feature value */ nth1(Pos,CaseDescription,Val). /******************************************************************/ /* */ /* call : cobweb(+Case) */ /* */ /* arguments : Case = unique case identificator */ /* */ /* side effects: assertz and retracts clauses */ /* */ /******************************************************************/ /* cobweb processes a case always completely. The case identifi- */ /* cator is used as pointer to the case. Every case must have a */ /* unique case identificator, accessible over the predicate */ /* get_case(Case). The three cases of asserting a case as initial */ /* root node, as new terminal node in the tree, or integrating */ /* the case into a node and processing the subtree's are handled. */ /******************************************************************/ cobweb(Case) :- /* if the tree is empty */ not get_node(_), init_node, /* generate root from Case */ node(Root,root,1,1), new_node_from_case(Case,Root), assert_node(Root), msgs([nl,' Root initialized with case: ',Root]), !. cobweb(Case) :- /* if root is terminal: */ node(OldRoot,root,1,1), remove_node(OldRoot), !, /* first, make a copy of root */ copy_node_to_new_node(OldRoot,New), node(New,_,1,1), assert_node(New), msgs([nl,' Root node: ',OldRoot,' used as new terminal node: ',New]), assert_d_sub(OldRoot,New), /* second, make a node of Case */ new_node_from_case(Case,New2), node(New2,_,1,1), assert_node(New2), msgs([nl,' Case ',Case,' becomes new terminal ',New2]), assert_d_sub(OldRoot,New2), /* third, incorporate Case into root */ incorporate_case_into_node(Case,OldRoot), node(NewRoot,root,2,_), assert_node(NewRoot), msgs([nl,' Root changed to: ',NewRoot]), !. cobweb(Case) :- /* if root is not terminal: */ node_name(OldRoot,root), remove_node(OldRoot), !, /* first, incorporate Case into root */ incorporate_case_into_node(Case,OldRoot), node_objects(OldRoot,Objects), NewObjects is Objects + 1, node(NewRoot,root,NewObjects,_), assert_node(NewRoot), msgs([nl,' Root changed to: ',NewRoot]), /* second, compute new subtree */ cobweb(NewRoot,Case), !. cobweb(none,_). cobweb(Parent,Case) :- best_child(Parent,Case,Best,IBest,Next,DoneRest,RestPred,PartSize, IncPrediction), !, new_child(Parent,Case,Best,Next,RestPred,PartSize,New,NewPrediction), !, merge_child(Parent,Case,Best,Next,RestPred,PartSize,Merge, MergePrediction), !, /* Correction of the reference: In the case of Split-Node is the best, The call cobweb(N,I) leads to double incorporating I into Node N. */ split_child(Parent,Case,Best,IBest,Next,DoneRest,RestPred,PartSize, SplitPrediction), !, max_of([IncPrediction,NewPrediction,MergePrediction,SplitPrediction], BestPrediction), !, ( BestPrediction = IncPrediction, do_incorp(IBest,Best,Merge,New,Case,NewParent); BestPrediction = SplitPrediction, do_split(Best,IBest,New,Merge,Parent,NewParent); BestPrediction = MergePrediction, do_merge(Best,Next,Merge,Parent,IBest,New,NewParent); BestPrediction = NewPrediction, do_new(Parent,New,IBest,Merge,NewParent)), !, cobweb(NewParent,Case). do_incorp(IBest,Best,Merge,New,Case,NewParent):- msgs([nl,' Incorporating case ',Case,' into node: ',IBest]), move_subs(Best,IBest), delete_node(Merge), delete_node(New), if(terminal_node(Best), ( /* if Best is a terminal node we have the case from the paper, where N is terminal before incorporating the new case. first: make Best to an subnode of IBest */ ins_node(IBest,Best,[]), msgs([nl,' Using old node: ',Best,' as terminal node.']), /* second: generate a new terminal node from Case */ new_node_from_case(Case,New2), node(New2,_,1,1), assert_node(New2), msgs([nl,' New terminal node: ',New2]), /* and make it to an subnode of IBest, too */ ins_node(IBest,New2,[]), /* than all is done, because Best and NewNode2 are terminal. */ NewParent = none), (delete_node(Best), NewParent = IBest)). do_split(Best,IBest,New,Merge,Parent,Parent):- msgs([nl,' Case ',Case,' splits node: ',Best]), /* The next call also copies the d_subs from Best to Parent */ delete_node(Best), delete_node(IBest), delete_node(New), delete_node(Merge). do_merge(Best,Next,Merge,Parent,IBest,New,Merge):- msgs([nl,' Case ',New,' merges nodes: ',nl,' ',Best, ' and ',Next,nl,' into ',Merge]), ins_node(Parent,Merge,[Best,Next]), /* Possible optimization: We could remember that Best is the best_child for incorporate and Next is the second best, RestP = 0, ..., i.e. we already know what best_child will produce in the next recursion. */ delete_node(IBest), delete_node(New). do_new(Parent,New,IBest,Merge,none):- /* all is done, because New is terminal. */ ins_node(Parent,New,[]), msgs([nl,' New terminal node: ',New]), delete_node(IBest), delete_node(Merge). best_child(Parent,Case,Best,IBest,Next,DoneRest,RestPred,PartSize, IncPrediction) :- bagof(Child,get_d_sub(Parent,Child),[C1,C2|DoRest]), length([C1,C2|DoRest],PartSize), copy_and_inc(C1,Case,IC1), copy_and_inc(C2,Case,IC2), compare_partitions(C1,IC1,C2,IC2,DoRest,[],Parent, First,IFirst,Second,ISecond,FirstRestP), !, best_childs(Parent,Case,DoRest,[],First,IFirst,Second,ISecond, FirstRestP,Best,IBest,Next,DoneRest,RestPred), sum_score([IBest],[Next],Parent,RestPred,IncScore), node_prediction(Parent,NormPrediction), IncPrediction isr (IncScore - NormPrediction) / PartSize. best_childs(_,_,[],DoneRest,Best,IBest,Next,_INext,RestP,Best,IBest, Next,DoneRest,RestP) :- delete_node(_INext), !. best_childs(Parent,Case,[Try|DoRest],DoneRest,First,IFirst,Second,ISecond, FirstRestP,Best,IBest,Next,NewDoneRest,RestP) :- copy_and_inc(Try,Case,ITry), if(compare_partitions(Second,ISecond,Try,ITry,DoRest,[First|DoneRest], Parent,Second,ISecond,Try,ITry,_), (/* Try is weaker than our Second, Delete ITry from memory put Try to done, use the old Results */ delete_node(ITry), best_childs(Parent,Case,DoRest,[Try|DoneRest], First,IFirst,Second,ISecond,FirstRestP, Best,IBest,Next,NewDoneRest,RestP)), (/* Try is stronger than our Second, Delete ISecond from memory, put Second to done compare Try with First, use the new Results */ delete_node(ISecond), compare_partitions(First,IFirst,Try,ITry, DoRest,[Second|DoneRest],Parent,NFirst, NIFirst,NSecond,NISecond,NFirstRestP), /* !, ??? */ best_childs(Parent,Case,DoRest,[Second|DoneRest],NFirst,NIFirst, NSecond,NISecond,NFirstRestP,Best,IBest,Next, NewDoneRest,RestP))). new_child(Parent,Case,Best,Next,RestPred,PartSize,New,NewPrediction) :- new_node_from_case(Case,New), /* Prediction from New is equal to 1 */ node(New,_,1,1), assert_node(New), sum_score([New],[Best,Next],Parent,RestPred,NewPredictionSum), node_prediction(Parent,NormPrediction), NewPrediction isr (NewPredictionSum - NormPrediction) / (PartSize + 1), !. merge_child(_Parent,_Case,_Best,_Next,_RestPred,2,Merge,~10000) :- new_node(Merge), assert_node(Merge), !. merge_child(Parent,Case,Best,Next,RestPred,PartSize,Merge,MergePrediction) :- /* first, copy BestNode Attributes to MergeNode */ copy_node_to_new_node(Best,Merge), /* second, merge NextNode Attributes into MergeNode */ merge_node_into_node(Next,Merge), /* third, incorporate Case into MergeNode */ incorporate_case_into_node(Case,Merge), /* compute the rest of MergeNode */ node_objects(Best,BestO), node_objects(Next,NextO), MergeObjects is BestO + NextO + 1, node_objects(Merge,MergeObjects), compute_prediction(Merge), assert_node(Merge), sum_score([Merge],[],Parent,RestPred,MergePredictionSum), node_prediction(Parent,NormPrediction), MergePrediction isr (MergePredictionSum - NormPrediction) / (PartSize - 1), /* completed W.E. */ !. split_child(_Parent,_Case,Best,_IBest,_Next,_DoneRest,_RestPred,_PartSize, ~10000) :- terminal_node(Best), /* we cannot split Best if it is terminal */ !. split_child(Parent,Case,Best,_IBest,Next,DoneRest,_RestPred,PartSize, SplitPrediction) :- /* best_child of the partition resulting from split */ /* (i.e. best of: Parent-Childs union Best-Childs without Best) */ bagof(Child,get_d_sub(Best,Child),[C1|DoRest]), length([C1|DoRest],CPartSize), copy_and_inc(C1,Case,IC1), copy_and_inc(Next,Case,INext), compare_partitions(C1,IC1,Next,INext,DoRest,DoneRest,Parent, First,IFirst,Second,ISecond,FirstRestP), !, best_childs(Parent,Case,DoRest,DoneRest,First,IFirst,Second,ISecond, FirstRestP,_CBest,CIBest,CNext,_,RPred), sum_score([CIBest],[CNext],Parent,RPred,SplitPredictionSum), node_prediction(Parent,NormPrediction), SplitPrediction isr (SplitPredictionSum - NormPrediction) / (PartSize + CPartSize -1 ), delete_node(CIBest), !. /******************************************************************/ /* compare_partitions */ /******************************************************************/ compare_partitions(C1,IC1,C2,IC2,DoRest,DoneRest,Parent,First,IFirst, Second,ISecond,RestP) :- sum_score(DoRest,DoneRest,Parent,0,RestP), sum_score([C1],[IC2],Parent,RestP,IC2_Score), sum_score([IC1],[C2],Parent,RestP,IC1_Score), (IC2_Score > IC1_Score -> ( First = C2, IFirst = IC2, Second = C1, ISecond = IC1) ; ( First = C1, IFirst = IC1, Second = C2, ISecond = IC2)), !. /******************************************************************/ /* basic node operations */ /******************************************************************/ copy_and_inc(Node,Case,INode) :- new_node(INode), !, /* first, copy all Node Attributes to INode */ copy_node_to_new_node(Node,INode), /* second, incorporate Case into INode */ incorporate_case_into_node(Case,INode), node_objects(Node,Objects), IObjects is Objects + 1, node_objects(INode,IObjects), compute_prediction(INode), assert_node(INode), !. /******************************************************************/ /* basic node attribute operations */ /******************************************************************/ merge_node_into_node(Node,MergeNode) :- (get_node_nominal_attr(Node,Attr,ValuesCounter), if((remove_node_nominal_attr(MergeNode,Attr,MergeValuesCounter), sum_value_counter(ValuesCounter,MergeValuesCounter, NewValuesCounter), assert_node_nominal_attr(MergeNode,Attr,NewValuesCounter)), fail); true), (get_node_numeric_attr(Node,Attr,N,SumXiPow2,SumXi), if((remove_node_numeric_attr(MergeNode,Attr,MergeN, MergeSumXiPow2,MergeSumXi), NewN isr N + MergeN, NewSumXiPow2 isr SumXiPow2 + MergeSumXiPow2, NewSumXi isr SumXi + MergeSumXi, assert_node_numeric_attr(MergeNode,Attr,NewN,NewSumXiPow2, NewSumXi)), fail); true), !. new_node_from_case(Case,Node) :- new_node(Node), (get_case_feature(Case,nominal,[Attr,Val]), if(assert_node_nominal_attr(Node,Attr,[Val-1]), fail); true), (get_case_feature(Case,numeric,[Attr,Val]), if((SumXiPow2 isr Val * Val, assert_node_numeric_attr(Node,Attr,1,SumXiPow2,Val)), fail); true), !. copy_node_to_new_node(Node,NewNode) :- new_node(NewNode), (get_node_nominal_attr(Node,Attr,ValuesCounter), if(assert_node_nominal_attr(NewNode,Attr,ValuesCounter), fail); true), (get_node_numeric_attr(Node,Attr,N,SumXiPow2,SumXi), if(assert_node_numeric_attr(NewNode,Attr,N,SumXiPow2,SumXi), fail); true), !. incorporate_case_into_node(Case,Node) :- (get_case_feature(Case,nominal,[Attr,Val]), if((remove_node_nominal_attr(Node,Attr,ValuesCounter), sum_value_counter(ValuesCounter,[Val-1],NewValuesCounter), assert_node_nominal_attr(Node,Attr,NewValuesCounter)), fail); true), (get_case_feature(Case,numeric,[Attr,Val]), if((remove_node_numeric_attr(Node,Attr,N,SumXiPow2,SumXi), NewN is N + 1, NewSumXiPow2 isr SumXiPow2 + (Val * Val), NewSumXi isr SumXi + Val, assert_node_numeric_attr(Node,Attr,NewN,NewSumXiPow2,NewSumXi)), fail); true), !. /******************************************************************/ /* sum_value_counter(+ValuesCounter,+ValuesCounter,-ValuesCounter)*/ /******************************************************************/ sum_value_counter(ValuesCounter,[],ValuesCounter) :- !. sum_value_counter([],ValuesCounter,ValuesCounter). sum_value_counter([Val-C1|R1],[Val-C2|R2],[Val-SumC|Rest]) :- SumC is C1 + C2, !, sum_value_counter(R1,R2,Rest). sum_value_counter([Val1-C1|R1],[Val2-C2|R2],[Val1-C1|Rest]) :- lt(Val1,Val2), !, sum_value_counter(R1,[Val2-C2|R2],Rest). sum_value_counter([Val1-C1|R1],[Val2-C2|R2],[Val2-C2|Rest]) :- lt(Val2,Val1), !, sum_value_counter([Val1-C1|R1],R2,Rest). /******************************************************************/ /* sum_score(+NodeList,+NodeList,+NormNode,+BaseScore,-FinalScore)*/ /******************************************************************/ /* This is following Gennari, et. al. 1989 and the COBWEB/3 implementation */ sum_score([],[],_,Score,Score). sum_score([],[Node|Rest],NormNode,Score,Sum_Score) :- node(Node,_,Objects,Prediction), node_objects(NormNode,NormObjects), ZScore isr ((Objects / NormObjects) * Prediction) + Score, !, sum_score([],Rest,NormNode,ZScore,Sum_Score). sum_score([Node|Rest],ToDo,NormNode,Score,Sum_Score) :- node(Node,_,Objects,Prediction), node_objects(NormNode,NormObjects), ZScore isr ((Objects / NormObjects) * Prediction) + Score, !, sum_score(Rest,ToDo,NormNode,ZScore,Sum_Score). /* This is following Fisher 1987 in the ML Journal but this seems to be wrong sum_score([],[],_,Score,Score). sum_score([],[Node|Rest],NormNode,Score,Sum_Score):- node(Node,_,Objects,Prediction), node(NormNode,_,NormObjects,NormPrediction), ZScore isr ((Objects / NormObjects) * (Prediction - NormPrediction)) + Score, !, sum_score([],Rest,NormNode,ZScore,Sum_Score). sum_score([Node|Rest],ToDo,NormNode,Score,Sum_Score):- node(Node,_,Objects,Prediction), node(NormNode,_,NormObjects,NormPrediction), ZScore isr ((Objects / NormObjects) * (Prediction - NormPrediction)) + Score, !, sum_score(Rest,ToDo,NormNode,ZScore,Sum_Score). */ /******************************************************************/ /* compute the prediction of Node */ /******************************************************************/ compute_prediction(Node) :- node_objects(Node,Objects), asserta(prediction_counter(0,0)), get_node_nominal_attr(Node,_,ValuesCounter), if(retract(prediction_counter(Sum,Count)),true), NCount is Count + 1, asserta(prediction_counter(Sum,NCount)), member(_-C,ValuesCounter), if(retract(prediction_counter(NNSum,NCount)),true), NSum isr NNSum + ((C / Objects) * (C / Objects)), asserta(prediction_counter(NSum,NCount)), fail. compute_prediction(Node) :- get_node_numeric_attr(Node,_,N,SumXiPow2,SumXi), if(retract(prediction_counter(Sum,Count)),true), NCount is Count + 1, DeviationPow2 isr (SumXiPow2/N) - ((SumXi*SumXi)/(N*N)), abs(DeviationPow2,PosDeviationPow2), Deviation isr sqrt(PosDeviationPow2), /* Deviation of one Instance is 0, so we use a minimum deviation of 1 */ /* Here 'acuity' is hardcoded ! */ max_of([Deviation,1],ScoreDeviation), NSum isr Sum + 1/ScoreDeviation, asserta(prediction_counter(NSum,NCount)), fail. compute_prediction(Node) :- /* Normalize the Prediction against the Number of Attributes */ retract(prediction_counter(Prediction,Count)), NormPrediction isr Prediction / Count, node_prediction(Node,NormPrediction), !. /******************************************************************/ /* Internal Data Structures are: */ /* */ /* node(Node,Objects) with */ /* Node = Atom and Objects = Integer */ /* node(Attribute,[Val-Count|...]) with */ /* Attribute = Atom, Val = Atom and Count = Integer */ /* d_sub(Parent,Child) with */ /* Parent = Atom and Child = Atom */ /******************************************************************/ init_node:- abolish(root,2), abolish(root,4), retractall(gensym_counter(node_,_)), retractall(node(root,_,_)), retractall(d_sub(root,_)), retractall(d_sub(_,root)), !. new_node(node(Node,_,_)) :- nonvar(Node). new_node(node(Node,_,_)):- var(Node), gensym(node_,Node), abolish(Node,2), abolish(Node,4), retractall(node(Node,_,_)), retractall(d_sub(Node,_)), retractall(d_sub(_,Node)), !. delete_node(Node) :- remove_node(Node), node_name(Node,NodeName), abolish(NodeName,2), abolish(NodeName,4), /* This asumes that there is mostly one ParentNode */ (remove_d_sub(Parent,Node), remove_d_sub(Node,Child), assert_d_sub(Parent,Child), fail; true), !. terminal_node(Node) :- node_objects(Node,1). move_subs(Source,Dest) :- remove_d_sub(Source,Child), assert_d_sub(Dest,Child), fail. move_subs(Source,Dest) :- remove_d_sub(Parent,Source), assert_d_sub(Parent,Dest), !. ins_node(Parent,New,[]) :- assert_d_sub(Parent,New), !. ins_node(Parent,New,[Child|Rest]) :- (remove_d_sub(Parent,Child);true), assert_d_sub(New,Child), !, ins_node(Parent,New,Rest). /******************************************************************/ /* node(Node:Atom,Objects:Integer,Prediction:Real) */ /******************************************************************/ node_name(node(Name,_,_),Name) :- nonvar(Name),!. node_objects(node(Name,Objects,_),Objects) :- nonvar(Name), if(var(Objects),get_node(node(Name,Objects,_)),true), !. node_prediction(node(Name,Objects,Pred),Pred) :- nonvar(Name), (var(Pred), get_node(node(Name,Objects,Pred)); true), if(var(Pred),compute_prediction(node(Name,Objects,Pred)),true), !. node(node(Name,Objects,Pred),Name,Objects,Pred) :- nonvar(Name), if(var(Objects),get_node(node(Name,Objects,_)),true), (var(Pred), get_node(node(Name,Objects,Pred)); true), if(var(Pred),compute_prediction(node(Name,Objects,Pred)),true), !. get_node(node(Node,Objects,Pred)) :- clause(node(Node,Objects,Pred),true). assert_node(node(Node,Objects,Pred)) :- nonvar(Node), asserta(node(Node,Objects,Pred)). remove_node(node(Node,Objects,Pred)) :- retract(node(Node,Objects,Pred)). /******************************************************************/ /* node(Attr:Atom,[Val:Atom-Count:Integer|...]) */ /******************************************************************/ get_node_nominal_attr(node(Node,_,_),Attr,ValuesCounter) :- nonvar(Node), nonvar(Attr), Call =.. [Node,Attr,ValuesCounter], (clause(Call,true); if(var(ValuesCounter),ValuesCounter = [])), !. get_node_nominal_attr(node(Node,_,_),Attr,ValuesCounter) :- nonvar(Node), var(Attr), Call =.. [Node,Attr,ValuesCounter], clause(Call,true). assert_node_nominal_attr(_,_,[]). assert_node_nominal_attr(node(Node,_,_),Attr,ValuesCounter) :- nonvar(Node), nonvar(Attr), nonvar(ValuesCounter), Call =.. [Node,Attr,ValuesCounter], asserta(Call). remove_node_nominal_attr(node(Node,_,_),Attr,ValuesCounter) :- nonvar(Node), nonvar(Attr), Call =.. [Node,Attr,ValuesCounter], (retract(Call); if(var(ValuesCounter),ValuesCounter = [])), !. remove_node_nominal_attr(node(Node,_,_),Attr,ValuesCounter) :- nonvar(Node), Call =.. [Node,Attr,ValuesCounter], retract(Call). /******************************************************************/ /* node(Attr:Atom,N:Integer,SumXiPow2:Integer,SumXi:Integer) */ /******************************************************************/ get_node_numeric_attr(node(Node,_,_),Attr,N,SumXiPow2,SumXi) :- nonvar(Node), nonvar(Attr), Call =.. [Node,Attr,N,SumXiPow2,SumXi], (clause(Call,true); if(var(N),(N = 0, SumXiPow2=0, SumXi=0))), !. get_node_numeric_attr(node(Node,_,_),Attr,N,SumXiPow2,SumXi) :- nonvar(Node), var(Attr), Call =.. [Node,Attr,N,SumXiPow2,SumXi], clause(Call,true). assert_node_numeric_attr(_,_,0,_,_). assert_node_numeric_attr(node(Node,_,_),Attr,N,SumXiPow2,SumXi) :- nonvar(Node), nonvar(Attr), nonvar(N), nonvar(SumXiPow2), nonvar(SumXi), Call =.. [Node,Attr,N,SumXiPow2,SumXi], asserta(Call). remove_node_numeric_attr(node(Node,_,_),Attr,N,SumXiPow2,SumXi) :- nonvar(Node), nonvar(Attr), Call =.. [Node,Attr,N,SumXiPow2,SumXi], (retract(Call); if(var(N),(N = 0,SumXiPow2=0,SumXi=0))), !. remove_node_numeric_attr(node(Node,_,_),Attr,N,SumXiPow2,SumXi) :- nonvar(Node), Call =.. [Node,Attr,N,SumXiPow2,SumXi], retract(Call). /******************************************************************/ /* d_sub(SuperNode:Atom,SubNode:Atom) */ /******************************************************************/ get_d_sub(node(SuperNode,_,_),node(SubNode,_,_)) :- clause(d_sub(SuperNode,SubNode),true). assert_d_sub(node(SuperNode,_,_),node(SubNode,_,_)) :- asserta(d_sub(SuperNode,SubNode)). remove_d_sub(node(SuperNode,_,_),node(SubNode,_,_)) :- retract(d_sub(SuperNode,SubNode)). /******************************************************************/ /* Miscealenous definitions */ /******************************************************************/ max_of([F|R],Max) :- max_of(R,F,Max),!. max_of([],Max,Max). max_of([F|R],Best,Max) :- not F>Best, !, max_of(R,Best,Max). max_of([F|R],_,Max) :- max_of(R,F,Max). msgs([]) :- !. msgs([First|Rest]) :- msg(First),msgs(Rest). /* msg(node(ID,Obj,Pred)) :- !, write(ID), write('(obj='), write(Obj), write(',pred='), write(Pred), write(')'). */ msg(Var) :- var(Var),!,write(Var). msg(nl) :- !, nl. msg(nl(N)) :- !, msg_repeat(N,nl). msg(sp) :- !, write(' '). msg(sp(N)) :- !, msg_repeat(N,outterm(' ')). msg(q_(O)) :- !, write(O). msg(X) :- !, write(X). /* msg_repeat Call N times. */ msg_repeat(N,_) :- N < 1, !. msg_repeat(N,Call) :- Call, N1 is N - 1, msg_repeat(N1,Call). /******************************************************************/ /* utility predicates */ /******************************************************************/ if(Cond,Then) :- Cond, !, Then. if(_,_). if(Cond,Then,_) :- Cond, !, calltrue(Then). if(_,_,Else) :- calltrue(Else). calltrue(Call) :- Call, !. calltrue(_). count(VAR,X) :- retract(gensym_counter(VAR,N)), X is N+1, assert(gensym_counter(VAR,X)), ! . count(VAR,1) :- assert(gensym_counter(VAR,1)) . gensym(SYM) :- gensym(g,SYM). gensym(N,Sym) :- count(N,X), name(N,S1), num2ascii(X,S2), append(S1,S2,S3), name(Sym,S3). num2ascii(N,[A]) :- N<10, A is N+48, !. num2ascii(N,R) :- M is N / 10, num2ascii(M,T), A is (N mod 10) + 48, append(T,[A],R),!. /* Accessing examples in standard form */ case([Id|Values]) :- example(Id,_,Avs), get_values(Avs,Values). get_values([],[]) :- !. get_values([_=V|T],[V|R]) :- get_values(T,R). features(Features) :- example(_,_,AV), !, build_features(AV,Features). build_features([],[]) :- !. build_features([A=V|T],[[numeric,A]|R]) :- number(V), !, build_features(T,R). build_features([A=_|T],[[nominal,A]|R]) :- build_features(T,R). /*------------ Zprolog adjustments -----------------*/ lt(X,Y) :- atom(X), atom(Y), !, name(X,[A|_]), name(Y,[B|_]), A1,write(+),write(N-PU); N=1,attr_vals(AVs,E),wr_example(E); N=1,case_attr(AVs,E),wr_case(E) ), nl, !. wr_example(E) :- example(N,C,X), subset(E,X), !, write(N-C). wr_case(E) :- case([Id|Case]), subset(E,Case), !, write(Id). /*-- show(max) ---------------------------------*/ write_node_info(F) :- functor(Nom,F,2), functor(Num,F,4), node(F,N,PU), findall(A/V,(Nom,arg(1,Nom,A),arg(2,Nom,V); Num,arg(1,Num,A),arg(2,Num,C), arg(4,Num,S),V isr S/C),AVs), (N>1,write(+),write(AVs); N=1,attr_vals(AVs,E),wr_example_info(E); N=1,case_attr(AVs,E),wr_case_info(E) ), nl, !. wr_example_info(E) :- example(N,C,X), subset(E,X), !, write(N-X-C). wr_case_info(E) :- case([Id|Case]), subset(E,Case), write([Id|Case]). case_attr([],[]) :- !. case_attr([_/[V-1]|T],[V|L]) :- !, case_attr(T,L). case_attr([_/V|T],[V|L]) :- case_attr(T,L). attr_vals([],[]) :- !. attr_vals([A/[V-1]|T],[A=V|L]) :- !, attr_vals(T,L). attr_vals([A/V|T],[A=V|L]) :- attr_vals(T,L). subset([],_) :- !. subset([X|T],L) :- member(X,L), !, subset(T,L). tab(0) :- !. tab(N) :- put(32), N1 is N-1, tab(N1).