Changeset 213 for branches/new-datamodel

Timestamp:

02/26/10 15:50:44 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: added some unit-tests for the base class TypableC; optimized the function add-type.

Location:

branches/new-datamodel/src

Files:

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

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

@@ -95 +95 @@
 
 
+;;TODO: add-type/add-parent/add-<x>-identifier handle situation where
+;;      new objects hve to be bound in an earlier revision than one
+;;      where a object is already bound
 ;;TODO: finalize add-reifier
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
@@ -171 +174 @@
 
 (defpclass TypableC()
-  ((instance-of :associate (TypeAssociationC type-topic)
+  ((instance-of :associate (TypeAssociationC typable-construct)
                 :inherit t
                 :documentation "Contains all association-objects that contain
@@ -1528 +1531 @@
                 (filter-slot-value-by-revision construct 'player
                                                :start-revision revision))))
+      ;;TODO: search a player-assoc for the passed construct that was set in an older version
       (cond ((and already-set-player
                   (eql (first already-set-player) player-topic))
@@ -1764 +1768 @@
            (map 'list #'type-topic
                 (filter-slot-value-by-revision construct 'instance-of
-                                               :start-revision revision))))
-      (cond ((and already-set-type
-                  (eql (first already-set-type) type-topic))
+                                               :start-revision revision)))
+          (same-type-assoc
+           (loop for type-assoc in (slot-p construct 'instance-of)
+              when (eql (type-topic type-assoc) type-topic)
+              return type-assoc)))
+      (when (and already-set-type
+                 (not (eql type-topic already-set-type)))
+        (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
+               construct type-topic already-set-type))
+      (cond (already-set-type
              (let ((type-assoc
                     (loop for type-assoc in (slot-p construct 'instance-of)
@@ -1772 +1783 @@
                        return type-assoc)))
                (add-to-version-history type-assoc :start-revision revision)))
-            ((not already-set-type)
+            (same-type-assoc
+             (add-to-version-history same-type-assoc :start-revision revision))
+            (t
              (let ((assoc
                     (make-instance 'TypeAssociationC
                                    :type-topic type-topic
                                    :typable-construct construct)))
-               (add-to-version-history assoc :start-revision revision)))
-            (t
-             (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a"
-                    construct type-topic already-set-type)))
-      construct)))
+               (add-to-version-history assoc :start-revision revision)))))
+    construct))
 
 

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

@@ -31 +31 @@
            :test-OccurrenceC
            :test-VariantC
-           :test-NameC))
+           :test-NameC
+           :test-TypableC))
 
 
@@ -690 +691 @@
       (add-parent name-2 top-1 :revision revision-8)
       (is (eql top-1 (parent name-2))))))
+
+
+(test test-TypableC ()
+  "Tests various functions of the base class TypableC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((name-1 (make-instance 'NameC))
+          (name-2 (make-instance 'NameC))
+          (top-1 (make-instance 'TopicC))
+          (top-2 (make-instance 'TopicC))
+          (revision-0-5 50)
+          (revision-1 100)
+          (revision-2 200)
+          (revision-3 300))
+      (setf *TM-REVISION* revision-1)
+      (is-false (instance-of name-1))
+      (add-type name-1 top-1)
+      (is (eql top-1 (instance-of name-1)))
+      (is-false (instance-of name-1 :revision revision-0-5))
+      (is (eql top-1 (instance-of name-1 :revision revision-2)))
+      (signals error (add-type name-1 top-2))
+      (add-type name-2 top-1 :revision revision-2)
+      (is (= (length (union (list name-1 name-2)
+                            (used-as-type top-1))) 2))
+      (is (= (length (union (list name-1)
+                            (used-as-type top-1
+                                          :revision revision-1))) 1))
+      (delete-type name-1 top-1 :revision revision-3)
+      (is-false (instance-of name-1))
+      (is (= (length (union (list name-2)
+                            (used-as-type top-1))) 1))
+      (add-type name-1 top-1 :revision revision-3)
+      (is (eql top-1 (instance-of name-1)))
+      (is (= (length (union (list name-1 name-2)
+                            (used-as-type top-1))) 2))
+      (is (= (length (slot-value top-1 'd::used-as-type)) 2)))))
       
 
@@ -708 +744 @@
   (it.bese.fiveam:run! 'test-VariantC)
   (it.bese.fiveam:run! 'test-NameC)
+  (it.bese.fiveam:run! 'test-TypableC)
 )