[isidorus-cvs] r231 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Mar 18 11:40:33 UTC 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
More information about the Isidorus-cvs
mailing list