[isidorus-cvs] r184 - branches/new-datamodel/src/model - isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

12 Feb 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()

    