[isidorus-cvs] r274 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Apr 12 15:06:20 UTC 2010
Author: lgiessmann
Date: Mon Apr 12 11:06:19 2010
New Revision: 274
Log:
new-datamodel: added merging of characteristics when added with "add-<type>"
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 Mon Apr 12 11:06:19 2010
@@ -157,12 +157,9 @@
-;;TODO: modify 2x add-parent --> use add-characteristic and add-role
-;;TODO: call merge-if-equivalent in 2x add-parent
;;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: check for duplicate identifiers after topic-creation/merge
;;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),
@@ -842,6 +839,12 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric find-self-or-equal (construct parent-construct &key revision)
+ (:documentation "Returns the construct 'construct' if is owned by the
+ parent-construct or an equal construct or nil if there
+ is no equal one."))
+
+
(defgeneric merge-if-equivalent (new-characteristic parent-construct
&key revision)
(:documentation "Merges the new characteristic/role with one equivalent of the
@@ -1692,10 +1695,11 @@
(let ((all-names
(map 'list #'characteristic (slot-p construct 'names))))
(if (find name all-names)
- (let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
- when (eql (parent-construct name-assoc)
- construct)
- return name-assoc)))
+ (let ((name-assoc
+ (loop for name-assoc in (slot-p construct 'names)
+ when (eql (parent-construct name-assoc)
+ construct)
+ return name-assoc)))
(add-to-version-history name-assoc :start-revision revision))
(make-construct 'NameAssociationC
:parent-construct construct
@@ -1752,9 +1756,10 @@
(let ((all-occurrences
(map 'list #'characteristic (slot-p construct 'occurrences))))
(if (find occurrence all-occurrences)
- (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
- when (eql (parent-construct occ-assoc) construct)
- return occ-assoc)))
+ (let ((occ-assoc
+ (loop for occ-assoc in (slot-p construct 'occurrences)
+ when (eql (parent-construct occ-assoc) construct)
+ return occ-assoc)))
(add-to-version-history occ-assoc :start-revision revision))
(make-construct 'OccurrenceAssociationC
:parent-construct construct
@@ -2017,6 +2022,27 @@
;;; CharacteristicC
+(defmethod find-self-or-equal ((construct CharacteristicC)
+ (parent-construct TopicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or OccurrenceC NameC) construct))
+ (let ((chars (if (typep construct 'OccurrenceC)
+ (occurrences parent-construct :revision revision)
+ (names parent-construct :revision revision))))
+ (let ((self (find construct chars)))
+ (if self
+ self
+ (let ((equal-char
+ (remove-if #'null
+ (map 'list
+ #'(lambda(char)
+ (strictly-equivalent-constructs
+ char construct :revision revision))
+ chars))))
+ (when equal-char
+ (first equal-char)))))))
+
+
(defmethod delete-if-not-referenced ((construct CharacteristicC))
(let ((references (slot-p construct 'parent)))
(when (or (not references)
@@ -2130,6 +2156,7 @@
(defmethod add-parent ((construct CharacteristicC)
(parent-construct ReifiableConstructC)
&key (revision *TM-REVISION*))
+ (declare (integer revision))
(let ((already-set-parent (parent construct :revision revision))
(same-parent-assoc ;should contain an object that was marked as deleted
(loop for parent-assoc in (slot-p construct 'parent)
@@ -2143,29 +2170,36 @@
:referenced-construct construct
:existing-reference (parent construct :revision revision)
:new-reference parent-construct)))
- (cond (already-set-parent
- (let ((parent-assoc
- (loop for parent-assoc in (slot-p construct 'parent)
- when (eql parent-construct
- (parent-construct parent-assoc))
- return parent-assoc)))
- (add-to-version-history parent-assoc :start-revision revision)))
- (same-parent-assoc
- (add-to-version-history same-parent-assoc :start-revision revision))
- (t
- (let ((association-type (cond ((typep construct 'OccurrenceC)
- 'OccurrenceAssociationC)
- ((typep construct 'NameC)
- 'NameAssociationC)
- (t
- 'VariantAssociationC))))
- (make-construct association-type
- :characteristic construct
- :parent-construct parent-construct
- :start-revision revision)))))
- (when (typep parent-construct 'VersionedConstructC)
- (add-to-version-history parent-construct :start-revision revision))
- construct)
+ (let ((merged-char
+ (merge-if-equivalent construct parent-construct :revision revision)))
+ (if merged-char
+ merged-char
+ (progn
+ (cond (already-set-parent
+ (let ((parent-assoc
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct
+ (parent-construct parent-assoc))
+ return parent-assoc)))
+ (add-to-version-history parent-assoc
+ :start-revision revision)))
+ (same-parent-assoc
+ (add-to-version-history same-parent-assoc
+ :start-revision revision))
+ (t
+ (let ((association-type (cond ((typep construct 'OccurrenceC)
+ 'OccurrenceAssociationC)
+ ((typep construct 'NameC)
+ 'NameAssociationC)
+ (t
+ 'VariantAssociationC))))
+ (make-construct association-type
+ :characteristic construct
+ :parent-construct parent-construct
+ :start-revision revision))))
+ (when (typep parent-construct 'VersionedConstructC)
+ (add-to-version-history parent-construct :start-revision revision))
+ construct)))))
(defmethod delete-parent ((construct CharacteristicC)
@@ -2215,6 +2249,24 @@
;;; VariantC
+(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((vars (variants parent-construct :revision revision)))
+ (let ((self (find construct vars)))
+ (if self
+ self
+ (let ((equal-var
+ (remove-if #'null
+ (map 'list
+ #'(lambda(var)
+ (strictly-equivalent-constructs
+ var construct :revision revision))
+ vars))))
+ (when equal-var
+ (first equal-var)))))))
+
+
(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC)
&key (revision *TM-REVISION*))
(declare (ignorable revision))
@@ -2475,6 +2527,24 @@
;;; RoleC
+(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((p-roles (roles parent-construct :revision revision)))
+ (let ((self (find construct p-roles)))
+ (if self
+ self
+ (let ((equal-role
+ (remove-if #'null
+ (map 'list
+ #'(lambda(role)
+ (strictly-equivalent-constructs
+ role construct :revision revision))
+ p-roles))))
+ (when equal-role
+ (first equal-role)))))))
+
+
(defmethod delete-if-not-referenced ((construct RoleC))
(let ((references (slot-p construct 'parent)))
(when (or (not references)
@@ -2586,6 +2656,7 @@
(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
&key (revision *TM-REVISION*))
+ (declare (integer revision))
(let ((already-set-parent (parent construct :revision revision))
(same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent)
when (eql parent-construct (parent-construct parent-assoc))
@@ -2598,22 +2669,29 @@
:referenced-construct construct
:existing-reference (parent construct :revision revision)
:new-reference parent-construct)))
- (cond (already-set-parent
- (let ((parent-assoc
- (loop for parent-assoc in (slot-p construct 'parent)
- when (eql parent-construct
- (parent-construct parent-assoc))
- return parent-assoc)))
- (add-to-version-history parent-assoc :start-revision revision)))
- (same-parent-assoc
- (add-to-version-history same-parent-assoc :start-revision revision))
- (t
- (make-construct 'RoleAssociationC
- :role construct
- :parent-construct parent-construct
- :start-revision revision))))
- (add-to-version-history parent-construct :start-revision revision)
- construct)
+ (let ((merged-role
+ (merge-if-equivalent construct parent-construct :revision revision)))
+ (if merged-role
+ merged-role
+ (progn
+ (cond (already-set-parent
+ (let ((parent-assoc
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct
+ (parent-construct parent-assoc))
+ return parent-assoc)))
+ (add-to-version-history parent-assoc
+ :start-revision revision)))
+ (same-parent-assoc
+ (add-to-version-history same-parent-assoc
+ :start-revision revision))
+ (t
+ (make-construct 'RoleAssociationC
+ :role construct
+ :parent-construct parent-construct
+ :start-revision revision)))
+ (add-to-version-history parent-construct :start-revision revision)
+ construct)))))
(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
@@ -3287,12 +3365,16 @@
:instance-of instance-of)
existing-role))
(map 'list #'role (slot-p parent 'roles)))))))
- (cond ((> (length existing-roles) 1)
- (merge-all-constructs existing-roles))
- (existing-roles
- (first existing-roles))
- (t
- (make-instance 'RoleC))))))
+ (if (and existing-roles
+ (or (eql parent (parent (first existing-roles)
+ :revision start-revision))
+ (not (parent (first existing-roles)
+ :revision start-revision))))
+ (progn
+ (add-role parent (first existing-roles)
+ :revision start-revision)
+ (first existing-roles))
+ (make-instance 'RoleC)))))
(when player
(add-player role player :revision start-revision))
(when parent
@@ -3412,7 +3494,7 @@
:argument-symbol 'start-revision
:function-symbol 'make-characgteristic)))
(let ((characteristic
- (let ((existing-characteristic
+ (let ((existing-characteristics
(when parent
(remove-if
#'null
@@ -3425,8 +3507,15 @@
:instance-of instance-of)
existing-characteristic))
(get-all-characteristics parent class-symbol))))))
- (if existing-characteristic
- (first existing-characteristic)
+ (if (and existing-characteristics
+ (or (eql parent (parent (first existing-characteristics)
+ :revision start-revision))
+ (not (parent (first existing-characteristics)
+ :revision start-revision))))
+ (progn
+ (add-characteristic parent (first existing-characteristics)
+ :revision start-revision)
+ (first existing-characteristics))
(make-instance class-symbol :charvalue charvalue
:datatype datatype)))))
(when (typep characteristic 'NameC)
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 Mon Apr 12 11:06:19 2010
@@ -80,7 +80,8 @@
:test-make-TopicC
:test-find-oldest-construct
:test-move-referenced-constructs-ReifiableConstructC
- :test-move-referenced-constructs-NameC))
+ :test-move-referenced-constructs-NameC
+ :test-move-referenced-constructs-TopicC))
;;TODO: test merge-constructs
@@ -2931,6 +2932,57 @@
(variants name-2 :revision rev-2)))))))))
+(test test-move-referenced-constructs-TopicC ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200))
+ (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (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-1
+ :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-1
+ :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))
+ )
+ ))))))
(defun run-datamodel-tests()
@@ -2991,4 +3043,5 @@
(it.bese.fiveam:run! 'test-find-oldest-construct)
(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
(it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
+ (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list