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

Lukas Giessmann lgiessmann at common-lisp.net
Mon Apr 12 15:06:20 UTC 2010


Author: lgiessmann
Date: Mon Apr 12 11:06:19 2010
New Revision: 274

Log:
new-datamodel: added merging of characteristics when added with "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	Mon Apr 12 11:06:19 2010
@@ -157,12 +157,9 @@
 
 
 
-;;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),
@@ -842,6 +839,12 @@
 
 
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric find-self-or-equal (construct parent-construct &key revision)
+  (:documentation "Returns the construct 'construct' if is owned by the
+                   parent-construct or an equal construct or nil if there
+                   is no equal one."))
+
+
 (defgeneric merge-if-equivalent (new-characteristic parent-construct
 						    &key revision)
   (:documentation "Merges the new characteristic/role with one equivalent of the
@@ -1692,10 +1695,11 @@
 	(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)))
+	      (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
@@ -1752,9 +1756,10 @@
 	(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)))
+	      (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
@@ -2017,6 +2022,27 @@
 
 
 ;;; CharacteristicC
+(defmethod find-self-or-equal ((construct CharacteristicC)
+			       (parent-construct TopicC)
+			       &key (revision *TM-REVISION*))
+  (declare (integer revision) (type (or OccurrenceC NameC) construct))
+  (let ((chars (if (typep construct 'OccurrenceC)
+		   (occurrences parent-construct :revision revision)
+		   (names parent-construct :revision revision))))
+    (let ((self (find construct chars)))
+      (if self
+	  self
+	  (let ((equal-char
+		 (remove-if #'null
+			    (map 'list
+				 #'(lambda(char)
+				     (strictly-equivalent-constructs
+				      char construct :revision revision))
+				 chars))))
+	    (when equal-char
+	      (first equal-char)))))))
+
+
 (defmethod delete-if-not-referenced ((construct CharacteristicC))
   (let ((references (slot-p construct 'parent)))
     (when (or (not references)
@@ -2130,6 +2156,7 @@
 (defmethod add-parent ((construct CharacteristicC)
 		       (parent-construct ReifiableConstructC)
 		       &key (revision *TM-REVISION*))
+  (declare (integer revision))
   (let ((already-set-parent (parent construct :revision revision))
 	(same-parent-assoc ;should contain an object that was marked as deleted
 	 (loop for parent-assoc in (slot-p construct 'parent)
@@ -2143,29 +2170,36 @@
 			     :referenced-construct construct
 			     :existing-reference (parent construct :revision revision)
 			     :new-reference parent-construct)))
-    (cond (already-set-parent
-	   (let ((parent-assoc
-		  (loop for parent-assoc in (slot-p construct 'parent)
-		     when (eql parent-construct
-			       (parent-construct parent-assoc))
-		     return parent-assoc)))
-	     (add-to-version-history parent-assoc :start-revision revision)))
-	  (same-parent-assoc
-	   (add-to-version-history same-parent-assoc :start-revision revision))
-	  (t
-	   (let ((association-type (cond ((typep construct 'OccurrenceC)
-					  'OccurrenceAssociationC)
-					 ((typep construct 'NameC)
-					  'NameAssociationC)
-					 (t
-					  'VariantAssociationC))))
-	     (make-construct association-type
-			     :characteristic construct
-			     :parent-construct parent-construct
-			     :start-revision revision)))))
-  (when (typep parent-construct 'VersionedConstructC)
-    (add-to-version-history parent-construct :start-revision revision))
-  construct)
+    (let ((merged-char
+	   (merge-if-equivalent construct parent-construct :revision revision)))
+      (if merged-char
+	  merged-char
+	  (progn
+	    (cond (already-set-parent
+		   (let ((parent-assoc
+			  (loop for parent-assoc in (slot-p construct 'parent)
+			     when (eql parent-construct
+				       (parent-construct parent-assoc))
+			     return parent-assoc)))
+		     (add-to-version-history parent-assoc
+					     :start-revision revision)))
+		  (same-parent-assoc
+		   (add-to-version-history same-parent-assoc
+					   :start-revision revision))
+		  (t
+		   (let ((association-type (cond ((typep construct 'OccurrenceC)
+						  'OccurrenceAssociationC)
+						 ((typep construct 'NameC)
+						  'NameAssociationC)
+						 (t
+						  'VariantAssociationC))))
+		     (make-construct association-type
+				     :characteristic construct
+				     :parent-construct parent-construct
+				     :start-revision revision))))
+	    (when (typep parent-construct 'VersionedConstructC)
+	      (add-to-version-history parent-construct :start-revision revision))
+	    construct)))))
 
 
 (defmethod delete-parent ((construct CharacteristicC)
@@ -2215,6 +2249,24 @@
 
 
 ;;; VariantC
+(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC)
+			       &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (let ((vars (variants parent-construct :revision revision)))
+    (let ((self (find construct vars)))
+      (if self
+	  self
+	  (let ((equal-var
+		 (remove-if #'null
+			    (map 'list
+				 #'(lambda(var)
+				     (strictly-equivalent-constructs
+				      var construct :revision revision))
+				 vars))))
+	    (when equal-var
+	      (first equal-var)))))))
+
+
 (defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC)
 				  &key (revision *TM-REVISION*))
   (declare (ignorable revision))
@@ -2475,6 +2527,24 @@
 
 
 ;;; RoleC
+(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC)
+			       &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (let ((p-roles (roles parent-construct :revision revision)))
+    (let ((self (find construct p-roles)))
+      (if self
+	  self
+	  (let ((equal-role
+		 (remove-if #'null
+			    (map 'list
+				 #'(lambda(role)
+				     (strictly-equivalent-constructs
+				      role construct :revision revision))
+				 p-roles))))
+	    (when equal-role
+	      (first equal-role)))))))
+
+
 (defmethod delete-if-not-referenced ((construct RoleC))
   (let ((references (slot-p construct 'parent)))
     (when (or (not references)
@@ -2586,6 +2656,7 @@
 
 (defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
 			    &key (revision *TM-REVISION*))
+  (declare (integer revision))
   (let ((already-set-parent (parent construct :revision revision))
 	(same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent)
 			      when (eql parent-construct (parent-construct parent-assoc))
@@ -2598,22 +2669,29 @@
 			     :referenced-construct construct
 			     :existing-reference (parent construct :revision revision)
 			     :new-reference parent-construct)))
-    (cond (already-set-parent
-	   (let ((parent-assoc
-		  (loop for parent-assoc in (slot-p construct 'parent)
-		     when (eql parent-construct
-			       (parent-construct parent-assoc))
-		     return parent-assoc)))
-	     (add-to-version-history parent-assoc :start-revision revision)))
-	  (same-parent-assoc
-	   (add-to-version-history same-parent-assoc :start-revision revision))
-	  (t
-	   (make-construct 'RoleAssociationC
-			   :role construct
-			   :parent-construct parent-construct
-			   :start-revision revision))))
-  (add-to-version-history parent-construct :start-revision revision)
-  construct)
+    (let ((merged-role
+	   (merge-if-equivalent construct parent-construct :revision revision)))
+      (if merged-role
+	  merged-role
+	  (progn
+	    (cond (already-set-parent
+		   (let ((parent-assoc
+			  (loop for parent-assoc in (slot-p construct 'parent)
+			     when (eql parent-construct
+				       (parent-construct parent-assoc))
+			     return parent-assoc)))
+		     (add-to-version-history parent-assoc
+					     :start-revision revision)))
+		  (same-parent-assoc
+		   (add-to-version-history same-parent-assoc
+					   :start-revision revision))
+		  (t
+		   (make-construct 'RoleAssociationC
+				   :role construct
+				   :parent-construct parent-construct
+				   :start-revision revision)))
+	    (add-to-version-history parent-construct :start-revision revision)
+	    construct)))))
 
 
 (defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
@@ -3287,12 +3365,16 @@
 					   :instance-of instance-of)
 				      existing-role))
 			  (map 'list #'role (slot-p parent 'roles)))))))
-	     (cond ((> (length existing-roles) 1)
-		    (merge-all-constructs existing-roles))
-		   (existing-roles
-		    (first existing-roles))
-		   (t
-		    (make-instance 'RoleC))))))
+	     (if (and existing-roles
+		      (or (eql parent (parent (first existing-roles)
+					      :revision start-revision))
+			  (not (parent (first existing-roles)
+				       :revision start-revision))))
+		 (progn
+		   (add-role parent (first existing-roles)
+			     :revision start-revision)
+		   (first existing-roles))
+		 (make-instance 'RoleC)))))
       (when player
 	(add-player role player :revision start-revision))
       (when parent
@@ -3412,7 +3494,7 @@
 			     :argument-symbol 'start-revision
 			     :function-symbol 'make-characgteristic)))
     (let ((characteristic
-	   (let ((existing-characteristic
+	   (let ((existing-characteristics
 		  (when parent
 		    (remove-if
 		     #'null
@@ -3425,8 +3507,15 @@
 					   :instance-of instance-of)
 				      existing-characteristic))
 			  (get-all-characteristics parent class-symbol))))))
-	     (if existing-characteristic
-		 (first existing-characteristic)
+	     (if (and existing-characteristics
+		      (or (eql parent (parent (first existing-characteristics)
+					      :revision start-revision))
+			  (not (parent (first existing-characteristics)
+				       :revision start-revision))))
+		 (progn
+		   (add-characteristic parent (first existing-characteristics)
+				       :revision start-revision)
+		   (first existing-characteristics))
 		 (make-instance class-symbol :charvalue charvalue
 				:datatype datatype)))))
       (when (typep characteristic 'NameC)

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	Mon Apr 12 11:06:19 2010
@@ -80,7 +80,8 @@
 	   :test-make-TopicC
 	   :test-find-oldest-construct
 	   :test-move-referenced-constructs-ReifiableConstructC
-	   :test-move-referenced-constructs-NameC))
+	   :test-move-referenced-constructs-NameC
+	   :test-move-referenced-constructs-TopicC))
 
 
 ;;TODO: test merge-constructs
@@ -2931,6 +2932,57 @@
 		      (variants name-2 :revision rev-2)))))))))
 
 
+(test test-move-referenced-constructs-TopicC ()
+  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((rev-1 100)
+	  (rev-2 200))
+      (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+	    (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+	    (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
+	    (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
+	    (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+	    (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
+	    (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1"
+				   :xtm-id "xtm-1"))
+	    (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2"
+				   :xtm-id "xtm-2"))
+	    (type-1 (make-construct 'TopicC :start-revision rev-1))
+	    (type-2 (make-construct 'TopicC :start-revision rev-1))
+	    (theme-1 (make-construct 'TopicC :start-revision rev-1))
+	    (theme-2 (make-construct 'TopicC :start-revision rev-1)))
+	(let ((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)))
+	      (variant-3 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :charvalue "var-1"
+					 :themes (list theme-1)))
+	      (occ-1 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :charvalue "occ-1"
+				     :instance-of type-1
+				     :themes (list theme-1)))
+	      (occ-2 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :charvalue "occ-2"
+				     :instance-of type-2))
+	      (occ-3 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :charvalue "occ-1"
+				     :instance-of type-1
+				     :themes (list theme-1))))
+	  (let ((name-1 (make-construct 'NameC
+					:start-revision rev-1
+					:charvalue "name-1"
+					:instance-of type-1))
+		)
+	    ))))))
 
 
 (defun run-datamodel-tests()
@@ -2991,4 +3043,5 @@
   (it.bese.fiveam:run! 'test-find-oldest-construct)
   (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
   (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
+  (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC)
   )
\ No newline at end of file




More information about the Isidorus-cvs mailing list