[isidorus-cvs] r184 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Feb 12 21:11:55 UTC 2010
Author: lgiessmann
Date: Fri Feb 12 16:11:54 2010
New Revision: 184
Log:
new-datamodel: added all PointerC-classes and all PointerAssociationC-classes
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 Feb 12 16:11:54 2010
@@ -13,12 +13,17 @@
(in-package :datamodel)
+;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar *TM-REVISION* 0)
+
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun slot-p (instance slot-symbol)
"Returns t if the slot depending on slot-symbol is bound and not nil."
- (and (slot-boundp instance slot-symbol)
- (slot-value instance slot-symbol)))
+ (when (slot-boundp instance slot-symbol)
+ (let ((value (slot-value instance slot-symbol)))
+ (when value
+ value))))
(defun delete-1-n-association(instance slot-symbol)
@@ -144,57 +149,110 @@
: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)
+ (= (end-revision vi) 0))
+ (versions construct))
+ nil
+ t)))
+
+
;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ReifierAssociationC
;;; SubjectLocatorAssociationC
;;; PersistentIdAssociationC
;;; TopicIdAssociationC
;;; ItemIdAssociationC
;;; PointerAssociationC
;;; VersionedAssociationC
+(defpclass ReifierAssociationC(VersionedAssociationC)
+ ((reifiable-construct :initarg :reifiable-construct
+ :accessor reifiable-construct
+ :associate ReifiableConstructC
+ :documentation "The actual construct which is reified
+ by a topic.")
+ (reifier-topic :initarg :reifier-topic
+ :accessor reifier-topic
+ :associate TopicC
+ :documentation "The reifier-topic that reifies the
+ reifiable-construct."))
+ (:index t)
+ (:documentation "A versioned-association that relates a reifiable-construct
+ with a topic."))
+
+
+(defmethod delete-construct :before ((construct ReifierAssociationC))
+ "Deletes the association-construct and the reifier-topic when it
+ is not used as a reifier of another construct."
+ (delete-1-n-association construct 'reifiable-construct)
+ (let ((reifier-top (slot-p construct 'reifier-topic)))
+ (delete-1-n-association construct 'reifier-topic)
+ (when (= (length (all-reified-constructs reifier-top)) 0)
+ (delete-construct reifier-top))))
+
+
(defpclass SubjectLocatorAssociationC(PointerAssociationC)
- ((identified-construct :initarg :identified-construct
- :accessor identified-construct
- :associate TopicC
- :documentation "The actual topic which is associated
- with the subject-locator."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the subject-locator."))
(:index t)
(:documentation "A pointer that associates subject-locators, versions
and topics."))
+(defmethod delete-construct :before ((construct SubjectLocatorAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
(defpclass PersistentIdAssociationC(PointerAssociationC)
- ((identified-construct :initarg :identified-construct
- :accessor identified-construct
- :associate TopicC
- :documentation "The actual topic which is associated
- with the subject-identifier/psi."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the subject-identifier/psi."))
(:index t)
(:documentation "A pointer that associates subject-identifiers, versions
and topics."))
+(defmethod delete-construct :before ((construct PersistentIdAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
(defpclass TopicIdAssociationC(PointerAssociationC)
- ((identified-construct :initarg :identified-construct
- :accessor identified-construct
- :associate TopicC
- :documentation "The actual topic which is associated
- with the topic-identifier."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the topic-identifier."))
(:index t)
(:documentation "A pointer that associates topic-identifiers, versions
and topics."))
+(defmethod delete-construct :before ((construct TopicIdAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
(defpclass ItemIdAssociationC(PointerAssociationC)
- ((identified-construct :initarg :identified-construct
- :accessor identified-construct
- :associate ReifiableConstructC
- :documentation "The actual parent which is associated
- with the item-identifier."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate ReifiableConstructC
+ :documentation "The actual parent which is associated
+ with the item-identifier."))
(:index t)
(:documentation "A pointer that associates item-identifiers, versions
and reifiable-constructs."))
+(defmethod delete-construct :before ((construct ItemIdAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
(defpclass PointerAssociationC (VersionedAssociationC)
((identifier :initarg :identifier
:accessor identifier
@@ -205,6 +263,15 @@
pointer-associations."))
+(defmethod delete-construct :before ((construct PointerAssociationC))
+ "Deletes the association-construct and the pointer if it is not used
+ as an idengtiffier of any other object."
+ (let ((id (slot-p construct 'identifier)))
+ (delete-1-n-association construct 'identifier)
+ (when (= (length (all-identified-constructs id)) 0)
+ (delete-construct id))))
+
+
(defpclass VersionedAssociationC()
()
(:documentation "An abstract base class for all versioned associations."))
@@ -267,11 +334,34 @@
:index t
:documentation "The actual value of a pointer, i.e. uri or ID.")
(identified-construct :initarg :identified-construct
- :accessor identified-construct
:associate (PointerAssociationC identifier)))
(:documentation "An abstract base class for all pointers."))
+(defgeneric identified-construct (construct &key revision)
+ (:documentation "Returns the identified-construct -> ReifiableConstructC or
+ TopicC that corresponds with the passed revision.")
+ (:method ((construct PointerC) &key (revision *TM-REVISION*))
+ (let ((results
+ (map 'list #'parent-construct
+ (filter-slot-value-by-revision construct 'identified-construct
+ :start-revision revision))))
+ (when results ;result must be nil or a list with one item
+ (first results)))))
+
+
+(defgeneric all-identified-constructs (construct &key with-deleted)
+ (:documentation "Returns all constructs which are associated with this
+ pointer.")
+ (:method ((construct PointerC) &key (with-deleted t))
+ (let ((all-values (slot-p construct 'identified-construct)))
+ (let ((filtered-values
+ (if with-deleted
+ all-values
+ (remove-if #'marked-as-deleted-p all-values))))
+ (map 'list #'parent-construct filtered-values)))))
+
+
;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpclass ReifiableConstructC(TopicMapConstructC)
((item-identifiers :initarg :item-identifiers
@@ -284,9 +374,63 @@
(:documentation "Reifiable constructs as per TMDM."))
-;;TODO: implement reader for item-identifiers and reifier (version)
-;;TODO: implement add-item-identifier and add-reifier (version)
+(defgeneric item-identifiers (construct &key revision)
+ (:documentation "Returns the ItemIdentifierC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'item-identifiers :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric reifier (construct &key revision)
+ (:documentation "Returns the reifier-topic that corresponds
+ with the passed construct and the passed version.")
+ (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'item-identifiers :start-revision revision)))
+ (when assocs ;assocs must be nil or a list with exactly one item
+ (reifier (first assocs))))))
+
+
+(defmethod delete-construct :before ((construct ReifiableConstructC))
+ "Deletes the passed construct its item-identifiers and its
+ reifiers. An item-identifier and a reifeir is only deleted
+ when these constructs are not referenced by other parent-objects."
+ (dolist (item-identifier (slot-p construct 'item-identifiers))
+ (delete-construct item-identifier))
+ (dolist (reifier-top (slot-p construct 'reifier))
+ (delete-construct reifier-top)))
+
+
+(defgeneric add-item-identifier (construct item-identifier &key revision)
+ (:documentation "Adds the passed item-identifier to the passed construct.
+ If the item-identifier is already related with the passed
+ construct a new revision is added.")
+ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
+ &key (revision *TM-REVISION*))
+ (let ((all-constructs
+ (all-identified-constructs item-identifier
+ :with-deleted nil)))
+ (cond ((find construct all-constructs)
+ (let ((ii-assoc
+ (loop for ii-assoc in (slot-p construct 'item-identifiers)
+ when (eql (identifier ii-assoc) item-identifier)
+ return ii-assoc)))
+ (add-to-version-history ii-assoc :start-revision revision)))
+ (all-constructs
+ (merge-constructs (first all-constructs) (second all-constructs)))
+ (t
+ (make-construct 'ItemIdAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier item-identifier))))
+ item-identifier))
+
+;;TODO: implement add-reifier (version)
+;;TODO: implement make-construct (symbol)
+;;TODO: implement merge-construct
;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpclass TopicMapConstructC()
More information about the Isidorus-cvs
mailing list