Changeset 274

Timestamp:

04/12/10 15:06:19 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: added merging of characteristics when added with "add-<type>"

Location:

branches/new-datamodel/src

Files:

• model/datamodel.lisp (modified) (14 diffs)
• unit_tests/datamodel_test.lisp (modified) (3 diffs)

branches/new-datamodel/src/model/datamodel.lisp ¶

@@ -158 +158 @@
 
 
-;;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
@@ -843 +840 @@
 
 ;;; 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)
@@ -1693 +1696 @@
                (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
@@ -1753 +1757 @@
                (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
@@ -2018 +2023 @@
 
 ;;; 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)))
@@ -2131 +2157 @@
                        (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
@@ -2144 +2171 @@
                              :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)))))
 
 
@@ -2216 +2250 @@
 
 ;;; 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*))
@@ -2476 +2528 @@
 
 ;;; 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)))
@@ -2587 +2657 @@
 (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)
@@ -2599 +2670 @@
                              :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)))))
 
 
@@ -3288 +3366 @@
                                       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))
@@ -3413 +3495 @@
                              :function-symbol 'make-characgteristic)))
     (let ((characteristic
-           (let ((existing-characteristic
+           (let ((existing-characteristics
                   (when parent
                     (remove-if
@@ -3426 +3508 @@
                                       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)))))

branches/new-datamodel/src/unit_tests/datamodel_test.lisp ¶

@@ -81 +81 @@
            :test-find-oldest-construct
            :test-move-referenced-constructs-ReifiableConstructC
-           :test-move-referenced-constructs-NameC))
+           :test-move-referenced-constructs-NameC
+           :test-move-referenced-constructs-TopicC))
 
 
@@ -2932 +2933 @@
 
 
+(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))
+                )
+            ))))))
 
 
@@ -2992 +3044 @@
   (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)
   )