[isidorus-cvs] r456 - in trunk/src: json/JTM unit_tests

Lukas Giessmann lgiessmann at common-lisp.net
Sat May 7 22:02:57 UTC 2011


Author: lgiessmann
Date: Sat May  7 18:02:56 2011
New Revision: 456

Log:
JTM: added functions that allow the import of a single topicstub, topic an array of topicstubs and topics

Modified:
   trunk/src/json/JTM/jtm_importer.lisp
   trunk/src/unit_tests/jtm_test.lisp

Modified: trunk/src/json/JTM/jtm_importer.lisp
==============================================================================
--- trunk/src/json/JTM/jtm_importer.lisp	(original)
+++ trunk/src/json/JTM/jtm_importer.lisp	Sat May  7 18:02:56 2011
@@ -21,6 +21,130 @@
   (rest (find item-keyword jtm-list :key #'first)))
 
 
+(defun import-topic-stubs-from-jtm-lists (jtm-lists parents &key
+					  (revision *TM-REVISION*) prefixes)
+  "Creates and returns a list of topics.
+   Note only the topic identifiers are imported and set in this function,
+   entire topics are imported in merge-topics-from-jtm-lists."
+  (declare (List jtm-lists parents prefixes)
+	   (Integer revision))
+  (map 'list #'(lambda(jtm-list)
+		 (import-topic-stub-from-jtm-list
+		  jtm-list parents :revision revision :prefixes prefixes))
+       jtm-lists))
+
+
+(defun import-topic-stub-from-jtm-list(jtm-list parents &key
+				       (revision *TM-REVISION*) prefixes)
+  "Creates and returns a topic object from the passed jtm
+   list generated by json:decode-json-from-string.
+   Note this function only sets the topic's identifiers."
+  (declare (List jtm-list parents prefixes)
+	   (Integer revision))
+  (let* ((t-iis (import-identifiers-from-jtm-strings
+		 (get-item :ITEM--IDENTIFIERS jtm-list)
+		 :prefixes prefixes))
+	 (t-psis (import-identifiers-from-jtm-strings
+		  (get-item :SUBJECT--IDENTIFIERS jtm-list)
+		  :prefixes prefixes :identifier-type-symbol 'd:PersistentIdC))
+	 (t-sls (import-identifiers-from-jtm-strings
+		 (get-item :SUBJECT--LOCATORS jtm-list)
+		 :prefixes prefixes :identifier-type-symbol 'd:SubjectLocatorC))
+	 (parent-references (get-item :PARENT jtm-list))
+	 (local-parents
+	  (if parents
+	      parents
+	      (when parent-references
+		(get-items-from-jtm-references
+		 parent-references :revision revision :prefixes prefixes)))))
+    (unless local-parents
+      (error (make-condition 'JTM-error :message (format nil "From import-topic-from-jtm-string(): the JTM topic ~a must have at least one parent set in its members." jtm-list))))
+    (unless (append t-iis t-sls t-psis)
+      (error (make-condition 'JTM-error :message (format nil "From import-topic-from-jtm-string(): the JTM topic ~a must have at least one identifier set in its members." jtm-list))))
+    (let* ((top (make-construct 'TopicC :start-revision revision
+				:psis t-psis
+				:item-identifiers t-iis
+				:locators t-sls)))
+      (dolist (tm local-parents)
+	(add-to-tm tm top))
+      top)))
+
+
+(defun make-instance-of-association (instance-top type-top parents &key
+				     (revision *TM-REVISION*))
+  "Creates and returns a type-instance-association for the passed
+   instance and type topics."
+  (declare (TopicC instance-top type-top)
+	   (List parents)
+	   (Integer revision))
+  (let ((t-top (get-item-by-psi *type-psi* :revision revision))
+	(i-top (get-item-by-psi *instance-psi* :revision revision))
+	(ti-top (get-item-by-psi *type-instance-psi* :revision revision)))
+    (let ((assoc (make-construct 'AssociationC :start-revision revision
+				 :instance-of ti-top
+				 :roles (list (list :start-revision revision
+						    :player instance-top
+						    :instance-of i-top)
+					      (list :start-revision revision
+						    :player type-top
+						    :instance-of t-top)))))
+      (dolist (tm parents)
+	(add-to-tm tm assoc))
+      assoc)))
+
+
+(defun merge-topics-from-jtm-lists (jtm-lists parents &key (instance-of-p t)
+				    (revision *TM-REVISION*) prefixes)
+  "Creates and returns a list of topics."
+  (declare (List jtm-lists parents prefixes)
+	   (Boolean instance-of-p)
+	   (Integer revision))
+  (map 'list #'(lambda(jtm-list)
+		 (merge-topic-from-jtm-list
+		  jtm-list parents :revision revision :prefixes prefixes
+		  :instance-of-p instance-of-p))
+       jtm-lists))
+
+
+(defun merge-topic-from-jtm-list(jtm-list parents &key (instance-of-p t)
+				  (revision *TM-REVISION*) prefixes)
+  "Creates and returns a topic object from the passed jtm
+   list generated by json:decode-json-from-string."
+  (declare (List jtm-list prefixes parents)
+	   (Boolean instance-of-p)
+	   (Integer revision))
+  (let* ((ids (append (get-item :ITEM--IDENTIFIERS jtm-list)
+		      (get-item :SUBJECT--IDENTIFIERS jtm-list)
+		      (get-item :SUBJECT--LOCATORS jtm-list)))
+	 (top (when ids
+		(get-item-from-jtm-reference (first ids) :revision revision
+					     :prefixes prefixes)))
+	 (instanceof (get-items-from-jtm-references
+		      (get-item :INSTANCE--OF jtm-list) :revision revision
+		      :prefixes prefixes))
+	 (top-names (import-characteristics-from-jtm-lists
+		     (get-item :NAMES jtm-list) top
+		     #'import-name-from-jtm-list :revision revision
+		     :prefixes prefixes))
+	 (top-occs (import-characteristics-from-jtm-lists
+		    (get-item :OCCURRENCES jtm-list) top
+		    #'import-occurrence-from-jtm-list :revision revision
+		    :prefixes prefixes)))
+    (unless ids
+      (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): the passed topic has to own at least one identifier: ~a" jtm-list))))
+    (unless top
+      (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): cannot find a topic that matches the corresponding JTM-list: ~a" jtm-list))))
+    (when (and (not instance-of-p) instanceof)
+      (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): the JTM-topic has an instance_of member set, but JTM version 1.0 does not allow an intance_of member within a topic object: ~a" jtm-list))))
+    (dolist (type-top instanceof)
+      (make-instance-of-association top type-top parents :revision revision))
+    (dolist (name top-names)
+      (add-name top name :revision revision))
+    (dolist (occ top-occs)
+      (add-occurrence top occ :revision revision))
+    top))
+
+
 (defun import-name-from-jtm-list (jtm-list parent &key
 				  (revision *TM-REVISION*) prefixes)
   "Creates and returns a name object from the passed jtm
@@ -59,9 +183,9 @@
 	    :reifier (when reifier
 		       (get-item-from-jtm-reference
 			reifier :revision revision :prefixes prefixes)))))
-      (import-constructs-from-jtm-lists name-variants name
-					#'import-variant-from-jtm-list
-					:revision revision :prefixes prefixes)
+      (import-characteristics-from-jtm-lists name-variants name
+					     #'import-variant-from-jtm-list
+					     :revision revision :prefixes prefixes)
       name)))
 
 
@@ -105,8 +229,8 @@
 				reifier :revision revision :prefixes prefixes)))))
 
 
-(defun import-constructs-from-jtm-lists(jtm-lists parent next-fun &key
-					(revision *TM-REVISION*) prefixes)
+(defun import-characteristics-from-jtm-lists(jtm-lists parent next-fun &key
+					     (revision *TM-REVISION*) prefixes)
   "Creates and returns a list of TM-Constructs returned by next-fun."
   (declare (List jtm-lists prefixes)
 	   (Integer revision)

Modified: trunk/src/unit_tests/jtm_test.lisp
==============================================================================
--- trunk/src/unit_tests/jtm_test.lisp	(original)
+++ trunk/src/unit_tests/jtm_test.lisp	Sat May  7 18:02:56 2011
@@ -1634,6 +1634,14 @@
 	 #'jtm::import-name-from-jtm-list :revision 100)))))
 
 
+;TODO:
+; *import-topic-stubs-from-jtm-lists
+; *import-topic-stub-from-jtm-list
+; *make-instance-of-association
+; *merge-topics-from-jtm-lists
+; *merge-topic-from-jtm-list
+
+
 (defun run-jtm-tests()
   "Runs all tests of this test-suite."
   (it.bese.fiveam:run! 'jtm-tests))
\ No newline at end of file




More information about the Isidorus-cvs mailing list