[isidorus-cvs] r144 - in trunk/src: . model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Nov 20 10:41:33 UTC 2009
Author: lgiessmann
Date: Fri Nov 20 05:41:32 2009
New Revision: 144
Log:
added some unit-tests for the "reification"-functions; fixed some problems; currently there is still a problem with the versioning of constructs that existed more than one revision and were not merged at the initial version.
Added:
trunk/src/unit_tests/reification_test.lisp
Modified:
trunk/src/isidorus.asd
trunk/src/model/datamodel.lisp
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Fri Nov 20 05:41:32 2009
@@ -143,7 +143,9 @@
(:file "rdf_importer_test"
:depends-on ("fixtures"))
(:file "rdf_exporter_test"
- :depends-on ("fixtures")))
+ :depends-on ("fixtures"))
+ (:file "reification_test"
+ :depends-on ("fixtures" "unittests-constants")))
:depends-on ("atom"
"constants"
"model"
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Fri Nov 20 05:41:32 2009
@@ -621,80 +621,6 @@
(setf (slot-value construct 'reifier) topic)
(setf (reified topic) construct)))
-(defgeneric add-reifier (construct reifier-uri)
- (:method ((construct ReifiableConstructC) reifier-uri)
- (let ((err "From add-reifier(): "))
- (let ((item-identifier
- (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri)))
- (unless item-identifier
- (error "~ano item-identifier could be found with the uri ~a"
- err reifier-uri))
- (let ((reifier-topic (identified-construct item-identifier)))
- (unless (typep reifier-topic 'TopicC)
- (error "~anitem-identifier ~a must be bound to a topic, but is ~a"
- err reifier-uri (type-of reifier-topic)))
- (cond
- ((and (not (reifier construct))
- (not (reified reifier-topic)))
- (setf (reifier construct) reifier-topic)
- (setf (reified reifier-topic) construct))
- ((and (not (reified reifier-topic))
- (reifier construct))
- (merge-reifier-topics (reifier construct) reifier-topic))
- ((and (not (reifier construct))
- (reified reifier-topic))
- (error "~a~a reifies already another object ~a"
- err reifier-uri (reified reifier-topic)))
- (t
- (when (not (eql (reified reifier-topic) construct))
- (error "~a~a reifies already another object ~a"
- err reifier-uri (reified reifier-topic)))
- (merge-reifier-topics (reifier construct) reifier-topic))))))
- construct))
-
-(defgeneric merge-reifier-topics (old-topic new-topic)
- ;;the reifier topics are not only merged but also bound to the reified-construct
- (:method ((old-topic TopicC) (new-topic TopicC))
- (unless (eql old-topic new-topic)
- ;merges all identifiers
- (move-identifiers old-topic new-topic)
- (move-identifiers old-topic new-topic :what 'locators)
- (move-identifiers old-topic new-topic :what 'psis)
- (move-identifiers old-topic new-topic :what 'topic-identifiers)
- ;merges all typed-object-associations
- (dolist (typed-construct (used-as-type new-topic))
- (remove-association typed-construct 'instance-of new-topic)
- (add-association typed-construct 'instance-of old-topic))
- ;merges all scope-object-associations
- (dolist (scoped-construct (used-as-theme new-topic))
- (remove-association scoped-construct 'theme new-topic)
- (add-association scoped-construct 'theme old-topic))
- (dolist (tm (in-topicmaps new-topic))
- (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it
- (dolist (a-role (player-in-roles new-topic))
- (remove-association a-role 'player new-topic)
- (add-association a-role 'player old-topic))
- ;merges all names
- (dolist (name (names new-topic))
- (remove-association name 'topic new-topic)
- (add-association name 'topic old-topic))
- ;merges all occurrences
- (dolist (occurrence (occurrences new-topic))
- (remove-association occurrence 'topic new-topic)
- (add-association occurrence 'topic old-topic))
- ;merges all version-infos
- (let ((versions-to-move
- (loop for vrs in (versions new-topic)
- when (not (find-if #'(lambda(x)
- (and (= (start-revision x) (start-revision vrs))
- (= (end-revision x) (end-revision vrs))))
- (versions old-topic)))
- collect vrs)))
- (dolist (vrs versions-to-move)
- (remove-association vrs 'versioned-construct new-topic)
- (add-association vrs 'versioned-construct old-topic))))))
-
-
(defgeneric item-identifiers (construct &key revision)
(:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))
@@ -1654,4 +1580,83 @@
(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
(when (find-item-by-revision ass revision)
- (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id)))
\ No newline at end of file
+ (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id)))
+
+;;;;;;;;;;;;;;;;;
+;; reification
+
+(defgeneric add-reifier (construct reifier-uri)
+ (:method ((construct ReifiableConstructC) reifier-uri)
+ (let ((err "From add-reifier(): "))
+ (let ((item-identifier
+ (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri)))
+ (unless item-identifier
+ (error "~ano item-identifier could be found with the uri ~a"
+ err reifier-uri))
+ (let ((reifier-topic (identified-construct item-identifier)))
+ (unless (typep reifier-topic 'TopicC)
+ (error "~anitem-identifier ~a must be bound to a topic, but is ~a"
+ err reifier-uri (type-of reifier-topic)))
+ (cond
+ ((and (not (reifier construct))
+ (not (reified reifier-topic)))
+ (setf (reifier construct) reifier-topic))
+ ((and (not (reified reifier-topic))
+ (reifier construct))
+ (merge-reifier-topics (reifier construct) reifier-topic))
+ ((and (not (reifier construct))
+ (reified reifier-topic))
+ (error "~a~a reifies already another object ~a"
+ err reifier-uri (reified reifier-topic)))
+ (t
+ (when (not (eql (reified reifier-topic) construct))
+ (error "~a~a reifies already another object ~a"
+ err reifier-uri (reified reifier-topic)))
+ (merge-reifier-topics (reifier construct) reifier-topic))))))
+ construct))
+
+(defgeneric merge-reifier-topics (old-topic new-topic)
+ ;;the reifier topics are not only merged but also bound to the reified-construct
+ (:method ((old-topic TopicC) (new-topic TopicC))
+ (unless (eql old-topic new-topic)
+ ;merges all identifiers
+ (move-identifiers old-topic new-topic)
+ (move-identifiers old-topic new-topic :what 'locators)
+ (move-identifiers old-topic new-topic :what 'psis)
+ (move-identifiers old-topic new-topic :what 'topic-identifiers)
+ ;merges all typed-object-associations
+ (dolist (typed-construct (used-as-type new-topic))
+ (remove-association typed-construct 'instance-of new-topic)
+ (add-association typed-construct 'instance-of old-topic))
+ ;merges all scope-object-associations
+ (dolist (scoped-construct (used-as-theme new-topic))
+ (remove-association scoped-construct 'themes new-topic)
+ (add-association scoped-construct 'themes old-topic))
+ (dolist (tm (in-topicmaps new-topic))
+ (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it
+ (dolist (a-role (player-in-roles new-topic))
+ (remove-association a-role 'player new-topic)
+ (add-association a-role 'player old-topic))
+ ;merges all names
+ (dolist (name (names new-topic))
+ (remove-association name 'topic new-topic)
+ (add-association name 'topic old-topic))
+ ;merges all occurrences
+ (dolist (occurrence (occurrences new-topic))
+ (remove-association occurrence 'topic new-topic)
+ (add-association occurrence 'topic old-topic))
+ ;merges all version-infos
+ (let ((versions-to-move
+ (loop for vrs in (versions new-topic)
+ when (not (find-if #'(lambda(x)
+ (and (= (start-revision x) (start-revision vrs))
+ (= (end-revision x) (end-revision vrs))))
+ (versions old-topic)))
+ collect vrs)))
+ (dolist (vrs versions-to-move)
+ (remove-association vrs 'versioned-construct new-topic)
+ (add-association vrs 'versioned-construct old-topic)))
+ (delete-construct new-topic))
+ ;TODO: order/repair all version-infos of the topic itself and add all new
+ ; versions to the original existing objects of the topic
+ old-topic))
\ No newline at end of file
Added: trunk/src/unit_tests/reification_test.lisp
==============================================================================
--- (empty file)
+++ trunk/src/unit_tests/reification_test.lisp Fri Nov 20 05:41:32 2009
@@ -0,0 +1,178 @@
+;;+-----------------------------------------------------------------------------
+;;+ Isidorus
+;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
+;;+
+;;+ Isidorus is freely distributable under the LGPL license.
+;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+
+(defpackage :reification-test
+ (:use
+ :common-lisp
+ :datamodel
+ :it.bese.FiveAM
+ :unittests-constants
+ :fixtures)
+ (:export
+ :reification-test
+ :run-reification-tests
+ :test-merge-reifier-topics))
+
+
+(in-package :reification-test)
+
+
+(def-suite reification-test
+ :description "tests various functions of the reification functions")
+
+(in-suite reification-test)
+
+
+(test test-merge-reifier-topics
+ "Tests the function merge-reifier-topics."
+ (let ((db-dir "data_base")
+ (revision-1 100)
+ (revision-2 200))
+ (clean-out-db db-dir)
+ (elephant:open-store (xml-importer:get-store-spec db-dir))
+ (let ((ii-1-1 (make-instance 'ItemIdentifierC
+ :uri "ii-1-1"
+ :start-revision revision-1))
+ (ii-1-2 (make-instance 'ItemIdentifierC
+ :uri "ii-1-2"
+ :start-revision revision-1))
+ (ii-2-1 (make-instance 'ItemIdentifierC
+ :uri "ii-2-1"
+ :start-revision revision-2))
+ (ii-2-2 (make-instance 'ItemIdentifierC
+ :uri "ii-2-2"
+ :start-revision revision-2))
+ (psi-1-1 (make-instance 'PersistentIdC
+ :uri "psi-1-1"
+ :start-revision revision-1))
+ (psi-1-2 (make-instance 'PersistentIdC
+ :uri "psi-1-2"
+ :start-revision revision-1))
+ (locator-2-1 (make-instance 'SubjectLocatorC
+ :uri "locator-2-1"
+ :start-revision revision-2))
+ (xtm-id-1 "xtm-id-1")
+ (xtm-id-2 "xtm-id-2")
+ (topic-id-1 "topic-id-1")
+ (topic-id-2 "topic-id-1")) ;should no be merged, since the xtm-id differs
+ (let ((topic-1 (make-construct 'TopicC
+ :item-identifiers (list ii-1-1 ii-1-2)
+ :locators nil
+ :psis (list psi-1-1 psi-1-2)
+ :topicid topic-id-1
+ :xtm-id xtm-id-1
+ :start-revision revision-1))
+ (topic-2 (make-construct 'TopicC
+ :item-identifiers (list ii-2-1 ii-2-2)
+ :locators (list locator-2-1)
+ :psis nil
+ :topicid topic-id-2
+ :xtm-id xtm-id-2
+ :start-revision revision-2))
+ (scope-1 (make-construct 'TopicC
+ :psis (list (make-instance 'PersistentIdC
+ :uri "psi-scope-1"
+ :start-revision revision-1))
+ :topicid "scope-1"
+ :xtm-id xtm-id-1
+ :start-revision revision-1))
+ (scope-2 (make-construct 'TopicC
+ :psis (list (make-instance 'PersistentIdC
+ :uri "psi-scope-2"
+ :start-revision revision-1))
+ :topicid "scope-2"
+ :xtm-id xtm-id-1
+ :start-revision revision-1))
+ (name-type (make-construct 'TopicC
+ :psis (list (make-instance 'PersistentIdC
+ :uri "psi-name-type"
+ :start-revision revision-1))
+ :topicid "name-type"
+ :xtm-id xtm-id-1
+ :start-revision revision-1))
+ (occurrence-type (make-construct 'TopicC
+ :psis (list (make-instance 'PersistentIdC
+ :uri "psi-occurrence-type"
+ :start-revision revision-1))
+ :topicid "occurrence-type"
+ :xtm-id xtm-id-1
+ :start-revision revision-1)))
+ (let ((name-1-1 (make-construct 'NameC
+ :item-identifiers nil
+ :topic topic-1
+ :themes (list scope-1)
+ :instance-of name-type
+ :charvalue "name-1-1"
+ :start-revision revision-1))
+ (name-2-1 (make-construct 'NameC
+ :item-identifiers (list (make-instance 'ItemIdentifierC
+ :uri "name-2-1-ii-1"
+ :start-revision revision-1))
+ :topic topic-2
+ :themes (list scope-2)
+ :instance-of nil
+ :charvalue "name-2-1"
+ :start-revision revision-2))
+ (occurrence-2-1 (make-construct 'OccurrenceC
+ :item-identifiers (list (make-instance 'ItemIdentifierC
+ :uri "occurrence-1-1-ii-1"
+ :start-revision revision-1))
+ :topic topic-2
+ :themes (list scope-1 scope-2)
+ :instance-of occurrence-type
+ :charvalue "occurrence-2-1"
+ :datatype "datatype"
+ :start-revision revision-2))
+ (occurrence-2-2 (make-construct 'OccurrenceC
+ :item-identifiers nil
+ :topic topic-2
+ :themes nil
+ :instance-of occurrence-type
+ :charvalue "occurrence-2-2"
+ :datatype "datatype"
+ :start-revision revision-2))
+ (test-name (make-construct 'NameC
+ :item-identifiers nil
+ :topic scope-2
+ :themes (list scope-1 topic-2)
+ :instance-of topic-2
+ :charvalue "test-name"
+ :start-revision revision-2)))
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 6))
+ (datamodel::merge-reifier-topics topic-1 topic-2)
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 5))
+ (is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2)
+ (item-identifiers topic-1)))
+ (length (list ii-1-1 ii-1-2 ii-2-1 ii-2-2))))
+ (is (= (length (union (list psi-1-1 psi-1-2)
+ (psis topic-1)))
+ (length (list psi-1-1 psi-1-2))))
+ (is (= (length (union (list locator-2-1)
+ (locators topic-1)))
+ (length (list locator-2-1))))
+ (is (= (length (union (names topic-1)
+ (list name-1-1 name-2-1)))
+ (length (list name-1-1 name-2-1))))
+ (is (= (length (union (occurrences topic-1)
+ (list occurrence-2-1 occurrence-2-2)))
+ (length (list occurrence-2-1 occurrence-2-2))))
+ (is (= (length (union (d:used-as-type topic-1)
+ (list test-name)))
+ (length (list test-name))))
+ (is (= (length (union (d:used-as-theme topic-1)
+ (list test-name)))
+ (length (list test-name))))
+ ;;TODO: roleplayer, topicmap
+ ;;TODO: check all objects and their version-infos
+ (elephant:close-store))))))
+
+
+(defun run-reification-tests ()
+ (it.bese.fiveam:run! 'test-merge-reifier-topics)
+ )
\ No newline at end of file
More information about the Isidorus-cvs
mailing list