[isidorus-cvs] r286 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Apr 23 18:47:37 UTC 2010
Author: lgiessmann
Date: Fri Apr 23 14:47:37 2010
New Revision: 286
Log:
new-datamodel: fixed an elephant bug that appears in the current version --> "get-instances-by-class" is embraced within a function that filters all instances by typep and optional a given revision; fixed a potential versioning bug in "merge-all-constructs"; fixed a bug in "equivalent-construct" --> AssociationC; fixed a bug in "merge-changed-constructs"; fixed a bug in "merge-constructs" --> the returned association object is added to the union of all tms the given associations were present in; added some unit-tests
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Fri Apr 23 14:47:37 2010
@@ -148,6 +148,9 @@
:check-for-duplicate-identifiers
:find-item-by-content
:rec-remf
+ :get-all-topics
+ :get-all-associations
+ :get-all-tms
;;globals
:*TM-REVISION*
@@ -156,10 +159,10 @@
(in-package :datamodel)
-
-;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
-;; versioned-construct of the called construct, same for add-xy ???
-;; and associations of player
+;;TODO: replace add-<xy> + add-parent in all merge-constructs where the
+;; characteristics are readded to make sure they are added to the current
+;; version --> collidates with merge-if-equivalent!!! in merge-constructs
+;;TODO: adapt changes-lisp
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
;; and the parent's parent construct + the reifier constructs),
@@ -701,6 +704,34 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*))
+ "Returns all instances of the given type and the given revision that are
+ stored in the db."
+ (declare (symbol class-symbol) (type (or null integer) revision))
+ (let ((db-instances (elephant:get-instances-by-class class-symbol)))
+ (let ((filtered-instances (remove-if-not #'(lambda(inst)
+ (typep inst class-symbol))
+ db-instances)))
+ (if revision
+ (remove-if #'null
+ (map 'list #'(lambda(inst)
+ (find-item-by-revision inst revision))
+ filtered-instances))
+ filtered-instances))))
+
+
+(defun get-all-topics (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'TopicC :revision revision))
+
+
+(defun get-all-associations (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'AssociationC :revision revision))
+
+
+(defun get-all-tms (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'TopicMapC :revision revision))
+
+
(defun find-version-info (versioned-constructs
&key (sort-function #'<) (sort-key 'start-revision))
"Returns all version-infos sorted by the function sort-function which is
@@ -811,14 +842,15 @@
(condition () nil)))
-(defun merge-all-constructs(constructs-to-be-merged)
+(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*))
"Merges all constructs contained in the given list."
(declare (list constructs-to-be-merged))
(let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
(merged-construct (elt constructs-to-be-merged 0)))
(loop for construct-to-be-merged in constructs-to-be-merged
do (setf merged-construct
- (merge-constructs merged-construct construct-to-be-merged)))))
+ (merge-constructs merged-construct construct-to-be-merged
+ :revision revision)))))
(defgeneric internal-id (construct)
@@ -980,7 +1012,7 @@
;;; VersionedConstructC
-(defgeneric exist-in-revision-history-? (versioned-construct)
+(defgeneric exist-in-version-history-p (versioned-construct)
(:documentation "Returns t if the passed construct does not exist in any
revision, i.e. the construct has no version-infos or exactly
one whose start-revision is equal to its end-revision.")
@@ -1106,8 +1138,16 @@
(let
((last-version ;the last active version
(find 0 (versions construct) :key #'end-revision)))
- (when last-version
- (setf (end-revision last-version) revision))))
+ (if (and last-version
+ (= (start-revision last-version) revision))
+ (progn
+ (delete-construct last-version)
+ (let ((sorted-versions
+ (sort (versions construct) #'> :key #'end-revision)))
+ (when sorted-versions
+ (setf (end-revision (first sorted-versions)) revision))))
+ (when last-version
+ (setf (end-revision last-version) revision)))))
;;; TopicMapconstructC
@@ -2494,9 +2534,14 @@
(and (eql (instance-of construct-1 :revision revision)
(instance-of construct-2 :revision revision))
(not (set-exclusive-or (themes construct-1 :revision revision)
- (themes construct-1 :revision revision)))
- (not (set-exclusive-or (roles construct-1 :revision revision)
- (roles construct-2 :revision revision)))))
+ (themes construct-2 :revision revision)))
+
+ (not (set-exclusive-or
+ (roles construct-1 :revision revision)
+ (roles construct-2 :revision revision)
+ :test #'(lambda(role-1 role-2)
+ (strictly-equivalent-constructs role-1 role-2
+ :revision revision))))))
(defgeneric AssociationC-p (class-symbol)
@@ -2517,21 +2562,22 @@
(type (or null TopicC) instance-of))
;; item-identifiers and reifers are not checked because the equality have to
;; be variafied without them
- (let ((checked-roles
- (loop for assoc-role in (roles construct :revision start-revision)
- when (loop for plist in roles
- when (equivalent-construct
- assoc-role :player (getf plist :player)
- :start-revision (or (getf plist :start-revision)
- start-revision)
- :instance-of (getf plist :instance-of))
- return t)
- collect assoc-role)))
+ (let ((checked-roles nil))
+ (loop for plist in roles
+ do (let ((found-role
+ (find-if #'(lambda(assoc-role)
+ (equivalent-construct
+ assoc-role :player (getf plist :player)
+ :start-revision (or (getf plist :start-revision)
+ start-revision)
+ :instance-of (getf plist :instance-of)))
+ (roles construct :revision start-revision))))
+ (when found-role
+ (push found-role checked-roles))))
(and
(not (set-exclusive-or (roles construct :revision start-revision)
checked-roles))
- (= (length (roles construct :revision start-revision))
- (length roles))
+ (= (length checked-roles) (length roles))
(equivalent-typable-construct construct instance-of
:start-revision start-revision)
(equivalent-scopable-construct construct themes
@@ -3428,9 +3474,10 @@
:roles roles :themes themes
:instance-of instance-of)
existing-association))
- (elephant:get-instances-by-class 'AssociationC)))))
+ (get-all-associations nil)))))
(cond ((> (length existing-associations) 1)
- (merge-all-constructs existing-associations))
+ (merge-all-constructs existing-associations
+ :revision start-revision))
(existing-associations
(first existing-associations))
(t
@@ -3512,9 +3559,9 @@
:item-identifiers item-identifiers
:reifier reifier)
existing-tm))
- (elephant:get-instances-by-class 'TopicMapC)))))
+ (get-all-tms start-revision)))))
(cond ((> (length existing-tms) 1)
- (merge-all-constructs existing-tms))
+ (merge-all-constructs existing-tms :revision start-revision))
(existing-tms
(first existing-tms))
(t
@@ -3554,9 +3601,9 @@
:item-identifiers item-identifiers
:topic-identifiers topic-identifiers)
existing-topic))
- (elephant:get-instances-by-class 'TopicC)))))
+ (get-all-topics start-revision)))))
(cond ((> (length existing-topics) 1)
- (merge-all-constructs existing-topics))
+ (merge-all-constructs existing-topics :revision start-revision))
(existing-topics
(first existing-topics))
(t
@@ -3919,23 +3966,61 @@
(let ((parent (when (or (typep construct 'RoleC)
(typep construct 'CharacteristicC))
(parent construct :revision revision))))
- (let ((found-equivalent
- (find-if #'(lambda(other-construct)
- (strictly-equivalent-constructs
- other-construct construct :revision revision))
- (cond ((typep construct 'OccurrenceC)
- (occurrences parent :revision revision))
- ((typep construct 'NameC)
- (names parent :revision revision))
- ((typep construct 'VariantC)
- (variants parent :revision revision))
- ((typep construct 'RoleC)
- (roles parent :revision revision))
- ((typep construct 'AssociationC)
- (elephant:get-instances-by-class 'AssociationC))))))
- (when found-equivalent
- (merge-all-constructs (append found-equivalent (list construct))))))))
-
+ (let ((all-other (cond ((typep construct 'OccurrenceC)
+ (occurrences parent :revision revision))
+ ((typep construct 'NameC)
+ (names parent :revision revision))
+ ((typep construct 'VariantC)
+ (variants parent :revision revision))
+ ((typep construct 'RoleC)
+ (roles parent :revision revision)))))
+ (let ((all-equivalent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(other)
+ (when (strictly-equivalent-constructs
+ construct other :revision revision)
+ other))
+ all-other))))
+ (when all-equivalent
+ (merge-all-constructs (append all-equivalent (list construct))
+ :revision revision))))))
+ (merge-changed-associations older-topic :revision revision))
+
+
+(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*))
+ "Merges all associations that became TMDM-equal since two referenced topics
+ were merged, e.g. the association types."
+ (declare (TopicC older-topic))
+ (let ((all-assocs
+ (remove-duplicates
+ (append
+ (remove-if
+ #'null
+ (map 'list #'(lambda(role)
+ (parent role :revision revision))
+ (player-in-roles older-topic :revision revision)))
+ (remove-if
+ #'null
+ (map
+ 'list #'(lambda(constr)
+ (when (typep constr 'AssociationC)
+ constr))
+ (append (used-as-type older-topic :revision revision)
+ (used-as-theme older-topic :revision revision))))))))
+ (dolist (assoc all-assocs)
+ (let ((all-equivalent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(db-assoc)
+ (when (strictly-equivalent-constructs
+ assoc db-assoc :revision revision)
+ db-assoc))
+ (get-all-associations nil)))))
+ (when all-equivalent
+ (merge-all-constructs (append all-equivalent (list assoc))
+ :revision revision))))))
+
(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
&key (revision *TM-REVISION*))
@@ -3953,7 +4038,7 @@
(move-reified-construct newer-topic older-topic :revision revision)
(merge-changed-constructs older-topic :revision revision)
(mark-as-deleted newer-topic :revision revision :source-locator nil)
- (when (exist-in-revision-history-? newer-topic)
+ (when (exist-in-version-history-p newer-topic)
(delete-construct newer-topic))
older-topic))))
@@ -3980,7 +4065,7 @@
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-char older-char
:revision revision)
- (delete-characteristic newer-char parent-2
+ (delete-characteristic parent-2 newer-char
:revision revision)
older-char)
((and parent-1 parent-2)
@@ -4032,7 +4117,7 @@
(add-to-tm top-or-assoc top-or-assoc))
(add-to-version-history older-tm :start-revision revision)
(mark-as-deleted newer-tm :revision revision)
- (when (exist-in-revision-history-? newer-tm)
+ (when (exist-in-version-history-p newer-tm)
(delete-construct newer-tm))
older-tm))))
@@ -4053,6 +4138,8 @@
construct-1 construct-2)
:construct-1 construct-1
:construct-2 construct-2)))
+ (dolist (tm (in-topicmaps newer-assoc :revision revision))
+ (add-to-tm tm older-assoc))
(move-referenced-constructs newer-assoc older-assoc)
(dolist (newer-role (roles newer-assoc :revision revision))
(let ((equivalent-role
@@ -4065,7 +4152,7 @@
(delete-role newer-assoc newer-role :revision revision)
(add-role older-assoc equivalent-role :revision revision)))
(mark-as-deleted newer-assoc :revision revision)
- (when (exist-in-revision-history-? newer-assoc)
+ (when (exist-in-version-history-p newer-assoc)
(delete-construct newer-assoc))
older-assoc))))
@@ -4091,8 +4178,14 @@
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-role older-role
:revision revision)
- (delete-role newer-role parent-2 :revision revision)
- (add-role older-role parent-1 :revision revision))
+ (delete-role parent-2 newer-role :revision revision)
+ (let ((r-assoc
+ (find-if
+ #'(lambda(r-assoc)
+ (and (eql (role r-assoc) older-role)
+ (eql (parent-construct r-assoc) parent-1)))
+ (slot-p parent-1 'roles))))
+ (add-to-version-history r-assoc :start-revision revision)))
((and parent-1 parent-2)
(let ((active-assoc (merge-constructs parent-1 parent-2
:revision revision)))
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Fri Apr 23 14:47:37 2010
@@ -81,7 +81,12 @@
:test-find-oldest-construct
:test-move-referenced-constructs-ReifiableConstructC
:test-move-referenced-constructs-NameC
- :test-merge-constructs-TopicC-1))
+ :test-merge-constructs-TopicC-1
+ :test-merge-constructs-TopicC-2
+ :test-merge-constructs-TopicC-3
+ :test-merge-constructs-TopicC-4
+ :test-merge-constructs-TopicC-5
+ :test-merge-constructs-TopicC-6))
;;TODO: test merge-constructs
@@ -1815,7 +1820,7 @@
:start-revision rev-1))
(role-2 (list :player player-2 :instance-of r-type-2
:start-revision rev-1))
- (role-3 (list :instance-of r-type-3 :player player-3
+ (role-3 (list :player player-3 :instance-of r-type-3
:start-revision rev-1))
(type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
@@ -1877,7 +1882,7 @@
(is-false (d::strictly-equivalent-constructs assoc-1 assoc-3))
(is-false (d::strictly-equivalent-constructs assoc-1 assoc-4))
(is-false (d::strictly-equivalent-constructs assoc-1 assoc-5))
- (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))
+ (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))
(test test-equivalent-TopicC ()
@@ -3046,6 +3051,414 @@
(is-true (d::marked-as-deleted-p occ-3))))))))))
+(test test-merge-constructs-TopicC-2 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
+ (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
+ (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+ (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
+ (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1"
+ :xtm-id "xtm-1"))
+ (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2"
+ :xtm-id "xtm-2"))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (theme-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((variant-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "var-1"
+ :themes (list theme-1)))
+ (variant-2 (make-construct 'VariantC
+ :start-revision rev-2
+ :charvalue "var-2"
+ :themes (list theme-2)))
+ (variant-3 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "var-1"
+ :themes (list theme-1)))
+ (occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list theme-1)))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :charvalue "occ-2"
+ :instance-of type-2))
+ (occ-3 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :item-identifiers (list ii-3)
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list theme-1))))
+ (let ((name-1 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-1"
+ :instance-of type-1))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-2
+ :charvalue "name-2"
+ :instance-of type-1
+ :variants (list variant-1 variant-2)))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-1"
+ :instance-of type-1
+ :variants (list variant-3))))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :topic-identifiers (list tid-1)
+ :item-identifiers (list ii-1)
+ :locators (list sl-1)
+ :psis (list psi-1)
+ :names (list name-1 name-2)
+ :occurrences (list occ-1 occ-2)))
+ (top-2 (make-construct 'TopicC
+ :start-revision rev-3
+ :topic-identifiers (list tid-2)
+ :item-identifiers (list ii-2)
+ :locators (list sl-2)
+ :psis (list psi-2)
+ :names (list name-3)
+ :occurrences (list occ-3))))
+ (setf *TM-REVISION* rev-3)
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 6))
+ (is (= (length (elephant:get-instances-by-class 'NameC)) 3))
+ (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3))
+ (is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
+ (let ((top (d::merge-constructs top-1 top-2 :revision rev-3)))
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 5))
+ (is (= (length (elephant:get-instances-by-class 'NameC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
+ (is (eql top top-1))
+ (is-false (append (psis top-2) (item-identifiers top-2)
+ (locators top-2) (topic-identifiers top-2)
+ (names top-2) (occurrences top-2)))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers top-1)))
+ (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1)))
+ (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
+ (is-false (set-exclusive-or (list tid-1 tid-2)
+ (topic-identifiers top-1)))
+ (is-false (set-exclusive-or (list psi-1)
+ (psis top-1 :revision rev-2)))
+ (is-false (set-exclusive-or (list name-1 name-2)
+ (names top-1)))
+ (is-false (set-exclusive-or (variants name-1)
+ (list variant-3)))
+ (is-false (variants name-3))
+ (is-false (set-exclusive-or (occurrences top-1)
+ (list occ-1 occ-2)))
+ (is-false (set-exclusive-or (item-identifiers occ-1)
+ (list ii-3)))
+ (is-false (item-identifiers occ-3))
+ (is-true (d::marked-as-deleted-p name-3))
+ (is-true (d::marked-as-deleted-p occ-3))))))))))
+
+
+(test test-merge-constructs-TopicC-3 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (n-type (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))
+ (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5"))
+ (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6"))
+ (var-0-1
+ (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list
+ (make-construct 'TopicC
+ :start-revision rev-1))
+ :charvalue "var-0-1"))
+ (var-0-2
+ (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list
+ (make-construct 'TopicC
+ :start-revision rev-1))
+ :charvalue "var-0-1")))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-1)
+ :charvalue "occ"
+ :instance-of type-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-2)
+ :charvalue "occ"
+ :instance-of type-2))
+ (name-1 (make-construct 'NameC
+ :start-revision rev-1
+ :item-identifiers (list ii-3)
+ :variants (list var-0-1)
+ :charvalue "name"
+ :instance-of type-1))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-1
+ :item-identifiers (list ii-4)
+ :variants (list var-0-2)
+ :charvalue "name"
+ :instance-of type-2))
+ (var-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :item-identifiers (list ii-5)
+ :charvalue "var"
+ :themes (list type-1)))
+ (var-2 (make-construct 'VariantC
+ :start-revision rev-1
+ :item-identifiers (list ii-6)
+ :charvalue "var"
+ :themes (list type-2))))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :occurrences (list occ-1 occ-2)
+ :names (list name-1 name-2)))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-3"
+ :instance-of n-type
+ :variants (list var-1 var-2))))
+ (let ((top-2 (make-construct 'TopicC
+ :start-revision rev-1
+ :names (list name-3))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (occurrences top-1)) 1))
+ (is-false (set-exclusive-or
+ (list ii-1 ii-2)
+ (item-identifiers (first (occurrences top-1)))))
+ (is (= (length (slot-value top-1 'd::occurrences)) 2))
+ (is (= (length (names top-1)) 1))
+ (is-false (set-exclusive-or
+ (list ii-3 ii-4)
+ (item-identifiers (first (names top-1)))))
+ (is (= (length (slot-value top-1 'd::names)) 2))
+ (is-false (set-exclusive-or (list var-0-1 var-0-2)
+ (variants (first (names top-1)))))
+ (is-true (d::marked-as-deleted-p
+ (find-if-not #'(lambda(occ)
+ (eql occ (first (occurrences top-1))))
+ (slot-value top-1 'd::occurrences))))
+ (is-true (d::marked-as-deleted-p
+ (find-if-not #'(lambda(name)
+ (eql name (first (names top-1))))
+ (slot-value top-1 'd::names))))
+ (is (= (length (variants (first (names top-2)))) 1))
+ (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2))
+ (is (eql (first (themes (first (variants (first (names top-2))))))
+ type-1)))))))))
+
+
+(test test-merge-constructs-TopicC-4 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (a-type (make-construct 'TopicC :start-revision rev-1))
+ (r-type (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
+ (let ((assoc-1 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of a-type
+ :roles (list (list :player type-1
+ :instance-of r-type
+ :item-identifiers (list ii-1)
+ :start-revision rev-1)
+ (list :player type-2
+ :item-identifiers (list ii-2)
+ :instance-of r-type
+ :start-revision rev-1)))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (roles assoc-1)) 1))
+ (is (= (length (slot-value assoc-1 'd::roles)) 2))
+ (is (eql (instance-of (first (roles assoc-1))) r-type))
+ (is (eql (player (first (roles assoc-1))) type-1))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers (first (roles assoc-1)))))
+ (let ((active-role (first (roles assoc-1)))
+ (non-active-role
+ (let ((r-assoc (find-if-not #'(lambda(role)
+ (eql role (first (roles assoc-1))))
+ (slot-value assoc-1 'd::roles))))
+ (when r-assoc
+ (d::role r-assoc)))))
+ (is (= (length (d::versions
+ (first (slot-value active-role 'd::parent)))) 2))
+ (is (= (length (d::versions
+ (first (slot-value non-active-role 'd::parent)))) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value non-active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-3 (d::start-revision vi))
+ (= 0 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))))))))
+
+
+(test test-merge-constructs-TopicC-5 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (a-type (make-construct 'TopicC :start-revision rev-1))
+ (player-1 (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
+ (let ((assoc-2 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of a-type
+ :roles (list (list :player player-1
+ :instance-of type-1
+ :item-identifiers (list ii-1)
+ :start-revision rev-1)
+ (list :player player-1
+ :item-identifiers (list ii-2)
+ :instance-of type-2
+ :start-revision rev-1)))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (roles assoc-2)) 1))
+ (is (= (length (slot-value assoc-2 'd::roles)) 2))
+ (is (eql (instance-of (first (roles assoc-2))) type-1))
+ (is (eql (player (first (roles assoc-2))) player-1))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers (first (roles assoc-2)))))
+ (let ((active-role (first (roles assoc-2)))
+ (non-active-role
+ (let ((r-assoc (find-if-not #'(lambda(role)
+ (eql role (first (roles assoc-2))))
+ (slot-value assoc-2 'd::roles))))
+ (when r-assoc
+ (d::role r-assoc)))))
+ (is (= (length (d::versions
+ (first (slot-value active-role 'd::parent)))) 2))
+ (is (= (length (d::versions
+ (first (slot-value non-active-role 'd::parent)))) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value non-active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-3 (d::start-revision vi))
+ (= 0 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))))))))
+
+
+(test test-merge-constructs-TopicC-6 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (r-type-1 (make-construct 'TopicC :start-revision rev-1))
+ (r-type-2 (make-construct 'TopicC :start-revision rev-1))
+ (player-1 (make-construct 'TopicC :start-revision rev-1))
+ (player-2 (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")))
+ (let ((assoc-3 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of type-1
+ :item-identifiers (list ii-3)
+ :roles (list (list :player player-1
+ :instance-of r-type-1
+ :item-identifiers (list ii-1)
+ :start-revision rev-1)
+ (list :player player-2
+ :instance-of r-type-2
+ :start-revision rev-1))))
+ (assoc-4 (make-construct 'AssociationC
+ :start-revision rev-2
+ :instance-of type-2
+ :item-identifiers (list ii-4)
+ :roles (list (list :player player-1
+ :instance-of r-type-1
+ :start-revision rev-2)
+ (list :player player-2
+ :item-identifiers (list ii-2)
+ :instance-of r-type-2
+ :start-revision rev-2)))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (d::versions assoc-3)) 2))
+ (is (= (length (d::versions assoc-4)) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::start-revision vi) rev-1)
+ (= (d::end-revision vi) rev-3)))
+ (d::versions assoc-3)))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::start-revision vi) rev-3)
+ (= (d::end-revision vi) 0)))
+ (d::versions assoc-3)))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::start-revision vi) rev-2)
+ (= (d::end-revision vi) rev-3)))
+ (d::versions assoc-4)))
+ (is (= (length (roles assoc-3)) 2))
+ (is (= (length (item-identifiers (first (roles assoc-3)))) 1))
+ (is (= (length (item-identifiers (second (roles assoc-3)))) 1))
+ (is (or (and (string= (uri (first (item-identifiers
+ (first (roles assoc-3)))))
+ "ii-1")
+ (string= (uri (first (item-identifiers
+ (second (roles assoc-3)))))
+ "ii-2"))
+ (and (string= (uri (first (item-identifiers
+ (first (roles assoc-3)))))
+ "ii-2")
+ (string= (uri (first (item-identifiers
+ (second (roles assoc-3)))))
+ "ii-1")))))))))
+
+
+
+
+
+
+;;TODO: merge topics/associations caused by a merge of their characteristics
+;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified
+;; by the same reifier
@@ -3108,4 +3521,9 @@
(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
(it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-1)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list