[isidorus-cvs] r225 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Sun Mar 14 15:50:41 UTC 2010
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
More information about the Isidorus-cvs
mailing list