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