Author: lgiessmann Date: Sun Mar 14 11:50:40 2010 New Revision: 225
Log: new-datamodel: added "equivalent-costruct" to PointerC, TopicIdentificationC, CharactersiticC, OccurrenceC, NameC, VariantC, RoleC, AssociationC, TopicC
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 Sun Mar 14 11:50:40 2010 @@ -12,6 +12,8 @@ (:nicknames :d) (:import-from :exceptions duplicate-identifier-error) + (:import-from :constants + *xml-string*) (:export ;;classes :TopicMapC :AssociationC @@ -77,6 +79,7 @@ :used-as-type :used-as-theme :datatype + :charvalue :reified-construct :mark-as-deleted :mark-as-deleted-p @@ -97,7 +100,6 @@ (in-package :datamodel)
-;;TODO: implement delete-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -186,9 +188,9 @@ :initarg :datatype :initform constants:*xml-string* :type string + :index t :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef).")) - (:index t) (:documentation "An abstract base class for characteristics that own an xml-datatype."))
@@ -581,6 +583,17 @@ (error () nil))))
+(defun make-construct (class-symbol &key start-revision &allow-other-keys) + "Creates a new topic map construct if necessary or + retrieves an equivalent one if available and updates the revision + history accordingly. Returns the object in question. Methods use + specific keyword arguments for their purpose." + (or class-symbol start-revision) + ;TODO: implement + ) + + + (defun delete-1-n-association(instance slot-symbol) (when (slot-p instance slot-symbol) (remove-association @@ -635,6 +648,39 @@ (condition () nil)))
+;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) + (:documentation "Returns t if the passed construct is equivalent to the passed + key arguments (TMDM equality rules.")) + + +(defgeneric get-most-recent-version-info (construct) + (:documentation "Returns the latest VersionInfoC object of the passed + versioned construct. + The latest construct is either the one with + end-revision=0 or with the highest end-revision value.")) + + +(defgeneric owned-p (construct) + (:documentation "Returns t if the passed construct is referenced by a parent + TM construct.")) + + +(defgeneric in-topicmaps (construct &key revision) + (:documentation "Returns all TopicMapS-obejcts where the constrict is + contained in.")) + + +(defgeneric add-to-tm (construct construct-to-add) + (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) + + +(defgeneric delete-from-tm (construct construct-to-delete) + (:documentation "Deletes a TM construct (TopicC or AssociationC) from + the TM.")) + + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) @@ -647,13 +693,6 @@ (delete-construct version-info)))
-(defgeneric get-most-recent-version-info (construct) - (:documentation "Returns the latest VersionInfoC object of the passed - versioned construct. - The latest construct is either the one with - end-revision=0 or with the highest end-revision value.")) - - (defmethod get-most-recent-version-info ((construct VersionedConstructC)) (let ((result (find 0 (versions construct) :key #'end-revision))) (if result @@ -690,38 +729,36 @@
(defgeneric add-to-version-history (construct &key start-revision end-revision) - (:documentation "Adds version history to a versioned construct")) - - -(defmethod add-to-version-history ((construct VersionedConstructC) - &key (start-revision (error "From add-to-version-history(): start revision must be present")) - (end-revision 0)) - (let ((eql-version-info - (find-if #'(lambda(vi) - (and (= (start-revision vi) start-revision) - (= (end-revision vi) end-revision))) - (versions construct)))) - (if eql-version-info - eql-version-info - (let ((current-version-info - (get-most-recent-version-info construct))) - (cond - ((and current-version-info - (= (end-revision current-version-info) start-revision)) - (setf (end-revision current-version-info) 0) - current-version-info) - ((and current-version-info - (= (end-revision current-version-info) 0)) - (setf (end-revision current-version-info) start-revision) - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)) - (t - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct))))))) + (:documentation "Adds version history to a versioned construct") + (:method ((construct VersionedConstructC) + &key (start-revision (error "From add-to-version-history(): start revision must be present")) + (end-revision 0)) + (let ((eql-version-info + (find-if #'(lambda(vi) + (and (= (start-revision vi) start-revision) + (= (end-revision vi) end-revision))) + (versions construct)))) + (if eql-version-info + eql-version-info + (let ((current-version-info + (get-most-recent-version-info construct))) + (cond + ((and current-version-info + (= (end-revision current-version-info) start-revision)) + (setf (end-revision current-version-info) 0) + current-version-info) + ((and current-version-info + (= (end-revision current-version-info) 0)) + (setf (end-revision current-version-info) start-revision) + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct)) + (t + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct))))))))
(defgeneric marked-as-deleted-p (construct) @@ -736,32 +773,28 @@
(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")) - + indicated by source-locator") + (:method ((construct VersionedConstructC) &key source-locator revision) + (declare (ignorable source-locator)) + (let + ((last-version ;the last active version + (find 0 (versions construct) :key #'end-revision))) + (when last-version + (setf (end-revision last-version) revision))))) +
-(defmethod mark-as-deleted ((construct VersionedConstructC) - &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)))) +;;; PointerC +(defmethod equivalent-construct ((construct PointerC) + &key start-revision (uri "")) + (declare (string uri) (ignorable start-revision)) + (string= (uri construct) uri))
-;;; PointerC (defmethod delete-construct :before ((construct PointerC)) (dolist (p-assoc (slot-p construct 'identified-construct)) (delete-construct p-assoc)))
-(defgeneric owned-p (construct) - (:documentation "Returns t if the passed construct is referenced by a parent - TM construct.")) - - (defmethod owned-p ((construct PointerC)) (when (slot-p construct 'identified-construct) t)) @@ -779,6 +812,17 @@ (first assocs)))))
+;;; TopicIdentificationC +(defmethod equivalent-construct ((construct TopicIdentificationC) + &key start-revision (uri "") (xtm-id "")) + (declare (string uri xtm-id)) + (let ((equivalent-pointer (call-next-method + construct :start-revision start-revision + :uri uri))) + (and equivalent-pointer + (string= (xtm-id construct) xtm-id)))) + + ;;; PointerAssociationC (defmethod delete-construct :before ((construct PointerAssociationC)) (delete-1-n-association construct 'identifier)) @@ -855,6 +899,19 @@
;;; TopicC +(defmethod equivalent-construct ((construct TopicC) + &key (start-revision 0) (psis nil) + (locators nil) (item-identifiers nil)) + (declare (integer start-revision) (list psis locators item-identifiers)) + (when + (intersection + (union (union (psis construct :revision start-revision) + (locators construct :revision start-revision)) + (item-identifiers construct :revision start-revision)) + (union (union psis locators) item-identifiers)) + t)) + + (defmethod delete-construct :before ((construct TopicC)) (let ((psi-assocs-to-delete (slot-p construct 'psis)) (sl-assocs-to-delete (slot-p construct 'locators)) @@ -1193,10 +1250,6 @@ (reifiable-construct (first assocs))))))
-(defgeneric in-topicmaps (construct &key revision) - (:documentation "Returns all TopicMapS-obejcts where the constrict is - contained in.")) - (defmethod in-topicmaps ((topic TopicC) &key (revision 0)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
@@ -1298,67 +1351,24 @@ :error-if-nil error-if-nil))
-;;; NameC -(defmethod delete-construct :before ((construct NameC)) - (let ((variant-assocs-to-delete (slot-p construct 'variants))) - (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) - (dolist (variant-assoc-to-delete variant-assocs-to-delete) - (delete-construct variant-assoc-to-delete)) - (dolist (candidate-to-delete all-variants) - (unless (owned-p candidate-to-delete) - (delete-construct candidate-to-delete)))))) - - -(defgeneric variants (construct &key revision) - (:documentation "Returns all variants that correspond with the given revision - and that are associated with the passed construct.") - (:method ((construct NameC) &key (revision 0)) - (let ((valid-associations - (filter-slot-value-by-revision construct 'variants - :start-revision revision))) - (map 'list #'characteristic valid-associations)))) - - -(defgeneric add-variant (construct variant &key revision) - (:documentation "Adds the given theme-topic to the passed - scopable-construct.") - (:method ((construct NameC) (variant VariantC) - &key (revision *TM-REVISION*)) - (when (and (parent variant :revision revision) - (not (eql (parent variant :revision revision) construct))) - (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" - variant construct (parent variant))) - (let ((all-variants - (map 'list #'characteristic (slot-p construct 'variants)))) - (if (find variant all-variants) - (let ((variant-assoc - (loop for variant-assoc in (slot-p construct 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (add-to-version-history variant-assoc :start-revision revision)) - (let ((assoc - (make-instance 'VariantAssociationC - :characteristic variant - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) - construct)) - - -(defgeneric 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 "From delete-variant(): revision must be set"))) - (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))) +;;; CharacteristicC +(defmethod equivalent-construct ((construct CharacteristicC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") + (instance-of nil) (themes nil)) + "Equality rule: Characteristics are equal if charvalue, themes and the parent- + constructs are equal." + (declare (string charvalue) (list themes item-identifiers) + (integer start-revision) + (type (or null TopicC) instance-of reifier)) + (or (and (string= (charvalue construct) charvalue) + (not (set-exclusive-or (themes construct :revision start-revision) + themes)) + (eql instance-of (instance-of construct :revision start-revision))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)))
-;;; CharacteristicC (defmethod delete-construct :before ((construct CharacteristicC)) (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) (delete-construct characteristic-assoc-to-delete))) @@ -1432,7 +1442,113 @@ construct)))
+;;; OccurrenceC +(defmethod equivalent-construct ((construct OccurrenceC) + &key (start-revision 0) (charvalue "") + (themes nil) (instance-of nil) + (datatype *xml-string*)) + (declare (type (or null TopicC) instance-of) (string datatype) + (ignorable start-revision charvalue themes instance-of)) + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; VariantC +(defmethod equivalent-construct ((construct VariantC) + &key (start-revision 0) (charvalue "") + (themes nil) (datatype *xml-string*)) + (declare (string datatype) (ignorable start-revision charvalue themes)) + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; NameC +(defmethod equivalent-construct ((construct NameC) + &key (start-revision 0) (charvalue "") + (themes nil) (instance-of nil)) + (declare (type (or null TopicC) instance-of) + (ignorable start-revision charvalue instance-of themes)) + (call-next-method)) + + +(defmethod delete-construct :before ((construct NameC)) + (let ((variant-assocs-to-delete (slot-p construct 'variants))) + (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) + (dolist (variant-assoc-to-delete variant-assocs-to-delete) + (delete-construct variant-assoc-to-delete)) + (dolist (candidate-to-delete all-variants) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete)))))) + + +(defgeneric variants (construct &key revision) + (:documentation "Returns all variants that correspond with the given revision + and that are associated with the passed construct.") + (:method ((construct NameC) &key (revision 0)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'variants + :start-revision revision))) + (map 'list #'characteristic valid-associations)))) + + +(defgeneric add-variant (construct variant &key revision) + (:documentation "Adds the given theme-topic to the passed + scopable-construct.") + (:method ((construct NameC) (variant VariantC) + &key (revision *TM-REVISION*)) + (when (and (parent variant :revision revision) + (not (eql (parent variant :revision revision) construct))) + (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" + variant construct (parent variant))) + (let ((all-variants + (map 'list #'characteristic (slot-p construct 'variants)))) + (if (find variant all-variants) + (let ((variant-assoc + (loop for variant-assoc in (slot-p construct 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (add-to-version-history variant-assoc :start-revision revision)) + (let ((assoc + (make-instance 'VariantAssociationC + :characteristic variant + :parent-construct construct))) + (add-to-version-history assoc :start-revision revision)))) + construct)) + + +(defgeneric 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 "From delete-variant(): revision must be set"))) + (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))) + + ;;; AssociationC +(defmethod equivalent-construct ((construct AssociationC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (roles nil) + (instance-of nil) (themes nil)) + (declare (integer start-revision) (list roles themes item-identifiers) + (type (or null TopicC) instance-of reifier)) + (or + (and + (not (set-exclusive-or roles (roles construct :revision start-revision))) + (eql instance-of (instance-of construct :revision start-revision)) + (not (set-exclusive-or themes + (themes construct :revision start-revision)))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) + + (defmethod delete-construct :before ((construct AssociationC)) (let ((roles-assocs-to-delete (slot-p construct 'roles))) (let ((all-roles (map 'list #'role roles-assocs-to-delete))) @@ -1498,6 +1614,19 @@
;;; RoleC +(defmethod equivalent-construct ((construct RoleC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (player nil) + (instance-of nil)) + (declare (integer start-revision) + (type (or null TopicC) player instance-of reifier) + (list item-identifiers)) + (or (and (eql instance-of (instance-of construct :revision start-revision)) + (eql player (player construct :revision start-revision))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) + + (defmethod delete-construct :before ((construct RoleC)) (dolist (role-assoc-to-delete (slot-p construct 'parent)) (delete-construct role-assoc-to-delete)) @@ -1620,6 +1749,18 @@
;;; ReifiableConstructC +(defgeneric equivalent-reifiable-construct (construct reifier item-identifiers + &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct ReifiableConstructC) reifier item-identifiers + &key (start-revision 0)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (or (eql reifier (reifier construct :revision start-revision)) + (intersection (item-identifiers construct :revision start-revision) + item-identifiers)))) + + (defmethod delete-construct :before ((construct ReifiableConstructC)) (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers)) (reifier-assocs-to-delete (slot-p construct 'reifier))) @@ -1889,10 +2030,6 @@ :start-revision revision)))
-(defgeneric add-to-tm (construct construct-to-add) - (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) - - (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) (add-association construct 'topics construct-to-add))
@@ -1901,11 +2038,6 @@ (add-association construct 'associations construct-to-add))
-(defgeneric delete-from-tm (construct construct-to-delete) - (:documentation "Deletes a TM construct (TopicC or AssociationC) from - the TM.")) - - (defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) (remove-association construct 'topics construct-to-delete))
@@ -1923,15 +2055,22 @@
+ + + + + + + + + + + + ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric merge-constructs(construct-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) (or revision) (if construct-1 construct-1 construct-2))) - - -(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) - (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*)) - (or class-symbol start-revision))) ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file