isidorus-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
April 2010
- 1 participants
- 38 discussions
Author: lgiessmann
Date: Tue Apr 6 09:42:50 2010
New Revision: 262
Log:
new-datamodel: added "merge-constructs" for "NameC" and "VariantC"
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 09:42:50 2010
@@ -876,7 +876,7 @@
(let ((vi-1 (find-version-info (list construct-1)))
(vi-2 (find-version-info (list construct-2))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -1030,7 +1030,7 @@
(let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
(vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -1858,7 +1858,7 @@
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
(vi-2 (find-version-info (slot-p construct-2 'parent))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -2278,7 +2278,7 @@
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
(vi-2 (find-version-info (slot-p construct-2 'parent))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -3536,4 +3536,83 @@
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
+;;; 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
1
0
Author: lgiessmann
Date: Tue Apr 6 02:30:26 2010
New Revision: 261
Log:
new-datamodel: optimized "merge-constructs" --> "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 02:30:26 2010
@@ -3496,12 +3496,16 @@
(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))
- (progn
- (move-identifiers construct-1 construct-2 :revision revision)
- (move-referenced-constructs construct-1 construct-2
- :revision revision)
- (delete-occurrence parent-1 construct-1 :revision revision)
- (add-occurrence parent-1 construct-2 :revision revision))
+ (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
1
0
Author: lgiessmann
Date: Mon Apr 5 16:50:11 2010
New Revision: 260
Log:
new-datamodel: added "merge-constructs" for "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 Mon Apr 5 16:50:11 2010
@@ -3459,7 +3459,6 @@
(merge-all-constructs (append found-equivalent (list construct))))))))
-
(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
&key (revision *TM-REVISION*))
(if (eql construct-1 construct-2)
@@ -3482,6 +3481,34 @@
older-topic))))
+(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
+ &key (revision *TM-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))
+ (progn
+ (move-identifiers construct-1 construct-2 :revision revision)
+ (move-referenced-constructs construct-1 construct-2
+ :revision revision)
+ (delete-occurrence parent-1 construct-1 :revision revision)
+ (add-occurrence parent-1 construct-2 :revision revision))
+ (let ((active-topic
+ (merge-constructs parent-1 parent-2 :revision revision)))
+ (if (find construct-1
+ (occurrences active-topic :revision revision))
+ construct-1
+ construct-2)))))))
+
1
0
Author: lgiessmann
Date: Mon Apr 5 16:15:44 2010
New Revision: 259
Log:
new-datamodel: fixed a bug in the declaration of "defmethod for mark-as-deleted"; fixed a bug in "merge-constructs" for "TopicC" when both merged constructs are references to the same object.
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 16:15:44 2010
@@ -979,8 +979,8 @@
t)))
-(defmethod marks-as-deleted ((construct VersionedConstructC)
- &key source-locator revision)
+(defmethod mark-as-deleted ((construct VersionedConstructC)
+ &key source-locator revision)
(declare (ignorable source-locator))
(let
((last-version ;the last active version
@@ -3462,22 +3462,24 @@
(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)))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (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))))
1
0
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
1
0
Author: lgiessmann
Date: Thu Apr 1 19:06:02 2010
New Revision: 257
Log:
new-datamodel: added the generic "merge-constructs" --> "CharacteristicC" => "OccurrenceC" + "NameC" + "VariantC"
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 Thu Apr 1 19:06:02 2010
@@ -3231,6 +3231,42 @@
;;; 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)
@@ -3258,14 +3294,38 @@
:revision revision))
reifier-1)))
(add-reifier older-construct merged-reifier :revision revision))))
- (when (eql (type-of newer-construct) 'ReifiableConstructC)
+ (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))
+ (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))
@@ -3281,8 +3341,12 @@
(dolist (locator (locators newer-construct :revision revision))
(delete-locator newer-construct locator :revision revision)
(add-locator older-construct locator :revision revision))
- ;;occurrences
- ;;names + variants
+ (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
1
0
01 Apr '10
Author: lgiessmann
Date: Thu Apr 1 16:31:29 2010
New Revision: 256
Log:
new-datamodel: added the generic "merge-constructs" --> "ReifiableConstructC"
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 Thu Apr 1 16:31:29 2010
@@ -155,6 +155,9 @@
(in-package :datamodel)
+;;TODO: check for duplicate identifiers after topic-creation/merge
+;;TODO: add: add-to-version-history (parent) to all
+;; "add-<construct>"/"delete-<construct>" generics
;;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),
@@ -3229,18 +3232,63 @@
-(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
+(defmethod merge-constructs ((construct-1 ReifiableConstructC)
+ (construct-2 ReifiableConstructC)
&key (revision *TM-REVISION*))
(declare (integer revision))
(if (eql construct-1 construct-2)
construct-1
- (progn
- (unless
- (equivalent-constructs construct-1 construct-2 :revision revision)
- (error "From merge-constructs(): the variants: ~a ~a are not mergable"
- construct-1 construct-2))
- ;;...
- )))
+ (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 (eql (type-of newer-construct) 'ReifiableConstructC)
+ ;;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))
+ 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))
+ ;;occurrences
+ ;;names + variants
+ ;;player-in-roles
+ ;;used-as-type
+ ;;used-as-scope
+ ;;reified-construct
+ ;;in-topicmaps
+ ))))
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 Thu Apr 1 16:31:29 2010
@@ -77,7 +77,6 @@
:test-find-oldest-construct))
-;;TODO: test equivalent-constructs
;;TODO: test merge-constructs
1
0
01 Apr '10
Author: lgiessmann
Date: Thu Apr 1 05:40:23 2010
New Revision: 255
Log:
new-datamodel: added the generic "find-oldest-construct" which is needed for "merge-constructs"; added unit-tests for "find-oldest-constructs" and "equivalent-constructs"; fixed a bug in "eqiuvalent-constructs" --> AssociaitonC; fixed a bug in "make-topic" which caused problems when adding topic-identifiers.
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 Thu Apr 1 05:40:23 2010
@@ -617,9 +617,23 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun find-version-info (versioned-constructs
+ &key (sort-function #'<) (sort-key 'start-revision))
+ "Returns all version-infos sorted by the function sort-function which is
+ applied on the slot sort-key."
+ (declare (list versioned-constructs))
+ (let ((vis
+ (sort
+ (loop for vc in versioned-constructs
+ append (versions vc))
+ sort-function :key sort-key)))
+ (when vis
+ (first vis))))
+
+
(defun rec-remf (plist keyword)
"Calls remf for the past plist with the given keyword until
- all key-value-pairs corresponding to the passed keyword were removed."
+ all key-value-pairs corresponding to the passed keyword were removed."
(declare (list plist) (keyword keyword))
(loop while (getf plist keyword)
do (remf plist keyword))
@@ -741,6 +755,20 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(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
+ association determines the construct's version info."))
+
+
+(defgeneric merge-constructs (construct-1 construct-2 &key revision)
+ (:documentation "Merges two constructs of the same type if they are
+ mergable. The latest construct will be marked as deleted
+ The older one gets all characteristics of the marked as
+ deleted one. All referenced constructs are also updated
+ with the changeds that are caused by this operation."))
+
+
(defgeneric delete-parent (construct parent-construct &key revision)
(:documentation "Sets the assoication-object between the passed
constructs as marded-as-deleted."))
@@ -824,6 +852,22 @@
;;; VersionedConstructC
+(defmethod find-oldest-construct ((construct-1 VersionedConstructC)
+ (construct-2 VersionedConstructC))
+ (let ((vi-1 (find-version-info (list construct-1)))
+ (vi-2 (find-version-info (list construct-2))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defgeneric VersionedConstructC-p (class-symbol)
(:documentation "Returns t if the passed class is equal to VersionedConstructC
or one of its subtypes.")
@@ -965,6 +1009,21 @@
;;; PointerC
+(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
+ (vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
&key (revision nil))
(declare (ignorable revision))
@@ -1041,7 +1100,8 @@
;;; TopicIdentificationC
-(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
+(defmethod equivalent-constructs ((construct-1 TopicIdentificationC)
+ (construct-2 TopicIdentificationC)
&key (revision nil))
(declare (ignorable revision))
(and (call-next-method)
@@ -1177,15 +1237,14 @@
(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC)
&key (revision *TM-REVISION*))
(declare (integer revision))
- (when (intersection (union
- (union (item-identifiers construct-1 :revision revision)
- (locators construct-1 :revision revision))
- (psis construct-1 :revision revision))
- (union
- (union (item-identifiers construct-2 :revision revision)
- (locators construct-2 :revision revision))
- (psis construct-2 :revision revision)))
- t))
+ (let ((ids-1 (union (union (item-identifiers construct-1 :revision revision)
+ (locators construct-1 :revision revision))
+ (psis construct-1 :revision revision)))
+ (ids-2 (union (union (item-identifiers construct-2 :revision revision)
+ (locators construct-2 :revision revision))
+ (psis construct-2 :revision revision))))
+ (when (intersection ids-1 ids-2)
+ t)))
(defgeneric TopicC-p (class-symbol)
@@ -1195,7 +1254,7 @@
(defmethod equivalent-construct ((construct TopicC)
- &key (start-revision 0) (psis nil)
+ &key (start-revision *TM-REVISION*) (psis nil)
(locators nil) (item-identifiers nil)
(topic-identifiers nil))
"Isidorus handles Topic-equality only by the topic's identifiers
@@ -1759,6 +1818,22 @@
;;; CharacteristicC
+(defmethod find-oldest-construct ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
+ (vi-2 (find-version-info (slot-p construct-2 'parent))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defmethod equivalent-constructs ((construct-1 CharacteristicC)
(construct-2 CharacteristicC)
&key (revision *TM-REVISION*))
@@ -2164,13 +2239,28 @@
;;; RoleC
+(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
+ (vi-2 (find-version-info (slot-p construct-2 'parent))))
+ (cond ((not (or vi-1 vi-2))
+ nil)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC)
&key (revision *TM-REVISION*))
(declare (integer revision))
(and (eql (instance-of construct-1 :revision revision)
(instance-of construct-2 :revision revision))
(eql (player construct-1 :revision revision)
- (player construct-1 :revision revision))))
+ (player construct-2 :revision revision))))
(defgeneric RoleC-p (class-symbol)
@@ -2455,11 +2545,6 @@
(let ((id-owner (identified-construct item-identifier
:revision revision)))
(when (not (eql id-owner construct))
- (unless (typep construct 'TopicC)
- (error (make-condition 'duplicate-identifier-error
- :message "From add-item-identifier(): duplicate ItemIdentifier has been found: ~a"
- (uri item-identifier)
- :uri (uri item-identifier))))
id-owner))))
(let ((merged-construct construct))
(cond (construct-to-be-merged
@@ -2890,7 +2975,6 @@
(apply #'make-construct 'RoleC
(append role-plist (list :parent association)))
:revision (getf role-plist :start-revision)))
- (format t "~%~%~%")
association)))
@@ -2997,6 +3081,9 @@
(t
(make-instance 'TopicC))))))
(let ((merged-topic topic))
+ (dolist (tid topic-identifiers)
+ (setf merged-topic (add-topic-identifier merged-topic tid
+ :revision start-revision)))
(dolist (psi psis)
(setf merged-topic (add-psi merged-topic psi
:revision start-revision)))
@@ -3134,9 +3221,39 @@
;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric merge-constructs(construct-1 construct-2 &key revision)
- (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
- &key (revision *TM-REVISION*))
- (or revision)
- (if construct-1 construct-1 construct-2)))
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
+(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+ &key (revision *TM-REVISION*))
+ (or revision)
+ (if construct-1 construct-1 construct-2))
+;;; 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
+ (progn
+ (unless
+ (equivalent-constructs construct-1 construct-2 :revision revision)
+ (error "From merge-constructs(): the variants: ~a ~a are not mergable"
+ construct-1 construct-2))
+ ;;...
+ )))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
\ 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 Thu Apr 1 05:40:23 2010
@@ -17,7 +17,8 @@
(:import-from :exceptions
duplicate-identifier-error)
(:import-from :constants
- *xml-string*)
+ *xml-string*
+ *xml-uri*)
(:export :run-datamodel-tests
:datamodel-test
:test-VersionInfoC
@@ -72,7 +73,8 @@
:test-make-RoleC
:test-make-TopicMapC
:test-make-AssociationC
- :test-make-TopicC))
+ :test-make-TopicC
+ :test-find-oldest-construct))
;;TODO: test equivalent-constructs
@@ -1527,13 +1529,23 @@
(test test-equivalent-PointerC ()
- "Tests the functions equivalent-construct depending on PointerC
- and its subclasses."
+ "Tests the functions equivalent-construct and strictly-equivalent-constructs
+ depending on PointerC and its subclasses."
(with-fixture with-empty-db (*db-dir*)
(let ((p-1 (make-instance 'd::PointerC :uri "p-1"))
(tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1"
:xtm-id "xtm-1"))
- (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")))
+ (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2"
+ :xtm-id "xtm-1"))
+ (tid-3 (make-instance 'd:TopicIdentificationC :uri "tid-1"
+ :xtm-id "xtm-2"))
+ (tid-4 (make-instance 'd:TopicIdentificationC :uri "tid-1"
+ :xtm-id "xtm-1"))
+ (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))
+ (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2"))
+ (psi-3 (make-instance 'd:PersistentIdC :uri "psi-1"))
+ (rev-1 100))
+ (setf *TM-REVISION* rev-1)
(is-true (d::equivalent-construct p-1 :uri "p-1"))
(is-false (d::equivalent-construct p-1 :uri "p-2"))
(is-true (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-1"))
@@ -1541,138 +1553,250 @@
(is-false (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-2"))
(is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-2"))
(is-true (d::equivalent-construct psi-1 :uri "psi-1"))
- (is-false (d::equivalent-construct psi-1 :uri "psi-2")))))
+ (is-false (d::equivalent-construct psi-1 :uri "psi-2"))
+ (is-false (d::strictly-equivalent-constructs tid-1 tid-1))
+ (is-false (d::strictly-equivalent-constructs tid-1 tid-2))
+ (is-false (d::strictly-equivalent-constructs tid-1 tid-3))
+ (is-true (d::strictly-equivalent-constructs tid-1 tid-4))
+ (is-false (d::strictly-equivalent-constructs psi-1 psi-1))
+ (is-false (d::strictly-equivalent-constructs psi-1 psi-2))
+ (is-true (d::strictly-equivalent-constructs psi-1 psi-3)))))
(test test-equivalent-OccurrenceC ()
"Tests the functions equivalent-construct depending on OccurrenceC."
(with-fixture with-empty-db (*db-dir*)
- (let ((occ-1 (make-instance 'd:OccurrenceC :charvalue "occ-1"))
- (type-1 (make-instance 'd:TopicC))
+ (let ((type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC))
- (revision-0-5 50)
- (version-1 100))
- (setf *TM-REVISION* version-1)
- (add-type occ-1 type-1)
- (add-theme occ-1 scope-1)
- (add-theme occ-1 scope-2)
- (is-true (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-2 scope-1)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-2 scope-1)
- :start-revision revision-0-5))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-2 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-3 scope-2)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-1"
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- occ-1 :charvalue "occ-2" :datatype constants:*xml-string*
- :instance-of type-1 :themes (list scope-2 scope-1))))))
+ (rev-0-5 50)
+ (rev-1 100))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-2
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-3 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list scope-3 scope-2)
+ :start-revision rev-1))
+ (occ-4 (make-construct 'OccurrenceC
+ :charvalue "occ-2"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-5 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :datatype *xml-uri*
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (occ-6 (make-construct 'OccurrenceC
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list scope-1)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-theme occ-6 scope-2)
+ (is-true (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-2 scope-1)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-2 scope-1)
+ :start-revision rev-0-5))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-2 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-3 scope-2)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-1"
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ occ-1 :charvalue "occ-2" :datatype *xml-string*
+ :instance-of type-1 :themes (list scope-2 scope-1)))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-1))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-2))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-3))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-4))
+ (is-false (d::strictly-equivalent-constructs occ-1 occ-5))
+ (is-true (d::strictly-equivalent-constructs occ-1 occ-6))))))
(test test-equivalent-NameC ()
"Tests the functions equivalent-construct depending on NameC."
(with-fixture with-empty-db (*db-dir*)
- (let ((nam-1 (make-instance 'd:NameC :charvalue "nam-1"))
- (type-1 (make-instance 'd:TopicC))
+ (let ((type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC))
- (revision-0-5 50)
- (version-1 100))
- (setf *TM-REVISION* version-1)
- (add-type nam-1 type-1)
- (add-theme nam-1 scope-1)
- (add-theme nam-1 scope-2)
- (is-true (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-1
- :themes (list scope-2 scope-1)))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-1
- :themes (list scope-2 scope-1)
- :start-revision revision-0-5))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-2
- :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-1" :instance-of type-1
- :themes (list scope-3 scope-2)))
- (is-false (d::equivalent-construct
- nam-1 :charvalue "nam-2" :instance-of type-1
- :themes (list scope-2 scope-1))))))
+ (variant-1 (make-instance 'd:VariantC))
+ (variant-2 (make-instance 'd:VariantC))
+ (rev-0-5 50)
+ (rev-1 100))
+ (let ((name-1 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (name-2 (make-construct 'NameC
+ :charvalue "name-2"
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (name-3 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-2
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (name-4 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-1
+ :themes (list scope-3 scope-2)
+ :start-revision rev-1))
+ (name-5 (make-construct 'NameC
+ :charvalue "name-1"
+ :instance-of type-1
+ :themes (list scope-2)
+ :variants (list variant-1 variant-2)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-theme name-5 scope-1)
+ (is-true (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-1
+ :themes (list scope-2 scope-1)))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-1
+ :themes (list scope-2 scope-1)
+ :start-revision rev-0-5))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-2
+ :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-1" :instance-of type-1
+ :themes (list scope-3 scope-2)))
+ (is-false (d::equivalent-construct
+ name-1 :charvalue "name-2" :instance-of type-1
+ :themes (list scope-2 scope-1)))
+ (is-false (d::strictly-equivalent-constructs name-1 name-1))
+ (is-false (d::strictly-equivalent-constructs name-1 name-2))
+ (is-false (d::strictly-equivalent-constructs name-1 name-3))
+ (is-false (d::strictly-equivalent-constructs name-1 name-4))
+ (is-true (d::strictly-equivalent-constructs name-1 name-5))))))
(test test-equivalent-VariantC ()
"Tests the functions equivalent-construct depending on VariantC."
(with-fixture with-empty-db (*db-dir*)
- (let ((var-1 (make-instance 'd:OccurrenceC :charvalue "var-1"))
- (scope-1 (make-instance 'd:TopicC))
+ (let ((scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC))
- (revision-0-5 50)
- (version-1 100))
- (setf *TM-REVISION* version-1)
- (add-theme var-1 scope-1)
- (add-theme var-1 scope-2)
- (is-true (d::equivalent-construct
- var-1 :charvalue "var-1" :datatype constants:*xml-string*
- :themes (list scope-2 scope-1)))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-1" :datatype constants:*xml-string*
- :themes (list scope-2 scope-1)
- :start-revision revision-0-5))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-1" :datatype constants:*xml-string*
- :themes (list scope-3 scope-2)))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-1"
- :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- var-1 :charvalue "var-2" :datatype constants:*xml-string*
- :themes (list scope-2 scope-1))))))
+ (rev-0-5 50)
+ (rev-1 100))
+ (let ((var-1 (make-construct 'VariantC
+ :charvalue "var-1"
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (var-2 (make-construct 'VariantC
+ :charvalue "var-2"
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (var-3 (make-construct 'VariantC
+ :charvalue "var-1"
+ :themes (list scope-1 scope-3)
+ :start-revision rev-1))
+ (var-4 (make-construct 'VariantC
+ :charvalue "var-1"
+ :datatype *xml-uri*
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (var-5 (make-construct 'VariantC
+ :charvalue "var-1"
+ :themes (list scope-1)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-theme var-5 scope-2)
+ (is-true (d::equivalent-construct
+ var-1 :charvalue "var-1" :datatype constants:*xml-string*
+ :themes (list scope-2 scope-1)))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-1" :datatype constants:*xml-string*
+ :themes (list scope-2 scope-1)
+ :start-revision rev-0-5))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-1" :datatype constants:*xml-string*
+ :themes (list scope-3 scope-2)))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-1"
+ :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ var-1 :charvalue "var-2" :datatype constants:*xml-string*
+ :themes (list scope-2 scope-1)))
+ (is-false (d::strictly-equivalent-constructs var-1 var-1))
+ (is-false (d::strictly-equivalent-constructs var-1 var-2))
+ (is-false (d::strictly-equivalent-constructs var-1 var-3))
+ (is-false (d::strictly-equivalent-constructs var-1 var-4))
+ (is-true (d::strictly-equivalent-constructs var-1 var-5))))))
(test test-equivalent-RoleC ()
"Tests the functions equivalent-construct depending on RoleC."
(with-fixture with-empty-db (*db-dir*)
- (let ((role-1 (make-instance 'd:RoleC))
- (type-1 (make-instance 'd:TopicC))
+ (let ((type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(player-1 (make-instance 'd:TopicC))
(player-2 (make-instance 'd:TopicC))
- (revision-1 100)
- (revision-2 200))
- (setf *TM-REVISION* revision-1)
- (add-type role-1 type-1)
- (add-player role-1 player-1)
- (is-true (d::equivalent-construct role-1 :player player-1
- :instance-of type-1))
- (is-false (d::equivalent-construct role-1 :player player-2
- :instance-of type-1))
- (is-false (d::equivalent-construct role-1 :player player-1
- :instance-of type-2))
- (setf *TM-REVISION* revision-2)
- (delete-player role-1 player-1 :revision revision-2)
- (add-player role-1 player-2)
- (delete-type role-1 type-1 :revision revision-2)
- (add-type role-1 type-2)
- (is-true (d::equivalent-construct role-1 :player player-2
- :instance-of type-2))
- (is-false (d::equivalent-construct role-1 :player player-1
- :instance-of type-2))
- (is-false (d::equivalent-construct role-1 :player player-2
- :instance-of type-1)))))
+ (rev-1 100)
+ (rev-2 200))
+ (let ((role-1 (make-construct 'RoleC
+ :player player-1
+ :instance-of type-1
+ :start-revision rev-1))
+ (role-2 (make-construct 'RoleC
+ :player player-2
+ :instance-of type-1
+ :start-revision rev-1))
+ (role-3 (make-construct 'RoleC
+ :player player-1
+ :instance-of type-2
+ :start-revision rev-1))
+ (role-4 (make-construct 'RoleC
+ :instance-of type-1
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-player role-4 player-1)
+ (is-true (d::equivalent-construct role-1 :player player-1
+ :instance-of type-1))
+ (is-false (d::equivalent-construct role-1 :player player-2
+ :instance-of type-1))
+ (is-false (d::equivalent-construct role-1 :player player-1
+ :instance-of type-2))
+ (is-false (d::strictly-equivalent-constructs role-1 role-1))
+ (is-false (d::strictly-equivalent-constructs role-1 role-2))
+ (is-false (d::strictly-equivalent-constructs role-1 role-3))
+ (is-true (d::strictly-equivalent-constructs role-1 role-4))
+ (setf *TM-REVISION* rev-2)
+ (delete-player role-1 player-1 :revision rev-2)
+ (add-player role-1 player-2)
+ (delete-type role-1 type-1 :revision rev-2)
+ (add-type role-1 type-2)
+ (is-true (d::equivalent-construct role-1 :player player-2
+ :instance-of type-2))
+ (is-false (d::equivalent-construct role-1 :player player-1
+ :instance-of type-2))
+ (is-false (d::equivalent-construct role-1 :player player-2
+ :instance-of type-1))))))
(test test-equivalent-AssociationC ()
@@ -1684,67 +1808,80 @@
(r-type-1 (make-instance 'TopicC))
(r-type-2 (make-instance 'TopicC))
(r-type-3 (make-instance 'TopicC))
- (revision-1 100))
- (let ((assoc-1 (make-instance 'd:AssociationC))
- (role-1 (make-construct 'd:RoleC
- :start-revision revision-1
- :player player-1
- :instance-of r-type-1))
- (role-2 (make-construct 'd:RoleC
- :start-revision revision-1
- :player player-2
- :instance-of r-type-2))
+ (rev-1 100))
+ (let ((role-1 (list :player player-1 :instance-of r-type-1
+ :start-revision rev-1))
+ (role-2 (list :player player-2 :instance-of r-type-2
+ :start-revision rev-1))
+ (role-3 (list :instance-of r-type-3 :player player-3
+ :start-revision rev-1))
(type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
(scope-1 (make-instance 'd:TopicC))
(scope-2 (make-instance 'd:TopicC))
(scope-3 (make-instance 'd:TopicC)))
- (setf *TM-REVISION* revision-1)
- (d:add-role assoc-1 role-1)
- (d:add-role assoc-1 role-2)
- (d:add-type assoc-1 type-1)
- (d:add-theme assoc-1 scope-1)
- (d:add-theme assoc-1 scope-2)
- (is-true (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1
- :start-revision revision-1)
- (list :instance-of r-type-2 :player player-2
- :start-revision revision-1))
- :instance-of type-1 :themes (list scope-1 scope-2)
- :start-revision revision-1))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-2 :player player-2)
- (list :instance-of r-type-3 :player player-3))
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1))
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-3 :player player-3))
- :instance-of type-1 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-2 :player player-2))
- :instance-of type-2 :themes (list scope-1 scope-2)))
- (is-false (d::equivalent-construct
- assoc-1 :roles (list
- (list :instance-of r-type-1 :player player-1)
- (list :instance-of r-type-2 :player player-2))
- :instance-of type-2 :themes (list scope-1 scope-3)))))))
+ (let ((assoc-1 (make-construct 'AssociationC
+ :roles (list role-1 role-2)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-2 (make-construct 'AssociationC
+ :roles (list role-1 role-2 role-3)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-3 (make-construct 'AssociationC
+ :roles (list role-1 role-3)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-4 (make-construct 'AssociationC
+ :roles (list role-1 role-2)
+ :instance-of type-2
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1))
+ (assoc-5 (make-construct 'AssociationC
+ :roles (list role-1 role-2)
+ :instance-of type-1
+ :themes (list scope-1 scope-3)
+ :start-revision rev-1))
+ (assoc-6 (make-construct 'AssociationC
+ :roles (list role-1)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (add-role assoc-6 (apply #'make-construct 'RoleC role-2))
+ (is-true (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2 role-3)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-3)
+ :instance-of type-1 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2)
+ :instance-of type-2 :themes (list scope-1 scope-2)))
+ (is-false (d::equivalent-construct
+ assoc-1 :roles (list role-1 role-2)
+ :instance-of type-2 :themes (list scope-1 scope-3)))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-1))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-2))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-3))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5))
+ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))
(test test-equivalent-TopicC ()
"Tests the functions equivalent-construct depending on TopicC."
(with-fixture with-empty-db (*db-dir*)
- (let ((top-1 (make-instance 'd:TopicC))
- (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+ (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
(ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
(sl-1 (make-instance 'd:SubjectLocatorC :uri "sl-1"))
(sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2"))
@@ -1754,43 +1891,60 @@
:xtm-id "xtm-id-1"))
(tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2"
:xtm-id "xtm-id-2"))
- (revision-1 100))
- (setf *TM-REVISION* revision-1)
- (d:add-item-identifier top-1 ii-1)
- (d:add-locator top-1 sl-1)
- (d:add-psi top-1 psi-1)
- (d:add-topic-identifier top-1 tid-1)
- (is-true (d::equivalent-construct top-1
- :item-identifiers (list ii-1 ii-2)))
- (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)
- :psis (list psi-1 psi-2)
- :item-identifiers (list ii-1 ii-2)))
- (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)))
- (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2)))
- (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1)))
- (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2)))
- (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2)
- :psis (list psi-2)
- :locators (list sl-2))))))
+ (rev-1 100))
+ (let ((top-1 (make-construct 'TopicC
+ :item-identifiers (list ii-1)
+ :locators (list sl-1)
+ :psis (list psi-1)
+ :topic-identifiers (list tid-1)
+ :start-revision rev-1))
+ (top-2 (make-construct 'TopicC
+ :item-identifiers (list ii-2)
+ :locators (list sl-2)
+ :psis (list psi-2)
+ :topic-identifiers (list tid-2)
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (is-true (d::equivalent-construct top-1
+ :item-identifiers (list ii-1 ii-2)))
+ (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)
+ :psis (list psi-1 psi-2)
+ :item-identifiers (list ii-1 ii-2)))
+ (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)))
+ (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2)))
+ (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1)))
+ (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2)))
+ (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2)
+ :psis (list psi-2)
+ :locators (list sl-2)))
+ (is-false (d::strictly-equivalent-constructs top-1 top-1))
+ (is-false (d::strictly-equivalent-constructs top-1 top-2))))))
(test test-equivalent-TopicMapC ()
"Tests the functions equivalent-construct depending on TopicMapC."
(with-fixture with-empty-db (*db-dir*)
- (let ((tm-1 (make-instance 'd:TopicMapC))
- (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+ (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
(ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
(reifier-1 (make-instance 'd:TopicC))
(reifier-2 (make-instance 'd:TopicC))
- (revision-1 100))
- (setf *TM-REVISION* revision-1)
- (d:add-item-identifier tm-1 ii-1)
- (d:add-reifier tm-1 reifier-1)
- (is-true (d::equivalent-construct tm-1
- :item-identifiers (list ii-1 ii-2)))
- (is-true (d::equivalent-construct tm-1 :reifier reifier-1))
- (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2)))
- (is-false (d::equivalent-construct tm-1 :reifier reifier-2)))))
+ (rev-1 100))
+ (let ((tm-1 (make-construct 'TopicMapC
+ :item-identifiers (list ii-1)
+ :reifier reifier-1
+ :start-revision rev-1))
+ (tm-2 (make-construct 'TopicMapC
+ :item-identifiers (list ii-2)
+ :reifier reifier-2
+ :start-revision rev-1)))
+ (setf *TM-REVISION* rev-1)
+ (is-true (d::equivalent-construct tm-1
+ :item-identifiers (list ii-1 ii-2)))
+ (is-true (d::equivalent-construct tm-1 :reifier reifier-1))
+ (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2)))
+ (is-false (d::equivalent-construct tm-1 :reifier reifier-2))
+ (is-false (d::strictly-equivalent-constructs tm-1 tm-1))
+ (is-false (d::strictly-equivalent-constructs tm-1 tm-2))))))
(test test-class-p ()
@@ -2566,6 +2720,58 @@
(is (eql (first (occurrences top-3)) occ-1))))))))
+(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)
+ (rev-2 200)
+ (rev-3 300))
+ (setf *TM-REVISION* rev-1)
+ (is-false (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-false (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-false (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-false (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))))))
+
+
(defun run-datamodel-tests()
@@ -2623,4 +2829,5 @@
(it.bese.fiveam:run! 'test-make-TopicMapC)
(it.bese.fiveam:run! 'test-make-AssociationC)
(it.bese.fiveam:run! 'test-make-TopicC)
+ (it.bese.fiveam:run! 'test-find-oldest-construct)
)
\ No newline at end of file
1
0