[isidorus-cvs] r271 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Apr 9 15:36:02 UTC 2010
Author: lgiessmann
Date: Fri Apr 9 11:36:02 2010
New Revision: 271
Log:
new-datamodel: added some unit-tests; fixed bugs in "add-name", "add-occurrence", "add-role" and "find-oldest-construct"
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 9 11:36:02 2010
@@ -157,16 +157,18 @@
+;;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),
;; add-psi, add-locator (--> duplicate-identifier-error)
-;;TODO: implement a macro "with-merge-construct" that merges constructs
-;; after some data-operations are completed (should be passed as body)
-;; and a merge should be done
+;;TODO: implement a macro with-merge-constructs, that merges constructs
+;; after all operations in the body were called
@@ -840,6 +842,19 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric merge-if-equivalent (new-characteristic parent-construct
+ &key revision)
+ (:documentation "Merges the new characteristic/role with one equivalent of the
+ parent's charateristics/roles instead of adding the entire new
+ characteristic/role to the parent."))
+
+
+(defgeneric parent (construct &key revision)
+ (:documentation "Returns the parent construct of the passed object that
+ corresponds with the given revision. The returned construct
+ can be a TopicC or a NameC."))
+
+
(defgeneric delete-if-not-referenced (construct)
(:documentation "Calls delete-construct for the given object if it is
not referenced by any other construct."))
@@ -1672,20 +1687,22 @@
:referenced-construct name
:existing-reference (parent name :revision revision)
:new-reference construct)))
- (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)))
- (add-to-version-history name-assoc :start-revision revision))
- (make-construct 'NameAssociationC
- :parent-construct construct
- :characteristic name
- :start-revision revision)))
- (add-to-version-history construct :start-revision revision)
- construct))
+ (if (merge-if-equivalent name construct :revision revision)
+ construct
+ (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)))
+ (add-to-version-history name-assoc :start-revision revision))
+ (make-construct 'NameAssociationC
+ :parent-construct construct
+ :characteristic name
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
(defgeneric delete-name (construct name &key revision)
@@ -1730,19 +1747,21 @@
:referenced-construct occurrence
:existing-reference (parent occurrence :revision revision)
:new-reference construct))
- (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)))
- (add-to-version-history occ-assoc :start-revision revision))
- (make-construct 'OccurrenceAssociationC
- :parent-construct construct
- :characteristic occurrence
- :start-revision revision)))
- (add-to-version-history construct :start-revision revision)
- construct))
+ (if (merge-if-equivalent occurrence construct :revision revision)
+ construct
+ (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)))
+ (add-to-version-history occ-assoc :start-revision revision))
+ (make-construct 'OccurrenceAssociationC
+ :parent-construct construct
+ :characteristic occurrence
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
(defgeneric delete-occurrence (construct occurrence &key revision)
@@ -2000,8 +2019,9 @@
;;; CharacteristicC
(defmethod delete-if-not-referenced ((construct CharacteristicC))
(let ((references (slot-p construct 'parent)))
- (when (and (<= (length references) 1)
- (marked-as-deleted-p (first references)))
+ (when (or (not references)
+ (and (= (length references) 1)
+ (marked-as-deleted-p (first references))))
(delete-construct construct))))
@@ -2099,16 +2119,12 @@
t))
-(defgeneric parent (construct &key revision)
- (:documentation "Returns the parent construct of the passed object that
- corresponds with the given revision. The returned construct
- can be a TopicC or a NameC.")
- (:method ((construct CharacteristicC) &key (revision *TM-REVISION*))
- (let ((valid-associations
- (filter-slot-value-by-revision construct 'parent
- :start-revision revision)))
- (when valid-associations
- (parent-construct (first valid-associations))))))
+(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'parent
+ :start-revision revision)))
+ (when valid-associations
+ (parent-construct (first valid-associations)))))
(defmethod add-parent ((construct CharacteristicC)
@@ -2290,19 +2306,21 @@
:referenced-construct variant
:existing-reference (parent variant :revision revision)
:new-reference construct)))
- (let ((all-variants
- (map 'list #'characteristic (slot-p construct 'variants))))
- (if (find variant all-variants)
- (let ((variant-assoc
- (loop for variant-assoc in (slot-p construct 'variants)
- when (eql (characteristic variant-assoc) variant)
- return variant-assoc)))
- (add-to-version-history variant-assoc :start-revision revision))
- (make-construct 'VariantAssociationC
- :characteristic variant
- :parent-construct construct
- :start-revision revision)))
- construct))
+ (if (merge-if-equivalent variant construct :revision revision)
+ construct
+ (let ((all-variants
+ (map 'list #'characteristic (slot-p construct 'variants))))
+ (if (find variant all-variants)
+ (let ((variant-assoc
+ (loop for variant-assoc in (slot-p construct 'variants)
+ when (eql (characteristic variant-assoc) variant)
+ return variant-assoc)))
+ (add-to-version-history variant-assoc :start-revision revision))
+ (make-construct 'VariantAssociationC
+ :characteristic variant
+ :parent-construct construct
+ :start-revision revision))
+ construct))))
(defgeneric delete-variant (construct variant &key revision)
@@ -2417,20 +2435,22 @@
(:documentation "Adds the given role to the passed association-construct.")
(:method ((construct AssociationC) (role RoleC)
&key (revision *TM-REVISION*))
- (let ((all-roles
- (map 'list #'role (slot-p construct 'roles))))
- (if (find role all-roles)
- (let ((role-assoc
- (loop for role-assoc in (slot-p construct 'roles)
- when (eql (role role-assoc) role)
- return role-assoc)))
- (add-to-version-history role-assoc :start-revision revision))
- (make-construct 'RoleAssociationC
- :role role
- :parent-construct construct
- :start-revision revision)))
- (add-to-version-history construct :start-revision revision)
- construct))
+ (if (merge-if-equivalent role construct :revision revision)
+ construct
+ (let ((all-roles
+ (map 'list #'role (slot-p construct 'roles))))
+ (if (find role all-roles)
+ (let ((role-assoc
+ (loop for role-assoc in (slot-p construct 'roles)
+ when (eql (role role-assoc) role)
+ return role-assoc)))
+ (add-to-version-history role-assoc :start-revision revision))
+ (make-construct 'RoleAssociationC
+ :role role
+ :parent-construct construct
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
(defgeneric delete-role (construct role &key revision)
@@ -2457,8 +2477,9 @@
;;; RoleC
(defmethod delete-if-not-referenced ((construct RoleC))
(let ((references (slot-p construct 'parent)))
- (when (and (<= (length references) 1)
- (marked-as-deleted-p (first references)))
+ (when (or (not references)
+ (and (= (length references) 1)
+ (marked-as-deleted-p (first references))))
(delete-construct construct))))
@@ -2988,7 +3009,7 @@
(:method ((construct ScopableC) (theme-topic TopicC)
&key (revision (error (make-condition 'missing-argument-error
:message "From delete-theme(): revision must be set"
- :argument-symbol 'revsion
+ :argument-symbol 'revision
:function-symbol 'delete-theme))))
(let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
when (eql (theme-topic theme-assoc) theme-topic)
@@ -3388,7 +3409,7 @@
(not start-revision))
(error (make-condition 'missing-argument-error
:message "From make-characteristic(): start-revision must be set"
- :argument-symbol 'start-revsion
+ :argument-symbol 'start-revision
:function-symbol 'make-characgteristic)))
(let ((characteristic
(let ((existing-characteristic
@@ -3895,4 +3916,59 @@
(move-referenced-constructs newer-role older-role
:revision revision)
(delete-if-not-referenced newer-role)
- older-role)))))))
\ No newline at end of file
+ older-role)))))))
+
+
+(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((possible-roles
+ (remove-if #'(lambda(role)
+ (when (parent role :revision revision)
+ role))
+ (map 'list #'role (slot-p parent-construct 'roles)))))
+ (let ((equivalent-role
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(role)
+ (when
+ (strictly-equivalent-constructs role new-role
+ :revision revision)
+ role))
+ possible-roles))))
+ (when equivalent-role
+ (merge-constructs (first equivalent-role) new-role
+ :revision revision)))))
+
+
+(defmethod merge-if-equivalent ((new-characteristic CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or TopicC NameC) parent-construct))
+ (let ((all-existing-characteristics
+ (map 'list #'characteristic
+ (cond ((typep new-characteristic 'OccurrenceC)
+ (slot-p parent-construct 'occurrences))
+ ((typep new-characteristic 'NameC)
+ (slot-p parent-construct 'names))
+ ((typep new-characteristic 'VariantC)
+ (slot-p parent-construct 'variants))))))
+ (let ((possible-characteristics ;all characteristics that are not referenced
+ ;other constructs at the given revision
+ (remove-if #'(lambda(char)
+ (parent char :revision revision))
+ all-existing-characteristics)))
+ (let ((equivalent-construct
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(char)
+ (when
+ (strictly-equivalent-constructs char new-characteristic
+ :revision revision)
+ char))
+ possible-characteristics))))
+ (when equivalent-construct
+ (merge-constructs (first equivalent-construct) new-characteristic
+ :revision revision))))))
\ No newline at end of file
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 9 11:36:02 2010
@@ -2741,53 +2741,67 @@
(test test-find-oldest-construct ()
"Tests the generic find-oldest-construct."
(with-fixture with-empty-db (*db-dir*)
- (let ((top-1 (make-instance 'TopicC))
- (top-2 (make-instance 'TopicC))
- (tm-1 (make-instance 'TopicMapC))
- (tm-2 (make-instance 'TopicMapC))
- (assoc-1 (make-instance 'AssociationC))
- (assoc-2 (make-instance 'AssociationC))
- (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
- (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
- (variant-1 (make-instance 'VariantC))
- (variant-2 (make-instance 'VariantC))
- (name-1 (make-instance 'NameC))
- (name-2 (make-instance 'NameC))
- (role-1 (make-instance 'RoleC))
- (role-2 (make-instance 'RoleC))
- (rev-1 100)
+ (let ((rev-1 100)
(rev-2 200)
(rev-3 300))
- (setf *TM-REVISION* rev-1)
- (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (add-item-identifier top-1 ii-1 :revision rev-3)
- (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (add-item-identifier assoc-1 ii-2 :revision rev-2)
- (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
- (add-item-identifier top-2 ii-1 :revision rev-1)
- (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (add-variant name-1 variant-1 :revision rev-3)
- (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (add-variant name-1 variant-2 :revision rev-2)
- (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2)))
- (add-variant name-2 variant-1 :revision rev-1)
- (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (add-role assoc-1 role-1 :revision rev-3)
- (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (add-role assoc-1 role-2 :revision rev-2)
- (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
- (add-role assoc-2 role-1 :revision rev-1)
- (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
- (d::add-to-version-history tm-1 :start-revision rev-3)
- (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
- (d::add-to-version-history tm-2 :start-revision rev-1)
- (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
- (d::add-to-version-history tm-1 :start-revision rev-1)
- (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
- (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))
+ (let ((theme-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-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)))
+ (let ((top-1 (make-instance 'TopicC))
+ (top-2 (make-instance 'TopicC))
+ (tm-1 (make-instance 'TopicMapC))
+ (tm-2 (make-instance 'TopicMapC))
+ (assoc-1 (make-instance 'AssociationC))
+ (assoc-2 (make-instance 'AssociationC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (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)))
+ (name-1 (make-instance 'NameC))
+ (name-2 (make-instance 'NameC))
+ (role-1 (make-construct 'RoleC
+ :start-revision rev-1
+ :player player-1))
+ (role-2 (make-construct 'RoleC
+ :start-revision rev-1
+ :player player-2)))
+ (setf *TM-REVISION* rev-1)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier top-1 ii-1 :revision rev-3)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier assoc-1 ii-2 :revision rev-2)
+ (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier top-2 ii-1 :revision rev-1)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (add-variant name-1 variant-1 :revision rev-3)
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (add-variant name-1 variant-2 :revision rev-2)
+ (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) ;x
+ (add-variant name-2 variant-1 :revision rev-1)
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+ (add-role assoc-1 role-1 :revision rev-3)
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2))) ;x
+ (add-role assoc-1 role-2 :revision rev-2)
+ (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
+ (add-role assoc-2 role-1 :revision rev-1)
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-1 :start-revision rev-3)
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-2 :start-revision rev-1)
+ (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-1 :start-revision rev-1)
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))))
(test test-move-referenced-constructs-ReifiableConstructC ()
More information about the Isidorus-cvs
mailing list