[isidorus-cvs] r258 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Apr 5 18:08:00 UTC 2010
Author: lgiessmann
Date: Mon Apr 5 14:07:59 2010
New Revision: 258
Log:
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
Modified:
branches/new-datamodel/src/model/datamodel.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 5 14:07:59 2010
@@ -155,6 +155,8 @@
(in-package :datamodel)
+;;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
;; "add-<construct>"/"delete-<construct>" generics
@@ -167,9 +169,7 @@
;; and a merge should be done
;;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
+
;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -758,6 +758,11 @@
;;; 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.
If a construct is not a versioned construct the oldest
@@ -855,6 +860,17 @@
;;; 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))
(let ((vi-1 (find-version-info (list construct-1)))
@@ -963,16 +979,14 @@
t)))
-(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))))
;;; TopicMapconstructC
@@ -1661,6 +1675,24 @@
(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)))
+
+
(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
@@ -1931,7 +1963,7 @@
(parent-construct ReifiableConstructC)
&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))
return parent-assoc)))
@@ -2598,13 +2630,14 @@
(merge-constructs (reifier construct :revision revision)
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
(slot-p merged-reifier-topic 'reified-construct)
@@ -2613,8 +2646,6 @@
return reifier-assoc)))
(add-to-version-history reifier-assoc
:start-revision revision)))
- (all-constructs
- (merge-constructs (first all-constructs) construct))
(t
(make-construct 'ReifierAssociationC
:reifiable-construct construct
@@ -2959,7 +2990,7 @@
(not start-revision))
(error "From make-association(): start-revision must be set"))
(let ((association
- (let ((existing-association
+ (let ((existing-associations
(remove-if
#'null
(map 'list #'(lambda(existing-association)
@@ -2970,9 +3001,12 @@
:instance-of instance-of)
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
(apply #'make-construct 'RoleC
@@ -2993,7 +3027,7 @@
(not start-revision))
(error "From make-role(): start-revision must be set"))
(let ((role
- (let ((existing-role
+ (let ((existing-roles
(when parent
(remove-if
#'null
@@ -3005,9 +3039,12 @@
:instance-of instance-of)
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))
(when parent
@@ -3038,7 +3075,7 @@
:reifier reifier)
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
(first existing-tms))
@@ -3077,7 +3114,7 @@
:topic-identifiers topic-identifiers)
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
(first existing-topics))
@@ -3205,167 +3242,265 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+;;; 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))
-;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+(defmethod move-identifiers ((source TopicC) (destination TopicC)
&key (revision *TM-REVISION*))
- (or revision)
- (if construct-1 construct-1 construct-2))
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (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)))
-(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)
+(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
- (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)))))))
+ (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)))
-(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))))
-
+(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 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
- ))))
+ (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
+;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+ &key (revision *TM-REVISION*))
+ (or revision)
+ (if construct-1 construct-1 construct-2))
-
\ No newline at end of file
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
More information about the Isidorus-cvs
mailing list