Changeset 456 for trunk/src/json/JTM

Timestamp:

05/07/11 22:02:56 (14 years ago)

Author:

lgiessmann

Message:

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

File:

• trunk/src/json/JTM/jtm_importer.lisp (modified) (3 diffs)

trunk/src/json/JTM/jtm_importer.lisp ¶

@@ -20 +20 @@
            (List jtm-list))
   (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))
 
 
@@ -60 +184 @@
                        (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)))
 
@@ -106 +230 @@
 
 
-(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)