Changeset 292 for branches/new-datamodel/src/unit_tests

Timestamp:

04/29/10 15:07:06 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: fixed two bugs in "merge-constructs" corresponding to "AssociationC"

File:

• branches/new-datamodel/src/unit_tests/datamodel_test.lisp (modified) (13 diffs)

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

@@ -91 +91 @@
            :test-merge-constructs-TopicC-8
            :test-merge-constructs-TopicC-9
-           :test-merge-constructs-TopicC-10))
+           :test-merge-constructs-TopicC-10
+           :test-merge-constructs-AssociationC))
 
 
@@ -2939 +2940 @@
 
 (test test-merge-constructs-TopicC-1 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3052 +3053 @@
 
 (test test-merge-constructs-TopicC-2 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3166 +3167 @@
 
 (test test-merge-constructs-TopicC-3 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3266 +3267 @@
 
 (test test-merge-constructs-TopicC-4 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3324 +3325 @@
 
 (test test-merge-constructs-TopicC-5 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3382 +3383 @@
 
 (test test-merge-constructs-TopicC-6 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3453 +3454 @@
 
 (test test-merge-constructs-TopicC-7 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3522 +3523 @@
 
 (test test-merge-constructs-TopicC-8 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3588 +3589 @@
 
 (test test-merge-constructs-TopicC-9 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3642 +3643 @@
 
 (test test-merge-constructs-TopicC-10 ()
-  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  "Tests the generic merge-constructs corresÃŒponding to TopicC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((rev-1 100)
@@ -3717 +3718 @@
             (is-false (set-exclusive-or (list variant-2) (variants name-4)))
             (is (= (length (d::versions top-1)) 2))))))))
-                                      
-
-
-;;TODO: merge associations caused by a merge of their roles
-
-
+
+
+(test test-merge-constructs-AssociationC ()
+  "Tests merge-constructs corresponding to AssociationC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((rev-1 100)
+          (rev-2 200)
+          (rev-3 300))
+      (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+            (r-type-1 (make-construct 'TopicC :start-revision rev-1))
+            (r-type-2 (make-construct 'TopicC :start-revision rev-1))
+            (player-1 (make-construct 'TopicC :start-revision rev-1))
+            (player-2 (make-construct 'TopicC :start-revision rev-1))
+            (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+            (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
+        (let ((role-1 (list :start-revision rev-1
+                            :player player-1
+                            :instance-of r-type-1))
+              (role-2-1 (list :start-revision rev-1
+                              :player player-1
+                              :instance-of r-type-2))
+              (role-2-2 (list :start-revision rev-2
+                              :player player-1
+                              :item-identifiers (list ii-2)
+                              :instance-of r-type-2))
+              (role-3 (list :start-revision rev-2
+                            :player player-2
+                            :instance-of r-type-1
+                            :item-identifiers (list ii-1)
+                            :instance-of r-type-2)))
+          (let ((assoc-1 (make-construct 'AssociationC
+                                         :start-revision rev-1
+                                         :instance-of type-1
+                                         :roles (list role-1 role-2-1)))
+                (assoc-2 (make-construct 'AssociationC
+                                         :start-revision rev-2
+                                         :instance-of type-1
+                                         :roles (list role-2-2 role-3))))
+            (setf *TM-REVISION* rev-3)
+            (is (= (length (get-all-associations nil)) 2))
+            (make-construct 'AssociationC
+                            :start-revision rev-2
+                            :instance-of type-1
+                            :roles (list role-1 role-2-1))
+            (is (= (length (get-all-associations nil)) 2))
+            (let ((role-2-1-inst
+                   (find-if #'(lambda(role)
+                                (and (eql (instance-of role) r-type-2)
+                                     (eql (player role) player-1)))
+                            (roles assoc-1))))
+              (is-true role-2-1-inst)
+              (is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst))
+              (is-true (marked-as-deleted-p assoc-2))
+              (is-false (roles assoc-2))
+              (is-false (instance-of assoc-2))
+              (is-false (themes assoc-2))
+              (is (eql (instance-of assoc-2 :revision rev-2) type-1))
+              (is (= (length (roles assoc-1)) 3))
+              (is-true (find-if #'(lambda(role)
+                                    (and (eql (instance-of role) r-type-1)
+                                         (eql (player role) player-1)))
+                                (roles assoc-1)))
+              (is-true (find-if #'(lambda(role)
+                                    (and (eql (instance-of role) r-type-1)
+                                         (eql (player role) player-2)
+                                         (not (set-exclusive-or
+                                               (list ii-1)
+                                               (item-identifiers role)))))
+                                (roles assoc-1)))
+              (is-true (find-if #'(lambda(role)
+                                    (and (eql (instance-of role) r-type-2)
+                                         (eql (player role) player-1)
+                                         (not (set-exclusive-or
+                                               (list ii-2)
+                                               (item-identifiers role)))))
+                                (roles assoc-1))))))))))
 
 
@@ -3793 +3864 @@
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9)
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10)
-  )
+  (it.bese.fiveam:run! 'test-merge-constructs-AssociationC))