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

[Lukas Giessmann]

Author: lgiessmann
Date: Fri Feb 26 10:50:44 2010
New Revision: 213

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

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	Fri Feb 26 10:50:44 2010
@@ -94,6 +94,9 @@
 (in-package :datamodel)
 
 
+;;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
 ;;      initarg in make-construct
@@ -170,7 +173,7 @@
 
 
 (defpclass TypableC()
-  ((instance-of :associate (TypeAssociationC type-topic)
+  ((instance-of :associate (TypeAssociationC typable-construct)
 		:inherit t
 		:documentation "Contains all association-objects that contain
                                 the actual type-topic."))
@@ -1527,6 +1530,7 @@
 	   (map 'list #'player-topic
 		(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))
 	     (let ((player-assoc
@@ -1763,24 +1767,30 @@
     (let ((already-set-type
 	   (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)
 		       when (eql type-topic (type-topic type-assoc))
 		       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))
 
 
 (defgeneric delete-type (construct type-topic &key revision)

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	Fri Feb 26 10:50:44 2010
@@ -30,7 +30,8 @@
 	   :test-ReifiableConstructC
 	   :test-OccurrenceC
 	   :test-VariantC
-	   :test-NameC))
+	   :test-NameC
+	   :test-TypableC))
 
 
 ;;TODO: test delete-construct
@@ -689,6 +690,41 @@
       (is-false (parent name-2))
       (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)))))
       
 
 
@@ -707,4 +743,5 @@
   (it.bese.fiveam:run! 'test-OccurrenceC)
   (it.bese.fiveam:run! 'test-VariantC)
   (it.bese.fiveam:run! 'test-NameC)
+  (it.bese.fiveam:run! 'test-TypableC)
 )
\ No newline at end of file