[isidorus-cvs] r399 - in trunk/src: TM-SPARQL model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Apr 1 11:22:42 UTC 2011
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))
More information about the Isidorus-cvs
mailing list