Author: lgiessmann Date: Fri Apr 1 07:22:42 2011 New Revision: 399
Log: TM-SPARQL: finished the unit-tests for the special predicate tms:reifier; fixed a problem with 2-dim. lists; fixed a bug in get-item-by-content; added get-most-recent-version to CharacteristicC, PointerC, and RoleC
Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_special_uris.lisp trunk/src/model/datamodel.lisp trunk/src/unit_tests/sparql_test.lisp
Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Fri Apr 1 07:22:42 2011 @@ -769,14 +769,16 @@ (pred (when (iri-p (predicate construct)) (value (predicate construct))))) (cond ((variable-p (object construct)) - (append (filter-characteristics - subj pred nil nil :revision revision) - (filter-associations - subj pred nil :revision revision))) + (when (typep subj 'TopicC) + (append (filter-characteristics + subj pred nil nil :revision revision) + (filter-associations + subj pred nil :revision revision)))) ((literal-p (object construct)) - (filter-characteristics - subj pred (value (object construct)) - (literal-datatype (object construct)) :revision revision)) + (when (typep subj 'TopicC) + (filter-characteristics + subj pred (value (object construct)) + (literal-datatype (object construct)) :revision revision))) ((iri-p (object construct)) (filter-associations subj pred (value (object construct)) :revision revision)))))))
Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_special_uris.lisp (original) +++ trunk/src/TM-SPARQL/sparql_special_uris.lisp Fri Apr 1 07:22:42 2011 @@ -114,16 +114,19 @@ (let ((player-top (player (value subj) :revision revision))) (when player-top - (list :subject subj-uri - :predicate pred-uri - :object (sparql-node player-top :revision revision))))) + (list + (list + :subject subj-uri + :predicate pred-uri + :object (sparql-node player-top :revision revision)))))) ((not (variable-p obj)) (let ((parent-roles (player-in-roles (value obj) :revision revision))) (loop for role in parent-roles - collect (list :subject (sparql-node role :revision revision) - :predicate pred-uri - :object (sparql-node (player role :revision revision) + collect (list + :subject (sparql-node role :revision revision) + :predicate pred-uri + :object (sparql-node (player role :revision revision) :revision revision))))) (t ; only pred is given (let ((all-roles @@ -163,9 +166,10 @@ ((not (variable-p obj)) (let ((parent-assoc (parent (value obj) :revision revision))) (when revision - (list :subject (sparql-node parent-assoc :revision revision) - :predicate pred-uri - :object obj-uri)))) + (list + (list :subject (sparql-node parent-assoc :revision revision) + :predicate pred-uri + :object obj-uri))))) (t ; only pred is given (let ((assocs (remove-null @@ -211,9 +215,10 @@ ((not (variable-p obj)) (let ((parent-top (parent (value obj) :revision revision))) (when revision - (list :subject (sparql-node parent-top :revision revision) - :predicate pred-uri - :object obj-uri)))) + (list + (list :subject (sparql-node parent-top :revision revision) + :predicate pred-uri + :object obj-uri))))) (t ; only pred is given (let ((topics (remove-null @@ -353,9 +358,10 @@ (let ((reifier-top (reifier (value subj) :revision revision))) (when reifier-top - (list :subject subj-uri - :predicate pred-uri - :object (sparql-node reifier-top :revision revision))))) + (list + (list :subject subj-uri + :predicate pred-uri + :object (sparql-node reifier-top :revision revision)))))) ((not (variable-p obj)) (let ((reified-cons (reified-construct (value obj) :revision revision)))
Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Apr 1 07:22:42 2011 @@ -749,10 +749,13 @@ (typep inst class-symbol)) db-instances))) (if revision - (remove-if #'null - (map 'list #'(lambda(inst) - (find-item-by-revision inst revision)) - filtered-instances)) + (remove-null + (map 'list #'(lambda(inst) + (if (typep inst 'CHaracteristicC) + (find-item-by-revision inst revision + (parent inst :revision revision)) + (find-item-by-revision inst revision))) + filtered-instances)) filtered-instances))))
@@ -809,15 +812,17 @@
(defun get-item-by-content (content &key (revision *TM-REVISION*)) "Finds characteristics by their (atomic) content." - (flet - ((get-existing-instances (class-symbol) - (delete-if-not - #'(lambda (constr) - (find-item-by-revision constr revision)) - (elephant:get-instances-by-value class-symbol 'charvalue content)))) - (nconc (get-existing-instances 'OccurenceC) - (get-existing-instances 'NameC) - (get-existing-instances 'VariantC)))) + (let ((constructs + (nconc (elephant:get-instances-by-value 'NameC 'Charvalue content) + (elephant:get-instances-by-value 'OccurrenceC 'Charvalue content) + (elephant:get-instances-by-value 'VariantC 'Charvalue content)))) + (first + (remove-if + #'(lambda(construct) + (or (string/= (charvalue construct) content) + (not (find-item-by-revision construct revision + (parent construct :revision revision))))) + constructs))))
(defmacro with-revision (revision &rest body) @@ -1154,6 +1159,24 @@ construct)))
+(defmethod find-most-recent-revision ((construct CharacteristicC)) + (loop for c-assoc in (slot-p construct 'parent) + when (find-most-recent-revision c-assoc) + return construct)) + + +(defmethod find-most-recent-revision ((construct PointerC)) + (loop for p-assoc in (slot-p construct 'identified-construct) + when (find-most-recent-revision p-assoc) + return construct)) + + +(defmethod find-most-recent-revision ((construct RoleC)) + (loop for r-assoc in (slot-p construct 'parent) + when (find-most-recent-revision r-assoc) + return construct)) + + (defun add-version-info(construct start-revision) "Adds 'construct' to the given version. If the construct is a VersionedConstructC add-to-version-history
Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Fri Apr 1 07:22:42 2011 @@ -1709,5 +1709,48 @@ r-1))))
+(test test-all-3 + "Tests the entire module with the file sparql_test.xtm" + (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) + (tm-sparql:init-tm-sparql) + (let* ((q-1 (concat + "PREFIX tms:http://www.networkedplanet.com/tmsparql/ + SELECT * WHERE { + http://some.where/ii/goethe-occ tms:reifier ?obj1. + ?subj1 tms:reifier http://some.where/ii/goethe-name-reifier" + "}")) + (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) + (is-true (= (length r-1) 2)) + (map 'list #'(lambda(item) + (cond ((string= (getf item :variable) "subj1") + (is (string= + (first (getf item :result)) + (concat "_:n" + (write-to-string + (elephant::oid + (d:get-item-by-content "von Goethe"))))))) + ((string= (getf item :variable) "obj1") + (is (string= (first (getf item :result)) + "http://some.where/ii/goethe-occ-reifier"))) + (t + (is-true (format t "bad variable-name found"))))) + r-1)))) + + +(test test-all-4 + "Tests the entire module with the file sparql_test.xtm" + (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) + (tm-sparql:init-tm-sparql) + (let* ((q-1 (concat + "PREFIX tms:http://www.networkedplanet.com/tmsparql/ + SELECT * WHERE { + http://some.where/ii/goethe-occ tms:reifier ?obj1. + ?subj1 tms:reifier http://some.where/ii/goethe-name-reifier" + "}")) + (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) + (is-true (= (length r-1) 2)) + ))) + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))