[isidorus-cvs] r263 - branches/new-datamodel/src/model - isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

6 Apr 2010

Author: lgiessmann
Date: Tue Apr  6 11:44:47 2010
New Revision: 263
Log:
new-datamodel: replaced "merge-cosntructs" --> "NameC", "OccurrenceC", "VariantC" by a generic for "CharacteristicC"; added the generics "add-characteristic" and "delete-characteristic" for "NameC", "VariantC", "OccurrenceC"
Modified:
   branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================

--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Tue Apr  6 11:44:47 2010
@@ -758,6 +758,18 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric add-characteristic (construct characteristic &key revision)
+  (:documentation "Adds the passed characterisitc to the given topic by calling
+                   add-name or add-occurrences.
+                   Variants are added to names by calling add-name."))
+
+
+(defgeneric delete-characteristic (construct characteristic &key revision)
+  (:documentation "Deletes the passed characteristic oif the given topic by
+                   calling delete-name or delete-occurrence.
+                   Variants are deleted from names by calling delete-variant."))
+
+
 (defgeneric mark-as-deleted (construct &key source-locator revision)
   (:documentation "Mark a construct as deleted if it comes from the source
                    indicated by source-locator"))
@@ -832,7 +844,6 @@
                    The latest construct is either the one with
                    end-revision=0 or with the highest end-revision value."))
-
 (defgeneric owned-p (construct)
   (:documentation "Returns t if the passed construct is referenced by a parent
                    TM construct."))
@@ -1638,6 +1649,24 @@
       construct)))
+(defmethod add-characteristic ((construct TopicC)
+			       (characteristic CharacteristicC)
+			       &key (revision *TM-REVISION*))
+  (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+  (if (typep characteristic 'NameC)
+      (add-name construct characteristic :revision revision)
+      (add-occurrence construct characteristic :revision revision)))
+
+
+(defmethod delete-characteristic ((construct TopicC)
+				  (characteristic CharacteristicC)
+				  &key (revision *TM-REVISION*))
+  (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+  (if (typep characteristic 'NameC)
+      (delete-name construct characteristic :revision revision)
+      (delete-occurrence construct characteristic :revision revision)))
+
+
 (defgeneric player-in-roles (construct &key revision)
   (:documentation "Returns the RoleC-objects that correspond
                    with the passed construct and the passed version.")
@@ -2156,6 +2185,18 @@
       construct)))
+(defmethod add-characteristic ((construct NameC) (characteristic VariantC)
+			       &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (add-variant construct characteristic :revision revision))
+
+
+(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
+				  &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (delete-variant construct characteristic :revision revision))
+
+
 ;;; AssociationC
 (defmethod equivalent-constructs ((construct-1 AssociationC)
    			  (construct-2 AssociationC)
@@ -3287,33 +3328,48 @@
 (defmethod move-referenced-constructs ((source ReifiableConstructC)
    			       (destination ReifiableConstructC)
    			       &key (revision *TM-REVISION*))
-  (let ((source-reifier (reifier source :revision revision))
-	(destination-reifier (reifier destination :revision revision)))
-    (cond ((and source-reifier destination-reifier)
-	   (delete-reifier (reified-construct source-reifier :revision revision)
-			   source-reifier :revision revision)
-	   (delete-reifier (reified-construct destination-reifier
-					      :revision revision)
-			   destination-reifier :revision revision)
-	   (let ((merged-reifier
-		  (merge-constructs source-reifier destination-reifier
-				    :revision revision)))
-	     (add-reifier destination merged-reifier :revision revision)))
-	  (source-reifier
-	   (delete-reifier (reified-construct source-reifier :revision revision)
-			   source-reifier :revision revision)
-	   (add-reifier destination source-reifier :revision revision)
-	   source-reifier)
-	  (destination-reifier
-	   (add-reifier destination destination-reifier :revision revision)
-	   destination-reifier))))
+  (declare (integer revision))
+  (remove-if
+   #'null
+   (append
+    (move-identifiers source destination :revision revision)
+    (let ((source-reifier (reifier source :revision revision))
+	  (destination-reifier (reifier destination :revision revision)))
+      (cond ((and source-reifier destination-reifier)
+	     (delete-reifier (reified-construct source-reifier
+						:revision revision)
+			     source-reifier :revision revision)
+	     (delete-reifier (reified-construct destination-reifier
+						:revision revision)
+			     destination-reifier :revision revision)
+	     (let ((merged-reifier
+		    (merge-constructs source-reifier destination-reifier
+				      :revision revision)))
+	       (add-reifier destination merged-reifier :revision revision)))
+	    (source-reifier
+	     (delete-reifier (reified-construct source-reifier
+						:revision revision)
+			     source-reifier :revision revision)
+	     (add-reifier destination source-reifier :revision revision)
+	     source-reifier)
+	    (destination-reifier
+	     (add-reifier destination destination-reifier :revision revision)
+	     destination-reifier))))))
+
+
+(defmethod move-referenced-constructs ((source NameC) (destination NameC)
+				       &key (revision *TM-REVISION*))
+  (declare (integer revision))
+  (append (call-next-method)
+	  (move-variants source destination :revision revision)))
(defmethod move-referenced-constructs ((source TopicC) (destination TopicC)
    			       &key (revision *TM-REVISION*))
   (let ((roles (player-in-roles source :revision revision))
    (scopables (used-as-theme source :revision revision))
-	(typables (used-as-type source :revision revision)))
+	(typables (used-as-type source :revision revision))
+	(ids (move-identifiers source destination :revision revision)))
     (dolist (role roles)
       (delete-player role source :revision revision)
       (add-player role destination :revision revision))
@@ -3323,7 +3379,7 @@
     (dolist (typable typables)
       (delete-type typable source :revision revision)
       (add-type typable destination :revision revision))
-    (append roles scopables typables)))
+    (remove-if #'null (append roles scopables typables ids))))
(defgeneric move-reified-construct (source destination &key revision)
@@ -3373,7 +3429,6 @@
      (if equivalent-occ
          (progn
    	(add-occurrence destination equivalent-occ :revision revision)
-		(move-identifiers occ equivalent-occ :revision revision)
    	(move-referenced-constructs occ equivalent-occ
    				    :revision revision))
          (add-occurrence destination occ :revision revision))))
@@ -3399,7 +3454,6 @@
      (if equivalent-var
          (progn
    	(add-variant destination equivalent-var :revision revision)
-		(move-identifiers var equivalent-var :revision revision)
    	(move-referenced-constructs var equivalent-var
    				    :revision revision))
          (add-variant destination var :revision revision))))
@@ -3423,10 +3477,8 @@
    		      destination-name))
    		(names destination :revision revision))))
      (if equivalent-name
-	      (progn
-		(move-variants name equivalent-name :revision revision)
+	      (progn		
    	(add-name destination equivalent-name :revision revision)
-		(move-identifiers name equivalent-name :revision revision)
    	(move-referenced-constructs name equivalent-name
    				    :revision revision))
          (add-name destination name :revision revision))))
@@ -3467,7 +3519,6 @@
    (let ((newer-topic (if (eql older-topic construct-1)
    		       construct-2
    		       construct-1)))
-	  (move-identifiers newer-topic older-topic :revision revision)
      (dolist (tm (in-topicmaps newer-topic :revision revision))
        (add-to-tm tm older-topic))
      (move-names newer-topic older-topic :revision revision)
@@ -3481,52 +3532,77 @@
      older-topic))))
-(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
+(defmethod merge-constructs ((construct-1 CharacteristicC)
+			     (construct-2 CharacteristicC)
    		     &key (revision *TM-REVISION*))
+  (declare (integer revision))
   (if (eql construct-1 construct-2)
       construct-1
-      (progn
-	(unless (strictly-equivalent-constructs construct-1 construct-2
-						:revision revision)
-	  (error "From merge-constructs(): ~a is not mergable with ~a"
-		 construct-1 construct-2))
-	(let ((parent-1 (parent construct-1 :revision revision))
-	      (parent-2 (parent construct-2 :revision revision)))
-	  (when (not (and parent-1 parent-2))
-	    (error "From merge-constructs():~a and ~a must be associated with a topic"
-		   construct-1 construct-2))
-	  (if (and parent-1 (eql parent-1 parent-2))
-	      (let ((older-occ (find-oldest-construct construct-1 construct-2)))
-		(let ((newer-occ (if (eql older-occ construct-1)
-				     construct-2
-				     construct-1)))
-		  (move-identifiers newer-occ older-occ :revision revision)
-		  (move-referenced-constructs newer-occ older-occ
-					      :revision revision)
-		  (delete-occurrence parent-1 construct-1 :revision revision)
-		  (add-occurrence parent-1 construct-2 :revision revision)
-		  older-occ))
-	      (let ((active-topic
-		     (merge-constructs parent-1 parent-2 :revision revision)))
-		(if (find construct-1
-			  (occurrences active-topic :revision revision))
-		    construct-1
-		    construct-2)))))))
+      (let ((older-char (find-oldest-construct construct-1 construct-2)))
+	(let ((newer-char (if (eql older-char construct-1)
+			      construct-2
+			      construct-1)))
+	  (let ((parent-1 (parent older-char :revision revision))
+		(parent-2 (parent newer-char :revision revision)))
+	    (unless (strictly-equivalent-constructs construct-1 construct-2
+						    :revision revision)
+	      (error "From merge-constructs(): ~a and ~a are not mergable"
+		     construct-1 construct-2))
+	    (cond ((and parent-1 (eql parent-1 parent-2))
+		   (move-referenced-constructs newer-char older-char
+					       :revision revision)
+		   (delete-characteristic newer-char parent-2
+					  :revision revision)
+		   older-char)
+		  ((and parent-1 parent-2)
+		   (let ((active-parent (merge-constructs parent-1 parent-2
+							  :revision revision)))
+		     (let ((found-older-char
+			    (cond ((typep older-char 'OccurrenceC)
+				   (find older-char
+					 (occurrences
+					  active-parent :revision revision)))
+				  ((typep older-char 'NameC)
+				   (find older-char
+					 (names
+					  active-parent :revision revision)))
+				  ((typep older-char 'VariantC)
+				   (find-if
+				    #'(lambda(name)
+					(find older-char
+					      (variants name
+							:revision revision)))
+				    (names active-parent :revision revision))))))
+		       (if found-older-char
+			   older-char
+			   newer-char))))
+		  ((or parent-1 parent-2)
+		   (let ((dst (if parent-1 older-char newer-char))
+			 (src (if parent-1 newer-char older-char)))
+		     (move-referenced-constructs src dst :revision revision)
+		     dst))
+		  (t
+		   (move-referenced-constructs newer-char older-char
+					       :revision revision)
+		   older-char)))))))
+
-;TODO: merge-constructs: RoleC, AssociationC, TopicMapC,
-;      OccurrenceC, NameC, VariantC --> call merge-constructs of the parent
-;      and return the active construct on what merge-constructs was initialy
-;      called
+;TODO: merge-constructs: RoleC (merge parents and return the active role object),
+;;     AssociationC, TopicMapC,
+
+
+
+
 ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
    		     &key (revision *TM-REVISION*))
@@ -3539,80 +3615,7 @@
 ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
-			     &key (revision *TM-REVISION*))
-  (declare (integer revision))
-  (if (eql construct-1 construct-2)
-      construct-1
-      (let ((older-var (find-oldest-construct construct-1 construct-2)))
-	(let ((newer-var (if (eql older-var construct-1)
-			     construct-2
-			     construct-1)))
-	  (let ((parent-1 (parent older-var :revision revision))
-		(parent-2 (parent newer-var :revision revision)))
-	    (unless (strictly-equivalent-constructs construct-1 construct-2
-						    :revision revision)
-	      (error "From merge-constructs(): ~a and ~a are not mergable"
-		     construct-1 construct-2))
-	    (cond ((and parent-1 parent-2)
-		   (let ((active-parent
-			  (merge-constructs parent-1 parent-2
-					    :revision revision)))
-		     (let ((all-names (names active-parent :revision revision)))
-		       (if (find-if #'(lambda(name)
-					(find older-var (variants name :revision
-								  revision)))
-				    all-names)
-			   older-var
-			   newer-var))))
-		  ((or parent-1 parent-2)
-		   (let ((dst (if parent-1 older-var newer-var))
-			 (src (if parent-1 newer-var older-var)))
-		     (move-identifiers src dst :revision revision)
-		     (move-referenced-constructs src dst :revision revision)
-		     dst))
-		  (t
-		   (move-identifiers newer-var older-var :revision revision)
-		   (move-referenced-constructs newer-var older-var
-					       :revision revision)
-		   older-var)))))))
-
-(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC)
-			     &key (revision *TM-REVISION*))
-  (declare (integer revision))
-  (if (eql construct-1 construct-2)
-      construct-1
-      (let ((older-name (find-oldest-construct construct-1 construct-2)))
-	(let ((newer-name (if (eql older-name construct-1)
-			      construct-2
-			      construct-1)))
-	  (let ((parent-1 (parent older-name :revision revision))
-		(parent-2 (parent newer-name :revision revision)))
-	    (unless (strictly-equivalent-constructs construct-1 construct-2
-						    :revision revision)
-	      (error "From merge-constructs(): ~a and ~a are not mergable"
-		     construct-1 construct-2))
-	    (cond ((and parent-1 parent-2)
-		   (let ((active-parent (merge-constructs parent-1 parent-2
-							  :revision revision)))
-		     (if (find older-name (names active-parent
-						 :revision revision))
-			 older-name
-			 newer-name)))
-		  ((or parent-1 parent-2)
-		   (let ((dst (if parent-1 older-name newer-name))
-			 (src (if parent-1 newer-name older-name)))
-		     (move-identifiers src dst :revision revision)
-		     (move-referenced-constructs src dst :revision revision)
-		     (move-variants src dst :revision revision)
-		     dst))
-		  (t
-		   (move-identifiers newer-name older-name :revision revision)
-		   (move-referenced-constructs newer-name older-name
-					       :revision revision)
-		   (move-variants newer-name older-name :revision revision)
-		   older-name)))))))
;TODO: --> include move-yx in move-referenced-constructs
\ No newline at end of file

    