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