source: branches/gdl-frontend/playground/abcl-test/lisp-code/TM-SPARQL/sparql.lisp

Last change on this file was 395, checked in by lgiessmann, 14 years ago

playground: added a project that uses some test cases with ABCL
File size: 44.9 KB
Line 
1;;+-----------------------------------------------------------------------------
2;;+  Isidorus
3;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
4;;+
5;;+  Isidorus is freely distributable under the LLGPL license.
6;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
7;;+  trunk/docs/LGPL-LICENSE.txt.
8;;+-----------------------------------------------------------------------------
9
10(defpackage :TM-SPARQL
11  (:use :cl :datamodel :base-tools :exceptions :constants
12        :TM-SPARQL-Constants :xml-importer :xml-constants
13        :isidorus-threading :xml-tools)
14  (:export :SPARQL-Query
15           :result
16           :init-tm-sparql))
17
18
19
20(in-package :TM-SPARQL)
21
22(defvar *empty-label* "_empty_label_symbol" "A label symobl for empyt prefix labels")
23
24(defvar *equal-operators* nil "A Table taht contains tuples of
25                               classes and equality operators.")
26
27
28
29(defgeneric sparql-node (construct &key revision)
30  (:documentation "Returns a string of the form <uri> or _t123 that represents
31                   a resource node or a blank node.")
32  (:method ((construct TopicMapConstructC) &key (revision d:*TM-REVISION*))
33    (declare (Integer revision))
34    (let ((uri-string (any-id construct :revision revision)))
35      (if uri-string
36          (concat "<" uri-string ">")
37          (let ((oid-string (write-to-string (elephant::oid construct)))
38                (pref (subseq (symbol-name (type-of construct)) 0 1)))
39            (concat "_:" (string-downcase pref) oid-string))))))
40
41
42(defun init-tm-sparql (&optional (revision (get-revision)))
43  "Imports the file tmsparql_core_psis.xtm. core_psis.xtm has to be imported
44   before."
45  (with-writer-lock
46    (with-tm (revision "tmsparql.xtm" (concat *tms* "topic-map"))
47      (let ((core-dom (cxml:parse-file *tmsparql_core_psis.xtm*
48                                       (cxml-dom:make-dom-builder)))
49            (xtm-id (reverse
50                     (base-tools:string-until
51                      (reverse
52                       (pathname-name
53                        xml-constants:*tmsparql_core_psis.xtm*)) "/"))))
54        (elephant:ensure-transaction (:txn-nosync t)
55          (loop for top-elem across 
56               (xpath-child-elems-by-qname (dom:document-element core-dom)
57                                           *xtm2.0-ns* "topic")
58             do (let ((top
59                       (from-topic-elem-to-stub top-elem revision
60                                                :xtm-id xtm-id)))
61                  (add-to-tm xml-importer::tm top))))))))
62
63
64
65(defun init-*equal-operators* ()
66  (setf *equal-operators*
67        (list (list :class 'Boolean :operator #'eql)
68              (list :class 'String :operator #'string=)
69              (list :class 'Number :operator #'=))))
70
71
72(init-*equal-operators*)
73
74
75(defun get-equal-operator (value)
76  (let ((entry
77         (find-if #'(lambda(entry)
78                      (typep value (getf entry :class)))
79                  *equal-operators*)))
80    (when entry
81      (getf entry :operator))))
82
83
84(defclass SPARQL-Triple-Elem()
85  ((elem-type :initarg :elem-type
86              :reader elem-type
87              :type Symbol
88              :initform (error
89                         (make-condition
90                          'missing-argument-error
91                          :message "From SPARQL-Triple-Elem(): elem-type must be set"))
92              :documentation "Contains information about the type of this element
93                              possible values are 'IRI, 'VARIABLE, or 'LITERAL")
94   (value :initarg :value
95          :accessor value
96          :type T
97          :initform nil
98          :documentation "Contains the actual value of any type.")
99   (literal-lang :initarg :literal-lang
100                 :accessor literal-lang
101                 :initform nil
102                 :type String
103                 :documentation "Contains the @lang attribute of a literal")
104   (literal-datatype :initarg :literal-datatype
105                     :accessor literal-datatype
106                     :type String
107                     :initform nil
108                     :documentation "Contains the datatype of the literal,
109                                     e.g. xml:string"))
110  (:documentation "Represents one element of an RDF-triple."))
111
112
113(defclass SPARQL-Triple()
114  ((subject :initarg :subject
115            :accessor subject
116            :type SPARQL-Triple-Elem
117            :initform (error
118                       (make-condition
119                        'missing-argument-error
120                        :message "From SPARQL-Triple(): subject must be set"))
121            :documentation "Represents the subject of an RDF-triple.")
122   (subject-result :initarg :subject-result
123                   :accessor subject-result
124                   :type T
125                   :initform nil
126                   :documentation "Contains the result of the subject triple elem.")
127   (predicate :initarg :predicate
128              :accessor predicate
129              :type SPARQL-Triple-Elem
130              :initform (error
131                         (make-condition
132                          'missing-argument-error
133                          :message "From SPARQL-Triple(): predicate must be set"))
134            :documentation "Represents the predicate of an RDF-triple.")
135   (predicate-result :initarg :predicate-result
136                     :accessor predicate-result
137                     :type T
138                     :initform nil
139                     :documentation "Contains the result of the predicate
140                                     triple elem.")
141   (object :initarg :object
142           :accessor object
143           :type SPARQL-Triple-Elem
144           :initform (error
145                      (make-condition
146                       'missing-argument-error
147                       :message "From SPARQL-Triple-(): object must be set"))
148           :documentation "Represents the subject of an RDF-triple.")
149   (object-result :initarg :object-result
150                  :accessor object-result
151                  :type T
152                  :initform nil
153                  :documentation "Contains the result of the object triple elem."))
154  (:documentation "Represents an entire RDF-triple."))
155
156
157(defclass SPARQL-Query ()
158  ((revision :initarg :revision
159             :accessor revision
160             :type Integer
161             :initform 0
162             :documentation "Represents the revision in which all the queries
163                             are processed in the DB.")
164   (original-query :initarg :query
165                   :accessor original-query  ;this value is only for internal
166                                             ;purposes and mustn't be reset
167                   :type String
168                   :initform (error
169                              (make-condition
170                               'missing-argument-error
171                               :message "From TM-Query(): original-query must be set"))
172                   :documentation "Containst the original received querry as string")
173   (variables :initarg :variables
174              :accessor variables ;this value is only for internal purposes
175                                        ;purposes and mustn't be reset
176              :type List
177              :initform nil
178              :documentation "A list of that contains the variable
179                              names as strings.")
180   (prefixes :initarg :prefixes
181             :accessor prefixes ;this value is only for internal purposes
182                                ;purposes and mustn't be reset
183             :type List
184             :initform nil
185             :documentation "A list of the form
186                            ((:label 'id' :value 'prefix'))")
187   (base-value :initarg :base ;initialy the requester's address
188               :accessor base-value ;this value is only for internal purposes
189                                    ;purposes and mustn't be reset
190               :type String
191               :initform nil
192               :documentation "Contains the last set base-value.")
193   (select-group :initarg :select-group
194                 :accessor select-group ;this value is only for
195                                        ;internal purposes purposes
196                                        ;and mustn't be reset
197                 :type List
198                 :initform nil
199                 :documentation "Contains a SPARQL-Group that represents
200                                 the entire inner select-where statement.")
201   (filters :initarg filters
202            :accessor filters ;this value is only for internal purposes
203                              ;purposes and mustn't be reset
204            :type List ;a list of strings
205            :initform nil
206            :documentation "Contains strings, each string represents a filter
207                            that was transformed to lisp code and can be evoked
208                            on each triple in the list select-group."))
209  (:documentation "This class represents the entire request."))
210
211
212(defgeneric *-p (construct)
213  (:documentation "Returns t if the user selected all variables with *.")
214  (:method ((construct SPARQL-Query))
215    (loop for var in (variables construct)
216       when (string= var "*")
217       return t)))
218
219
220(defgeneric add-filter (construct filter)
221  (:documentation "Pushes the filter string to the corresponding list in
222                   the construct.")
223  (:method ((construct SPARQL-Query) (filter String))
224    (push filter (filters construct))))
225
226
227(defmethod variables ((construct SPARQL-Triple))
228  "Returns all variable names that are contained in the passed element."
229  (remove-duplicates
230   (remove-null
231    (list (when (variable-p (subject construct))
232            (value (subject construct)))
233          (when (variable-p (predicate construct))
234            (value (predicate construct)))
235          (when (variable-p (object construct))
236            (value (object construct)))))
237   :test #'string=))
238
239
240(defgeneric add-triple (construct triple)
241  (:documentation "Adds a triple object to the select-group list.")
242  (:method ((construct SPARQL-Query) (triple SPARQL-Triple))
243    (push triple (slot-value construct 'select-group))))
244
245
246(defgeneric (setf elem-type) (construct elem-type)
247  (:documentation "Sets the passed elem-type on the passed cosntruct.")
248  (:method ((construct SPARQL-Triple-Elem) (elem-type Symbol))
249    (when (and (not (eql elem-type 'IRI))
250               (not (eql elem-type 'VARIABLE))
251               (not (eql elem-type 'LITERAL)))
252      (error (make-condition
253              'bad-argument-error
254              :message (format nil "Expected a one of the symbols ~a, but get ~a~%"
255                               '('IRI 'VARIABLE 'LITERAL) elem-type))))
256    (setf (slot-value construct 'elem-type) elem-type)))
257
258
259(defgeneric add-prefix (construct prefix-label prefix-value)
260  (:documentation "Adds the new prefix tuple to the list of all existing.
261                   If there already exists a tuple with the same label
262                   the label's value will be overwritten by the new value.")
263  (:method ((construct SPARQL-Query) (prefix-label String) (prefix-value String))
264    (let ((existing-tuple
265           (find-if #'(lambda(x)
266                        (string= (getf x :label) prefix-label))
267                    (prefixes construct))))
268      (if existing-tuple
269          (setf (getf existing-tuple :value) prefix-value)
270          (push (list :label prefix-label :value prefix-value)
271                (prefixes construct))))))
272
273
274(defgeneric get-prefix (construct string-with-prefix)
275  (:documentation "Returns the URL corresponding to the found prefix-label
276                   followed by : and the variable. Otherwise the return
277                   value is nil.")
278  (:method ((construct SPARQL-query) (string-with-prefix String))
279    (loop for entry in (prefixes construct)
280       when (string-starts-with string-with-prefix (concat (getf entry :label) ":"))
281       return (concatenate-uri
282               (getf entry :value)
283               (string-after string-with-prefix (concat (getf entry :label) ":"))))))
284
285
286(defgeneric add-variable (construct variable-name)
287  (:documentation "Adds a new variable-name with its value to the aexisting list.
288                   If a variable-already exists the existing entry will be
289                   overwritten. An entry is of the form
290                   (:variable string :value any-type).")
291  (:method ((construct SPARQL-Query) (variable-name String))
292    (unless (find variable-name (variables construct) :test #'string=)
293      (push variable-name (variables construct)))))
294
295
296(defgeneric make-variable-values(construct variable-name existing-results)
297  (:documentation "Returns a list of values that are bound to the passed
298                   variable. The first occurrence of the given variable
299                   is evaluated, since all occurrences have the same values,
300                   because reduce-results is called before and makes an
301                   intersection over all triples.")
302  (:method ((construct SPARQL-Query) (variable-name String) (existing-results List))
303    (let* ((found-p nil)
304           (results
305            (loop for triple in (select-group construct)
306               when (and (variable-p (subject triple))
307                         (string= (value (subject triple)) variable-name))
308               return (progn (setf found-p t)
309                             (subject-result triple))
310               when (and (variable-p (predicate triple))
311                         (string= (value (predicate triple)) variable-name))
312               return (progn (setf found-p t)
313                             (predicate-result triple))
314               when (and (variable-p (object triple))
315                         (string= (value (object triple))
316                                  variable-name))
317               return (progn (setf found-p t)
318                             (object-result triple))))
319           (new-results nil))
320      (if (not found-p)
321          existing-results
322          (if existing-results
323              (dolist (result results new-results)
324                (dolist (old-result existing-results)
325                  (push (append old-result (list (list :variable-name variable-name
326                                                       :variable-value result)))
327                        new-results)))
328              (map 'list #'(lambda(result)
329                             (list (list :variable-name variable-name
330                                         :variable-value result)))
331                   results))))))
332
333
334(defun to-lisp-code (variable-values filter)
335  "Concatenates all variable names and elements with the filter expression
336   in a let statement and returns a string representing the corresponding
337   lisp code."
338  (declare (List variable-values))
339  (let ((result "(let* ((true t)(false nil)"))
340    (dolist (var-elem variable-values)
341      (push-string (concat "(?" (getf var-elem :variable-name) " "
342                           (write-to-string (getf var-elem :variable-value)) ")")
343                   result)
344      (push-string (concat "($" (getf var-elem :variable-name) " "
345                           (write-to-string (getf var-elem :variable-value)) ")")
346                   result))
347    (push-string (concat "(result " filter "))") result)
348    (push-string "(declare (Ignorable true false " result)
349    (when variable-values
350      (dolist (var-elem variable-values)
351        (push-string (concat "?" (getf var-elem :variable-name) " ") result)
352        (push-string (concat "$" (getf var-elem :variable-name) " ") result)))
353    (push-string ")) result)" result)
354    (concat "(handler-case " result " (condition () nil))")))
355
356
357(defun return-false-values (all-values true-values)
358  "Returns a list that contains all values from all-values that
359   are not contained in true-values."
360  (let ((local-all-values
361         (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values)
362                            :test #'variable-list=))
363        (results nil))
364    (dolist (value local-all-values)
365      (when (not (find value true-values :test #'variable-list=))
366        (push value results)))
367    results))
368
369
370(defun variable-list= (x y)
371  (and (string= (getf x :variable-name)
372                (getf y :variable-name))
373       (literal= (getf x :variable-value)
374                 (getf y :variable-value))))
375
376
377(defgeneric process-filters (construct)
378  (:documentation "Processes all filters by calling invoke-filter.")
379  (:method ((construct SPARQL-Query))
380    (dolist (filter (filters construct))
381      (let* ((filter-variable-names
382              (get-variables-from-filter-string filter))
383             (filter-variable-values nil)
384             (true-values nil))
385        (dolist (var-name filter-variable-names)
386          (setf filter-variable-values
387                (make-variable-values construct var-name filter-variable-values)))
388        (dolist (filter (filters construct))
389          (dolist (var-elem filter-variable-values)
390            (when (eval (read-from-string (to-lisp-code var-elem filter)))
391              (map 'list #'(lambda(list-elem)
392                             (push list-elem true-values))
393                   var-elem))))
394        (let ((values-to-remove
395               (return-false-values filter-variable-values
396                                    (remove-duplicates true-values
397                                                       :test #'variable-list=))))
398          (dolist (to-del values-to-remove)
399            (delete-rows-by-value construct (getf to-del :variable-name)
400                                  (getf to-del :variable-value))))))
401    construct))
402
403
404(defgeneric idx-of (construct variable-name variable-value &key what)
405  (:documentation "Returns the idx of the variable with the name
406                   variable-name and the value variable-value.")
407  (:method ((construct SPARQL-Triple) (variable-name String)
408            variable-value &key (what :subject))
409    (declare (Keyword what))
410    (let ((result nil)
411          (local-results
412           (cond ((eql what :subject) (subject-result construct))
413                 ((eql what :predicate) (predicate-result construct))
414                 ((eql what :object) (object-result construct))))
415          (is-variable
416           (cond ((eql what :subject)
417                  (and (variable-p (subject construct))
418                       (value (subject construct))))
419                 ((eql what :predicate)
420                  (and (variable-p (predicate construct))
421                       (value (predicate construct))))
422                 ((eql what :object)
423                  (and (variable-p (object construct))
424                       (value (object construct)))))))
425      (when is-variable
426        (remove-null
427         (dotimes (idx (length local-results))
428           (when (literal= variable-value (elt local-results idx))
429             (push idx result)))))
430      result)))
431
432
433(defgeneric delete-rows-by-value (construct variable-name value-to-delete)
434  (:documentation "Deletes all rows that owns a variable with the
435                   given value.")
436  (:method ((construct SPARQL-Query) (variable-name String) value-to-delete)
437    (dolist (triple (select-group construct))
438      (let* ((subj-delete-idx-lst
439              (idx-of triple variable-name value-to-delete))
440             (pred-delete-idx-lst
441              (idx-of triple variable-name value-to-delete :what :predicate))
442             (obj-delete-idx-lst
443              (idx-of triple variable-name value-to-delete :what :object))
444             (all-idxs (union (union subj-delete-idx-lst
445                                     pred-delete-idx-lst)
446                              obj-delete-idx-lst)))
447        (when all-idxs
448          (let ((new-values nil))
449            (dotimes (idx (length (subject-result triple)))
450              (when (not (find idx all-idxs))
451                (push
452                 (list :subject (elt (subject-result triple) idx)
453                       :predicate (elt (predicate-result triple) idx)
454                       :object (elt (object-result triple) idx))
455                 new-values)))
456            (setf (subject-result triple)
457                  (map 'list #'(lambda(elem) (getf elem :subject)) new-values))
458            (setf (predicate-result triple)
459                  (map 'list #'(lambda(elem) (getf elem :predicate)) new-values))
460            (setf (object-result triple)
461                  (map 'list #'(lambda(elem) (getf elem :object)) new-values))))))
462    construct))
463
464
465(defgeneric set-results (construct &key revision)
466  (:documentation "Calculates the result of a triple and set all the values in
467                   the passed object.")
468  (:method ((construct SPARQL-Triple) &key (revision d:*TM-REVISION*))
469    (declare (Integer revision))
470    (set-tm-constructs construct :revision revision)
471    (when (not (iri-not-found-p construct)) ;there is only a result if all IRIs were found
472      (let ((results (append
473                      (or (filter-by-given-subject construct :revision revision)
474                          (filter-by-given-predicate construct :revision revision)
475                          (filter-by-given-object construct :revision revision))
476                      (filter-by-special-uris construct :revision revision))))
477        (map 'list #'(lambda(result)
478                       (push (getf result :subject) (subject-result construct))
479                       (push (getf result :predicate) (predicate-result construct))
480                       (push (getf result :object) (object-result construct)))
481             ;;literal-datatype is not used and is not returned, since
482             ;;the values are returned as object of their specific type, e.g.
483             ;;integer, boolean, string, ...
484             results)))))
485
486
487(defgeneric filter-by-given-object (construct &key revision)
488  (:documentation "Returns a list representing a triple that is the result
489                   of a given object.")
490  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
491    (declare (Integer revision))
492    (when (and (not (variable-p (object construct)))
493               (variable-p (predicate construct))
494               (variable-p (subject construct)))
495      (cond ((literal-p (object construct))
496             (filter-by-characteristic-value (value (object construct))
497                                             (literal-datatype (object construct))
498                                             :revision revision))
499            ((iri-p (object construct))
500             (filter-by-otherplayer (value (object construct))
501                                    :revision revision))))))
502
503
504(defun return-characteristics (literal-value literal-datatype)
505  "Returns all characteristica that own the specified value."
506  (declare (String literal-datatype))
507  (let ((chars
508         (cond ((string= literal-datatype *xml-string*)
509                (remove-if #'(lambda(elem)
510                               (string/= (charvalue elem) literal-value))
511                           (append
512                            (elephant:get-instances-by-value
513                             'OccurrenceC 'charvalue literal-value)
514                            (elephant:get-instances-by-value
515                             'VariantC 'charvalue literal-value)
516                            (elephant:get-instances-by-value
517                             'NameC 'charvalue literal-value))))
518               ((and (string= literal-datatype *xml-boolean*)
519                     literal-value)
520                (remove-if #'(lambda(elem)
521                               (string/= (charvalue elem) "true"))
522                           (append (elephant:get-instances-by-value
523                                    'VariantC 'charvalue "true")
524                                   (elephant:get-instances-by-value
525                                    'OccurrenceC 'charvalue "true"))))
526               ((and (string= literal-datatype *xml-boolean*)
527                     (not literal-value))
528                (remove-if #'(lambda(elem)
529                               (string/= (charvalue elem) "false"))
530                           (append (elephant:get-instances-by-value
531                                    'VariantC 'charvalue "true")
532                                   (elephant:get-instances-by-value
533                                    'OccurrenceC 'charvalue "false"))))
534               ((or (string= literal-datatype *xml-double*)
535                    (string= literal-datatype *xml-decimal*)
536                    (string= literal-datatype *xml-integer*))
537                (let ((constructs
538                       (remove-if #'(lambda(con)
539                                      (string/= (datatype con) literal-datatype))
540                                  (append
541                                   (elephant:get-instances-by-value
542                                    'VariantC 'datatype literal-datatype)
543                                   (elephant:get-instances-by-value
544                                    'OccurrenceC 'datatype literal-datatype)))))
545                  (remove-if #'(lambda(con)
546                                 (not (literal= (charvalue con) literal-value)))
547                             constructs))))))
548    ;;elephant returns names, occurences, and variants if any string
549    ;;value matches, so all duplicates have to be removed
550    (remove-duplicates chars)))
551
552
553(defun filter-by-characteristic-value (literal-value literal-datatype
554                                       &key (revision *TM-REVISION*))
555  "Returns a triple where the passed value is a charvalue in a occurrence
556   or name. The subject is the owner topic and the predicate is the
557   characteristic's type.
558   (Variants are not considered because they are not typed, so they cannot
559   be referenced via a predicate)."
560  (declare (Integer revision)
561           (String literal-datatype))
562    (remove-null
563     (map 'list #'(lambda(char)
564                    (let ((subj-uri
565                           (when-do top (parent char :revision revision)
566                                    (sparql-node top :revision revision)))
567                          (pred-uri
568                           (when-do top (instance-of char :revision revision)
569                                    (sparql-node top :revision revision))))
570                      (list :subject subj-uri
571                            :predicate pred-uri
572                            :object (charvalue char)
573                            :literal-datatype literal-datatype)))
574          (remove-if #'(lambda(char)
575                         (typep char 'VariantC))
576                     (return-characteristics literal-value literal-datatype)))))
577
578
579(defgeneric filter-by-otherplayer (construct &key revision)
580  (:documentation "Returns triples where the passed player is the object,
581                   the other player is the subject and the type of the passed
582                   player's role is the predicate.")
583  (:method ((construct TopicC) &key (revision *TM-REVISION*))
584    (declare (Integer revision))
585    (let ((roles-by-oplayer (player-in-roles construct :revision revision))
586          (obj-uri (sparql-node construct :revision revision)))
587      (remove-null
588       (map 'list
589            #'(lambda(role)
590                (let ((orole
591                       (when-do assoc (parent role :revision revision)
592                                (when (= (length (roles assoc :revision revision))
593                                         2)
594                                  (find-if #'(lambda(r) (not (eql r role)))
595                                           (roles assoc :revision revision))))))
596                  (list :subject
597                        (when-do plr (player orole :revision revision)
598                                 (sparql-node plr :revision revision))
599                        :predicate
600                        (when-do type (instance-of role :revision revision)
601                                 (sparql-node type :revision revision))
602                        :object obj-uri)))
603            roles-by-oplayer)))))
604
605
606(defgeneric filter-by-given-predicate (construct &key revision)
607  (:documentation "Returns all topics that owns a characteristic of the
608                   given type or an associaiton with an otherrole of the
609                   given type. The result is a plist representing a triple.")
610  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
611    (declare (Integer revision))
612    (when (and (variable-p (subject construct))
613               (iri-p (predicate construct)))
614      (cond ((variable-p (object construct))
615             (append (filter-by-otherroletype construct :revision revision)
616                     (filter-by-characteristictype construct :revision revision)))
617            ((literal-p (object construct))
618             (filter-by-characteristictype construct :revision revision))
619            ((iri-p (object construct))
620             (filter-by-otherroletype construct :revision revision))))))
621
622
623(defgeneric filter-by-otherroletype (construct &key revision)
624  (:documentation "Returns triple where the passed predicate is a
625                   type of a role. The returned subject is the otherplayer,
626                   the predicate is the passed predicate, the object is
627                   the player of the role of the passed type.")
628  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
629    (declare (Integer revision))
630    (when (or (variable-p (object construct))
631              (iri-p (object construct)))
632      (let* ((roles-by-type
633              (remove-null
634               (map 'list #'(lambda(typed-construct)
635                              (when (typep typed-construct 'RoleC)
636                                typed-construct))
637                    (used-as-type (value (predicate construct)) :revision revision))))
638             (roles-by-player
639              (if (iri-p (object construct))
640                  (remove-null
641                   (map 'list #'(lambda(role)
642                                  (when (eql (player role :revision revision)
643                                             (value (object construct)))
644                                    role))
645                        roles-by-type))
646                  roles-by-type)))
647        (remove-null
648         (map 'list
649              #'(lambda(role)
650                  (let* ((assoc (parent role :revision revision))
651                         (orole (when (and assoc
652                                           (= (length
653                                               (roles assoc :revision revision))
654                                              2))
655                                  (find-if #'(lambda(r)
656                                               (not (eql r role)))
657                                           (roles assoc :revision revision)))))
658                    (list :subject
659                          (when-do plr (player orole :revision revision)
660                                   (sparql-node plr :revision revision))
661                          :predicate
662                          (sparql-node (value (predicate construct))
663                                                 :revision revision)
664                          :object
665                          (when-do plr-top (player role :revision revision)
666                                   (sparql-node plr-top :revision revision)))))
667              roles-by-player))))))
668
669
670(defgeneric filter-by-characteristictype (construct &key revision)
671  (:documentation "Returns the results of filter-by-nametype and
672                   filter-by-occurrencetype.")
673  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
674    (declare (Integer revision))
675    (append (filter-by-nametype construct :revision revision)
676            (filter-by-occurrencetype construct :revision revision))))
677
678
679(defgeneric filter-by-nametype (construct &key revision)
680  (:documentation "Returns all names that corresponds to the given parameters.")
681  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
682    (declare (Integer revision))
683    (when (and (not (iri-p (object construct)))
684               (or (not (literal-datatype (object construct)))
685                   (string= (literal-datatype (object construct)) *xml-string*)))
686      (let* ((names-by-type
687              (remove-null
688               (map 'list #'(lambda(typed-construct)
689                              (when (typep typed-construct 'NameC)
690                                typed-construct))
691                    (used-as-type (value (predicate construct))
692                                  :revision revision))))
693             (names-by-literal
694              (if (variable-p (object construct))
695                  names-by-type
696                  (remove-null
697                   (map 'list #'(lambda(name)
698                                  (when (string= (charvalue name)
699                                                 (value (object construct)))
700                                    name))
701                        names-by-type)))))
702        (remove-null
703         (map 'list
704              #'(lambda(name)
705                  (list :subject
706                        (when-do top (parent name :revision revision)
707                                 (sparql-node top :revision revision))
708                        :predicate
709                        (when-do top (instance-of name :revision revision)
710                                 (sparql-node top :revision revision))
711                        :object (charvalue name)
712                        :literal-datatype *xml-string*))
713              names-by-literal))))))
714
715
716(defgeneric filter-by-occurrencetype (construct &key revision)
717  (:documentation "Returns all occurrence that corresponds to the
718                   given parameters.")
719  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
720    (declare (Integer revision))
721    (unless (iri-p (object construct))
722      (let* ((occs-by-type
723              (remove-null
724               (map 'list #'(lambda(typed-construct)
725                              (when (typep typed-construct 'OccurrenceC)
726                                typed-construct))
727                    (used-as-type (value (predicate construct))
728                                  :revision revision))))
729             (all-occs
730              (let ((literal-value (if (variable-p (object construct))
731                                       nil
732                                       (value (object construct))))
733                    (literal-datatype (literal-datatype (object construct))))
734                (remove-null
735                 (map 'list #'(lambda(occ)
736                                (filter-occ-by-value occ literal-value
737                                                     literal-datatype))
738                      occs-by-type)))))
739        (remove-null
740         (map 'list
741              #'(lambda(occ)
742                  (list :subject
743                        (when-do top (parent occ :revision revision)
744                                 (sparql-node top :revision revision))
745                        :predicate
746                        (when-do top (instance-of occ :revision revision)
747                                 (sparql-node top :revision revision))
748                        :object (charvalue occ)
749                        :literal-datatype (datatype occ)))
750              all-occs))))))
751
752
753(defgeneric filter-by-given-subject (construct &key revision)
754  (:documentation "Calls filter-characteristics and filter associations
755                   for the topic that is set as a subject of the passed triple.")
756  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
757    (declare (Integer revision))
758    (when (iri-p (subject construct))
759      (let* ((subj (value (subject construct)))
760             (pred (when (iri-p (predicate construct))
761                     (value (predicate construct)))))
762        (cond ((variable-p (object construct))
763               (append (filter-characteristics
764                        subj pred nil nil :revision revision)
765                       (filter-associations
766                        subj pred nil :revision revision)))
767              ((literal-p (object construct))
768               (filter-characteristics
769                subj pred (value (object construct))
770                (literal-datatype (object construct)) :revision revision))
771              ((iri-p (object construct))
772               (filter-associations subj pred (value (object construct))
773                                    :revision revision)))))))
774
775
776(defgeneric literal-p (construct)
777  (:documentation "Returns t if the passed construct has an elem-type
778                   set to 'LITERAL.")
779  (:method ((construct SPARQL-Triple-Elem))
780    (eql (elem-type construct) 'LITERAL)))
781
782
783(defgeneric iri-p (construct)
784  (:documentation "Returns t if the passed construct has an elem-type
785                   set to 'IRI.")
786  (:method ((construct SPARQL-Triple-Elem))
787    (eql (elem-type construct) 'IRI)))
788
789
790(defgeneric variable-p (construct)
791  (:documentation "Returns t if the passed construct has an elem-type
792                   set to 'VARIABLE.")
793  (:method ((construct SPARQL-Triple-Elem))
794    (eql (elem-type construct) 'VARIABLE)))
795
796
797(defgeneric iri-not-found-p (construct)
798  (:documentation "Must be called after a call of set-tm-constructs.
799                   It returns t if a TM-construct was not found for a
800                   given IRI, so the result value of a query is nil.")
801  (:method ((construct SPARQL-Triple))
802    (or (iri-not-found-p (subject construct))
803        (iri-not-found-p (predicate construct))
804        (iri-not-found-p (object construct)))))
805
806
807(defmethod iri-not-found-p ((construct SPARQL-Triple-Elem))
808  (and (eql (elem-type construct) 'IRI)
809       (not (value construct))))
810
811
812(defgeneric set-tm-constructs (construct &key revision)
813  (:documentation "Calls the method set-tm-construct for every element
814                   in a SPARQL-Triple object.")
815  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
816    (when-do subj (subject construct)
817             (set-tm-construct subj :revision revision))
818    (when-do pred (predicate construct)
819             (set-tm-construct pred :revision revision))
820    (when-do obj (object construct) (set-tm-construct obj :revision revision))))
821
822
823(defgeneric set-tm-construct (construct &key revision)
824  (:documentation "Replaces the IRI in the given object by the corresponding
825                   TM-construct.")
826  (:method ((construct SPARQL-Triple-Elem) &key (revision *TM-REVISION*))
827    (declare (Integer revision))
828    (when (eql (elem-type construct) 'IRI)
829      (setf (value construct)
830            (get-item-by-any-id (value construct) :revision revision)))))
831
832
833(defun literal= (value-1 value-2)
834  "Returns t if both arguments are equal. The equality function is searched in
835   the table *equal-operators*."
836  (when (or (and (numberp value-1) (numberp value-2))
837            (typep value-1 (type-of value-2))
838            (typep value-2 (type-of value-1)))
839    (let ((operator (get-equal-operator value-1)))
840      (funcall operator value-1 value-2))))
841
842
843(defun filter-datatypable-by-value (construct literal-value literal-datatype)
844  "A helper that compares the datatypable's charvalue with the passed
845   literal value."
846  (declare (d::DatatypableC construct)
847           (type (or Null String) literal-value literal-datatype))
848  (when (or (not literal-datatype)
849            (string= (datatype construct) literal-datatype))
850    (if (not literal-value)
851        construct
852        (handler-case
853            (let ((occ-value (cast-literal (charvalue construct)
854                                           (datatype construct))))
855              (when (literal= occ-value literal-value)
856                construct))
857          (condition () nil)))))             
858
859
860(defun filter-variant-by-value (variant literal-value literal-datatype)
861  "A helper that compares the occurrence's variant's with the passed
862   literal value."
863  (declare (VariantC variant)
864           (type (or Null String) literal-value literal-datatype))
865  (filter-datatypable-by-value variant literal-value literal-datatype))
866
867
868(defun filter-occ-by-value (occurrence literal-value literal-datatype)
869  "A helper that compares the occurrence's charvalue with the passed
870   literal value."
871  (declare (OccurrenceC occurrence)
872           (type (or Null String) literal-value literal-datatype))
873  (filter-datatypable-by-value occurrence literal-value literal-datatype))
874     
875
876(defgeneric filter-occurrences(construct type-top literal-value
877                                         literal-datatype &key revision)
878  (:documentation "Returns a list representing a triple.")
879  (:method ((construct TopicC) type-top literal-value literal-datatype
880            &key (revision *TM-REVISION*))
881    (declare (Integer revision)
882             (type (or Null String) literal-value literal-datatype)
883             (type (or Null TopicC) type-top))
884    (let* ((occs-by-type
885            (if type-top
886                (occurrences-by-type construct type-top :revision revision)
887                (occurrences construct :revision revision)))
888           (all-occs
889            (remove-null
890             (map 'list
891                  #'(lambda(occ)
892                      (filter-occ-by-value occ literal-value literal-datatype))
893                  occs-by-type)))
894           (subj-uri (sparql-node construct :revision revision)))
895      (remove-null
896       (map 'list #'(lambda(occ)
897                      (list :subject subj-uri
898                            :predicate
899                            (when-do type-top
900                                     (instance-of occ :revision revision)
901                                     (sparql-node type-top :revision revision))
902                            :object (charvalue occ)
903                            :literal-datatype (datatype occ)))
904            all-occs)))))
905
906
907(defgeneric filter-names(construct type-top literal-value
908                                   &key revision)
909  (:documentation "Returns a list representing a triple.")
910  (:method ((construct TopicC) type-top literal-value
911            &key (revision *TM-REVISION*))
912    (declare (Integer revision)
913             (type (or Null String) literal-value)
914             (type (or Null TopicC) type-top))
915    (let* ((by-type
916            (if type-top
917                (names-by-type construct type-top :revision revision)
918                (names construct :revision revision)))
919           (by-literal (if literal-value
920                           (names-by-value
921                            construct #'(lambda(name)
922                                          (string= name literal-value))
923                            :revision revision)
924                           (names construct :revision revision)))
925           (all-names (intersection by-type by-literal))
926           (subj-uri (sparql-node construct :revision revision)))
927      (remove-null
928       (map 'list #'(lambda(name)
929                      (list :subject subj-uri
930                            :predicate
931                            (when-do type-top (instance-of name :revision revision)
932                                     (sparql-node type-top :revision revision))
933                            :object (charvalue name)
934                            :literal-datatype *xml-string*))
935            all-names)))))
936
937
938(defgeneric filter-characteristics (construct type-top literal-value
939                                              literal-datatype &key revision)
940  (:documentation "Returns a list representing a triple.")
941  (:method ((construct TopicC) type-top literal-value literal-datatype
942            &key (revision *TM-REVISION*))
943    (declare (Integer revision)
944             (type (or Null String) literal-value literal-datatype)
945             (type (or Null TopicC) type-top))
946    (let ((occs (filter-occurrences construct type-top literal-value
947                                    literal-datatype :revision revision))
948          (names (if (or (not literal-datatype)
949                         (string= literal-datatype *xml-string*))
950                     (filter-names construct type-top literal-value
951                                   :revision revision)
952                     nil)))
953      (append occs names))))
954
955
956(defgeneric filter-associations(construct type-top player-top
957                                          &key revision)
958  (:documentation "Returns a list of the form (:predicate <uri>
959                   :object <uri> :subject <uri>).
960                   predicate is the type of the otherrole and
961                   object is the uri of the otherplayer.")
962  (:method ((construct TopicC) type-top player-top
963            &key (revision *TM-REVISION*))
964    (declare (Integer revision)
965             (type (or Null TopicC) type-top player-top))
966    (let ((assocs
967           (associations-of construct nil nil type-top player-top
968                            :revision revision))
969          (subj-uri (sparql-node construct :revision revision)))
970      (remove-null ;only assocs with two roles can match!
971       (map 'list
972            #'(lambda(assoc)
973                (when (= (length (roles assoc :revision revision)) 2)
974                  (let* ((other-role
975                          (find-if #'(lambda(role)
976                                       (and
977                                        (not (eql construct
978                                                  (player role :revision revision)))
979                                        (or (not type-top)
980                                            (eql type-top
981                                                 (instance-of
982                                                  role :revision revision)))))
983                                   (roles assoc :revision revision)))
984                         (pred-uri
985                          (when other-role
986                            (when-do
987                             type-top (instance-of other-role
988                                                   :revision revision)
989                             (sparql-node type-top :revision revision))))
990                         
991                         (obj-uri
992                          (when other-role
993                            (when-do player-top (player other-role
994                                                        :revision revision)
995                                     (sparql-node player-top :revision revision)))))
996                    (list :subject subj-uri
997                          :predicate pred-uri
998                          :object obj-uri))))
999            assocs)))))
1000
1001
1002(defgeneric result (construct)
1003  (:documentation "Returns the result of the entire query.")
1004  (:method ((construct SPARQL-Query))
1005    (let* ((response-variables
1006            (reverse (if (*-p construct)
1007                         (all-variables construct)
1008                         (variables construct))))
1009           (cleaned-results (make-result-lists construct)))
1010      (map 'list #'(lambda(response-variable)
1011                     (list :variable response-variable
1012                           :result (variable-intersection response-variable
1013                                                          cleaned-results)))
1014           response-variables))))
1015
1016
1017(defgeneric make-result-lists (construct)
1018  (:documentation "Returns a list of the form ((:variable 'var-name'
1019                   :result (<any-object>)).")
1020  (:method ((construct SPARQL-Query))
1021    (remove-null
1022     (loop for triple in (select-group construct)
1023        append (remove-null
1024                (list
1025                 (when (variable-p (subject triple))
1026                   (list :variable (value (subject triple))
1027                         :result (subject-result triple)))
1028                 (when (variable-p (predicate triple))
1029                   (list :variable (value (predicate triple))
1030                          :result (predicate-result triple)))
1031                 (when (variable-p (object triple))
1032                   (list :variable (value (object triple))
1033                         :result (object-result triple)))))))))
1034
1035
1036(defgeneric all-variables (result-lists)
1037  (:documentation "Returns a list of all variables that are contained in
1038                   the passed result-lists."))
1039
1040
1041(defmethod all-variables ((result-lists List))
1042  (remove-duplicates
1043   (map 'list #'(lambda(entry)
1044                  (getf entry :variable))
1045        result-lists)
1046   :test #'string=))
1047
1048
1049(defmethod all-variables ((construct SPARQL-Query))
1050  "Returns all variables that are contained in the select group memebers."
1051  (remove-duplicates
1052   (remove-null
1053    (loop for triple in (select-group construct)
1054       append (variables triple)))
1055   :test #'string=))
1056
1057
1058(defgeneric variable-intersection (variable-name result-lists)
1059  (:documentation "Returns a list with all results of the passed variable
1060                   that are contained in the result-lists. All results is
1061                   an intersection of all paratial results.")
1062  (:method ((variable-name String) (result-lists List))
1063    (let* ((all-values (results-for-variable variable-name result-lists))
1064           (list-1 (when (>= (length all-values) 1)
1065                     (first all-values)))
1066           (list-2 (if (> (length all-values) 2)
1067                       (second all-values)
1068                       list-1))
1069           (more-lists (rest (rest all-values))))
1070      (recursive-intersection list-1 list-2 more-lists))))
1071
1072
1073(defun recursive-intersection (list-1 list-2 more-lists)
1074  "Returns an intersection of al the passed lists."
1075  (declare (List list-1 list-2))
1076  (let ((current-result
1077         (intersection list-1 list-2
1078                       :test #'(lambda(val-1 val-2)
1079                                 (if (and (stringp val-1) (stringp val-2))
1080                                     (string= val-1 val-2)
1081                                     (eql val-1 val-2))))))
1082    (if (not more-lists)
1083        current-result
1084        (recursive-intersection current-result (first more-lists)
1085                                (rest more-lists)))))
1086
1087
1088(defgeneric reduce-results(construct result-lists)
1089  (:documentation "Reduces the select-group of the passed construct by processing
1090                   all triples with the intersection-results.")
1091  (:method ((construct SPARQL-Query) (result-lists List))
1092    (map 'list #'(lambda(triple)
1093                   (reduce-triple triple result-lists))
1094         (select-group construct))))
1095
1096
1097(defgeneric reduce-triple(construct result-lists)
1098  (:documentation "Reduces the results of a triple by using only the
1099                   intersection values.")
1100  (:method ((construct SPARQL-Triple) (result-lists List))
1101    (let* ((triple-variables (variables construct))
1102           (intersections
1103            (map 'list #'(lambda(var)
1104                           (list :variable var
1105                                 :result (variable-intersection
1106                                          var result-lists)))
1107                 triple-variables)))
1108      (map 'list #'(lambda(entry)
1109                     (delete-rows construct (getf entry :variable)
1110                                  (getf entry :result)))
1111           intersections))))
1112
1113
1114(defgeneric delete-rows (construct variable-name dont-touch-values)
1115  (:documentation "Checks all results of the passed variable of the given
1116                   construct and deletes every result with the corresponding
1117                   row that is not contained in the dont-touch-values.")
1118  (:method ((construct SPARQL-Triple) (variable-name String)
1119            (dont-touch-values List))
1120    (let ((var-elem
1121           (cond ((and (variable-p (subject construct))
1122                       (string= (value (subject construct)) variable-name))
1123                  (subject-result construct))
1124                 ((and (variable-p (predicate construct))
1125                       (string= (value (predicate construct)) variable-name))
1126                  (predicate-result construct))
1127                 ((and (variable-p (object construct))
1128                       (string= (value (object construct)) variable-name))
1129                  (object-result construct)))))
1130      (when var-elem
1131        (let* ((rows-to-hold
1132                (remove-null
1133                 (map 'list #'(lambda(res)
1134                                (when (cond
1135                                        ((stringp res)
1136                                         (find res dont-touch-values :test #'string=))
1137                                        ((numberp res)
1138                                         (find res dont-touch-values :test #'=))
1139                                        (t
1140                                         (find res dont-touch-values)))
1141                                  (position res var-elem)))
1142                      var-elem)))
1143               (new-result-list
1144                (map 'list
1145                     #'(lambda(row-idx)
1146                         (list :subject (elt (subject-result construct) row-idx)
1147                               :predicate (elt (predicate-result construct) row-idx)
1148                               :object (elt (object-result construct) row-idx)))
1149                     rows-to-hold)))
1150          (setf (subject-result construct)
1151                (map 'list #'(lambda(entry)
1152                               (getf entry :subject)) new-result-list))
1153          (setf (predicate-result construct)
1154                (map 'list #'(lambda(entry)
1155                               (getf entry :predicate)) new-result-list))
1156          (setf (object-result construct)
1157                (map 'list #'(lambda(entry)
1158                               (getf entry :object)) new-result-list)))))))
1159
1160
1161(defgeneric results-for-variable (variable-name result-lists)
1162  (:documentation "Returns a list with result-lists for the passed variable.")
1163  (:method ((variable-name String) (result-lists List))
1164    (let* ((cleaned-result-lists
1165            (remove-if-not #'(lambda(entry)
1166                               (string= (getf entry :variable)
1167                                        variable-name))
1168                           result-lists))
1169           (values
1170            (map 'list #'(lambda(entry)
1171                           (getf entry :result))
1172                 cleaned-result-lists)))
1173      values)))
1174
1175
1176(defun cast-literal (literal-value literal-type)
1177  "A helper function that casts the passed string value of the literal
1178   corresponding to the passed literal-type."
1179  (declare (String literal-value literal-type))
1180  (cond ((string= literal-type *xml-string*)
1181         literal-value)
1182        ((string= literal-type *xml-boolean*)
1183         (when (and (string/= literal-value "false")
1184                    (string/= literal-value "true"))
1185           (error (make-condition
1186                   'sparql-parser-error
1187                   :message (format nil "Could not cast from ~a to ~a"
1188                                    literal-value literal-type))))
1189         (if (string= literal-value "false")
1190             nil
1191             t))
1192        ((string= literal-type *xml-integer*)
1193         (handler-case (parse-integer literal-value)
1194           (condition ()
1195             (error (make-condition
1196                   'sparql-parser-error
1197                   :message (format nil "Could not cast from ~a to ~a"
1198                                    literal-value literal-type))))))
1199        ((or (string= literal-type *xml-decimal*) ;;both types are
1200             (string= literal-type *xml-double*)) ;;handled the same way
1201         (let ((value (read-from-string literal-value)))
1202           (unless (numberp value)
1203             (error (make-condition
1204                   'sparql-parser-error
1205                   :message (format nil "Could not cast from ~a to ~a"
1206                                    literal-value literal-type))))
1207           value))
1208        (t ; return the value as a string
1209         literal-value)))
1210
1211
1212(defmethod initialize-instance :after ((construct SPARQL-Query) &rest args)
1213  (declare (ignorable args))
1214  (parser-start construct (original-query construct))
1215  (dolist (triple (select-group construct))
1216    (set-results triple :revision (revision construct)))
1217  ;; filters all entries that are not important for the result
1218  ;; => an intersection is invoked
1219  (reduce-results construct (make-result-lists construct))
1220  (process-filters construct)
1221  construct)
Note: See TracBrowser for help on using the repository browser.