| 1 | ;;+----------------------------------------------------------------------------- |
|---|
| 2 | ;;+ Isidorus |
|---|
| 3 | ;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff |
|---|
| 4 | ;;+ |
|---|
| 5 | ;;+ Isidorus is freely distributable under the LLGPL license. |
|---|
| 6 | ;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and |
|---|
| 7 | ;;+ trunk/docs/LGPL-LICENSE.txt. |
|---|
| 8 | ;;+----------------------------------------------------------------------------- |
|---|
| 9 | |
|---|
| 10 | |
|---|
| 11 | (in-package :jtm) |
|---|
| 12 | |
|---|
| 13 | (defun get-item (item-keyword jtm-list) |
|---|
| 14 | (declare (Keyword item-keyword) |
|---|
| 15 | (List jtm-list)) |
|---|
| 16 | (rest (find item-keyword jtm-list :key #'first))) |
|---|
| 17 | |
|---|
| 18 | |
|---|
| 19 | (defun make-prefix-list-from-jtm-list (jtm-list) |
|---|
| 20 | "Creates a plist of the form ((:pref 'pref_1' :value 'value-1') |
|---|
| 21 | (:pref 'pref_2' :value 'value-2')) if the passed jtm-list is |
|---|
| 22 | of the form ((:PREF--1 . 'value-1')(:PREF--2 . 'value-2'))." |
|---|
| 23 | (declare (List jtm-list)) |
|---|
| 24 | (loop for item in jtm-list |
|---|
| 25 | collect (list :pref (json:lisp-to-camel-case |
|---|
| 26 | (subseq (write-to-string (first item)) 1)) |
|---|
| 27 | :value (rest item)))) |
|---|
| 28 | |
|---|
| 29 | |
|---|
| 30 | (defun import-construct-from-jtm-string (jtm-string &key |
|---|
| 31 | (revision *TM-REVISION*) |
|---|
| 32 | (jtm-format :1.1) tm-id |
|---|
| 33 | (create-fragments nil)) |
|---|
| 34 | "Imports the passed jtm-string. |
|---|
| 35 | Note tm-id needs not to be declared, but if the imported construct |
|---|
| 36 | is a topicmap and it has no item-identifiers defined, a JTM-error |
|---|
| 37 | is thrown." |
|---|
| 38 | (declare (String jtm-string) |
|---|
| 39 | (type (or Null String) tm-id) |
|---|
| 40 | (Integer revision) |
|---|
| 41 | (Keyword jtm-format) |
|---|
| 42 | (Boolean create-fragments)) |
|---|
| 43 | (let* ((jtm-list (json:decode-json-from-string jtm-string))) |
|---|
| 44 | (import-construct-from-jtm-decoded-list |
|---|
| 45 | jtm-list :revision revision :jtm-format jtm-format |
|---|
| 46 | :tm-id tm-id :create-fragments create-fragments))) |
|---|
| 47 | |
|---|
| 48 | |
|---|
| 49 | (defun import-construct-from-jtm-decoded-list (jtm-list &key |
|---|
| 50 | (revision *TM-REVISION*) |
|---|
| 51 | (jtm-format :1.1) tm-id |
|---|
| 52 | (create-fragments nil)) |
|---|
| 53 | "Imports the passed jtm-decoded-list. |
|---|
| 54 | Note tm-id needs not to be declared, but if the imported construct |
|---|
| 55 | is a topicmap and it has no item-identifiers defined, a JTM-error |
|---|
| 56 | is thrown." |
|---|
| 57 | (declare (List jtm-list) |
|---|
| 58 | (Integer revision) |
|---|
| 59 | (Keyword jtm-format) |
|---|
| 60 | (type (or Null String) tm-id) |
|---|
| 61 | (Boolean create-fragments)) |
|---|
| 62 | (let* ((version (get-item :VERSION jtm-list)) |
|---|
| 63 | (item_type (get-item :ITEM--TYPE jtm-list)) |
|---|
| 64 | (prefixes (make-prefix-list-from-jtm-list (get-item :PREFIXES jtm-list))) |
|---|
| 65 | (format-1.1-p (eql jtm-format :1.1))) |
|---|
| 66 | (cond ((eql jtm-format :1.0) |
|---|
| 67 | (unless (string= version "1.0") |
|---|
| 68 | (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member version must be set to \"1.0\" in JTM version 1.0, but is ~a" version)))) |
|---|
| 69 | (when prefixes |
|---|
| 70 | (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member prefixes must not be set when using JTM version 1.0, but found: ~a" prefixes))))) |
|---|
| 71 | ((eql jtm-format :1.1) |
|---|
| 72 | (unless (string= version "1.1") |
|---|
| 73 | (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member version must be set to \"1.1\" in JTM version 1.1, but is ~a" version))))) |
|---|
| 74 | (t |
|---|
| 75 | (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): only JTM format \"1.0\" and \"1.1\" is supported, but found: \"~a\"" jtm-format))))) |
|---|
| 76 | (cond ((or (not item_type) |
|---|
| 77 | (string= item_type item_type-topicmap)) |
|---|
| 78 | (import-topic-map-from-jtm-list |
|---|
| 79 | jtm-list tm-id :revision revision :prefixes prefixes |
|---|
| 80 | :instance-of-p format-1.1-p :create-fragments create-fragments)) |
|---|
| 81 | ((string= item_type item_type-topic) |
|---|
| 82 | (import-topic-stub-from-jtm-list jtm-list nil :revision revision |
|---|
| 83 | :prefixes prefixes) |
|---|
| 84 | (merge-topic-from-jtm-list jtm-list :instance-of-p format-1.1-p |
|---|
| 85 | :revision revision :prefixes prefixes |
|---|
| 86 | :create-fragment create-fragments)) |
|---|
| 87 | ((string= item_type item_type-name) |
|---|
| 88 | (import-name-from-jtm-list jtm-list nil :revision revision |
|---|
| 89 | :prefixes prefixes)) |
|---|
| 90 | ((string= item_type item_type-variant) |
|---|
| 91 | (import-variant-from-jtm-list jtm-list nil :revision revision |
|---|
| 92 | :prefixes prefixes)) |
|---|
| 93 | ((string= item_type item_type-occurrence) |
|---|
| 94 | (import-occurrence-from-jtm-list jtm-list nil :revision revision |
|---|
| 95 | :prefixes prefixes)) |
|---|
| 96 | ((string= item_type item_type-role) |
|---|
| 97 | (import-role-from-jtm-list jtm-list nil :revision revision |
|---|
| 98 | :prefixes prefixes)) |
|---|
| 99 | ((string= item_type item_type-association) |
|---|
| 100 | (import-association-from-jtm-list jtm-list nil :revision revision |
|---|
| 101 | :prefixes prefixes)) |
|---|
| 102 | (t |
|---|
| 103 | (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member \"item_type\" must be set to one of ~a or nil, but found \"~a\". If \"item_type\" is not specified or nil the JTM-data is treated as a topicmap." item_type (list item_type-topicmap item_type-topic item_type-name item_type-variant item_type-occurrence item_type-role item_type-association)))))))) |
|---|
| 104 | |
|---|
| 105 | |
|---|
| 106 | (defun import-from-jtm (jtm-path repository-path &key (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) (revision *TM-REVISION*) (jtm-format :1.1)) |
|---|
| 107 | "Imports the given jtm-file by calling import-construct-from-jtm-string." |
|---|
| 108 | (declare (type (or Pathname String) jtm-path repository-path) |
|---|
| 109 | (String tm-id) |
|---|
| 110 | (Keyword jtm-format) |
|---|
| 111 | (Integer revision)) |
|---|
| 112 | (open-tm-store repository-path) |
|---|
| 113 | (import-construct-from-jtm-string (read-file-to-string jtm-path) |
|---|
| 114 | :tm-id tm-id :revision revision |
|---|
| 115 | :jtm-format jtm-format) |
|---|
| 116 | (close-tm-store)) |
|---|
| 117 | |
|---|
| 118 | |
|---|
| 119 | (defun import-topic-map-from-jtm-list (jtm-list tm-id &key (revision *TM-REVISION*) |
|---|
| 120 | prefixes (instance-of-p t) |
|---|
| 121 | (create-fragments nil)) |
|---|
| 122 | "Creates and returns a topic map corresponding to the tm-id or a given |
|---|
| 123 | item-identifier in the jtm-list and returns the tm construct after all |
|---|
| 124 | topics and associations contained in the jtm-list has been created." |
|---|
| 125 | (declare (List jtm-list prefixes) |
|---|
| 126 | (Integer revision) |
|---|
| 127 | (Boolean instance-of-p create-fragments)) |
|---|
| 128 | (let* ((iis (let ((value (append (import-identifiers-from-jtm-strings |
|---|
| 129 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 130 | :prefixes prefixes) |
|---|
| 131 | (when tm-id |
|---|
| 132 | (list |
|---|
| 133 | (make-construct 'ItemIdentifierC |
|---|
| 134 | :uri tm-id)))))) |
|---|
| 135 | (unless value |
|---|
| 136 | (error (make-condition 'JTM-error :message (format nil "From import-topic-map-from-jtm-list(): no topic-map item-identifier is set for ~a" jtm-list)))) |
|---|
| 137 | value)) |
|---|
| 138 | (j-tops (get-item :TOPICS jtm-list)) |
|---|
| 139 | (j-assocs (get-item :ASSOCIATIONS jtm-list)) |
|---|
| 140 | (tm (make-construct 'TopicMapC :start-revision revision |
|---|
| 141 | :item-identifiers iis))) |
|---|
| 142 | (import-topic-stubs-from-jtm-lists j-tops (list tm) :revision revision |
|---|
| 143 | :prefixes prefixes) |
|---|
| 144 | (merge-topics-from-jtm-lists j-tops :instance-of-p instance-of-p |
|---|
| 145 | :revision revision :prefixes prefixes |
|---|
| 146 | :create-fragments create-fragments) |
|---|
| 147 | (import-associations-from-jtm-lists j-assocs (list tm) :revision revision |
|---|
| 148 | :prefixes prefixes) |
|---|
| 149 | tm)) |
|---|
| 150 | |
|---|
| 151 | |
|---|
| 152 | (defun import-associations-from-jtm-lists (jtm-lists parents &key |
|---|
| 153 | (revision *TM-REVISION*) prefixes) |
|---|
| 154 | "Create a listof AssociationC objects corresponding to the passed jtm-lists |
|---|
| 155 | and returns it." |
|---|
| 156 | (declare (List jtm-lists parents prefixes) |
|---|
| 157 | (Integer revision)) |
|---|
| 158 | (map 'list #'(lambda(jtm-list) |
|---|
| 159 | (import-association-from-jtm-list |
|---|
| 160 | jtm-list parents :revision revision :prefixes prefixes)) |
|---|
| 161 | jtm-lists)) |
|---|
| 162 | |
|---|
| 163 | |
|---|
| 164 | (defun import-role-from-jtm-list (jtm-list parent &key (revision *TM-REVISION*) |
|---|
| 165 | prefixes) |
|---|
| 166 | "Creates and returns a role object form the given jtm-list." |
|---|
| 167 | (let* ((iis (import-identifiers-from-jtm-strings |
|---|
| 168 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 169 | :prefixes prefixes)) |
|---|
| 170 | (type (get-item :TYPE jtm-list)) |
|---|
| 171 | (reifier (get-item :REIFIER jtm-list)) |
|---|
| 172 | (player (get-item :PLAYER jtm-list)) |
|---|
| 173 | (parent-references (get-item :PARENT jtm-list)) |
|---|
| 174 | (local-parent |
|---|
| 175 | (if parent |
|---|
| 176 | (list parent) |
|---|
| 177 | (when parent-references |
|---|
| 178 | (get-items-from-jtm-references |
|---|
| 179 | parent-references :revision revision :prefixes prefixes))))) |
|---|
| 180 | (unless local-parent |
|---|
| 181 | (error (make-condition 'JTM-error :message (format nil "From import-role-from-jtm-list(): the JTM role ~a must have exactly one parent set in its members." jtm-list)))) |
|---|
| 182 | (unless type |
|---|
| 183 | (error (make-condition 'JTM-error :message (format nil "From import-role-from-jtm-list(): the role ~a must have exactly one type set as member." jtm-list)))) |
|---|
| 184 | (unless player |
|---|
| 185 | (error (make-condition 'JTM-error :message (format nil "From import-role-from-jtm-list(): the role ~a must have exactly one player set as member." jtm-list)))) |
|---|
| 186 | (make-construct 'RoleC :start-revision revision |
|---|
| 187 | :item-identifiers iis |
|---|
| 188 | :reifier (when reifier |
|---|
| 189 | (get-item-from-jtm-reference |
|---|
| 190 | reifier :revision revision :prefixes prefixes)) |
|---|
| 191 | :instance-of (get-item-from-jtm-reference |
|---|
| 192 | type :revision revision :prefixes prefixes) |
|---|
| 193 | :player (get-item-from-jtm-reference |
|---|
| 194 | player :revision revision :prefixes prefixes) |
|---|
| 195 | :parent (first local-parent)))) |
|---|
| 196 | |
|---|
| 197 | |
|---|
| 198 | (defun make-plist-of-jtm-role(jtm-list &key (revision *TM-REVISION*) prefixes) |
|---|
| 199 | "Returns a plist of the form (:start-revision <rev> :player <top> |
|---|
| 200 | :instance-of <top> :reifier <top> :item-identifiers <ii>)." |
|---|
| 201 | (unless (and (get-item :PLAYER jtm-list) |
|---|
| 202 | (get-item :TYPE jtm-list)) |
|---|
| 203 | (error (make-condition 'JTM-error :message (format nil "From make-plist-of-jtm-role(): the role ~a must have a type and player member set." jtm-list)))) |
|---|
| 204 | (list :start-revision revision |
|---|
| 205 | :player (get-item-from-jtm-reference |
|---|
| 206 | (get-item :PLAYER jtm-list) |
|---|
| 207 | :revision revision :prefixes prefixes) |
|---|
| 208 | :instance-of (get-item-from-jtm-reference |
|---|
| 209 | (get-item :TYPE jtm-list) |
|---|
| 210 | :revision revision :prefixes prefixes) |
|---|
| 211 | :item-identifiers (import-identifiers-from-jtm-strings |
|---|
| 212 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 213 | :prefixes prefixes) |
|---|
| 214 | :reifier (when (get-item :REIFIER jtm-list) |
|---|
| 215 | (get-item-from-jtm-reference |
|---|
| 216 | (get-item :REIFIER jtm-list) |
|---|
| 217 | :revision revision :prefixes prefixes)))) |
|---|
| 218 | |
|---|
| 219 | |
|---|
| 220 | (defun import-association-from-jtm-list (jtm-list parents &key |
|---|
| 221 | (revision *TM-REVISION*) prefixes) |
|---|
| 222 | "Create an AssociationC object corresponding to the passed jtm-list and |
|---|
| 223 | returns it." |
|---|
| 224 | (declare (List jtm-list parents prefixes) |
|---|
| 225 | (Integer revision)) |
|---|
| 226 | (let* ((iis (import-identifiers-from-jtm-strings |
|---|
| 227 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 228 | :prefixes prefixes)) |
|---|
| 229 | (scope (get-item :SCOPE jtm-list)) |
|---|
| 230 | (type (get-item :TYPE jtm-list)) |
|---|
| 231 | (reifier (get-item :REIFIER jtm-list)) |
|---|
| 232 | (parent-references (get-item :PARENT jtm-list)) |
|---|
| 233 | (role-lists |
|---|
| 234 | (map 'list #'(lambda(role) |
|---|
| 235 | (make-plist-of-jtm-role role :revision revision |
|---|
| 236 | :prefixes prefixes)) |
|---|
| 237 | (get-item :ROLES jtm-list))) |
|---|
| 238 | (local-parent |
|---|
| 239 | (if parents |
|---|
| 240 | parents |
|---|
| 241 | (when parent-references |
|---|
| 242 | (get-items-from-jtm-references |
|---|
| 243 | parent-references :revision revision :prefixes prefixes))))) |
|---|
| 244 | (unless local-parent |
|---|
| 245 | (error (make-condition 'JTM-error :message (format nil "From import-association-from-jtm-list(): the JTM association ~a must have at least one parent set in its members." jtm-list)))) |
|---|
| 246 | (unless role-lists |
|---|
| 247 | (error (make-condition 'JTM-error :message (format nil "From import-association-from-jtm-list(): the JTM association ~a must have at least one role set in its members." jtm-list)))) |
|---|
| 248 | (unless type |
|---|
| 249 | (error (make-condition 'JTM-error :message (format nil "From import-association-from-jtm-list(): the association ~a must have exactly one type set as member." jtm-list)))) |
|---|
| 250 | (let ((assoc |
|---|
| 251 | (make-construct 'AssociationC :start-revision revision |
|---|
| 252 | :item-identifiers iis |
|---|
| 253 | :themes (get-items-from-jtm-references |
|---|
| 254 | scope :revision revision :prefixes prefixes) |
|---|
| 255 | :reifier (when reifier |
|---|
| 256 | (get-item-from-jtm-reference |
|---|
| 257 | reifier :revision revision :prefixes prefixes)) |
|---|
| 258 | :instance-of (get-item-from-jtm-reference |
|---|
| 259 | type :revision revision :prefixes prefixes) |
|---|
| 260 | :roles role-lists))) |
|---|
| 261 | (dolist (tm local-parent) |
|---|
| 262 | (add-to-tm tm assoc)) |
|---|
| 263 | (format t "a") |
|---|
| 264 | assoc))) |
|---|
| 265 | |
|---|
| 266 | |
|---|
| 267 | (defun import-topic-stubs-from-jtm-lists (jtm-lists parents &key |
|---|
| 268 | (revision *TM-REVISION*) prefixes) |
|---|
| 269 | "Creates and returns a list of topics. |
|---|
| 270 | Note only the topic identifiers are imported and set in this function, |
|---|
| 271 | entire topics are imported in merge-topics-from-jtm-lists." |
|---|
| 272 | (declare (List jtm-lists parents prefixes) |
|---|
| 273 | (Integer revision)) |
|---|
| 274 | (map 'list #'(lambda(jtm-list) |
|---|
| 275 | (import-topic-stub-from-jtm-list |
|---|
| 276 | jtm-list parents :revision revision :prefixes prefixes)) |
|---|
| 277 | jtm-lists)) |
|---|
| 278 | |
|---|
| 279 | |
|---|
| 280 | (defun import-topic-stub-from-jtm-list(jtm-list parents &key |
|---|
| 281 | (revision *TM-REVISION*) prefixes) |
|---|
| 282 | "Creates and returns a topic object from the passed jtm |
|---|
| 283 | list generated by json:decode-json-from-string. |
|---|
| 284 | Note this function only sets the topic's identifiers." |
|---|
| 285 | (declare (List jtm-list parents prefixes) |
|---|
| 286 | (Integer revision)) |
|---|
| 287 | (let* ((t-iis (import-identifiers-from-jtm-strings |
|---|
| 288 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 289 | :prefixes prefixes)) |
|---|
| 290 | (t-psis (import-identifiers-from-jtm-strings |
|---|
| 291 | (get-item :SUBJECT--IDENTIFIERS jtm-list) |
|---|
| 292 | :prefixes prefixes :identifier-type-symbol 'd:PersistentIdC)) |
|---|
| 293 | (t-sls (import-identifiers-from-jtm-strings |
|---|
| 294 | (get-item :SUBJECT--LOCATORS jtm-list) |
|---|
| 295 | :prefixes prefixes :identifier-type-symbol 'd:SubjectLocatorC)) |
|---|
| 296 | (parent-references (get-item :PARENT jtm-list)) |
|---|
| 297 | (local-parents |
|---|
| 298 | (if parents |
|---|
| 299 | parents |
|---|
| 300 | (when parent-references |
|---|
| 301 | (get-items-from-jtm-references |
|---|
| 302 | parent-references :revision revision :prefixes prefixes))))) |
|---|
| 303 | (unless local-parents |
|---|
| 304 | (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)))) |
|---|
| 305 | (unless (append t-iis t-sls t-psis) |
|---|
| 306 | (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)))) |
|---|
| 307 | (let* ((top (make-construct 'TopicC :start-revision revision |
|---|
| 308 | :psis t-psis |
|---|
| 309 | :item-identifiers t-iis |
|---|
| 310 | :locators t-sls))) |
|---|
| 311 | (dolist (tm local-parents) |
|---|
| 312 | (add-to-tm tm top)) |
|---|
| 313 | top))) |
|---|
| 314 | |
|---|
| 315 | |
|---|
| 316 | (defun make-instance-of-association (instance-top type-top parents &key |
|---|
| 317 | (revision *TM-REVISION*)) |
|---|
| 318 | "Creates and returns a type-instance-association for the passed |
|---|
| 319 | instance and type topics." |
|---|
| 320 | (declare (TopicC instance-top type-top) |
|---|
| 321 | (List parents) |
|---|
| 322 | (Integer revision)) |
|---|
| 323 | (unless parents |
|---|
| 324 | (error (make-condition 'JTM-error :message (format nil "From make-instance-of-association(): parents must contain at least one TopicMapC object, but is nil")))) |
|---|
| 325 | (let ((t-top (get-item-by-psi *type-psi* :revision revision)) |
|---|
| 326 | (i-top (get-item-by-psi *instance-psi* :revision revision)) |
|---|
| 327 | (ti-top (get-item-by-psi *type-instance-psi* :revision revision))) |
|---|
| 328 | (unless (and i-top t-top ti-top) |
|---|
| 329 | (let ((missing-topic (cond ((not t-top) *type-psi*) |
|---|
| 330 | ((not i-top) *instance-psi*) |
|---|
| 331 | (t *type-instance-psi*)))) |
|---|
| 332 | (error (make-condition 'missing-reference-error :message (format nil "From make-instance-of-association(): the core topics ~a, ~a, and ~a are necessary, but ~a cannot be found" *type-psi* *instance-psi* *type-instance-psi* missing-topic) :reference missing-topic)))) |
|---|
| 333 | (let ((assoc |
|---|
| 334 | (make-construct 'AssociationC :start-revision revision |
|---|
| 335 | :instance-of ti-top |
|---|
| 336 | :roles (list (list :start-revision revision |
|---|
| 337 | :player instance-top |
|---|
| 338 | :instance-of i-top) |
|---|
| 339 | (list :start-revision revision |
|---|
| 340 | :player type-top |
|---|
| 341 | :instance-of t-top))))) |
|---|
| 342 | (dolist (tm parents) |
|---|
| 343 | (add-to-tm tm i-top) |
|---|
| 344 | (add-to-tm tm t-top) |
|---|
| 345 | (add-to-tm tm ti-top) |
|---|
| 346 | (add-to-tm tm assoc)) |
|---|
| 347 | assoc))) |
|---|
| 348 | |
|---|
| 349 | |
|---|
| 350 | (defun merge-topics-from-jtm-lists (jtm-lists &key (instance-of-p t) |
|---|
| 351 | (revision *TM-REVISION*) prefixes |
|---|
| 352 | (create-fragments nil)) |
|---|
| 353 | "Creates and returns a list of topics." |
|---|
| 354 | (declare (List jtm-lists prefixes) |
|---|
| 355 | (Boolean instance-of-p create-fragments) |
|---|
| 356 | (Integer revision)) |
|---|
| 357 | (map 'list #'(lambda(jtm-list) |
|---|
| 358 | (merge-topic-from-jtm-list |
|---|
| 359 | jtm-list :revision revision :prefixes prefixes |
|---|
| 360 | :instance-of-p instance-of-p |
|---|
| 361 | :create-fragment create-fragments)) |
|---|
| 362 | jtm-lists)) |
|---|
| 363 | |
|---|
| 364 | |
|---|
| 365 | (defun merge-topic-from-jtm-list(jtm-list &key (instance-of-p t) |
|---|
| 366 | (revision *TM-REVISION*) prefixes |
|---|
| 367 | (create-fragment nil)) |
|---|
| 368 | "Creates and returns a topic object from the passed jtm |
|---|
| 369 | list generated by json:decode-json-from-string. |
|---|
| 370 | Note that the merged topics are not added explicitly to the parent |
|---|
| 371 | topic maps, it is only needed for the instance-of-associations - |
|---|
| 372 | topics are added in the function import-topic-stubs-from-jtm-lists |
|---|
| 373 | to their topic map elements." |
|---|
| 374 | (declare (List jtm-list prefixes) |
|---|
| 375 | (Boolean instance-of-p) |
|---|
| 376 | (Integer revision) |
|---|
| 377 | (Boolean create-fragment)) |
|---|
| 378 | (let* ((ids (append (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 379 | (get-item :SUBJECT--IDENTIFIERS jtm-list) |
|---|
| 380 | (get-item :SUBJECT--LOCATORS jtm-list))) |
|---|
| 381 | (top (when ids |
|---|
| 382 | (get-item-by-any-id |
|---|
| 383 | (compute-uri-from-jtm-identifier (first ids) prefixes) |
|---|
| 384 | :revision revision))) |
|---|
| 385 | (instanceof (get-items-from-jtm-references |
|---|
| 386 | (get-item :INSTANCE--OF jtm-list) :revision revision |
|---|
| 387 | :prefixes prefixes)) |
|---|
| 388 | (top-names (import-characteristics-from-jtm-lists |
|---|
| 389 | (get-item :NAMES jtm-list) top |
|---|
| 390 | #'import-name-from-jtm-list :revision revision |
|---|
| 391 | :prefixes prefixes)) |
|---|
| 392 | (top-occs (import-characteristics-from-jtm-lists |
|---|
| 393 | (get-item :OCCURRENCES jtm-list) top |
|---|
| 394 | #'import-occurrence-from-jtm-list :revision revision |
|---|
| 395 | :prefixes prefixes))) |
|---|
| 396 | (unless ids |
|---|
| 397 | (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)))) |
|---|
| 398 | (unless top |
|---|
| 399 | (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)))) |
|---|
| 400 | (when (and (not instance-of-p) instanceof) |
|---|
| 401 | (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)))) |
|---|
| 402 | (dolist (type-top instanceof) |
|---|
| 403 | (make-instance-of-association |
|---|
| 404 | top type-top (in-topicmaps top :revision revision) |
|---|
| 405 | :revision revision)) |
|---|
| 406 | (dolist (name top-names) |
|---|
| 407 | (add-name top name :revision revision)) |
|---|
| 408 | (dolist (occ top-occs) |
|---|
| 409 | (add-occurrence top occ :revision revision)) |
|---|
| 410 | (when create-fragment |
|---|
| 411 | (let ((all-assocs |
|---|
| 412 | (remove-null (map 'list (lambda(role) |
|---|
| 413 | (parent role :revision revision)) |
|---|
| 414 | (player-in-roles top :revision revision))))) |
|---|
| 415 | (let ((all-tops |
|---|
| 416 | (remove-null |
|---|
| 417 | (loop for assoc in all-assocs |
|---|
| 418 | append (map 'list (lambda(role) |
|---|
| 419 | (d:player role :revision revision)) |
|---|
| 420 | (roles assoc :revision revision)))))) |
|---|
| 421 | (map nil (lambda(top) |
|---|
| 422 | (map nil #'elephant:drop-instance |
|---|
| 423 | (elephant:get-instances-by-value 'FragmentC 'topic top)) |
|---|
| 424 | (create-latest-fragment-of-topic top)) |
|---|
| 425 | (append all-tops (list top)))))) |
|---|
| 426 | (format t "t") |
|---|
| 427 | top)) |
|---|
| 428 | |
|---|
| 429 | |
|---|
| 430 | (defun import-name-from-jtm-list (jtm-list parent &key |
|---|
| 431 | (revision *TM-REVISION*) prefixes) |
|---|
| 432 | "Creates and returns a name object from the passed jtm |
|---|
| 433 | list generated by json:decode-json-from-string." |
|---|
| 434 | (declare (List jtm-list prefixes) |
|---|
| 435 | (Integer revision) |
|---|
| 436 | (type (or Null TopicC) parent)) |
|---|
| 437 | (let* ((iis (import-identifiers-from-jtm-strings |
|---|
| 438 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 439 | :prefixes prefixes)) |
|---|
| 440 | (scope (get-item :SCOPE jtm-list)) |
|---|
| 441 | (type (get-item :TYPE jtm-list)) |
|---|
| 442 | (value (get-item :VALUE jtm-list)) |
|---|
| 443 | (name-variants (get-item :VARIANTS jtm-list)) |
|---|
| 444 | (reifier (get-item :REIFIER jtm-list)) |
|---|
| 445 | (parent-references (get-item :PARENT jtm-list)) |
|---|
| 446 | (local-parent |
|---|
| 447 | (if parent |
|---|
| 448 | (list parent) |
|---|
| 449 | (when parent-references |
|---|
| 450 | (get-items-from-jtm-references |
|---|
| 451 | parent-references :revision revision :prefixes prefixes))))) |
|---|
| 452 | (when (/= (length local-parent) 1) |
|---|
| 453 | (error (make-condition 'JTM-error :message (format nil "From import-name-from-jtm-list(): the JTM name ~a must have exactly one parent set in its members." jtm-list)))) |
|---|
| 454 | (let ((name |
|---|
| 455 | (make-construct |
|---|
| 456 | 'NameC :start-revision revision |
|---|
| 457 | :item-identifiers iis |
|---|
| 458 | :charvalue value |
|---|
| 459 | :themes (get-items-from-jtm-references |
|---|
| 460 | scope :revision revision :prefixes prefixes) |
|---|
| 461 | :instance-of (if type |
|---|
| 462 | (get-item-from-jtm-reference |
|---|
| 463 | type :revision revision :prefixes prefixes) |
|---|
| 464 | (get-item-by-psi *topic-name-psi* |
|---|
| 465 | :revision revision :error-if-nil t)) |
|---|
| 466 | :parent (first local-parent) |
|---|
| 467 | :reifier (when reifier |
|---|
| 468 | (get-item-from-jtm-reference |
|---|
| 469 | reifier :revision revision :prefixes prefixes))))) |
|---|
| 470 | (import-characteristics-from-jtm-lists name-variants name |
|---|
| 471 | #'import-variant-from-jtm-list |
|---|
| 472 | :revision revision :prefixes prefixes) |
|---|
| 473 | name))) |
|---|
| 474 | |
|---|
| 475 | |
|---|
| 476 | (defun import-occurrence-from-jtm-list (jtm-list parent &key |
|---|
| 477 | (revision *TM-REVISION*) prefixes) |
|---|
| 478 | "Creates and returns an occurrence object from the passed jtm |
|---|
| 479 | list generated by json:decode-json-from-string." |
|---|
| 480 | (declare (List jtm-list prefixes) |
|---|
| 481 | (Integer revision) |
|---|
| 482 | (type (or Null TopicC) parent)) |
|---|
| 483 | (let* ((iis (import-identifiers-from-jtm-strings |
|---|
| 484 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 485 | :prefixes prefixes)) |
|---|
| 486 | (datatype |
|---|
| 487 | (let ((curie (jtm::get-item :DATATYPE jtm-list))) |
|---|
| 488 | (cond ((null curie) |
|---|
| 489 | constants:*xml-string*) |
|---|
| 490 | ((and (tools:string-starts-with curie "[") |
|---|
| 491 | (tools:string-ends-with curie "]")) |
|---|
| 492 | (jtm::compute-uri-from-jtm-identifier curie prefixes)) |
|---|
| 493 | (t |
|---|
| 494 | curie)))) |
|---|
| 495 | (scope (get-item :SCOPE jtm-list)) |
|---|
| 496 | (type (get-item :TYPE jtm-list)) |
|---|
| 497 | (value (get-item :VALUE jtm-list)) |
|---|
| 498 | (reifier (get-item :REIFIER jtm-list)) |
|---|
| 499 | (parent-references (get-item :PARENT jtm-list)) |
|---|
| 500 | (local-parent |
|---|
| 501 | (if parent |
|---|
| 502 | (list parent) |
|---|
| 503 | (when parent-references |
|---|
| 504 | (get-items-from-jtm-references |
|---|
| 505 | parent-references :revision revision :prefixes prefixes))))) |
|---|
| 506 | (when (/= (length local-parent) 1) |
|---|
| 507 | (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-list(): the JTM occurrence ~a must have a parent set in its members." jtm-list)))) |
|---|
| 508 | (unless type |
|---|
| 509 | (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-list(): the JTM occurrence ~a must have a type set in its members." jtm-list)))) |
|---|
| 510 | (make-construct 'OccurrenceC :start-revision revision |
|---|
| 511 | :item-identifiers iis |
|---|
| 512 | :datatype datatype |
|---|
| 513 | :charvalue value |
|---|
| 514 | :themes (get-items-from-jtm-references |
|---|
| 515 | scope :revision revision :prefixes prefixes) |
|---|
| 516 | :instance-of (get-item-from-jtm-reference |
|---|
| 517 | type :revision revision :prefixes prefixes) |
|---|
| 518 | :parent (first local-parent) |
|---|
| 519 | :reifier (when reifier |
|---|
| 520 | (get-item-from-jtm-reference |
|---|
| 521 | reifier :revision revision :prefixes prefixes))))) |
|---|
| 522 | |
|---|
| 523 | |
|---|
| 524 | (defun import-characteristics-from-jtm-lists(jtm-lists parent next-fun &key |
|---|
| 525 | (revision *TM-REVISION*) prefixes) |
|---|
| 526 | "Creates and returns a list of TM-Constructs returned by next-fun." |
|---|
| 527 | (declare (List jtm-lists prefixes) |
|---|
| 528 | (Integer revision) |
|---|
| 529 | (type (or Null ReifiableConstructC) parent) |
|---|
| 530 | (Function next-fun)) |
|---|
| 531 | (map 'list #'(lambda(jtm-list) |
|---|
| 532 | (apply next-fun (list jtm-list parent :revision revision |
|---|
| 533 | :prefixes prefixes))) |
|---|
| 534 | jtm-lists)) |
|---|
| 535 | |
|---|
| 536 | |
|---|
| 537 | (defun import-variant-from-jtm-list(jtm-list parent &key |
|---|
| 538 | (revision *TM-REVISION*) prefixes) |
|---|
| 539 | "Creates a variant object from the passed jtm list generated by |
|---|
| 540 | json:decode-json-from-string." |
|---|
| 541 | (declare (List jtm-list prefixes) |
|---|
| 542 | (type (or Null NameC) parent) |
|---|
| 543 | (Integer revision)) |
|---|
| 544 | (let* ((iis (import-identifiers-from-jtm-strings |
|---|
| 545 | (get-item :ITEM--IDENTIFIERS jtm-list) |
|---|
| 546 | :prefixes prefixes)) |
|---|
| 547 | (datatype |
|---|
| 548 | (let ((curie (jtm::get-item :DATATYPE jtm-list))) |
|---|
| 549 | (cond ((null curie) |
|---|
| 550 | constants:*xml-string*) |
|---|
| 551 | ((and (tools:string-starts-with curie "[") |
|---|
| 552 | (tools:string-ends-with curie "]")) |
|---|
| 553 | (jtm::compute-uri-from-jtm-identifier curie prefixes)) |
|---|
| 554 | (t |
|---|
| 555 | curie)))) |
|---|
| 556 | (value (get-item :VALUE jtm-list)) |
|---|
| 557 | (reifier (get-item :REIFIER jtm-list)) |
|---|
| 558 | (parent-references (get-item :PARENT jtm-list)) |
|---|
| 559 | (local-parent |
|---|
| 560 | (if parent |
|---|
| 561 | (list parent) |
|---|
| 562 | (when parent-references |
|---|
| 563 | (get-items-from-jtm-references |
|---|
| 564 | parent-references :revision revision :prefixes prefixes)))) |
|---|
| 565 | (scopes (when local-parent |
|---|
| 566 | (remove-duplicates |
|---|
| 567 | (append |
|---|
| 568 | (get-items-from-jtm-references |
|---|
| 569 | (get-item :SCOPE jtm-list) |
|---|
| 570 | :revision revision :prefixes prefixes) |
|---|
| 571 | (themes (first local-parent) :revision revision)))))) |
|---|
| 572 | (when (/= (length local-parent) 1) |
|---|
| 573 | (error (make-condition 'JTM-error :message (format nil "From import-variant-from-jtm-list(): the JTM variant ~a must have exactly one parent set in its members." jtm-list)))) |
|---|
| 574 | (make-construct 'VariantC :start-revision revision |
|---|
| 575 | :item-identifiers iis |
|---|
| 576 | :datatype (if datatype datatype *xml-string*) |
|---|
| 577 | :charvalue value |
|---|
| 578 | :themes scopes |
|---|
| 579 | :parent (first local-parent) |
|---|
| 580 | :reifier (when reifier |
|---|
| 581 | (get-item-from-jtm-reference |
|---|
| 582 | reifier :revision revision :prefixes prefixes))))) |
|---|
| 583 | |
|---|
| 584 | |
|---|
| 585 | (defun import-identifiers-from-jtm-strings |
|---|
| 586 | (jtm-strings &key (identifier-type-symbol 'ItemIdentifierC) prefixes) |
|---|
| 587 | "Creates and returns a list of identifiers specified by jtm-strings and |
|---|
| 588 | identifier-type-symbol." |
|---|
| 589 | (declare (List jtm-strings) |
|---|
| 590 | (Symbol identifier-type-symbol) |
|---|
| 591 | (List prefixes)) |
|---|
| 592 | (map 'list #'(lambda(jtm-string) |
|---|
| 593 | (import-identifier-from-jtm-string |
|---|
| 594 | jtm-string :prefixes prefixes |
|---|
| 595 | :identifier-type-symbol identifier-type-symbol)) |
|---|
| 596 | jtm-strings)) |
|---|
| 597 | |
|---|
| 598 | |
|---|
| 599 | (defun import-identifier-from-jtm-string |
|---|
| 600 | (jtm-string &key (identifier-type-symbol 'ItemIdentifierC) prefixes) |
|---|
| 601 | "Creates and returns an identifier of the type specified by |
|---|
| 602 | identifier-type-symbol." |
|---|
| 603 | (declare (String jtm-string) |
|---|
| 604 | (Symbol identifier-type-symbol) |
|---|
| 605 | (List prefixes)) |
|---|
| 606 | (let ((uri-value (compute-uri-from-jtm-identifier jtm-string prefixes))) |
|---|
| 607 | (make-construct identifier-type-symbol |
|---|
| 608 | :uri uri-value))) |
|---|
| 609 | |
|---|
| 610 | |
|---|
| 611 | |
|---|
| 612 | (defun get-item-from-jtm-reference (reference-string &key (revision *TM-REVISION*) |
|---|
| 613 | prefixes) |
|---|
| 614 | "Returns a ReifiableConstructC that is bound to the reference that is |
|---|
| 615 | passed to this function. If the construct cannot be found the error |
|---|
| 616 | tm-reference-error is thrown." |
|---|
| 617 | (declare (Integer revision) |
|---|
| 618 | (List prefixes) |
|---|
| 619 | (String reference-string)) |
|---|
| 620 | (let* ((identifier-type |
|---|
| 621 | (get-identifier-type-from-jtm-reference reference-string)) |
|---|
| 622 | (identifier-value (subseq reference-string 3)) |
|---|
| 623 | (identifier-uri |
|---|
| 624 | (compute-uri-from-jtm-identifier identifier-value prefixes)) |
|---|
| 625 | (construct |
|---|
| 626 | (d::get-item-by-identifier identifier-uri :revision revision |
|---|
| 627 | :identifier-type-symbol identifier-type))) |
|---|
| 628 | (if construct |
|---|
| 629 | construct |
|---|
| 630 | (error (make-condition 'missing-reference-error :message (format nil "From get-item-from-jtm-reference(): cannot find the item identified by \"~a\"(~a)" identifier-uri reference-string) |
|---|
| 631 | :reference identifier-uri))))) |
|---|
| 632 | |
|---|
| 633 | |
|---|
| 634 | (defun get-items-from-jtm-references (reference-strings &key (revision *TM-REVISion*) |
|---|
| 635 | prefixes) |
|---|
| 636 | "Returns a list of ReifiableConstructCs that are referenced via the |
|---|
| 637 | string-values in reference-strings." |
|---|
| 638 | (declare (List reference-strings prefixes) |
|---|
| 639 | (Integer revision)) |
|---|
| 640 | (map 'list #'(lambda(reference-string) |
|---|
| 641 | (get-item-from-jtm-reference reference-string :revision revision |
|---|
| 642 | :prefixes prefixes)) |
|---|
| 643 | reference-strings)) |
|---|
| 644 | |
|---|
| 645 | |
|---|
| 646 | (defun compute-uri-from-jtm-identifier (identifier-value prefixes) |
|---|
| 647 | "Returns the full uri of an identifier string, i.e. |
|---|
| 648 | * if the value is of the form '[pref:value]' the return value is |
|---|
| 649 | the concatenation of 'value-of-pref' and 'value'. |
|---|
| 650 | * if the value is of the form 'full-uri' the return value is |
|---|
| 651 | 'full-uri'" |
|---|
| 652 | (declare (String identifier-value) |
|---|
| 653 | (List prefixes)) |
|---|
| 654 | (cond ((and (string-starts-with identifier-value "[") |
|---|
| 655 | (string-ends-with identifier-value "]")) |
|---|
| 656 | (let* ((pref-name |
|---|
| 657 | (let ((value (string-until identifier-value ":"))) |
|---|
| 658 | (when value |
|---|
| 659 | (subseq value 1)))) |
|---|
| 660 | (suffix |
|---|
| 661 | (when pref-name |
|---|
| 662 | (let ((value |
|---|
| 663 | (subseq identifier-value (1+ (length pref-name))))) |
|---|
| 664 | (when value |
|---|
| 665 | (subseq value (min 1 (length value)) |
|---|
| 666 | (max 0 (1- (length value))))))))) |
|---|
| 667 | (when (or (not pref-name) (not suffix)) |
|---|
| 668 | (error (make-condition 'JTM-error :message (format nil "From compute-uri-from-jtm-identifier: the section within the range of \"[\" and \"]\" must be of the form prefix:suffix, but is: \"~a\"" identifier-value)))) |
|---|
| 669 | (compute-full-uri prefixes pref-name suffix))) |
|---|
| 670 | ((> (length identifier-value) 0) |
|---|
| 671 | identifier-value) |
|---|
| 672 | (t |
|---|
| 673 | (error (make-condition 'JTM-error :message (format nil "From compute-uri-from-jtm-identifier(): the identifier-value must be of the form \"[pref:value]\" or \"full-uri\", but is: \"~a\"" identifier-value)))))) |
|---|
| 674 | |
|---|
| 675 | |
|---|
| 676 | (defun get-identifier-type-from-jtm-reference (identifier-string) |
|---|
| 677 | "Returns the symbol 'PersistentIdC if identifier-string starts |
|---|
| 678 | with si:, 'SubjectLocatorC if identifier-string starts with |
|---|
| 679 | sl:, or 'ItemIdentifierC if identifier-string starts with ii:. |
|---|
| 680 | If identifier-string do not start with one of these strings |
|---|
| 681 | the error JTM-error is thrown." |
|---|
| 682 | (cond ((string-starts-with identifier-string "ii:") |
|---|
| 683 | 'ItemIdentifierC) |
|---|
| 684 | ((string-starts-with identifier-string "si:") |
|---|
| 685 | 'PersistentIdC) |
|---|
| 686 | ((string-starts-with identifier-string "sl:") |
|---|
| 687 | 'SubjectLocatorC) |
|---|
| 688 | (t |
|---|
| 689 | (error (make-condition 'JTM-error :message (format nil "From get-identifier-type(): the identifier value must start with one of \"ii:\", \"si:\", or \"sl:\", but is: \"~a\"" identifier-string)))))) |
|---|
