-
Notifications
You must be signed in to change notification settings - Fork 1
/
arch2.pl
executable file
·273 lines (254 loc) · 14.6 KB
/
arch2.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
/******************************************************************/
/* ARCH2.PRO Last Modification: Fri Jan 14 19:21:09 1994 */
/* Winston's incremental learning procedure. */
/******************************************************************/
%
% Copyright (c) 1990 Ivan Bratko
%
/******************************************************************/
/* reimpl. by : Thomas Hoppe */
/* Mommsenstr. 50 */
/* D-10629 Berlin */
/* F.R.G. */
/* E-Mail: [email protected] */
/* 1990 */
/* */
/* reference : Chapter 18, */
/* Ivan Bratko */
/* Prolog */
/* 2nd extend edition */
/* Addison-Wesley, 1990 */
/* */
/* call : learn(-Concept) */
/* */
/* argument : Concept = learned concept description */
/* */
/******************************************************************/
/* This is a strong restricted version of Winston's incremental */
/* learning procedure for structural descriptions. */
/* The following restrictions are known: */
/* - The first example must be positive. */
/* - The implementation can handle only up to six objects. */
/* - The list containing missing or extra descriptors of a concept*/
/* can contain only 3 descriptors. */
/* */
/* The representation used: */
/* Object = object(ListOfParts,ListOfRelations) */
/* Concept = concept(ListOfParts,MustRels,Rels,MustNotRels) */
/* Positive example = + Object */
/* Negative example = - Object */
/* */
/* Parts in an objects are denoted by Prolog variables, in a */
/* description they are denoted by constants (i.e. part1, ...) */
/* */
/* learn induces a structural concept description from a list of */
/* examples. */
/******************************************************************/
% TH Sat May 29 23:41:21 1993 - made some minor modifications
learn(Concept) :-
findbag(X,example(X),L),
learn(L,Concept).
learn([FirstExample|Examples],ConceptDesc) :-
initialize(FirstExample,InitialHypothesis),
process_examples(InitialHypothesis,Examples,ConceptDesc).
initialize(+ object(Parts,Rels), concept(Parts,[],Rels,[])) :-
% Turn variables in a description into constants. Atmost the concept
% can contain 6 objects.
namevars(Parts,[part1,part2,part3,part4,part5,part6]).
/******************************************************************/
/* */
/* call : namevars(+VarList,+NameList) */
/* */
/* argument : VarList = list of variables */
/* NameList = list of constants */
/* */
/******************************************************************/
/* namevars instantiates the variables in VarList with the */
/* constants in NameList. */
/******************************************************************/
namevars(List,NameList) :-
append(List,_,NameList).
process_examples(ConceptDesc,[],ConceptDesc).
process_examples(CurDesc,[Example|Examples],FinDesc) :-
object_type(Example,Object,Type),
match(Object,CurDesc,Difference),
update(Type,Difference,CurDesc,NewDesc),
process_examples(NewDesc,Examples,FinDesc).
object_type(+ Object,Object,positive).
object_type(- Object,Object,negative).
/******************************************************************/
/* */
/* call : match(+ObjectDesc,+ConceptDesc,-Difference) */
/* */
/* argument : ObjectDesc = description of an example */
/* ConceptDesc = current concept description */
/* Difference = term of the form: Missing + Extra */
/* */
/******************************************************************/
/* match matches the description of an example against the current*/
/* concept description and determines two lists of Missing and */
/* Extra descriptors. These are returned and form the basis for */
/* updates of the current concept description. */
/* Matching proceeds in the following order, first all: */
/* - must matches are performed, then */
/* - a difference template is generated */
/* - parts of the object and concept descriptions are matched */
/* - other relations are matched and */
/* - it is checked whether all MustNots are missing. */
/* On backtracking a different template is tried. */
/******************************************************************/
match(object(OParts,ORels),concept(CParts,Musts,Rels,MustNots),
Missing + Extras) :-
list_diff(ORels,Musts,[] + RestRels),
short_lists(Missing + Extras),
list_diff(OParts,CParts,[] + []),
list_diff(RestRels,Rels,Missing + Extras),
list_diff(Extras,MustNots,MustNots + _).
/******************************************************************/
/* */
/* call : list_diff(+List1,+List2,-ListDiffs) */
/* */
/* argument : List1 = list of descriptors */
/* List2 = list of descriptors */
/* ListDiffs = List2\List1 + List1\List2 */
/* */
/******************************************************************/
list_diff(List,[],[] + List).
list_diff(List1,[X|List2],Miss + Extras) :-
delete(List1,List11,X,Miss11,Miss),
list_diff(List11,List2,Miss11 + Extras).
/******************************************************************/
/* */
/* call : delete(+List1,+List2,+Descriptor,-List3,-List4) */
/* */
/* argument : List1 = list of descriptors */
/* List2 = list of descriptors possibly without */
/* Descriptor */
/* Descriptor= Descriptor which should be deleted */
/* List3 = list of descriptors with Descriptor */
/* deleted */
/* List4 = list of descriptors possibly with */
/* Descriptor */
/* */
/******************************************************************/
/* If Descriptor is deleted from List1 then List4 = List1, */
/* if not the List2 = List1 and List4 = [Descriptor|List3]. */
/* (If Descriptor is not deleted then it is missing in List.) */
/******************************************************************/
delete([],[],X,Dels,[X|Dels]).
delete([Y|L],L,X,Dels,Dels) :-
X == Y, !.
delete([Y|L],L,X,Dels,Dels) :-
X = Y.
delete([Y|L],[Y|L1],X,Dels,Dels1) :-
delete(L,L1,X,Dels,Dels1).
/******************************************************************/
/* */
/* call : short_lists(List1 + List2) */
/* */
/* argument : List1 = list of descriptors */
/* List2 = list of descriptors */
/* */
/******************************************************************/
/* short_lists generates difference templates of the form: */
/* List1 + List2; short lists are generated first to force finding*/
/* good (in the sense of short) matches, before more complex */
/* are tried. Templates are generated in the order: */
/* [] + [], [] + [_], [_] + [], [] + [_,_], [_] + [_] .... */
/* Each list can contain atmost 3 elements. */
/******************************************************************/
short_lists(L1 + L2) :-
append(L,_,[_,_,_]),
append(L1,L2,L).
/******************************************************************/
/* */
/* call : update(+TypeOfExample,+Difference,+CurrentDesc, */
/* -NewDesc) */
/* */
/* argument : TypeOfExample = classification of the example */
/* Difference = determined difference */
/* CurrentDesc = current concept description */
/* NewDesc = modified concept description */
/* */
/******************************************************************/
/* updates modifies the current concept description in */
/* correspondance to the determined difference. */
/* The clauses make the following: */
/* Clause 1: Forbid-relation rule: an extra relation in a negative*/
/* example must be forbidden in */
/* the concept description. */
/* Clause 2: Require-relation rule: missing relations in a */
/* negative example must be */
/* required in the concept */
/* description. */
/* Clause 3: One missing and one extra relation in a negative */
/* Can be handled separatly. */
/* Clause 4: Climb-taxonomy rule: generalize an isa-relation by */
/* climbing a-kind-of taxonomy. */
/* The ako-taxonomy represents the */
/* background knowledge of the */
/* system. */
/******************************************************************/
update(negative,_ + [ExtraRelation],
concept(Parts,Musts,Rels,MustNots),
concept(Parts,Musts,Rels,[ExtraRelation|MustNots])).
update(negative,Missing + _,
concept(Parts,Musts,Rels,MustNots),
concept(Parts,NewMusts,NewRels,MustNots)) :-
Missing = [_|_],
append(Missing,Musts,NewMusts),
list_diff(Rels,Missing,_ + NewRels).
update(negative,[MissR] + [ExtraR],CurDesc,NewDesc) :-
update(negative,[] + [ExtraR],CurDesc,InterDesc),
update(negative,[MissR] + [],InterDesc,FinDesc).
update(positive,[isa(Object,Class1)] + [isa(Object,Class2)],
concept(Parts,Musts,Rels,MustNots),
concept(Parts,Musts,NewRels,MustNots)) :-
climb(Class1,Class),
climb(Class2,Class),
!,
replace(isa(Object,Class1),Rels,isa(Object,Class),NewRels).
/******************************************************************/
/* */
/* call : replace(+Item,+List,+NewItem,-NewList) */
/* */
/* argument : Item = descriptor */
/* List = list of descriptors */
/* NewItem = replacement descriptor */
/* NewList = replaced list of descriptors */
/* */
/******************************************************************/
/* replace removes Item from List and adds Newitem producing */
/* NewList. */
/******************************************************************/
replace(Item,List,NewItem,[NewItem|List1]) :-
delete(List,List1,Item,_,_).
/******************************************************************/
/* */
/* call : climb(+Class1,-Class2) */
/* */
/* argument : Class1 = Subclass */
/* Class2 = Superclass */
/* */
/******************************************************************/
/* climb climbs in a-kind-of taxonomy from Class1 to superclass */
/* Class2. */
/******************************************************************/
climb(Class,Class).
climb(Class,SuperClass) :-
clause(ako(Class1,Class),true),
climb(Class1,SuperClass).
:- dynamic found/1.
findbag(X,G,_) :-
asserta(found(mark)), call(G),
asserta(found(X)), fail .
findbag(_,_,L) :-
collect_found([],L) .
collect_found(L,L1) :-
getnext(X), collect_found([X|L],L1) .
collect_found(L,L) .
getnext(X) :-
retract(found(X)), !, not (X == mark) .
help :- write('Load data set with command: [Filename].'), nl,
write('Start arch2 with command: learn(X).'), nl.
:- help.