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

Lukas Giessmann lgiessmann at common-lisp.net
Fri Apr 9 15:36:02 UTC 2010


Author: lgiessmann
Date: Fri Apr  9 11:36:02 2010
New Revision: 271

Log:
new-datamodel: added some unit-tests; fixed bugs in "add-name", "add-occurrence", "add-role" and "find-oldest-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	Fri Apr  9 11:36:02 2010
@@ -157,16 +157,18 @@
 
 
 
+;;TODO: modify 2x add-parent --> use add-characteristic and add-role
+;;TODO: call merge-if-equivalent in 2x add-parent
 ;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
 ;;      versioned-construct of the called construct, same for add-xy ???
+;;      and associations of player
 ;;TODO: check for duplicate identifiers after topic-creation/merge
 ;;TODO: check merge-constructs in add-topic-identifier,
 ;;      add-item-identifier/add-reifier (can merge the parent constructs
 ;;      and the parent's parent construct + the reifier constructs),
 ;;      add-psi, add-locator (--> duplicate-identifier-error)
-;;TODO: implement a macro "with-merge-construct" that merges constructs
-;;      after some data-operations are completed (should be passed as body)
-;;      and a merge should be done
+;;TODO: implement a macro with-merge-constructs, that merges constructs
+;;      after all operations in the body were called
 
 
 
@@ -840,6 +842,19 @@
 
 
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric merge-if-equivalent (new-characteristic parent-construct
+						    &key revision)
+  (:documentation "Merges the new characteristic/role with one equivalent of the
+                   parent's charateristics/roles instead of adding the entire new
+                   characteristic/role to the parent."))
+
+
+(defgeneric parent (construct &key revision)
+  (:documentation "Returns the parent construct of the passed object that
+                   corresponds with the given revision. The returned construct
+                   can be a TopicC or a NameC."))
+
+
 (defgeneric delete-if-not-referenced (construct)
   (:documentation "Calls delete-construct for the given object if it is
                    not referenced by any other construct."))
@@ -1672,20 +1687,22 @@
 			     :referenced-construct name
 			     :existing-reference (parent name :revision revision)
 			     :new-reference construct)))
-    (let ((all-names
-	   (map 'list #'characteristic (slot-p construct 'names))))
-      (if (find name all-names)
-	  (let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
-			       when (eql (parent-construct name-assoc)
-					 construct)
-			       return name-assoc)))
-	    (add-to-version-history name-assoc :start-revision revision))
-	  (make-construct 'NameAssociationC
-			  :parent-construct construct
-			  :characteristic name
-			  :start-revision revision)))
-    (add-to-version-history construct :start-revision revision)
-    construct))
+    (if (merge-if-equivalent name construct :revision revision)
+	construct
+	(let ((all-names
+	       (map 'list #'characteristic (slot-p construct 'names))))
+	  (if (find name all-names)
+	      (let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
+				   when (eql (parent-construct name-assoc)
+					     construct)
+				   return name-assoc)))
+		(add-to-version-history name-assoc :start-revision revision))
+	      (make-construct 'NameAssociationC
+			      :parent-construct construct
+			      :characteristic name
+			      :start-revision revision))
+	  (add-to-version-history construct :start-revision revision)
+	  construct))))
 
 
 (defgeneric delete-name (construct name &key revision)
@@ -1730,19 +1747,21 @@
 	     :referenced-construct occurrence
 	     :existing-reference (parent occurrence :revision revision)
 	     :new-reference construct))
-    (let ((all-occurrences
-	   (map 'list #'characteristic (slot-p construct 'occurrences))))
-      (if (find occurrence all-occurrences)
-	  (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
-			      when (eql (parent-construct occ-assoc) construct)
-			      return occ-assoc)))
-	    (add-to-version-history occ-assoc :start-revision revision))
-	  (make-construct 'OccurrenceAssociationC
-			  :parent-construct construct
-			  :characteristic occurrence
-			  :start-revision revision)))
-    (add-to-version-history construct :start-revision revision)
-    construct))
+    (if (merge-if-equivalent occurrence construct :revision revision)
+	construct
+	(let ((all-occurrences
+	       (map 'list #'characteristic (slot-p construct 'occurrences))))
+	  (if (find occurrence all-occurrences)
+	      (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
+				  when (eql (parent-construct occ-assoc) construct)
+				  return occ-assoc)))
+		(add-to-version-history occ-assoc :start-revision revision))
+	      (make-construct 'OccurrenceAssociationC
+			      :parent-construct construct
+			      :characteristic occurrence
+			      :start-revision revision))
+	  (add-to-version-history construct :start-revision revision)
+	  construct))))
 
 
 (defgeneric delete-occurrence (construct occurrence &key revision)
@@ -2000,8 +2019,9 @@
 ;;; CharacteristicC
 (defmethod delete-if-not-referenced ((construct CharacteristicC))
   (let ((references (slot-p construct 'parent)))
-    (when (and (<= (length references) 1)
-	       (marked-as-deleted-p (first references)))
+    (when (or (not references)
+	      (and (= (length references) 1)
+		   (marked-as-deleted-p (first references))))
       (delete-construct construct))))
 
 
@@ -2099,16 +2119,12 @@
     t))
 
 
-(defgeneric parent (construct &key revision)
-  (:documentation "Returns the parent construct of the passed object that
-                   corresponds with the given revision. The returned construct
-                   can be a TopicC or a NameC.")
-  (:method ((construct CharacteristicC) &key (revision *TM-REVISION*))
-    (let ((valid-associations
-	   (filter-slot-value-by-revision construct 'parent
-					  :start-revision revision)))
-      (when valid-associations
-	(parent-construct (first valid-associations))))))
+(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*))
+  (let ((valid-associations
+	 (filter-slot-value-by-revision construct 'parent
+					:start-revision revision)))
+    (when valid-associations
+      (parent-construct (first valid-associations)))))
 
 
 (defmethod add-parent ((construct CharacteristicC)
@@ -2290,19 +2306,21 @@
 			     :referenced-construct variant
 			     :existing-reference (parent variant :revision revision)
 			     :new-reference construct)))
-    (let ((all-variants 
-	   (map 'list #'characteristic (slot-p construct 'variants))))
-      (if (find variant all-variants)
-	  (let ((variant-assoc
-		 (loop for variant-assoc in (slot-p construct 'variants)
-		    when (eql (characteristic variant-assoc) variant)
-		    return variant-assoc)))
-	    (add-to-version-history variant-assoc :start-revision revision))
-	  (make-construct 'VariantAssociationC
-			  :characteristic variant
-			  :parent-construct construct
-			  :start-revision revision)))
-    construct))
+    (if (merge-if-equivalent variant construct :revision revision)
+	construct
+	(let ((all-variants 
+	       (map 'list #'characteristic (slot-p construct 'variants))))
+	  (if (find variant all-variants)
+	      (let ((variant-assoc
+		     (loop for variant-assoc in (slot-p construct 'variants)
+			when (eql (characteristic variant-assoc) variant)
+			return variant-assoc)))
+		(add-to-version-history variant-assoc :start-revision revision))
+	      (make-construct 'VariantAssociationC
+			      :characteristic variant
+			      :parent-construct construct
+			      :start-revision revision))
+	  construct))))
 
 
 (defgeneric delete-variant (construct variant &key revision)
@@ -2417,20 +2435,22 @@
   (:documentation "Adds the given role to the passed association-construct.")
   (:method ((construct AssociationC) (role RoleC)
 	    &key (revision *TM-REVISION*))
-    (let ((all-roles
-	   (map 'list #'role  (slot-p construct 'roles))))
-      (if (find role all-roles)
-	  (let ((role-assoc
-		 (loop for role-assoc in (slot-p construct 'roles)
-		    when (eql (role role-assoc) role)
-		    return role-assoc)))
-	    (add-to-version-history role-assoc  :start-revision revision))
-	  (make-construct 'RoleAssociationC
-			  :role role
-			  :parent-construct construct
-			  :start-revision revision)))
-    (add-to-version-history construct :start-revision revision)
-    construct))
+    (if (merge-if-equivalent role construct :revision revision)
+	construct
+	(let ((all-roles
+	       (map 'list #'role  (slot-p construct 'roles))))
+	  (if (find role all-roles)
+	      (let ((role-assoc
+		     (loop for role-assoc in (slot-p construct 'roles)
+			when (eql (role role-assoc) role)
+			return role-assoc)))
+		(add-to-version-history role-assoc  :start-revision revision))
+	      (make-construct 'RoleAssociationC
+			      :role role
+			      :parent-construct construct
+			      :start-revision revision))
+	  (add-to-version-history construct :start-revision revision)
+	  construct))))
 
 
 (defgeneric delete-role (construct role &key revision)
@@ -2457,8 +2477,9 @@
 ;;; RoleC
 (defmethod delete-if-not-referenced ((construct RoleC))
   (let ((references (slot-p construct 'parent)))
-    (when (and (<= (length references) 1)
-	       (marked-as-deleted-p (first references)))
+    (when (or (not references)
+	      (and (= (length references) 1)
+		   (marked-as-deleted-p (first references))))
       (delete-construct construct))))
 
 
@@ -2988,7 +3009,7 @@
   (:method ((construct ScopableC) (theme-topic TopicC)
 	    &key (revision (error (make-condition 'missing-argument-error
 						  :message "From delete-theme(): revision must be set"
-						  :argument-symbol 'revsion
+						  :argument-symbol 'revision
 						  :function-symbol 'delete-theme))))
     (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
 			      when (eql (theme-topic theme-assoc) theme-topic)
@@ -3388,7 +3409,7 @@
 	       (not start-revision))
       (error (make-condition 'missing-argument-error
 			     :message "From make-characteristic(): start-revision must be set"
-			     :argument-symbol 'start-revsion
+			     :argument-symbol 'start-revision
 			     :function-symbol 'make-characgteristic)))
     (let ((characteristic
 	   (let ((existing-characteristic
@@ -3895,4 +3916,59 @@
 		   (move-referenced-constructs newer-role older-role
 					       :revision revision)
 		   (delete-if-not-referenced newer-role)
-		   older-role)))))))
\ No newline at end of file
+		   older-role)))))))
+
+
+(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC)
+				&key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (let ((possible-roles
+	 (remove-if #'(lambda(role)
+			(when (parent role :revision revision)
+			  role))
+		    (map 'list #'role (slot-p parent-construct 'roles)))))
+    (let ((equivalent-role
+	   (remove-if
+	    #'null
+	    (map 'list
+		 #'(lambda(role)
+		     (when
+			 (strictly-equivalent-constructs role new-role
+							 :revision revision)
+		       role))
+		 possible-roles))))
+      (when equivalent-role
+	(merge-constructs (first equivalent-role) new-role
+			  :revision revision)))))
+		      
+
+(defmethod merge-if-equivalent ((new-characteristic CharacteristicC)
+				(parent-construct ReifiableConstructC)
+				&key (revision *TM-REVISION*))
+  (declare (integer revision) (type (or TopicC NameC) parent-construct))
+  (let ((all-existing-characteristics
+	 (map 'list #'characteristic
+	      (cond ((typep new-characteristic 'OccurrenceC)
+		     (slot-p parent-construct 'occurrences))
+		    ((typep new-characteristic 'NameC)
+		     (slot-p parent-construct 'names))
+		    ((typep new-characteristic 'VariantC)
+		     (slot-p parent-construct 'variants))))))
+    (let ((possible-characteristics ;all characteristics that are not referenced
+				    ;other constructs at the given revision
+	   (remove-if #'(lambda(char)
+			  (parent char :revision revision))
+		      all-existing-characteristics)))
+      (let ((equivalent-construct
+	     (remove-if
+	      #'null
+	      (map 'list
+		   #'(lambda(char)
+		       (when
+			   (strictly-equivalent-constructs char new-characteristic
+							   :revision revision)
+			 char))
+		   possible-characteristics))))
+	(when equivalent-construct
+	  (merge-constructs (first equivalent-construct) new-characteristic
+			    :revision revision))))))
\ No newline at end of file

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 Apr  9 11:36:02 2010
@@ -2741,53 +2741,67 @@
 (test test-find-oldest-construct ()
   "Tests the generic find-oldest-construct."
   (with-fixture with-empty-db (*db-dir*)
-    (let ((top-1 (make-instance 'TopicC))
-	  (top-2 (make-instance 'TopicC))
-	  (tm-1 (make-instance 'TopicMapC))
-	  (tm-2 (make-instance 'TopicMapC))
-	  (assoc-1 (make-instance 'AssociationC))
-	  (assoc-2 (make-instance 'AssociationC))
-	  (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
-	  (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
-	  (variant-1 (make-instance 'VariantC))
-	  (variant-2 (make-instance 'VariantC))
-	  (name-1 (make-instance 'NameC))
-	  (name-2 (make-instance 'NameC))
-	  (role-1 (make-instance 'RoleC))
-	  (role-2 (make-instance 'RoleC))
-	  (rev-1 100)
+    (let ((rev-1 100)
 	  (rev-2 200)
 	  (rev-3 300))
-      (setf *TM-REVISION* rev-1)
-      (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
-      (add-item-identifier top-1 ii-1 :revision rev-3)
-      (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
-      (add-item-identifier assoc-1 ii-2 :revision rev-2)
-      (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
-      (add-item-identifier top-2 ii-1 :revision rev-1)
-      (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
-      (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
-      (add-variant name-1 variant-1 :revision rev-3)
-      (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
-      (add-variant name-1 variant-2 :revision rev-2)
-      (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2)))
-      (add-variant name-2 variant-1 :revision rev-1)
-      (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
-      (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
-      (add-role assoc-1 role-1 :revision rev-3)
-      (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
-      (add-role assoc-1 role-2 :revision rev-2)
-      (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
-      (add-role assoc-2 role-1 :revision rev-1)
-      (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
-      (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
-      (d::add-to-version-history tm-1 :start-revision rev-3)
-      (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
-      (d::add-to-version-history tm-2 :start-revision rev-1)
-      (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
-      (d::add-to-version-history tm-1 :start-revision rev-1)
-      (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
-      (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))
+      (let ((theme-1 (make-construct 'TopicC :start-revision rev-1))
+	    (theme-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)))
+	(let ((top-1 (make-instance 'TopicC))
+	      (top-2 (make-instance 'TopicC))
+	      (tm-1 (make-instance 'TopicMapC))
+	      (tm-2 (make-instance 'TopicMapC))
+	      (assoc-1 (make-instance 'AssociationC))
+	      (assoc-2 (make-instance 'AssociationC))
+	      (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+	      (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+	      (variant-1 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :charvalue "var-1"
+					 :themes (list theme-1)))
+	      (variant-2 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :charvalue "var-2"
+					 :themes (list theme-2)))
+	      (name-1 (make-instance 'NameC))
+	      (name-2 (make-instance 'NameC))
+	      (role-1 (make-construct 'RoleC
+				      :start-revision rev-1
+				      :player player-1))
+	      (role-2 (make-construct 'RoleC
+				      :start-revision rev-1
+				      :player player-2)))
+	  (setf *TM-REVISION* rev-1)
+	  (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+	  (add-item-identifier top-1 ii-1 :revision rev-3)
+	  (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+	  (add-item-identifier assoc-1 ii-2 :revision rev-2)
+	  (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
+	  (add-item-identifier top-2 ii-1 :revision rev-1)
+	  (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+	  (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+	  (add-variant name-1 variant-1 :revision rev-3)
+	  (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+	  (add-variant name-1 variant-2 :revision rev-2)
+	  (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) ;x
+	  (add-variant name-2 variant-1 :revision rev-1)
+	  (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+	  (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+	  (add-role assoc-1 role-1 :revision rev-3)
+	  (is (eql role-1 (d::find-oldest-construct role-1 role-2))) ;x
+	  (add-role assoc-1 role-2 :revision rev-2)
+	  (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
+	  (add-role assoc-2 role-1 :revision rev-1)
+	  (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+	  (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+	  (d::add-to-version-history tm-1 :start-revision rev-3)
+	  (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+	  (d::add-to-version-history tm-2 :start-revision rev-1)
+	  (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
+	  (d::add-to-version-history tm-1 :start-revision rev-1)
+	  (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+	  (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))))
 
 
 (test test-move-referenced-constructs-ReifiableConstructC ()




More information about the Isidorus-cvs mailing list