1 | ;;+----------------------------------------------------------------------------- |
---|
2 | ;;+ Isidorus |
---|
3 | ;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann |
---|
4 | ;;+ |
---|
5 | ;;+ Isidorus is freely distributable under the LGPL license. |
---|
6 | ;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. |
---|
7 | ;;+----------------------------------------------------------------------------- |
---|
8 | |
---|
9 | |
---|
10 | (in-package :datamodel) |
---|
11 | |
---|
12 | (defun get-all-revisions () |
---|
13 | "Returns an ordered set of the start dates of all revisions in the engine" |
---|
14 | ;TODO: this is a very inefficient implementation... it would equally |
---|
15 | ;be possible to have a separate object that stored all such |
---|
16 | ;revisions and only make the search from the latest version that's |
---|
17 | ;stored their |
---|
18 | (let ((revision-set)) |
---|
19 | (dolist (vi (elephant:get-instances-by-class 'VersionInfoC)) |
---|
20 | (pushnew (start-revision vi) revision-set)) |
---|
21 | (sort revision-set #'<))) |
---|
22 | |
---|
23 | |
---|
24 | (defun get-all-revisions-for-tm (tm-id) |
---|
25 | "Returns an ordered set of the start dates of all revisions in the |
---|
26 | engine for this Topic Map" |
---|
27 | (let* |
---|
28 | ((tm (get-item-by-item-identifier tm-id :revision 0)) |
---|
29 | (tops-and-assocs (when tm (union (topics tm) (associations tm)))) |
---|
30 | (revision-set nil)) |
---|
31 | (dolist (vi (mapcan #'versions tops-and-assocs)) |
---|
32 | (pushnew (start-revision vi) revision-set)) |
---|
33 | (sort revision-set #'<))) |
---|
34 | |
---|
35 | |
---|
36 | (defgeneric find-all-associations (instance &key revision) |
---|
37 | (:documentation "Finds all associations for a topic.") |
---|
38 | (:method ((instance TopicC) &key (revision *TM-REVISION*)) |
---|
39 | (declare (type (or integer null) revision)) |
---|
40 | (remove-duplicates |
---|
41 | (map 'list #'(lambda(role) |
---|
42 | (parent role :revision revision)) |
---|
43 | (player-in-roles instance :revision revision))))) |
---|
44 | |
---|
45 | |
---|
46 | (defgeneric find-associations (instance &key revision) |
---|
47 | (:documentation "Finds all associations of this topic except |
---|
48 | type-instance-associations.") |
---|
49 | (:method ((instance TopicC) &key (revision *TM-REVISION*)) |
---|
50 | (declare (type (or integer null) revision)) |
---|
51 | (let ((type-instance-topic |
---|
52 | (d:identified-construct |
---|
53 | (elephant:get-instance-by-value |
---|
54 | 'PersistentIdC 'uri *type-instance-psi*)))) |
---|
55 | (remove-if |
---|
56 | #'(lambda(assoc) |
---|
57 | (eql (instance-of assoc :revision revision) |
---|
58 | type-instance-topic)) |
---|
59 | (find-all-associations instance :revision revision))))) |
---|
60 | |
---|
61 | |
---|
62 | (defgeneric find-referenced-topics (construct &key revision) |
---|
63 | (:documentation "find all the topics that are references from this construct as type, scope or player, as the case may be")) |
---|
64 | |
---|
65 | |
---|
66 | (defmethod find-referenced-topics ((characteristic CharacteristicC) |
---|
67 | &key (revision *TM-REVISION*)) |
---|
68 | "characteristics are scopable + typable + reifiable" |
---|
69 | (append |
---|
70 | (when (reifier characteristic :revision revision) |
---|
71 | (list (reifier characteristic :revision revision))) |
---|
72 | (themes characteristic :revision revision) |
---|
73 | (when (instance-of characteristic :revision revision) |
---|
74 | (list (instance-of characteristic :revision revision))) |
---|
75 | (when (and (typep characteristic 'NameC) |
---|
76 | (variants characteristic :revision revision)) |
---|
77 | (remove-if #'null |
---|
78 | (loop for var in (variants characteristic :revision revision) |
---|
79 | append (find-referenced-topics var :revision revision)))) |
---|
80 | (when (and (typep characteristic 'OccurrenceC) |
---|
81 | (> (length (charvalue characteristic)) 0) |
---|
82 | (eq #\# (elt (charvalue characteristic) 0))) |
---|
83 | (list (get-item-by-id (subseq (charvalue characteristic) 1) |
---|
84 | :revision revision))))) |
---|
85 | |
---|
86 | |
---|
87 | (defmethod find-referenced-topics ((role RoleC) |
---|
88 | &key (revision *TM-REVISION*)) |
---|
89 | (append |
---|
90 | (when (reifier role :revision revision) |
---|
91 | (list (reifier role :revision revision))) |
---|
92 | (list (instance-of role :revision revision)) |
---|
93 | (list (player role :revision revision)))) |
---|
94 | |
---|
95 | |
---|
96 | (defmethod find-referenced-topics ((association AssociationC) |
---|
97 | &key (revision *TM-REVISION*)) |
---|
98 | "associations are scopable + typable" |
---|
99 | (append |
---|
100 | (when (reifier association :revision revision) |
---|
101 | (list (reifier association :revision revision))) |
---|
102 | (list (instance-of association :revision revision)) |
---|
103 | (themes association :revision revision) |
---|
104 | (mapcan #'(lambda(role) |
---|
105 | (find-referenced-topics role :revision revision)) |
---|
106 | (roles association :revision revision)))) |
---|
107 | |
---|
108 | |
---|
109 | (defmethod find-referenced-topics ((top TopicC) |
---|
110 | &key (revision *TM-REVISION*)) |
---|
111 | "Part 1b of the eGov-Share spec states: |
---|
112 | # for each topicname in T export a topic stub for each scope topic |
---|
113 | # for each occurrence in T export a topic stub for the occurrence type (if it exists) |
---|
114 | # for each occurrence in T export a topic stub for each scope topic |
---|
115 | # for each association A in which T plays a role export the association |
---|
116 | # for each association A export a topic stub for the association type |
---|
117 | # for each association A export a topic stub for each topic scope topic |
---|
118 | # for each role R in A export a topic stub for the role type and one for the role player UNLESS the role player is T" |
---|
119 | (remove-duplicates |
---|
120 | (remove |
---|
121 | top |
---|
122 | (append |
---|
123 | (list-instanceOf top :revision revision) |
---|
124 | (mapcan #'(lambda(name) |
---|
125 | (find-referenced-topics name :revision revision)) |
---|
126 | (names top :revision revision)) |
---|
127 | (mapcan #'(lambda(variant) |
---|
128 | (find-referenced-topics variant :revision revision)) |
---|
129 | (mapcan #'variants (names top :revision revision))) |
---|
130 | (mapcan #'(lambda(occ) |
---|
131 | (find-referenced-topics occ :revision revision)) |
---|
132 | (occurrences top :revision revision)) |
---|
133 | (mapcan #'(lambda(assoc) |
---|
134 | (find-referenced-topics assoc :revision revision)) |
---|
135 | (find-associations top :revision revision)))))) |
---|
136 | |
---|
137 | |
---|
138 | (defgeneric initial-version-p (version-info) |
---|
139 | (:documentation "A helper function for changed-p that returns the passed |
---|
140 | version-info object if it is the initial version-info object, |
---|
141 | i.e. it owns the smallest start-revsion of the |
---|
142 | version-construct.") |
---|
143 | (:method ((version-info VersionInfoC)) |
---|
144 | (unless (find-if #'(lambda(vi) |
---|
145 | (< (start-revision vi) (start-revision version-info))) |
---|
146 | (versions (versioned-construct version-info))) |
---|
147 | version-info))) |
---|
148 | |
---|
149 | |
---|
150 | (defgeneric changed-p (construct revision) |
---|
151 | (:documentation "Has the topic map construct changed in a given revision? |
---|
152 | 'Changed' can mean: |
---|
153 | * newly created |
---|
154 | * deletion of an element |
---|
155 | * modified through the addition or removal of identifiers |
---|
156 | * (for associations) modified through the addition or removal of |
---|
157 | identifiers in the association or one of its roles |
---|
158 | * (for topics) modified through the addition or removal of identifiers |
---|
159 | or characteristics |
---|
160 | * (for topics) modified through the addition or removal of an association |
---|
161 | in which it is first player")) |
---|
162 | |
---|
163 | |
---|
164 | (defmethod changed-p ((construct TopicMapConstructC) (revision integer)) |
---|
165 | "changed-p returns nil for TopicMapConstructCs that are not specified |
---|
166 | more detailed. The actual algorithm is processed for all |
---|
167 | VersionedConstructCs." |
---|
168 | (declare (ignorable revision)) |
---|
169 | nil) |
---|
170 | |
---|
171 | |
---|
172 | (defmethod changed-p ((construct PointerC) (revision integer)) |
---|
173 | "Returns t if the PointerC was added to a construct the first |
---|
174 | time in the passed revision" |
---|
175 | (let ((version-info (some #'(lambda(pointer-association) |
---|
176 | (changed-p pointer-association revision)) |
---|
177 | (slot-p construct 'identified-construct)))) |
---|
178 | (when version-info |
---|
179 | (initial-version-p version-info)))) |
---|
180 | |
---|
181 | |
---|
182 | (defmethod changed-p ((construct VersionedConstructC) (revision integer)) |
---|
183 | "changed-p returns t if there exist a VersionInfoC with the given start-revision." |
---|
184 | (let ((version-info |
---|
185 | (find revision (versions construct) :test #'= :key #'start-revision))) |
---|
186 | (when version-info |
---|
187 | (initial-version-p version-info)))) |
---|
188 | |
---|
189 | |
---|
190 | (defmethod changed-p ((construct CharacteristicC) (revision integer)) |
---|
191 | "Returns t if the CharacteristicC was added to a construct in the passed |
---|
192 | revision or if <ReifiableConstructC> changed." |
---|
193 | (or (call-next-method) |
---|
194 | (let ((version-info |
---|
195 | (some #'(lambda(characteristic-association) |
---|
196 | (changed-p characteristic-association revision)) |
---|
197 | (slot-p construct 'parent)))) |
---|
198 | (when version-info |
---|
199 | (initial-version-p version-info))))) |
---|
200 | |
---|
201 | |
---|
202 | (defmethod changed-p ((construct RoleC) (revision integer)) |
---|
203 | "Returns t if the RoleC was added to a construct in the passed |
---|
204 | revision or if <ReifiableConstructC> changed." |
---|
205 | (or (call-next-method) |
---|
206 | (let ((version-info |
---|
207 | (some #'(lambda(role-association) |
---|
208 | (changed-p role-association revision)) |
---|
209 | (slot-p construct 'parent)))) |
---|
210 | (when version-info |
---|
211 | (initial-version-p version-info))))) |
---|
212 | |
---|
213 | |
---|
214 | (defgeneric end-revision-p (construct revision) |
---|
215 | (:documentation "A helper function for changed-p. It returns the latest |
---|
216 | version-info if the passed versioned-construct was |
---|
217 | marked-as-deleted in the version that is given.") |
---|
218 | (:method ((construct VersionedConstructC) (revision integer)) |
---|
219 | (let ((version-info (find revision (versions construct) |
---|
220 | :key #'end-revision :test #'=))) |
---|
221 | (when (and version-info |
---|
222 | (not |
---|
223 | (find-if |
---|
224 | #'(lambda(vi) |
---|
225 | (or (> (end-revision vi) (end-revision version-info)) |
---|
226 | (= (end-revision vi) 0))) |
---|
227 | (versions construct)))) |
---|
228 | version-info)))) |
---|
229 | |
---|
230 | |
---|
231 | (defmethod changed-p ((construct ReifiableConstructC) (revision integer)) |
---|
232 | "Returns t if a ReifiableConstructC changed in the given version, i.e. |
---|
233 | an item-identifier or reifier was added to the construct itself." |
---|
234 | (or (some #'(lambda(vc) |
---|
235 | (changed-p vc revision)) |
---|
236 | (union (item-identifiers construct :revision revision) |
---|
237 | (let ((reifier-top (reifier construct :revision revision))) |
---|
238 | (when reifier-top |
---|
239 | (list reifier-top))))) |
---|
240 | (some #'(lambda(vc) |
---|
241 | (end-revision-p vc revision)) |
---|
242 | (union (slot-p construct 'item-identifiers) |
---|
243 | (slot-p construct 'reifier))))) |
---|
244 | |
---|
245 | |
---|
246 | (defmethod changed-p ((construct NameC) (revision integer)) |
---|
247 | "Returns t if the passed NameC changed in the given version, i.e. |
---|
248 | the <ReifiableConstructC> characteristics or the variants changed." |
---|
249 | (or (call-next-method) |
---|
250 | (some #'(lambda(var) |
---|
251 | (changed-p var revision)) |
---|
252 | (variants construct :revision revision)) |
---|
253 | (some #'(lambda(vc) |
---|
254 | (end-revision-p vc revision)) |
---|
255 | (slot-p construct 'variants)))) |
---|
256 | |
---|
257 | |
---|
258 | (defmethod changed-p ((construct TopicC) (revision integer)) |
---|
259 | "Returns t if the passed TopicC changed in the given version, i.e. |
---|
260 | the <ReifiableConstructC>, <PersistentIdC>, <LocatorC>, <NameC>, |
---|
261 | <OccurrenceC>, <AssociationC> or the reified-construct changed." |
---|
262 | (or (call-next-method) |
---|
263 | (some #'(lambda(vc) |
---|
264 | (changed-p vc revision)) |
---|
265 | (union |
---|
266 | (union |
---|
267 | (union (psis construct :revision revision) |
---|
268 | (locators construct :revision revision)) |
---|
269 | (union (names construct :revision revision) |
---|
270 | (occurrences construct :revision revision))) |
---|
271 | (remove-if-not |
---|
272 | (lambda (assoc) |
---|
273 | (eq (player (first (roles assoc :revision revision)) |
---|
274 | :revision revision) |
---|
275 | construct)) |
---|
276 | (find-all-associations construct :revision revision)))) |
---|
277 | (let ((rc (reified-construct construct :revision revision))) |
---|
278 | (when rc |
---|
279 | (let ((ra (find-if #'(lambda(reifier-assoc) |
---|
280 | (eql (reifiable-construct reifier-assoc) rc)) |
---|
281 | (slot-p construct 'reified-construct)))) |
---|
282 | (changed-p ra revision)))) |
---|
283 | (some #'(lambda(vc) |
---|
284 | (end-revision-p vc revision)) |
---|
285 | (union (union (union (slot-p construct 'psis) |
---|
286 | (slot-p construct 'locators)) |
---|
287 | (union (slot-p construct 'names) |
---|
288 | (slot-p construct 'occurrences))) |
---|
289 | (slot-p construct 'reified-construct))))) |
---|
290 | |
---|
291 | |
---|
292 | |
---|
293 | (defmethod changed-p ((construct AssociationC) (revision integer)) |
---|
294 | "Returns t if the passed AssociationC changed in the given version, i.e. |
---|
295 | the <RoleC> or the <ReifiableConstructC> changed." |
---|
296 | (or (call-next-method) |
---|
297 | (some #'(lambda(role) |
---|
298 | (changed-p role revision)) |
---|
299 | (roles construct :revision revision)) |
---|
300 | (some #'(lambda(vc) |
---|
301 | (end-revision-p vc revision)) |
---|
302 | (slot-p construct 'roles)))) |
---|
303 | |
---|
304 | |
---|
305 | (defpclass FragmentC () |
---|
306 | ((revision :type integer |
---|
307 | :initarg :revision |
---|
308 | :accessor revision |
---|
309 | :index t |
---|
310 | :documentation "revision in question") |
---|
311 | (unique-id :initarg :unique-id |
---|
312 | :accessor unique-id |
---|
313 | :index t |
---|
314 | :documentation "a unique id for this fragment. for now |
---|
315 | just its OID, but may become a true UUID in the future") |
---|
316 | (topic :type TopicC |
---|
317 | :initarg :topic |
---|
318 | :accessor topic |
---|
319 | :index t |
---|
320 | :documentation "changed topic (topicSI in Atom") |
---|
321 | (referenced-topics |
---|
322 | :type list |
---|
323 | :initarg :referenced-topics |
---|
324 | :accessor referenced-topics |
---|
325 | :documentation "list of topics that this topic references somehow (through associations, types, scopes in the characteristics etc.") |
---|
326 | (associations |
---|
327 | :type list |
---|
328 | :initarg :associations |
---|
329 | :accessor associations |
---|
330 | :documentation "list of association that this topic is a player in"))) |
---|
331 | |
---|
332 | (defmethod initialize-instance :after ((fragment FragmentC) &key) |
---|
333 | "initialze the unique id of the fragment ot some suitable value" |
---|
334 | (setf (slot-value fragment 'unique-id) (elephant::oid fragment))) |
---|
335 | |
---|
336 | |
---|
337 | (defun get-fragments (revision) |
---|
338 | "Gets the list of all fragments for a given revision. Returns a |
---|
339 | list of FragmentC objects" |
---|
340 | (declare (integer revision)) |
---|
341 | (let |
---|
342 | ((cached-fragments |
---|
343 | (elephant:get-instances-by-value 'FragmentC |
---|
344 | 'revision |
---|
345 | revision))) |
---|
346 | (if cached-fragments |
---|
347 | cached-fragments |
---|
348 | (remove |
---|
349 | nil |
---|
350 | (map |
---|
351 | 'list |
---|
352 | (lambda (top) |
---|
353 | (when (changed-p top revision) |
---|
354 | (make-instance 'FragmentC |
---|
355 | :revision revision |
---|
356 | :associations (find-associations |
---|
357 | top :revision revision) |
---|
358 | ;TODO: this quite probably introduces |
---|
359 | ;code duplication with query: Check! |
---|
360 | :referenced-topics (find-referenced-topics |
---|
361 | top :revision revision) |
---|
362 | :topic top))) |
---|
363 | (get-all-topics revision)))))) |
---|
364 | |
---|
365 | (defun get-fragment (unique-id) |
---|
366 | "get a fragment by its unique id" |
---|
367 | (declare (integer unique-id)) |
---|
368 | (elephant:get-instance-by-value 'FragmentC |
---|
369 | 'unique-id |
---|
370 | unique-id)) |
---|
371 | |
---|
372 | (defgeneric add-source-locator (construct &key source-locator revision) |
---|
373 | (:documentation "adds an item identifier to a given construct based on the source |
---|
374 | locator and an internally generated id (ideally a uuid)")) |
---|
375 | |
---|
376 | |
---|
377 | (defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision) |
---|
378 | (declare (integer revision)) |
---|
379 | (unless |
---|
380 | (some (lambda (ii) |
---|
381 | (string-starts-with (uri ii) source-locator)) |
---|
382 | (item-identifiers construct :revision revision)) |
---|
383 | (let |
---|
384 | ((ii-uri (format nil "~a/~d" source-locator (internal-id construct)))) |
---|
385 | (make-construct 'ItemIdentifierC |
---|
386 | :uri ii-uri |
---|
387 | :identified-construct construct |
---|
388 | :start-revision revision)))) |
---|
389 | |
---|
390 | |
---|
391 | (defmethod add-source-locator ((top TopicC) &key source-locator revision) |
---|
392 | ;topics already have the source locator in (at least) one PSI, so we |
---|
393 | ;do not need to add an extra item identifier to them. However, we |
---|
394 | ;need to do that for all their characteristics + associations |
---|
395 | (mapc (lambda (name) |
---|
396 | (add-source-locator name :revision revision |
---|
397 | :source-locator source-locator)) |
---|
398 | (names top :revision revision)) |
---|
399 | (mapc (lambda (occ) |
---|
400 | (add-source-locator occ :revision revision |
---|
401 | :source-locator source-locator)) |
---|
402 | (occurrences top :revision revision)) |
---|
403 | (mapc (lambda (ass) |
---|
404 | (add-source-locator ass :revision revision |
---|
405 | :source-locator source-locator)) |
---|
406 | (find-associations top :revision revision))) |
---|
407 | |
---|
408 | |
---|
409 | (defun create-latest-fragment-of-topic (topic-psi) |
---|
410 | "Returns the latest fragment of the passed topic-psi" |
---|
411 | (declare (string topic-psi)) |
---|
412 | (let ((topic (get-latest-topic-by-psi topic-psi))) |
---|
413 | (when topic |
---|
414 | (let ((start-revision |
---|
415 | (start-revision |
---|
416 | (find-if #'(lambda(x) |
---|
417 | (when (= 0 (end-revision x)) |
---|
418 | t)) |
---|
419 | (versions topic))))) |
---|
420 | (let ((existing-fragment |
---|
421 | (find-if #'(lambda(x) |
---|
422 | (when (eq topic (topic x)) |
---|
423 | t)) |
---|
424 | (get-fragments start-revision)))) |
---|
425 | (if existing-fragment |
---|
426 | existing-fragment |
---|
427 | (make-instance 'FragmentC |
---|
428 | :revision start-revision |
---|
429 | :associations (find-associations |
---|
430 | topic :revision start-revision) |
---|
431 | :referenced-topics (find-referenced-topics |
---|
432 | topic :revision start-revision) |
---|
433 | :topic topic))))))) |
---|
434 | |
---|
435 | |
---|
436 | (defun get-latest-fragment-of-topic (topic-psi) |
---|
437 | "Returns the latest existing fragment of the passed topic-psi." |
---|
438 | (declare (string topic-psi)) |
---|
439 | (let ((topic (get-latest-topic-by-psi topic-psi))) |
---|
440 | (when topic |
---|
441 | (let ((existing-fragments |
---|
442 | (elephant:get-instances-by-value 'FragmentC 'topic topic))) |
---|
443 | (when existing-fragments |
---|
444 | (first (sort existing-fragments |
---|
445 | #'(lambda(frg-1 frg-2) |
---|
446 | (> (revision frg-1) (revision frg-2)))))))))) |
---|