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