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

Lukas Giessmann lgiessmann at common-lisp.net
Sat Mar 20 22:00:40 UTC 2010


Author: lgiessmann
Date: Sat Mar 20 18:00:40 2010
New Revision: 235

Log:
new-datamodel: finalized "make-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	Sat Mar 20 18:00:40 2010
@@ -663,6 +663,16 @@
     (condition () nil)))
 
 
+(defun merge-all-constructs(constructs-to-be-merged)
+  "Merges all constructs contained in the given list."
+  (declare (list constructs-to-be-merged))
+  (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
+	(merged-construct (elt constructs-to-be-merged 0)))
+    (loop for construct-to-be-merged in constructs-to-be-merged
+       do (setf merged-construct
+		(merge-constructs merged-construct construct-to-be-merged)))))
+
+
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defgeneric get-all-characteristics (parent-construct characteristic-symbol)
   (:documentation "Returns all characterisitcs of the passed type the parent
@@ -2378,29 +2388,104 @@
 	   ((CharacteristicC-p class-symbol)
 	    (make-characteristic class-symbol (getf args :charvalue) args))
 	   ((TopicC-p class-symbol)
-	    (make-topic args)))))
+	    (make-topic args))
+	   ((TopicMapC-p class-symbol)
+	    (make-tm args))
+	   ((RoleC-p class-symbol)
+	    (make-role args))
+	   ((AssociationC-p class-symbol)
+	    (make-association args)))))
     construct))
 
 
-(defun merge-all-constructs(constructs-to-be-merged)
-  "Merges all constructs contained in the given list."
-  (declare (list constructs-to-be-merged))
-  (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
-	(merged-construct (elt constructs-to-be-merged 0)))
-    (loop for construct-to-be-merged in constructs-to-be-merged
-       do (setf merged-construct
-		(merge-constructs merged-construct construct-to-be-merged)))))
+(defun make-association (args)
+  "Returns an association object. If the association has already existed the
+   existing one is returned otherwise a new one is created.
+   This function exists only for being used by make-construct!"
+  (let ((item-identifiers (getf (first args) :item-identifiers))
+	(reifier (getf (first args) :reifier))
+	(instance-of (getf (first args) :instance-of))
+	(start-revision (getf (first args) :start-revision))
+	(themes (get (first args) :themes))
+	(roles (get (first args) :roles))
+	(err "From make-association(): "))
+    (unless start-revision (error "~astart-revision must be set" err))
+    (unless roles (error "~aroles must be set" err))
+    (unless instance-of (error "~ainstance-of must be set" err))
+    (let ((association
+	   (let ((existing-association
+		  (remove-if
+		   #'null
+		   (map 'list #'(lambda(existing-association)
+				  (when (equivalent-construct
+					 existing-association
+					 :start-revision start-revision
+					 :roles roles :themes themes
+					 :instance-of instance-of)
+				    existing-association))
+			(elephant:get-instances-by-class 'AssociationC)))))
+	     (if existing-association
+		 existing-association
+		 (make-instance 'AssociationC)))))
+      (initialize-typable association instance-of :start-revision
+			  start-revision)
+      (dolist (role roles)
+	(add-role association role :revision start-revision))
+      (dolist (theme themes)
+	(add-theme association theme :revision start-revision))
+      (initialize-reifiable association item-identifiers reifier
+			    :start-revision start-revision))))
 
 
-(defun make-tm (&rest args)
+(defun make-role (args)
+  "Returns a role object. If the role has already existed the
+   existing one is returned otherwise a new one is created.
+   This function exists only for being used by make-construct!"
+  (let ((item-identifiers (getf args :item-identifiers))
+	(reifier (getf args :reifier))
+	(parent (getf args :parent))
+	(instance-of (getf args :instance-of))
+	(player (getf args :player))
+	(start-revision (getf args :start-revision))
+	(err "From make-role(): "))
+    (unless start-revision (error "~astart-revision must be set" err))
+    (unless instance-of (error "~ainstance-of must be set" err))
+    (unless player (error "~aplayer must be set" err))
+    (let ((role
+	   (let ((existing-role
+		  (remove-if
+		   #'null
+		   (map 'list #'(lambda(existing-role)
+				  (when (equivalent-construct
+					 existing-role
+					 :player player
+					 :instance-of instance-of)
+				    existing-role))
+			(slot-p parent 'roles)))))
+	     (if existing-role
+		 existing-role
+		 (make-instance 'RoleC)))))
+      (when player
+	(add-player role player :revision start-revision))
+      (initialize-typable role instance-of :start-revision start-revision)
+      (when parent
+	(add-parent role parent :revision start-revision))
+      (initialize-reifiable role item-identifiers reifier
+			    :start-revision start-revision))))
+
+
+(defun make-tm (args)
   "Returns a topic map object. If the topic map has already existed the
    existing one is returned otherwise a new one is created.
    This function exists only for being used by make-construct!"
-  (let ((item-identifiers (getf (first args) :item-identifiers))
-	(reifier (getf (first args) :reifier))
-	(topics (getf (first args) :topics))
-	(assocs (getf (first args) :associations))
-	(start-revision (getf (first args) :start-revision)))
+  (let ((item-identifiers (getf args :item-identifiers))
+	(reifier (getf args :reifier))
+	(topics (getf args :topics))
+	(assocs (getf args :associations))
+	(start-revision (getf args :start-revision))
+	(err "From make-tm(): "))
+    (unless item-identifiers (error "~aitem-identifiers must be set" err))
+    (unless start-revision (error "~astart-revision must be set" err))
     (let ((tm
 	   (let ((existing-tms
 		  (remove-if
@@ -2420,21 +2505,24 @@
 		    (make-instance 'TopicMapC))))))
       (dolist (top-or-assoc (union topics assocs))
 	(add-to-tm tm top-or-assoc))
-      (add-to-version-history tm :start-revision start-revision)
-      tm)))
+      (initialize-reifiable tm item-identifiers reifier
+			    :start-revision start-revision))))
 	   
 
 (defun make-topic (&rest args)
   "Returns a topic object. If the topic has already existed the existing one is
    returned otherwise a new one is created.
    This function exists only for being used by make-construct!"
-  (let ((start-revision (getf (first args) :start-revision))
-	(psis (getf (first args) :psis))
-	(locators (getf (first args) :locators))
-	(item-identifiers (getf (first args) :item-identifiers))
-	(topic-identifiers (getf (first args) :topic-identifiers))
-	(names (getf (first args) :names))
-	(occurrences (getf (first args) :occurrences)))
+  (let ((start-revision (getf args :start-revision))
+	(psis (getf args :psis))
+	(locators (getf args :locators))
+	(item-identifiers (getf args :item-identifiers))
+	(topic-identifiers (getf args :topic-identifiers))
+	(names (getf args :names))
+	(occurrences (getf args :occurrences))
+	(err "From make-topic(): "))
+    (unless topic-identifiers (error "~atopic-identifiers must be set" err))
+    (unless start-revision (error "~astart-revision must be set" err))
     (let ((topic
 	   (let ((existing-topics
 		  (remove-if
@@ -2454,9 +2542,10 @@
 		    (first existing-topics))
 		   (t
 		    (make-instance 'TopicC))))))
-      (initialize-reifiable topic item-identifiers nil
-			    :start-revision start-revision)
       (let ((merged-topic topic))
+	(setf merged-topic
+	      (initialize-reifiable topic item-identifiers nil
+				    :start-revision start-revision))
 	(dolist (psi psis)
 	  (setf merged-topic (add-psi merged-topic psi
 				      :revision start-revision)))
@@ -2464,10 +2553,10 @@
 	  (setf merged-topic (add-locator merged-topic locator
 					  :revision start-revision)))
 	(dolist (name names)
-	  (setf merged-topic (add-name topic name :revision start-revision)))
+	  (setf merged-topic (add-name merged-topic name
+				       :revision start-revision)))
 	(dolist (occ occurrences)
 	  (add-occurrence merged-topic occ :revision start-revision))
-	(add-to-version-history merged-topic :start-revision start-revision)
 	merged-topic))))
 
 
@@ -2484,11 +2573,17 @@
 	(themes (getf (first args) :themes))
 	(variants (getf (first args) :variants))
 	(reifier (getf (first args) :reifier))
-	(parent-construct (getf (first args) :parent-construct))
-	(item-identifiers (getf (first args) :item-identifiers)))
+	(parent (getf (first args) :parent))
+	(item-identifiers (getf (first args) :item-identifiers))
+	(err "From make-characteristic(): "))
+    (unless start-revision (error "~astart-revision must be set" err))
+    (unless charvalue (error "~acharvalue must be set" err))
+    (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol))
+	       (not instance-of))
+      (error "~ainstance-of must be set" err))
     (let ((characteristic
 	   (let ((existing-characteristic
-		  (when parent-construct
+		  (when parent
 		    (remove-if
 		     #'null
 		     (map 'list #'(lambda(existing-characteristic)
@@ -2499,26 +2594,19 @@
 					   :charvalue charvalue :themes themes
 					   :instance-of instance-of)
 				      existing-characteristic))
-			  (get-all-characteristics parent-construct
-						   class-symbol))))))
+			  (get-all-characteristics parent class-symbol))))))
 	     (if existing-characteristic
 		 existing-characteristic
 		 (make-instance class-symbol :charvalue charvalue
 				:datatype datatype)))))
-      (let ((merged-characteristic characteristic))
-	(setf merged-characteristic
-	      (initialize-reifiable merged-characteristic item-identifiers
-				    reifier :start-revision start-revision))
-	(initialize-scopable merged-characteristic themes
-			     :start-revision start-revision)
-	(initialize-typable merged-characteristic instance-of
-			    :start-revision start-revision)
-	(initialize-name merged-characteristic variants
-			 :start-revision start-revision)
-	(when parent-construct
-	  (add-parent merged-characteristic parent-construct
-		      :revision start-revision))
-	merged-characteristic))))
+      (initialize-scopable characteristic themes :start-revision start-revision)
+      (initialize-typable characteristic instance-of
+			  :start-revision start-revision)
+      (initialize-name characteristic variants :start-revision start-revision)
+      (when parent
+	(add-parent characteristic parent :revision start-revision))
+      (initialize-reifiable characteristic item-identifiers
+			    reifier :start-revision start-revision))))
 
 
 (defun make-pointer (class-symbol &rest args)
@@ -2528,7 +2616,10 @@
   (let ((uri (getf (first args) :uri))
 	(xtm-id (getf (first args) :xtm-id))
 	(start-revision (getf (first args) :start-revision))
-	(identified-construct (getf (first args) :identified-construct)))
+	(identified-construct (getf (first args) :identified-construct))
+	(err "From make-pointer(): "))
+    (when (and identified-construct (not start-revision))
+      (error "~astart-revision must be set" err))
     (let ((identifier
 	   (let ((existing-pointer
 		  (remove-if

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	Sat Mar 20 18:00:40 2010
@@ -61,11 +61,8 @@
 	   :test-class-p))
 
 
-;;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
-;;      (occurrences, names, variants, associations, roles)
-;;TODO: test ReifiableConstructC --> reifier has to be merged
+;;TODO: test make-construct
+;;TODO: test merge-constructs
 
 
 




More information about the Isidorus-cvs mailing list