isidorus-cvs

Download

isidorus-cvs@common-lisp.net

April 2011

1 participants
32 discussions

[isidorus-cvs] r399 - in trunk/src: TM-SPARQL model unit_tests
by Lukas Giessmann 01 Apr '11

01 Apr '11

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))

1 0

[isidorus-cvs] r398 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 01 Apr '11

01 Apr '11

Author: lgiessmann Date: Fri Apr 1 06:04:00 2011 New Revision: 398 Log: TM-SPARQL: finished unit-tests for the special predicates rdf:type, a, and tmdm:type => fixed a problem with rdf:type Modified: trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Fri Apr 1 06:04:00 2011 @@ -144,7 +144,14 @@ :elem-type 'IRI :value *type-psi*))) ((string-starts-with trimmed-str "<") - (parse-base-suffix-pair construct trimmed-str)) + (let ((result (parse-base-suffix-pair construct trimmed-str))) + (if (and (not (variable-p (getf result :value))) + (string= (value (getf result :value)) *rdf-type*)) + (list :next-query (getf result :next-query) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value *type-psi*)) + result))) ((or (string-starts-with trimmed-str "?") (string-starts-with trimmed-str "$")) (let ((result @@ -166,8 +173,14 @@ trimmed-str (original-query construct) "an IRI of the form prefix:suffix or <iri> but found a literal."))) (parse-literal-elem construct trimmed-str)) - (parse-prefix-suffix-pair construct trimmed-str))))))) - + (let ((result (parse-prefix-suffix-pair construct trimmed-str))) + (if (and (not (variable-p (getf result :value))) + (string= (value (getf result :value)) *rdf-type*)) + (list :next-query (getf result :next-query) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value *type-psi*)) + result)))))))) (defgeneric parse-literal-elem (construct query-string) (:documentation "A helper-function that returns a literal vaue of the form @@ -338,7 +351,7 @@ (:method ((construct SPARQL-Query) (query-string String)) (let* ((trimmed-str (cut-comment query-string)) (delimiters (list "." ";" "}" "<" " " (string #\newline) - (string #\tab) "#")) + (string #\tab))) ; "#")) (end-pos (search-first delimiters trimmed-str)) (elem-str (when end-pos (subseq trimmed-str 0 end-pos))) 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 06:04:00 2011 @@ -1635,7 +1635,7 @@ "SELECT * WHERE { ?subj1 <http://some.where/tmsparql/first-name> \"Johann Wolfgang\". ?subj2 <http://some.where/tmsparql/last-name> 'von Goethe'^^" - *xml-string* ". + *xml-string* ". ?subj3 <http://some.where/tmsparql/date-of-birth> '28.08.1749'^^" *xml-date* ". ?subj4 <http://some.where/tmsparql/date-of-death> '22.03.1832'^^" @@ -1683,5 +1683,31 @@ (is-true (d:get-item-by-psi *rdf-type* :revision 0)))) +(test test-all-2 + "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 pref:<http://www.w3.org/1999/02/> + SELECT * WHERE { + ?subj1 a <http://some.where/tmsparql/author> . + ?subj2 <http://www.w3.org/1999/02/22-rdf-syntax-ns#type> <http://some.where/tmsparql/author> . + ?subj3 <http://psi.topicmaps.org/iso13250/model/type> <http://some.where/tmsparql/author> . + ?subj4 pref:22-rdf-syntax-ns#type <http://some.where/tmsparql/author>" + "}")) + (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) + (is-true (= (length r-1) 4)) + (map 'list #'(lambda(item) + (cond ((or (string= (getf item :variable) "subj1") + (string= (getf item :variable) "subj2") + (string= (getf item :variable) "subj3") + (string= (getf item :variable) "subj4")) + (is (string= (first (getf item :result)) + "<http://some.where/tmsparql/author/goethe>"))) + (t + (is-true (format t "bad variable-name found"))))) + r-1)))) + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0