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

Lukas Giessmann lgiessmann at common-lisp.net
Wed Mar 10 13:59:48 UTC 2010


Author: lgiessmann
Date: Wed Mar 10 08:59:47 2010
New Revision: 222

Log:
new-datamodel: fixed a bug in "delete-construct"; finalized the unit-tests for "delete-construct"

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	Wed Mar 10 08:59:47 2010
@@ -597,18 +597,7 @@
 
 
 (defmethod delete-construct :after ((construct elephant:persistent))
-  "Removes the passed object from the data base when it is not
-   referenced by a parent TM construct.
-   So pointers, characteristics, topics, roles and associations
-   can be only dropped when there are not owned by a parent."
-  (if (or (typep construct 'PointerC)
-	  (typep construct 'CharacteristicC)
-	  (typep construct 'TopicC)
-	  (typep construct 'RoleC)
-	  (typep construct 'AssociationC))
-      (unless (owned-p construct)
-	(drop-instance construct))
-      (drop-instance construct)))
+  (drop-instance construct))
 
 
 (defun filter-slot-value-by-revision (construct slot-symbol
@@ -835,7 +824,7 @@
 
 ;;; CharacteristicAssociationC
 (defmethod delete-construct :before ((construct CharacteristicAssociationC))
-  (delete-1-n-association construct 'charactersitic))
+  (delete-1-n-association construct 'characteristic))
 
 
 ;;; OccurrenceAssociationC
@@ -867,30 +856,40 @@
 
 ;;; TopicC
 (defmethod delete-construct :before ((construct TopicC))
-  (let ((psis-to-delete
-	 (map 'list #'identifier (slot-p construct 'psis)))
-	(sls-to-delete
-	 (map 'list #'identifier (slot-p construct 'locators)))
-	(names-to-delete
-	 (map 'list #'characteristic (slot-p construct 'names)))
-	(occurrences-to-delete (slot-p construct 'occurrences))
-	(roles-to-delete
-	 (map 'list #'parent-construct (slot-p construct 'player-in-roles)))
-	(typables-to-delete
-	 (map 'list #'typable-construct (slot-p construct 'used-as-type)))
+  (let ((psi-assocs-to-delete (slot-p construct 'psis))
+	(sl-assocs-to-delete (slot-p construct 'locators))
+	(name-assocs-to-delete (slot-p construct 'names))
+	(occ-assocs-to-delete (slot-p construct 'occurrences))
+	(role-assocs-to-delete (slot-p construct 'player-in-roles))
+	(type-assocs-to-delete (slot-p construct 'used-as-type))
+	(scope-assocs-to-delete (slot-p construct 'used-as-theme))
 	(reifier-assocs-to-delete (slot-p construct 'reified-construct)))
-    (dolist (construct-to-delete (append psis-to-delete
-					 sls-to-delete
-					 names-to-delete
-					 occurrences-to-delete
-					 roles-to-delete
-					 typables-to-delete
-					 reifier-assocs-to-delete))
-      (delete-construct construct-to-delete)))
-  (dolist (scope-assoc-to-delete (slot-p construct 'used-as-theme))
-    (delete-construct scope-assoc-to-delete))
-  (dolist (tm (slot-p construct 'in-topicmaps))
-    (remove-association construct 'in-topicmaps tm)))
+    (let ((all-psis (map 'list #'identifier psi-assocs-to-delete))
+	  (all-sls (map 'list #'identifier sl-assocs-to-delete))
+	  (all-names (map 'list #'characteristic name-assocs-to-delete))
+	  (all-occs (map 'list #'characteristic occ-assocs-to-delete))
+	  (all-roles (map 'list #'parent-construct role-assocs-to-delete))
+	  (all-types (map 'list #'typable-construct type-assocs-to-delete)))
+      (dolist (construct-to-delete (append psi-assocs-to-delete
+					   sl-assocs-to-delete
+					   name-assocs-to-delete
+					   occ-assocs-to-delete
+					   role-assocs-to-delete
+					   type-assocs-to-delete
+					   scope-assocs-to-delete
+					   reifier-assocs-to-delete))
+	(delete-construct construct-to-delete))
+      (dolist (candidate-to-delete (append all-psis all-sls all-names all-occs))
+	(unless (owned-p candidate-to-delete)
+	  (delete-construct candidate-to-delete)))
+      (dolist (candidate-to-delete all-roles)
+	(unless (player-p candidate-to-delete)
+	  (delete-construct candidate-to-delete)))
+      (dolist (candidate-to-delete all-types)
+	(unless (instance-of-p candidate-to-delete)
+	  (delete-construct candidate-to-delete)))
+      (dolist (tm (slot-p construct 'in-topicmaps))
+	(remove-association construct 'in-topicmaps tm)))))
 
 
 (defmethod owned-p ((construct TopicC))
@@ -1101,7 +1100,7 @@
   (:method ((construct TopicC) (name NameC)
 	    &key (revision (error "From delete-name(): revision must be set")))
     (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
-			      when (eql (parent-construct name-assoc) construct)
+			      when (eql (characteristic name-assoc) name)
 			      return name-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
@@ -1150,7 +1149,7 @@
   (:method ((construct TopicC) (occurrence OccurrenceC)
 	    &key (revision (error "From delete-occurrence(): revision must be set")))
     (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
-			      when (eql (parent-construct occ-assoc) construct)
+			      when (eql (characteristic occ-assoc) occurrence)
 			      return occ-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
@@ -1301,10 +1300,13 @@
 
 ;;; NameC
 (defmethod delete-construct :before ((construct NameC))
-  (dolist (variant-to-delete
-	    (map 'list #'characteristic
-		 (slot-p construct 'variants)))
-    (delete-construct variant-to-delete)))
+  (let ((variant-assocs-to-delete (slot-p construct 'variants)))
+    (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete)))
+      (dolist (variant-assoc-to-delete variant-assocs-to-delete)
+	(delete-construct variant-assoc-to-delete))
+      (dolist (candidate-to-delete all-variants)
+	(unless (owned-p candidate-to-delete)
+	  (delete-construct candidate-to-delete))))))
 
 
 (defgeneric variants (construct &key revision)
@@ -1432,11 +1434,15 @@
 
 ;;; AssociationC
 (defmethod delete-construct :before ((construct AssociationC))
-  (dolist (role-to-delete
-	    (map 'list #'role (slot-p construct 'roles)))
-    (delete-construct role-to-delete))
-  (dolist (tm (slot-p construct 'in-topicmaps))
-    (remove-association construct 'in-topicmaps tm)))
+  (let ((roles-assocs-to-delete (slot-p construct 'roles)))
+    (let ((all-roles (map 'list #'role roles-assocs-to-delete)))
+      (dolist (role-assoc-to-delete roles-assocs-to-delete)
+	(delete-construct role-assoc-to-delete))
+      (dolist (candidate-to-delete all-roles)
+	(unless (owned-p candidate-to-delete)
+	  (delete-construct candidate-to-delete)))
+      (dolist (tm (slot-p construct 'in-topicmaps))
+	(remove-association construct 'in-topicmaps tm)))))
 
 
 (defmethod owned-p ((construct AssociationC))
@@ -1499,6 +1505,14 @@
     (delete-construct player-assoc-to-delete)))
 
 
+(defgeneric player-p (construct)
+  (:documentation "Returns t if a player is set in this role.
+		   t is also returned if the player is markes-as-deleted.")
+  (:method ((construct RoleC))
+    (when (slot-p construct 'player)
+      t)))
+
+
 (defmethod owned-p ((construct RoleC))
   (when (slot-p construct 'parent)
     t))
@@ -1573,7 +1587,7 @@
 	      return player-assoc)))
       (when (and already-set-player
 		 (not (eql already-set-player player-topic)))
-	(error "From add-player(): ~a can't be palyed by ~a since it is played by ~a"
+	(error "From add-player(): ~a can't be played by ~a since it is played by ~a"
 	       construct player-topic already-set-player))
       (cond (already-set-player
 	     (let ((player-assoc
@@ -1598,7 +1612,7 @@
 	    &key (revision (error "From delete-parent(): revision must be set")))
     (let ((assoc-to-delete
 	   (loop for player-assoc in (slot-p construct 'player)
-	      when (eql (player-topic player-assoc) player-topic)
+	      when (eql (parent-construct player-assoc) construct)
 	      return player-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
@@ -1607,12 +1621,15 @@
 
 ;;; ReifiableConstructC
 (defmethod delete-construct :before ((construct ReifiableConstructC))
-  (let ((iis-to-delete
-	 (map 'list #'identifier (slot-p construct 'item-identifiers)))
-	(reifier-tops-to-delete
-	 (map 'list #'reifier-topic (slot-p construct 'reifier))))
-    (dolist (construct-to-delete (append iis-to-delete reifier-tops-to-delete))
-      (delete-construct construct-to-delete))))
+  (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers))
+	(reifier-assocs-to-delete (slot-p construct 'reifier)))
+    (let ((all-iis (map 'list #'identifier ii-assocs-to-delete)))
+      (dolist (construct-to-delete (append ii-assocs-to-delete
+					   reifier-assocs-to-delete))
+	(delete-construct construct-to-delete))
+      (dolist (ii all-iis)
+	(unless (owned-p ii)
+	  (delete-construct ii))))))
 
 
 (defgeneric item-identifiers (construct &key revision)
@@ -1784,6 +1801,15 @@
   (dolist (type-assoc-to-delete (slot-p construct 'instance-of))
     (delete-construct type-assoc-to-delete)))
 
+
+(defgeneric instance-of-p (construct)
+  (:documentation "Returns t if there is any type set in this object.
+                   t is also returned if the type is marked-as-deleted.")
+  (:method ((construct TypableC))
+    (when (slot-p construct 'instance-of)
+      t)))
+
+
 (defgeneric instance-of (construct &key revision)
   (:documentation "Returns the type topic that is set on the passed
                    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	Wed Mar 10 08:59:47 2010
@@ -39,10 +39,17 @@
 	   :test-TopicMapC
 	   :test-delete-ItemIdentifierC
 	   :test-delete-PersistentIdC
-	   :test-delete-SubjectLocatorC))
+	   :test-delete-SubjectLocatorC
+	   :test-delete-ReifiableConstructC
+	   :test-delete-VariantC
+	   :test-delete-NameC
+	   :test-delete-OccurrenceC
+	   :test-delete-TypableC
+	   :test-delete-ScopableC
+	   :test-delete-AssociationC
+	   :test-delete-RoleC))
 
 
-;;TODO: test delete-construct
 ;;TODO: test merge-constructs when merging was caused by an item-dentifier,
 ;;      a psi, a subject-locator, a topic-id
 ;;TODO: test merge-constructs when merging was caused by reifiers
@@ -957,9 +964,15 @@
       (add-item-identifier name-2 ii-4 :revision revision-2)
       (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
 	     2))
-      (delete-construct ii-4)
-      (is-false (elephant:get-instances-by-class 'ItemIdentifierC))
-      (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)))))
+      (delete-construct occ-2)
+      (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1))
+      (is (= (length (union (list ii-4) (item-identifiers name-2))) 1))
+      (delete-construct name-2)
+      (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))
+      (is-false (elephant:get-instances-by-class 'ItemIdentifierC)))))
+
 
 
 (test test-delete-PersistentIdC ()
@@ -999,9 +1012,12 @@
       (add-psi topic-4 psi-4 :revision revision-2)
       (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
 	     2))
-      (delete-construct psi-4)
-      (is-false (elephant:get-instances-by-class 'PersistentIdC))
-      (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC)))))
+      (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1))
+      (delete-construct topic-2)
+      (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1))
+      (is (= (length (union (list psi-4) (psis topic-4))) 1)))))
 
 
 (test test-delete-SubjectLocatorC ()
@@ -1041,10 +1057,284 @@
       (add-locator topic-4 sl-4 :revision revision-2)
       (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
 	     2))
-      (delete-construct sl-4)
-      (is-false (elephant:get-instances-by-class 'SubjectLocatorC))
-      (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)))))
-      
+      (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1))
+      (delete-construct topic-2)
+      (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1))
+      (is (= (length (union (list sl-4) (locators topic-4))) 1)))))
+
+
+
+(test test-delete-ReifiableConstructC ()
+  "Tests the function delete-construct of the class ReifiableConstructC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((rc-1 (make-instance 'd::ReifiableConstructC))
+	  (rc-2 (make-instance 'd::ReifiableConstructC))
+	  (reifier-1 (make-instance 'TopicC))
+	  (reifier-2 (make-instance 'TopicC))
+	  (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-reifier rc-1 reifier-1)
+      (add-item-identifier rc-1 ii-1)
+      (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
+	     2))
+      (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
+	     1))
+      (delete-reifier rc-1 reifier-1 :revision revision-2)
+      (delete-item-identifier rc-1 ii-1 :revision revision-2)
+      (add-reifier rc-2 reifier-1 :revision revision-2)
+      (add-item-identifier rc-2 ii-1 :revision revision-2)
+      (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
+	     2))
+      (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
+	     2))
+      (delete-construct rc-1)
+      (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
+	     1))
+      (is (= (length (union (list ii-1) (item-identifiers rc-2))) 1))
+      (is (eql reifier-1 (reifier rc-2)))
+      (delete-construct ii-1)
+      (delete-construct reifier-1)
+      (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
+	     1))
+      (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))
+      (is-false (elephant:get-instances-by-class 'd::ReifierAssociationC))
+      (delete-construct reifier-2)
+      (is-false (elephant:get-instances-by-class 'd::ReifierAssociationC)))))
+
+
+(test test-delete-VariantC ()
+  "Tests the function delete-construct of the class VariantC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((name-1 (make-instance 'NameC))
+	  (name-2 (make-instance 'NameC))
+	  (variant-1 (make-instance 'VariantC))
+	  (variant-2 (make-instance 'VariantC))
+	  (variant-3 (make-instance 'VariantC))
+	  (variant-4 (make-instance 'VariantC))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-variant name-1 variant-1)
+      (add-variant name-1 variant-2)
+      (add-variant name-1 variant-3)
+      (delete-variant name-1 variant-1 :revision revision-2)
+      (delete-variant name-1 variant-2 :revision revision-2)
+      (add-variant name-2 variant-1 :revision revision-2)
+      (add-variant name-2 variant-2 :revision revision-2)
+      (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC))
+	     5))
+      (delete-construct variant-1)
+      (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC))
+	     3))
+      (is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
+      (delete-construct name-1)
+      (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'VariantC)) 2))
+      (delete-construct name-2)
+      (is (= (length (elephant:get-instances-by-class 'VariantC)) 1))
+      (is-false (elephant:get-instances-by-class 'd::VariantAssociationC))
+      (delete-construct variant-4)
+      (is-false (elephant:get-instances-by-class 'VariantC)))))
+
+
+(test test-delete-NameC ()
+  "Tests the function delete-construct of the class NameC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((topic-1 (make-instance 'TopicC))
+	  (topic-2 (make-instance 'TopicC))
+	  (name-1 (make-instance 'NameC))
+	  (name-2 (make-instance 'NameC))
+	  (name-3 (make-instance 'NameC))
+	  (name-4 (make-instance 'NameC))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-name topic-1 name-1)
+      (add-name topic-1 name-2)
+      (add-name topic-1 name-3)
+      (delete-name topic-1 name-1 :revision revision-2)
+      (delete-name topic-1 name-2 :revision revision-2)
+      (add-name topic-2 name-1 :revision revision-2)
+      (add-name topic-2 name-2 :revision revision-2)
+      (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC))
+	     5))
+      (delete-construct name-1)
+      (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC))
+	     3))
+      (is (= (length (elephant:get-instances-by-class 'NameC)) 3))
+      (delete-construct topic-1)
+      (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'NameC)) 2))
+      (delete-construct topic-2)
+      (is (= (length (elephant:get-instances-by-class 'NameC)) 1))
+      (is-false (elephant:get-instances-by-class 'd::NameAssociationC))
+      (delete-construct name-4)
+      (is-false (elephant:get-instances-by-class 'NameC)))))
+
+
+(test test-delete-OccurrenceC ()
+  "Tests the function delete-construct of the class OccurrenceC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((topic-1 (make-instance 'TopicC))
+	  (topic-2 (make-instance 'TopicC))
+	  (occurrence-1 (make-instance 'OccurrenceC))
+	  (occurrence-2 (make-instance 'OccurrenceC))
+	  (occurrence-3 (make-instance 'OccurrenceC))
+	  (occurrence-4 (make-instance 'OccurrenceC))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-occurrence topic-1 occurrence-1)
+      (add-occurrence topic-1 occurrence-2)
+      (add-occurrence topic-1 occurrence-3)
+      (delete-occurrence topic-1 occurrence-1 :revision revision-2)
+      (delete-occurrence topic-1 occurrence-2 :revision revision-2)
+      (add-occurrence topic-2 occurrence-1 :revision revision-2)
+      (add-occurrence topic-2 occurrence-2 :revision revision-2)
+      (is (= (length (elephant:get-instances-by-class
+		      'd::OccurrenceAssociationC)) 5))
+      (delete-construct occurrence-1)
+      (is (= (length (elephant:get-instances-by-class
+		      'd::OccurrenceAssociationC)) 3))
+      (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3))
+      (delete-construct topic-1)
+      (is (= (length (elephant:get-instances-by-class
+		      'd::OccurrenceAssociationC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2))
+      (delete-construct topic-2)
+      (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 1))
+      (is-false (elephant:get-instances-by-class 'd::OccurrenceAssociationC))
+      (delete-construct occurrence-4)
+      (is-false (elephant:get-instances-by-class 'OccurrenceC)))))
+
+
+(test test-delete-TypableC ()
+  "Tests the function delete-construct of the class TypableC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((name-1 (make-instance 'NameC))
+	  (name-2 (make-instance 'NameC))
+	  (type-1 (make-instance 'TopicC))
+	  (type-2 (make-instance 'TopicC))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-type name-1 type-1)
+      (delete-type name-1 type-1 :revision revision-2)
+      (add-type name-1 type-2 :revision revision-2)
+      (add-type name-2 type-2)
+      (is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 3))
+      (is (= (length (elephant:get-instances-by-class 'd::NameC)) 2))
+      (delete-construct type-2)
+      (is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'd::NameC)) 1))
+      (delete-construct name-1)
+      (is-false (elephant:get-instances-by-class 'd::TypeAssociationC))
+      (is-false (elephant:get-instances-by-class 'd::NameC)))))
+
+
+(test test-delete-ScopableC ()
+  "Tests the function delete-construct of the class ScopableC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((assoc-1 (make-instance 'AssociationC))
+	  (assoc-2 (make-instance 'AssociationC))
+	  (assoc-3 (make-instance 'AssociationC))
+	  (scope-1 (make-instance 'TopicC))
+	  (scope-2 (make-instance 'TopicC))
+	  (scope-3 (make-instance 'TopicC))
+	  (revision-1 100))
+      (setf *TM-REVISION* revision-1)
+      (add-theme assoc-1 scope-1)
+      (add-theme assoc-1 scope-2)
+      (add-theme assoc-2 scope-1)
+      (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC))
+	     3))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
+      (delete-construct scope-1)
+      (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC))
+	     1))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
+      (delete-construct assoc-1)
+      (is-false (elephant:get-instances-by-class 'd::ScopeAssociationC))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2))
+      (add-theme assoc-2 scope-3)
+      (add-theme assoc-3 scope-3)
+      (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC))
+	     2))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2))
+      (delete-construct assoc-2)
+      (is (= (length (union (list scope-3) (themes assoc-3))) 1)))))
+
+
+(test test-delete-AssociationC ()
+  "Tests the function delete-construct of the class AssociationC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((role-1 (make-instance 'RoleC))
+	  (role-2 (make-instance 'RoleC))
+	  (assoc-1 (make-instance 'AssociationC))
+	  (assoc-2 (make-instance 'AssociationC))
+	  (assoc-3 (make-instance 'AssociationC))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-role assoc-1 role-1)
+      (delete-role assoc-1 role-1 :revision revision-2)
+      (add-role assoc-2 role-1 :revision revision-2)
+      (add-role assoc-2 role-2)
+      (is (= (length (elephant:get-instances-by-class 'RoleC)) 2))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
+      (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 3))
+      (delete-construct role-1)
+      (is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
+      (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 1))
+      (delete-role assoc-2 role-2 :revision revision-2)
+      (add-role assoc-3 role-2 :revision revision-2)
+      (is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
+      (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 2))
+      (delete-construct assoc-3)
+      (is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2))
+      (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC))
+	     1)))))
+
+
+(test test-delete-RoleC ()
+  "Tests the function delete-construct of the class RoleC"
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((role-1 (make-instance 'RoleC))
+	  (role-2 (make-instance 'RoleC))
+	  (player-1 (make-instance 'TopicC))
+	  (player-2 (make-instance 'TopicC))
+	  (revision-1 100)
+	  (revision-2 200))
+      (setf *TM-REVISION* revision-1)
+      (add-player role-1 player-1)
+      (delete-player role-1 player-1 :revision revision-2)
+      (add-player role-1 player-2 :revision revision-2)
+      (add-player role-2 player-1)
+      (is (= (length (elephant:get-instances-by-class 'RoleC)) 2))
+      (is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC))
+	     3))
+      (delete-construct player-1)
+      (is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC))
+	     1))
+      (delete-construct role-1)
+      (is-false (elephant:get-instances-by-class 'RoleC))
+      (is-false (elephant:get-instances-by-class 'd::PlayerAssociationC)))))
 
 
 (defun run-datamodel-tests()
@@ -1071,4 +1361,12 @@
   (it.bese.fiveam:run! 'test-delete-ItemIdentifierC)
   (it.bese.fiveam:run! 'test-delete-PersistentIdC)
   (it.bese.fiveam:run! 'test-delete-SubjectLocatorC)
+  (it.bese.fiveam:run! 'test-delete-ReifiableConstructC)
+  (it.bese.fiveam:run! 'test-delete-VariantC)
+  (it.bese.fiveam:run! 'test-delete-NameC)
+  (it.bese.fiveam:run! 'test-delete-OccurrenceC)
+  (it.bese.fiveam:run! 'test-delete-TypableC)
+  (it.bese.fiveam:run! 'test-delete-ScopableC)
+  (it.bese.fiveam:run! 'test-delete-AssociationC)
+  (it.bese.fiveam:run! 'test-delete-RoleC)
   )
\ No newline at end of file




More information about the Isidorus-cvs mailing list