| 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 | (defpackage :jtm |
|---|
| 11 | (:use :cl :json :datamodel :base-tools :isidorus-threading |
|---|
| 12 | :constants :exceptions) |
|---|
| 13 | (:export :import-from-jtm |
|---|
| 14 | :import-construct-from-jtm-decoded-list |
|---|
| 15 | :import-construct-from-jtm-string |
|---|
| 16 | :export-as-jtm |
|---|
| 17 | :export-as-jtm-string |
|---|
| 18 | :export-construct-as-jtm-string |
|---|
| 19 | :item_type-topicmap |
|---|
| 20 | :item_type-topic |
|---|
| 21 | :item_type-name |
|---|
| 22 | :item_type-variant |
|---|
| 23 | :item_type-occurrence |
|---|
| 24 | :item_type-association |
|---|
| 25 | :item_type-role)) |
|---|
| 26 | |
|---|
| 27 | (in-package :jtm) |
|---|
| 28 | |
|---|
| 29 | (defvar item_type-topicmap "topicmap") |
|---|
| 30 | |
|---|
| 31 | (defvar item_type-topic "topic") |
|---|
| 32 | |
|---|
| 33 | (defvar item_type-name "name") |
|---|
| 34 | |
|---|
| 35 | (defvar item_type-variant "variant") |
|---|
| 36 | |
|---|
| 37 | (defvar item_type-occurrence "occurrence") |
|---|
| 38 | |
|---|
| 39 | (defvar item_type-association "association") |
|---|
| 40 | |
|---|
| 41 | (defvar item_type-role "role") |
|---|
| 42 | |
|---|
| 43 | |
|---|
| 44 | (defgeneric create-prefix-list-for-construct (construct &key revision) |
|---|
| 45 | (:documentation "Returns a list of the following structure: |
|---|
| 46 | ((:pref 'pref_1' :value 'uri-pref') (...)).")) |
|---|
| 47 | |
|---|
| 48 | |
|---|
| 49 | (defun compute-full-uri (prefix-list prefix-name suffix) |
|---|
| 50 | "Returns a full uri if the prefix-name can found in an item of the form |
|---|
| 51 | (:pref 'prefix-name' :value 'uri-value/'), the returnvalue would be of |
|---|
| 52 | the form uri-value/suffix. Otherwise the return value is nil." |
|---|
| 53 | (declare (List prefix-list) |
|---|
| 54 | (String prefix-name suffix)) |
|---|
| 55 | (if (= (length suffix) 0) |
|---|
| 56 | (error (make-condition 'JTM-error :message (format nil "From compute-full-uri(): suffix must no be of length 0, but is \"~a\"" suffix))) |
|---|
| 57 | (let ((result (loop for item in prefix-list |
|---|
| 58 | when (string= (getf item :pref) prefix-name) |
|---|
| 59 | return (concat (getf item :value) suffix)))) |
|---|
| 60 | (if result |
|---|
| 61 | result |
|---|
| 62 | (error (make-condition 'JTM-error :message (format nil "From compute-full-uri(): prefix \"~a\" not found in the available prefixes \"~a\"" prefix-name prefix-list))))))) |
|---|
| 63 | |
|---|
| 64 | |
|---|
| 65 | (defun export-construct-as-jtm-string (construct &key (revision (get-revision)) |
|---|
| 66 | (jtm-format :1.1) (parent-p t)) |
|---|
| 67 | "Exports a name variant as JTM string. |
|---|
| 68 | jtm-format must be set either to :1.0 or :1.1." |
|---|
| 69 | (declare (Symbol jtm-format) |
|---|
| 70 | (Integer revision) |
|---|
| 71 | (Boolean parent-p) |
|---|
| 72 | (type (or ReifiableConstructC FragmentC) construct)) |
|---|
| 73 | (with-reader-lock |
|---|
| 74 | (let* ((prefixes |
|---|
| 75 | (when (eql jtm-format :1.1) |
|---|
| 76 | (create-prefix-list-for-construct construct :revision revision))) |
|---|
| 77 | (prefixes-p (cond ((eql jtm-format :1.1) t) |
|---|
| 78 | ((eql jtm-format :1.0) nil) |
|---|
| 79 | (t (error (make-condition 'JTM-error :message (format nil "From export-construct-as-jtm-string(): jtm-format must be set to :1.1 or :1.0, but is ~a" jtm-format)))))) |
|---|
| 80 | (version (concat "\"" (symbol-name jtm-format) "\"")) |
|---|
| 81 | (json-str |
|---|
| 82 | (if (typep construct 'TopicC) |
|---|
| 83 | (export-to-jtm construct :parent-p parent-p :prefixes prefixes |
|---|
| 84 | :prefixes-p prefixes-p :revision revision |
|---|
| 85 | :instance-of-p (eql jtm-format :1.1)) |
|---|
| 86 | (export-to-jtm construct :parent-p parent-p :prefixes prefixes |
|---|
| 87 | :prefixes-p prefixes-p :revision revision)))) |
|---|
| 88 | (concat "{\"version\":" version "," (subseq json-str 1))))) |
|---|
| 89 | |
|---|
| 90 | |
|---|
| 91 | (defun export-as-jtm-string (&key tm-id (revision (get-revision)) |
|---|
| 92 | (jtm-format :1.1)) |
|---|
| 93 | "Exports a topic map or all stored constructs as JTM string. |
|---|
| 94 | jtm-format must be set either to :1.0 or :1.1." |
|---|
| 95 | (declare (type (or Null String) tm-id) |
|---|
| 96 | (Symbol jtm-format) |
|---|
| 97 | (Integer revision)) |
|---|
| 98 | (with-reader-lock |
|---|
| 99 | (let ((tm |
|---|
| 100 | (when tm-id |
|---|
| 101 | (get-item-by-item-identifier tm-id :revision revision))) |
|---|
| 102 | (version-1.1-p (eq jtm-format :1.1))) |
|---|
| 103 | (let* ((tm-tops |
|---|
| 104 | (if tm |
|---|
| 105 | (let ((inner-tops |
|---|
| 106 | (delete-if #'(lambda(top) |
|---|
| 107 | (not (find-item-by-revision top revision))) |
|---|
| 108 | (topics tm)))) |
|---|
| 109 | (if (eql jtm-format :1.1) |
|---|
| 110 | (filter-type-instance-topics inner-tops tm |
|---|
| 111 | :revision revision) |
|---|
| 112 | inner-tops)) |
|---|
| 113 | (get-all-topics revision))) |
|---|
| 114 | (tm-assocs |
|---|
| 115 | (let ((assocs |
|---|
| 116 | (if tm |
|---|
| 117 | (delete-if #'(lambda(assoc) |
|---|
| 118 | (not (find-item-by-revision assoc revision))) |
|---|
| 119 | (associations tm)) |
|---|
| 120 | (get-all-associations revision)))) |
|---|
| 121 | (if version-1.1-p |
|---|
| 122 | (set-difference |
|---|
| 123 | assocs |
|---|
| 124 | (loop for top in tm-tops |
|---|
| 125 | append (instance-of-associations top :revision revision))) |
|---|
| 126 | assocs))) |
|---|
| 127 | (prefixes |
|---|
| 128 | (when version-1.1-p |
|---|
| 129 | (create-prefix-list-for-tm tm-tops tm-assocs tm :revision revision))) |
|---|
| 130 | (version (if version-1.1-p |
|---|
| 131 | "\"version\":\"1.1\"," |
|---|
| 132 | "\"version\":\"1.0\",")) |
|---|
| 133 | (prefix-value (when version-1.1-p |
|---|
| 134 | (concat "\"prefixes\":" |
|---|
| 135 | (export-prefix-list-to-jtm prefixes) ","))) |
|---|
| 136 | (iis (concat "\"item_identifiers\":" |
|---|
| 137 | (if tm |
|---|
| 138 | (export-identifiers-to-jtm |
|---|
| 139 | tm :identifier-type 'ItemIdentifierC :prefixes prefixes |
|---|
| 140 | :revision revision) |
|---|
| 141 | "null") ",")) |
|---|
| 142 | (topics (concat "\"topics\":" |
|---|
| 143 | (export-topics-to-jtm |
|---|
| 144 | tm-tops :prefixes prefixes :instance-of-p version-1.1-p |
|---|
| 145 | :item-type-p nil :revision revision) ",")) |
|---|
| 146 | (assocs (concat "\"associations\":" |
|---|
| 147 | (export-associations-to-jtm |
|---|
| 148 | tm-assocs :prefixes prefixes |
|---|
| 149 | :item-type-p nil :revision revision) ",")) |
|---|
| 150 | (item-type (concat "\"item_type\":\"" item_type-topicmap "\",")) |
|---|
| 151 | (tm-reifier |
|---|
| 152 | (concat "\"reifier\":" |
|---|
| 153 | (if tm |
|---|
| 154 | (export-reifier-to-jtm tm :prefixes prefixes |
|---|
| 155 | :revision revision) |
|---|
| 156 | "null")))) |
|---|
| 157 | (concat "{" version prefix-value iis topics assocs item-type tm-reifier |
|---|
| 158 | "}"))))) |
|---|
| 159 | |
|---|
| 160 | |
|---|
| 161 | |
|---|
| 162 | (defun export-as-jtm (jtm-path &key tm-id (revision (get-revision)) |
|---|
| 163 | (jtm-format :1.1)) |
|---|
| 164 | "Exports a topic map or all stored constructs as JTM file by calling |
|---|
| 165 | export-as-jtm-string." |
|---|
| 166 | (declare (type (or Null String) tm-id) |
|---|
| 167 | (type (or String Pathname) jtm-path) |
|---|
| 168 | (Symbol jtm-format) |
|---|
| 169 | (Integer revision)) |
|---|
| 170 | (with-open-file (stream jtm-path :direction :output) |
|---|
| 171 | (format stream (export-as-jtm-string :tm-id tm-id :revision revision |
|---|
| 172 | :jtm-format jtm-format)))) |
|---|
| 173 | |
|---|
| 174 | |
|---|
| 175 | (defun export-prefix-list-to-jtm (prefix-list) |
|---|
| 176 | "Returns a json object that represent an object with namespaces and their |
|---|
| 177 | prefix qualifiers." |
|---|
| 178 | (declare (List prefix-list)) |
|---|
| 179 | (if prefix-list |
|---|
| 180 | (let ((result "{")) |
|---|
| 181 | (loop for item in prefix-list |
|---|
| 182 | do (push-string |
|---|
| 183 | (concat "\"" (getf item :pref) "\":" |
|---|
| 184 | (json:encode-json-to-string (getf item :value)) ",") |
|---|
| 185 | result)) |
|---|
| 186 | (concat (subseq result 0 (1- (length result))) "}")) |
|---|
| 187 | "null")) |
|---|
| 188 | |
|---|
| 189 | |
|---|
| 190 | (defun create-prefix-list-for-tm (topics associations topic-map &key |
|---|
| 191 | (revision *TM-REVISION*)) |
|---|
| 192 | "Returns a list of the following structure: ((:pref 'pref_1' |
|---|
| 193 | :value 'uri-pref') (...))." |
|---|
| 194 | (declare (List topics associations) |
|---|
| 195 | (type (or Null TopicMapC) topic-map) |
|---|
| 196 | (Integer revision)) |
|---|
| 197 | (let ((identifiers |
|---|
| 198 | (append (loop for topic in topics |
|---|
| 199 | append |
|---|
| 200 | (append |
|---|
| 201 | (get-all-identifiers-of-construct topic :revision revision) |
|---|
| 202 | (loop for name in (names topic :revision revision) |
|---|
| 203 | append (append |
|---|
| 204 | (item-identifiers name :revision revision) |
|---|
| 205 | (loop for variant in |
|---|
| 206 | (variants name :revision revision) |
|---|
| 207 | append (append |
|---|
| 208 | (item-identifiers |
|---|
| 209 | variant :revision revision))))) |
|---|
| 210 | (loop for occ in (occurrences topic :revision revision) |
|---|
| 211 | append (append |
|---|
| 212 | (item-identifiers occ :revision revision))))) |
|---|
| 213 | (loop for assoc in associations |
|---|
| 214 | append (append |
|---|
| 215 | (item-identifiers assoc :revision revision) |
|---|
| 216 | (loop for role in (roles assoc :revision revision) |
|---|
| 217 | append (item-identifiers role :revision revision)))) |
|---|
| 218 | (when topic-map |
|---|
| 219 | (item-identifiers topic-map :revision revision))))) |
|---|
| 220 | (create-prefix-list-of-identifiers identifiers))) |
|---|
| 221 | |
|---|
| 222 | |
|---|
| 223 | (defun create-prefix-list-of-identifiers (identifiers) |
|---|
| 224 | "Returns a list of the following structure: ((:pref 'pref_1' |
|---|
| 225 | :value 'uri-pref') (...)) the list identifiers can own items of |
|---|
| 226 | the type IdentifierC and of the form (list :pref 'pref' :value 'value')." |
|---|
| 227 | (declare (List identifiers)) |
|---|
| 228 | (let ((prefixes |
|---|
| 229 | (remove-duplicates |
|---|
| 230 | (remove-null (map 'list #'(lambda(id) |
|---|
| 231 | (if (typep id 'IdentifierC) |
|---|
| 232 | (prefix-of-uri (uri id)) |
|---|
| 233 | (getf id :value))) |
|---|
| 234 | identifiers)) :test #'string=))) |
|---|
| 235 | (let ((result |
|---|
| 236 | (append |
|---|
| 237 | (loop for idx to (1- (length prefixes)) |
|---|
| 238 | collect (list :pref (concat "pref_" (write-to-string (1+ idx))) |
|---|
| 239 | :value (elt prefixes idx))) |
|---|
| 240 | (list (list :pref "xsd" :value *xsd-ns*))))) |
|---|
| 241 | (sort result #'(lambda(x y) |
|---|
| 242 | (> (length (getf x :value)) (length (getf y :value)))))))) |
|---|
| 243 | |
|---|
| 244 | |
|---|
| 245 | |
|---|
| 246 | (defmethod create-prefix-list-for-construct ((construct FragmentC) &key |
|---|
| 247 | (revision *TM-REVISION*)) |
|---|
| 248 | (declare (Integer revision)) |
|---|
| 249 | (create-prefix-list-for-tm (append (list (topic construct)) |
|---|
| 250 | (referenced-topics construct)) |
|---|
| 251 | (associations construct) nil :revision revision)) |
|---|
| 252 | |
|---|
| 253 | |
|---|
| 254 | (defmethod create-prefix-list-for-construct ((construct VariantC) &key |
|---|
| 255 | (revision *TM-REVISION*)) |
|---|
| 256 | (declare (Integer revision)) |
|---|
| 257 | (let ((identifiers |
|---|
| 258 | (append |
|---|
| 259 | (loop for scope in (themes construct :revision revision) |
|---|
| 260 | append (get-all-identifiers-of-construct scope :revision revision)) |
|---|
| 261 | (when (parent construct :revision revision) |
|---|
| 262 | (get-all-identifiers-of-construct |
|---|
| 263 | (parent construct :revision revision) :revision revision)) |
|---|
| 264 | (when (reifier construct :revision revision) |
|---|
| 265 | (get-all-identifiers-of-construct |
|---|
| 266 | (reifier construct :revision revision)))))) |
|---|
| 267 | (create-prefix-list-of-identifiers identifiers))) |
|---|
| 268 | |
|---|
| 269 | |
|---|
| 270 | (defmethod create-prefix-list-for-construct ((construct NameC) &key |
|---|
| 271 | (revision *TM-REVISION*)) |
|---|
| 272 | (declare (Integer revision)) |
|---|
| 273 | (let ((identifiers |
|---|
| 274 | (append |
|---|
| 275 | (loop for scope in (themes construct :revision revision) |
|---|
| 276 | append (get-all-identifiers-of-construct scope :revision revision)) |
|---|
| 277 | (when (parent construct :revision revision) |
|---|
| 278 | (get-all-identifiers-of-construct |
|---|
| 279 | (parent construct :revision revision) :revision revision)) |
|---|
| 280 | (loop for var in (variants construct :revision revision) |
|---|
| 281 | append (create-prefix-list-for-construct var :revision revision)) |
|---|
| 282 | (when (reifier construct :revision revision) |
|---|
| 283 | (get-all-identifiers-of-construct |
|---|
| 284 | (reifier construct :revision revision))) |
|---|
| 285 | (when (instance-of construct :revision revision) |
|---|
| 286 | (get-all-identifiers-of-construct |
|---|
| 287 | (instance-of construct :revision revision)))))) |
|---|
| 288 | (create-prefix-list-of-identifiers identifiers))) |
|---|
| 289 | |
|---|
| 290 | |
|---|
| 291 | (defmethod create-prefix-list-for-construct ((construct OccurrenceC) &key |
|---|
| 292 | (revision *TM-REVISION*)) |
|---|
| 293 | (declare (Integer revision)) |
|---|
| 294 | (let ((identifiers |
|---|
| 295 | (append |
|---|
| 296 | (loop for scope in (themes construct :revision revision) |
|---|
| 297 | append (get-all-identifiers-of-construct scope :revision revision)) |
|---|
| 298 | (when (parent construct :revision revision) |
|---|
| 299 | (get-all-identifiers-of-construct |
|---|
| 300 | (parent construct :revision revision) :revision revision)) |
|---|
| 301 | (when (reifier construct :revision revision) |
|---|
| 302 | (get-all-identifiers-of-construct |
|---|
| 303 | (reifier construct :revision revision))) |
|---|
| 304 | (when (instance-of construct :revision revision) |
|---|
| 305 | (get-all-identifiers-of-construct |
|---|
| 306 | (instance-of construct :revision revision)))))) |
|---|
| 307 | (create-prefix-list-of-identifiers identifiers))) |
|---|
| 308 | |
|---|
| 309 | |
|---|
| 310 | (defmethod create-prefix-list-for-construct ((construct RoleC) &key |
|---|
| 311 | (revision *TM-REVISION*)) |
|---|
| 312 | (declare (Integer revision)) |
|---|
| 313 | (let ((identifiers |
|---|
| 314 | (append |
|---|
| 315 | (when (parent construct :revision revision) |
|---|
| 316 | (get-all-identifiers-of-construct |
|---|
| 317 | (parent construct :revision revision) :revision revision)) |
|---|
| 318 | (when (reifier construct :revision revision) |
|---|
| 319 | (get-all-identifiers-of-construct |
|---|
| 320 | (reifier construct :revision revision))) |
|---|
| 321 | (when (player construct :revision revision) |
|---|
| 322 | (get-all-identifiers-of-construct |
|---|
| 323 | (player construct :revision revision))) |
|---|
| 324 | (when (instance-of construct :revision revision) |
|---|
| 325 | (get-all-identifiers-of-construct |
|---|
| 326 | (instance-of construct :revision revision)))))) |
|---|
| 327 | (create-prefix-list-of-identifiers identifiers))) |
|---|
| 328 | |
|---|
| 329 | |
|---|
| 330 | (defmethod create-prefix-list-for-construct ((construct AssociationC) &key |
|---|
| 331 | (revision *TM-REVISION*)) |
|---|
| 332 | (declare (Integer revision)) |
|---|
| 333 | (let ((identifiers |
|---|
| 334 | (append |
|---|
| 335 | (loop for tm in (in-topicmaps construct :revision revision) |
|---|
| 336 | append (get-all-identifiers-of-construct tm :revision revision)) |
|---|
| 337 | (when (reifier construct :revision revision) |
|---|
| 338 | (get-all-identifiers-of-construct |
|---|
| 339 | (reifier construct :revision revision))) |
|---|
| 340 | (when (instance-of construct :revision revision) |
|---|
| 341 | (get-all-identifiers-of-construct |
|---|
| 342 | (instance-of construct :revision revision))) |
|---|
| 343 | (loop for scope in (themes construct :revision revision) |
|---|
| 344 | append (get-all-identifiers-of-construct construct |
|---|
| 345 | :revision revision)) |
|---|
| 346 | (loop for role in (roles construct :revision revision) |
|---|
| 347 | append (create-prefix-list-for-construct role :revision revision))))) |
|---|
| 348 | (create-prefix-list-of-identifiers identifiers))) |
|---|
| 349 | |
|---|
| 350 | |
|---|
| 351 | (defmethod create-prefix-list-for-construct ((construct TopicC) &key |
|---|
| 352 | (revision *TM-REVISION*)) |
|---|
| 353 | (declare (Integer revision)) |
|---|
| 354 | (let ((identifiers |
|---|
| 355 | (append |
|---|
| 356 | (get-all-identifiers-of-construct construct :revision revision) |
|---|
| 357 | (loop for occ in (occurrences construct :revision revision) |
|---|
| 358 | append (create-prefix-list-for-construct occ :revision revision)) |
|---|
| 359 | (loop for name in (names construct :revision revision) |
|---|
| 360 | append (create-prefix-list-for-construct name :revision revision)) |
|---|
| 361 | (loop for top in (list-instanceof construct :revision revision) |
|---|
| 362 | append (get-all-identifiers-of-construct top :revision revision))))) |
|---|
| 363 | (create-prefix-list-of-identifiers identifiers))) |
|---|
