[isidorus-cvs] r231 - in branches/new-datamodel/src: model unit_tests

18 Mar 2010

Author: lgiessmann
Date: Thu Mar 18 07:40:32 2010
New Revision: 231
Log:
new-datamodel: added the helper function "make-pointer" for "make-construct"; added the generics <class>-p to all class-symbols and a unit-test fort these methods.
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 Mar 18 07:40:32 2010
@@ -92,6 +92,26 @@
       :get-item-by-locator
       :string-integer-p
       :with-revision
+	   :PointerC-p
+	   :IdentifierC-p
+	   :SubjectLocatorC-p
+	   :PersistentIdC-p
+	   :ItemIdentifierC-p
+	   :TopicIdentificationC-p
+	   :CharacteristicC-p
+	   :OccurrenceC-p
+	   :NameC-p
+	   :VariantC-p
+	   :ScopableC-p
+	   :TypableC-p
+	   :TopicC-p
+	   :AssociationC-p
+	   :RoleC-p
+	   :TopicMapC-p
+	   :ReifiableConstructC-p
+	   :TopicMapConstructC-p
+	   :VersionedConstructC-p
+	   :make-construct
;;globals
       :*TM-REVISION*
@@ -100,6 +120,12 @@
 (in-package :datamodel)
+
+
+;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier,
+;;      add-psi, add-locator
+
+
 ;;TODO: finalize add-reifier
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
@@ -108,8 +134,6 @@
 ;;      and a merge should be done
 ;;TODO: use some exceptions --> more than one type,
 ;;      identifier, not-mergable merges, missing-init-args...
-;;TODO: implement make-construct -> symbol
-;;      replace the latest make-construct-method
 ;;TODO: implement merge-construct -> ReifiableConstructC -> ...
 ;;      the method should merge two constructs that are inherited from
 ;;      ReifiableConstructC
@@ -583,17 +607,6 @@
    (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
@@ -691,6 +704,16 @@
;;; VersionedConstructC
+(defgeneric VersionedConstructC-p (class-symbol)
+  (:documentation "Returns t if the passed class is equal to VersionedConstructC
+                   or one of its subtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'VersionedconstructC)
+	(TopicC-p class-symbol)
+	(TopicMapC-p class-symbol)
+	(AssociationC-p class-symbol))))
+
+
 (defmethod delete-construct :before ((construct VersionedConstructC))
   (dolist (version-info (versions construct))
     (delete-construct version-info)))
@@ -786,7 +809,29 @@
    (setf (end-revision last-version) revision)))))
+;;; TopicMapconstructC
+(defgeneric TopicMapConstructC-p (class-symbol)
+  (:documentation "Returns t if the passed class is equal to TopicMapConstructC
+                   or one of its subtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'TopicMapConstructC)
+	(ReifiableConstructC-p class-symbol)
+	(PointerC-p class-symbol))))
+
+
 ;;; PointerC
+(defgeneric PointerC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol corresponds to the class
+                   PointerC or one of its subclasses.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'PointerC)
+	(IdentifierC-p class-symbol)
+	(TopicIdentificationC-p class-symbol)
+	(PersistentIdC-p class-symbol)
+	(ItemIdentifierC-p class-symbol)
+	(SubjectLocatorC-p class-symbol))))
+
+
 (defmethod equivalent-construct ((construct PointerC)
    			 &key start-revision (uri ""))
   "All Pointers are equal if they have the same URI value."
@@ -817,6 +862,13 @@
;;; TopicIdentificationC
+(defgeneric TopicIdentificationC-p (class-symbol)
+  (:documentation "Returns t if the passed class symbol is equal
+                   to TopicIdentificationC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'TopicIdentificationC)))
+
+
 (defmethod equivalent-construct ((construct TopicIdentificationC)
    			 &key start-revision (uri "") (xtm-id ""))
   "TopicIdentifiers are equal if teh URI and XTM-ID values are equal."
@@ -828,6 +880,37 @@
     (string= (xtm-id construct) xtm-id))))
+;;; IdentifierC
+(defgeneric IdentifierC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to IdentifierC
+                   or one of its sybtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'IdentifierC)
+	(PersistentIdC-p class-symbol)
+	(SubjectLocatorC-p class-symbol)
+	(ItemIdentifierC-p class-symbol))))
+
+
+;;; PersistentIdC
+(defgeneric PersistentIdC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to PersistentIdC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'PersistentIdC)))
+
+
+;;; ItemIdentifierC
+(defgeneric ItemIdentifierC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to ItemIdentifierC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'ItemIdentifierC)))
+
+;;; SubjectLocatorC
+(defgeneric SubjectLocatorC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to SubjectLocatorC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'SubjectLocatorC)))
+
+
 ;;; PointerAssociationC
 (defmethod delete-construct :before ((construct PointerAssociationC))
   (delete-1-n-association construct 'identifier))
@@ -904,6 +987,12 @@
;;; TopicC
+(defgeneric TopicC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to TopicC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'TopicC)))
+
+
 (defmethod equivalent-construct ((construct TopicC)
    			 &key (start-revision 0) (psis nil)
    			 (locators nil) (item-identifiers nil))
@@ -1362,6 +1451,16 @@
;;; CharacteristicC
+(defgeneric CharacteristicC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to CharacteristicC
+                   or one of its subtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'CharacteristicC)
+	(OccurrenceC-p class-symbol)
+	(NameC-p class-symbol)
+	(VariantC-p class-symbol))))
+
+
 (defmethod equivalent-construct ((construct CharacteristicC)
    			 &key (start-revision 0) (reifier nil)
    			 (item-identifiers nil) (charvalue "")
@@ -1454,6 +1553,12 @@
;;; OccurrenceC
+(defgeneric OccurrenceC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to OccurrenceC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'OccurrenceC)))
+
+
 (defmethod equivalent-construct ((construct OccurrenceC)
    			 &key (start-revision 0) (reifier nil)
    			 (item-identifiers nil) (charvalue "")
@@ -1472,6 +1577,12 @@
;;; VariantC
+(defgeneric VariantC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to VariantC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'VariantC)))
+
+
 (defmethod equivalent-construct ((construct VariantC)
    			 &key (start-revision 0) (reifier nil)
    			 (item-identifiers nil) (charvalue "")
@@ -1489,6 +1600,12 @@
;;; NameC
+(defgeneric NameC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to Name.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'NameC)))
+
+
 (defmethod equivalent-construct ((construct NameC)
    			 &key (start-revision 0) (reifier nil)
    			 (item-identifiers nil) (charvalue "")
@@ -1561,6 +1678,12 @@
;;; AssociationC
+(defgeneric AssociationC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to AssociationC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'AssociationC)))
+
+
 (defmethod equivalent-construct ((construct AssociationC)
    			 &key (start-revision 0) (reifier nil)
    			 (item-identifiers nil) (roles nil)
@@ -1645,6 +1768,12 @@
;;; RoleC
+(defgeneric RoleC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to RoleC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'RoleC)))
+
+
 (defmethod equivalent-construct ((construct RoleC)
    			&key (start-revision 0) (reifier nil)
    			 (item-identifiers nil) (player nil)
@@ -1782,6 +1911,18 @@
;;; ReifiableConstructC
+(defgeneric ReifiableConstructC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to ReifiableConstructC
+                   or one of its subtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'ReifiableconstructC)
+	(TopicMapC-p class-symbol)
+	(TopicC-p class-symbol)
+	(AssociationC-p class-symbol)
+	(RoleC-p class-symbol)
+	(CharacteristicC-p class-symbol))))
+
+
 (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers
    					      &key start-revision)
   (:documentation "Returns t if the passed constructs are TMDM equal, i.e
@@ -1924,6 +2065,16 @@
       construct)))
;;; TypableC
+(defgeneric TypableC-p (class-symbol)
+  (:documentation "Returns t if the passed class is equal to TypableC or
+                   one of its subtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'TypableC)
+	(AssociationC-p class-symbol)
+	(RoleC-p class-symbol)
+	(CharacteristicC-p class-symbol))))
+
+
 (defgeneric equivalent-typable-construct (construct instance-of
    					     &key start-revision)
   (:documentation "Returns t if the passed constructs are TMDM equal, i.e.
@@ -1935,6 +2086,15 @@
;;; ScopableC
+(defgeneric ScopableC-p (class-symbol)
+  (:documentation "Returns t if the passed class is equal to ScopableC or
+                   one of its subtypes.")
+  (:method ((class-symbol symbol))
+    (or (eql class-symbol 'ScopableC)
+	(AssociationC-p class-symbol)
+	(CharacteristicC-p class-symbol))))
+
+
 (defgeneric equivalent-scopable-construct (construct themes &key start-revision)
   (:documentation "Returns t if the passed constructs are TMDM equal, i.e.
                    the scopable constructs have to own the same themes.")
@@ -2065,6 +2225,12 @@
;;; TopicMapC
+(defgeneric TopicMapC-p (class-symbol)
+  (:documentation "Returns t if the passed symbol is equal to TopicMapC.")
+  (:method ((class-symbol symbol))
+    (eql class-symbol 'TopicMapC)))
+
+
 (defmethod equivalent-construct ((construct TopicMapC)
    			 &key (start-revision 0) (reifier nil)
    			 (item-identifiers nil))
@@ -2113,9 +2279,83 @@
   (remove-association construct 'associations construct-to-delete))
+;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun make-construct (class-symbol &rest args)
+  "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."
+  (declare (symbol class-symbol))
+  (let ((start-revision (getf args :start-revision))
+	(uri (getf args :uri))
+	(xtm-id (getf args :xtm-id))
+	(identified-construct (getf args :identified-construct)))
+    (let ((construct
+	   (cond
+	     ((PointerC-p class-symbol)
+	      (make-pointer class-symbol uri :start-revision start-revision
+			    :xtm-id xtm-id
+			    :identified-construct identified-construct)))))
+
+      construct)))
+
+
+
+(defun make-pointer (class-symbol uri
+		     &key (start-revision *TM-REVISION*) (xtm-id nil)
+		     (identified-construct nil))
+  "Returns a pointer object with the specified parameters."
+  (declare (symbol class-symbol) (string uri) (integer start-revision)
+	   (type (or null string) xtm-id)
+	   (type (or null ReifiableconstructC)))
+  (let ((identifier
+	 (let ((existing-pointer
+		(remove-if
+		 #'null
+		 (map 'list 
+		      #'(lambda(existing-pointer)
+			  (when (equivalent-construct existing-pointer :uri uri
+						      :xtm-id xtm-id)
+			    existing-pointer))
+		      (elephant:get-instances-by-value class-symbol 'd::uri uri)))))
+	   (if existing-pointer existing-pointer
+	       (make-instance class-symbol :uri uri :xtm-id xtm-id)))))
+    (when identified-construct
+      (cond ((TopicIdentificationC-p class-symbol)
+	     (add-topic-identifier identified-construct identifier
+				   :revision start-revision))
+	    ((PersistentIdC-p class-symbol)
+	     (add-psi identified-construct identifier :revision start-revision))
+	    ((ItemIdentifierC-p class-symbol)
+	     (add-item-identifier identified-construct identifier
+				  :revision start-revision))
+	    ((SubjectLocatorC-p class-symbol)
+	     (add-locator identified-construct identifier
+			  :revision start-revision))))
+    identifier))
+		      
+	   
+		     
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
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 Mar 18 07:40:32 2010
@@ -57,7 +57,8 @@
       :test-equivalent-RoleC
       :test-equivalent-AssociationC
       :test-equivalent-TopicC
-	   :test-equivalent-TopicMapC))
+	   :test-equivalent-TopicMapC
+	   :test-class-p))
;;TODO: test merge-constructs when merging was caused by an item-dentifier,
@@ -1643,6 +1644,61 @@
       (is-false (d::equivalent-construct tm-1 :reifier reifier-2)))))
+(test test-class-p ()
+  "Tests the functions <class>-p."
+  (let ((identifier (list 'd::IdentifierC 'd::ItemIdentifierC 'd:PersistentIdC
+			  'd:SubjectLocatorC))
+	(topic-identifier (list 'd::TopicIdentificationC))
+	(characteristic (list 'd::CharacteristicC 'd:OccurrenceC 'd:NameC
+			      'd:VariantC))
+	(topic (list 'd:TopicC))
+	(assoc (list 'd:AssociationC))
+	(role (list 'd:AssociationC))
+	(tm (list 'd:TopicMapC)))
+    (let ((pointer (append identifier topic-identifier))
+	  (reifiable (append topic assoc role tm characteristic))
+	  (typable (append characteristic assoc role))
+	  (scopable (append characteristic assoc)))
+  (dolist (class pointer)
+    (is-true (d:PointerC-p class)))
+  (dolist (class identifier)
+    (is-true (d:IdentifierC-p class)))
+  (dolist (class topic-identifier)
+    (is-true (d:TopicIdentificationC-p class)))
+  (is-true (d:PersistentIdC-p 'd:PersistentIdC))
+  (is-true (d:SubjectLocatorC-p 'd:SubjectLocatorC))
+  (is-true (d:ItemIdentifierC-p 'd:ItemIdentifierC))
+  (dolist (class characteristic)
+    (is-true (d:CharacteristicC-p class)))
+  (is-true (d:OccurrenceC-p 'd:OccurrenceC))
+  (is-true (d:VariantC-p 'd:VariantC))
+  (is-true (d:NameC-p 'd:NameC))
+  (is-true (d:RoleC-p 'd:RoleC))
+  (is-true (d:AssociationC-p 'd:AssociationC))
+  (is-true (d:TopicC-p 'd:TopicC))
+  (is-true (d:TopicMapC-p 'd:TopicMapC))
+  (dolist (class reifiable)
+    (is-true (d:ReifiableconstructC-p class)))
+  (dolist (class scopable)
+    (is-true (d:ScopableC-p class)))
+  (dolist (class typable)
+    (is-true (d:TypableC-p class)))
+  (dolist (class (append reifiable pointer))
+    (is-true (d:TopicMapConstructC-p class)))
+  (dolist (class (append topic tm assoc))
+    (is-true (d:VersionedConstructC-p class)))
+  (dolist (class identifier)
+    (is-false (d:TopicIdentificationC-p class)))
+  (dolist (class topic-identifier)
+    (is-false (d:IdentifierC-p class)))
+  (dolist (class characteristic)
+    (is-false (d:PointerC-p class))))))
+
+
+
+
+
+
 (defun run-datamodel-tests()
   "Runs all tests of this test-suite."
   (it.bese.fiveam:run! 'test-VersionInfoC)
@@ -1683,4 +1739,5 @@
   (it.bese.fiveam:run! 'test-equivalent-AssociationC)
   (it.bese.fiveam:run! 'test-equivalent-TopicC)
   (it.bese.fiveam:run! 'test-equivalent-TopicMapC)
+  (it.bese.fiveam:run! 'test-class-p)
   )
\ No newline at end of file

    

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

[isidorus-cvs] r231 - in branches/new-datamodel/src: model unit_tests