Changeset 231 for branches/new-datamodel

Timestamp:

03/18/10 11:40:32 (15 years ago)

Author:

lgiessmann

Message:

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.

Location:

branches/new-datamodel/src

Files:

• model/datamodel.lisp (modified) (20 diffs)
• unit_tests/datamodel_test.lisp (modified) (3 diffs)

branches/new-datamodel/src/model/datamodel.lisp ¶

@@ -93 +93 @@
            :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
@@ -99 +119 @@
 
 (in-package :datamodel)
+
+
+
+
+;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier,
+;;      add-psi, add-locator
 
 
@@ -109 +135 @@
 ;;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
@@ -584 +608 @@
 
 
-(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)
@@ -692 +705 @@
 
 ;;; 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))
@@ -787 +810 @@
   
 
+;;; 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 ""))
@@ -818 +863 @@
 
 ;;; 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 ""))
@@ -829 +881 @@
 
 
+;;; 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))
@@ -905 +988 @@
 
 ;;; 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)
@@ -1363 +1452 @@
 
 ;;; 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)
@@ -1455 +1554 @@
 
 ;;; 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)
@@ -1473 +1578 @@
 
 ;;; 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)
@@ -1490 +1601 @@
 
 ;;; 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)
@@ -1562 +1679 @@
 
 ;;; 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)
@@ -1646 +1769 @@
 
 ;;; 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)
@@ -1783 +1912 @@
 
 ;;; 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)
@@ -1925 +2066 @@
 
 ;;; 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)
@@ -1936 +2087 @@
 
 ;;; 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.
@@ -2066 +2226 @@
 
 ;;; 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)
@@ -2114 +2280 @@
 
 
-
-
-
+;;; 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))
+                      
+           
+                     
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+        
 
 

branches/new-datamodel/src/unit_tests/datamodel_test.lisp ¶

@@ -58 +58 @@
            :test-equivalent-AssociationC
            :test-equivalent-TopicC
-           :test-equivalent-TopicMapC))
+           :test-equivalent-TopicMapC
+           :test-class-p))
 
 
@@ -1644 +1645 @@
 
 
+(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."
@@ -1684 +1740 @@
   (it.bese.fiveam:run! 'test-equivalent-TopicC)
   (it.bese.fiveam:run! 'test-equivalent-TopicMapC)
+  (it.bese.fiveam:run! 'test-class-p)
   )