[isidorus-cvs] r263 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Apr 6 15:44:47 UTC 2010
Author: lgiessmann
Date: Tue Apr 6 11:44:47 2010
New Revision: 263
Log:
new-datamodel: replaced "merge-cosntructs" --> "NameC", "OccurrenceC", "VariantC" by a generic for "CharacteristicC"; added the generics "add-characteristic" and "delete-characteristic" for "NameC", "VariantC", "OccurrenceC"
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 Tue Apr 6 11:44:47 2010
@@ -758,6 +758,18 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric add-characteristic (construct characteristic &key revision)
+ (:documentation "Adds the passed characterisitc to the given topic by calling
+ add-name or add-occurrences.
+ Variants are added to names by calling add-name."))
+
+
+(defgeneric delete-characteristic (construct characteristic &key revision)
+ (:documentation "Deletes the passed characteristic oif the given topic by
+ calling delete-name or delete-occurrence.
+ Variants are deleted from names by calling delete-variant."))
+
+
(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"))
@@ -832,7 +844,6 @@
The latest construct is either the one with
end-revision=0 or with the highest end-revision value."))
-
(defgeneric owned-p (construct)
(:documentation "Returns t if the passed construct is referenced by a parent
TM construct."))
@@ -1638,6 +1649,24 @@
construct)))
+(defmethod add-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (add-name construct characteristic :revision revision)
+ (add-occurrence construct characteristic :revision revision)))
+
+
+(defmethod delete-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (delete-name construct characteristic :revision revision)
+ (delete-occurrence construct characteristic :revision revision)))
+
+
(defgeneric player-in-roles (construct &key revision)
(:documentation "Returns the RoleC-objects that correspond
with the passed construct and the passed version.")
@@ -2156,6 +2185,18 @@
construct)))
+(defmethod add-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (add-variant construct characteristic :revision revision))
+
+
+(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (delete-variant construct characteristic :revision revision))
+
+
;;; AssociationC
(defmethod equivalent-constructs ((construct-1 AssociationC)
(construct-2 AssociationC)
@@ -3287,33 +3328,48 @@
(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))))
+ (declare (integer revision))
+ (remove-if
+ #'null
+ (append
+ (move-identifiers source destination :revision 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 NameC) (destination NameC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (append (call-next-method)
+ (move-variants source destination :revision revision)))
(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)))
+ (typables (used-as-type source :revision revision))
+ (ids (move-identifiers source destination :revision revision)))
(dolist (role roles)
(delete-player role source :revision revision)
(add-player role destination :revision revision))
@@ -3323,7 +3379,7 @@
(dolist (typable typables)
(delete-type typable source :revision revision)
(add-type typable destination :revision revision))
- (append roles scopables typables)))
+ (remove-if #'null (append roles scopables typables ids))))
(defgeneric move-reified-construct (source destination &key revision)
@@ -3373,7 +3429,6 @@
(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))))
@@ -3399,7 +3454,6 @@
(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))))
@@ -3423,10 +3477,8 @@
destination-name))
(names destination :revision revision))))
(if equivalent-name
- (progn
- (move-variants name equivalent-name :revision revision)
+ (progn
(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))))
@@ -3467,7 +3519,6 @@
(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)
@@ -3481,52 +3532,77 @@
older-topic))))
-(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
+(defmethod merge-constructs ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC)
&key (revision *TM-REVISION*))
+ (declare (integer revision))
(if (eql construct-1 construct-2)
construct-1
- (progn
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
- (error "From merge-constructs(): ~a is not mergable with ~a"
- construct-1 construct-2))
- (let ((parent-1 (parent construct-1 :revision revision))
- (parent-2 (parent construct-2 :revision revision)))
- (when (not (and parent-1 parent-2))
- (error "From merge-constructs():~a and ~a must be associated with a topic"
- construct-1 construct-2))
- (if (and parent-1 (eql parent-1 parent-2))
- (let ((older-occ (find-oldest-construct construct-1 construct-2)))
- (let ((newer-occ (if (eql older-occ construct-1)
- construct-2
- construct-1)))
- (move-identifiers newer-occ older-occ :revision revision)
- (move-referenced-constructs newer-occ older-occ
- :revision revision)
- (delete-occurrence parent-1 construct-1 :revision revision)
- (add-occurrence parent-1 construct-2 :revision revision)
- older-occ))
- (let ((active-topic
- (merge-constructs parent-1 parent-2 :revision revision)))
- (if (find construct-1
- (occurrences active-topic :revision revision))
- construct-1
- construct-2)))))))
+ (let ((older-char (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-char (if (eql older-char construct-1)
+ construct-2
+ construct-1)))
+ (let ((parent-1 (parent older-char :revision revision))
+ (parent-2 (parent newer-char :revision revision)))
+ (unless (strictly-equivalent-constructs construct-1 construct-2
+ :revision revision)
+ (error "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2))
+ (cond ((and parent-1 (eql parent-1 parent-2))
+ (move-referenced-constructs newer-char older-char
+ :revision revision)
+ (delete-characteristic newer-char parent-2
+ :revision revision)
+ older-char)
+ ((and parent-1 parent-2)
+ (let ((active-parent (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (let ((found-older-char
+ (cond ((typep older-char 'OccurrenceC)
+ (find older-char
+ (occurrences
+ active-parent :revision revision)))
+ ((typep older-char 'NameC)
+ (find older-char
+ (names
+ active-parent :revision revision)))
+ ((typep older-char 'VariantC)
+ (find-if
+ #'(lambda(name)
+ (find older-char
+ (variants name
+ :revision revision)))
+ (names active-parent :revision revision))))))
+ (if found-older-char
+ older-char
+ newer-char))))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-char newer-char))
+ (src (if parent-1 newer-char older-char)))
+ (move-referenced-constructs src dst :revision revision)
+ dst))
+ (t
+ (move-referenced-constructs newer-char older-char
+ :revision revision)
+ older-char)))))))
+
-;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
+;TODO: merge-constructs: RoleC (merge parents and return the active role object),
+;; AssociationC, TopicMapC,
+
+
+
+
;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
&key (revision *TM-REVISION*))
@@ -3539,80 +3615,7 @@
;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
- &key (revision *TM-REVISION*))
- (declare (integer revision))
- (if (eql construct-1 construct-2)
- construct-1
- (let ((older-var (find-oldest-construct construct-1 construct-2)))
- (let ((newer-var (if (eql older-var construct-1)
- construct-2
- construct-1)))
- (let ((parent-1 (parent older-var :revision revision))
- (parent-2 (parent newer-var :revision revision)))
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
- (cond ((and parent-1 parent-2)
- (let ((active-parent
- (merge-constructs parent-1 parent-2
- :revision revision)))
- (let ((all-names (names active-parent :revision revision)))
- (if (find-if #'(lambda(name)
- (find older-var (variants name :revision
- revision)))
- all-names)
- older-var
- newer-var))))
- ((or parent-1 parent-2)
- (let ((dst (if parent-1 older-var newer-var))
- (src (if parent-1 newer-var older-var)))
- (move-identifiers src dst :revision revision)
- (move-referenced-constructs src dst :revision revision)
- dst))
- (t
- (move-identifiers newer-var older-var :revision revision)
- (move-referenced-constructs newer-var older-var
- :revision revision)
- older-var)))))))
-
-(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC)
- &key (revision *TM-REVISION*))
- (declare (integer revision))
- (if (eql construct-1 construct-2)
- construct-1
- (let ((older-name (find-oldest-construct construct-1 construct-2)))
- (let ((newer-name (if (eql older-name construct-1)
- construct-2
- construct-1)))
- (let ((parent-1 (parent older-name :revision revision))
- (parent-2 (parent newer-name :revision revision)))
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
- (cond ((and parent-1 parent-2)
- (let ((active-parent (merge-constructs parent-1 parent-2
- :revision revision)))
- (if (find older-name (names active-parent
- :revision revision))
- older-name
- newer-name)))
- ((or parent-1 parent-2)
- (let ((dst (if parent-1 older-name newer-name))
- (src (if parent-1 newer-name older-name)))
- (move-identifiers src dst :revision revision)
- (move-referenced-constructs src dst :revision revision)
- (move-variants src dst :revision revision)
- dst))
- (t
- (move-identifiers newer-name older-name :revision revision)
- (move-referenced-constructs newer-name older-name
- :revision revision)
- (move-variants newer-name older-name :revision revision)
- older-name)))))))
;TODO: --> include move-yx in move-referenced-constructs
\ No newline at end of file
More information about the Isidorus-cvs
mailing list