Changeset 258

Timestamp:

04/05/10 18:07:59 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: added the generics "add-reified-construct" and "delet-reified-construct" for "TopicC"; added "merge-constructs" for "TopicC"; changed the behaviour of merging "CharacteristicC"s

File:

• branches/new-datamodel/src/model/datamodel.lisp (modified) (17 diffs)

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

@@ -156 +156 @@
 
 
+;;TODO: mark-as-deleted should call mark as deleted for every owned
+;;      versioned-construct of the called construct
 ;;TODO: check for duplicate identifiers after topic-creation/merge
 ;;TODO: add: add-to-version-history (parent) to all
@@ -168 +170 @@
 ;;TODO: use some exceptions --> more than one type,
 ;;      identifier, not-mergable merges, missing-init-args...
-;;TODO: implement merge-construct -> ReifiableConstructC -> ...
-;;      the method should merge two constructs that are inherited from
-;;      ReifiableConstructC
+
 
 
@@ -759 +759 @@
 
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric mark-as-deleted (construct &key source-locator revision)
+  (:documentation "Mark a construct as deleted if it comes from the source
+                   indicated by source-locator"))
+
+
 (defgeneric find-oldest-construct (construct-1 construct-2)
   (:documentation "Returns the construct which owns the oldes version info.
@@ -856 +861 @@
 
 ;;; VersionedConstructC
+(defgeneric does-not-exist-in-revision-history (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.")
+  (:method ((versioned-construct VersionedConstructC))
+    (or (not (versions versioned-construct))
+        (and (= (length (versions versioned-construct)) 1)
+             (= (start-revision (first (versions versioned-construct)))
+                (end-revision (first (versions versioned-construct))))))))
+
+
 (defmethod find-oldest-construct ((construct-1 VersionedConstructC)
                                  (construct-2 VersionedConstructC))
@@ -964 +980 @@
 
 
-(defgeneric mark-as-deleted (construct &key source-locator revision)
-  (:documentation "Mark a construct as deleted if it comes from the source
-                   indicated by source-locator")
-  (:method ((construct VersionedConstructC) &key source-locator revision)
-    (declare (ignorable source-locator))
-    (let
-        ((last-version ;the last active version
-          (find 0 (versions construct) :key #'end-revision)))
-      (when last-version
-        (setf (end-revision last-version) revision)))))
+(defmethod marks-as-deleted ((construct VersionedConstructC)
+                             &key source-locator revision)
+  (declare (ignorable source-locator))
+  (let
+      ((last-version ;the last active version
+        (find 0 (versions construct) :key #'end-revision)))
+    (when last-version
+      (setf (end-revision last-version) revision))))
   
 
@@ -1660 +1674 @@
       (when assocs
         (reifiable-construct (first assocs))))))
+
+
+(defgeneric add-reified-construct (construct reified-construct &key revision)
+  (:documentation "Sets the passed construct as reified-consturct of the given
+                   topic.")
+  (:method ((construct TopicC) (reified-construct ReifiableConstructC)
+            &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (add-reifier reified-construct construct :revision revision)))
+
+
+(defgeneric delete-reified-construct (construct reified-construct &key revision)
+  (:documentation "Unsets the passed construct as reified-construct of the
+                   given topic.")
+  (:method ((construct TopicC) (reified-construct ReifiableConstructC)
+            &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (delete-reifier reified-construct construct :revision revision)))
 
 
@@ -1932 +1964 @@
                        &key (revision *TM-REVISION*))
   (let ((already-set-parent (parent construct :revision revision))
-        (same-parent-assoc ;should contain a object that was marked as deleted
+        (same-parent-assoc ;should contain an object that was marked as deleted
          (loop for parent-assoc in (slot-p construct 'parent)
             when (eql parent-construct (parent-construct parent-assoc))
@@ -2599 +2631 @@
                                  reifier-topic)
                reifier-topic)))
-      (let ((all-constructs
-             (let ((inner-construct (reified-construct merged-reifier-topic
-                                                       :revision revision)))
-               (when inner-construct
-                 (list inner-construct)))))
+      (let ((all-constructs (map 'list #'reifiable-construct
+                                 (slot-p reifier-topic 'reified-construct))))
         (let ((merged-construct construct))
-          (cond ((find construct all-constructs)
+          (cond ((reified-construct merged-reifier-topic :revision revision)
+                 (merge-constructs
+                  (reified-construct merged-reifier-topic :revision revision)
+                  construct))
+                ((find construct all-constructs)
                  (let ((reifier-assoc
                         (loop for reifier-assoc in
@@ -2614 +2647 @@
                    (add-to-version-history reifier-assoc
                                            :start-revision revision)))
-                (all-constructs
-                 (merge-constructs (first all-constructs) construct))
                 (t
                  (make-construct 'ReifierAssociationC
@@ -2960 +2991 @@
       (error "From make-association(): start-revision must be set"))
     (let ((association
-           (let ((existing-association
+           (let ((existing-associations
                   (remove-if
                    #'null
@@ -2971 +3002 @@
                                     existing-association))
                         (elephant:get-instances-by-class 'AssociationC)))))
-             (if existing-association
-                 (first existing-association)
-                 (make-instance 'AssociationC)))))
+             (cond ((> (length existing-associations) 1)
+                    (merge-all-constructs existing-associations))
+                   (existing-associations
+                    (first existing-associations))
+                   (t
+                    (make-instance 'AssociationC))))))
       (dolist (role-plist roles)
         (add-role association
@@ -2994 +3028 @@
       (error "From make-role(): start-revision must be set"))
     (let ((role
-           (let ((existing-role
+           (let ((existing-roles
                   (when parent
                     (remove-if
@@ -3006 +3040 @@
                                       existing-role))
                           (map 'list #'role (slot-p parent 'roles)))))))
-             (if existing-role
-                 (first existing-role)
-                 (make-instance 'RoleC)))))
+             (cond ((> (length existing-roles) 1)
+                    (merge-all-constructs existing-roles))
+                   (existing-roles
+                    (first existing-roles))
+                   (t
+                    (make-instance 'RoleC))))))
       (when player
         (add-player role player :revision start-revision))
@@ -3039 +3076 @@
                                     existing-tm))
                         (elephant:get-instances-by-class 'TopicMapC)))))
-             (cond ((and existing-tms (> (length existing-tms) 1))
+             (cond ((> (length existing-tms) 1)
                     (merge-all-constructs existing-tms))
                    (existing-tms
@@ -3078 +3115 @@
                                     existing-topic))
                         (elephant:get-instances-by-class 'TopicC)))))
-             (cond ((and existing-topics (> (length existing-topics) 1))
+             (cond ((> (length existing-topics) 1)
                     (merge-all-constructs existing-topics))
                    (existing-topics
@@ -3206 +3243 @@
 
 
-        
-
-
-
-
-
-
-
-
-
-
-
-
+;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric move-identifiers (source destination &key revision)
+  (:documentation "Sets all identifiers as mark as deleted in the given
+                   version and adds the marked identifiers to the
+                   destination construct."))
+
+
+(defmethod move-identifiers ((source ReifiableConstructC)
+                             (destination ReifiableConstructC)
+                             &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (let ((iis (item-identifiers source :revision revision)))
+    (dolist (ii iis)
+      (delete-item-identifier source ii :revision revision)
+      (add-item-identifier destination ii :revision revision))
+    iis))
+
+
+(defmethod move-identifiers ((source TopicC) (destination TopicC)
+                             &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (let ((iis (call-next-method))
+        (tids (topic-identifiers source :revision revision))
+        (psis (psis source :revision revision))
+        (sls (locators source :revision revision)))
+    (dolist (tid tids)
+      (delete-topic-identifier source tid :revision revision)
+      (add-topic-identifier destination tid :revision revision))
+    (dolist (psi psis)
+      (delete-psi source psi :revision revision)
+      (add-psi destination psi :revision revision))
+    (dolist (sl sls)
+      (delete-locator source sl :revision revision)
+      (add-locator destination sl :revision revision))
+    (append tids iis psis sls)))
+
+
+(defgeneric move-referenced-constructs (source destination &key revision)
+  (:documentation "Moves all referenced constructs in the given version from
+                   the source TM-construct to the destination TM-construct."))
+
+
+(defmethod move-referenced-constructs ((source ReifiableConstructC)
+                                       (destination ReifiableConstructC)
+                                       &key (revision *TM-REVISION*))
+  (let ((source-reifier (reifier source :revision revision))
+        (destination-reifier (reifier destination :revision revision)))
+    (cond ((and source-reifier destination-reifier)
+           (delete-reifier (reified-construct source-reifier :revision revision)
+                           source-reifier :revision revision)
+           (delete-reifier (reified-construct destination-reifier
+                                              :revision revision)
+                           destination-reifier :revision revision)
+           (let ((merged-reifier
+                  (merge-constructs source-reifier destination-reifier
+                                    :revision revision)))
+             (add-reifier destination merged-reifier :revision revision)))
+          (source-reifier
+           (delete-reifier (reified-construct source-reifier :revision revision)
+                           source-reifier :revision revision)
+           (add-reifier destination source-reifier :revision revision)
+           source-reifier)
+          (destination-reifier
+           (add-reifier destination destination-reifier :revision revision)
+           destination-reifier))))
+
+
+(defmethod move-referenced-constructs ((source TopicC) (destination TopicC)
+                                       &key (revision *TM-REVISION*))
+  (let ((roles (player-in-roles source :revision revision))
+        (scopables (used-as-theme source :revision revision))
+        (typables (used-as-type source :revision revision)))
+    (dolist (role roles)
+      (delete-player role source :revision revision)
+      (add-player role destination :revision revision))
+    (dolist (scopable scopables)
+      (delete-theme scopable source :revision revision)
+      (add-theme scopable destination :revision revision))
+    (dolist (typable typables)
+      (delete-type typable source :revision revision)
+      (add-type typable destination :revision revision))
+    (append roles scopables typables)))
+
+
+(defgeneric move-reified-construct (source destination &key revision)
+  (:documentation "Moves the refied TM-construct from the source topic
+                   to the given destination topic.")
+  (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (let ((source-reified (reified-construct source :revision revision))
+          (destination-reified (reified-construct destination
+                                                  :revision revision)))
+      (unless (eql (type-of source-reified) (type-of destination-reified))
+        (error "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
+               source destination source-reified destination-reified))
+      (cond ((and source-reified destination-reified)
+             (delete-reifier source-reified source :revision revision)
+             (delete-reifier destination-reified destination :revision revision)
+             (let ((merged-reified
+                    (merge-constructs source-reified destination-reified
+                                      :revision revision)))
+               (add-reifier merged-reified destination :revision revision)
+               merged-reified))
+            (source-reified
+             (delete-reifier source source-reified :revision revision)
+             (add-reifier destination source-reified :revision revision)
+             source-reified)
+            (destination-reified
+             (add-reifier destination destination-reified :revision revision)
+             destination-reified)))))
+
+
+(defgeneric move-occurrences (source destination &key revision)
+  (:documentation "Moves all occurrences from the source topic to the
+                   destination topic. If occurrences are TMDM equal
+                   they are merged, i.e. one is marked-as-deleted.")
+  (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (let ((occs-to-move (occurrences source :revision revision)))
+      (dolist (occ occs-to-move)
+        (delete-occurrence occ source :revision revision)
+        (let ((equivalent-occ
+               (find-if #'(lambda (destination-occ)
+                            (when 
+                                (strictly-equivalent-constructs
+                                 occ destination-occ :revision revision)
+                              destination-occ))
+                        (occurrences destination :revision revision))))
+          (if equivalent-occ
+              (progn
+                (add-occurrence destination equivalent-occ :revision revision)
+                (move-identifiers occ equivalent-occ :revision revision)
+                (move-referenced-constructs occ equivalent-occ
+                                            :revision revision))
+              (add-occurrence destination occ :revision revision))))
+      occs-to-move)))
+
+
+(defgeneric move-variants (source destination &key revision)
+  (:documentation "Moves all variants from the source name to the destination
+                   name. If any variants are TMDM equal they are merged -->
+                   i.e. one of the variants is marked-as-deleted.")
+  (:method ((source NameC) (destination NameC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (let ((vars-to-move (variants source :revision revision)))
+      (dolist (var vars-to-move)
+        (delete-variant source var :revision revision)
+        (let ((equivalent-var
+               (find-if #'(lambda (destination-var)
+                            (when 
+                                (strictly-equivalent-constructs
+                                 var destination-var :revision revision)
+                              destination-var))
+                        (variants destination :revision revision))))
+          (if equivalent-var
+              (progn
+                (add-variant destination equivalent-var :revision revision)
+                (move-identifiers var equivalent-var :revision revision)
+                (move-referenced-constructs var equivalent-var
+                                            :revision revision))
+              (add-variant destination var :revision revision))))
+      vars-to-move)))
+
+
+(defgeneric move-names (source destination &key revision)
+  (:documentation "Moves all names from the source topic to the destination
+                   topic. If any names are equal they are merged, i.e.
+                   one of the names is marked-as-deleted.")
+  (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (let ((names-to-move (names source :revision revision)))
+      (dolist (name names-to-move)
+        (delete-name source name :revision revision)
+        (let ((equivalent-name
+               (find-if #'(lambda (destination-name)
+                            (when 
+                                (strictly-equivalent-constructs
+                                 name destination-name :revision revision)
+                              destination-name))
+                        (names destination :revision revision))))
+          (if equivalent-name
+              (progn
+                (move-variants name equivalent-name :revision revision)
+                (add-name destination equivalent-name :revision revision)
+                (move-identifiers name equivalent-name :revision revision)
+                (move-referenced-constructs name equivalent-name
+                                            :revision revision))
+              (add-name destination name :revision revision))))
+      names-to-move)))
+
+
+(defun merge-changed-constructs (older-topic &key (revision *TM-REVISION*))
+  (declare (TopicC older-topic))
+  (dolist (construct (append (used-as-type older-topic :revision revision)
+                             (used-as-theme older-topic :revision revision)
+                             (player-in-roles older-topic :revision revision)))
+    (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))))))))
+
+
+
+(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
+                             &key (revision *TM-REVISION*))
+  (let ((older-topic (find-oldest-construct construct-1 construct-2)))
+    (let ((newer-topic (if (eql older-topic construct-1)
+                           construct-2
+                           construct-1)))
+      (move-identifiers newer-topic older-topic :revision revision)
+      (dolist (tm (in-topicmaps newer-topic :revision revision))
+        (add-to-tm tm older-topic))
+      (move-names newer-topic older-topic :revision revision)
+      (move-occurrences newer-topic older-topic :revision revision)
+      (move-referenced-constructs newer-topic older-topic :revision revision)
+      (move-reified-construct newer-topic older-topic :revision revision)
+      (merge-changed-constructs older-topic :revision revision)
+      (mark-as-deleted newer-topic :revision revision)
+      (when (does-not-exist-in-revision-history newer-topic)
+        (delete-construct newer-topic))
+      older-topic)))
+
+
+
+
+
+
+
+;TODO: merge-constructs: RoleC, AssociationC, TopicMapC,
+;      OccurrenceC, NameC, VariantC --> call merge-constructs of the parent
+;      and return the active construct on what merge-constructs was initialy
+;      called
 
 
@@ -3229 +3500 @@
   (or revision)
   (if construct-1 construct-1 construct-2))
+
+
+
+
 ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defun merge-characteristics (older-parent newer-parent
-                              &key (revision *TM-REVISION*)
-                              (characteristic-type 'OccurrenceC))
-  "Deletes all characteristics of the given type from the newer-parent.
-   Merges equivalent characteristics between the newer and the older parent.
-   Adds all characteristics from the newer-parent to the older-parent or adds
-   the merged characterisitcs to the older-parent."
-  (declare (type (or TopicC NameC) older-parent newer-parent)
-           (integer revision) (symbol characteristic-type))
-  (let ((object-name
-         (subseq (write-to-string characteristic-type) 0
-                 (- (length (write-to-string characteristic-type)) 1))))
-    (let ((request-fun
-           (symbol-function
-            (find-symbol (concatenate 'string object-name "S"))))
-          (delete-fun
-           (symbol-function
-            (find-symbol (concatenate 'string "DELETE-" object-name))))
-          (add-fun
-           (symbol-function
-            (find-symbol (concatenate 'string "ADD-" object-name)))))
-      (dolist (newer-char (funcall request-fun newer-parent :revision revision))
-        (let ((older-char
-               (find-if #'(lambda(char)
-                            (equivalent-constructs char newer-char
-                                                   :revision revision))
-                        (funcall request-fun older-parent :revision revision))))
-          (funcall delete-fun newer-parent newer-char :revision revision)
-          (if (and newer-char older-char)
-              (progn
-                (funcall delete-fun older-parent older-char :revision revision)
-                (funcall add-fun older-parent
-                         (merge-constructs newer-char older-char
-                                           :revision revision)))
-              (funcall add-fun older-parent newer-char)))))))
-
-
-(defmethod merge-constructs ((construct-1 ReifiableConstructC)
-                             (construct-2 ReifiableConstructC)
-                             &key (revision *TM-REVISION*))
-  (declare (integer revision))
-  (if (eql construct-1 construct-2)
-      construct-1
-      (let ((older-construct (find-oldest-construct construct-1 construct-2)))
-        (let ((newer-construct (if (eql older-construct construct-1)
-                                   construct-2
-                                   construct-1)))
-          (dolist (ii (item-identifiers newer-construct :revision revision))
-            (delete-item-identifier newer-construct ii :revision revision)
-            (add-item-identifier older-construct ii :revision revision))
-          (let ((reifier-1 (reifier newer-construct :revision revision))
-                (reifier-2 (reifier older-construct :revision revision)))
-            (when reifier-1
-              (delete-reifier newer-construct reifier-1 :revision revision)
-              (let ((merged-reifier
-                     (if reifier-2
-                         (progn
-                           (delete-reifier older-construct reifier-2
-                                           :revision revision)
-                           (merge-constructs reifier-1 reifier-2
-                                             :revision revision))
-                         reifier-1)))
-                (add-reifier older-construct merged-reifier :revision revision))))
-          (when (and (eql (type-of newer-construct) 'ReifiableConstructC)
-                     (eql (type-of newer-construct) 'ReifiableConstructC)
-                     (typep newer-construct 'VersionedConstructC)
-                     (typep older-construct 'VersionedConstructC))
-            ;;If the older-construct is a "real" ReifiableConstructC and no sub
-            ;;class the older-construct must be marked as deleted.
-            ;;Sub classes are marked as deleted in the "next-method" calls.
-            (mark-as-deleted newer-construct :revision revision)
-            (add-to-version-history older-construct :start-revision revision))
-          older-construct))))
-
-
-(defmethod merge-constructs ((construct-1 CharacteristicC)
-                             (construct-2 CharacteristicC)
-                             &key (revision *TM-REVISION*))
-  (declare (integer revision))
-  (unless (equivalent-constructs construct-1 construct-2 :revision revision)
-    (error "From merge-constructs(): ~a and ~a are not mergable"
-           construct-1 construct-2))
-  (if (eql construct-1 construct-2)
-      construct-1
-      (let ((older-construct (call-next-method)))
-        (let ((newer-construct (if (eql older-construct construct-1)
-                                   construct-2
-                                   construct-1)))
-          (when (and (typep construct-1 'NameC) (typep construct-2 'NameC))
-            (merge-characteristics older-construct newer-construct
-                                   :revision revision
-                                   :characteristic-type 'VariantC)))
-        older-construct)))
-
-
-(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
-                             &key (revision *TM-REVISION*))
-  (declare (integer revision))
-  (if (eql construct-1 construct-2)
-      construct-1
-      (let ((older-construct (call-next-method)))
-        (let ((newer-construct (if (eql older-construct construct-1)
-                                   construct-2
-                                   construct-1)))
-          (dolist (psi (psis newer-construct :revision revision))
-            (delete-psi newer-construct psi :revision revision)
-            (add-psi older-construct psi :revision revision))
-          (dolist (locator (locators newer-construct :revision revision))
-            (delete-locator newer-construct locator :revision revision)
-            (add-locator older-construct locator :revision revision))
-          (merge-characteristics older-construct newer-construct
-                                 :revision revision
-                                 :characteristic-type 'OccurrenceC)
-          (merge-characteristics older-construct newer-construct
-                                 :revision revision
-                                 :characteristic-type 'NameC)
-          ;;player-in-roles
-          ;;used-as-type
-          ;;used-as-scope
-          ;;reified-construct
-          ;;in-topicmaps
-          ))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-