isidorus-cvs
Threads by month
- ----- 2025 -----
- July
- June
- May
- April
- March
- 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
- 1037 discussions
Author: lgiessmann
Date: Tue May 25 13:04:57 2010
New Revision: 294
Log:
fixed a compilation problem in the json-importer with sbcl 1.0.34.0.debian
Modified:
trunk/src/json/json_importer.lisp
Modified: trunk/src/json/json_importer.lisp
==============================================================================
--- trunk/src/json/json_importer.lisp (original)
+++ trunk/src/json/json_importer.lisp Tue May 25 13:04:57 2010
@@ -242,8 +242,8 @@
(json-to-scope (getf json-decoded-list :scopes)))
(instance-of
(psis-to-topic (getf json-decoded-list :type))))
- (declare (list json-decoded-list))
- (declare (TopicC top))
+ ;(declare (list json-decoded-list)) causes problems with sbcl 1.0.34.0.debian
+ ;(declare (TopicC top))
(unless namevalue
(error "A name must have exactly one namevalue"))
(let ((name (make-construct 'NameC
1
0
Author: lgiessmann
Date: Sun May 2 08:00:41 2010
New Revision: 293
Log:
new-datamodel: added helper-functions for creating conditions; modified all delete-<xy> methods, so the parents are now recursively added to the version-history; added to every delete-<xy> function a private one that does the same operation except adding the parent to the version history --> is needed for merging => to avoid mismatches of the versions; adapted changes.lisp except the method "changed-p" to the new datamodel
Modified:
branches/new-datamodel/src/model/changes.lisp
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/changes.lisp
==============================================================================
--- branches/new-datamodel/src/model/changes.lisp (original)
+++ branches/new-datamodel/src/model/changes.lisp Sun May 2 08:00:41 2010
@@ -21,6 +21,7 @@
(pushnew (start-revision vi) revision-set))
(sort revision-set #'<)))
+
(defun get-all-revisions-for-tm (tm-id)
"Returns an ordered set of the start dates of all revisions in the
engine for this Topic Map"
@@ -50,7 +51,7 @@
(d:identified-construct
(elephant:get-instance-by-value 'PersistentIdC
'uri
- "http://psi.topicmaps.org/iso13250/model/type-instance"))))
+ constants:*type-instance-psi*))))
(remove-if
#'(lambda(assoc)
(when (eql (instance-of assoc :revision revision)
@@ -59,41 +60,50 @@
(find-all-associations-for-topic top :revision revision))))
-(defgeneric find-referenced-topics (construct)
+(defgeneric find-referenced-topics (construct &key revision)
(:documentation "find all the topics that are references from this construct as type, scope or player, as the case may be"))
-(defmethod find-referenced-topics ((characteristic CharacteristicC))
- "characteristics are scopable + typable"
+
+(defmethod find-referenced-topics ((characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ "characteristics are scopable + typable + reifiable"
(append
- (when (reifier characteristic)
- (list (reifier characteristic)))
- (themes characteristic)
- (when (instance-of-p characteristic)
- (list (instance-of characteristic)))
+ (when (reifier characteristic :revision revision)
+ (list (reifier characteristic :revision revision)))
+ (themes characteristic :revision revision)
+ (when (instance-of-p characteristic :revision revision)
+ (list (instance-of characteristic :revision revision)))
(when (and (typep characteristic 'OccurrenceC)
(> (length (charvalue characteristic)) 0)
(eq #\# (elt (charvalue characteristic) 0)))
- (list (get-item-by-id (subseq (charvalue characteristic) 1))))))
+ (list (get-item-by-id (subseq (charvalue characteristic) 1)
+ :revision revision)))))
-(defmethod find-referenced-topics ((role RoleC))
+(defmethod find-referenced-topics ((role RoleC)
+ &key (revision *TM-REVISION*))
(append
- (when (reifier role)
- (list (reifier role)))
- (list (instance-of role))
- (list (player role))))
+ (when (reifier role :revision revision)
+ (list (reifier role :revision revision)))
+ (list (instance-of role :revision revision))
+ (list (player role :revision revision))))
+
-(defmethod find-referenced-topics ((association AssociationC))
+(defmethod find-referenced-topics ((association AssociationC)
+ &key (revision *TM-REVISION*))
"associations are scopable + typable"
(append
- (when (reifier association)
- (list (reifier association)))
- (list (instance-of association))
- (themes association)
- (mapcan #'find-referenced-topics (roles association))))
+ (when (reifier association :revision revision)
+ (list (reifier association :revision revision)))
+ (list (instance-of association :revision revision))
+ (themes association :revision revision)
+ (mapcan #'(lambda(role)
+ (find-referenced-topics role :revision revision))
+ (roles association :revision revision))))
-(defmethod find-referenced-topics ((top TopicC))
+(defmethod find-referenced-topics ((top TopicC)
+ &key (revision *TM-REVISION*))
"Part 1b of the eGov-Share spec states:
# for each topicname in T export a topic stub for each scope topic
# for each occurrence in T export a topic stub for the occurrence type (if it exists)
@@ -106,11 +116,19 @@
(remove
top
(append
- (list-instanceOf top)
- (mapcan #'find-referenced-topics (names top))
- (mapcan #'find-referenced-topics (mapcan #'variants (names top)))
- (mapcan #'find-referenced-topics (occurrences top))
- (mapcan #'find-referenced-topics (find-associations-for-topic top))))))
+ (list-instanceOf top :revision revision)
+ (mapcan #'(lambda(name)
+ (find-referenced-topics name :revision revision))
+ (names top :revision revision))
+ (mapcan #'(lambda(variant)
+ (find-referenced-topics variant :revision revision))
+ (mapcan #'variants (names top :revision revision)))
+ (mapcan #'(lambda(occ)
+ (find-referenced-topics occ :revision revision))
+ (occurrences top :revision revision))
+ (mapcan #'(lambda(assoc)
+ (find-referenced-topics assoc :revision revision))
+ (find-associations-for-topic top :revision revision))))))
(defgeneric changed-p (construct revision)
@@ -204,8 +222,8 @@
(when (changed-p top revision)
(make-instance 'FragmentC
:revision revision
- :associations (find-associations-for-topic top) ;TODO: this quite probably introduces code duplication with query: Check!
- :referenced-topics (find-referenced-topics top)
+ :associations (find-associations-for-topic top :revision revision) ;TODO: this quite probably introduces code duplication with query: Check!
+ :referenced-topics (find-referenced-topics top :revision revision)
:topic top)))
(elephant:get-instances-by-class 'TopicC))))))
@@ -220,31 +238,37 @@
(:documentation "adds an item identifier to a given construct based on the source
locator and an internally generated id (ideally a uuid)"))
+
(defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision)
- (declare (ignorable revision))
+ (declare (integer revision))
(unless
- (some (lambda (ii) (string-starts-with (uri ii) source-locator)) (item-identifiers construct))
+ (some (lambda (ii)
+ (string-starts-with (uri ii) source-locator))
+ (item-identifiers construct :revision revision))
(let
((ii-uri (format nil "~a/~d" source-locator (internal-id construct))))
- (make-instance 'ItemIdentifierC :uri ii-uri :identified-construct construct :start-revision revision))))
+ (make-construct 'ItemIdentifierC
+ :uri ii-uri
+ :identified-construct construct
+ :start-revision revision))))
+
(defmethod add-source-locator ((top TopicC) &key source-locator revision)
;topics already have the source locator in (at least) one PSI, so we
;do not need to add an extra item identifier to them. However, we
;need to do that for all their characteristics + associations
(mapc (lambda (name) (add-source-locator name :revision revision :source-locator source-locator))
- (names top))
+ (names top :revision revision))
(mapc (lambda (occ) (add-source-locator occ :revision revision :source-locator source-locator))
- (occurrences top))
+ (occurrences top :revision revision))
(mapc (lambda (ass) (add-source-locator ass :revision revision :source-locator source-locator))
- (find-associations-for-topic top)))
+ (find-associations-for-topic top :revision revision)))
(defun create-latest-fragment-of-topic (topic-psi)
"Returns the latest fragment of the passed topic-psi"
(declare (string topic-psi))
- (let ((topic
- (get-item-by-psi topic-psi)))
+ (let ((topic (get-latest-topic-by-psi topic-psi)))
(when topic
(let ((start-revision
(start-revision
@@ -269,8 +293,7 @@
(defun get-latest-fragment-of-topic (topic-psi)
"Returns the latest existing fragment of the passed topic-psi."
(declare (string topic-psi))
- (let ((topic
- (get-item-by-psi topic-psi)))
+ (let ((topic (get-latest-topic-by-psi topic-psi)))
(when topic
(let ((existing-fragments
(elephant:get-instances-by-value 'FragmentC 'topic topic)))
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Sun May 2 08:00:41 2010
@@ -160,8 +160,7 @@
(in-package :datamodel)
-;;TODO: remove-<xy> --> add to version history???
-;;TODO: adapt changes-lisp
+;;TODO: adapt changes.lisp --> changed-p
;;TODO: implement a macro with-merge-constructs, that merges constructs
;; after all operations in the body were called
@@ -251,11 +250,7 @@
:accessor uri
:inherit t
:type string
- :initform (error
- (make-condition 'missing-argument-error
- :message "From PointerC(): uri must be set for a pointer"
- :argument-symbol 'uri
- :function-symbol ':uri))
+ :initform (error (make-missing-argument-condition "From PointerC(): uri must be set for a pointer" 'uri ':uri))
:index t
:documentation "The actual value of a pointer, i.e. uri or ID.")
(identified-construct :associate (PointerAssociationC identifier)
@@ -275,11 +270,7 @@
((xtm-id :initarg :xtm-id
:accessor xtm-id
:type string
- :initform (error
- (make-condition 'missing-argument-error
- :message "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier"
- :argument-symbol 'xtm-id
- :function-symbol ':xtm-id))
+ :initform (error (make-missing-argument-condition "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" 'xtm-id ':xtm-id))
:index t
:documentation "ID of the TM this identification came from."))
(:index t)
@@ -437,21 +428,13 @@
(defpclass TypeAssociationC(VersionedAssociationC)
((type-topic :initarg :type-topic
:accessor type-topic
- :initform (error
- (make-condition 'missing-argument-error
- :message "From TypeAssociationC(): type-topic must be set"
- :argument-symbol 'type-topic
- :function-symbol ':type-topic))
+ :initform (error (make-missing-argument-condition "From TypeAssociationC(): type-topic must be set" 'type-topic ':type-topic))
:associate TopicC
:documentation "Associates this object with a topic that is used
as type.")
(typable-construct :initarg :typable-construct
:accessor typable-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From TypeAssociationC(): typable-construct must be set"
- :argument-symbol 'typable-construct
- :function-symbol ':typable-construct))
+ :initform (error (make-missing-argument-condition "From TypeAssociationC(): typable-construct must be set" 'typable-construct ':typable-construct))
:associate TypableC
:documentation "Associates this object with the typable
construct that is typed by the
@@ -464,21 +447,13 @@
(defpclass ScopeAssociationC(VersionedAssociationC)
((theme-topic :initarg :theme-topic
:accessor theme-topic
- :initform (error
- (make-condition 'missing-argument-error
- :message "From ScopeAssociationC(): theme-topic must be set"
- :argument-symbol 'theme-topic
- :function-symbol ':theme-topic))
+ :initform (error (make-missing-argument-condition "From ScopeAssociationC(): theme-topic must be set" 'theme-topic ':theme-topic))
:associate TopicC
:documentation "Associates this opbject with a topic that is a
scopable construct.")
(scopable-construct :initarg :scopable-construct
:accessor scopable-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From ScopeAssociationC(): scopable-construct must be set"
- :argument-symbol 'scopable-construct
- :function-symbol ':scopable-construct))
+ :initform (error (make-missing-argument-condition "From ScopeAssociationC(): scopable-construct must be set" 'scopable-construct ':scopable-construct))
:associate ScopableC
:documentation "Associates this object with the socpable
construct that is scoped by the
@@ -491,21 +466,13 @@
(defpclass ReifierAssociationC(VersionedAssociationC)
((reifiable-construct :initarg :reifiable-construct
:accessor reifiable-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From ReifierAssociation(): reifiable-construct must be set"
- :argument-symbol 'reifiable-construct
- :function-symbol ':reifiable-construct))
+ :initform (error (make-missing-argument-condition "From ReifierAssociation(): reifiable-construct must be set" 'reifiable-construct ':reifiable-construct))
:associate ReifiableConstructC
:documentation "The actual construct which is reified
by a topic.")
(reifier-topic :initarg :reifier-topic
:accessor reifier-topic
- :initform (error
- (make-condition 'missing-argument-error
- :message "From ReifierAssociationC(): reifier-topic must be set"
- :argument-symbol 'reifier-topic
- :function-symbol ':reifier-topic))
+ :initform (error (make-missing-argument-condition "From ReifierAssociationC(): reifier-topic must be set" 'reifier-topic ':reifier-topic))
:associate TopicC
:documentation "The reifier-topic that reifies the
reifiable-construct."))
@@ -518,11 +485,7 @@
((identifier :initarg :identifier
:accessor identifier
:inherit t
- :initform (error
- (make-condition 'missing-argument-error
- :message "From PointerAssociationC(): identifier must be set"
- :argument-symbol 'identifier
- :function-symbol ':identifier))
+ :initform (error (make-missing-argument-condition "From PointerAssociationC(): identifier must be set" 'identifier ':identifier))
:associate PointerC
:documentation "The actual data that is associated with
the pointer-association's parent."))
@@ -533,11 +496,7 @@
(defpclass SubjectLocatorAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From SubjectLocatorAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-symbol))
+ :initform (error (make-missing-argument-condition "From SubjectLocatorAssociationC(): parent-construct must be set" 'parent-construct ':parent-symbol))
:associate TopicC
:documentation "The actual topic which is associated
with the subject-locator."))
@@ -548,11 +507,7 @@
(defpclass PersistentIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From PersistentIdAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From PersistentIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:associate TopicC
:documentation "The actual topic which is associated
with the subject-identifier/psi."))
@@ -563,11 +518,7 @@
(defpclass TopicIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-arguement-error
- :message "From TopicIdAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From TopicIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:associate TopicC
:documentation "The actual topic which is associated
with the topic-identifier."))
@@ -578,11 +529,7 @@
(defpclass ItemIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From ItemIdAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From ItemIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:associate ReifiableConstructC
:documentation "The actual parent which is associated
with the item-identifier."))
@@ -595,11 +542,7 @@
((characteristic :initarg :characteristic
:accessor characteristic
:inherit t
- :initform (error
- (make-condition 'missing-argument-error
- :message "From CharacteristicCAssociation(): characteristic must be set"
- :argument-symbol 'characteristic
- :function-symbol ':characteristic))
+ :initform (error (make-missing-argument-condition "From CharacteristicCAssociation(): characteristic must be set" 'characteristic ':characteristic))
:associate CharacteristicC
:documentation "Associates this object with the actual
characteristic object."))
@@ -610,11 +553,7 @@
(defpclass VariantAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From VariantAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From VariantAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:associate NameC
:documentation "Associates this object with a name."))
(:documentation "Associates variant objects with name obejcts.
@@ -624,11 +563,7 @@
(defpclass NameAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From NameAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From NameAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:associate TopicC
:documentation "Associates this object with a topic."))
(:documentation "Associates name objects with their parent topics.
@@ -638,11 +573,7 @@
(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error
- (make-condition 'missing-argument-error
- :message "From OccurrenceAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From OccurrenceAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:associate TopicC
:documentation "Associates this object with a topic."))
(:documentation "Associates occurrence objects with their parent topics.
@@ -654,21 +585,13 @@
((player-topic :initarg :player-topic
:accessor player-topic
:associate TopicC
- :initform (error
- (make-condition 'missing-argument-error
- :message "From PlayerAssociationC(): player-topic must be set"
- :argument-symbol 'player-topic
- :function-symbol ':player-topic))
+ :initform (error (make-missing-argument-condition "From PlayerAssociationC(): player-topic must be set" 'player-topic ':player-topic))
:documentation "Associates this object with a topic that is
a player.")
(parent-construct :initarg :parent-construct
:accessor parent-construct
:associate RoleC
- :initform (error
- (make-condition 'missing-argument-error
- :message "From PlayerAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From PlayerAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:documentation "Associates this object with the parent-association."))
(:documentation "This class associates roles and their player in given
revisions."))
@@ -678,20 +601,12 @@
((role :initarg :role
:accessor role
:associate RoleC
- :initform (error
- (make-condition 'missing-argument-error
- :message "From RoleAssociationC(): role must be set"
- :argument-symbol 'role
- :function-symbol ':role))
+ :initform (error (make-missing-argument-condition "From RoleAssociationC(): role must be set" 'role ':role))
:documentation "Associates this objetc with a role-object.")
(parent-construct :initarg :parent-construct
:accessor parent-construct
:associate AssociationC
- :initform (error
- (make-condition 'missing-argument-error
- :message "From RoleAssociationC(): parent-construct must be set"
- :argument-symbol 'parent-construct
- :function-symbol ':parent-construct))
+ :initform (error (make-missing-argument-condition "From RoleAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
:documentation "Assocates thius object with an
association-object."))
(:documentation "Associates roles with assoications and adds some
@@ -699,6 +614,83 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun make-duplicate-identifier-condition (message uri)
+ "Returns an duplicate-identifier-condition with the passed arguments."
+ (make-condition 'duplicate-identifier-error
+ :message message
+ :uri uri))
+
+
+(defun make-object-not-found-condition (message)
+ "Returns an object-not-found-condition with the passed arguments."
+ (make-condition 'object-not-found-error
+ :message message))
+
+
+(defun make-tm-reference-condition (message referenced-construct
+ existing-reference new-reference)
+ "Returns a tm-reference-condition with the passed arguments."
+ (make-condition 'tm-reference-error
+ :message message
+ :referenced-construct referenced-construct
+ :existing-reference existing-reference
+ :new-reference new-reference))
+
+
+(defun make-not-mergable-condition (message construct-1 construct-2)
+ "Returns a not-mergable-condition with the passed arguments."
+ (make-condition 'not-mergable-error
+ :message message
+ :construct-1 construct-1
+ :construct-2 construct-2))
+
+
+(defun make-missing-argument-condition (message argument-symbol function-symbol)
+ "Returns a missing-argument-condition with the passed arguments."
+ (make-condition 'missing-argument-error
+ :message message
+ :argument-symbol argument-symbol
+ :function-symbol function-symbol))
+
+
+(defgeneric get-most-recent-versioned-assoc (construct slot-symbol)
+ (:documentation "Returns the most recent VersionedAssociationC
+ object.")
+ (:method ((construct TopicMapConstructC) (slot-symbol Symbol))
+ (let ((all-assocs (slot-p construct slot-symbol)))
+ (let ((zero-assoc
+ (find-if #'(lambda(assoc)
+ (= (end-revision
+ (get-most-recent-version-info assoc)) 0))
+ all-assocs)))
+ (if zero-assoc
+ zero-assoc
+ (let ((ordered-assocs
+ (sort all-assocs
+ #'(lambda(x y)
+ (> (end-revision
+ (get-most-recent-version-info x))
+ (end-revision
+ (get-most-recent-version-info y)))))))
+ (when ordered-assocs
+ (first ordered-assocs))))))))
+
+
+(defun get-latest-topic-by-psi (topic-psi)
+ "Returns the latest topic bound to the PersistentIdC
+ object corresponding to the given uri."
+ (declare (String topic-psi))
+ (let ((psi-inst
+ (elephant:get-instance-by-value
+ 'PersistentIdC 'uri topic-psi)))
+ (let ((latest-va
+ (get-most-recent-versioned-assoc
+ psi-inst 'identified-construct)))
+ (when latest-va
+ (identified-construct
+ psi-inst :revision (start-revision latest-va))))))
+
+
(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*))
"Returns all instances of the given type and the given revision that are
stored in the db."
@@ -905,12 +897,18 @@
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
+(defgeneric private-delete-characteristic (construct characteristic &key revision)
+ (:documentation "Deletes the passed characteristic of the given topic by
calling delete-name or delete-occurrence.
Variants are deleted from names by calling delete-variant."))
+(defgeneric delete-characteristic (construct characteristic &key revision)
+ (:documentation "See private-delete-characteristic but adds the parent
+ (if it is a variant also the parent's parent) to the
+ version history of this call's revision"))
+
+
(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
@@ -925,11 +923,16 @@
with the changeds that are caused by this operation."))
-(defgeneric delete-parent (construct parent-construct &key revision)
+(defgeneric parent-delete-parent (construct parent-construct &key revision)
(:documentation "Sets the assoication-object between the passed
constructs as marded-as-deleted."))
+(defgeneric delete-parent (construct parent-construct &key revision)
+ (:documentation "See private-delete-parent but adds the parent to
+ the given version."))
+
+
(defgeneric add-parent (construct parent-construct &key revision)
(:documentation "Adds the parent-construct (TopicC or NameC) in form of
a corresponding association to the given object."))
@@ -1083,14 +1086,37 @@
construct)))
+(defun add-version-info(construct start-revision)
+ "Adds 'construct' to the given version.
+ If the construct is a VersionedConstructC add-to-version-history
+ is called directly. Otherwise there is called a corresponding
+ add-<whatever> method that adds recursively 'construct' to its
+ parent and so on."
+ (declare (type (or TopicMapConstructC VersionedConstructC) construct)
+ (integer start-revision))
+ (cond ((typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision start-revision))
+ ((typep construct 'VariantC)
+ (let ((name (parent construct :revision start-revision)))
+ (when name
+ (add-variant name construct :revision start-revision)
+ (let ((top (parent name :revision start-revision)))
+ (when top
+ (add-name top name :revision start-revision))))))
+ ((typep construct 'CharacteristicC)
+ (let ((top (parent construct :revision start-revision)))
+ (when top
+ (add-characteristic top construct :revision start-revision))))
+ ((typep construct 'RoleC)
+ (let ((assoc (parent construct :revision start-revision)))
+ (when assoc
+ (add-role assoc construct :revision start-revision))))))
+
+
(defgeneric add-to-version-history (construct &key start-revision end-revision)
(:documentation "Adds version history to a versioned construct")
(:method ((construct VersionedConstructC)
- &key (start-revision (error
- (make-condition 'missing-argument-error
- :message "From add-to-version-history(): start revision must be present"
- :argument-symbol 'start-revision
- :function-symbol 'add-to-version-history)))
+ &key (start-revision (error (make-missing-argument-condition "From add-to-version-history(): start revision must be present" 'start-revision 'add-to-version-history)))
(end-revision 0))
(let ((eql-version-info
(find-if #'(lambda(vi)
@@ -1189,13 +1215,13 @@
(let ((owner (identified-construct construct :revision 0)))
(when owner
(cond ((typep construct 'PersistentIdC)
- (delete-psi owner construct :revision revision))
+ (private-delete-psi owner construct :revision revision))
((typep construct 'SubjectLocatorC)
- (delete-locator owner construct :revision revision))
+ (private-delete-locator owner construct :revision revision))
((typep construct 'ItemIdentifierC)
- (delete-item-identifier owner construct :revision revision))
+ (private-delete-item-identifier owner construct :revision revision))
((typep construct 'TopicIdentificationC)
- (delete-topic-identifier owner construct :revision revision))))))
+ (private-delete-topic-identifier owner construct :revision revision))))))
(defmethod marked-as-deleted-p ((construct PointerC))
@@ -1562,11 +1588,7 @@
(string= (xtm-id top-id) xtm-id))
(topic-identifiers construct :revision revision))))
(unless possible-identifiers
- (error (make-condition
- 'object-not-found-error
- :message
- (format nil "Could not find an object ~a in xtm-id ~a"
- construct xtm-id))))
+ (error (make-object-not-found-condition (format nil "Could not find an object ~a in xtm-id ~a" construct xtm-id))))
(uri (first possible-identifiers)))
(concatenate 'string "t" (write-to-string (internal-id construct))))))
@@ -1616,20 +1638,29 @@
merged-construct))))
-(defgeneric delete-topic-identifier (construct topic-identifier &key revision)
+(defgeneric private-delete-topic-identifier
+ (construct topic-identifier &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-topic-identifier(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-topic-identifier))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-topic-identifier(): revision must be set" 'revision 'private-delete-topic-identifier))))
(let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers)
when (eql (identifier ti-assoc) topic-identifier)
return ti-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history construct :start-revision revision))
+ construct))))
+
+
+(defgeneric delete-topic-identifier
+ (construct topic-identifier &key revision)
+ (:documentation "See private-delete-topic-identifier but adds the parent
+ construct to the given version")
+ (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+ &key (revision (error (make-missing-argument-condition "From delete-topic-identifier(): revision must be set" 'revision 'delete-topic-identifier))))
+ (when (private-delete-topic-identifier construct topic-identifier
+ :revision revision)
+ (add-to-version-history construct :start-revision revision)
construct)))
@@ -1675,20 +1706,26 @@
merged-construct))))
-(defgeneric delete-psi (construct psi &key revision)
+(defgeneric private-delete-psi (construct psi &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (psi PersistentIdC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-psi(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-psi))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-psi(): revision must be set" 'revision 'private-delete-psi))))
(let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis)
when (eql (identifier psi-assoc) psi)
return psi-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history construct :start-revision revision))
+ construct))))
+
+
+(defgeneric delete-psi (construct psi &key revision)
+ (:documentation "See private-delete-psis but adds the parent to the given
+ version.")
+ (:method ((construct TopicC) (psi PersistentIdC)
+ &key (revision (error (make-missing-argument-condition "From delete-psi(): revision must be set" 'revision 'delete-psi))))
+ (when (private-delete-psi construct psi :revision revision)
+ (add-to-version-history construct :start-revision revision)
construct)))
@@ -1735,20 +1772,26 @@
merged-construct))))
-(defgeneric delete-locator (construct locator &key revision)
+(defgeneric private-delete-locator (construct locator &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (locator SubjectLocatorC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-locator(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-locator))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-locator(): revision must be set" 'revision 'private-delete-locator))))
(let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators)
when (eql (identifier loc-assoc) locator)
return loc-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history construct :start-revision revision))
+ construct))))
+
+
+(defgeneric delete-locator (construct locator &key revision)
+ (:documentation "See private-delete-locator but add the parent construct
+ to the given version.")
+ (:method ((construct TopicC) (locator SubjectLocatorC)
+ &key (revision (error (make-missing-argument-condition "From delete-locator(): revision must be set" 'revision 'delete-locator))))
+ (when (private-delete-locator construct locator :revision revision)
+ (add-to-version-history construct :start-revision revision)
construct)))
@@ -1779,12 +1822,9 @@
&key (revision *TM-REVISION*))
(when (and (parent name :revision revision)
(not (eql (parent name :revision revision) construct)))
- (error (make-condition 'tm-reference-error
- :message (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
- name construct (parent name :revision revision))
- :referenced-construct name
- :existing-reference (parent name :revision revision)
- :new-reference construct)))
+ (error (make-tm-reference-condition (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ name construct (parent name :revision revision))
+ name (parent name :revision revision) construct)))
(if (merge-if-equivalent name construct :revision revision)
construct
(let ((all-names
@@ -1804,20 +1844,26 @@
construct))))
-(defgeneric delete-name (construct name &key revision)
+(defgeneric private-delete-name (construct name &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (name NameC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-name(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-name))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-name(): revision must be set" 'revision 'private-delete-name))))
(let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
when (eql (characteristic name-assoc) name)
return name-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history construct :start-revision revision))
+ construct))))
+
+
+(defgeneric delete-name (construct name &key revision)
+ (:documentation "See private-delete-name but adds the parent to
+ the given version.")
+ (:method ((construct TopicC) (name NameC)
+ &key (revision (error (make-missing-argument-condition "From delete-name(): revision must be set" 'revision 'delete-name))))
+ (when (private-delete-name construct name :revision revision)
+ (add-to-version-history construct :start-revision revision)
construct)))
@@ -1840,12 +1886,9 @@
&key (revision *TM-REVISION*))
(when (and (parent occurrence :revision revision)
(not (eql (parent occurrence :revision revision) construct)))
- (error 'tm-reference-error
- :message (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
- occurrence construct (parent occurrence :revision revision))
- :referenced-construct occurrence
- :existing-reference (parent occurrence :revision revision)
- :new-reference construct))
+ (error (make-tm-reference-condition (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ occurrence construct (parent occurrence :revision revision))
+ occurrence (parent occurrence :revision revision) construct)))
(if (merge-if-equivalent occurrence construct :revision revision)
construct
(let ((all-occurrences
@@ -1864,20 +1907,26 @@
construct))))
-(defgeneric delete-occurrence (construct occurrence &key revision)
+(defgeneric private-delete-occurrence (construct occurrence &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (occurrence OccurrenceC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-occurrence(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-construct))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-occurrence(): revision must be set" 'revision 'private-delete-occurrence))))
(let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
when (eql (characteristic occ-assoc) occurrence)
return occ-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history construct :start-revision revision))
+ construct))))
+
+
+(defgeneric delete-occurrence (construct occurrence &key revision)
+ (:documentation "See private-delete-occurrence but adds the parent
+ to the given version history.")
+ (:method ((construct TopicC) (occurrence OccurrenceC)
+ &key (revision (error (make-missing-argument-condition "From delete-occurrence(): revision must be set" 'revision 'delete-occurrence))))
+ (when (private-delete-occurrence construct occurrence :revision revision)
+ (add-to-version-history construct :start-revision revision)
construct)))
@@ -1890,9 +1939,19 @@
(add-occurrence construct characteristic :revision revision)))
+(defmethod private-delete-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic))))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (private-delete-name construct characteristic :revision revision)
+ (private-delete-occurrence construct characteristic
+ :revision revision)))
+
+
(defmethod delete-characteristic ((construct TopicC)
(characteristic CharacteristicC)
- &key (revision *TM-REVISION*))
+ &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic))))
(declare (integer revision) (type (or NameC OccurrenceC) characteristic))
(if (typep characteristic 'NameC)
(delete-name construct characteristic :revision revision)
@@ -1945,11 +2004,22 @@
(add-reifier reified-construct construct :revision revision)))
-(defgeneric delete-reified-construct (construct reified-construct &key revision)
+(defgeneric private-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*))
+ &key (revision (error (make-missing-argument-condition "From private-delete-reified-construct(): revision must be set" 'revision 'private-delete-reified-construct))))
+ (declare (integer revision))
+ (private-delete-reifier reified-construct construct
+ :revision revision)))
+
+
+(defgeneric delete-reified-construct (construct reified-construct &key revision)
+ (:documentation "See private-delete-reified-construct but adds the
+ reifier to the given version.")
+ (:method ((construct TopicC) (reified-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From -delete-reified-construct(): revision must be set" 'revision '-delete-reified-construct))))
(declare (integer revision))
(delete-reifier reified-construct construct :revision revision)))
@@ -1984,11 +2054,7 @@
(identified-construct (first possible-top-ids)
:revision revision))
(unless (= (length possible-top-ids) 1)
- (error
- (make-condition 'duplicate-identifier-error
- :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
- possible-top-ids topic-id xtm-id)
- :uri topic-id)))
+ (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" possible-top-ids topic-id xtm-id) topic-id)))
(identified-construct (first possible-top-ids)
:revision revision)
;no revision need not to be chaecked, since the revision
@@ -2004,9 +2070,7 @@
(when (find-item-by-revision top-from-oid revision)
top-from-oid))))))
(if (and error-if-nil (not result))
- (error (make-condition 'object-not-found-error
- :message (format nil "No such item (id: ~a, tm: ~a, rev: ~a)"
- topic-id xtm-id revision)))
+ (error (make-object-not-found-condition (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)))
result)))
@@ -2025,10 +2089,7 @@
(identified-construct (first possible-ids)
:revision revision))
(unless (= (length possible-ids) 1)
- (error (make-condition 'duplicate-identifier-error
- :message (format nil "(length possible-items ~a) for id ~a"
- possible-ids uri)
- :uri uri)))
+ (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri)))
(identified-construct (first possible-ids)
:revision revision)))))
;no revision need to be checked, since the revision
@@ -2036,8 +2097,7 @@
(if result
result
(when error-if-nil
- (error (make-condition 'object-not-found-error
- :message "No such item is bound to the given identifier uri."))))))
+ (error (make-object-not-found-condition "No such item is bound to the given identifier uri."))))))
(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*)
@@ -2123,7 +2183,7 @@
(declare (ignorable source-locator))
(let ((owner (parent construct :revision 0)))
(when owner
- (delete-characteristic owner construct :revision revision))))
+ (private-delete-characteristic owner construct :revision revision))))
(defmethod marked-as-deleted-p ((construct CharacteristicC))
@@ -2273,12 +2333,9 @@
return parent-assoc)))
(when (and already-set-parent
(not (eql already-set-parent parent-construct)))
- (error (make-condition 'tm-reference-error
- :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
construct parent-construct already-set-parent)
- :referenced-construct construct
- :existing-reference (parent construct :revision revision)
- :new-reference parent-construct)))
+ construct (parent construct :revision revision) parent-construct)))
(let ((merged-char
(merge-if-equivalent construct parent-construct :revision revision)))
(if merged-char
@@ -2311,21 +2368,26 @@
construct)))))
-(defmethod delete-parent ((construct CharacteristicC)
- (parent-construct ReifiableConstructC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-parent(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-parent))))
+(defmethod private-delete-parent ((construct CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent))))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
when (eql (parent-construct parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (when (typep parent-construct 'VersionedConstructC)
- (add-to-version-history parent-construct :start-revision revision)))
- construct))
+ construct)))
+
+
+(defmethod delete-parent ((construct CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent))))
+ (let ((parent (parent construct :revision revision)))
+ (when (private-delete-parent construct parent-construct :revision revision)
+ (when parent
+ (add-version-info parent revision))
+ construct)))
;;; OccurrenceC
@@ -2461,12 +2523,9 @@
&key (revision *TM-REVISION*))
(when (and (parent variant :revision revision)
(not (eql (parent variant :revision revision) construct)))
- (error (make-condition 'tm-reference-error
- :message (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
- variant construct (parent variant :revision revision))
- :referenced-construct variant
- :existing-reference (parent variant :revision revision)
- :new-reference construct)))
+ (error (make-tm-reference-condition (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
+ variant construct (parent variant :revision revision))
+ variant (parent variant :revision revision) construct)))
(if (merge-if-equivalent variant construct :revision revision)
construct
(let ((all-variants
@@ -2487,21 +2546,30 @@
construct))))
-(defgeneric delete-variant (construct variant &key revision)
+(defgeneric private-delete-variant (construct variant &key revision)
(:documentation "Deletes the passed variant by marking it's association as
deleted in the passed revision.")
(:method ((construct NameC) (variant VariantC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-variant(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-variant))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-variant(): revision must be set" 'revision 'private-delete-variant))))
(let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
'variants)
when (eql (characteristic variant-assoc) variant)
return variant-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- construct)))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-variant (construct variant &key revision)
+ (:documentation "See private-delete-variant but adds a the parent
+ and the parent's parent to the given version history.")
+ (:method ((construct NameC) (variant VariantC)
+ &key (revision (error (make-missing-argument-condition "From delete-variant(): revision must be set" 'revision 'delete-variant))))
+ (when (private-delete-variant construct variant :revision revision)
+ (when (parent construct :revision revision)
+ (add-name (parent construct :revision revision) construct
+ :revision revision)
+ construct))))
(defmethod add-characteristic ((construct NameC) (characteristic VariantC)
@@ -2510,8 +2578,14 @@
(add-variant construct characteristic :revision revision))
-(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
- &key (revision *TM-REVISION*))
+(defmethod private-delete-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic))))
+ (declare (integer revision))
+ (private-delete-variant construct characteristic :revision revision))
+
+
+(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic))))
(declare (integer revision))
(delete-variant construct characteristic :revision revision))
@@ -2631,20 +2705,26 @@
construct))))
-(defgeneric delete-role (construct role &key revision)
+(defgeneric private-delete-role (construct role &key revision)
(:documentation "Deletes the passed role by marking it's association as
deleted in the passed revision.")
(:method ((construct AssociationC) (role RoleC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-role(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-role))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-role(): revision must be set" 'revision 'private-delete-role))))
(let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles)
when (eql (role role-assoc) role)
return role-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history construct :start-revision revision))
+ construct))))
+
+
+(defgeneric delete-role (construct role &key revision)
+ (:documentation "See private-delete-role but adds the parent association
+ to the given version.")
+ (:method ((construct AssociationC) (role RoleC)
+ &key (revision (error (make-missing-argument-condition "From delete-role(): revision must be set" 'revision 'delete-role))))
+ (when (private-delete-role construct role :revision revision)
+ (add-to-version-history construct :start-revision revision)
construct)))
@@ -2659,7 +2739,7 @@
(declare (ignorable source-locator))
(let ((owner (parent construct :revision 0)))
(when owner
- (delete-role owner construct :revision revision))))
+ (private-delete-role owner construct :revision revision))))
(defmethod marked-as-deleted-p ((construct RoleC))
@@ -2803,12 +2883,9 @@
return parent-assoc)))
(when (and already-set-parent
(not (eql already-set-parent parent-construct)))
- (error (make-condition 'tm-reference-error
- :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
- construct parent-construct already-set-parent)
- :referenced-construct construct
- :existing-reference (parent construct :revision revision)
- :new-reference parent-construct)))
+ (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ construct parent-construct already-set-parent)
+ construct (parent construct :revision revision) parent-construct)))
(let ((merged-role
(merge-if-equivalent construct parent-construct :revision revision)))
(if merged-role
@@ -2834,18 +2911,21 @@
construct)))))
-(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-parent(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-parent))))
+(defmethod private-delete-parent ((construct RoleC) (parent-construct AssociationC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent))))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
when (eql (parent-construct parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (add-to-version-history parent-construct :start-revision revision))
+ construct)))
+
+
+(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
+ &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent))))
+ (when (private-delete-parent construct parent-construct :revision revision)
+ (add-to-version-history parent-construct :start-revision revision)
construct))
@@ -2871,12 +2951,8 @@
return player-assoc)))
(when (and already-set-player
(not (eql already-set-player player-topic)))
- (error (make-condition 'tm-reference-error
- :message (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a"
- construct player-topic already-set-player)
- :referenced-construct construct
- :existing-reference (player construct :revision revision)
- :new-reference player-topic)))
+ (error (make-tm-reference-condition (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player)
+ construct (player construct :revision revision) player-topic)))
(cond (already-set-player
(let ((player-assoc
(loop for player-assoc in (slot-p construct 'player)
@@ -2893,21 +2969,30 @@
construct))
-(defgeneric delete-player (construct player-topic &key revision)
+(defgeneric private-delete-player (construct player-topic &key revision)
(:documentation "Deletes the passed topic as a player of the passed role
object by marking its association-object as deleted.")
(:method ((construct RoleC) (player-topic TopicC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-parent(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-player))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-player(): revision must be set" 'revision 'private-delete-player))))
(let ((assoc-to-delete
(loop for player-assoc in (slot-p construct 'player)
when (eql (parent-construct player-assoc) construct)
return player-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- construct)))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-player (construct player-topic &key revision)
+ (:documentation "See delete-player but adds the parent role to
+ the given version.")
+ (:method ((construct RoleC) (player-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From delete-player(): revision must be set" 'revision 'delete-player))))
+ (when (private-delete-player construct player-topic :revision revision)
+ (let ((assoc (parent construct :revision revision)))
+ (when assoc
+ (add-role assoc construct :revision revision)
+ construct)))))
;;; ReifiableConstructC
@@ -2917,7 +3002,7 @@
(declare (ignorable source-locator))
(call-next-method)
(dolist (ii (item-identifiers construct :revision 0))
- (delete-item-identifier construct ii :revision revision)))
+ (private-delete-item-identifier construct ii :revision revision)))
(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)
@@ -2932,10 +3017,7 @@
(elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
(elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
1)
- (error
- (make-condition 'duplicate-identifier-error
- :message (format nil "Duplicate Identifier ~a has been found" (uri id))
- :uri (uri id))))))
+ (error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id))))))
(defgeneric ReifiableConstructC-p (class-symbol)
@@ -3047,34 +3129,33 @@
:parent-construct construct
:identifier item-identifier
:start-revision revision)))
- (cond ((typep merged-construct 'VersionedConstructC)
- (add-to-version-history merged-construct :start-revision revision))
- ((and (typep merged-construct 'CharacteristicC)
- (parent merged-construct :revision revision))
- (add-characteristic (parent merged-construct :revision revision)
- merged-construct :revision revision))
- ((and (typep merged-construct 'RoleC)
- (parent merged-construct :revision revision))
- (add-role (parent merged-construct :revision revision)
- merged-construct :revision revision)))
+ (add-version-info construct revision)
merged-construct))))
-(defgeneric delete-item-identifier (construct item-identifier &key revision)
+(defgeneric private-delete-item-identifier (construct item-identifier
+ &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-item-identifier(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-item-identifier))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-item-identifier(): revision must be set" 'revision 'private-delete-item-identifier))))
(let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers)
when (eql (identifier ii-assoc) item-identifier)
return ii-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history construct :start-revision revision)))
+ construct))))
+
+
+(defgeneric delete-item-identifier (construct item-identifier
+ &key revision)
+ (:documentation "See private-delete-item-identifier but adds the parent
+ construct to the given version.")
+ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
+ &key (revision (error (make-missing-argument-condition "From delete-item-identifier(): revision must be set" 'revision 'delete-item-identifier))))
+ (when (private-delete-item-identifier construct item-identifier
+ :revision revision)
+ (add-version-info construct revision)
construct)))
@@ -3090,11 +3171,9 @@
(not (equivalent-constructs construct
(reified-construct
reifier-topic :revision revision))))
- (error (make-condition 'not-mergable-error
- :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable"
- reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct)
- :construct-1 construct
- :construct-2 (reified-construct reifier-topic :revision revision))))
+ (error (make-not-mergable-condition (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable"
+ reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct)
+ construct (reified-construct reifier-topic :revision revision))))
(let ((merged-reifier-topic
(if (reifier construct :revision revision)
(merge-constructs (reifier construct :revision revision)
@@ -3123,26 +3202,30 @@
:reifiable-construct construct
:reifier-topic merged-reifier-topic
:start-revision revision)))
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history merged-construct :start-revision revision))
+ (add-version-info construct revision)
merged-construct)))))
-(defgeneric delete-reifier (construct reifier &key revision)
+(defgeneric private-delete-reifier (construct reifier &key revision)
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct ReifiableConstructC) (reifier TopicC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-reifier(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-reifier))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-reifier(): revision must be set" 'revision 'private-delete-reifier))))
(let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier)
when (eql (reifier-topic reifier-assoc) reifier)
return reifier-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision)
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history construct :start-revision revision)))
+ construct))))
+
+
+(defgeneric delete-reifier (construct reifier &key revision)
+ (:documentation "See private-delete-reifier but adds the reified-construct
+ to the given version.")
+ (:method ((construct ReifiableConstructC) (reifier TopicC)
+ &key (revision (error (make-missing-argument-condition "From delete-reifier(): revision must be set" 'revision 'delete-reifier))))
+ (when (private-delete-reifier construct reifier :revision revision)
+ (add-version-info construct revision)
construct)))
@@ -3249,21 +3332,26 @@
construct))
-(defgeneric delete-theme (construct theme-topic &key revision)
+(defgeneric private-delete-theme (construct theme-topic &key revision)
(:documentation "Deletes the passed theme by marking it's association as
deleted in the passed revision.")
(:method ((construct ScopableC) (theme-topic TopicC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-theme(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-theme))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-theme(): revision must be set" 'revision 'private-delete-theme))))
(let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
when (eql (theme-topic theme-assoc) theme-topic)
return theme-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history construct :start-revision revision))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-theme (construct theme-topic &key revision)
+ (:documentation "See private-delete-theme but adds the parent construct
+ to the given version.")
+ (:method ((construct ScopableC) (theme-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From delete-theme(): revision must be set" 'revision 'delete-theme))))
+ (when (private-delete-theme construct theme-topic :revision revision)
+ (add-version-info construct revision)
construct)))
@@ -3305,12 +3393,9 @@
return type-assoc)))
(when (and already-set-type
(not (eql type-topic already-set-type)))
- (error (make-condition 'tm-reference-error
- :message (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
- construct type-topic already-set-type)
- :referenced-construct construct
- :existing-reference (instance-of construct :revision revision)
- :new-reference type-topic)))
+ (error (make-tm-reference-condition (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
+ construct type-topic already-set-type)
+ construct (instance-of construct :revision revision) type-topic)))
(cond (already-set-type
(let ((type-assoc
(loop for type-assoc in (slot-p construct 'instance-of)
@@ -3329,22 +3414,27 @@
construct))
-(defgeneric delete-type (construct type-topic &key revision)
+(defgeneric private-delete-type (construct type-topic &key revision)
(:documentation "Deletes the passed type by marking it's association as
deleted in the passed revision.")
(:method ((construct TypableC) (type-topic TopicC)
- &key (revision (error (make-condition 'missing-argument-error
- :message "From delete-type(): revision must be set"
- :argument-symbol 'revision
- :function-symbol 'delete-type))))
+ &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type))))
(let ((assoc-to-delete
(loop for type-assoc in (slot-p construct 'instance-of)
when (eql (type-topic type-assoc) type-topic)
return type-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history construct :start-revision revision))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-type (construct type-topic &key revision)
+ (:documentation "See private-delete-type but adds the parent construct
+ to the given version.")
+ (:method ((construct TypableC) (type-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type))))
+ (when (private-delete-type construct type-topic :revision revision)
+ (add-version-info construct revision)
construct)))
@@ -3425,10 +3515,7 @@
(and (ReifiableConstructC-p class-symbol)
(or (getf args :item-identifiers) (getf args :reifier))))
(not (getf args :start-revision)))
- (error (make-condition 'missing-argument-error
- :message "From make-construct(): start-revision must be set"
- :argument-symbol 'start-revision
- :function-symbol 'make-construct)))
+ (error (make-missing-argument-condition "From make-construct(): start-revision must be set" 'start-revision 'make-construct)))
(let ((construct
(cond
((PointerC-p class-symbol)
@@ -3476,10 +3563,7 @@
(roles (getf args :roles)))
(when (and (or roles instance-of themes)
(not start-revision))
- (error (make-condition 'missing-argument-error
- :message "From make-association(): start-revision must be set"
- :argument-symbol 'start-revision
- :function-symbol 'make-association)))
+ (error (make-missing-argument-condition "From make-association(): start-revision must be set" 'start-revision 'make-association)))
(let ((association
(let ((existing-associations
(remove-if
@@ -3517,10 +3601,7 @@
(start-revision (getf args :start-revision)))
(when (and (or instance-of player parent)
(not start-revision))
- (error (make-condition 'missing-argument-error
- :message "From make-role(): start-revision must be set"
- :argument-symbol 'start-revision
- :function-symbol 'make-role)))
+ (error (make-missing-argument-condition "From make-role(): start-revision must be set" 'start-revision 'make-role)))
(let ((role
(let ((existing-roles
(when parent
@@ -3562,10 +3643,7 @@
(start-revision (getf args :start-revision)))
(when (and (or item-identifiers reifier)
(not start-revision))
- (error (make-condition 'missing-argument-error
- :message "From make-tm(): start-revision must be set"
- :argument-symbol 'start-revision
- :function-symbol 'make-tm)))
+ (error (make-missing-argument-condition "From make-tm(): start-revision must be set" 'start-revision 'make-tm)))
(let ((tm
(let ((existing-tms
(remove-if
@@ -3603,10 +3681,7 @@
(when (and (or psis locators item-identifiers topic-identifiers
names occurrences)
(not start-revision))
- (error (make-condition 'missing-argument-error
- :message "From make-topic(): start-revision must be set"
- :argument-symbol 'start-revision
- :function-symbol 'make-topic)))
+ (error (make-missing-argument-condition "From make-topic(): start-revision must be set" 'start-revision 'make-topic)))
(let ((topic
(let ((existing-topics
(remove-if
@@ -3662,10 +3737,7 @@
(parent (getf args :parent)))
(when (and (or instance-of themes variants parent)
(not start-revision))
- (error (make-condition 'missing-argument-error
- :message "From make-characteristic(): start-revision must be set"
- :argument-symbol 'start-revision
- :function-symbol 'make-characgteristic)))
+ (error (make-missing-argument-condition "From make-characteristic(): start-revision must be set" 'start-revision 'make-characgteristic)))
(let ((characteristic
(let ((existing-characteristics
(when parent
@@ -3708,21 +3780,12 @@
(identified-construct (getf args :identified-construct))
(err "From make-pointer(): "))
(when (and identified-construct (not start-revision))
- (error (make-condition 'missing-argument-error
- :message (format nil "~astart-revision must be set" err)
- :argument-symbol 'start-revision
- :function-symbol 'make-pointer)))
+ (error (make-missing-argument-condition (format nil "~astart-revision must be set" err) 'start-revision 'make-pointer)))
(unless uri
- (error (make-condition 'missing-argument-error
- :message (format nil "~auri must be set" err)
- :argument-symbol 'uri
- :function-symbol 'make-pointer)))
+ (error (make-missing-argument-condition (format nil "~auri must be set" err) 'uri 'make-pointer)))
(when (and (TopicIdentificationC-p class-symbol)
(not xtm-id))
- (error (make-condition 'missing-argument-error
- :message (format nil "~axtm-id must be set" err)
- :argument-symbol 'xtm-id
- :function-symbol 'make-pointer)))
+ (error (make-missing-argument-condition (format nil "~axtm-id must be set" err) 'xtm-id 'make-pointer)))
(let ((identifier
(let ((existing-pointer
(remove-if
@@ -3763,7 +3826,7 @@
(declare (integer revision))
(let ((iis (item-identifiers source :revision revision)))
(dolist (ii iis)
- (delete-item-identifier source ii :revision revision)
+ (private-delete-item-identifier source ii :revision revision)
(add-item-identifier destination ii :revision revision))
iis))
@@ -3776,13 +3839,13 @@
(psis (psis source :revision revision))
(sls (locators source :revision revision)))
(dolist (tid tids)
- (delete-topic-identifier source tid :revision revision)
+ (private-delete-topic-identifier source tid :revision revision)
(add-topic-identifier destination tid :revision revision))
(dolist (psi psis)
- (delete-psi source psi :revision revision)
+ (private-delete-psi source psi :revision revision)
(add-psi destination psi :revision revision))
(dolist (sl sls)
- (delete-locator source sl :revision revision)
+ (private-delete-locator source sl :revision revision)
(add-locator destination sl :revision revision))
(append tids iis psis sls)))
@@ -3804,10 +3867,10 @@
(destination-reifier (reifier destination :revision revision)))
(let ((result
(cond ((and source-reifier destination-reifier)
- (delete-reifier (reified-construct source-reifier
+ (private-delete-reifier (reified-construct source-reifier
:revision revision)
source-reifier :revision revision)
- (delete-reifier (reified-construct destination-reifier
+ (private-delete-reifier (reified-construct destination-reifier
:revision revision)
destination-reifier :revision revision)
(let ((merged-reifier
@@ -3816,7 +3879,7 @@
(add-reifier destination merged-reifier :revision revision)
merged-reifier))
(source-reifier
- (delete-reifier (reified-construct source-reifier
+ (private-delete-reifier (reified-construct source-reifier
:revision revision)
source-reifier :revision revision)
(add-reifier destination source-reifier :revision revision)
@@ -3842,13 +3905,13 @@
(typables (used-as-type source :revision revision))
(ids (move-identifiers source destination :revision revision)))
(dolist (role roles)
- (delete-player role source :revision revision)
+ (private-delete-player role source :revision revision)
(add-player role destination :revision revision))
(dolist (scopable scopables)
- (delete-theme scopable source :revision revision)
+ (private-delete-theme scopable source :revision revision)
(add-theme scopable destination :revision revision))
(dolist (typable typables)
- (delete-type typable source :revision revision)
+ (private-delete-type typable source :revision revision)
(add-type typable destination :revision revision))
(remove-if #'null (append roles scopables typables ids))))
@@ -3864,21 +3927,19 @@
(when (and source-reified destination-reified
(not (eql (type-of source-reified)
(type-of destination-reified))))
- (error (make-condition 'not-mergable-error
- :message (format nil "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)
- :construct-1 source
- :construct-2 destination)))
+ (error (make-not-mergable-condition (format nil "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)
+ source destination)))
(cond ((and source-reified destination-reified)
- (delete-reifier source-reified source :revision revision)
- (delete-reifier destination-reified destination :revision revision)
+ (private-delete-reifier source-reified source :revision revision)
+ (private-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)
+ (private-delete-reifier source source-reified :revision revision)
(add-reifier source-reified destination :revision revision)
source-reified)
(destination-reified
@@ -3894,7 +3955,7 @@
(declare (integer revision))
(let ((occs-to-move (occurrences source :revision revision)))
(dolist (occ occs-to-move)
- (delete-occurrence source occ :revision revision)
+ (private-delete-occurrence source occ :revision revision)
(let ((equivalent-occ
(find-if #'(lambda (destination-occ)
(when
@@ -3919,7 +3980,7 @@
(declare (integer revision))
(let ((vars-to-move (variants source :revision revision)))
(dolist (var vars-to-move)
- (delete-variant source var :revision revision)
+ (private-delete-variant source var :revision revision)
(let ((equivalent-var
(find-if #'(lambda (destination-var)
(when
@@ -3944,7 +4005,7 @@
(declare (integer revision))
(let ((names-to-move (names source :revision revision)))
(dolist (name names-to-move)
- (delete-name source name :revision revision)
+ (private-delete-name source name :revision revision)
(let ((equivalent-name
(find-if #'(lambda (destination-name)
(when
@@ -4060,15 +4121,12 @@
(parent-2 (parent newer-char :revision revision)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error (make-condition 'not-mergable-error
- :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2)
- :construct-1 construct-1
- :construct-2 construct-2)))
+ (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
+ construct-1 construct-2)))
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-char older-char
:revision revision)
- (delete-characteristic parent-2 newer-char
+ (private-delete-characteristic parent-2 newer-char
:revision revision)
(let ((c-assoc
(find-if
@@ -4158,14 +4216,11 @@
(themes construct-2 :revision revision))
(not (eql (instance-of construct-1 :revision revision)
(instance-of construct-2 :revision revision))))
- (error (make-condition 'not-mergable-error
- :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2)
- :construct-1 construct-1
- :construct-2 construct-2)))
+ (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
+ construct-1 construct-2)))
(dolist (tm (in-topicmaps newer-assoc :revision revision))
(add-to-tm tm older-assoc))
- (delete-type newer-assoc (instance-of newer-assoc :revision revision)
+ (private-delete-type newer-assoc (instance-of newer-assoc :revision revision)
:revision revision)
(move-referenced-constructs newer-assoc older-assoc)
(dolist (newer-role (roles newer-assoc :revision revision))
@@ -4177,7 +4232,7 @@
(when equivalent-role
(move-referenced-constructs newer-role equivalent-role
:revision revision))
- (delete-role newer-assoc newer-role :revision revision)
+ (private-delete-role newer-assoc newer-role :revision revision)
(add-role older-assoc (if equivalent-role
equivalent-role
newer-role)
@@ -4199,17 +4254,14 @@
construct-1)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error (make-condition 'not-mergable-error
- :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2)
- :construct-1 construct-1
- :construct-2 construct-2)))
+ (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
+ construct-1 construct-2)))
(let ((parent-1 (parent older-role :revision revision))
(parent-2 (parent newer-role :revision revision)))
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-role older-role
:revision revision)
- (delete-role parent-2 newer-role :revision revision)
+ (private-delete-role parent-2 newer-role :revision revision)
(let ((r-assoc
(find-if
#'(lambda(r-assoc)
1
0
29 Apr '10
Author: lgiessmann
Date: Thu Apr 29 11:07:06 2010
New Revision: 292
Log:
new-datamodel: fixed two bugs in "merge-constructs" corresponding to "AssociationC"
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 29 11:07:06 2010
@@ -4149,8 +4149,15 @@
(let ((newer-assoc (if (eql older-assoc construct-1)
construct-2
construct-1)))
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
+ ;(unless (strictly-equivalent-constructs construct-1 construct-2
+ ; :revision revision)
+ ;;associations that have different roles can be although merged, e.g.
+ ;;two roles are in two different association objects references
+ ;;the same item-identifier or reifier
+ (when (or (set-exclusive-or (themes construct-1 :revision revision)
+ (themes construct-2 :revision revision))
+ (not (eql (instance-of construct-1 :revision revision)
+ (instance-of construct-2 :revision revision))))
(error (make-condition 'not-mergable-error
:message (format nil "From merge-constructs(): ~a and ~a are not mergable"
construct-1 construct-2)
@@ -4158,6 +4165,8 @@
:construct-2 construct-2)))
(dolist (tm (in-topicmaps newer-assoc :revision revision))
(add-to-tm tm older-assoc))
+ (delete-type newer-assoc (instance-of newer-assoc :revision revision)
+ :revision revision)
(move-referenced-constructs newer-assoc older-assoc)
(dolist (newer-role (roles newer-assoc :revision revision))
(let ((equivalent-role
@@ -4165,10 +4174,14 @@
(strictly-equivalent-constructs
older-role newer-role :revision revision))
(roles older-assoc :revision revision))))
- (move-referenced-constructs newer-role equivalent-role
- :revision revision)
+ (when equivalent-role
+ (move-referenced-constructs newer-role equivalent-role
+ :revision revision))
(delete-role newer-assoc newer-role :revision revision)
- (add-role older-assoc equivalent-role :revision revision)))
+ (add-role older-assoc (if equivalent-role
+ equivalent-role
+ newer-role)
+ :revision revision)))
(mark-as-deleted newer-assoc :revision revision)
(when (exist-in-version-history-p newer-assoc)
(delete-construct newer-assoc))
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 29 11:07:06 2010
@@ -90,7 +90,8 @@
:test-merge-constructs-TopicC-7
:test-merge-constructs-TopicC-8
:test-merge-constructs-TopicC-9
- :test-merge-constructs-TopicC-10))
+ :test-merge-constructs-TopicC-10
+ :test-merge-constructs-AssociationC))
(declaim (optimize (debug 3)))
@@ -2938,7 +2939,7 @@
(test test-merge-constructs-TopicC-1 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3051,7 +3052,7 @@
(test test-merge-constructs-TopicC-2 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3165,7 +3166,7 @@
(test test-merge-constructs-TopicC-3 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-3 300))
@@ -3265,7 +3266,7 @@
(test test-merge-constructs-TopicC-4 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-3 300))
@@ -3323,7 +3324,7 @@
(test test-merge-constructs-TopicC-5 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-3 300))
@@ -3381,7 +3382,7 @@
(test test-merge-constructs-TopicC-6 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3452,7 +3453,7 @@
(test test-merge-constructs-TopicC-7 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3521,7 +3522,7 @@
(test test-merge-constructs-TopicC-8 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3587,7 +3588,7 @@
(test test-merge-constructs-TopicC-9 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3641,7 +3642,7 @@
(test test-merge-constructs-TopicC-10 ()
- "Tests the generic move-referenced-constructs corresponding to TopicC."
+ "Tests the generic merge-constructs corresüponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
(rev-2 200)
@@ -3716,12 +3717,82 @@
(is-false (set-exclusive-or (list variant-1) (variants name-1)))
(is-false (set-exclusive-or (list variant-2) (variants name-4)))
(is (= (length (d::versions top-1)) 2))))))))
-
-
-
-;;TODO: merge associations caused by a merge of their roles
+(test test-merge-constructs-AssociationC ()
+ "Tests merge-constructs corresponding to AssociationC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (r-type-1 (make-construct 'TopicC :start-revision rev-1))
+ (r-type-2 (make-construct 'TopicC :start-revision rev-1))
+ (player-1 (make-construct 'TopicC :start-revision rev-1))
+ (player-2 (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
+ (let ((role-1 (list :start-revision rev-1
+ :player player-1
+ :instance-of r-type-1))
+ (role-2-1 (list :start-revision rev-1
+ :player player-1
+ :instance-of r-type-2))
+ (role-2-2 (list :start-revision rev-2
+ :player player-1
+ :item-identifiers (list ii-2)
+ :instance-of r-type-2))
+ (role-3 (list :start-revision rev-2
+ :player player-2
+ :instance-of r-type-1
+ :item-identifiers (list ii-1)
+ :instance-of r-type-2)))
+ (let ((assoc-1 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of type-1
+ :roles (list role-1 role-2-1)))
+ (assoc-2 (make-construct 'AssociationC
+ :start-revision rev-2
+ :instance-of type-1
+ :roles (list role-2-2 role-3))))
+ (setf *TM-REVISION* rev-3)
+ (is (= (length (get-all-associations nil)) 2))
+ (make-construct 'AssociationC
+ :start-revision rev-2
+ :instance-of type-1
+ :roles (list role-1 role-2-1))
+ (is (= (length (get-all-associations nil)) 2))
+ (let ((role-2-1-inst
+ (find-if #'(lambda(role)
+ (and (eql (instance-of role) r-type-2)
+ (eql (player role) player-1)))
+ (roles assoc-1))))
+ (is-true role-2-1-inst)
+ (is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst))
+ (is-true (marked-as-deleted-p assoc-2))
+ (is-false (roles assoc-2))
+ (is-false (instance-of assoc-2))
+ (is-false (themes assoc-2))
+ (is (eql (instance-of assoc-2 :revision rev-2) type-1))
+ (is (= (length (roles assoc-1)) 3))
+ (is-true (find-if #'(lambda(role)
+ (and (eql (instance-of role) r-type-1)
+ (eql (player role) player-1)))
+ (roles assoc-1)))
+ (is-true (find-if #'(lambda(role)
+ (and (eql (instance-of role) r-type-1)
+ (eql (player role) player-2)
+ (not (set-exclusive-or
+ (list ii-1)
+ (item-identifiers role)))))
+ (roles assoc-1)))
+ (is-true (find-if #'(lambda(role)
+ (and (eql (instance-of role) r-type-2)
+ (eql (player role) player-1)
+ (not (set-exclusive-or
+ (list ii-2)
+ (item-identifiers role)))))
+ (roles assoc-1))))))))))
(defun run-datamodel-tests()
@@ -3792,4 +3863,4 @@
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-9)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-10)
- )
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-merge-constructs-AssociationC))
\ No newline at end of file
1
0
29 Apr '10
Author: lgiessmann
Date: Thu Apr 29 06:47:46 2010
New Revision: 291
Log:
new-datamodel: fixed a bug when merging topics by adding an item-identifier to two different variants of the topic's names that are mergable
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 29 06:47:46 2010
@@ -4101,7 +4101,10 @@
(find older-char
(variants name
:revision revision)))
- (names active-parent :revision revision))))))
+ (if (parent active-parent :revision revision)
+ (names (parent active-parent :revision revision)
+ :revision revision)
+ (list active-parent)))))))
(if found-older-char
older-char
newer-char))))
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 29 06:47:46 2010
@@ -89,13 +89,8 @@
:test-merge-constructs-TopicC-6
:test-merge-constructs-TopicC-7
:test-merge-constructs-TopicC-8
- :test-merge-constructs-TopicC-9))
-
-
-;;TODO: test merge-constructs --> associations when merge was caused by
-;; item-identifier of two roles
-;;TODO: test mark-as-deleted
-
+ :test-merge-constructs-TopicC-9
+ :test-merge-constructs-TopicC-10))
(declaim (optimize (debug 3)))
@@ -3644,8 +3639,87 @@
(is-false (set-exclusive-or (list occ-2) (occurrences top-2))))))))
-;;TODO: merge topics caused by variant-item-identifiers
-;;TODO: merge associations caused by a merge of their characteristics
+
+(test test-merge-constructs-TopicC-10 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+ (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :psis (list psi-1)))
+ (top-2 (make-construct 'TopicC
+ :start-revision rev-2
+ :psis (list psi-2)))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (scope-1 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((name-1 (make-construct 'NameC
+ :start-revision rev-1
+ :instance-of nil
+ :charvalue "name"
+ :themes (list scope-1)
+ :item-identifiers (list ii-1)
+ :parent top-1))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-1
+ :instance-of type-1
+ :charvalue "name"
+ :themes (list scope-1)
+ :parent top-1))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-2
+ :instance-of nil
+ :charvalue "name"
+ :themes (list scope-1)
+ :item-identifiers (list ii-2)
+ :parent top-2))
+ (name-4 (make-construct 'NameC
+ :start-revision rev-2
+ :instance-of type-1
+ :charvalue "name"
+ :themes nil
+ :parent top-2)))
+ (let ((variant-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "variant"
+ :themes (list scope-1)
+ :item-identifiers (list ii-3 ii-4)
+ :parent name-1))
+ (variant-2 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "variant"
+ :themes (list scope-1)
+ :parent name-4))
+ (variant-3 (make-construct 'VariantC
+ :start-revision rev-2
+ :charvalue "variant"
+ :themes (list scope-1)
+ :parent name-3)))
+ (setf *TM-REVISION* rev-3)
+ (signals not-mergable-error (add-item-identifier variant-2 ii-4))
+ (is-false (marked-as-deleted-p top-2))
+ (is-false (marked-as-deleted-p top-1))
+ (is-false (marked-as-deleted-p name-4))
+ (is (eql (add-item-identifier variant-3 ii-4) variant-1))
+ (is-true (marked-as-deleted-p top-2))
+ (is-false (names top-2))
+ (is-false (psis top-2))
+ (is-false (set-exclusive-or (list name-1 name-2 name-4) (names top-1)))
+ (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
+ (is-false (set-exclusive-or (list variant-1) (variants name-1)))
+ (is-false (set-exclusive-or (list variant-2) (variants name-4)))
+ (is (= (length (d::versions top-1)) 2))))))))
+
+
+
+;;TODO: merge associations caused by a merge of their roles
@@ -3717,4 +3791,5 @@
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-7)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-9)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10)
)
\ No newline at end of file
1
0
29 Apr '10
Author: lgiessmann
Date: Thu Apr 29 06:17:20 2010
New Revision: 290
Log:
new-datamodel: fixed a problem when topic-merging was caused by reifying the same "ReifiableConstructC"; fixed a bug when two topics are merged and every of these topics reifies a construct that can't be merged with the other one.
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 29 06:17:20 2010
@@ -3086,6 +3086,15 @@
the reified-constructs are merged.")
(:method ((construct ReifiableConstructC) (reifier-topic TopicC)
&key (revision *TM-REVISION*))
+ (when (and (reified-construct reifier-topic :revision revision)
+ (not (equivalent-constructs construct
+ (reified-construct
+ reifier-topic :revision revision))))
+ (error (make-condition 'not-mergable-error
+ :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable"
+ reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct)
+ :construct-1 construct
+ :construct-2 (reified-construct reifier-topic :revision revision))))
(let ((merged-reifier-topic
(if (reifier construct :revision revision)
(merge-constructs (reifier construct :revision revision)
@@ -3852,7 +3861,9 @@
(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))
+ (when (and source-reified destination-reified
+ (not (eql (type-of source-reified)
+ (type-of destination-reified))))
(error (make-condition 'not-mergable-error
:message (format nil "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)
@@ -3868,10 +3879,10 @@
merged-reified))
(source-reified
(delete-reifier source source-reified :revision revision)
- (add-reifier destination source-reified :revision revision)
+ (add-reifier source-reified destination :revision revision)
source-reified)
(destination-reified
- (add-reifier destination destination-reified :revision revision)
+ (add-reifier destination-reified destination :revision revision)
destination-reified)))))
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 29 06:17:20 2010
@@ -88,7 +88,8 @@
:test-merge-constructs-TopicC-5
:test-merge-constructs-TopicC-6
:test-merge-constructs-TopicC-7
- :test-merge-constructs-TopicC-8))
+ :test-merge-constructs-TopicC-8
+ :test-merge-constructs-TopicC-9))
;;TODO: test merge-constructs --> associations when merge was caused by
@@ -3554,12 +3555,96 @@
(setf *TM-REVISION* rev-3)
(signals not-mergable-error (add-reifier occ-3 reifier-1))
(is (eql (add-reifier occ-2 reifier-1) occ-1))
+ (is-false (set-exclusive-or (list occ-1 occ-3) (occurrences top-1)))
(is-true (marked-as-deleted-p top-2))
- (is-true (marked-as-deleted-p occ-2)))))))
+ (is-true (marked-as-deleted-p occ-2))
+ (is (= (length (d::versions top-1)) 2))
+ (is (= (length (d::versions top-2)) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::end-revision vi) rev-3)
+ (= (d::start-revision vi) rev-1)))
+ (d::versions top-1)))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::end-revision vi) 0)
+ (= (d::start-revision vi) rev-3)))
+ (d::versions top-1)))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::end-revision vi) rev-3)
+ (= (d::start-revision vi) rev-2)))
+ (d::versions top-2)))
+ (is (= (length (slot-value occ-2 'd::parent)) 1))
+ (is (= (length (slot-value occ-1 'd::parent)) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::end-revision vi) rev-3)
+ (= (d::start-revision vi) rev-2)))
+ (first (map 'list #'d::versions
+ (slot-value occ-2 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::end-revision vi) rev-3)
+ (= (d::start-revision vi) rev-1)))
+ (first (map 'list #'d::versions
+ (slot-value occ-1 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::end-revision vi) 0)
+ (= (d::start-revision vi) rev-3)))
+ (first (map 'list #'d::versions
+ (slot-value occ-1 'd::parent))))))))))
+
+
+(test test-merge-constructs-TopicC-9 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (rev-4 400)
+ (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+ (psi-2 (make-construct 'PersistentIdC :uri "psi-2")))
+ (let ((top-1 (make-construct 'TopicC :start-revision rev-2
+ :psis (list psi-2)))
+ (top-2 (make-construct 'TopicC :start-revision rev-2))
+ (top-3 (make-construct 'TopicC :start-revision rev-1))
+ (reifier-1 (make-construct 'TopicC :start-revision rev-1))
+ (reifier-2 (make-construct 'TopicC :start-revision rev-2
+ :psis (list psi-1)))
+ (reifier-3 (make-construct 'TopicC :start-revision rev-1))
+ (reifier-4 (make-construct 'TopicC :start-revision rev-1))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :instance-of type-1
+ :charvalue "occ"
+ :reifier reifier-1
+ :parent top-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :instance-of type-2
+ :charvalue "occ"
+ :reifier reifier-3
+ :parent top-2))
+ (occ-3 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :instance-of type-1
+ :charvalue "occ"
+ :reifier reifier-4
+ :parent top-3)))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (reifier occ-2) reifier-3))
+ (signals not-mergable-error (add-reifier occ-1 reifier-3))
+ (is (eql occ-1 (add-reifier occ-1 reifier-2)))
+ (is-true (marked-as-deleted-p reifier-2))
+ (is-false (set-exclusive-or (list psi-1) (psis reifier-1)))
+ (setf *TM-REVISION* rev-4)
+ (is (eql (add-reifier occ-1 reifier-4) occ-3))
+ (is-true (marked-as-deleted-p top-1))
+ (is-false (marked-as-deleted-p top-3))
+ (is-false (set-exclusive-or (list psi-2) (psis top-3)))
+ (is-false (marked-as-deleted-p top-2))
+ (is-false (set-exclusive-or (list occ-2) (occurrences top-2))))))))
;;TODO: merge topics caused by variant-item-identifiers
-;;TODO: mrege topics caused by reifying the same reified-construct
;;TODO: merge associations caused by a merge of their characteristics
@@ -3631,4 +3716,5 @@
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-6)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-7)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9)
)
\ No newline at end of file
1
0
Author: lgiessmann
Date: Wed Apr 28 05:35:03 2010
New Revision: 289
Log:
json-exporter: fixed a bug in the function "get-all-topics"
Modified:
trunk/src/json/json_exporter.lisp
Modified: trunk/src/json/json_exporter.lisp
==============================================================================
--- trunk/src/json/json_exporter.lisp (original)
+++ trunk/src/json/json_exporter.lisp Wed Apr 28 05:35:03 2010
@@ -298,8 +298,10 @@
(remove-if #'null (map 'list #'(lambda(psi-list)
(when psi-list
(map 'list #'uri psi-list)))
- (clean-topics
- (elephant:get-instances-by-class 'TopicC))))))
+ (map 'list
+ #'d:psis
+ (clean-topics
+ (elephant:get-instances-by-class 'TopicC)))))))
(defun to-json-string-summary (topic)
1
0
27 Apr '10
Author: lgiessmann
Date: Tue Apr 27 15:51:47 2010
New Revision: 288
Log:
new-datamodel: fixed bugs in the function: "add-item-identifier", "add-variant" and "make-topic"; added new unit-tests
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 Tue Apr 27 15:51:47 2010
@@ -98,7 +98,7 @@
:charvalue
:reified-construct
:mark-as-deleted
- :mark-as-deleted-p
+ :marked-as-deleted-p
:in-topicmaps
:delete-construct
:get-revision
@@ -152,6 +152,7 @@
:get-all-associations
:get-all-tms
+
;;globals
:*TM-REVISION*
:*CURRENT-XTM*))
@@ -159,11 +160,8 @@
(in-package :datamodel)
+;;TODO: remove-<xy> --> add to version history???
;;TODO: adapt changes-lisp
-;;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),
-;; add-psi, add-locator (--> duplicate-identifier-error)
;;TODO: implement a macro with-merge-constructs, that merges constructs
;; after all operations in the body were called
@@ -2483,6 +2481,9 @@
:characteristic variant
:parent-construct construct
:start-revision revision))
+ (when (parent construct :revision revision)
+ (add-name (parent construct :revision revision) construct
+ :revision revision))
construct))))
@@ -3046,8 +3047,16 @@
:parent-construct construct
:identifier item-identifier
:start-revision revision)))
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history merged-construct :start-revision revision))
+ (cond ((typep merged-construct 'VersionedConstructC)
+ (add-to-version-history merged-construct :start-revision revision))
+ ((and (typep merged-construct 'CharacteristicC)
+ (parent merged-construct :revision revision))
+ (add-characteristic (parent merged-construct :revision revision)
+ merged-construct :revision revision))
+ ((and (typep merged-construct 'RoleC)
+ (parent merged-construct :revision revision))
+ (add-role (parent merged-construct :revision revision)
+ merged-construct :revision revision)))
merged-construct))))
@@ -3086,9 +3095,11 @@
(slot-p reifier-topic 'reified-construct))))
(let ((merged-construct construct))
(cond ((reified-construct merged-reifier-topic :revision revision)
- (merge-constructs
- (reified-construct merged-reifier-topic :revision revision)
- construct))
+ (let ((merged-reified
+ (merge-constructs
+ (reified-construct merged-reifier-topic
+ :revision revision) construct)))
+ (setf merged-construct merged-reified)))
((find construct all-constructs)
(let ((reifier-assoc
(loop for reifier-assoc in
@@ -3578,7 +3589,8 @@
(item-identifiers (getf args :item-identifiers))
(topic-identifiers (getf args :topic-identifiers))
(names (getf args :names))
- (occurrences (getf args :occurrences)))
+ (occurrences (getf args :occurrences))
+ (reified-construct (getf args :refied-construct)))
(when (and (or psis locators item-identifiers topic-identifiers
names occurrences)
(not start-revision))
@@ -3620,6 +3632,9 @@
:revision start-revision)))
(dolist (occ occurrences)
(add-occurrence merged-topic occ :revision start-revision))
+ (when reified-construct
+ (add-reified-construct merged-topic reified-construct
+ :revision start-revision))
merged-topic))))
@@ -3724,26 +3739,6 @@
(add-locator identified-construct identifier
:revision start-revision))))
identifier)))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 Tue Apr 27 15:51:47 2010
@@ -86,10 +86,13 @@
:test-merge-constructs-TopicC-3
:test-merge-constructs-TopicC-4
:test-merge-constructs-TopicC-5
- :test-merge-constructs-TopicC-6))
+ :test-merge-constructs-TopicC-6
+ :test-merge-constructs-TopicC-7
+ :test-merge-constructs-TopicC-8))
-;;TODO: test merge-constructs
+;;TODO: test merge-constructs --> associations when merge was caused by
+;; item-identifier of two roles
;;TODO: test mark-as-deleted
@@ -3452,13 +3455,113 @@
"ii-1")))))))))
+(test test-merge-constructs-TopicC-7 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+ (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
+ (tid-1 (make-construct 'TopicIdentificationC
+ :uri "tid-1" :xtm-id "xtm-1"))
+ (tid-2 (make-construct 'TopicIdentificationC
+ :uri "tid-2" :xtm-id "xtm-2"))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (scope-1 (make-construct 'TopicC :start-revision rev-1))
+ (scope-2 (make-construct 'TopicC :start-revision rev-1))
+ (top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :psis (list psi-1)
+ :topic-identifiers (list tid-1)))
+ (top-2 (make-construct 'TopicC
+ :start-revision rev-2
+ :locators (list sl-1)
+ :topic-identifiers (list tid-2))))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-1)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :charvalue "occ"
+ :parent top-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :item-identifiers (list ii-2)
+ :instance-of type-1
+ :themes (list scope-1 scope-2)
+ :charvalue "occ"
+ :parent top-2))
+ (occ-3 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-3)
+ :instance-of type-1
+ :themes (list scope-1)
+ :charvalue "occ"
+ :parent top-1)))
+ (setf *TM-REVISION* rev-3)
+ (is (= (length (get-all-topics rev-1)) 4))
+ (is (= (length (get-all-topics rev-3)) 5))
+ (is (= (length (d::get-db-instances-by-class
+ 'd::OccurrenceC :revision nil)) 3))
+ (signals not-mergable-error (add-item-identifier occ-3 ii-1))
+ (is (eql occ-1 (add-item-identifier occ-1 ii-2)))
+ (is (= (length (get-all-topics rev-3)) 4))
+ (is-true (d::marked-as-deleted-p occ-2))
+ (is-true (d::marked-as-deleted-p top-2))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers occ-1)))
+ (is-false (item-identifiers occ-2))
+ (is-false (set-exclusive-or (list ii-2)
+ (item-identifiers occ-2 :revision rev-2)))
+ (is-false (set-exclusive-or (list psi-1) (psis top-1)))
+ (is-false (set-exclusive-or (list sl-1) (locators top-1)))
+ (is-false (set-exclusive-or (list tid-1 tid-2)
+ (topic-identifiers top-1)))
+ (is-false (locators top-2)))))))
+(test test-merge-constructs-TopicC-8 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (let ((top-1 (make-construct 'TopicC :start-revision rev-1))
+ (top-2 (make-construct 'TopicC :start-revision rev-2))
+ (reifier-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :instance-of type-1
+ :charvalue "occ"
+ :reifier reifier-1
+ :parent top-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :instance-of type-1
+ :charvalue "occ"
+ :parent top-2))
+ (occ-3 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :instance-of type-2
+ :charvalue "occ"
+ :parent top-1)))
+ (setf *TM-REVISION* rev-3)
+ (signals not-mergable-error (add-reifier occ-3 reifier-1))
+ (is (eql (add-reifier occ-2 reifier-1) occ-1))
+ (is-true (marked-as-deleted-p top-2))
+ (is-true (marked-as-deleted-p occ-2)))))))
+
+;;TODO: merge topics caused by variant-item-identifiers
+;;TODO: mrege topics caused by reifying the same reified-construct
+;;TODO: merge associations caused by a merge of their characteristics
-;;TODO: merge topics/associations caused by a merge of their characteristics
-;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified
-;; by the same reifier
@@ -3526,4 +3629,6 @@
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-4)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-5)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-6)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
)
\ No newline at end of file
1
0
Author: lgiessmann
Date: Fri Apr 23 15:51:28 2010
New Revision: 287
Log:
new-datamodel: fixed a versioningproblem in "merge-constructs" --> CharacteristicC
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 Fri Apr 23 15:51:28 2010
@@ -159,9 +159,6 @@
(in-package :datamodel)
-;;TODO: replace add-<xy> + add-parent in all merge-constructs where the
-;; characteristics are readded to make sure they are added to the current
-;; version --> collidates with merge-if-equivalent!!! in merge-constructs
;;TODO: adapt changes-lisp
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
@@ -4067,6 +4064,18 @@
:revision revision)
(delete-characteristic parent-2 newer-char
:revision revision)
+ (let ((c-assoc
+ (find-if
+ #'(lambda(c-assoc)
+ (and (eql (characteristic c-assoc) older-char)
+ (eql (parent-construct c-assoc) parent-1)))
+ (cond ((typep older-char 'OccurrenceC)
+ (slot-p parent-1 'occurrences))
+ ((typep older-char 'NameC)
+ (slot-p parent-1 'names))
+ ((typep older-char 'VariantC)
+ (slot-p parent-1 'variants))))))
+ (add-to-version-history c-assoc :start-revision revision))
older-char)
((and parent-1 parent-2)
(let ((active-parent (merge-constructs parent-1 parent-2
@@ -4185,7 +4194,8 @@
(and (eql (role r-assoc) older-role)
(eql (parent-construct r-assoc) parent-1)))
(slot-p parent-1 'roles))))
- (add-to-version-history r-assoc :start-revision revision)))
+ (add-to-version-history r-assoc :start-revision revision)
+ older-role))
((and parent-1 parent-2)
(let ((active-assoc (merge-constructs parent-1 parent-2
:revision revision)))
1
0
23 Apr '10
Author: lgiessmann
Date: Fri Apr 23 14:47:37 2010
New Revision: 286
Log:
new-datamodel: fixed an elephant bug that appears in the current version --> "get-instances-by-class" is embraced within a function that filters all instances by typep and optional a given revision; fixed a potential versioning bug in "merge-all-constructs"; fixed a bug in "equivalent-construct" --> AssociationC; fixed a bug in "merge-changed-constructs"; fixed a bug in "merge-constructs" --> the returned association object is added to the union of all tms the given associations were present in; added some unit-tests
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 Fri Apr 23 14:47:37 2010
@@ -148,6 +148,9 @@
:check-for-duplicate-identifiers
:find-item-by-content
:rec-remf
+ :get-all-topics
+ :get-all-associations
+ :get-all-tms
;;globals
:*TM-REVISION*
@@ -156,10 +159,10 @@
(in-package :datamodel)
-
-;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
-;; versioned-construct of the called construct, same for add-xy ???
-;; and associations of player
+;;TODO: replace add-<xy> + add-parent in all merge-constructs where the
+;; characteristics are readded to make sure they are added to the current
+;; version --> collidates with merge-if-equivalent!!! in merge-constructs
+;;TODO: adapt changes-lisp
;;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),
@@ -701,6 +704,34 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*))
+ "Returns all instances of the given type and the given revision that are
+ stored in the db."
+ (declare (symbol class-symbol) (type (or null integer) revision))
+ (let ((db-instances (elephant:get-instances-by-class class-symbol)))
+ (let ((filtered-instances (remove-if-not #'(lambda(inst)
+ (typep inst class-symbol))
+ db-instances)))
+ (if revision
+ (remove-if #'null
+ (map 'list #'(lambda(inst)
+ (find-item-by-revision inst revision))
+ filtered-instances))
+ filtered-instances))))
+
+
+(defun get-all-topics (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'TopicC :revision revision))
+
+
+(defun get-all-associations (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'AssociationC :revision revision))
+
+
+(defun get-all-tms (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'TopicMapC :revision revision))
+
+
(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
@@ -811,14 +842,15 @@
(condition () nil)))
-(defun merge-all-constructs(constructs-to-be-merged)
+(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*))
"Merges all constructs contained in the given list."
(declare (list constructs-to-be-merged))
(let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
(merged-construct (elt constructs-to-be-merged 0)))
(loop for construct-to-be-merged in constructs-to-be-merged
do (setf merged-construct
- (merge-constructs merged-construct construct-to-be-merged)))))
+ (merge-constructs merged-construct construct-to-be-merged
+ :revision revision)))))
(defgeneric internal-id (construct)
@@ -980,7 +1012,7 @@
;;; VersionedConstructC
-(defgeneric exist-in-revision-history-? (versioned-construct)
+(defgeneric exist-in-version-history-p (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.")
@@ -1106,8 +1138,16 @@
(let
((last-version ;the last active version
(find 0 (versions construct) :key #'end-revision)))
- (when last-version
- (setf (end-revision last-version) revision))))
+ (if (and last-version
+ (= (start-revision last-version) revision))
+ (progn
+ (delete-construct last-version)
+ (let ((sorted-versions
+ (sort (versions construct) #'> :key #'end-revision)))
+ (when sorted-versions
+ (setf (end-revision (first sorted-versions)) revision))))
+ (when last-version
+ (setf (end-revision last-version) revision)))))
;;; TopicMapconstructC
@@ -2494,9 +2534,14 @@
(and (eql (instance-of construct-1 :revision revision)
(instance-of construct-2 :revision revision))
(not (set-exclusive-or (themes construct-1 :revision revision)
- (themes construct-1 :revision revision)))
- (not (set-exclusive-or (roles construct-1 :revision revision)
- (roles construct-2 :revision revision)))))
+ (themes construct-2 :revision revision)))
+
+ (not (set-exclusive-or
+ (roles construct-1 :revision revision)
+ (roles construct-2 :revision revision)
+ :test #'(lambda(role-1 role-2)
+ (strictly-equivalent-constructs role-1 role-2
+ :revision revision))))))
(defgeneric AssociationC-p (class-symbol)
@@ -2517,21 +2562,22 @@
(type (or null TopicC) instance-of))
;; item-identifiers and reifers are not checked because the equality have to
;; be variafied without them
- (let ((checked-roles
- (loop for assoc-role in (roles construct :revision start-revision)
- when (loop for plist in roles
- when (equivalent-construct
- assoc-role :player (getf plist :player)
- :start-revision (or (getf plist :start-revision)
- start-revision)
- :instance-of (getf plist :instance-of))
- return t)
- collect assoc-role)))
+ (let ((checked-roles nil))
+ (loop for plist in roles
+ do (let ((found-role
+ (find-if #'(lambda(assoc-role)
+ (equivalent-construct
+ assoc-role :player (getf plist :player)
+ :start-revision (or (getf plist :start-revision)
+ start-revision)
+ :instance-of (getf plist :instance-of)))
+ (roles construct :revision start-revision))))
+ (when found-role
+ (push found-role checked-roles))))
(and
(not (set-exclusive-or (roles construct :revision start-revision)
checked-roles))
- (= (length (roles construct :revision start-revision))
- (length roles))
+ (= (length checked-roles) (length roles))
(equivalent-typable-construct construct instance-of
:start-revision start-revision)
(equivalent-scopable-construct construct themes
@@ -3428,9 +3474,10 @@
:roles roles :themes themes
:instance-of instance-of)
existing-association))
- (elephant:get-instances-by-class 'AssociationC)))))
+ (get-all-associations nil)))))
(cond ((> (length existing-associations) 1)
- (merge-all-constructs existing-associations))
+ (merge-all-constructs existing-associations
+ :revision start-revision))
(existing-associations
(first existing-associations))
(t
@@ -3512,9 +3559,9 @@
:item-identifiers item-identifiers
:reifier reifier)
existing-tm))
- (elephant:get-instances-by-class 'TopicMapC)))))
+ (get-all-tms start-revision)))))
(cond ((> (length existing-tms) 1)
- (merge-all-constructs existing-tms))
+ (merge-all-constructs existing-tms :revision start-revision))
(existing-tms
(first existing-tms))
(t
@@ -3554,9 +3601,9 @@
:item-identifiers item-identifiers
:topic-identifiers topic-identifiers)
existing-topic))
- (elephant:get-instances-by-class 'TopicC)))))
+ (get-all-topics start-revision)))))
(cond ((> (length existing-topics) 1)
- (merge-all-constructs existing-topics))
+ (merge-all-constructs existing-topics :revision start-revision))
(existing-topics
(first existing-topics))
(t
@@ -3919,23 +3966,61 @@
(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))))))))
-
+ (let ((all-other (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)))))
+ (let ((all-equivalent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(other)
+ (when (strictly-equivalent-constructs
+ construct other :revision revision)
+ other))
+ all-other))))
+ (when all-equivalent
+ (merge-all-constructs (append all-equivalent (list construct))
+ :revision revision))))))
+ (merge-changed-associations older-topic :revision revision))
+
+
+(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*))
+ "Merges all associations that became TMDM-equal since two referenced topics
+ were merged, e.g. the association types."
+ (declare (TopicC older-topic))
+ (let ((all-assocs
+ (remove-duplicates
+ (append
+ (remove-if
+ #'null
+ (map 'list #'(lambda(role)
+ (parent role :revision revision))
+ (player-in-roles older-topic :revision revision)))
+ (remove-if
+ #'null
+ (map
+ 'list #'(lambda(constr)
+ (when (typep constr 'AssociationC)
+ constr))
+ (append (used-as-type older-topic :revision revision)
+ (used-as-theme older-topic :revision revision))))))))
+ (dolist (assoc all-assocs)
+ (let ((all-equivalent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(db-assoc)
+ (when (strictly-equivalent-constructs
+ assoc db-assoc :revision revision)
+ db-assoc))
+ (get-all-associations nil)))))
+ (when all-equivalent
+ (merge-all-constructs (append all-equivalent (list assoc))
+ :revision revision))))))
+
(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
&key (revision *TM-REVISION*))
@@ -3953,7 +4038,7 @@
(move-reified-construct newer-topic older-topic :revision revision)
(merge-changed-constructs older-topic :revision revision)
(mark-as-deleted newer-topic :revision revision :source-locator nil)
- (when (exist-in-revision-history-? newer-topic)
+ (when (exist-in-version-history-p newer-topic)
(delete-construct newer-topic))
older-topic))))
@@ -3980,7 +4065,7 @@
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-char older-char
:revision revision)
- (delete-characteristic newer-char parent-2
+ (delete-characteristic parent-2 newer-char
:revision revision)
older-char)
((and parent-1 parent-2)
@@ -4032,7 +4117,7 @@
(add-to-tm top-or-assoc top-or-assoc))
(add-to-version-history older-tm :start-revision revision)
(mark-as-deleted newer-tm :revision revision)
- (when (exist-in-revision-history-? newer-tm)
+ (when (exist-in-version-history-p newer-tm)
(delete-construct newer-tm))
older-tm))))
@@ -4053,6 +4138,8 @@
construct-1 construct-2)
:construct-1 construct-1
:construct-2 construct-2)))
+ (dolist (tm (in-topicmaps newer-assoc :revision revision))
+ (add-to-tm tm older-assoc))
(move-referenced-constructs newer-assoc older-assoc)
(dolist (newer-role (roles newer-assoc :revision revision))
(let ((equivalent-role
@@ -4065,7 +4152,7 @@
(delete-role newer-assoc newer-role :revision revision)
(add-role older-assoc equivalent-role :revision revision)))
(mark-as-deleted newer-assoc :revision revision)
- (when (exist-in-revision-history-? newer-assoc)
+ (when (exist-in-version-history-p newer-assoc)
(delete-construct newer-assoc))
older-assoc))))
@@ -4091,8 +4178,14 @@
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-role older-role
:revision revision)
- (delete-role newer-role parent-2 :revision revision)
- (add-role older-role parent-1 :revision revision))
+ (delete-role parent-2 newer-role :revision revision)
+ (let ((r-assoc
+ (find-if
+ #'(lambda(r-assoc)
+ (and (eql (role r-assoc) older-role)
+ (eql (parent-construct r-assoc) parent-1)))
+ (slot-p parent-1 'roles))))
+ (add-to-version-history r-assoc :start-revision revision)))
((and parent-1 parent-2)
(let ((active-assoc (merge-constructs parent-1 parent-2
:revision revision)))
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 Fri Apr 23 14:47:37 2010
@@ -81,7 +81,12 @@
:test-find-oldest-construct
:test-move-referenced-constructs-ReifiableConstructC
:test-move-referenced-constructs-NameC
- :test-merge-constructs-TopicC-1))
+ :test-merge-constructs-TopicC-1
+ :test-merge-constructs-TopicC-2
+ :test-merge-constructs-TopicC-3
+ :test-merge-constructs-TopicC-4
+ :test-merge-constructs-TopicC-5
+ :test-merge-constructs-TopicC-6))
;;TODO: test merge-constructs
@@ -1815,7 +1820,7 @@
: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
+ (role-3 (list :player player-3 :instance-of r-type-3
:start-revision rev-1))
(type-1 (make-instance 'd:TopicC))
(type-2 (make-instance 'd:TopicC))
@@ -1877,7 +1882,7 @@
(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)))))))
+ (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))
(test test-equivalent-TopicC ()
@@ -3046,6 +3051,414 @@
(is-true (d::marked-as-deleted-p occ-3))))))))))
+(test test-merge-constructs-TopicC-2 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
+ (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
+ (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+ (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
+ (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1"
+ :xtm-id "xtm-1"))
+ (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2"
+ :xtm-id "xtm-2"))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (theme-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((variant-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "var-1"
+ :themes (list theme-1)))
+ (variant-2 (make-construct 'VariantC
+ :start-revision rev-2
+ :charvalue "var-2"
+ :themes (list theme-2)))
+ (variant-3 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "var-1"
+ :themes (list theme-1)))
+ (occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list theme-1)))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :charvalue "occ-2"
+ :instance-of type-2))
+ (occ-3 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :item-identifiers (list ii-3)
+ :charvalue "occ-1"
+ :instance-of type-1
+ :themes (list theme-1))))
+ (let ((name-1 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-1"
+ :instance-of type-1))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-2
+ :charvalue "name-2"
+ :instance-of type-1
+ :variants (list variant-1 variant-2)))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-1"
+ :instance-of type-1
+ :variants (list variant-3))))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :topic-identifiers (list tid-1)
+ :item-identifiers (list ii-1)
+ :locators (list sl-1)
+ :psis (list psi-1)
+ :names (list name-1 name-2)
+ :occurrences (list occ-1 occ-2)))
+ (top-2 (make-construct 'TopicC
+ :start-revision rev-3
+ :topic-identifiers (list tid-2)
+ :item-identifiers (list ii-2)
+ :locators (list sl-2)
+ :psis (list psi-2)
+ :names (list name-3)
+ :occurrences (list occ-3))))
+ (setf *TM-REVISION* rev-3)
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 6))
+ (is (= (length (elephant:get-instances-by-class 'NameC)) 3))
+ (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3))
+ (is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
+ (let ((top (d::merge-constructs top-1 top-2 :revision rev-3)))
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 5))
+ (is (= (length (elephant:get-instances-by-class 'NameC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
+ (is (eql top top-1))
+ (is-false (append (psis top-2) (item-identifiers top-2)
+ (locators top-2) (topic-identifiers top-2)
+ (names top-2) (occurrences top-2)))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers top-1)))
+ (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1)))
+ (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
+ (is-false (set-exclusive-or (list tid-1 tid-2)
+ (topic-identifiers top-1)))
+ (is-false (set-exclusive-or (list psi-1)
+ (psis top-1 :revision rev-2)))
+ (is-false (set-exclusive-or (list name-1 name-2)
+ (names top-1)))
+ (is-false (set-exclusive-or (variants name-1)
+ (list variant-3)))
+ (is-false (variants name-3))
+ (is-false (set-exclusive-or (occurrences top-1)
+ (list occ-1 occ-2)))
+ (is-false (set-exclusive-or (item-identifiers occ-1)
+ (list ii-3)))
+ (is-false (item-identifiers occ-3))
+ (is-true (d::marked-as-deleted-p name-3))
+ (is-true (d::marked-as-deleted-p occ-3))))))))))
+
+
+(test test-merge-constructs-TopicC-3 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (n-type (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))
+ (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5"))
+ (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6"))
+ (var-0-1
+ (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list
+ (make-construct 'TopicC
+ :start-revision rev-1))
+ :charvalue "var-0-1"))
+ (var-0-2
+ (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list
+ (make-construct 'TopicC
+ :start-revision rev-1))
+ :charvalue "var-0-1")))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-1)
+ :charvalue "occ"
+ :instance-of type-1))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-2)
+ :charvalue "occ"
+ :instance-of type-2))
+ (name-1 (make-construct 'NameC
+ :start-revision rev-1
+ :item-identifiers (list ii-3)
+ :variants (list var-0-1)
+ :charvalue "name"
+ :instance-of type-1))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-1
+ :item-identifiers (list ii-4)
+ :variants (list var-0-2)
+ :charvalue "name"
+ :instance-of type-2))
+ (var-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :item-identifiers (list ii-5)
+ :charvalue "var"
+ :themes (list type-1)))
+ (var-2 (make-construct 'VariantC
+ :start-revision rev-1
+ :item-identifiers (list ii-6)
+ :charvalue "var"
+ :themes (list type-2))))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :occurrences (list occ-1 occ-2)
+ :names (list name-1 name-2)))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-3"
+ :instance-of n-type
+ :variants (list var-1 var-2))))
+ (let ((top-2 (make-construct 'TopicC
+ :start-revision rev-1
+ :names (list name-3))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (occurrences top-1)) 1))
+ (is-false (set-exclusive-or
+ (list ii-1 ii-2)
+ (item-identifiers (first (occurrences top-1)))))
+ (is (= (length (slot-value top-1 'd::occurrences)) 2))
+ (is (= (length (names top-1)) 1))
+ (is-false (set-exclusive-or
+ (list ii-3 ii-4)
+ (item-identifiers (first (names top-1)))))
+ (is (= (length (slot-value top-1 'd::names)) 2))
+ (is-false (set-exclusive-or (list var-0-1 var-0-2)
+ (variants (first (names top-1)))))
+ (is-true (d::marked-as-deleted-p
+ (find-if-not #'(lambda(occ)
+ (eql occ (first (occurrences top-1))))
+ (slot-value top-1 'd::occurrences))))
+ (is-true (d::marked-as-deleted-p
+ (find-if-not #'(lambda(name)
+ (eql name (first (names top-1))))
+ (slot-value top-1 'd::names))))
+ (is (= (length (variants (first (names top-2)))) 1))
+ (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2))
+ (is (eql (first (themes (first (variants (first (names top-2))))))
+ type-1)))))))))
+
+
+(test test-merge-constructs-TopicC-4 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (a-type (make-construct 'TopicC :start-revision rev-1))
+ (r-type (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
+ (let ((assoc-1 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of a-type
+ :roles (list (list :player type-1
+ :instance-of r-type
+ :item-identifiers (list ii-1)
+ :start-revision rev-1)
+ (list :player type-2
+ :item-identifiers (list ii-2)
+ :instance-of r-type
+ :start-revision rev-1)))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (roles assoc-1)) 1))
+ (is (= (length (slot-value assoc-1 'd::roles)) 2))
+ (is (eql (instance-of (first (roles assoc-1))) r-type))
+ (is (eql (player (first (roles assoc-1))) type-1))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers (first (roles assoc-1)))))
+ (let ((active-role (first (roles assoc-1)))
+ (non-active-role
+ (let ((r-assoc (find-if-not #'(lambda(role)
+ (eql role (first (roles assoc-1))))
+ (slot-value assoc-1 'd::roles))))
+ (when r-assoc
+ (d::role r-assoc)))))
+ (is (= (length (d::versions
+ (first (slot-value active-role 'd::parent)))) 2))
+ (is (= (length (d::versions
+ (first (slot-value non-active-role 'd::parent)))) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value non-active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-3 (d::start-revision vi))
+ (= 0 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))))))))
+
+
+(test test-merge-constructs-TopicC-5 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (a-type (make-construct 'TopicC :start-revision rev-1))
+ (player-1 (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
+ (let ((assoc-2 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of a-type
+ :roles (list (list :player player-1
+ :instance-of type-1
+ :item-identifiers (list ii-1)
+ :start-revision rev-1)
+ (list :player player-1
+ :item-identifiers (list ii-2)
+ :instance-of type-2
+ :start-revision rev-1)))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (roles assoc-2)) 1))
+ (is (= (length (slot-value assoc-2 'd::roles)) 2))
+ (is (eql (instance-of (first (roles assoc-2))) type-1))
+ (is (eql (player (first (roles assoc-2))) player-1))
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers (first (roles assoc-2)))))
+ (let ((active-role (first (roles assoc-2)))
+ (non-active-role
+ (let ((r-assoc (find-if-not #'(lambda(role)
+ (eql role (first (roles assoc-2))))
+ (slot-value assoc-2 'd::roles))))
+ (when r-assoc
+ (d::role r-assoc)))))
+ (is (= (length (d::versions
+ (first (slot-value active-role 'd::parent)))) 2))
+ (is (= (length (d::versions
+ (first (slot-value non-active-role 'd::parent)))) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value non-active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-1 (d::start-revision vi))
+ (= rev-3 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))
+ (is-true (find-if #'(lambda(vi)
+ (and (= rev-3 (d::start-revision vi))
+ (= 0 (d::end-revision vi))))
+ (d::versions (first (slot-value active-role
+ 'd::parent)))))))))))
+
+
+(test test-merge-constructs-TopicC-6 ()
+ "Tests the generic move-referenced-constructs corresponding to TopicC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (rev-3 300))
+ (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1))
+ (r-type-1 (make-construct 'TopicC :start-revision rev-1))
+ (r-type-2 (make-construct 'TopicC :start-revision rev-1))
+ (player-1 (make-construct 'TopicC :start-revision rev-1))
+ (player-2 (make-construct 'TopicC :start-revision rev-1))
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+ (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")))
+ (let ((assoc-3 (make-construct 'AssociationC
+ :start-revision rev-1
+ :instance-of type-1
+ :item-identifiers (list ii-3)
+ :roles (list (list :player player-1
+ :instance-of r-type-1
+ :item-identifiers (list ii-1)
+ :start-revision rev-1)
+ (list :player player-2
+ :instance-of r-type-2
+ :start-revision rev-1))))
+ (assoc-4 (make-construct 'AssociationC
+ :start-revision rev-2
+ :instance-of type-2
+ :item-identifiers (list ii-4)
+ :roles (list (list :player player-1
+ :instance-of r-type-1
+ :start-revision rev-2)
+ (list :player player-2
+ :item-identifiers (list ii-2)
+ :instance-of r-type-2
+ :start-revision rev-2)))))
+ (setf *TM-REVISION* rev-3)
+ (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
+ (is (= (length (d::versions assoc-3)) 2))
+ (is (= (length (d::versions assoc-4)) 1))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::start-revision vi) rev-1)
+ (= (d::end-revision vi) rev-3)))
+ (d::versions assoc-3)))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::start-revision vi) rev-3)
+ (= (d::end-revision vi) 0)))
+ (d::versions assoc-3)))
+ (is-true (find-if #'(lambda(vi)
+ (and (= (d::start-revision vi) rev-2)
+ (= (d::end-revision vi) rev-3)))
+ (d::versions assoc-4)))
+ (is (= (length (roles assoc-3)) 2))
+ (is (= (length (item-identifiers (first (roles assoc-3)))) 1))
+ (is (= (length (item-identifiers (second (roles assoc-3)))) 1))
+ (is (or (and (string= (uri (first (item-identifiers
+ (first (roles assoc-3)))))
+ "ii-1")
+ (string= (uri (first (item-identifiers
+ (second (roles assoc-3)))))
+ "ii-2"))
+ (and (string= (uri (first (item-identifiers
+ (first (roles assoc-3)))))
+ "ii-2")
+ (string= (uri (first (item-identifiers
+ (second (roles assoc-3)))))
+ "ii-1")))))))))
+
+
+
+
+
+
+;;TODO: merge topics/associations caused by a merge of their characteristics
+;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified
+;; by the same reifier
@@ -3108,4 +3521,9 @@
(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
(it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
(it.bese.fiveam:run! 'test-merge-constructs-TopicC-1)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6)
)
\ No newline at end of file
1
0
22 Apr '10
Author: lgiessmann
Date: Thu Apr 22 06:51:39 2010
New Revision: 285
Log:
new-datamodel: adapted the "mark-as-deleted" and "marked-as-deleted-p" methods to the new datamodel; added some unit-tests for mergeing topics
Modified:
branches/new-datamodel/src/model/changes.lisp
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/changes.lisp
==============================================================================
--- branches/new-datamodel/src/model/changes.lisp (original)
+++ branches/new-datamodel/src/model/changes.lisp Thu Apr 22 06:51:39 2010
@@ -7,7 +7,6 @@
;;+-----------------------------------------------------------------------------
-;-*- standard-indent:2; tab-width:2; indent-tabs-mode:nil -*-
(in-package :datamodel)
(defun get-all-revisions ()
@@ -36,19 +35,28 @@
(sort revision-set #'<)))
-(defun find-associations-for-topic (top)
- "find all associations of this topic"
+(defun find-all-associations-for-topic (top &key (revision *TM-REVISION*))
+ "Finds all associations for a topic."
+ (remove-duplicates
+ (map 'list #'(lambda(role)
+ (parent role :revision revision))
+ (player-in-roles top :revision revision))))
+
+
+(defun find-associations-for-topic (top &key (revision *TM-REVISION*))
+ "Finds all associations of this topic except type-instance-associations."
(let
((type-instance-topic
(d:identified-construct
(elephant:get-instance-by-value 'PersistentIdC
'uri
"http://psi.topicmaps.org/iso13250/model/type-instance"))))
- (remove
- type-instance-topic
- (remove-duplicates
- (map 'list #'parent (player-in-roles top)))
- :key #'instance-of)))
+ (remove-if
+ #'(lambda(assoc)
+ (when (eql (instance-of assoc :revision revision)
+ type-instance-topic)
+ t))
+ (find-all-associations-for-topic top :revision revision))))
(defgeneric find-referenced-topics (construct)
@@ -208,53 +216,9 @@
'unique-id
unique-id))
-;(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"))
-
-;(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision)
-; "Mark a topic as deleted if it comes from the source indicated by
-;source-locator"
-; (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 mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
-; "Mark an association and its roles as deleted"
-; (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator))
-; (roles ass))
-; (call-next-method))
-;
-;(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision)
-; "Mark a topic as deleted if it comes from the source indicated by
-;source-locator"
-; ;;Part 1b, 1.4.3.3.1:
-; ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
-; ;; * Let SI be the value of TopicSI element in ATOM entry E
-; ;; * feed F contains E
-; ;; * entry E references topic fragment TF
-; ;; * Let LTM be the local topic map
-; ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
-; ;; * For all names, occurrences and associations in which T plays a role, TMC
-; ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
-; ;; * Merge in the fragment TF using SP as the base all generated source locators.
-;
-; (when
-; (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top))
-; (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator))
-; (names top))
-; (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator))
-; (occurrences top))
-; (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator))
-; (find-associations-for-topic top))
-; (call-next-method)))
-
(defgeneric add-source-locator (construct &key source-locator revision)
(:documentation "adds an item identifier to a given construct based on the source
-locator and an internally generated id (ideally a uuid)"))
+ locator and an internally generated id (ideally a uuid)"))
(defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision)
(declare (ignorable revision))
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 22 06:51:39 2010
@@ -839,6 +839,15 @@
;;; 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 marked-as-deleted-p (construct)
+ (:documentation "Returns t if the construct was marked-as-deleted."))
+
+
(defgeneric find-self-or-equal (construct parent-construct &key revision)
(:documentation "Returns the construct 'construct' if is owned by the
parent-construct or an equal construct or nil if there
@@ -875,11 +884,6 @@
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"))
-
-
(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
@@ -1089,14 +1093,11 @@
:versioned-construct construct))))))))
-(defgeneric marked-as-deleted-p (construct)
- (:documentation "Returns t if the construct was marked-as-deleted.")
- (:method ((construct VersionedConstructC))
- (if (find-if #'(lambda(vi)
+(defmethod marked-as-deleted-p ((construct VersionedConstructC))
+ (unless (find-if #'(lambda(vi)
(= (end-revision vi) 0))
(versions construct))
- nil
- t)))
+ t))
(defmethod mark-as-deleted ((construct VersionedConstructC)
@@ -1107,7 +1108,7 @@
(find 0 (versions construct) :key #'end-revision)))
(when last-version
(setf (end-revision last-version) revision))))
-
+
;;; TopicMapconstructC
(defgeneric strictly-equivalent-constructs (construct-1 construct-2
@@ -1146,6 +1147,27 @@
;;; PointerC
+(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision)
+ "Marks the last active relation between a pointer and its parent construct
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (identified-construct construct :revision 0)))
+ (when owner
+ (cond ((typep construct 'PersistentIdC)
+ (delete-psi owner construct :revision revision))
+ ((typep construct 'SubjectLocatorC)
+ (delete-locator owner construct :revision revision))
+ ((typep construct 'ItemIdentifierC)
+ (delete-item-identifier owner construct :revision revision))
+ ((typep construct 'TopicIdentificationC)
+ (delete-topic-identifier owner construct :revision revision))))))
+
+
+(defmethod marked-as-deleted-p ((construct PointerC))
+ (unless (identified-construct construct :revision 0)
+ t))
+
+
(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))))
@@ -1371,6 +1393,44 @@
;;; TopicC
+(defmethod mark-as-deleted :around ((top TopicC)
+ &key (source-locator nil sl-provided-p)
+ revision)
+ "Mark a topic as deleted if it comes from the source indicated by
+ source-locator"
+ ;;Part 1b, 1.4.3.3.1:
+ ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
+ ;; * Let SI be the value of TopicSI element in ATOM entry E
+ ;; * feed F contains E)
+ ;; * entry E references topic fragment TF
+ ;; * Let LTM be the local topic map
+ ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
+ ;; * For all names, occurrences and associations in which T plays a role, TMC
+ ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
+ ;; * Merge in the fragment TF using SP as the base all generated source locators.
+ (when (or (and (not source-locator) sl-provided-p)
+ (and sl-provided-p
+ (some (lambda (psi) (string-starts-with (uri psi) source-locator))
+ (psis top :revision 0))))
+ (unless sl-provided-p
+ (mapc (lambda(psi)(mark-as-deleted psi :revision revision
+ :source-locator source-locator))
+ (psis top :revision 0)))
+ (mapc (lambda(sl)(mark-as-deleted sl :revision revision
+ :source-locator source-locator))
+ (locators top :revision 0))
+ (mapc (lambda (name) (mark-as-deleted name :revision revision
+ :source-locator source-locator))
+ (names top :revision 0))
+ (mapc (lambda (occ) (mark-as-deleted occ :revision revision
+ :source-locator source-locator))
+ (occurrences top :revision 0))
+ (mapc (lambda (ass) (mark-as-deleted ass :revision revision
+ :source-locator source-locator))
+ (find-all-associations-for-topic top :revision 0))
+ (call-next-method)))
+
+
(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC)
&key (revision *TM-REVISION*))
(declare (integer revision))
@@ -2022,6 +2082,20 @@
;;; CharacteristicC
+(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision)
+ "Marks the last active relation between a characteristic and its parent topic
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (parent construct :revision 0)))
+ (when owner
+ (delete-characteristic owner construct :revision revision))))
+
+
+(defmethod marked-as-deleted-p ((construct CharacteristicC))
+ (unless (parent construct :revision 0)
+ t))
+
+
(defmethod find-self-or-equal ((construct CharacteristicC)
(parent-construct TopicC)
&key (revision *TM-REVISION*))
@@ -2405,6 +2479,14 @@
;;; AssociationC
+(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
+ "Marks an association and its roles as deleted"
+ (mapc (lambda (role)
+ (mark-as-deleted role :revision revision :source-locator source-locator))
+ (roles ass :revision 0))
+ (call-next-method))
+
+
(defmethod equivalent-constructs ((construct-1 AssociationC)
(construct-2 AssociationC)
&key (revision *TM-REVISION*))
@@ -2527,6 +2609,20 @@
;;; RoleC
+(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision)
+ "Marks the last active relation between a role and its parent association
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (parent construct :revision 0)))
+ (when owner
+ (delete-role owner construct :revision revision))))
+
+
+(defmethod marked-as-deleted-p ((construct RoleC))
+ (unless (parent construct :revision 0)
+ t))
+
+
(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC)
&key (revision *TM-REVISION*))
(declare (integer revision))
@@ -2771,6 +2867,15 @@
;;; ReifiableConstructC
+(defmethod mark-as-deleted :around ((construct ReifiableConstructC)
+ &key source-locator revision)
+ "Marks all item-identifiers of a given reifiable-construct as deleted."
+ (declare (ignorable source-locator))
+ (call-next-method)
+ (dolist (ii (item-identifiers construct :revision 0))
+ (delete-item-identifier construct ii :revision revision)))
+
+
(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)
&key (revision *TM-REVISION*))
(declare (integer revision))
@@ -3739,7 +3844,7 @@
(declare (integer revision))
(let ((occs-to-move (occurrences source :revision revision)))
(dolist (occ occs-to-move)
- (delete-occurrence occ source :revision revision)
+ (delete-occurrence source occ :revision revision)
(let ((equivalent-occ
(find-if #'(lambda (destination-occ)
(when
@@ -3847,7 +3952,7 @@
(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)
+ (mark-as-deleted newer-topic :revision revision :source-locator nil)
(when (exist-in-revision-history-? newer-topic)
(delete-construct newer-topic))
older-topic))))
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 22 06:51:39 2010
@@ -81,10 +81,11 @@
:test-find-oldest-construct
:test-move-referenced-constructs-ReifiableConstructC
:test-move-referenced-constructs-NameC
- :test-move-referenced-constructs-TopicC))
+ :test-merge-constructs-TopicC-1))
;;TODO: test merge-constructs
+;;TODO: test mark-as-deleted
@@ -2932,13 +2933,15 @@
(variants name-2 :revision rev-2)))))))))
-(test test-move-referenced-constructs-TopicC ()
+(test test-merge-constructs-TopicC-1 ()
"Tests the generic move-referenced-constructs corresponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
- (rev-2 200))
+ (rev-2 200)
+ (rev-3 300))
(let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
(sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
(sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
@@ -2956,7 +2959,7 @@
:charvalue "var-1"
:themes (list theme-1)))
(variant-2 (make-construct 'VariantC
- :start-revision rev-1
+ :start-revision rev-2
:charvalue "var-2"
:themes (list theme-2)))
(variant-3 (make-construct 'VariantC
@@ -2973,7 +2976,8 @@
:charvalue "occ-2"
:instance-of type-2))
(occ-3 (make-construct 'OccurrenceC
- :start-revision rev-1
+ :start-revision rev-2
+ :item-identifiers (list ii-3)
:charvalue "occ-1"
:instance-of type-1
:themes (list theme-1))))
@@ -2981,8 +2985,68 @@
:start-revision rev-1
:charvalue "name-1"
:instance-of type-1))
- )
- ))))))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-2
+ :charvalue "name-2"
+ :instance-of type-1
+ :variants (list variant-1 variant-2)))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-1"
+ :instance-of type-1
+ :variants (list variant-3))))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :topic-identifiers (list tid-1)
+ :item-identifiers (list ii-1)
+ :locators (list sl-1)
+ :psis (list psi-1)
+ :names (list name-1 name-2)
+ :occurrences (list occ-1 occ-2)))
+ (top-2 (make-construct 'TopicC
+ :start-revision rev-2
+ :topic-identifiers (list tid-2)
+ :item-identifiers (list ii-2)
+ :locators (list sl-2)
+ :psis (list psi-2)
+ :names (list name-3)
+ :occurrences (list occ-3))))
+ (setf *TM-REVISION* rev-3)
+ (let ((top (d::merge-constructs top-1 top-2 :revision rev-3)))
+ (is (eql top top-1))
+ (is-true (d::marked-as-deleted-p top-2))
+ (is-false (append (psis top-2) (item-identifiers top-2)
+ (locators top-2) (topic-identifiers top-2)
+ (names top-2) (occurrences top-2)))
+ (setf *TM-REVISION* rev-2)
+ (is (= (length (append (psis top-2) (item-identifiers top-2)
+ (locators top-2) (topic-identifiers top-2)
+ (names top-2) (occurrences top-2)))
+ 6))
+ (setf *TM-REVISION* rev-3)
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers top-1)))
+ (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1)))
+ (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
+ (is-false (set-exclusive-or (list tid-1 tid-2)
+ (topic-identifiers top-1)))
+ (is-false (set-exclusive-or (list psi-1)
+ (psis top-1 :revision rev-2)))
+ (is-false (set-exclusive-or (list name-1 name-2)
+ (names top-1)))
+ (is-false (set-exclusive-or (variants name-1)
+ (list variant-3)))
+ (is-false (variants name-3))
+ (is-false (set-exclusive-or (occurrences top-1)
+ (list occ-1 occ-2)))
+ (is-false (set-exclusive-or (item-identifiers occ-1)
+ (list ii-3)))
+ (is-false (item-identifiers occ-3))
+ (is-true (d::marked-as-deleted-p name-3))
+ (is-true (d::marked-as-deleted-p occ-3))))))))))
+
+
+
(defun run-datamodel-tests()
@@ -3043,5 +3107,5 @@
(it.bese.fiveam:run! 'test-find-oldest-construct)
(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
(it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
- (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1)
)
\ No newline at end of file
1
0