[isidorus-cvs] r325 - in trunk: docs playground src src/ajax/javascripts src/json src/model src/rest_interface src/unit_tests src/xml/rdf src/xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Sun Oct 10 09:41:19 UTC 2010
Author: lgiessmann
Date: Sun Oct 10 05:41:19 2010
New Revision: 325
Log:
merged the branch "new-datamodel" with "trunk" -> resolved all conflicts, except -> the remove-handler of the ui isn't supported by the backend yet
Added:
trunk/docs/isidorus_data_model.pdf
- copied unchanged from r324, /branches/new-datamodel/docs/isidorus_data_model.pdf
trunk/docs/isidorus_data_model.vsd
- copied unchanged from r324, /branches/new-datamodel/docs/isidorus_data_model.vsd
trunk/playground/
- copied from r324, /branches/new-datamodel/playground/
trunk/src/unit_tests/datamodel_test.lisp
- copied, changed from r324, /branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Removed:
trunk/docs/isidorus_classes.pdf
Modified:
trunk/docs/TODOs.txt
trunk/docs/install_isidorus.txt
trunk/src/ajax/javascripts/constants.js
trunk/src/isidorus.asd
trunk/src/json/json_exporter.lisp
trunk/src/json/json_importer.lisp
trunk/src/json/json_tmcl.lisp
trunk/src/json/json_tmcl_constants.lisp
trunk/src/json/json_tmcl_validation.lisp
trunk/src/model/changes.lisp
trunk/src/model/datamodel.lisp
trunk/src/model/exceptions.lisp
trunk/src/rest_interface/read.lisp
trunk/src/rest_interface/rest-interface.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
trunk/src/unit_tests/atom_test.lisp
trunk/src/unit_tests/exporter_xtm1.0_test.lisp
trunk/src/unit_tests/exporter_xtm2.0_test.lisp
trunk/src/unit_tests/fixtures.lisp
trunk/src/unit_tests/importer_test.lisp
trunk/src/unit_tests/json_test.lisp
trunk/src/unit_tests/rdf_exporter_test.lisp
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/unit_tests/reification_test.lisp
trunk/src/unit_tests/versions_test.lisp
trunk/src/xml/rdf/exporter.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/map_to_tm.lisp
trunk/src/xml/xtm/exporter.lisp
trunk/src/xml/xtm/exporter_xtm1.0.lisp
trunk/src/xml/xtm/exporter_xtm2.0.lisp
trunk/src/xml/xtm/importer.lisp
trunk/src/xml/xtm/importer_xtm1.0.lisp
trunk/src/xml/xtm/importer_xtm2.0.lisp
trunk/src/xml/xtm/setup.lisp
Modified: trunk/docs/TODOs.txt
==============================================================================
--- trunk/docs/TODOs.txt (original)
+++ trunk/docs/TODOs.txt Sun Oct 10 05:41:19 2010
@@ -18,14 +18,11 @@
for the concrete name of the import and another one for the
logical name of the TM
-* reifier: the one missing link to 100% import compatibility...
-
* admin interface for the
* configuration of the sytem: import and export of feeds
etc. incl. consolidation of the present feed configuration
- * creation and display of topics and associations
* TMCL: implement a constraint language --- but the one under ISO
FCD ballot, see http://www.itscj.ipsj.or.jp/sc34/open/1053.pdf or
Modified: trunk/docs/install_isidorus.txt
==============================================================================
--- trunk/docs/install_isidorus.txt (original)
+++ trunk/docs/install_isidorus.txt Sun Oct 10 05:41:19 2010
@@ -2,107 +2,7 @@
Installing Isidorus
=============================================
-Dependencies
-================
-
- * Berkeley DB 4.5 or 4.6 including its development files
-
- * sbcl (1.0.17 or newer)
-
-and the following Lisp packages:
-
-Elephant
-----------------
-
-Install the persistence framework elephant in its unstable version
-
-darcs get http://www.common-lisp.net/project/elephant/darcs/elephant-unstable/
-
-Also install all of its dependencies as described in elephant_install.txt. In particular these are:
- * (require 'asdf-install)
- * (asdf-install:install 'CL-BASE64)
- * (asdf-install:install 'uffi)
-
-For uffi you need the libc development files (libc6-dev linux-libc-dev
-zlib1g-dev under Linux). Under Ubuntu both packages exist also as
-Debian packages. Cf. also http://uffi.b9.com/
-
-Configure elephant for your platform in my-config.sexp and link its
-asd-files to the system-wide install
-
-
-cxml
--------
-
-CL-USER> (asdf:operate 'asdf:load-op 'asdf-install)
-CL-USER> (asdf-install:install 'cxml)
-
-uuid
---------
-
-Download the ironclad library from
-http://www.method-combination.net/lisp/files/ironclad.tar.gz and link the asd-file to
-the sbcl system path. Ironclad is a prerequisite for the UUID library
-
-Download the UUID library from http://dardoria.net/software/uuid.tar.gz
-and link the asd-file to the sbcl system path
-
-fiveam (unittests)
--------------------
-
-CL-USER> (asdf-install:install 'fiveam)
-
-Under Ubuntu Linux, fiveam exists also as a Debian package.
-
-Installing pathnames
----------------------
-
-Pathnames is part of Seibel's libraries (http://www.gigamonkeys.com/book/) and
-included with isidorus under src/external. Link the asd-file to the sbcl system path.
-
-Hunchentoot
---------------
-
-Hunchentoot (http://www.weitz.de/hunchentoot/) is also
-asdf-install'able:
-
-(asdf-install:install 'hunchentoot)
-
-It requires a significant number of auxiliary libraries and the
-installation hung once during the process. I installed a few libraries
-manually then:
-
- * CL-PPCRE
- * CL-FAD
-
-On restart, the installation completed correctly
-
-Test:
- (asdf:oos 'asdf:load-op :hunchentoot-test)
- (hunchentoot:start-server :port 4242)
-
-cl-json
----------
-
-Download the parenscript library:
-
-darcs get http://common-lisp.net/project/ucw/repos/parenscript
-
-Link the asd-file to the sbcl system path.
-
-Download the cl-json library:
-
-darcs get http://common-lisp.net/project/cl-json/darcs/cl-json
-
-Link the asd-file to the sbcl system path.
-
-
-Drakma
----------
-
-Drakma (http://weitz.de/drakma) also follows the same pattern:
-
-(asdf-install:install 'drakma)
+http://trac.common-lisp.net/isidorus/wiki/InstallIsidorus
Starting Isidorus
Modified: trunk/src/ajax/javascripts/constants.js
==============================================================================
--- trunk/src/ajax/javascripts/constants.js (original)
+++ trunk/src/ajax/javascripts/constants.js Sun Oct 10 05:41:19 2010
@@ -28,6 +28,7 @@
+
// --- A kind of enum for the the different pages with an attribute and a value
var PAGES = {"home" : "home", "search" : "searchTopic", "edit" : "editTopic", "create" : "createTopic", "current" : ""};
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Sun Oct 10 05:41:19 2010
@@ -150,6 +150,8 @@
:depends-on ("fixtures"))
(:file "rdf_exporter_test"
:depends-on ("fixtures"))
+ (:file "datamodel_test"
+ :depends-on ("fixtures"))
(:file "reification_test"
:depends-on ("fixtures" "unittests-constants")))
:depends-on ("atom"
@@ -204,7 +206,6 @@
:uuid
:cl-json))
-
(setf sb-impl::*default-external-format* *old-external-format*)
;;
Modified: trunk/src/json/json_exporter.lisp
==============================================================================
--- trunk/src/json/json_exporter.lisp (original)
+++ trunk/src/json/json_exporter.lisp Sun Oct 10 05:41:19 2010
@@ -8,7 +8,7 @@
(defpackage :json-exporter
- (:use :cl :json :datamodel :json-tmcl-constants)
+ (:use :cl :json :datamodel)
(:export :to-json-string
:get-all-topic-psis
:to-json-string-summary
@@ -22,17 +22,22 @@
;; =============================================================================
;; --- main json data model ----------------------------------------------------
;; =============================================================================
-(defgeneric to-json-string (instance &key xtm-id)
+(defgeneric to-json-string (instance &key xtm-id revision)
(:documentation "converts the Topic Map construct instance to a json string"))
-(defun identifiers-to-json-string (parent-construct &key (what 'd:psis))
+(defun identifiers-to-json-string (parent-construct &key (what 'd:psis)
+ (revision *TM-REVISION*))
"returns the identifiers of a TopicMapConstructC as a json list"
+ (declare (TopicMapConstructC parent-construct)
+ (symbol what)
+ (type (or integer null) revision))
(when (and parent-construct
- (or (eql what 'psis) (eql what 'item-identifiers) (eql what 'locators)))
+ (or (eql what 'psis)
+ (eql what 'item-identifiers)
+ (eql what 'locators)))
(let ((items
- (map 'list #'uri (funcall what parent-construct))))
- (declare (TopicMapConstructC parent-construct)) ;must be a topic for psis and locators
+ (map 'list #'uri (funcall what parent-construct :revision revision))))
(json:encode-json-to-string items))))
@@ -40,52 +45,67 @@
"returns a resourceRef and resourceData json object"
;(declare (string value datatype))
(if (string= datatype "http://www.w3.org/2001/XMLSchema#anyURI")
- (concatenate 'string "\"resourceRef\":"
- (let ((inner-value
- (let ((ref-topic (when (and (> (length value) 0)
- (eql (elt value 0) #\#))
- (get-item-by-id (subseq value 1) :xtm-id xtm-id))))
- (if ref-topic
- (concatenate 'string "#" (topicid ref-topic))
- value))))
- (json:encode-json-to-string inner-value))
- ",\"resourceData\":null")
+ (concatenate
+ 'string "\"resourceRef\":"
+ (let ((inner-value
+ (let ((ref-topic (when (and (> (length value) 0)
+ (eql (elt value 0) #\#))
+ (get-item-by-id (subseq value 1) :xtm-id xtm-id))))
+ (if ref-topic
+ (concatenate 'string "#" (topic-id ref-topic))
+ value))))
+ (json:encode-json-to-string inner-value))
+ ",\"resourceData\":null")
(concatenate 'string "\"resourceRef\":null,"
- "\"resourceData\":{\"datatype\":"
- (json:encode-json-to-string datatype)
- ",\"value\":"
- (json:encode-json-to-string value) "}")))
+ "\"resourceData\":{\"datatype\":"
+ (json:encode-json-to-string datatype)
+ ",\"value\":"
+ (json:encode-json-to-string value) "}")))
-(defun ref-topics-to-json-string (topics)
+(defun ref-topics-to-json-string (topics &key (revision *TM-REVISION*))
"returns a json string of all psi-uris of the passed topics as a list of lists"
+ (declare (list topics)
+ (type (or integer null) revision))
(if topics
(let ((psis (json:encode-json-to-string
(map 'list #'(lambda(topic)
(declare (topicC topic))
- (map 'list #'uri (psis topic)))
+ (map 'list #'uri (psis topic :revision revision)))
topics))))
(declare (list topics))
psis)
"null"))
-(defun type-to-json-string (parent-elem)
+(defun type-to-json-string (parent-elem &key (revision *TM-REVISION*))
"returns a json string of the type of the passed parent-elem"
- (declare (TypableC parent-elem))
- (concatenate 'string "\"type\":"
- (if (slot-boundp parent-elem 'instance-of)
- (json:encode-json-to-string (map 'list #'uri (psis (instance-of parent-elem))))
- "null")))
+ (declare (TypableC parent-elem)
+ (type (or integer null) revision))
+ (concatenate
+ 'string "\"type\":"
+ (if (instance-of parent-elem :revision revision)
+ (json:encode-json-to-string
+ (map 'list #'uri (psis (instance-of parent-elem :revision revision)
+ :revision revision)))
+ "null")))
-(defmethod to-json-string ((instance VariantC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance VariantC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms a VariantC object to a json string"
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
(let ((itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string instance :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string instance :what 'item-identifiers
+ :revision revision)))
(scope
- (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance))))
+ (concatenate
+ 'string "\"scopes\":" (ref-topics-to-json-string
+ (themes instance :revision revision)
+ :revision revision)))
(resourceX
(let ((value
(when (slot-boundp instance 'charvalue)
@@ -97,42 +117,65 @@
(concatenate 'string "{" itemIdentity "," scope "," resourceX "}")))
-(defmethod to-json-string ((instance NameC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance NameC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms a NameC object to a json string"
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
(let ((itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string instance :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string instance :what 'item-identifiers
+ :revision revision)))
(type
- (type-to-json-string instance))
+ (type-to-json-string instance :revision revision))
(scope
- (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance))))
+ (concatenate
+ 'string "\"scopes\":"
+ (ref-topics-to-json-string (themes instance :revision revision)
+ :revision revision)))
(value
(concatenate 'string "\"value\":"
(if (slot-boundp instance 'charvalue)
(json:encode-json-to-string (charvalue instance))
"null")))
(variant
- (if (variants instance)
- (concatenate 'string "\"variants\":"
- (let ((j-variants "["))
- (loop for variant in (variants instance)
- do (setf j-variants
- (concatenate 'string j-variants
- (json-exporter::to-json-string variant :xtm-id xtm-id) ",")))
- (concatenate 'string (subseq j-variants 0 (- (length j-variants) 1)) "]")))
+ (if (variants instance :revision revision)
+ (concatenate
+ 'string "\"variants\":"
+ (let ((j-variants "["))
+ (loop for variant in (variants instance :revision revision)
+ do (setf j-variants
+ (concatenate
+ 'string j-variants
+ (json-exporter::to-json-string variant :xtm-id xtm-id
+ :revision revision)
+ ",")))
+ (concatenate
+ 'string (subseq j-variants 0
+ (- (length j-variants) 1)) "]")))
(concatenate 'string "\"variants\":null"))))
- (concatenate 'string "{" itemIdentity "," type "," scope "," value "," variant "}")))
+ (concatenate 'string "{" itemIdentity "," type "," scope "," value
+ "," variant "}")))
-(defmethod to-json-string ((instance OccurrenceC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance OccurrenceC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms an OccurrenceC object to a json string"
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
(let ((itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string instance :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string instance :what 'item-identifiers
+ :revision revision)))
(type
- (type-to-json-string instance))
+ (type-to-json-string instance :revision revision))
(scope
- (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance))))
+ (concatenate
+ 'string "\"scopes\":"
+ (ref-topics-to-json-string (themes instance :revision revision)
+ :revision revision)))
(resourceX
(let ((value
(when (slot-boundp instance 'charvalue)
@@ -144,223 +187,298 @@
(concatenate 'string "{" itemIdentity "," type "," scope "," resourceX "}")))
-(defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms an TopicC object to a json string"
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
(let ((id
- (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid instance))))
+ (concatenate
+ 'string "\"id\":"
+ (json:encode-json-to-string (topic-id instance revision))))
(itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string instance :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string instance :what 'item-identifiers
+ :revision revision)))
(subjectLocator
- (concatenate 'string "\"subjectLocators\":"
- (identifiers-to-json-string instance :what 'locators)))
+ (concatenate
+ 'string "\"subjectLocators\":"
+ (identifiers-to-json-string instance :what 'locators
+ :revision revision)))
(subjectIdentifier
- (concatenate 'string "\"subjectIdentifiers\":"
- (identifiers-to-json-string instance :what 'psis)))
+ (concatenate
+ 'string "\"subjectIdentifiers\":"
+ (identifiers-to-json-string instance :what 'psis
+ :revision revision)))
(instanceOf
- (concatenate 'string "\"instanceOfs\":" (ref-topics-to-json-string (list-instanceOf instance))))
+ (concatenate
+ 'string "\"instanceOfs\":"
+ (ref-topics-to-json-string (list-instanceOf instance :revision revision)
+ :revision revision)))
(name
- (concatenate 'string "\"names\":"
- (if (names instance)
- (let ((j-names "["))
- (loop for item in (names instance)
- do (setf j-names
- (concatenate 'string j-names (to-json-string item :xtm-id xtm-id) ",")))
- (concatenate 'string (subseq j-names 0 (- (length j-names) 1)) "]"))
- "null")))
+ (concatenate
+ 'string "\"names\":"
+ (if (names instance :revision revision)
+ (let ((j-names "["))
+ (loop for item in (names instance :revision revision)
+ do (setf j-names
+ (concatenate
+ 'string j-names (to-json-string item :xtm-id xtm-id
+ :revision revision)
+ ",")))
+ (concatenate 'string (subseq j-names 0 (- (length j-names) 1)) "]"))
+ "null")))
(occurrence
- (concatenate 'string "\"occurrences\":"
- (if (occurrences instance)
- (let ((j-occurrences "["))
- (loop for item in (occurrences instance)
- do (setf j-occurrences
- (concatenate 'string j-occurrences (to-json-string item :xtm-id xtm-id) ",")))
- (concatenate 'string (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]"))
- "null"))))
- (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier ","
+ (concatenate
+ 'string "\"occurrences\":"
+ (if (occurrences instance :revision revision)
+ (let ((j-occurrences "["))
+ (loop for item in (occurrences instance :revision revision)
+ do (setf j-occurrences
+ (concatenate
+ 'string j-occurrences
+ (to-json-string item :xtm-id xtm-id :revision revision)
+ ",")))
+ (concatenate
+ 'string (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]"))
+ "null"))))
+ (concatenate 'string "{" id "," itemIdentity "," subjectLocator ","
+ subjectIdentifier ","
instanceOf "," name "," occurrence "}")))
-(defun to-json-topicStub-string (topic)
+(defun to-json-topicStub-string (topic &key (revision *TM-REVISION*))
"transforms the passed TopicC object to a topic stub
string in the json format, which contains an id,
all itemIdentities, all subjectLocators and all
subjectIdentifiers"
+ (declare (type (or TopicC null) topic)
+ (type (or integer null) revision))
(when topic
(let ((id
- (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid topic))))
+ (concatenate
+ 'string "\"id\":"
+ (json:encode-json-to-string (topic-id topic revision))))
(itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string topic :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string topic :what 'item-identifiers
+ :revision revision)))
(subjectLocator
- (concatenate 'string "\"subjectLocators\":"
- (identifiers-to-json-string topic :what 'locators)))
+ (concatenate
+ 'string "\"subjectLocators\":"
+ (identifiers-to-json-string topic :what 'locators :revision revision)))
(subjectIdentifier
- (concatenate 'string "\"subjectIdentifiers\":"
- (identifiers-to-json-string topic :what 'psis))))
- (declare (TopicC topic))
+ (concatenate
+ 'string "\"subjectIdentifiers\":"
+ (identifiers-to-json-string topic :what 'psis :revision revision))))
(concatenate 'string "{" id "," itemIdentity "," subjectLocator ","
subjectIdentifier "}"))))
-(defmethod to-json-string ((instance RoleC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance RoleC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms an RoleC object to a json string"
- (declare (ignorable xtm-id))
+ (declare (ignorable xtm-id)
+ (type (or integer null) revision))
(let ((itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string instance :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string instance :what 'item-identifiers
+ :revision revision)))
(type
- (type-to-json-string instance))
+ (type-to-json-string instance :revision revision))
(topicRef
- (concatenate 'string "\"topicRef\":"
- (if (slot-boundp instance 'player)
- (json:encode-json-to-string (map 'list #'uri (psis (player instance))))
- "null"))))
+ (concatenate
+ 'string "\"topicRef\":"
+ (if (player instance :revision revision)
+ (json:encode-json-to-string
+ (map 'list #'uri (psis (player instance :revision revision)
+ :revision revision)))
+ "null"))))
(concatenate 'string "{" itemIdentity "," type "," topicRef "}")))
-(defmethod to-json-string ((instance AssociationC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance AssociationC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms an AssociationC object to a json string"
(let ((itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string instance :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string instance :what 'item-identifiers
+ :revision revision)))
(type
- (type-to-json-string instance))
+ (type-to-json-string instance :revision revision))
(scope
- (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance))))
+ (concatenate
+ 'string "\"scopes\":"
+ (ref-topics-to-json-string (themes instance :revision revision)
+ :revision revision)))
(role
- (concatenate 'string "\"roles\":"
- (if (roles instance)
- (let ((j-roles "["))
- (loop for item in (roles instance)
- do (setf j-roles
- (concatenate 'string j-roles (to-json-string item :xtm-id xtm-id) ",")))
- (concatenate 'string (subseq j-roles 0 (- (length j-roles) 1)) "]"))
- "null"))))
+ (concatenate
+ 'string "\"roles\":"
+ (if (roles instance :revision revision)
+ (let ((j-roles "["))
+ (loop for item in (roles instance :revision revision)
+ do (setf j-roles
+ (concatenate
+ 'string j-roles (to-json-string item :xtm-id xtm-id
+ :revision revision)
+ ",")))
+ (concatenate 'string (subseq j-roles 0 (- (length j-roles) 1)) "]"))
+ "null"))))
(concatenate 'string "{" itemIdentity "," type "," scope "," role "}")))
-(defmethod to-json-string ((instance TopicMapC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance TopicMapC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"returns the ItemIdentifier's uri"
- (declare (ignorable xtm-id))
- (let ((ii (item-identifiers instance)))
+ (declare (ignorable xtm-id)
+ (type (or integer null) revision))
+ (let ((ii (item-identifiers instance :revision revision)))
(when ii
(uri (first ii)))))
-(defmethod to-json-string ((instance FragmentC) &key (xtm-id d:*current-xtm*))
+(defmethod to-json-string ((instance FragmentC) &key (xtm-id d:*current-xtm*)
+ (revision *TM-REVISION*))
"transforms an FragmentC object to a json string,
which contains the main topic, all depending topicStubs
and all associations depending on the main topic"
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
(let ((main-topic
- (concatenate 'string "\"topic\":"
- (to-json-string (topic instance) :xtm-id xtm-id)))
+ (concatenate
+ 'string "\"topic\":"
+ (to-json-string (topic instance) :xtm-id xtm-id :revision revision)))
(topicStubs
- (concatenate 'string "\"topicStubs\":"
- (if (referenced-topics instance)
- (let ((j-topicStubs "["))
- (loop for item in (referenced-topics instance)
- do (setf j-topicStubs (concatenate 'string j-topicStubs
- (to-json-topicStub-string item) ",")))
- (concatenate 'string (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]"))
- "null")))
+ (concatenate
+ 'string "\"topicStubs\":"
+ (if (referenced-topics instance)
+ (let ((j-topicStubs "["))
+ (loop for item in (referenced-topics instance)
+ do (setf j-topicStubs
+ (concatenate
+ 'string j-topicStubs
+ (to-json-topicStub-string item :revision revision)
+ ",")))
+ (concatenate
+ 'string (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]"))
+ "null")))
(associations
- (concatenate 'string "\"associations\":"
- (if (associations instance)
- (let ((j-associations "["))
- (loop for item in (associations instance)
- do (setf j-associations
- (concatenate 'string j-associations
- (to-json-string item :xtm-id xtm-id) ",")))
- (concatenate 'string (subseq j-associations 0 (- (length j-associations) 1)) "]"))
- "null")))
+ (concatenate
+ 'string "\"associations\":"
+ (if (associations instance)
+ (let ((j-associations "["))
+ (loop for item in (associations instance)
+ do (setf j-associations
+ (concatenate 'string j-associations
+ (to-json-string item :xtm-id xtm-id
+ :revision revision) ",")))
+ (concatenate 'string (subseq j-associations 0
+ (- (length j-associations) 1)) "]"))
+ "null")))
(tm-ids
- (concatenate 'string "\"tmIds\":"
- (if (in-topicmaps (topic instance))
- (let ((j-tm-ids "["))
- (loop for item in (in-topicmaps (topic instance))
- ;do (setf j-tm-ids (concatenate 'string j-tm-ids "\""
- ; (d:uri (first (d:item-identifiers item))) "\",")))
- do (setf j-tm-ids (concatenate 'string j-tm-ids
- (json:encode-json-to-string (d:uri (first (d:item-identifiers item)))) ",")))
- (concatenate 'string (subseq j-tm-ids 0 (- (length j-tm-ids) 1)) "]"))
- "null"))))
- (concatenate 'string "{" main-topic "," topicStubs "," associations "," tm-ids "}")))
+ (concatenate
+ 'string "\"tmIds\":"
+ (if (in-topicmaps (topic instance))
+ (let ((j-tm-ids "["))
+ (loop for item in (in-topicmaps (topic instance))
+ do (setf j-tm-ids
+ (concatenate
+ 'string j-tm-ids
+ (json:encode-json-to-string
+ (d:uri (first (d:item-identifiers item
+ :revision revision))))
+ ",")))
+ (concatenate 'string (subseq j-tm-ids 0 (- (length j-tm-ids) 1)) "]"))
+ "null"))))
+ (concatenate 'string "{" main-topic "," topicStubs "," associations
+ "," tm-ids "}")))
;; =============================================================================
;; --- json data summeries -----------------------------------------------------
;; =============================================================================
-(defun get-all-topic-psis()
+(defun get-all-topic-psis(&key (revision *TM-REVISION*))
"returns all topic psis as a json list of the form
[[topic-1-psi-1, topic-1-psi-2],[topic-2-psi-1, topic-2-psi-2],...]"
+ (declare (type (or integer null) revision))
(encode-json-to-string
- (remove-if #'null (map 'list #'(lambda(psi-list)
- (when psi-list
- (map 'list #'uri psi-list)))
- (map 'list
- #'d:psis
- (clean-topics
- (elephant:get-instances-by-class 'TopicC)))))))
+ (remove-if #'null
+ (map 'list
+ #'(lambda(psi-list)
+ (when psi-list
+ (map 'list #'uri psi-list)))
+ (map 'list #'psis (get-all-topics revision))))))
-(defun to-json-string-summary (topic)
+(defun to-json-string-summary (topic &key (revision *TM-REVISION*))
"creates a json string of called topic element. the following elements are within this
summary:
*topic id
*all identifiers
*names (only the real name value)
*occurrences (jonly the resourceRef and resourceData elements)"
- (declare (TopicC topic))
+ (declare (TopicC topic)
+ (type (or integer null) revision))
(let ((id
- (concatenate 'string "\"id\":\"" (topicid topic) "\""))
+ (concatenate 'string "\"id\":\"" (topic-id topic revision) "\""))
(itemIdentity
- (concatenate 'string "\"itemIdentities\":"
- (identifiers-to-json-string topic :what 'item-identifiers)))
+ (concatenate
+ 'string "\"itemIdentities\":"
+ (identifiers-to-json-string topic :what 'item-identifiers
+ :revision revision)))
(subjectLocator
- (concatenate 'string "\"subjectLocators\":"
- (identifiers-to-json-string topic :what 'locators)))
+ (concatenate
+ 'string "\"subjectLocators\":"
+ (identifiers-to-json-string topic :what 'locators :revision revision)))
(subjectIdentifier
- (concatenate 'string "\"subjectIdentifiers\":"
- (identifiers-to-json-string topic :what 'psis)))
+ (concatenate
+ 'string "\"subjectIdentifiers\":"
+ (identifiers-to-json-string topic :what 'psis :revision revision)))
(instanceOf
- (concatenate 'string "\"instanceOfs\":" (ref-topics-to-json-string (list-instanceOf topic))))
+ (concatenate
+ 'string "\"instanceOfs\":"
+ (ref-topics-to-json-string (list-instanceOf topic :revision revision)
+ :revision revision)))
(name
- (concatenate 'string "\"names\":"
- (if (names topic)
- (json:encode-json-to-string (loop for name in (names topic)
- when (slot-boundp name 'charvalue)
- collect (charvalue name)))
- "null")))
+ (concatenate
+ 'string "\"names\":"
+ (if (names topic :revision revision)
+ (json:encode-json-to-string
+ (loop for name in (names topic :revision revision)
+ when (slot-boundp name 'charvalue)
+ collect (charvalue name)))
+ "null")))
(occurrence
- (concatenate 'string "\"occurrences\":"
- (if (occurrences topic)
- (json:encode-json-to-string (loop for occurrence in (occurrences topic)
- when (slot-boundp occurrence 'charvalue)
- collect (charvalue occurrence)))
- "null"))))
- (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier ","
- instanceOf "," name "," occurrence "}")))
+ (concatenate
+ 'string "\"occurrences\":"
+ (if (occurrences topic :revision revision)
+ (json:encode-json-to-string
+ (loop for occurrence in (occurrences topic :revision revision)
+ when (slot-boundp occurrence 'charvalue)
+ collect (charvalue occurrence)))
+ "null"))))
+ (concatenate 'string "{" id "," itemIdentity "," subjectLocator ","
+ subjectIdentifier "," instanceOf "," name "," occurrence "}")))
-(defun make-topic-summary (topic-list)
+(defun make-topic-summary (topic-list &key (revision *TM-REVISION*))
"creates a json list of the produced json-strings by to-json-string-summary"
+ (declare (list topic-list)
+ (type (or integer null) revision))
(if topic-list
(let ((json-string
(let ((inner-string nil))
- (concatenate 'string
- (loop for topic in topic-list
- do (setf inner-string (concatenate 'string inner-string (to-json-string-summary topic) ","))))
+ (concatenate
+ 'string
+ (loop for topic in topic-list
+ do (setf inner-string
+ (concatenate
+ 'string inner-string
+ (to-json-string-summary topic :revision revision) ","))))
(subseq inner-string 0 (- (length inner-string) 1)))))
(concatenate 'string "[" json-string "]"))
- "null"))
-
-
-(defun clean-topics(isas-or-akos)
- (remove-if
- #'null
- (map 'list
- #'(lambda(top)
- (when (d:find-item-by-revision top 0)
- top))
- isas-or-akos)))
\ No newline at end of file
+ "null"))
\ No newline at end of file
Modified: trunk/src/json/json_importer.lisp
==============================================================================
--- trunk/src/json/json_importer.lisp (original)
+++ trunk/src/json/json_importer.lisp Sun Oct 10 05:41:19 2010
@@ -23,32 +23,38 @@
(defun json-to-elem(json-string &key (xtm-id *json-xtm*))
"creates all objects (topics, topic stubs, associations)
of the passed json-decoded-list (=fragment)"
+ (declare (type (or string null) json-string xtm-id))
(when json-string
(let ((fragment-values
(get-fragment-values-from-json-list
(json:decode-json-from-string json-string))))
- (declare (string json-string))
(let ((topic-values (getf fragment-values :topic))
(topicStubs-values (getf fragment-values :topicStubs))
(associations-values (getf fragment-values :associations))
- (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment
+ (rev (get-revision)) ; creates a new revision, equal for all elements of the passed fragment
+ (tm-ids (getf fragment-values :tm-ids)))
+ (unless tm-ids
+ (error "From json-to-elem(): tm-ids must be set"))
(let ((psi-of-topic
(let ((psi-uris (getf topic-values :subjectIdentifiers)))
(when psi-uris
(first psi-uris)))))
(elephant:ensure-transaction (:txn-nosync nil)
- (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids)))
- (loop for topicStub-values in topicStubs-values
- do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id))
+ (xml-importer:with-tm (rev xtm-id (first tm-ids))
+ (loop for topicStub-values in
+ (append topicStubs-values (list topic-values))
+ do (json-to-stub topicStub-values rev :tm xml-importer::tm
+ :xtm-id xtm-id))
(json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id)
(loop for association-values in associations-values
- do (json-to-association association-values rev :tm xml-importer::tm)))
- (when psi-of-topic
- (create-latest-fragment-of-topic psi-of-topic))))))))
+ do (json-to-association association-values rev
+ :tm xml-importer::tm))))
+ (when psi-of-topic
+ (create-latest-fragment-of-topic psi-of-topic)))))))
(defun json-to-association (json-decoded-list start-revision
- &key tm )
+ &key tm)
"creates an association element of the passed json-decoded-list"
(elephant:ensure-transaction (:txn-nosync t)
(let
@@ -57,9 +63,9 @@
(make-identifier 'ItemIdentifierC uri start-revision))
(getf json-decoded-list :itemIdentities)))
(instance-of
- (psis-to-topic (getf json-decoded-list :type)))
+ (psis-to-topic (getf json-decoded-list :type) :revision start-revision))
(themes
- (json-to-scope (getf json-decoded-list :scopes)))
+ (json-to-scope (getf json-decoded-list :scopes) start-revision))
(roles
(map 'list #'(lambda(role-values)
(json-to-role role-values start-revision))
@@ -67,14 +73,14 @@
(declare (list json-decoded-list))
(declare (integer start-revision))
(declare (TopicMapC tm))
- (setf roles (xml-importer::set-standard-role-types roles))
- (add-to-topicmap tm
- (make-construct 'AssociationC
- :start-revision start-revision
- :item-identifiers item-identifiers
- :instance-of instance-of
- :themes themes
- :roles roles)))))
+ (setf roles (xml-importer::set-standard-role-types roles start-revision))
+ (add-to-tm tm
+ (make-construct 'AssociationC
+ :start-revision start-revision
+ :item-identifiers item-identifiers
+ :instance-of instance-of
+ :themes themes
+ :roles roles)))))
(defun json-to-role (json-decoded-list start-revision)
@@ -87,14 +93,19 @@
(make-identifier 'ItemIdentifierC uri start-revision))
(getf json-decoded-list :itemIdentities)))
(instance-of
- (psis-to-topic (getf json-decoded-list :type)))
+ (psis-to-topic (getf json-decoded-list :type) :revision start-revision))
(player
- (psis-to-topic (getf json-decoded-list :topicRef))))
+ (psis-to-topic (getf json-decoded-list :topicRef)
+ :revision start-revision)))
(declare (list json-decoded-list))
(declare (integer start-revision))
(unless player
- (error "Role in association with topicref ~a not complete" (getf json-decoded-list :topicRef)))
- (list :instance-of instance-of :player player :item-identifiers item-identifiers)))))
+ (error "Role in association with topicref ~a not complete"
+ (getf json-decoded-list :topicRef)))
+ (list :instance-of instance-of
+ :player player
+ :item-identifiers item-identifiers
+ :start-revision start-revision)))))
(defun json-merge-topic (json-decoded-list start-revision
@@ -103,13 +114,11 @@
elements from the json-decoded-list"
(when json-decoded-list
(elephant:ensure-transaction (:txn-nosync t)
-; (let ((top
-; (d:get-item-by-id
-; (getf json-decoded-list :id)
-; :revision start-revision
-; :xtm-id xtm-id)))
- (let ((top (json-to-stub json-decoded-list start-revision
- :tm tm :xtm-id xtm-id)))
+ (let ((top
+ (d:get-item-by-id
+ (getf json-decoded-list :id)
+ :revision start-revision
+ :xtm-id xtm-id)))
(declare (list json-decoded-list))
(declare (integer start-revision))
(declare (TopicMapC tm))
@@ -118,14 +127,19 @@
(let ((instanceof-topics
(remove-duplicates
(map 'list
- #'psis-to-topic
+ #'(lambda(psis)
+ (psis-to-topic psis :revision start-revision))
(getf json-decoded-list :instanceOfs)))))
+
(loop for name-values in (getf json-decoded-list :names)
do (json-to-name name-values top start-revision))
+
(loop for occurrence-values in (getf json-decoded-list :occurrences)
do (json-to-occurrence occurrence-values top start-revision))
(dolist (instanceOf-top instanceof-topics)
- (json-create-instanceOf-association instanceOf-top top start-revision :tm tm))
+ (json-create-instanceOf-association instanceOf-top top start-revision
+ :tm tm))
+ ;(add-to-tm tm top) ; will be done in "json-to-stub"
top)))))
@@ -144,7 +158,13 @@
(subject-locators
(map 'list #'(lambda(uri)
(make-identifier 'SubjectLocatorC uri start-revision))
- (getf json-decoded-list :subjectLocators))))
+ (getf json-decoded-list :subjectLocators)))
+ (topic-ids
+ (when (getf json-decoded-list :id)
+ (list
+ (make-construct 'TopicIdentificationC
+ :uri (getf json-decoded-list :id)
+ :xtm-id xtm-id)))))
;; all topic stubs has to be added top a topicmap object in this method
;; becuase the only one topic that is handled in "json-merge-topic"
;; is the main topic of the fragment
@@ -153,9 +173,8 @@
:item-identifiers item-identifiers
:locators subject-locators
:psis subject-identifiers
- :topicid (getf json-decoded-list :id)
- :xtm-id xtm-id)))
- (add-to-topicmap tm top)
+ :topic-identifiers topic-ids)))
+ (add-to-tm tm top)
top)))))
@@ -164,13 +183,13 @@
(when json-decoded-list
(let
((themes
- (json-to-scope (getf json-decoded-list :scopes)))
+ (json-to-scope (getf json-decoded-list :scopes) start-revision))
(item-identifiers
(map 'list #'(lambda(uri)
(make-identifier 'ItemIdentifierC uri start-revision))
(getf json-decoded-list :itemIdentities)))
(instance-of
- (psis-to-topic (getf json-decoded-list :type)))
+ (psis-to-topic (getf json-decoded-list :type) :revision start-revision))
(occurrence-value
(json-to-resourceX json-decoded-list)))
@@ -178,7 +197,7 @@
(error "OccurrenceC: one of resourceRef and resourceData must be set"))
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes themes
:item-identifiers item-identifiers
:instance-of instance-of
@@ -192,27 +211,30 @@
(declare (symbol classsymbol))
(declare (string uri))
(declare (integer start-revision))
- (let ((id (make-instance classsymbol
- :uri uri
- :start-revision start-revision)))
- id))
+ (make-construct classsymbol
+ :uri uri
+ :start-revision start-revision))
-(defun json-to-scope (json-decoded-list)
+(defun json-to-scope (json-decoded-list start-revision)
"Generate set of themes (= topics) from this scope element and
return that set. If the input is nil, the list of themes is empty"
(when json-decoded-list
(let ((tops
- (map 'list #'psis-to-topic json-decoded-list)))
+ (map 'list #'(lambda(psis)
+ (psis-to-topic psis :revision start-revision))
+ json-decoded-list)))
(declare (list json-decoded-list))
(unless (>= (length tops) 1)
(error "need at least one topic in a scope"))
tops)))
-(defun psis-to-topic(psis)
+(defun psis-to-topic(psis &key (revision *TM-REVISION*))
"searches for a topic of the passed psis-list describing
exactly one topic"
+ (declare (list psis)
+ (type (or integer null) revision))
(when psis
(let ((top
(let ((psi
@@ -221,9 +243,8 @@
'd:PersistentIdC 'd:uri uri)
return (elephant:get-instance-by-value
'd:PersistentIdC 'd:uri uri))))
- (format t "psi: ~a~%" psi)
(when psi
- (d:identified-construct psi)))))
+ (d:identified-construct psi :revision revision)))))
(unless top
(error (make-condition 'missing-reference-error
:message (format nil "psis-to-topic: could not resolve reference ~a" psis))))
@@ -239,23 +260,20 @@
(getf json-decoded-list :itemIdentities)))
(namevalue (getf json-decoded-list :value))
(themes
- (json-to-scope (getf json-decoded-list :scopes)))
+ (json-to-scope (getf json-decoded-list :scopes) start-revision))
(instance-of
- (psis-to-topic (getf json-decoded-list :type))))
- ;(declare (list json-decoded-list)) causes problems with sbcl 1.0.34.0.debian
- ;(declare (TopicC top))
+ (psis-to-topic (getf json-decoded-list :type) :revision start-revision)))
(unless namevalue
(error "A name must have exactly one namevalue"))
(let ((name (make-construct 'NameC
:start-revision start-revision
- :topic top
+ :parent top
:charvalue namevalue
:instance-of instance-of
:item-identifiers item-identifiers
:themes themes)))
(loop for variant in (getf json-decoded-list :variants)
do (json-to-variant variant name start-revision))
- ;(json-to-variant (getf json-decoded-list :variants) name start-revision)
name))))
@@ -267,19 +285,20 @@
(make-identifier 'ItemIdentifierC uri start-revision))
(getf json-decoded-list :itemIdentities)))
(themes
- (remove-duplicates (append (d:themes name)
- (json-to-scope (getf json-decoded-list :scopes)))))
+ (remove-duplicates
+ (append (d:themes name)
+ (json-to-scope (getf json-decoded-list :scopes)
+ start-revision))))
(variant-value
(json-to-resourceX json-decoded-list)))
(declare (list json-decoded-list))
- ;(declare (NameC name))
(make-construct 'VariantC
:start-revision start-revision
:item-identifiers item-identifiers
:themes themes
:charvalue (getf variant-value :data)
:datatype (getf variant-value :type)
- :name name))))
+ :parent name))))
(defun json-to-resourceX(json-decoded-list)
@@ -309,23 +328,19 @@
from all the others in that it is not modelled one to one, but
following the suggestion of the XTM 2.0 spec (4.9) and the
TMDM (7.2) as an association"
-
- (declare (TopicC supertype))
- (declare (TopicC player2-obj))
- (declare (TopicMapC tm))
+ (declare (TopicC supertype player2-obj)
+ (TopicMapC tm))
(let
((associationtype
- (get-item-by-psi constants:*type-instance-psi*))
+ (get-item-by-psi constants:*type-instance-psi* :revision start-revision))
(roletype1
- (get-item-by-psi constants:*type-psi*))
+ (get-item-by-psi constants:*type-psi* :revision start-revision))
(roletype2
- (get-item-by-psi constants:*instance-psi*))
+ (get-item-by-psi constants:*instance-psi* :revision start-revision))
(player1 supertype))
-
(unless (and associationtype roletype1 roletype2)
(error "Error in the creation of an instanceof association: core topics are missing"))
-
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct
'AssociationC
@@ -333,8 +348,12 @@
:themes nil
:start-revision start-revision
:instance-of associationtype
- :roles (list (list :instance-of roletype1 :player player1)
- (list :instance-of roletype2 :player player2-obj))))))
+ :roles (list (list :instance-of roletype1
+ :player player1
+ :start-revision start-revision)
+ (list :instance-of roletype2
+ :player player2-obj
+ :start-revision start-revision))))))
(defun get-fragment-values-from-json-list(json-decoded-list)
@@ -358,7 +377,7 @@
(setf tm-ids (cdr j-elem)))
(t
(error "json-importer:get-fragment-values-from-json-string:
- bad item-specifier found in json-list (~a)" (car j-elem)))))
+ bad item-specifier found in json-list"))))
(unless topic
(error "json-importer:get-fragment-values-from-json-string: the element topic must be set"))
(unless (= (length tm-ids) 1)
Modified: trunk/src/json/json_tmcl.lisp
==============================================================================
--- trunk/src/json/json_tmcl.lisp (original)
+++ trunk/src/json/json_tmcl.lisp Sun Oct 10 05:41:19 2010
@@ -11,316 +11,25 @@
;; =============================================================================
-;; --- mark-as-deleted handler -------------------------------------------------
-;; =============================================================================
-(defun mark-as-deleted-from-json (json-data)
- "Marks an object that is specified by the given JSON data as deleted."
- (declare (string json-data))
- (let ((values (json:decode-json-from-string json-data)))
- (let ((type nil)
- (topics nil)
- (associations nil)
- (parent-topic nil)
- (parent-name nil)
- (names nil)
- (variants nil)
- (occurrences nil)
- (parent-association nil)
- (roles nil)
- (rev (get-revision)))
- (loop for entry in values
- when (consp entry)
- do (let ((st (car entry))
- (nd (cdr entry)))
- (cond ((eql st :type) (setf type nd))
- ((eql st :topics) (setf topics nd))
- ((eql st :associations) (setf associations nd))
- ((eql st :parent-topic) (setf parent-topic nd))
- ((eql st :parent-name) (setf parent-name nd))
- ((eql st :names) (setf names nd))
- ((eql st :variants) (setf variants nd))
- ((eql st :occurrences) (setf occurrences nd))
- ((eql st :parent-association) (setf parent-association nd))
- ((eql st :roles) (setf roles nd)))))
- (cond ((string= type "Topic")
- (delete-topics-from-json topics rev))
- ((string= type "Association")
- (delete-associations-from-json associations rev))
- ((string= type "Occurrence")
- (delete-occurrences-from-json occurrences parent-topic rev))
- ((string= type "Name")
- (delete-names-from-json names parent-topic rev))
- ((string= type "Variant")
- (delete-variants-from-json variants parent-topic parent-name rev))
- ((string= type "Role")
- (delete-roles-from-json roles parent-association rev))
- (t
- (error "From mark-as-deleted-from-json(): the type ~a is not defined"
- type))))))
-
-
-(defun find-role-from-json (parent-association json-plist)
- (declare (AssociationC parent-association) (list json-plist))
- (let ((found-role
- (find-if
- #'(lambda(role)
- (let ((type (when (getf json-plist :type)
- (d:get-item-by-psi (first (getf json-plist :type)))))
- (player (when (getf json-plist :topicRef)
- (d:get-item-by-psi
- (first (getf json-plist :topicRef))))))
- (and (eql type (d:instance-of role))
- (eql player (d:player role)))))
- (d:roles parent-association))))
- found-role))
-
-
-(defun delete-roles-from-json (roles parent-association revision)
- (declare (list roles parent-association) (integer revision))
- (let ((err "From delete-roles-from-association(): ")
- (parent-assoc
- (find-association-from-json
- (json-importer::get-association-values-from-json-list
- parent-association))))
- (unless parent-assoc
- (error "~a~a not found" err parent-association))
- (dolist (j-role roles)
- (let ((plist (json-importer::get-role-values-from-json-list j-role)))
- (let ((role (find-role-from-json parent-assoc plist)))
- (unless role
- (error "~a~a not found" err plist))
- (format t "~a~%" role)
- (mark-as-deleted role :revision revision))))))
-
-
-(defun find-variant-from-json (parent-name json-plist)
- (declare (NameC parent-name) (list json-plist))
- (let ((err "From find-variant-from-json(): "))
- (let ((found-var
- (find-if
- #'(lambda(var)
- (let ((datatype (cond ((getf json-plist :datatype)
- (getf json-plist :datatype))
- ((getf json-plist :resourceRef)
- constants:*xml-uri*)
- ((getf json-plist :resourceData)
- (let ((val
- (getf
- (getf json-plist :resourceData)
- :datatype)))
- (if val val constants:*xml-string*)))
- (t
- constants:*xml-string*)))
- (charvalue (cond ((getf json-plist :resourceRef)
- (getf json-plist :resourceRef))
- ((getf json-plist :resourceData)
- (getf (getf json-plist :resourceData)
- :value))
- (t
- "")))
- (scopes nil))
- (loop for scope-entry in (getf json-plist :scopes)
- do (let ((top (d:get-item-by-psi (first scope-entry))))
- (unless top
- (error "~a ~a not found" err (first scope-entry)))
- (pushnew top scopes)))
- (and (not (set-exclusive-or scopes (d:themes var)))
- (string= datatype (d:datatype var))
- (string= charvalue (d:charvalue var)))))
- (d:variants parent-name :revision 0))))
- found-var)))
-
-
-(defun delete-variants-from-json (variants parent-psi parent-name revision)
- (declare (string parent-psi) (list variants parent-name))
- (let ((err "From delete-variants-from-json(): ")
- (parent-topic (d:get-item-by-psi parent-psi)))
- (unless parent-topic
- (error "~a~a not found" err parent-psi))
- (let ((v-name
- (find-name-from-json
- parent-topic
- (json-importer::get-name-values-from-json-list parent-name))))
- (unless v-name
- (error "~a~a not found" err parent-name))
- (dolist (j-variant variants)
- (let ((plist
- (json-importer::get-variant-values-from-json-list j-variant)))
- (let ((variant (find-variant-from-json v-name plist)))
- (unless variant
- (error "~a~a not found" err plist))
- (mark-as-deleted variant :revision revision)))))))
-
-
-(defun find-name-from-json(parent-topic json-plist)
- (declare (TopicC parent-topic) (list json-plist))
- (let ((err "From find-name-from-json(): "))
- (let ((found-name
- (find-if
- #'(lambda(name)
- (let ((type (when (getf json-plist :type)
- (d:get-item-by-psi (first (getf json-plist :type)))))
- (charvalue (if (getf json-plist :value)
- (getf json-plist :value)
- ""))
- (scopes nil))
- (loop for scope-entry in (getf json-plist :scopes)
- do (let ((top (d:get-item-by-psi (first scope-entry))))
- (unless top
- (error "~a ~a not found" err (first scope-entry)))
- (pushnew top scopes)))
- (and (eql type (d:instance-of name))
- (not (set-exclusive-or scopes (d:themes name)))
- (string= charvalue (d:charvalue name)))))
- (names parent-topic :revision 0))))
- found-name)))
-
-
-(defun delete-names-from-json (names parent-psi revision)
- (declare (list names) (string parent-psi) (integer revision))
- (let ((parent-topic (d:get-item-by-psi parent-psi))
- (err "From delete-names-from-json(): "))
- (unless parent-topic
- (error "~a~a not found"
- err parent-psi))
- (dolist (j-name names)
- (let ((plist (json-importer::get-name-values-from-json-list j-name)))
- (let ((name (find-name-from-json parent-topic plist)))
- (unless name
- (error "~a~a not found" err plist))
- (mark-as-deleted name :revision revision))))))
-
-
-(defun find-occurrence-from-json(parent-topic json-plist)
- (declare (TopicC parent-topic) (list json-plist))
- (let ((err "From find-occurrence-from-json(): "))
- (let ((found-occ
- (find-if
- #'(lambda(occ)
- (let ((type (when (getf json-plist :type)
- (d:get-item-by-psi (first (getf json-plist :type)))))
- (datatype (cond ((getf json-plist :datatype)
- (getf json-plist :datatype))
- ((getf json-plist :resourceRef)
- constants:*xml-uri*)
- ((getf json-plist :resourceData)
- (let ((val
- (getf
- (getf json-plist :resourceData)
- :datatype)))
- (if val val constants:*xml-string*)))
- (t
- constants:*xml-string*)))
- (charvalue (cond ((getf json-plist :resourceRef)
- (getf json-plist :resourceRef))
- ((getf json-plist :resourceData)
- (getf (getf json-plist :resourceData)
- :value))
- (t
- "")))
- (scopes nil))
- (loop for scope-entry in (getf json-plist :scopes)
- do (let ((top (d:get-item-by-psi (first scope-entry))))
- (unless top
- (error "~a ~a not found" err (first scope-entry)))
- (pushnew top scopes)))
- (and (eql type (d:instance-of occ))
- (not (set-exclusive-or scopes (d:themes occ)))
- (string= datatype (d:datatype occ))
- (string= charvalue (d:charvalue occ)))))
- (occurrences parent-topic :revision 0))))
- found-occ)))
-
-
-(defun delete-occurrences-from-json(occurrences parent-psi revision)
- (declare (list occurrences) (string parent-psi) (integer revision))
- (let ((parent-topic (d:get-item-by-psi parent-psi))
- (err "From delete-occurrences-from-json(): "))
- (unless parent-topic
- (error "~a~a not found" err parent-psi))
- (dolist (j-occ occurrences)
- (let ((plist (json-importer::get-occurrence-values-from-json-list j-occ)))
- (let ((occ (find-occurrence-from-json parent-topic plist)))
- (unless occ
- (error "~a~a not found" err plist))
- (mark-as-deleted occ :revision revision))))))
-
-
-(defun find-association-from-json (json-plist)
- (declare (list json-plist))
- (let ((type-assocs
- (elephant:get-instances-by-value
- 'd:AssociationC 'd:instance-of
- (d:get-item-by-psi (first (getf json-plist :type)))))
- (scopes nil)
- (err "From find-association-from-json(): "))
- (loop for scope-entry in (getf json-plist :scopes)
- do (let ((top (d:get-item-by-psi (first scope-entry))))
- (unless top
- (error "~a ~a not found" err (first scope-entry)))
- (pushnew top scopes)))
- (let ((scope-assocs
- (loop for assoc in type-assocs
- when (not (set-exclusive-or scopes (themes assoc)))
- collect assoc)))
- (loop for assoc in scope-assocs
- when (let ((found-roles
- (loop for j-role in (getf json-plist :roles)
- when (let ((j-player (when (getf j-role :topicRef)
- (d:get-item-by-psi (first (getf j-role :topicRef)))))
- (j-type (when (getf j-role :type)
- (d:get-item-by-psi (first (getf j-role :type))))))
- (find-if #'(lambda(role)
- (and (eql (instance-of role) j-type)
- (eql (player role) j-player)))
- (roles assoc)))
- collect j-role)))
- (= (length (roles assoc)) (length (getf json-plist :roles))
- (length found-roles)))
- return assoc))))
-
-
-(defun delete-associations-from-json (associations revision)
- (declare (list associations) (integer revision))
- (dolist (j-assoc associations)
- (let ((plist (json-importer::get-association-values-from-json-list j-assoc))
- (err "From delete-associations-from-json(): "))
- (let ((assoc (find-association-from-json plist)))
- (unless assoc
- (error "~a ~a not found" err plist))
- (mark-as-deleted assoc :revision revision)))))
-
-
-(defun delete-topics-from-json (topics revision)
- (declare (list topics) (integer revision))
- (let ((psis nil))
- (dolist (uri topics)
- (let ((psi (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri uri)))
- (unless psi
- (error "From delete-topics-from-json(): PSI ~a not found" uri))
- (pushnew psi psis)))
- (let ((tops
- (remove-duplicates
- (map 'list #'d:identified-construct psis))))
- (dolist (top tops)
- (let ((psi (uri (first (psis top)))))
- (mark-as-deleted top :source-locator psi :revision revision))))))
-
-
-;; =============================================================================
;; --- all fragment constraints ------------------------------------------------
;; =============================================================================
-(defun get-constraints-of-fragment(topic-psis &key (treat-as 'type))
+(defun get-constraints-of-fragment(topic-psis &key
+ (treat-as 'type) (revision *TM-REVISION*))
"Returns a json string with all constraints of this topic-psis.
- topic-psis must contain one item if it is treated as instance other wiese there can be more psis
- then the fragment will be treated as an instanceOf all passed psis."
- (let ((associationtype (get-item-by-psi *associationtype-psi*))
- (associationtype-constraint (is-type-constrained :what *associationtype-constraint-psi*))
+ topic-psis must contain one item if it is treated as instance otherwise#
+ there can be more psis then the fragment will be treated as an instanceOf
+ all passed psis."
+ (declare (type (or integer null) revision)
+ (symbol treat-as)
+ (list topic-psis))
+ (let ((associationtype (get-item-by-psi *associationtype-psi* :revision revision))
+ (associationtype-constraint (is-type-constrained
+ :what *associationtype-constraint-psi*
+ :revision revision))
(topics nil))
(when (and (not (eql treat-as 'type))
(> (length topic-psis) 1))
(error "From get-constraints-of-fragment: when treat-as is set ot instance there must be exactly one item in topic-psis!"))
-
(loop for topic-psi in topic-psis
do (let ((psi
(elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi)))
@@ -330,78 +39,110 @@
(when topics
(let ((topic-constraints
(let ((value
- (get-constraints-of-topic topics :treat-as treat-as)))
+ (get-constraints-of-topic topics :treat-as treat-as
+ :revision revision)))
(concatenate 'string "\"topicConstraints\":" value))))
(let ((available-associations
(remove-duplicates
(loop for topic in topics
- append (get-available-associations-of-topic topic :treat-as treat-as)))))
+ append (get-available-associations-of-topic
+ topic :treat-as treat-as :revision revision)))))
(dolist (item available-associations)
- (topictype-p item associationtype associationtype-constraint))
+ (topictype-p item associationtype associationtype-constraint
+ nil revision))
(let ((associations-constraints
- (concatenate 'string "\"associationsConstraints\":"
- (let ((inner-associations-constraints "["))
- (loop for available-association in available-associations
- do (let ((value
- (get-constraints-of-association available-association)))
- (setf inner-associations-constraints
- (concatenate 'string inner-associations-constraints value ","))))
- (if (string= inner-associations-constraints "[")
- (setf inner-associations-constraints "null")
- (setf inner-associations-constraints
- (concatenate 'string (subseq inner-associations-constraints 0 (- (length inner-associations-constraints) 1)) "]")))))))
+ (concatenate
+ 'string "\"associationsConstraints\":"
+ (let ((inner-associations-constraints "["))
+ (loop for available-association in available-associations
+ do (let ((value
+ (get-constraints-of-association
+ available-association :revision revision)))
+ (setf inner-associations-constraints
+ (concatenate 'string inner-associations-constraints
+ value ","))))
+ (if (string= inner-associations-constraints "[")
+ (setf inner-associations-constraints "null")
+ (setf inner-associations-constraints
+ (concatenate
+ 'string
+ (subseq inner-associations-constraints 0
+ (- (length inner-associations-constraints) 1))
+ "]")))))))
(let ((json-string
(concatenate 'string
- "{" topic-constraints "," associations-constraints "}")))
+ "{" topic-constraints "," associations-constraints
+ "}")))
json-string)))))))
;; =============================================================================
;; --- all association constraints ---------------------------------------------
;; =============================================================================
-(defun get-constraints-of-association (associationtype-topic)
+(defun get-constraints-of-association (associationtype-topic &key
+ (revision *TM-REVISION*))
"Returns a list of constraints which are describing associations of the
passed associationtype-topic."
+ (declare (TopicC associationtype-topic)
+ (type (or integer null) revision))
(let ((constraint-topics
- (get-all-constraint-topics-of-association associationtype-topic)))
+ (get-all-constraint-topics-of-association associationtype-topic
+ :revision revision)))
(let ((associationtype
(concatenate 'string "\"associationType\":"
- (json-exporter::identifiers-to-json-string associationtype-topic)))
+ (json-exporter::identifiers-to-json-string
+ associationtype-topic :revision revision)))
(associationtypescope-constraints
- (let ((value (get-typescope-constraints associationtype-topic :what 'association)))
+ (let ((value (get-typescope-constraints associationtype-topic
+ :what 'association
+ :revision revision)))
(concatenate 'string "\"scopeConstraints\":" value)))
(associationrole-constraints
(let ((value
- (get-associationrole-constraints (getf constraint-topics :associationrole-constraints))))
+ (get-associationrole-constraints
+ (getf constraint-topics :associationrole-constraints)
+ :revision revision)))
(concatenate 'string "\"associationRoleConstraints\":" value)))
(roleplayer-constraints
(let ((value
- (get-roleplayer-constraints (getf constraint-topics :roleplayer-constraints))))
+ (get-roleplayer-constraints
+ (getf constraint-topics :roleplayer-constraints)
+ :revision revision)))
(concatenate 'string "\"rolePlayerConstraints\":" value)))
(otherrole-constraints
(let ((value
- (get-otherrole-constraints (getf constraint-topics :otherrole-constraints))))
+ (get-otherrole-constraints
+ (getf constraint-topics :otherrole-constraints)
+ :revision revision)))
(concatenate 'string "\"otherRoleConstraints\":" value))))
(let ((json-string
- (concatenate 'string "{" associationtype "," associationrole-constraints "," roleplayer-constraints ","
- otherrole-constraints "," associationtypescope-constraints "}")))
+ (concatenate 'string "{" associationtype "," associationrole-constraints
+ "," roleplayer-constraints ","
+ otherrole-constraints "," associationtypescope-constraints
+ "}")))
json-string))))
-(defun get-otherrole-constraints (constraint-topics)
+(defun get-otherrole-constraints (constraint-topics &key (revision *TM-REVISION*))
"Returns a list of the form
- ((::role <topic> :player <topic> :otherrole <topic> :othertopic <topic> :card-min <string> :card-max <string>) <...>)
+ ((::role <topic> :player <topic> :otherrole <topic> :othertopic <topic>
+ :card-min <string> :card-max <string>) <...>)
which describes an otherrole constraint for the parent-association of a give type."
- (let ((applies-to (get-item-by-psi *applies-to-psi*))
- (constraint-role (get-item-by-psi *constraint-role-psi*))
- (topictype-role (get-item-by-psi *topictype-role-psi*))
- (roletype-role (get-item-by-psi *roletype-role-psi*))
- (othertopictype-role (get-item-by-psi *othertopictype-role-psi*))
- (otherroletype-role (get-item-by-psi *otherroletype-role-psi*))
- (roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*))
- (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained)))
+ (declare (list constraint-topics)
+ (type (or integer null) revision))
+ (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision))
+ (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision))
+ (othertopictype-role (get-item-by-psi *othertopictype-role-psi*
+ :revision revision))
+ (otherroletype-role (get-item-by-psi *otherroletype-role-psi*
+ :revision revision))
+ (roletype (get-item-by-psi *roletype-psi* :revision revision))
+ (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*
+ :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision)))
(let ((otherrole-constraints
(loop for constraint-topic in constraint-topics
append (let ((players nil)
@@ -409,13 +150,22 @@
(otherplayers nil)
(otherroletypes nil)
(constraint-list
- (get-constraint-topic-values constraint-topic)))
- (loop for role in (player-in-roles constraint-topic)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- do (loop for other-role in (roles (parent role))
- do (let ((current-player (player other-role))
- (current-role (instance-of other-role)))
+ (get-constraint-topic-values constraint-topic
+ :revision revision)))
+ (loop for role in (player-in-roles constraint-topic
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role :revision revision))
+ (eq applies-to (instance-of
+ (parent role :revision revision)
+ :revision revision)))
+ do (loop for other-role in (roles
+ (parent role :revision revision)
+ :revision revision)
+ do (let ((current-player
+ (player other-role :revision revision))
+ (current-role
+ (instance-of other-role :revision revision)))
(cond
((eq topictype-role current-role)
(push current-player players))
@@ -425,26 +175,47 @@
(push current-player otherplayers))
((eq otherroletype-role current-role)
(push current-player otherroletypes))))))
- (when (and (append players roletypes otherplayers otherroletypes)
- (or (not players) (not roletypes) (not otherplayers) (not otherroletypes)))
+ (when (and (append
+ players roletypes otherplayers otherroletypes)
+ (or (not players) (not roletypes)
+ (not otherplayers) (not otherroletypes)))
(error "otherroletype-constraint ~a is not complete:~%players: ~a~%roletypes: ~a~%otherplayers: ~a~%otherroletypes: ~a~%"
(uri (first (psis constraint-topic)))
- (map 'list #'(lambda(x)(uri (first (psis x)))) players)
- (map 'list #'(lambda(x)(uri (first (psis x)))) roletypes)
- (map 'list #'(lambda(x)(uri (first (psis x)))) otherplayers)
- (map 'list #'(lambda(x)(uri (first (psis x)))) otherroletypes)))
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ players)
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ roletypes)
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ otherplayers)
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ otherroletypes)))
(let ((cross-product-1
(loop for player in players
append (loop for roletype in roletypes
- collect (list :player player :role roletype))))
+ collect (list :player player
+ :role roletype))))
(cross-product-2
(loop for otherplayer in otherplayers
append (loop for otherroletype in otherroletypes
- collect (list :otherplayer otherplayer :otherrole otherroletype)))))
+ collect
+ (list :otherplayer otherplayer
+ :otherrole otherroletype)))))
(let ((cross-product
(loop for tupple-1 in cross-product-1
- append (loop for tupple-2 in cross-product-2
- collect (append tupple-1 tupple-2 (list :constraint constraint-list))))))
+ append
+ (loop for tupple-2 in cross-product-2
+ collect
+ (append
+ tupple-1 tupple-2
+ (list :constraint constraint-list))))))
cross-product))))))
(let ((involved-topic-tupples
(remove-duplicates
@@ -453,10 +224,14 @@
(role-type (getf otherrole-constraint :role))
(otherplayer (getf otherrole-constraint :otherplayer))
(otherrole-type (getf otherrole-constraint :otherrole)))
- (topictype-p player)
- (topictype-p role-type roletype roletype-constraint)
- (topictype-p otherplayer)
- (topictype-p otherrole-type roletype roletype-constraint)
+ (topictype-p player topictype topictype-constraint
+ nil revision)
+ (topictype-p role-type roletype roletype-constraint
+ nil revision)
+ (topictype-p otherplayer topictype topictype-constraint
+ nil revision)
+ (topictype-p otherrole-type roletype roletype-constraint
+ nil revision)
(list :player player
:role role-type
:otherplayer otherplayer
@@ -471,105 +246,176 @@
do (let ((constraint-lists
(remove-duplicate-constraints
(loop for otherrole-constraint in otherrole-constraints
- when (and (eq (getf otherrole-constraint :player) (getf involved-topic-tupple :player))
- (eq (getf otherrole-constraint :role) (getf involved-topic-tupple :role))
- (eq (getf otherrole-constraint :otherplayer) (getf involved-topic-tupple :otherplayer))
- (eq (getf otherrole-constraint :otherrole) (getf involved-topic-tupple :otherrole)))
+ when (and (eq (getf otherrole-constraint :player)
+ (getf involved-topic-tupple :player))
+ (eq (getf otherrole-constraint :role)
+ (getf involved-topic-tupple :role))
+ (eq (getf otherrole-constraint :otherplayer)
+ (getf involved-topic-tupple :otherplayer))
+ (eq (getf otherrole-constraint :otherrole)
+ (getf involved-topic-tupple :otherrole)))
collect (getf otherrole-constraint :constraint)))))
(when (> (length constraint-lists) 1)
(error "found contrary otherrole-constraints:~%player: ~a~%role: ~a~%otherplayer: ~a~%otherrole: ~a~% ~a~%"
- (uri (first (psis (getf involved-topic-tupple :player))))
- (uri (first (psis (getf involved-topic-tupple :role))))
- (uri (first (psis (getf involved-topic-tupple :otherplayer))))
- (uri (first (psis (getf involved-topic-tupple :otherrole))))
+ (uri (first (psis (getf involved-topic-tupple :player)
+ :revision revision)))
+ (uri (first (psis (getf involved-topic-tupple :role)
+ :revision revision)))
+ (uri (first (psis (getf involved-topic-tupple :otherplayer)
+ :revision revision)))
+ (uri (first (psis (getf involved-topic-tupple :otherrole)
+ :revision revision)))
constraint-lists))
(let ((json-player-type
- (concatenate 'string "\"playerType\":"
- (topics-to-json-list (getf (list-subtypes (getf involved-topic-tupple :player) nil nil) :subtypes))))
+ (concatenate
+ 'string "\"playerType\":"
+ (topics-to-json-list
+ (getf (list-subtypes (getf involved-topic-tupple :player)
+ nil nil nil nil revision)
+ :subtypes) :revision revision)))
(json-player
- (concatenate 'string "\"players\":"
- (topics-to-json-list
- (list-instances (getf involved-topic-tupple :player) topictype topictype-constraint))))
+ (concatenate
+ 'string "\"players\":"
+ (topics-to-json-list
+ (list-instances (getf involved-topic-tupple :player)
+ topictype topictype-constraint revision)
+ :revision revision)))
(json-role
- (concatenate 'string "\"roleType\":"
- (topics-to-json-list
- (getf (list-subtypes (getf involved-topic-tupple :role) roletype roletype-constraint) :subtypes))))
+ (concatenate
+ 'string "\"roleType\":"
+ (topics-to-json-list
+ (getf (list-subtypes (getf involved-topic-tupple :role)
+ roletype roletype-constraint nil
+ nil revision)
+ :subtypes) :revision revision)))
(json-otherplayer-type
- (concatenate 'string "\"otherPlayerType\":"
- (topics-to-json-list (getf (list-subtypes (getf involved-topic-tupple :otherplayer) nil nil) :subtypes))))
+ (concatenate
+ 'string "\"otherPlayerType\":"
+ (topics-to-json-list
+ (getf (list-subtypes
+ (getf involved-topic-tupple :otherplayer)
+ nil nil nil nil revision) :subtypes)
+ :revision revision)))
(json-otherplayer
- (concatenate 'string "\"otherPlayers\":"
- (topics-to-json-list
- (list-instances (getf involved-topic-tupple :otherplayer) topictype topictype-constraint))))
+ (concatenate
+ 'string "\"otherPlayers\":"
+ (topics-to-json-list
+ (list-instances (getf involved-topic-tupple :otherplayer)
+ topictype topictype-constraint revision)
+ :revision revision)))
(json-otherrole
- (concatenate 'string "\"otherRoleType\":"
- (topics-to-json-list
- (getf (list-subtypes (getf involved-topic-tupple :otherrole) roletype roletype-constraint) :subtypes))))
+ (concatenate
+ 'string "\"otherRoleType\":"
+ (topics-to-json-list
+ (getf (list-subtypes
+ (getf involved-topic-tupple :otherrole)
+ roletype roletype-constraint nil nil revision)
+ :subtypes) :revision revision)))
(card-min
- (concatenate 'string "\"cardMin\":" (getf (first constraint-lists) :card-min)))
+ (concatenate 'string "\"cardMin\":"
+ (getf (first constraint-lists) :card-min)))
(card-max
- (concatenate 'string "\"cardMax\":" (getf (first constraint-lists) :card-max))))
+ (concatenate 'string "\"cardMax\":"
+ (getf (first constraint-lists) :card-max))))
(setf cleaned-otherrole-constraints
(concatenate 'string cleaned-otherrole-constraints
- "{" json-player-type "," json-player "," json-role "," json-otherplayer-type "," json-otherplayer "," json-otherrole "," card-min "," card-max "},")))))
+ "{" json-player-type "," json-player ","
+ json-role "," json-otherplayer-type ","
+ json-otherplayer "," json-otherrole ","
+ card-min "," card-max "},")))))
(if (string= cleaned-otherrole-constraints "[")
(setf cleaned-otherrole-constraints "null")
(setf cleaned-otherrole-constraints
- (concatenate 'string (subseq cleaned-otherrole-constraints 0 (- (length cleaned-otherrole-constraints) 1)) "]")))
+ (concatenate
+ 'string (subseq cleaned-otherrole-constraints 0
+ (- (length cleaned-otherrole-constraints) 1))
+ "]")))
cleaned-otherrole-constraints)))))
-(defun get-roleplayer-constraints (constraint-topics)
+(defun get-roleplayer-constraints (constraint-topics &key (revision *TM-REVISION*))
"Returns a list of the form
((:role <topic> :player <topic> :card-min <string> :card-max <string>) <...>)
which describes the cardinality of topctypes used as players in roles of given
types in an association of a given type which is also the parent if this list."
- (let ((applies-to (get-item-by-psi *applies-to-psi*))
- (constraint-role (get-item-by-psi *constraint-role-psi*))
- (topictype-role (get-item-by-psI *topictype-role-psi*))
- (roletype-role (get-item-by-psi *roletype-role-psi*))
- (roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*))
- (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained)))
+ (declare (type (or integer null) revision)
+ (list constraint-topics))
+ (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (topictype-role (get-item-by-psI *topictype-role-psi* :revision revision))
+ (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision))
+ (roletype (get-item-by-psi *roletype-psi* :revision revision))
+ (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*
+ :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision)))
(let ((roleplayer-constraints
(loop for constraint-topic in constraint-topics
append (let ((constraint-list
- (get-constraint-topic-values constraint-topic)))
+ (get-constraint-topic-values constraint-topic
+ :revision revision)))
(let ((players
- (loop for role in (player-in-roles constraint-topic)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (eq topictype-role (instance-of other-role))
- collect (player other-role))))
+ (loop for role in (player-in-roles constraint-topic
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role :revision revision))
+ (eq applies-to
+ (instance-of
+ (parent role :revision revision)
+ :revision revision)))
+ append (loop for other-role in
+ (roles (parent role :revision revision)
+ :revision revision)
+ when (eq topictype-role
+ (instance-of other-role
+ :revision revision))
+ collect (player other-role
+ :revision revision))))
(roles
- (loop for role in (player-in-roles constraint-topic)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
+ (loop for role in (player-in-roles constraint-topic
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role :revision revision))
+ (eq applies-to
+ (instance-of
+ (parent role :revision revision)
+ :revision revision)))
append (loop for other-role in (roles (parent role))
- when (eq roletype-role (instance-of other-role))
+ when (eq roletype-role
+ (instance-of other-role
+ :revision revision))
collect (player other-role)))))
(when (or (and players (not roles))
(and roles (not players)))
(error "roleplayer-constraint ~a is not complete:~%players: ~a~%roles: ~a~%"
- (uri (first (psis constraint-topic)))
- (map 'list #'(lambda(x)(uri (first (psis x)))) players)
- (map 'list #'(lambda(x)(uri (first (psis x)))) roles)))
+ (uri (first (psis constraint-topic
+ :revision revision)))
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ players)
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ roles)))
(let ((cross-product
(loop for player in players
append (loop for role in roles
- collect (list :player player :role role :constraint constraint-list)))))
+ collect
+ (list :player player
+ :role role
+ :constraint constraint-list)))))
cross-product))))))
-
(let ((role-player-tupples
(remove-duplicates
(loop for roleplayer-constraint in roleplayer-constraints
collect (let ((current-player (getf roleplayer-constraint :player))
(current-role (getf roleplayer-constraint :role)))
- (topictype-p current-player)
- (topictype-p current-role roletype roletype-constraint)
+ (topictype-p current-player topictype topictype-constraint
+ nil revision)
+ (topictype-p current-role roletype roletype-constraint
+ nil revision)
(list :player current-player
:role current-role)))
:test #'(lambda(x y)
@@ -580,109 +426,163 @@
do (let ((constraint-lists
(remove-duplicate-constraints
(loop for roleplayer-constraint in roleplayer-constraints
- when (and (eq (getf roleplayer-constraint :player) (getf role-player-tupple :player))
- (eq (getf roleplayer-constraint :role) (getf role-player-tupple :role)))
+ when (and (eq (getf roleplayer-constraint :player)
+ (getf role-player-tupple :player))
+ (eq (getf roleplayer-constraint :role)
+ (getf role-player-tupple :role)))
collect (getf roleplayer-constraint :constraint)))))
(when (> (length constraint-lists) 1)
(error "found contrary roleplayer-constraints:~%role: ~a~%player: ~a~% ~a ~%"
- (uri (first (psis (getf role-player-tupple :role))))
- (uri (first (psis (getf role-player-tupple :player))))
+ (uri (first (psis (getf role-player-tupple :role)
+ :revision revision)))
+ (uri (first (psis (getf role-player-tupple :player)
+ :revision revision)))
constraint-lists))
(let ((json-player-type
- (concatenate 'string "\"playerType\":"
- (topics-to-json-list (getf (list-subtypes (getf role-player-tupple :player) nil nil) :subtypes))))
+ (concatenate
+ 'string "\"playerType\":"
+ (topics-to-json-list
+ (getf (list-subtypes (getf role-player-tupple :player)
+ nil nil nil nil revision) :subtypes)
+ :revision revision)))
(json-players
- (concatenate 'string "\"players\":"
- (topics-to-json-list
- (list-instances (getf role-player-tupple :player) topictype topictype-constraint))))
+ (concatenate
+ 'string "\"players\":"
+ (topics-to-json-list
+ (list-instances (getf role-player-tupple :player)
+ topictype topictype-constraint revision)
+ :revision revision)))
(json-role
- (concatenate 'string "\"roleType\":"
- (topics-to-json-list
- (getf (list-subtypes (getf role-player-tupple :role) roletype roletype-constraint) :subtypes))))
+ (concatenate
+ 'string "\"roleType\":"
+ (topics-to-json-list
+ (getf (list-subtypes (getf role-player-tupple :role)
+ roletype roletype-constraint nil
+ nil revision)
+ :subtypes)
+ :revision revision)))
(card-min
- (concatenate 'string "\"cardMin\":" (getf (first constraint-lists) :card-min)))
+ (concatenate
+ 'string "\"cardMin\":"
+ (getf (first constraint-lists) :card-min)))
(card-max
- (concatenate 'string "\"cardMax\":" (getf (first constraint-lists) :card-max))))
+ (concatenate
+ 'string "\"cardMax\":"
+ (getf (first constraint-lists) :card-max))))
(setf cleaned-roleplayer-constraints
(concatenate 'string cleaned-roleplayer-constraints
- "{" json-player-type "," json-players "," json-role "," card-min "," card-max "},")))))
+ "{" json-player-type "," json-players ","
+ json-role "," card-min "," card-max "},")))))
(if (string= cleaned-roleplayer-constraints "[")
(setf cleaned-roleplayer-constraints "null")
(setf cleaned-roleplayer-constraints
- (concatenate 'string (subseq cleaned-roleplayer-constraints 0 (- (length cleaned-roleplayer-constraints) 1)) "]")))
+ (concatenate
+ 'string (subseq cleaned-roleplayer-constraints 0
+ (- (length cleaned-roleplayer-constraints) 1))
+ "]")))
cleaned-roleplayer-constraints)))))
-(defun get-associationrole-constraints (constraint-topics)
+(defun get-associationrole-constraints (constraint-topics &key
+ (revision *TM-REVISION*))
"Returns a list of the form
((:associationroletype <topic> :card-min <string> :card-max <string>), <...>)
which describes all associationrole-constraints of the passed
constraint-topics.
- If as-json is set to t the return value of this function is a json-string otherwise a
- list of lists of the following form (:roletype <topic, topic, ...> :cardMin <min> :cardMax <max>)"
- (let ((applies-to (get-item-by-psi *applies-to-psi*))
- (roletype-role (get-item-by-psi *roletype-role-psi*))
- (constraint-role (get-item-by-psi *constraint-role-psi*))
- (roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*)))
+ If as-json is set to t the return value of this function is a
+ json-string otherwise a list of lists of the following form
+ (:roletype <topic, topic, ...> :cardMin <min> :cardMax <max>)"
+ (declare (type (or integer null) revision)
+ (list constraint-topics))
+ (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision))
+ (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (roletype (get-item-by-psi *roletype-psi* :revision revision))
+ (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*
+ :revision revision)))
(let ((associationrole-constraints
(loop for constraint-topic in constraint-topics
append (let ((constraint-list
- (get-constraint-topic-values constraint-topic)))
- (loop for role in (player-in-roles constraint-topic)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (eq roletype-role (instance-of other-role))
- collect (list :associationroletype (player other-role)
- :constraint constraint-list)))))))
+ (get-constraint-topic-values constraint-topic
+ :revision revision)))
+ (loop for role in (player-in-roles constraint-topic
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role :revision revision))
+ (eq applies-to
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ append (loop for other-role in
+ (roles (parent role :revision revision)
+ :revision revision)
+ when (eq roletype-role
+ (instance-of other-role
+ :revision revision))
+ collect
+ (list :associationroletype
+ (player other-role :revision revision)
+ :constraint constraint-list)))))))
(let ((associationroletype-topics
- (remove-duplicates (map 'list #'(lambda(x)
- (let ((associationroletype (getf x :associationroletype)))
- (topictype-p associationroletype roletype roletype-constraint)
- associationroletype))
- associationrole-constraints))))
+ (remove-duplicates
+ (map 'list #'(lambda(x)
+ (let ((associationroletype (getf x :associationroletype)))
+ (topictype-p associationroletype roletype
+ roletype-constraint nil revision)
+ associationroletype))
+ associationrole-constraints))))
(let ((cleaned-associationrole-constraints "["))
- ;(raw-constraints nil))
(loop for associationroletype-topic in associationroletype-topics
- do (let ((constraint-lists
- (remove-duplicate-constraints
- (loop for associationrole-constraint in associationrole-constraints
- when (eq associationroletype-topic (getf associationrole-constraint :associationroletype))
- collect (getf associationrole-constraint :constraint)))))
- (when (> (length constraint-lists) 1)
- (error "found contrary associationrole-constraints: ~a ~a~%" (uri (first (psis associationroletype-topic))) constraint-lists))
+ do
+ (let ((constraint-lists
+ (remove-duplicate-constraints
+ (loop for associationrole-constraint in
+ associationrole-constraints
+ when (eq associationroletype-topic
+ (getf associationrole-constraint
+ :associationroletype))
+ collect (getf associationrole-constraint :constraint)))))
+ (when (> (length constraint-lists) 1)
+ (error "found contrary associationrole-constraints: ~a ~a~%" (uri (first (psis associationroletype-topic :revision revision))) constraint-lists))
(let ((roletype-with-subtypes
(json:encode-json-to-string
(map 'list #'(lambda(topic)
- (map 'list #'uri (psis topic)))
- (getf (list-subtypes associationroletype-topic roletype roletype-constraint) :subtypes)))))
- (setf cleaned-associationrole-constraints
- (concatenate 'string
- cleaned-associationrole-constraints
- "{\"roleType\":" roletype-with-subtypes
- ",\"cardMin\":" (getf (first constraint-lists) :card-min)
- ",\"cardMax\":" (getf (first constraint-lists) :card-max) "},")))))
-
-
+ (map 'list #'uri
+ (psis topic :revision revision)))
+ (getf (list-subtypes associationroletype-topic
+ roletype roletype-constraint
+ nil nil revision) :subtypes)))))
+ (setf cleaned-associationrole-constraints
+ (concatenate 'string
+ cleaned-associationrole-constraints
+ "{\"roleType\":" roletype-with-subtypes
+ ",\"cardMin\":" (getf (first constraint-lists)
+ :card-min)
+ ",\"cardMax\":" (getf (first constraint-lists)
+ :card-max) "},")))))
(if (string= cleaned-associationrole-constraints "[")
(setf cleaned-associationrole-constraints "null")
(setf cleaned-associationrole-constraints
- (concatenate 'string (subseq cleaned-associationrole-constraints 0 (- (length cleaned-associationrole-constraints) 1)) "]")))
+ (concatenate
+ 'string (subseq cleaned-associationrole-constraints 0
+ (- (length cleaned-associationrole-constraints)
+ 1)) "]")))
cleaned-associationrole-constraints)))))
;; =============================================================================
;; --- all topic constraints ---------------------------------------------------
;; =============================================================================
-(defun get-constraints-of-topic (topic-instances &key(treat-as 'type))
+(defun get-constraints-of-topic (topic-instances &key(treat-as 'type)
+ (revision *TM-REVISION*))
"Returns a constraint list with the constraints:
subjectidentifier-constraints, subjectlocator-constraints,
topicname-constraints, topicoccurrence-constraints and
uniqueoccurrence-constraints.
topic-instances should be a list with exactly one item if trea-as is set to type
otherwise it can constain more items."
- (declare (list topic-instances))
+ (declare (list topic-instances)
+ (symbol treat-as)
+ (type (or integer null) revision))
(when (and (> (length topic-instances) 1)
(not (eql treat-as 'type)))
(error "From get-constraints-of-topic: topic-instances must contain exactly one item when treated as instance!"))
@@ -695,14 +595,17 @@
(uniqueoccurrence-constraints nil))
(loop for topic-instance in topic-instances
do (let ((current-constraints
- (get-all-constraint-topics-of-topic topic-instance :treat-as treat-as)))
+ (get-all-constraint-topics-of-topic topic-instance
+ :treat-as treat-as
+ :revision revision)))
(dolist (item (getf current-constraints :abstract-topictype-constraints))
(pushnew item abstract-topictype-constraints))
(dolist (item (getf current-constraints :exclusive-instance-constraints))
(let ((current-list
(list topic-instance (list item))))
(let ((found-item
- (find current-list exclusive-instance-constraints :key #'first)))
+ (find current-list exclusive-instance-constraints
+ :key #'first)))
(if found-item
(dolist (inner-item (second current-list))
(pushnew inner-item (second found-item)))
@@ -720,28 +623,41 @@
(let ((exclusive-instance-constraints
(let ((value "["))
(loop for exclusive-instance-constraint in exclusive-instance-constraints
- do (setf value (concatenate 'string value
- (get-exclusive-instance-constraints (first exclusive-instance-constraint)
- (second exclusive-instance-constraint)) ",")))
+ do (setf value
+ (concatenate 'string value
+ (get-exclusive-instance-constraints
+ (first exclusive-instance-constraint)
+ (second exclusive-instance-constraint)
+ :revision revision) ",")))
(if (string= value "[")
(setf value "null")
- (setf value (concatenate 'string (subseq value 0 (- (length value) 1)) "]")))
+ (setf value (concatenate 'string (subseq value 0
+ (- (length value) 1)) "]")))
(concatenate 'string "\"exclusiveInstances\":" value)))
(subjectidentifier-constraints
(let ((value
- (get-simple-constraints subjectidentifier-constraints :error-msg-constraint-name "subjectidentifier")))
+ (get-simple-constraints
+ subjectidentifier-constraints
+ :error-msg-constraint-name "subjectidentifier"
+ :revision revision)))
(concatenate 'string "\"subjectIdentifierConstraints\":" value)))
(subjectlocator-constraints
(let ((value
- (get-simple-constraints subjectlocator-constraints :error-msg-constraint-name "subjectlocator")))
+ (get-simple-constraints
+ subjectlocator-constraints
+ :error-msg-constraint-name "subjectlocator"
+ :revision revision)))
(concatenate 'string "\"subjectLocatorConstraints\":" value)))
(topicname-constraints
(let ((value
- (get-topicname-constraints topicname-constraints)))
+ (get-topicname-constraints topicname-constraints
+ :revision revision)))
(concatenate 'string "\"topicNameConstraints\":" value)))
(topicoccurrence-constraints
(let ((value
- (get-topicoccurrence-constraints topicoccurrence-constraints uniqueoccurrence-constraints)))
+ (get-topicoccurrence-constraints topicoccurrence-constraints
+ uniqueoccurrence-constraints
+ :revision revision)))
(concatenate 'string "\"topicOccurrenceConstraints\":" value)))
(abstract-constraint
(concatenate 'string "\"abstractConstraint\":"
@@ -749,54 +665,89 @@
"true"
"false"))))
(let ((json-string
- (concatenate 'string "{" exclusive-instance-constraints "," subjectidentifier-constraints
+ (concatenate 'string "{" exclusive-instance-constraints ","
+ subjectidentifier-constraints
"," subjectlocator-constraints "," topicname-constraints ","
topicoccurrence-constraints "," abstract-constraint "}")))
json-string))))
-(defun get-exclusive-instance-constraints(owner exclusive-instances-lists)
+(defun get-exclusive-instance-constraints(owner exclusive-instances-lists
+ &key (revision *TM-REVISION*))
"Returns a JSON-obejct of the following form:
{owner: [psi-1, psi-2], exclusives: [[psi-1-1, psi-1-2], [psi-2-1, <...>], <...>]}."
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (topictype-role (get-item-by-psi *topictype-role-psi*))
- (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained)))
+ (declare (type (or integer null) revision))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision)))
(let ((topics
(remove-duplicates
(loop for exclusive-instances-list in exclusive-instances-lists
- append (let ((owner (getf exclusive-instances-list :owner))
- (exclusive-constraints (getf exclusive-instances-list :exclusive-constraints)))
- (loop for exclusive-constraint in exclusive-constraints
- append (loop for role in (player-in-roles exclusive-constraint)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (and (eq topictype-role (instance-of other-role))
- (not (eq owner (player other-role))))
- ;collect (player other-role)))))))))
- append (getf (list-subtypes (player other-role) topictype topictype-constraint) :subtypes)))))))))
- (concatenate 'string "{\"owner\":" (json-exporter::identifiers-to-json-string owner)
+ append
+ (let ((owner (getf exclusive-instances-list :owner))
+ (exclusive-constraints
+ (getf exclusive-instances-list :exclusive-constraints)))
+ (loop for exclusive-constraint in exclusive-constraints
+ append
+ (loop for role in
+ (player-in-roles exclusive-constraint
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role
+ :revision revision))
+ (eq applies-to (instance-of
+ (parent role :revision revision)
+ :revision revision)))
+ append
+ (loop for other-role in
+ (roles
+ (parent role :revision revision)
+ :revision revision)
+ when (and (eq topictype-role
+ (instance-of other-role
+ :revision revision))
+ (not
+ (eq owner (player other-role
+ :revision revision))))
+ append
+ (getf
+ (list-subtypes
+ (player other-role :revision revision)
+ topictype topictype-constraint nil
+ nil revision) :subtypes)))))))))
+ (concatenate 'string "{\"owner\":" (json-exporter::identifiers-to-json-string
+ owner :revision revision)
",\"exclusives\":"
- (json:encode-json-to-string (map 'list #'(lambda(y)
- (map 'list #'uri y))
- (map 'list #'psis topics))) "}"))))
+ (json:encode-json-to-string
+ (map 'list #'(lambda(y)
+ (map 'list #'uri y))
+ (map 'list #'(lambda(z)
+ (psis z :revision revision))
+ topics))) "}"))))
-(defun get-simple-constraints(constraint-topics &key (error-msg-constraint-name "uniqueoccurrence"))
+(defun get-simple-constraints(constraint-topics &key
+ (error-msg-constraint-name "uniqueoccurrence")
+ (revision *TM-REVISION*))
"Returns a list of the form
((:regexp <string> :card-min <string> :card-max <string>))
which contains the subjectidentifier, subjectlocator or
unique-occurrence constraints. This depends on the passed
constraint-topics."
+ (declare (list constraint-topics)
+ (string error-msg-constraint-name)
+ (type (or integer null) revision))
(let ((all-values
(remove-duplicate-constraints
(loop for constraint-topic in constraint-topics
- collect (get-constraint-topic-values constraint-topic)))))
+ collect (get-constraint-topic-values constraint-topic
+ :revision revision)))))
(let ((contrary-constraints (find-contrary-constraints all-values)))
(when contrary-constraints
- (error "found contrary ~a-constraints: ~a~%" error-msg-constraint-name contrary-constraints)))
+ (error "found contrary ~a-constraints: ~a~%"
+ error-msg-constraint-name contrary-constraints)))
(simple-constraints-to-json all-values)))
@@ -807,13 +758,15 @@
[{regexp: expr, cardMin: 123, cardMax: 456}, <...>]."
(let ((constraints "["))
(loop for constraint in simple-constraints
- do (let ((constraint (concatenate 'string "{\"regexp\":"
- (json:encode-json-to-string (getf constraint :regexp))
- ",\"cardMin\":"
- (json:encode-json-to-string (getf constraint :card-min))
- ",\"cardMax\":"
- (json:encode-json-to-string (getf constraint :card-max))
- "}")))
+ do (let ((constraint
+ (concatenate
+ 'string "{\"regexp\":"
+ (json:encode-json-to-string (getf constraint :regexp))
+ ",\"cardMin\":"
+ (json:encode-json-to-string (getf constraint :card-min))
+ ",\"cardMax\":"
+ (json:encode-json-to-string (getf constraint :card-max))
+ "}")))
(if (string= constraints "[")
(setf constraints (concatenate 'string constraints constraint))
(setf constraints (concatenate 'string constraints "," constraint)))))
@@ -823,34 +776,53 @@
constraints))
-(defun get-topicname-constraints(constraint-topics)
+(defun get-topicname-constraints(constraint-topics &key (revision *TM-REVISION*))
"Returns all topicname constraints as a list of the following form:
[{nametypescopes:[{nameType: [psi-1, psi-2], scopeConstraints: [<scopeConstraint>]},
{nameType: [subtype-1-psi-1], scopeConstraints: [<scopeConstraints>]},
constraints: [<simpleConstraint>, <...>]},
<...>]."
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (nametype-role (get-item-by-psi *nametype-role-psi*))
- (nametype (get-item-by-psi *nametype-psi*))
- (nametype-constraint (is-type-constrained :what *nametype-constraint-psi*)))
+ (declare (type (or integer null) revision)
+ (list constraint-topics))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (nametype-role (get-item-by-psi *nametype-role-psi* :revision revision))
+ (nametype (get-item-by-psi *nametype-psi* :revision revision))
+ (nametype-constraint (is-type-constrained :what *nametype-constraint-psi*
+ :revision revision)))
(let ((topicname-constraints
- (remove-if #'null
- (loop for constraint-topic in constraint-topics
- append (loop for role in (player-in-roles constraint-topic)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (eq nametype-role (instance-of other-role))
- collect (let ((nametype-topic (player other-role))
- (constraint-list (get-constraint-topic-values constraint-topic)))
- (list :type nametype-topic :constraint constraint-list))))))))
+ (remove-if
+ #'null
+ (loop for constraint-topic in constraint-topics
+ append
+ (loop for role in (player-in-roles constraint-topic
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role :revision revision))
+ (eq applies-to
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ append
+ (loop for other-role in
+ (roles (parent role :revision revision)
+ :revision revision)
+ when (eq nametype-role
+ (instance-of other-role :revision revision))
+ collect
+ (let ((nametype-topic
+ (player other-role :revision revision))
+ (constraint-list
+ (get-constraint-topic-values constraint-topic
+ :revision revision)))
+ (list :type nametype-topic
+ :constraint constraint-list))))))))
(let ((nametype-topics
(remove-duplicates
(map 'list #'(lambda(x)
(let ((topicname-type
(getf x :type)))
- (topictype-p topicname-type nametype nametype-constraint)
+ (topictype-p topicname-type nametype
+ nametype-constraint nil revision)
topicname-type))
topicname-constraints))))
(let ((cleaned-topicname-constraints "["))
@@ -863,31 +835,55 @@
(let ((contrary-constraints
(find-contrary-constraints constraint-lists)))
(when contrary-constraints
- (error "found contrary topicname-constraints: ~a~%" contrary-constraints)))
+ (error "found contrary topicname-constraints: ~a~%"
+ contrary-constraints)))
(let ((nametype-with-subtypes
- (remove-if #'null (getf (list-subtypes nametype-topic nametype nametype-constraint) :subtypes))))
+ (remove-if
+ #'null
+ (getf (list-subtypes nametype-topic nametype
+ nametype-constraint nil nil revision)
+ :subtypes))))
(let ((nametypescopes "\"nametypescopes\":["))
(loop for current-topic in nametype-with-subtypes
do (let ((current-json-string
- (concatenate 'string "{\"nameType\":" (json-exporter::identifiers-to-json-string current-topic)
- ",\"scopeConstraints\":" (get-typescope-constraints current-topic :what 'topicname) "}")))
- (setf nametypescopes (concatenate 'string nametypescopes current-json-string ","))))
+ (concatenate
+ 'string "{\"nameType\":"
+ (json-exporter::identifiers-to-json-string
+ current-topic :revision revision)
+ ",\"scopeConstraints\":"
+ (get-typescope-constraints current-topic
+ :what 'topicname
+ :revision revision)
+ "}")))
+ (setf nametypescopes
+ (concatenate 'string nametypescopes
+ current-json-string ","))))
(if (string= nametypescopes "\"nametypescopes\"[")
(setf nametypescopes "null")
(setf nametypescopes
- (concatenate 'string (subseq nametypescopes 0 (- (length nametypescopes) 1)) "]")))
+ (concatenate
+ 'string (subseq nametypescopes 0
+ (- (length nametypescopes) 1)) "]")))
(let ((json-constraint-lists
- (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists))))
+ (concatenate
+ 'string "\"constraints\":"
+ (simple-constraints-to-json constraint-lists))))
(setf cleaned-topicname-constraints
- (concatenate 'string cleaned-topicname-constraints "{" nametypescopes "," json-constraint-lists "},")))))))
+ (concatenate
+ 'string cleaned-topicname-constraints "{"
+ nametypescopes "," json-constraint-lists "},")))))))
(if (string= cleaned-topicname-constraints "[")
(setf cleaned-topicname-constraints "null")
(setf cleaned-topicname-constraints
- (concatenate 'string (subseq cleaned-topicname-constraints 0 (- (length cleaned-topicname-constraints) 1)) "]")))
+ (concatenate
+ 'string (subseq cleaned-topicname-constraints 0
+ (- (length cleaned-topicname-constraints) 1))
+ "]")))
cleaned-topicname-constraints)))))
-(defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics)
+(defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics
+ &key (revision *TM-REVISION*))
"Returns all topicoccurrence constraints as a list of the following form:
[{occurrenceTypes:[{occurrenceType:[psi-1,psi-2],
scopeConstraints:[<scopeConstraints>],
@@ -896,105 +892,177 @@
constraints:[<simpleConstraints>, <...>],
uniqueConstraint:[<uniqueConstraints>, <...> ]}
<...>]."
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*))
- (occurrencetype (get-item-by-psi *occurrencetype-psi*))
- (occurrencetype-constraint (is-type-constrained :what *occurrencetype-constraint-psi*)))
+ (declare (type (or integer null) revision)
+ (list constraint-topics unique-constraint-topics))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*
+ :revision revision))
+ (occurrencetype (get-item-by-psi *occurrencetype-psi*
+ :revision revision))
+ (occurrencetype-constraint
+ (is-type-constrained :what *occurrencetype-constraint-psi*
+ :revision revision)))
(let ((topicoccurrence-constraints
- (remove-if #'null
- (loop for constraint-topic in constraint-topics
- append (loop for role in (player-in-roles constraint-topic)
- when (and (eq constraint-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (eq occurrencetype-role (instance-of other-role))
- collect (let ((occurrencetype-topic (player other-role))
- (constraint-list (get-constraint-topic-values constraint-topic)))
- (list :type occurrencetype-topic :constraint constraint-list))))))))
+ (remove-if
+ #'null
+ (loop for constraint-topic in constraint-topics
+ append
+ (loop for role in (player-in-roles constraint-topic
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of role :revision revision))
+ (eq applies-to
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ append
+ (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
+ when (eq occurrencetype-role
+ (instance-of other-role :revision revision))
+ collect
+ (let ((occurrencetype-topic
+ (player other-role :revision revision))
+ (constraint-list
+ (get-constraint-topic-values constraint-topic
+ :revision revision)))
+ (list :type occurrencetype-topic
+ :constraint constraint-list))))))))
(let ((occurrencetype-topics
(remove-duplicates
- (map 'list #'(lambda(x)
- (let ((occurrence-type (getf x :type)))
- (topictype-p occurrence-type occurrencetype occurrencetype-constraint)
- occurrence-type))
+ (map 'list
+ #'(lambda(x)
+ (let ((occurrence-type (getf x :type)))
+ (topictype-p occurrence-type occurrencetype
+ occurrencetype-constraint nil revision)
+ occurrence-type))
topicoccurrence-constraints))))
(let ((cleaned-topicoccurrence-constraints "["))
(loop for occurrencetype-topic in occurrencetype-topics
do (let ((constraint-lists
(remove-duplicate-constraints
- (loop for topicoccurrence-constraint in topicoccurrence-constraints
- when (eq occurrencetype-topic (getf topicoccurrence-constraint :type))
+ (loop for topicoccurrence-constraint in
+ topicoccurrence-constraints
+ when (eq occurrencetype-topic
+ (getf topicoccurrence-constraint :type))
collect (getf topicoccurrence-constraint :constraint)))))
(let ((contrary-constraints
(find-contrary-constraints constraint-lists)))
(when contrary-constraints
- (error "found contrary topicname-constraints: ~a~%" contrary-constraints)))
-
-
+ (error "found contrary topicname-constraints: ~a~%"
+ contrary-constraints)))
(let ((occurrencetype-with-subtypes
- (getf (list-subtypes occurrencetype-topic occurrencetype occurrencetype-constraint) :subtypes)))
-
+ (getf
+ (list-subtypes occurrencetype-topic
+ occurrencetype occurrencetype-constraint
+ nil nil revision) :subtypes)))
(let ((occurrencetypes-json-string "\"occurrenceTypes\":["))
(loop for current-topic in occurrencetype-with-subtypes
do (let ((current-json-string
- (concatenate 'string "{\"occurrenceType\":" (json-exporter::identifiers-to-json-string current-topic)
- ",\"scopeConstraints\":" (get-typescope-constraints current-topic :what 'topicoccurrence)
- ",\"datatypeConstraint\":" (get-occurrence-datatype-constraint current-topic) "}")))
- (setf occurrencetypes-json-string (concatenate 'string occurrencetypes-json-string current-json-string ","))))
-
+ (concatenate
+ 'string "{\"occurrenceType\":"
+ (json-exporter::identifiers-to-json-string
+ current-topic :revision revision)
+ ",\"scopeConstraints\":"
+ (get-typescope-constraints
+ current-topic :what 'topicoccurrence
+ :revision revision)
+ ",\"datatypeConstraint\":"
+ (get-occurrence-datatype-constraint
+ current-topic :revision revision)
+ "}")))
+ (setf occurrencetypes-json-string
+ (concatenate 'string occurrencetypes-json-string
+ current-json-string ","))))
(if (string= occurrencetypes-json-string "\"occurrenceTypes\"[")
(setf occurrencetypes-json-string "null")
(setf occurrencetypes-json-string
- (concatenate 'string (subseq occurrencetypes-json-string 0 (- (length occurrencetypes-json-string) 1)) "]")))
+ (concatenate
+ 'string (subseq occurrencetypes-json-string 0
+ (- (length
+ occurrencetypes-json-string) 1))
+ "]")))
(let ((unique-constraints
(concatenate 'string "\"uniqueConstraints\":"
- (get-simple-constraints unique-constraint-topics)))
+ (get-simple-constraints
+ unique-constraint-topics
+ :revision revision)))
(json-constraint-lists
- (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists))))
+ (concatenate
+ 'string "\"constraints\":"
+ (simple-constraints-to-json constraint-lists))))
(let ((current-json-string
- (concatenate 'string "{" occurrencetypes-json-string "," json-constraint-lists "," unique-constraints "}")))
+ (concatenate
+ 'string "{" occurrencetypes-json-string ","
+ json-constraint-lists "," unique-constraints "}")))
(setf cleaned-topicoccurrence-constraints
- (concatenate 'string cleaned-topicoccurrence-constraints current-json-string ","))))))))
+ (concatenate
+ 'string cleaned-topicoccurrence-constraints
+ current-json-string ","))))))))
(if (string= cleaned-topicoccurrence-constraints "[")
(setf cleaned-topicoccurrence-constraints "null")
(setf cleaned-topicoccurrence-constraints
- (concatenate 'string (subseq cleaned-topicoccurrence-constraints 0 (- (length cleaned-topicoccurrence-constraints) 1)) "]")))
+ (concatenate
+ 'string
+ (subseq
+ cleaned-topicoccurrence-constraints 0
+ (- (length cleaned-topicoccurrence-constraints) 1)) "]")))
cleaned-topicoccurrence-constraints)))))
-(defun get-occurrence-datatype-constraint(occurrencetype-topic)
+(defun get-occurrence-datatype-constraint(occurrencetype-topic
+ &key (revision *TM-REVISION*))
"Return a datatype qualifier as a string."
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*))
- (datatype (get-item-by-psi *datatype-psi*))
- (occurrencedatatype-constraint (get-item-by-psi *occurrencedatatype-constraint-psi*)))
+ (declare (TopicC occurrencetype-topic)
+ (type (or integer null) revision))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*
+ :revision revision))
+ (datatype (get-item-by-psi *datatype-psi* :revision revision))
+ (occurrencedatatype-constraint
+ (get-item-by-psi *occurrencedatatype-constraint-psi*
+ :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*
+ :revision revision)))
(let ((datatype-constraints
(remove-duplicates
- (loop for role in (player-in-roles occurrencetype-topic)
- when (and (eq occurrencetype-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (and (eq constraint-role (instance-of other-role))
- (topictype-of-p (player other-role) occurrencedatatype-constraint))
- collect (player other-role))))))
+ (loop for role in (player-in-roles occurrencetype-topic :revision revision)
+ when (and (eq occurrencetype-role (instance-of role :revision revision))
+ (eq applies-to (instance-of (parent role :revision revision)
+ :revision revision)))
+ append (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of other-role :revision revision))
+ (topictype-of-p
+ (player other-role :revision revision)
+ occurrencedatatype-constraint topictype
+ topictype-constraint nil revision))
+ collect (player other-role :revision revision))))))
(let ((datatype-constraint
(remove-duplicates
- (map 'list #'(lambda(constraint-topic)
- (loop for occurrence in (occurrences constraint-topic)
- when (and (eq (instance-of occurrence) datatype)
- (slot-boundp occurrence 'charvalue))
- return (charvalue occurrence)))
- datatype-constraints))))
+ (map
+ 'list
+ #'(lambda(constraint-topic)
+ (loop for occurrence in
+ (occurrences constraint-topic :revision revision)
+ when (and (eq (instance-of occurrence :revision revision)
+ datatype)
+ (slot-boundp occurrence 'charvalue))
+ return (charvalue occurrence)))
+ datatype-constraints))))
(when (> (length datatype-constraint) 1)
- (error "found contrary occurrence-datatype-constraints: ~a~%" datatype-constraints))
+ (error "found contrary occurrence-datatype-constraints: ~a~%"
+ datatype-constraints))
(if datatype-constraint
(json:encode-json-to-string (first datatype-constraint))
"null")))))
-(defun get-typescope-constraints(element-type-topic &key(what 'topicname))
+(defun get-typescope-constraints(element-type-topic &key (what 'topicname)
+ (revision *TM-REVISION*))
"Returns a list of scopes for the element-typetopic which is the type topic of
a topicname, a topicoccurrence or an association. To specifiy of what kind
of element the scopes should be there is the key-variable what.
@@ -1003,116 +1071,175 @@
[{scopeTypes:[[[psi-1-1, psi-1-2], [subtype-1-psi-1, subtype-1-psi-2]], [[psi-2-1],
[subtype-1-psi-1], [subtype-2-psi-1]]], cardMin: <int-as-string>,
cardMax <int-as-string | MAX_INT>}, <...>]."
+ (declare (TopicC element-type-topic)
+ (symbol what)
+ (type (or integer null) revision))
(let ((element-type-role-and-scope-constraint
(cond
((eq what 'topicname)
- (list (get-item-by-psi *nametype-role-psi*)
- (get-item-by-psi *nametypescope-constraint-psi*)))
+ (list (get-item-by-psi *nametype-role-psi* :revision revision)
+ (get-item-by-psi *nametypescope-constraint-psi*
+ :revision revision)))
((eq what 'topicoccurrence)
(list
- (get-item-by-psi *occurrencetype-role-psi*)
- (get-item-by-psi *occurrencetypescope-constraint-psi*)))
+ (get-item-by-psi *occurrencetype-role-psi* :revision revision)
+ (get-item-by-psi *occurrencetypescope-constraint-psi*
+ :revision revision)))
((eq what 'association)
(list
- (get-item-by-psi *associationtype-role-psi*)
- (get-item-by-psi *associationtypescope-constraint-psi*)))))
- (scopetype-role (get-item-by-psi *scopetype-role-psi*))
- (constraint-role (get-item-by-psi *constraint-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (scopetype (get-item-by-psi *scopetype-psi*)))
+ (get-item-by-psi *associationtype-role-psi* :revision revision)
+ (get-item-by-psi *associationtypescope-constraint-psi*
+ :revision revision)))))
+ (scopetype-role (get-item-by-psi *scopetype-role-psi* :revision revision))
+ (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (scopetype (get-item-by-psi *scopetype-psi* :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*
+ :revision revision)))
(when (and (= (length element-type-role-and-scope-constraint) 2)
(first element-type-role-and-scope-constraint)
(second element-type-role-and-scope-constraint))
(let ((type-role (first element-type-role-and-scope-constraint))
(typescope-constraint (second element-type-role-and-scope-constraint)))
(let ((typescope-constraints
- (loop for role in (player-in-roles element-type-topic)
- when (and (eq type-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (and (eq constraint-role (instance-of other-role))
- (topictype-of-p (player other-role) typescope-constraint))
- collect (let ((scopes nil)
- (constraint nil))
- (loop for c-role in (player-in-roles (player other-role))
- when (and (eq constraint-role (instance-of c-role))
- (eq applies-to (instance-of (parent c-role))))
- do (progn
- (setf constraint (get-constraint-topic-values (player c-role)))
- (loop for c-other-role in (roles (parent c-role))
- when (eq scopetype-role (instance-of c-other-role))
- do (push (player c-other-role) scopes))))
- (list :scopes scopes :constraint constraint))))))
+ (loop for role in
+ (player-in-roles element-type-topic :revision revision)
+ when (and (eq type-role (instance-of role :revision revision))
+ (eq applies-to
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ append
+ (loop for other-role in
+ (roles (parent role :revision revision)
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of other-role :revision revision))
+ (topictype-of-p
+ (player other-role :revision revision)
+ typescope-constraint topictype
+ topictype-constraint nil revision))
+ collect
+ (let ((scopes nil)
+ (constraint nil))
+ (loop for c-role in
+ (player-in-roles
+ (player other-role :revision revision)
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of c-role :revision revision))
+ (eq applies-to
+ (instance-of
+ (parent c-role :revision revision)
+ :revision revision)))
+ do (progn
+ (setf constraint
+ (get-constraint-topic-values
+ (player c-role :revision revision)
+ :revision revision))
+ (loop for c-other-role in
+ (roles (parent c-role :revision revision)
+ :revision revision)
+ when (eq scopetype-role
+ (instance-of c-other-role
+ :revision revision))
+ do (push
+ (player c-other-role :revision revision)
+ scopes))))
+ (list :scopes scopes :constraint constraint))))))
(let ((scopetype-groups
- (remove-duplicates (map 'list #'(lambda(x)
- (let ((scopes (getf x :scopes)))
- (when scopes
- scopes)))
- typescope-constraints)
- :test #'(lambda(x y)
- (when (and (= (length x) (length y))
- (= (length x) (length (intersection x y))))
- t)))))
+ (remove-duplicates
+ (map 'list #'(lambda(x)
+ (let ((scopes (getf x :scopes)))
+ (when scopes
+ scopes)))
+ typescope-constraints)
+ :test #'(lambda(x y)
+ (when (and (= (length x) (length y))
+ (= (length x) (length (intersection x y))))
+ t)))))
(let ((cleaned-typescope-constraints "["))
(loop for scopetype-group in scopetype-groups
do (let ((constraint-lists
(remove-duplicate-constraints
(loop for typescope-constraint in typescope-constraints
- when (and (= (length (getf typescope-constraint :scopes))
- (length scopetype-group))
- (= (length (getf typescope-constraint :scopes))
- (length (intersection (getf typescope-constraint :scopes) scopetype-group))))
+ when
+ (and (= (length (getf typescope-constraint :scopes))
+ (length scopetype-group))
+ (= (length (getf typescope-constraint :scopes))
+ (length (intersection
+ (getf typescope-constraint :scopes)
+ scopetype-group))))
collect (getf typescope-constraint :constraint)))))
(when (> (length constraint-lists) 1)
(error "found contrary scopetype-constraints for ~a: ~a~%"
- (map 'list #'(lambda(x)(uri (first (psis x)))) scopetype-group)
+ (map 'list
+ #'(lambda(x)
+ (uri (first (psis x :revision revision))))
+ scopetype-group)
constraint-lists))
(let ((card-min (getf (first constraint-lists) :card-min))
(card-max (getf (first constraint-lists) :card-max)))
(let ((json-scopes
- (concatenate 'string "\"scopeTypes\":"
-
- (let ((scopetypes-with-subtypes
- (remove-if #'null
- (loop for current-scopetype in scopetype-group
- collect (getf (list-subtypes current-scopetype scopetype nil) :subtypes)))))
-
- (json:encode-json-to-string
- (map 'list #'(lambda(topic-group)
- (map 'list #'(lambda(topic)
- (map 'list #'uri (psis topic)))
- topic-group))
- scopetypes-with-subtypes))))))
+ (concatenate
+ 'string "\"scopeTypes\":"
+ (let ((scopetypes-with-subtypes
+ (remove-if
+ #'null
+ (loop for current-scopetype in scopetype-group
+ collect (getf
+ (list-subtypes current-scopetype
+ scopetype nil nil
+ nil revision)
+ :subtypes)))))
+ (json:encode-json-to-string
+ (map
+ 'list
+ #'(lambda(topic-group)
+ (map 'list
+ #'(lambda(topic)
+ (map 'list #'uri
+ (psis topic :revision revision)))
+ topic-group))
+ scopetypes-with-subtypes))))))
(let ((current-json-string
- (concatenate 'string "{" json-scopes ",\"cardMin\":\"" card-min "\",\"cardMax\":\"" card-max "\"}")))
+ (concatenate 'string "{" json-scopes
+ ",\"cardMin\":\"" card-min
+ "\",\"cardMax\":\"" card-max "\"}")))
(setf cleaned-typescope-constraints
- (concatenate 'string cleaned-typescope-constraints current-json-string ",")))))))
+ (concatenate 'string cleaned-typescope-constraints
+ current-json-string ",")))))))
(if (string= cleaned-typescope-constraints "[")
(setf cleaned-typescope-constraints "null")
(setf cleaned-typescope-constraints
- (concatenate 'string (subseq cleaned-typescope-constraints 0 (- (length cleaned-typescope-constraints) 1)) "]")))
+ (concatenate
+ 'string
+ (subseq cleaned-typescope-constraints 0
+ (- (length cleaned-typescope-constraints) 1)) "]")))
cleaned-typescope-constraints)))))))
;; =============================================================================
;; --- some basic helpers ------------------------------------------------------
;; =============================================================================
-(defun get-constraint-topic-values(topic)
+(defun get-constraint-topic-values(topic &key (revision *TM-REVISION*))
"Returns all constraint values of the passed topic in the
following form (list :regexp regexp :card-min card-min :card-max card-max)"
+ (declare (type (or integer null) revision))
(let ((regexp
- (get-constraint-occurrence-value topic))
+ (get-constraint-occurrence-value topic :revision revision))
(card-min
- (get-constraint-occurrence-value topic :what 'card-min))
+ (get-constraint-occurrence-value topic :what 'card-min :revision revision))
(card-max
- (get-constraint-occurrence-value topic :what 'card-max)))
+ (get-constraint-occurrence-value topic :what 'card-max :revision revision)))
(when (and (string/= "MAX_INT" card-max)
(> (parse-integer card-min) (parse-integer card-max)))
(error "card-min (~a) must be < card-max (~a)" card-min card-max))
(list :regexp regexp :card-min card-min :card-max card-max)))
-(defun get-constraint-occurrence-value(topic &key (what 'regexp))
+(defun get-constraint-occurrence-value(topic &key (what 'regexp)
+ (revision *TM-REVISION*))
"Checks the occurrence-value of a regexp, card-min or card-max
constraint-occurrence.
If what = 'regexp and the occurrence-value is empty there will be returned
@@ -1121,6 +1248,9 @@
the value '0'.
If what = 'card-max and the occurrence-value is empty there will be returned
the value 'MAX_INT'"
+ (declare (type (or integer null) revision)
+ (TopicC topic)
+ (symbol what))
(let ((occurrence-type
(get-item-by-psi
(cond
@@ -1131,11 +1261,14 @@
((eq what 'card-max)
*card-max-psi*)
(t
- "")))))
+ ""))
+ :revision revision)))
(when occurrence-type
(let ((occurrence-value
(let ((occurrence
- (find occurrence-type (occurrences topic) :key #'instance-of)))
+ (find occurrence-type (occurrences topic :revision revision)
+ :key #'(lambda(occ)
+ (instance-of occ :revision revision)))))
(if (and occurrence
(slot-boundp occurrence 'charvalue)
(> (length (charvalue occurrence)) 0))
@@ -1157,7 +1290,7 @@
(condition () nil))))
(unless is-valid
(error "card-min in ~a is \"~a\" but should be >= 0"
- (uri (first (psis topic)))
+ (uri (first (psis topic :revision revision)))
occurrence-value))))
((eq what 'card-max)
(let ((is-valid
@@ -1184,9 +1317,14 @@
do (progn
(when (> (length current-constraint) 0)
(return-from find-contrary-constraints current-constraint))
- (setf current-constraint (remove-if #'null (map 'list #'(lambda(x)
- (contrary-constraint-list x constraint-list))
- constraint-lists)))))))
+ (setf current-constraint
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(x)
+ (contrary-constraint-list x constraint-list))
+ constraint-lists)))))))
+
(defun contrary-constraint-list (lst-1 lst-2)
"Returns both passed lists when they have the same
@@ -1208,7 +1346,6 @@
(remove-duplicates constraint-lists :test #'eql-constraint-list))
-
(defun eql-constraint-list (lst-1 lst-2)
"Compares two constraint lists of the form (list <string> <string> string>)
or (list <topic> <string> <string> <string>."
@@ -1220,20 +1357,35 @@
;; --- gets all constraint topics ----------------------------------------------
-(defun get-direct-constraint-topics-of-topic (topic-instance)
+(defun get-direct-constraint-topics-of-topic (topic-instance &key
+ (revision *TM-REVISION*))
"Returns all constraint topics defined for the passed topic-instance"
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (topictype-role (get-item-by-psi *topictype-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (abstract-topictype-constraint (get-item-by-psi *abstract-topictype-constraint-psi*))
- (exclusive-instance-constraint (get-item-by-psi *exclusive-instance-psi*))
- (subjectidentifier-constraint (get-item-by-psi *subjectidentifier-constraint-psi*))
- (subjectlocator-constraint (get-item-by-psi *subjectlocator-constraint-psi*))
- (topicname-constraint (get-item-by-psi *topicname-constraint-psi*))
- (topicoccurrence-constraint (get-item-by-psi *topicoccurrence-constraint-psi*))
- (uniqueoccurrence-constraint (get-item-by-psi *uniqueoccurrence-constraint-psi*))
- (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*))
- (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (abstract-topictype-constraint
+ (get-item-by-psi *abstract-topictype-constraint-psi* :revision revision))
+ (exclusive-instance-constraint
+ (get-item-by-psi *exclusive-instance-psi* :revision revision))
+ (subjectidentifier-constraint
+ (get-item-by-psi *subjectidentifier-constraint-psi* :revision revision))
+ (subjectlocator-constraint
+ (get-item-by-psi *subjectlocator-constraint-psi* :revision revision))
+ (topicname-constraint
+ (get-item-by-psi *topicname-constraint-psi* :revision revision))
+ (topicoccurrence-constraint
+ (get-item-by-psi *topicoccurrence-constraint-psi* :revision revision))
+ (uniqueoccurrence-constraint
+ (get-item-by-psi *uniqueoccurrence-constraint-psi* :revision revision))
+ (roleplayer-constraint
+ (get-item-by-psi *roleplayer-constraint-psi* :revision revision))
+ (otherrole-constraint
+ (get-item-by-psi *otherrole-constraint-psi* :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*
+ :revision revision))
(abstract-topictype-constraints nil)
(exclusive-instance-constraints nil)
(subjectidentifier-constraints nil)
@@ -1241,35 +1393,51 @@
(topicname-constraints nil)
(topicoccurrence-constraints nil)
(uniqueoccurrence-constraints nil))
-
- (loop for role in (player-in-roles topic-instance)
- when (and (eq topictype-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- do (loop for other-role in (roles (parent role))
- when (eq constraint-role (instance-of other-role))
- do (let ((constraint-topic (player other-role)))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (and (eq topictype-role (instance-of role :revision revision))
+ (eq applies-to (instance-of (parent role :revision revision)
+ :revision revision)))
+ do (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
+ when (eq constraint-role (instance-of other-role :revision revision))
+ do (let ((constraint-topic (player other-role :revision revision)))
(cond
- ((topictype-of-p constraint-topic abstract-topictype-constraint)
+ ((topictype-of-p constraint-topic abstract-topictype-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic abstract-topictype-constraints))
- ((topictype-of-p constraint-topic exclusive-instance-constraint)
+ ((topictype-of-p constraint-topic exclusive-instance-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic exclusive-instance-constraints))
- ((topictype-of-p constraint-topic subjectidentifier-constraint)
+ ((topictype-of-p constraint-topic subjectidentifier-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic subjectidentifier-constraints))
- ((topictype-of-p constraint-topic subjectlocator-constraint)
+ ((topictype-of-p constraint-topic subjectlocator-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic subjectlocator-constraints))
- ((topictype-of-p constraint-topic topicname-constraint)
+ ((topictype-of-p constraint-topic topicname-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic topicname-constraints))
- ((topictype-of-p constraint-topic topicoccurrence-constraint)
+ ((topictype-of-p constraint-topic topicoccurrence-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic topicoccurrence-constraints))
- ((topictype-of-p constraint-topic uniqueoccurrence-constraint)
+ ((topictype-of-p constraint-topic uniqueoccurrence-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic uniqueoccurrence-constraints))
(t
- (unless (or (topictype-of-p constraint-topic roleplayer-constraint)
- (topictype-of-p constraint-topic otherrole-constraint))
- (error "Constraint-Topic \"~a\" could not be handled" (uri (first (psis constraint-topic))))))))))
+ (unless (or
+ (topictype-of-p constraint-topic roleplayer-constraint
+ topictype topictype-constraint
+ nil revision)
+ (topictype-of-p constraint-topic otherrole-constraint
+ topictype topictype-constraint
+ nil revision))
+ (error "Constraint-Topic \"~a\" could not be handled"
+ (uri (first (psis constraint-topic
+ :revision revision))))))))))
(list :abstract-topictype-constraints abstract-topictype-constraints
- :exclusive-instance-constraints (list :exclusive-constraints exclusive-instance-constraints
- :owner topic-instance)
+ :exclusive-instance-constraints
+ (list :exclusive-constraints exclusive-instance-constraints
+ :owner topic-instance)
:subjectidentifier-constraints subjectidentifier-constraints
:subjectlocator-constraints subjectlocator-constraints
:topicname-constraints topicname-constraints
@@ -1277,7 +1445,8 @@
:uniqueoccurrence-constraints uniqueoccurrence-constraints)))
-(defun get-all-constraint-topics-of-topic (topic-instance &key (treat-as 'type))
+(defun get-all-constraint-topics-of-topic (topic-instance &key (treat-as 'type)
+ (revision *TM-REVISION*))
"Returns a list of constraint-topics of the topics-instance's base type(s).
If topic c is instanceOf a and b, there will be returned all
constraint-topics of the topic types a and b.
@@ -1285,112 +1454,157 @@
defined for the supertypes or the types of the passed topic - all constraints
defined directly for the passed topic are ignored, unless the passed topic is
an instance of itself."
- (let ((akos-and-isas-of-this
- (remove-duplicates
- (if (eql treat-as 'type)
- (progn
- (topictype-p topic-instance)
- (get-all-upper-constrainted-topics topic-instance))
- (progn
- (valid-instance-p topic-instance)
- (let ((topictypes
- (get-direct-types-of-topic topic-instance))
- (all-constraints nil))
- (dolist (tt topictypes)
- (let ((upts
- (get-all-upper-constrainted-topics tt)))
- (dolist (upt upts)
- (pushnew upt all-constraints))))
- (remove-if #'(lambda(x)
- (when (eql x topic-instance)
- t))
- all-constraints)))))))
-
- (let ((all-abstract-topictype-constraints nil)
- (all-exclusive-instance-constraints nil)
- (all-subjectidentifier-constraints nil)
- (all-subjectlocator-constraints nil)
- (all-topicname-constraints nil)
- (all-topicoccurrence-constraints nil)
- (all-uniqueoccurrence-constraints nil))
- (loop for topic in akos-and-isas-of-this
- do (let ((constraint-topics-of-topic (get-direct-constraint-topics-of-topic topic)))
- (when (eq topic topic-instance)
- (dolist (item (getf constraint-topics-of-topic :abstract-topictype-constraints))
- (pushnew item all-abstract-topictype-constraints)))
- (let ((exclusive-instance-constraints
- (getf constraint-topics-of-topic :exclusive-instance-constraints)))
- (when (getf exclusive-instance-constraints :exclusive-constraints)
- (push exclusive-instance-constraints all-exclusive-instance-constraints)))
- (dolist (item (getf constraint-topics-of-topic :subjectidentifier-constraints))
- (pushnew item all-subjectidentifier-constraints))
- (dolist (item (getf constraint-topics-of-topic :subjectlocator-constraints))
- (pushnew item all-subjectlocator-constraints))
- (dolist (item (getf constraint-topics-of-topic :topicname-constraints))
- (pushnew item all-topicname-constraints))
- (dolist (item (getf constraint-topics-of-topic :topicoccurrence-constraints))
- (pushnew item all-topicoccurrence-constraints))
- (dolist (item (getf constraint-topics-of-topic :uniqueoccurrence-constraints))
- (pushnew item all-uniqueoccurrence-constraints))))
- (list :abstract-topictype-constraints all-abstract-topictype-constraints
- :exclusive-instance-constraints all-exclusive-instance-constraints
- :subjectidentifier-constraints all-subjectidentifier-constraints
- :subjectlocator-constraints all-subjectlocator-constraints
- :topicname-constraints all-topicname-constraints
- :topicoccurrence-constraints all-topicoccurrence-constraints
- :uniqueoccurrence-constraints all-uniqueoccurrence-constraints))))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance)
+ (symbol treat-as))
+ (let ((topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*
+ :revision revision)))
+ (let ((akos-and-isas-of-this
+ (remove-duplicates
+ (if (eql treat-as 'type)
+ (progn
+ (topictype-p topic-instance topictype topictype-constraint
+ nil revision)
+ (get-all-upper-constrainted-topics topic-instance
+ :revision revision))
+ (progn
+ (valid-instance-p topic-instance nil nil revision)
+ (let ((topictypes
+ (get-direct-types-of-topic topic-instance
+ :revision revision))
+ (all-constraints nil))
+ (dolist (tt topictypes)
+ (let ((upts
+ (get-all-upper-constrainted-topics tt
+ :revision revision)))
+ (dolist (upt upts)
+ (pushnew upt all-constraints))))
+ (remove-if #'(lambda(x)
+ (when (eql x topic-instance)
+ t))
+ all-constraints)))))))
+ (let ((all-abstract-topictype-constraints nil)
+ (all-exclusive-instance-constraints nil)
+ (all-subjectidentifier-constraints nil)
+ (all-subjectlocator-constraints nil)
+ (all-topicname-constraints nil)
+ (all-topicoccurrence-constraints nil)
+ (all-uniqueoccurrence-constraints nil))
+ (loop for topic in akos-and-isas-of-this
+ do (let ((constraint-topics-of-topic
+ (get-direct-constraint-topics-of-topic topic
+ :revision revision)))
+ (when (eq topic topic-instance)
+ (dolist (item (getf constraint-topics-of-topic
+ :abstract-topictype-constraints))
+ (pushnew item all-abstract-topictype-constraints)))
+ (let ((exclusive-instance-constraints
+ (getf constraint-topics-of-topic
+ :exclusive-instance-constraints)))
+ (when (getf exclusive-instance-constraints :exclusive-constraints)
+ (push exclusive-instance-constraints
+ all-exclusive-instance-constraints)))
+ (dolist (item (getf constraint-topics-of-topic
+ :subjectidentifier-constraints))
+ (pushnew item all-subjectidentifier-constraints))
+ (dolist (item (getf constraint-topics-of-topic
+ :subjectlocator-constraints))
+ (pushnew item all-subjectlocator-constraints))
+ (dolist (item (getf constraint-topics-of-topic
+ :topicname-constraints))
+ (pushnew item all-topicname-constraints))
+ (dolist (item (getf constraint-topics-of-topic
+ :topicoccurrence-constraints))
+ (pushnew item all-topicoccurrence-constraints))
+ (dolist (item (getf constraint-topics-of-topic
+ :uniqueoccurrence-constraints))
+ (pushnew item all-uniqueoccurrence-constraints))))
+ (list :abstract-topictype-constraints all-abstract-topictype-constraints
+ :exclusive-instance-constraints all-exclusive-instance-constraints
+ :subjectidentifier-constraints all-subjectidentifier-constraints
+ :subjectlocator-constraints all-subjectlocator-constraints
+ :topicname-constraints all-topicname-constraints
+ :topicoccurrence-constraints all-topicoccurrence-constraints
+ :uniqueoccurrence-constraints all-uniqueoccurrence-constraints)))))
-(defun get-direct-constraint-topics-of-association(associationtype-topic)
+(defun get-direct-constraint-topics-of-association(associationtype-topic
+ &key (revision *TM-REVISION*))
"Returns all direct constraint topics defined for associations if
the passed associationtype-topic"
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (associationtype-role (get-item-by-psi *associationtype-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (associationtypescope-constraint (get-item-by-psi *associationtypescope-constraint-psi*))
- (associationrole-constraint (get-item-by-psi *associationrole-constraint-psi*))
- (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*))
- (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*))
+ (declare (type (or integer null) revision)
+ (TopicC associationtype-topic))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (associationtype-role (get-item-by-psi *associationtype-role-psi*
+ :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (associationtypescope-constraint
+ (get-item-by-psi *associationtypescope-constraint-psi* :revision revision))
+ (associationrole-constraint (get-item-by-psi *associationrole-constraint-psi*
+ :revision revision))
+ (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*
+ :revision revision))
+ (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*
+ :revision revision))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*
+ :revision revision))
(associationrole-constraints nil)
(roleplayer-constraints nil)
(otherrole-constraints nil))
-
- (loop for role in (player-in-roles associationtype-topic)
- when (and (eq associationtype-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- do (loop for other-role in (roles (parent role))
- when (eq constraint-role (instance-of other-role))
- do (let ((constraint-topic (player other-role)))
+ (loop for role in (player-in-roles associationtype-topic :revision revision)
+ when (and (eq associationtype-role (instance-of role :revision revision))
+ (eq applies-to (instance-of (parent role :revision revision)
+ :revision revision)))
+ do (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
+ when (eq constraint-role (instance-of other-role :revision revision))
+ do (let ((constraint-topic (player other-role :revision revision)))
(cond
- ((topictype-of-p constraint-topic associationtypescope-constraint)
+ ((topictype-of-p constraint-topic associationtypescope-constraint
+ topictype topictype-constraint nil revision)
t) ;do nothing
- ((topictype-of-p constraint-topic associationrole-constraint)
+ ((topictype-of-p constraint-topic associationrole-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic associationrole-constraints))
- ((topictype-of-p constraint-topic roleplayer-constraint)
+ ((topictype-of-p constraint-topic roleplayer-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic roleplayer-constraints))
- ((topictype-of-p constraint-topic otherrole-constraint)
+ ((topictype-of-p constraint-topic otherrole-constraint
+ topictype topictype-constraint nil revision)
(pushnew constraint-topic otherrole-constraints))
(t
- (error "Constraint-Topic \"~a\" could not be handled" (uri (first (psis constraint-topic)))))))))
-
+ (error "Constraint-Topic \"~a\" could not be handled"
+ (uri (first (psis constraint-topic
+ :revision revision)))))))))
(list :associationrole-constraints associationrole-constraints
:roleplayer-constraints roleplayer-constraints
:otherrole-constraints otherrole-constraints)))
-(defun get-all-constraint-topics-of-association(associationtype-topic)
+(defun get-all-constraint-topics-of-association(associationtype-topic &key
+ (revision *TM-REVISION*))
"Returns all constraint topics defined for associations if
the passed associationtype-topic."
- (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*))
+ (declare (type (or integer null) revision)
+ (TopicC associationtype-topic))
+ (topictype-p associationtype-topic
+ (get-item-by-psi *associationtype-psi* :revision revision)
+ (is-type-constrained :what *associationtype-constraint-psi*
+ :revision revision) nil revision)
(let ((akos-and-isas-of-this
- (get-all-upper-constrainted-topics associationtype-topic)))
+ (get-all-upper-constrainted-topics associationtype-topic
+ :revision revision)))
(let ((all-associationrole-constraints nil)
(all-roleplayer-constraints nil)
(all-otherrole-constraints nil))
(loop for topic in akos-and-isas-of-this
do (let ((constraint-topics-of-topic
- (get-direct-constraint-topics-of-association topic)))
- (dolist (item (getf constraint-topics-of-topic :associationrole-constraints))
+ (get-direct-constraint-topics-of-association topic
+ :revision revision)))
+ (dolist (item (getf constraint-topics-of-topic
+ :associationrole-constraints))
(pushnew item all-associationrole-constraints))
(dolist (item (getf constraint-topics-of-topic :roleplayer-constraints))
(pushnew item all-roleplayer-constraints))
@@ -1401,105 +1615,173 @@
:otherrole-constraints all-otherrole-constraints))))
-(defun get-available-associations-of-topic(topic-instance &key (treat-as 'type))
+(defun get-available-associations-of-topic(topic-instance &key (treat-as 'type)
+ (revision *TM-REVISION*))
"Returns a list of topics decribing the available associationtype for the
passed topic."
- (let ((applies-to (get-item-by-psi *applies-to-psi*))
- (topictype-role (get-item-by-psi *topictype-role-psi*))
- (constraint-role (get-item-by-psi *constraint-role-psi*))
- (othertopictype-role (get-item-by-psi *othertopictype-role-psi*))
- (associationtype-role (get-item-by-psi *associationtype-role-psi*))
- (associationtype (get-item-by-psi *associationtype-psi*))
- (associationtype-constraint (get-item-by-psi *associationtype-constraint-psi*))
- (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*))
- (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*))
- (all-possible-player-topics
- (remove-duplicates
- (if (eql treat-as 'type)
- (topictype-p topic-instance)
- (valid-instance-p topic-instance)))))
- (let ((all-available-associationtypes
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance)
+ (symbol treat-as))
+ (let ((topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*
+ :revision revision)))
+ (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision))
+ (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (othertopictype-role (get-item-by-psi *othertopictype-role-psi*
+ :revision revision))
+ (associationtype-role (get-item-by-psi *associationtype-role-psi*
+ :revision revision))
+ (associationtype (get-item-by-psi *associationtype-psi* :revision revision))
+ (associationtype-constraint
+ (get-item-by-psi *associationtype-constraint-psi* :revision revision))
+ (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*
+ :revision revision))
+ (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*
+ :revision revision))
+ (all-possible-player-topics
(remove-duplicates
- (loop for possible-player-topic in all-possible-player-topics
- append (loop for role in (player-in-roles possible-player-topic)
- when (and (or (eq topictype-role (instance-of role))
- (eq othertopictype-role (instance-of role)))
- (eq applies-to (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (and (eq constraint-role (instance-of other-role))
- (or (topictype-of-p (player other-role) roleplayer-constraint)
- (topictype-of-p (player other-role) otherrole-constraint)))
- append (loop for c-role in (player-in-roles (player other-role))
- when (and (eq constraint-role (instance-of c-role))
- (eq applies-to (instance-of (parent c-role))))
- append (loop for type-role in (roles (parent c-role))
- when (eq associationtype-role (instance-of type-role))
- append (map 'list #'(lambda(x)
- (topictype-p x associationtype associationtype-constraint)
- x)
- (getf (list-subtypes (player type-role) associationtype associationtype-constraint) :subtypes))))))))))
- all-available-associationtypes)))
+ (if (eql treat-as 'type)
+ (topictype-p topic-instance topictype topictype-constraint nil
+ revision)
+ (valid-instance-p topic-instance nil nil revision)))))
+ (let ((all-available-associationtypes
+ (remove-duplicates
+ (loop for possible-player-topic in all-possible-player-topics
+ append
+ (loop for role in (player-in-roles possible-player-topic
+ :revision revision)
+ when (and (or (eq topictype-role
+ (instance-of role :revision revision))
+ (eq othertopictype-role
+ (instance-of role :revision revision)))
+ (eq applies-to
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ append
+ (loop for other-role in
+ (roles (parent role :revision revision)
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of other-role :revision revision))
+ (or (topictype-of-p
+ (player other-role :revision revision)
+ roleplayer-constraint topictype
+ topictype-constraint nil revision)
+ (topictype-of-p
+ (player other-role :revision revision)
+ otherrole-constraint topictype
+ topictype-constraint nil revision)))
+ append
+ (loop for c-role in
+ (player-in-roles
+ (player other-role :revision revision)
+ :revision revision)
+ when (and (eq constraint-role
+ (instance-of c-role :revision revision))
+ (eq applies-to
+ (instance-of (parent c-role
+ :revision revision)
+ :revision revision)))
+ append
+ (loop for type-role in
+ (roles (parent c-role :revision revision)
+ :revision revision)
+ when (eq associationtype-role
+ (instance-of type-role
+ :revision revision))
+ append
+ (map
+ 'list
+ #'(lambda(x)
+ (topictype-p x associationtype
+ associationtype-constraint
+ nil revision)
+ x)
+ (getf (list-subtypes
+ (player type-role :revision revision)
+ associationtype
+ associationtype-constraint nil
+ nil revision) :subtypes))))))))))
+ all-available-associationtypes))))
-(defun topics-to-json-list (topics)
+(defun topics-to-json-list (topics &key (revision *TM-REVISION*))
"Returns a json list of psi-lists."
+ (declare (list topics)
+ (type (or integer null) revision))
(json:encode-json-to-string
(map 'list #'(lambda(topic)
- (map 'list #'uri (psis topic)))
+ (map 'list #'uri (psis topic :revision revision)))
topics)))
(defun tree-view-to-json-string (tree-views)
"Returns a full tree-view as json-string."
(let ((json-string
- (concatenate 'string "["
- (if tree-views
- (let ((inner-string ""))
- (loop for tree-view in tree-views
- do (setf inner-string (concatenate 'string inner-string (node-to-json-string tree-view) ",")))
- (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]"))
- "null"))))
+ (concatenate
+ 'string "["
+ (if tree-views
+ (let ((inner-string ""))
+ (loop for tree-view in tree-views
+ do (setf inner-string
+ (concatenate 'string inner-string
+ (node-to-json-string tree-view) ",")))
+ (concatenate 'string (subseq inner-string 0
+ (- (length inner-string) 1)) "]"))
+ "null"))))
json-string))
-(defun make-tree-view ()
+
+(defun make-tree-view (&key (revision *TM-REVISION*))
"Returns a list of the form:
((<topictype> (direct-instances) (direc-subtypes)) (<...>));
-> direct-instances: (<any-topic> (direct-instances) (direct-subtypes))
-> direct-subtypes: (<any-topic> (direct-instances) (direct-subtypes))"
- (let ((topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*))
- (topictype-constraint (is-type-constrained)))
+ (declare (type (or integer null) revision))
+ (let ((topictype
+ (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision)))
(if topictype-constraint
(progn
(unless topictype
(error "From make-tree-view(): The topictype-constraint \"~a\" exists but the topictype \"~a\" is missing!"
- json-tmcl-constants::*topictype-constraint-psi*
- json-tmcl-constants::*topictype-psi*))
- (list (make-nodes topictype t t)))
+ *topictype-constraint-psi*
+ *topictype-psi*))
+ (list (make-nodes topictype t t :revision revision)))
(let ((tree-roots
- (get-all-tree-roots)))
+ (get-all-tree-roots :revision revision)))
(let ((tree-list
(loop for root in tree-roots
- collect (let ((l-is-type
- (handler-case (progn
- (topictype-p root topictype topictype-constraint)
- t)
- (Condition () nil)))
- (l-is-instance
- (handler-case (progn
- (valid-instance-p root)
- t)
- (Condition () nil))))
- (make-nodes root l-is-type l-is-instance)))))
+ collect
+ (let ((l-is-type
+ (handler-case
+ (progn
+ (topictype-p root topictype topictype-constraint
+ nil revision)
+ t)
+ (Condition () nil)))
+ (l-is-instance
+ (handler-case (progn
+ (valid-instance-p root nil nil revision)
+ t)
+ (Condition () nil))))
+ (make-nodes root l-is-type l-is-instance
+ :revision revision)))))
tree-list)))))
-(defun node-to-json-string(node)
+(defun node-to-json-string(node &key (revision *TM-REVISION*))
"Returns a json-object of the form
{topic: [<psis>], isType: <bool>, isInstance: <bool>,
instances: [<nodes>], subtypes: [<nodes>]}."
+ (declare (type (or integer null) revision)
+ (list node))
(let ((topic-psis
- (concatenate 'string "\"topic\":"
- (json:encode-json-to-string (map 'list #'d:uri (d:psis (getf node :topic))))))
+ (concatenate
+ 'string "\"topic\":"
+ (json:encode-json-to-string
+ (map 'list #'d:uri (d:psis (getf node :topic) :revision revision)))))
(is-type
(concatenate 'string "\"isType\":"
(if (getf node :is-type)
@@ -1511,82 +1793,116 @@
"true"
"false")))
(instances
- (concatenate 'string "\"instances\":"
- (if (getf node :instances)
- (let ((inner-string "["))
- (loop for instance-node in (getf node :instances)
- do (setf inner-string (concatenate 'string inner-string (node-to-json-string instance-node) ",")))
- (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]"))
- "null")))
+ (concatenate
+ 'string "\"instances\":"
+ (if (getf node :instances)
+ (let ((inner-string "["))
+ (loop for instance-node in (getf node :instances)
+ do (setf inner-string
+ (concatenate
+ 'string inner-string
+ (node-to-json-string instance-node :revision revision)
+ ",")))
+ (concatenate 'string (subseq inner-string 0
+ (- (length inner-string) 1)) "]"))
+ "null")))
(subtypes
- (concatenate 'string "\"subtypes\":"
- (if (getf node :subtypes)
- (let ((inner-string "["))
- (loop for instance-node in (getf node :subtypes)
- do (setf inner-string (concatenate 'string inner-string (node-to-json-string instance-node) ",")))
- (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]"))
- "null"))))
- (concatenate 'string "{" topic-psis "," is-type "," is-instance "," instances "," subtypes"}")))
+ (concatenate
+ 'string "\"subtypes\":"
+ (if (getf node :subtypes)
+ (let ((inner-string "["))
+ (loop for instance-node in (getf node :subtypes)
+ do (setf inner-string
+ (concatenate 'string inner-string
+ (node-to-json-string instance-node
+ :revision revision)
+ ",")))
+ (concatenate 'string (subseq inner-string 0
+ (- (length inner-string) 1)) "]"))
+ "null"))))
+ (concatenate 'string "{" topic-psis "," is-type "," is-instance "," instances
+ "," subtypes"}")))
-(defun make-nodes (topic-instance is-type is-instance)
+(defun make-nodes (topic-instance is-type is-instance &key (revision *TM-REVISION*))
"Creates a li of nodes.
A node looks like
- (:topic <topic> :is-type <bool> :is-instance <bool> :instances <node> :subtypes <nodes>)."
- (declare (d:TopicC topic-instance))
- (let ((topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*))
- (topictype-constraint (is-type-constrained)))
+ (:topic <topic> :is-type <bool> :is-instance <bool> :instances <node>
+ :subtypes <nodes>)."
+ (declare (TopicC topic-instance)
+ (type (or integer null) revision))
+ (let ((topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision)))
(let ((isas-of-this
- (map 'list #'(lambda(z)
- (let ((l-is-type
- (handler-case (progn
- (topictype-p z topictype topictype-constraint)
- t)
- (Condition () nil)))
- (l-is-instance
- (handler-case (progn
- (valid-instance-p z)
- t)
- (Condition () nil))))
- (list :topic z :is-type l-is-type :is-instance l-is-instance)))
+ (map
+ 'list
+ #'(lambda(z)
+ (let ((l-is-type
+ (handler-case
+ (progn
+ (topictype-p z topictype topictype-constraint
+ nil revision)
+ t)
+ (Condition () nil)))
+ (l-is-instance
+ (handler-case (progn
+ (valid-instance-p z nil nil revision)
+ t)
+ (Condition () nil))))
+ (list :topic z :is-type l-is-type :is-instance l-is-instance)))
(remove-duplicates
(remove-if #'null
- (remove-if #'(lambda(x) (when (eql topic-instance x)
- t))
- (get-direct-instances-of-topic topic-instance))))))
+ (remove-if
+ #'(lambda(x) (when (eql topic-instance x)
+ t))
+ (get-direct-instances-of-topic topic-instance
+ :revision revision))))))
(akos-of-this
- (map 'list #'(lambda(z)
- (let ((l-is-type
- (handler-case (progn
- (topictype-p z topictype topictype-constraint)
- t)
- (Condition () nil)))
- (l-is-instance
- (handler-case (progn
- (valid-instance-p z)
- t)
- (Condition () nil))))
- (list :topic z :is-type l-is-type :is-instance l-is-instance)))
+ (map 'list
+ #'(lambda(z)
+ (let ((l-is-type
+ (handler-case
+ (progn
+ (topictype-p z topictype topictype-constraint
+ nil revision)
+ t)
+ (Condition () nil)))
+ (l-is-instance
+ (handler-case (progn
+ (valid-instance-p z nil nil revision)
+ t)
+ (Condition () nil))))
+ (list :topic z :is-type l-is-type :is-instance l-is-instance)))
(remove-duplicates
- (remove-if #'null
- (remove-if #'(lambda(x) (when (eql topic-instance x)
- t))
- (get-direct-subtypes-of-topic topic-instance)))))))
+ (remove-if
+ #'null
+ (remove-if #'(lambda(x) (when (eql topic-instance x)
+ t))
+ (get-direct-subtypes-of-topic topic-instance
+ :revision revision)))))))
(let ((cleaned-isas ;;all constraint topics are removed
- (clean-topic-entries isas-of-this))
+ (clean-topic-entries isas-of-this :revision revision))
(cleaned-akos ;;all constraint topics are removed
- (clean-topic-entries akos-of-this)))
+ (clean-topic-entries akos-of-this :revision revision)))
(list :topic topic-instance
:is-type is-type
:is-instance is-instance
:instances (map 'list #'(lambda(x)
- (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance)))
+ (make-nodes (getf x :topic)
+ (getf x :is-type)
+ (getf x :is-instance)
+ :revision revision))
cleaned-isas)
:subtypes (map 'list #'(lambda(x)
- (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance)))
+ (make-nodes (getf x :topic)
+ (getf x :is-type)
+ (getf x :is-instance)
+ :revision revision))
cleaned-akos))))))
-(defun clean-topic-entries(isas-or-akos)
+
+(defun clean-topic-entries(isas-or-akos &key (revision *TM-REVISION*))
+ "Removes all TMCL-topics from the passed topic-list."
(remove-if
#'null
(map 'list
@@ -1602,33 +1918,31 @@
(string= (uri psi) *scopetype-psi*)
(string= (uri psi) *schema-psi*))
top-entry))
- (psis (getf top-entry :topic))))
+ (psis (getf top-entry :topic) :revision revision)))
top-entry))
isas-or-akos)))
-(defun get-all-tree-roots ()
+(defun get-all-tree-roots (&key (revision *TM-REVISION*))
"Returns all topics that are no instanceOf and no subtype
of any other topic."
- (let ((all-topics
- (remove-if #'null
- (map 'list
- #'(lambda(top)
- (when (d:find-item-by-revision top 0)
- top))
- (elephant:get-instances-by-class 'd:TopicC)))))
- (remove-if #'null
- (map 'list #'(lambda(x)
- (let ((isas-of-x
- (remove-if #'(lambda(y)
- (when (eql y x)
- t))
- (get-direct-types-of-topic x)))
- (akos-of-x
- (remove-if #'(lambda(y)
- (when (eql y x)
- t))
- (get-direct-supertypes-of-topic x))))
- (unless (or isas-of-x akos-of-x)
- x)))
- all-topics))))
\ No newline at end of file
+ (declare (type (or integer null) revision))
+ (let ((all-topics (get-all-topics revision)))
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(x)
+ (let ((isas-of-x
+ (remove-if #'(lambda(y)
+ (when (eql y x)
+ t))
+ (get-direct-types-of-topic x :revision revision)))
+ (akos-of-x
+ (remove-if
+ #'(lambda(y)
+ (when (eql y x)
+ t))
+ (get-direct-supertypes-of-topic x :revision revision))))
+ (unless (or isas-of-x akos-of-x)
+ x)))
+ all-topics))))
\ No newline at end of file
Modified: trunk/src/json/json_tmcl_constants.lisp
==============================================================================
--- trunk/src/json/json_tmcl_constants.lisp (original)
+++ trunk/src/json/json_tmcl_constants.lisp Sun Oct 10 05:41:19 2010
@@ -53,9 +53,6 @@
(in-package :json-tmcl-constants)
-
-(defparameter *schema-psi* "http://psi.topicmaps.org/tmcl/schema")
-(defparameter *constraint-psi* "http://psi.topicmaps.org/tmcl/constraint")
(defparameter *topictype-psi* "http://psi.topicmaps.org/tmcl/topic-type")
(defparameter *topictype-constraint-psi* "http://psi.topicmaps.org/tmcl/topic-type-constraint")
(defparameter *associationtype-psi* "http://psi.topicmaps.org/tmcl/association-type")
@@ -94,4 +91,6 @@
(defparameter *otherroletype-role-psi* "http://psi.topicmaps.org/tmcl/other-role-type-role")
(defparameter *associationtype-role-psi* "http://psi.topicmaps.org/tmcl/association-type-role")
(defparameter *associationrole-constraint-psi* "http://psi.topicmaps.org/tmcl/association-role-constraint")
-(defparameter *roletype-role-psi* "http://psi.topicmaps.org/tmcl/role-type-role")
\ No newline at end of file
+(defparameter *roletype-role-psi* "http://psi.topicmaps.org/tmcl/role-type-role")
+(defparameter *schema-psi* "http://psi.topicmaps.org/tmcl/schema")
+(defparameter *constraint-psi* "http://psi.topicmaps.org/tmcl/constraint")
\ No newline at end of file
Modified: trunk/src/json/json_tmcl_validation.lisp
==============================================================================
--- trunk/src/json/json_tmcl_validation.lisp (original)
+++ trunk/src/json/json_tmcl_validation.lisp Sun Oct 10 05:41:19 2010
@@ -19,261 +19,319 @@
(in-package :json-tmcl)
-(defun abstract-p (topic-instance)
+(defun abstract-p (topic-instance &key (revision *TM-REVISION*))
"Returns t if this topic type is an abstract topic type."
- (let ((constraint-role (get-item-by-psi *constraint-role-psi*))
- (topictype-role (get-item-by-psi *topictype-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*))
- (abstract-topictype-constraint (get-item-by-psi *abstract-topictype-constraint-psi*)))
-
- (loop for role in (player-in-roles topic-instance)
- when (and (eq topictype-role (instance-of role))
- (eq applies-to (instance-of (parent role))))
- return (loop for other-role in (roles (parent role))
- when (and (eq constraint-role (instance-of other-role))
- (topictype-of-p (player other-role) abstract-topictype-constraint))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance))
+ (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision))
+ (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision))
+ (applies-to (get-item-by-psi *applies-to-psi* :revision revision))
+ (abstract-topictype-constraint
+ (get-item-by-psi *abstract-topictype-constraint-psi* :revision revision)))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (and (eq topictype-role (instance-of role :revision revision))
+ (eq applies-to (instance-of (parent role :revision revision)
+ :revision revision)))
+ return (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
+ when (and (eq constraint-role (instance-of other-role
+ :revision revision))
+ (topictype-of-p (player other-role :revision revision)
+ abstract-topictype-constraint nil nil
+ nil revision))
return t))))
-(defun topictype-of-p (topic-instance type-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained))
- checked-topics)
+(defun topictype-of-p (topic-instance type-instance &optional
+ (topictype (get-item-by-psi *topictype-psi* :revision 0))
+ (topictype-constraint (is-type-constrained :revision 0))
+ checked-topics (revision *TM-REVISION*))
"Returns a list of all types and supertypes of this topic if this topic is a
valid instance-topic of the type-topic called type-instance. TMCL 4.4.2.
When the type-instance is set to nil there will be checked only if the
topic-instance is a valid instance."
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance)
+ (type (or TopicC null) topictype-constraint)
+ (list checked-topics))
(let ((current-checked-topics (append checked-topics (list topic-instance)))
- (isas-of-this (get-direct-types-of-topic topic-instance))
- (akos-of-this (get-direct-supertypes-of-topic topic-instance)))
-
+ (isas-of-this (get-direct-types-of-topic topic-instance :revision revision))
+ (akos-of-this (get-direct-supertypes-of-topic topic-instance
+ :revision revision)))
(when (eq topic-instance topictype)
t)
-
(when (and (not isas-of-this)
(not akos-of-this))
(return-from topictype-of-p nil))
-
(loop for isa-of-this in isas-of-this
- do (let ((found-topics (topictype-p isa-of-this topictype topictype-constraint)))
+ do (let ((found-topics
+ (topictype-p isa-of-this topictype topictype-constraint nil revision)))
(when (not found-topics)
(return-from topictype-of-p nil))
(dolist (item found-topics)
(pushnew item current-checked-topics))))
-
(loop for ako-of-this in akos-of-this
when (not (find ako-of-this current-checked-topics :test #'eq))
- do (let ((found-topics (topictype-of-p ako-of-this type-instance topictype topictype-constraint current-checked-topics)))
+ do (let ((found-topics
+ (topictype-of-p ako-of-this type-instance topictype
+ topictype-constraint current-checked-topics
+ revision)))
(when (not found-topics)
(return-from topictype-of-p nil))
(dolist (item found-topics)
(pushnew item current-checked-topics))))
-
(if type-instance
(when (find type-instance current-checked-topics)
current-checked-topics)
current-checked-topics)))
-(defun topictype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained))
- (checked-topics nil))
+(defun topictype-p (topic-instance &optional
+ (topictype (get-item-by-psi *topictype-psi* :revision 0))
+ (topictype-constraint (is-type-constrained :revision 0))
+ (checked-topics nil) (revision *TM-REVISION*))
"Returns a list of all instanceOf-topics and all Supertypes of this topic
if this topic is a valid topic (-type). I.e. the passed topic is the
topictype or it is an instanceOf of the topictype or it is a subtype of
the topictype. TMDM 7.2 + TMDM 7.3"
- ;(format t "~%~%topictype-p ~a~%" (uri (first (psis topic-instance))))
+ (declare (type (or integer null) revision)
+ (type (or TopicC null) topictype topic-instance)
+ (list checked-topics))
(let ((current-checked-topics (append checked-topics (list topic-instance)))
- (akos-of-this (get-direct-supertypes-of-topic topic-instance))
- (isas-of-this (get-direct-types-of-topic topic-instance)))
-
+ (akos-of-this (get-direct-supertypes-of-topic topic-instance
+ :revision revision))
+ (isas-of-this (get-direct-types-of-topic topic-instance :revision revision)))
(when (eq topictype topic-instance)
(return-from topictype-p current-checked-topics))
-
(when (not (union akos-of-this isas-of-this :test #'eq))
(when topictype-constraint
- ;(return-from topictype-p nil))
- (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))
+ (error "~a is not a valid type for ~a"
+ (uri (first (psis topic-instance :revision revision)))
+ (uri (first (psis topictype :revision revision)))))
(return-from topictype-p current-checked-topics))
-
(let ((akos-are-topictype nil))
(loop for ako-of-this in akos-of-this
when (not (find ako-of-this current-checked-topics))
- do (let ((further-topics (topictype-p ako-of-this topictype topictype-constraint)))
+ do (let ((further-topics
+ (topictype-p ako-of-this topictype topictype-constraint
+ nil revision)))
(if further-topics
(progn
(dolist (item further-topics)
(pushnew item current-checked-topics))
(pushnew ako-of-this akos-are-topictype))
(when topictype-constraint
- ;(return-from topictype-p nil)))))
- (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype))))))))
-
+ (error "~a is not a valid type for ~a"
+ (uri (first (psis topic-instance :revision revision)))
+ (uri (first (psis topictype :revision revision))))))))
(when isas-of-this
(let ((topictype-topics-of-isas nil))
(loop for isa-of-this in isas-of-this
- do (let ((topic-akos (subtype-p isa-of-this topictype)))
+ do (let ((topic-akos (subtype-p isa-of-this topictype nil revision)))
(when topic-akos
(pushnew isa-of-this topictype-topics-of-isas)
(pushnew isa-of-this current-checked-topics)
(dolist (item topic-akos)
(pushnew item current-checked-topics)))))
-
(when (and (not topictype-topics-of-isas)
(not akos-are-topictype)
topictype-constraint)
- ;(return-from topictype-p nil))
- (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))
-
+ (error "~a is not a valid type for ~a"
+ (uri (first (psis topic-instance :revision revision)))
+ (uri (first (psis topictype :revision revision)))))
(loop for isa-of-this in isas-of-this
when (and (not (find isa-of-this current-checked-topics :test #'eq))
(not (find isa-of-this topictype-topics-of-isas :test #'eq)))
- do (let ((further-topic-types (topictype-p isa-of-this topictype topictype-constraint current-checked-topics)))
+ do (let ((further-topic-types
+ (topictype-p isa-of-this topictype topictype-constraint
+ current-checked-topics revision)))
(if further-topic-types
(dolist (item further-topic-types)
(pushnew item current-checked-topics))
(when topictype-constraint
- ;(return-from topictype-p nil))))))))
- (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))))))))
+ (error "~a is not a valid type for ~a"
+ (uri (first (psis topic-instance :revision revision)))
+ (uri (first (psis topictype :revision revision)))))))))))
current-checked-topics))
-(defun subtype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) (checked-topics nil))
+(defun subtype-p (topic-instance &optional
+ (topictype (get-item-by-psi *topictype-psi* :revision 0))
+ (checked-topics nil) (revision *TM-REVISION*))
"Returns a list of all supertypes of the passed topic if the passed topic
is not an instanceOf any other topic but a subtype of some supertypes
of a topictype or it is the topictype-topic itself.
This function isn't useable as a standalone function - it's only necessary
for a special case in the function topictype-p."
- ;(format t "~%~%subtype-p ~a~%" (uri (first (psis topic-instance))))
- (let ((current-checked-topics (remove-duplicates (append checked-topics (list topic-instance)))))
-
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance)
+ (type (or TopicC null) topictype)
+ (list checked-topics))
+ (let ((current-checked-topics
+ (remove-duplicates (append checked-topics (list topic-instance)))))
(when (eq topictype topic-instance)
(return-from subtype-p current-checked-topics))
-
- (when (get-direct-types-of-topic topic-instance)
+ (when (get-direct-types-of-topic topic-instance :revision revision)
(return-from subtype-p nil))
-
- (let ((supertypes-of-this (get-direct-supertypes-of-topic topic-instance)))
+ (let ((supertypes-of-this
+ (get-direct-supertypes-of-topic topic-instance :revision revision)))
(when (not supertypes-of-this)
(return-from subtype-p nil))
(when supertypes-of-this
(loop for supertype-of-this in supertypes-of-this
when (not (find supertype-of-this current-checked-topics :test #'eq))
- do (let ((further-supertypes (subtype-p topictype supertype-of-this current-checked-topics)))
+ do (let ((further-supertypes
+ (subtype-p topictype supertype-of-this current-checked-topics
+ revision)))
(when (not further-supertypes)
(return-from subtype-p nil))
-
(dolist (item further-supertypes)
(pushnew item current-checked-topics))))))
-
current-checked-topics))
-(defun get-direct-types-of-topic(topic-instance)
+(defun get-direct-types-of-topic(topic-instance &key (revision *TM-REVISION*))
"Returns the direct types of the topic as a list passed to this function.
This function only returns the types of the type-instance-relationship -> TMDM 7.2
This function was defined for the use in topictype-p and not for a standalone
usage."
- (let ((type-instance (get-item-by-psi *type-instance-psi*))
- (instance (get-item-by-psi *instance-psi*))
- (type (get-item-by-psi *type-psi*)))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance))
+ (let ((type-instance (get-item-by-psi *type-instance-psi* :revision revision))
+ (instance (get-item-by-psi *instance-psi* :revision revision))
+ (type (get-item-by-psi *type-psi* :revision revision)))
(let ((topic-types
- (loop for role in (player-in-roles topic-instance)
- when (eq instance (instance-of role))
- collect (loop for other-role in (roles (parent role))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (eq instance (instance-of role :revision revision))
+ collect (loop for other-role in
+ (roles (parent role :revision revision) :revision revision)
when (and (not (eq role other-role))
- (eq type-instance (instance-of (parent role)))
- (eq type (instance-of other-role)))
- return (player other-role)))))
+ (eq type-instance (instance-of
+ (parent role :revision revision)
+ :revision revision))
+ (eq type (instance-of other-role
+ :revision revision)))
+ return (player other-role :revision revision)))))
(when topic-types
(remove-if #'null topic-types)))))
-(defun get-direct-instances-of-topic(topic-instance)
+(defun get-direct-instances-of-topic(topic-instance &key (revision *TM-REVISION*))
"Returns the direct instances of the topic as a list.
This function only returns the types of the type-instance-relationship -> TMDM 7.2
This function was defined for the use in topictype-p and not for a standalone
usage."
- (let ((type-instance (get-item-by-psi *type-instance-psi*))
- (instance (get-item-by-psi *instance-psi*))
- (type (get-item-by-psi *type-psi*)))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance))
+ (let ((type-instance (get-item-by-psi *type-instance-psi* :revision revision))
+ (instance (get-item-by-psi *instance-psi* :revision revision))
+ (type (get-item-by-psi *type-psi* :revision revision)))
(let ((topic-instances
- (loop for role in (player-in-roles topic-instance)
- when (eq type (instance-of role))
- collect (loop for other-role in (roles (parent role))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (eq type (instance-of role :revision revision))
+ collect (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
when (and (not (eq role other-role))
- (eq type-instance (instance-of (parent role)))
- (eq instance (instance-of other-role)))
- return (player other-role)))))
+ (eq type-instance
+ (instance-of (parent role :revision revision)
+ :revision revision))
+ (eq instance (instance-of other-role
+ :revision revision)))
+ return (player other-role :revision revision)))))
(when topic-instances
(remove-if #'null topic-instances)))))
-(defun get-direct-supertypes-of-topic(topic-instance)
+(defun get-direct-supertypes-of-topic(topic-instance &key (revision *TM-REVISION*))
"Returns the direct supertypes of the topic as a list passed to this function.
This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3.
This function was defined for the use in topictype-p and not for a standalone
usage."
- (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
- (supertype (get-item-by-psi *supertype-psi*))
- (subtype (get-item-by-psi *subtype-psi*)))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance))
+ (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi* :revision revision))
+ (supertype (get-item-by-psi *supertype-psi* :revision revision))
+ (subtype (get-item-by-psi *subtype-psi* :revision revision)))
(let ((supertypes
- (loop for role in (player-in-roles topic-instance)
- when (eq subtype (instance-of role))
- append (loop for other-role in (roles (parent role))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (eq subtype (instance-of role :revision revision))
+ append (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
when (and (not (eq role other-role))
- (eq supertype-subtype (instance-of (parent role)))
- (eq supertype (instance-of other-role)))
+ (eq supertype-subtype
+ (instance-of (parent role :revision revision)
+ :revision revision))
+ (eq supertype
+ (instance-of other-role :revision revision)))
collect (player other-role)))))
(when supertypes
(remove-if #'null supertypes)))))
-(defun get-direct-subtypes-of-topic(topic-instance)
+(defun get-direct-subtypes-of-topic(topic-instance &key (revision *TM-REVISION*))
"Returns the direct subtypes of the topic as a list.
- This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3.
+ This function only returns the types of the supertype-subtype-relationship
+ -> TMDM 7.3.
This function was defined for the use in topictype-p and not for a standalone
usage."
- (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
- (supertype (get-item-by-psi *supertype-psi*))
- (subtype (get-item-by-psi *subtype-psi*)))
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance))
+ (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi* :revision revision))
+ (supertype (get-item-by-psi *supertype-psi* :revision revision))
+ (subtype (get-item-by-psi *subtype-psi* :revision revision)))
(let ((subtypes
- (loop for role in (player-in-roles topic-instance)
- when (eq supertype (instance-of role))
- append (loop for other-role in (roles (parent role))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (eq supertype (instance-of role :revision revision))
+ append (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
when (and (not (eq role other-role))
- (eq supertype-subtype (instance-of (parent role)))
- (eq subtype (instance-of other-role)))
- collect (player other-role)))))
+ (eq supertype-subtype
+ (instance-of (parent role :revision revision)
+ :revision revision))
+ (eq subtype (instance-of other-role
+ :revision revision)))
+ collect (player other-role :revision revision)))))
(when subtypes
(remove-if #'null subtypes)))))
-(defun list-subtypes (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained))
- (checked-topics nil) (valid-subtypes nil))
+(defun list-subtypes (topic-instance &optional
+ (topictype (get-item-by-psi *topictype-psi* :revision 0))
+ (topictype-constraint (is-type-constrained :revision 0))
+ (checked-topics nil) (valid-subtypes nil)
+ (revision *TM-REVISION*))
"Returns all valid subtypes of a topic, e.g.:
nametype-constraint ako constraint .
first-name isa nametype .
first-name-1 ako first-name .
// ...
- The return value is a named list of the form (:subtypes (<topic> <...>) :checked-topics (<topic> <...>)"
+ The return value is a named list of the form (:subtypes (<topic> <...>)
+ :checked-topics (<topic> <...>)"
(let ((current-checked-topics (append checked-topics (list topic-instance))))
-
- (handler-case (topictype-p topic-instance topictype topictype-constraint)
- (condition () (return-from list-subtypes (list :subtypes nil :checked-topics current-checked-topics))))
-
- (let ((subtype (get-item-by-psi *subtype-psi*))
- (supertype (get-item-by-psi *supertype-psi*))
- (supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
+ (handler-case (topictype-p topic-instance topictype topictype-constraint
+ nil revision)
+ (condition () (return-from list-subtypes
+ (list :subtypes nil :checked-topics current-checked-topics))))
+ (let ((subtype (get-item-by-psi *subtype-psi* :revision revision))
+ (supertype (get-item-by-psi *supertype-psi* :revision revision))
+ (supertype-subtype (get-item-by-psi *supertype-subtype-psi*
+ :revision revision))
(current-valid-subtypes (append valid-subtypes (list topic-instance))))
- (loop for role in (player-in-roles topic-instance)
- when (and (eq supertype (instance-of role))
- (eq supertype-subtype (instance-of (parent role))))
- do (loop for other-role in (roles (parent role))
- do (when (and (eq subtype (instance-of other-role))
- (not (find (player other-role) current-checked-topics)))
+ (loop for role in (player-in-roles topic-instance :revision revision)
+ when (and (eq supertype (instance-of role :revision revision))
+ (eq supertype-subtype
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ do (loop for other-role in (roles (parent role :revision revision)
+ :revision revision)
+ do (when (and (eq subtype (instance-of other-role :revision revision))
+ (not (find (player other-role :revision revision)
+ current-checked-topics)))
(let ((new-values
- (list-subtypes (player other-role) topictype topictype-constraint current-checked-topics current-valid-subtypes)))
+ (list-subtypes (player other-role :revision revision)
+ topictype topictype-constraint
+ current-checked-topics
+ current-valid-subtypes revision)))
(dolist (item (getf new-values :subtypes))
(pushnew item current-valid-subtypes))
(dolist (item (getf new-values :checked-topics))
@@ -281,172 +339,209 @@
(list :subtypes current-valid-subtypes :checked-topics current-checked-topics))))
-(defun list-instances (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (is-type-constrained)))
- "Returns the topic-instance, all subtypes found by the function list-subtypes and all direct
- instances for the found subtypes."
+(defun list-instances (topic-instance &optional
+ (topictype (get-item-by-psi *topictype-psi* :revision 0))
+ (topictype-constraint (is-type-constrained :revision 0))
+ (revision *TM-REVISION*))
+ "Returns the topic-instance, all subtypes found by the function list-subtypes
+ and all direct instances for the found subtypes."
(let ((all-subtypes-of-this
- (getf (list-subtypes topic-instance topictype topictype-constraint) :subtypes))
- (type (get-item-by-psi *type-psi*))
- (instance (get-item-by-psi *instance-psi*))
- (type-instance (get-item-by-psi *type-instance-psi*)))
+ (getf (list-subtypes topic-instance topictype topictype-constraint
+ nil nil revision)
+ :subtypes))
+ (type (get-item-by-psi *type-psi* :revision revision))
+ (instance (get-item-by-psi *instance-psi* :revision revision))
+ (type-instance (get-item-by-psi *type-instance-psi* :revision revision)))
(let ((all-instances-of-this
(remove-duplicates
(loop for subtype-of-this in all-subtypes-of-this
- append (loop for role in (player-in-roles subtype-of-this)
- when (and (eq type (instance-of role))
- (eq type-instance (instance-of (parent role))))
- append (loop for other-role in (roles (parent role))
- when (eq instance (instance-of other-role))
- collect (player other-role)))))))
+ append (loop for role in (player-in-roles subtype-of-this
+ :revision revision)
+ when (and (eq type (instance-of role :revision revision))
+ (eq type-instance
+ (instance-of (parent role :revision revision)
+ :revision revision)))
+ append (loop for other-role in
+ (roles (parent role :revision revision)
+ :revision revision)
+ when (eq instance (instance-of other-role
+ :revision revision))
+ collect (player other-role :revision revision)))))))
(let ((all-subtypes-of-all-instances
(remove-if #'null
(remove-duplicates
(loop for subtype in all-instances-of-this
- append (getf (list-subtypes subtype nil nil) :subtypes))))))
+ append (getf
+ (list-subtypes subtype topictype
+ nil nil nil revision)
+ :subtypes))))))
(union all-instances-of-this
(remove-if #'null
(map 'list #'(lambda(x)
(handler-case (progn
- (topictype-of-p x nil)
+ (topictype-of-p x nil nil nil
+ nil revision)
x)
(condition () nil)))
all-subtypes-of-all-instances)))))))
-(defun valid-instance-p (topic-instance &optional (akos-checked nil) (all-checked-topics nil))
+(defun valid-instance-p (topic-instance &optional
+ (akos-checked nil) (all-checked-topics nil)
+ (revision *TM-REVISION*))
"Returns a list of all checked topics or throws an exception if the given
topic is not a valid instance of any topictype in elephant."
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance)
+ (list akos-checked all-checked-topics))
(let ((isas-of-this
- (get-direct-types-of-topic topic-instance))
+ (get-direct-types-of-topic topic-instance :revision revision))
(akos-of-this
- (get-direct-supertypes-of-topic topic-instance))
- (psi-of-this (uri (first (psis topic-instance))))
- (topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*))
- (topictype-constraint (is-type-constrained))
+ (get-direct-supertypes-of-topic topic-instance :revision revision))
+ (psi-of-this (uri (first (psis topic-instance :revision revision))))
+ (topictype (get-item-by-psi *topictype-psi* :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision))
(local-all-checked-topics all-checked-topics)
(local-akos-checked))
-
(when (not topictype-constraint)
(return-from valid-instance-p (list topic-instance)))
-
(when (and topictype-constraint
(not topictype))
- (error (format nil "From valid-instance-p(): The topic \"~a\" does not exist - please create it or remove the topic \"~a\""
- json-tmcl-constants::*topictype-psi* (d:uri (first (d:psis topictype-constraint))))))
-
+ (error "From valid-instance-p(): The topic \"~a\" does not exist - please create it or remove the topic \"~a\""
+ *topictype-psi*
+ (uri (first (psis topictype-constraint :revision revision)))))
(when (eql topic-instance topictype)
- (return-from valid-instance-p (remove-duplicates (append all-checked-topics (list topic-instance)))))
-
+ (return-from valid-instance-p
+ (remove-duplicates (append all-checked-topics (list topic-instance)))))
(unless (or isas-of-this akos-of-this)
- (error (format nil "The topic \"~a\" is not a valid topic-instance for any topic-type" psi-of-this)))
-
+ (error "The topic \"~a\" is not a valid topic-instance for any topic-type"
+ psi-of-this))
(when (find topic-instance akos-checked)
(return-from valid-instance-p all-checked-topics))
-
(pushnew topic-instance local-all-checked-topics)
(pushnew topic-instance local-akos-checked)
-
(dolist (isa isas-of-this)
(handler-case (let ((topics
- (topictype-p isa topictype topictype-constraint)))
+ (topictype-p isa topictype topictype-constraint
+ nil revision)))
(dolist (top topics)
(pushnew top local-all-checked-topics)))
- (condition (err) (error (format nil "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a" psi-of-this err)))))
+ (condition (err) (error "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a"
+ psi-of-this err))))
(dolist (ako akos-of-this)
- (when (not (handler-case (let ((topics
- (topictype-p ako topictype topictype-constraint all-checked-topics)))
+ (when (not (handler-case
+ (let ((topics
+ (topictype-p ako topictype topictype-constraint
+ all-checked-topics revision)))
(dolist (top topics)
(pushnew top local-all-checked-topics))
(pushnew ako local-akos-checked)
topics)
(condition () nil)))
- (handler-case (let ((topics
- (valid-instance-p ako akos-checked (append all-checked-topics (list ako)))))
+ (handler-case
+ (let ((topics
+ (valid-instance-p ako akos-checked (append all-checked-topics
+ (list ako)) revision)))
(dolist (top topics)
(pushnew top local-all-checked-topics)
(pushnew top local-akos-checked))
topics)
- (condition (err) (error (format nil "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a" psi-of-this err))))))
+ (condition (err) (error "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a"
+ psi-of-this err)))))
local-all-checked-topics))
-(defun return-all-tmcl-types ()
+(defun return-all-tmcl-types (&key (revision *TM-REVISION*))
"Returns all topics that are valid tmcl-types"
- (let ((all-topics
- (json-exporter::clean-topics
- (elephant:get-instances-by-class 'd:TopicC)))
- (topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*))
- (topictype-constraint (is-type-constrained)))
+ (declare (type (or integer null) revision))
+ (let ((all-topics (get-all-topics revision))
+ (topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*
+ :revision revision))
+ (topictype-constraint (is-type-constrained :revision revision)))
(let ((all-types
- (remove-if #'null
- (map 'list #'(lambda(x)
- (handler-case (progn
- (topictype-p x topictype topictype-constraint)
- x)
- (condition () nil))) all-topics))))
+ (remove-if
+ #'null
+ (map 'list #'(lambda(x)
+ (handler-case
+ (progn
+ (topictype-p x topictype topictype-constraint
+ nil revision)
+ x)
+ (condition () nil))) all-topics))))
(let ((not-abstract-types
(remove-if #'null
(map 'list #'(lambda(x)
- (unless (json-tmcl:abstract-p x)
+ (unless (abstract-p x :revision revision)
x))
all-types))))
not-abstract-types))))
-(defun return-all-tmcl-instances ()
+(defun return-all-tmcl-instances (&key (revision *TM-REVISION*))
"Returns all topics that are valid instances of any topic type.
The validity is only oriented on the typing of topics, e.g.
type-instance or supertype-subtype."
- (let ((all-topics
- (json-exporter::clean-topics
- (elephant:get-instances-by-class 'd:TopicC))))
+ (declare (type (or integer null) revision))
+ (let ((all-topics (get-all-topics revision)))
(let ((valid-instances
- (remove-if #'null
- (map 'list #'(lambda(x)
- (handler-case (progn
- (valid-instance-p x)
- x)
- (condition () nil))) all-topics))))
+ (remove-if
+ #'null
+ (map 'list #'(lambda(x)
+ (handler-case (progn
+ (valid-instance-p x nil nil revision)
+ x)
+ (condition () nil))) all-topics))))
valid-instances)))
-(defun is-type-constrained (&key (what json-tmcl::*topictype-constraint-psi*))
- "Returns nil if there is no type-constraint otherwise the instance of the type-constraint."
- (let ((topictype-constraint (d:get-item-by-psi what)))
+(defun is-type-constrained (&key (what *topictype-constraint-psi*)
+ (revision *TM-REVISION*))
+ "Returns nil if there is no type-constraint otherwise the instance of
+ the type-constraint."
+ (declare (string what)
+ (type (or integer null) revision))
+ (let ((topictype-constraint (get-item-by-psi what :revision revision)))
(when topictype-constraint
(let ((ttc
(remove-duplicates
- (remove-if #'null
- (remove-if #'(lambda(x) (when (eql topictype-constraint x)
- t))
- (get-direct-instances-of-topic topictype-constraint))))))
+ (remove-if
+ #'null
+ (remove-if #'(lambda(x) (when (eql topictype-constraint x)
+ t))
+ (get-direct-instances-of-topic topictype-constraint
+ :revision revision))))))
ttc))))
-(defun list-all-supertypes (topic-instance &optional (checked-topics nil))
+(defun list-all-supertypes (topic-instance &optional (checked-topics nil)
+ (revision *TM-REVISION*))
"Returns all supertypes of the given topic recursively."
+ (declare (type (or integer null) revision)
+ (TopicC topic-instance)
+ (list checked-topics))
(let ((current-checked-topics (append checked-topics (list topic-instance)))
- (akos-of-this (get-direct-supertypes-of-topic topic-instance)))
+ (akos-of-this (get-direct-supertypes-of-topic topic-instance
+ :revision revision)))
(dolist (ako-of-this akos-of-this)
(when (not (find ako-of-this current-checked-topics))
(let ((new-checked-topics
- (list-all-supertypes ako-of-this current-checked-topics)))
+ (list-all-supertypes ako-of-this current-checked-topics revision)))
(dolist (new-topic new-checked-topics)
(pushnew new-topic current-checked-topics)))))
current-checked-topics))
-(defun get-all-upper-constrainted-topics (topic)
+(defun get-all-upper-constrainted-topics (topic &key (revision *TM-REVISION*))
"Returns all topics that are supertypes or direct types
of the given topic-type. So all direct constraints of the found
topics are valid constraints for the given one."
+ (declare (TopicC topic)
+ (type (or integer null) revision))
;; find all direct types
(let ((direct-isas-of-this
- (get-direct-types-of-topic topic)))
-
+ (get-direct-types-of-topic topic :revision revision)))
;; find all supertypes (recursive -> transitive relationship
(let ((all-akos-of-this
- (list-all-supertypes topic)))
+ (list-all-supertypes topic nil revision)))
(remove-duplicates (union direct-isas-of-this all-akos-of-this)))))
\ No newline at end of file
Modified: trunk/src/model/changes.lisp
==============================================================================
--- trunk/src/model/changes.lisp (original)
+++ trunk/src/model/changes.lisp Sun Oct 10 05:41:19 2010
@@ -7,21 +7,20 @@
;;+-----------------------------------------------------------------------------
-;-*- standard-indent:2; tab-width:2; indent-tabs-mode:nil -*-
(in-package :datamodel)
(defun get-all-revisions ()
"Returns an ordered set of the start dates of all revisions in the engine"
- ;TODO: this is a very inefficient implementation... it would equally
- ;be possible to have a separate object that stored all such
- ;revisions and only make the search from the latest version that's
- ;stored their
- (let
- ((revision-set))
+ ;TODO: this is a very inefficient implementation... it would equally
+ ;be possible to have a separate object that stored all such
+ ;revisions and only make the search from the latest version that's
+ ;stored their
+ (let ((revision-set))
(dolist (vi (elephant:get-instances-by-class 'VersionInfoC))
(pushnew (start-revision vi) revision-set))
(sort revision-set #'<)))
+
(defun get-all-revisions-for-tm (tm-id)
"Returns an ordered set of the start dates of all revisions in the
engine for this Topic Map"
@@ -29,63 +28,86 @@
((tm (get-item-by-item-identifier tm-id :revision 0))
(tops-and-assocs (when tm (union (topics tm) (associations tm))))
(revision-set nil))
- ;(format t "tops-and-assocs: ~a~&" (mapcan #'versions tops-and-assocs))
(dolist (vi (mapcan #'versions tops-and-assocs))
- ;(format t "(start-revision vi): ~a~&" (start-revision vi))
(pushnew (start-revision vi) revision-set))
(sort revision-set #'<)))
-(defun find-associations-for-topic (top)
- "find all associations of this topic"
- (let
- ((type-instance-topic
- (d:identified-construct
- (elephant:get-instance-by-value 'PersistentIdC
- 'uri
- "http://psi.topicmaps.org/iso13250/model/type-instance"))))
- (remove
- type-instance-topic
- (remove-duplicates
- (map 'list #'parent (player-in-roles top)))
- :key #'instance-of)))
+(defgeneric find-all-associations (instance &key revision)
+ (:documentation "Finds all associations for a topic.")
+ (:method ((instance TopicC) &key (revision *TM-REVISION*))
+ (declare (type (or integer null) revision))
+ (remove-duplicates
+ (map 'list #'(lambda(role)
+ (parent role :revision revision))
+ (player-in-roles instance :revision revision)))))
+
+
+(defgeneric find-associations (instance &key revision)
+ (:documentation "Finds all associations of this topic except
+ type-instance-associations.")
+ (:method ((instance TopicC) &key (revision *TM-REVISION*))
+ (declare (type (or integer null) revision))
+ (let ((type-instance-topic
+ (d:identified-construct
+ (elephant:get-instance-by-value
+ 'PersistentIdC 'uri *type-instance-psi*))))
+ (remove-if
+ #'(lambda(assoc)
+ (eql (instance-of assoc :revision revision)
+ type-instance-topic))
+ (find-all-associations instance :revision revision)))))
-(defgeneric find-referenced-topics (construct)
+(defgeneric find-referenced-topics (construct &key revision)
(:documentation "find all the topics that are references from this construct as type, scope or player, as the case may be"))
-(defmethod find-referenced-topics ((characteristic CharacteristicC))
- "characteristics are scopable + typable"
+
+(defmethod find-referenced-topics ((characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ "characteristics are scopable + typable + reifiable"
(append
- (when (reifier characteristic)
- (list (reifier characteristic)))
- (themes characteristic)
- (when (instance-of-p characteristic)
- (list (instance-of characteristic)))
+ (when (reifier characteristic :revision revision)
+ (list (reifier characteristic :revision revision)))
+ (themes characteristic :revision revision)
+ (when (instance-of characteristic :revision revision)
+ (list (instance-of characteristic :revision revision)))
+ (when (and (typep characteristic 'NameC)
+ (variants characteristic :revision revision))
+ (remove-if #'null
+ (loop for var in (variants characteristic :revision revision)
+ append (find-referenced-topics var :revision revision))))
(when (and (typep characteristic 'OccurrenceC)
(> (length (charvalue characteristic)) 0)
(eq #\# (elt (charvalue characteristic) 0)))
- (list (get-item-by-id (subseq (charvalue characteristic) 1))))))
+ (list (get-item-by-id (subseq (charvalue characteristic) 1)
+ :revision revision)))))
-(defmethod find-referenced-topics ((role RoleC))
+(defmethod find-referenced-topics ((role RoleC)
+ &key (revision *TM-REVISION*))
(append
- (when (reifier role)
- (list (reifier role)))
- (list (instance-of role))
- (list (player role))))
+ (when (reifier role :revision revision)
+ (list (reifier role :revision revision)))
+ (list (instance-of role :revision revision))
+ (list (player role :revision revision))))
+
-(defmethod find-referenced-topics ((association AssociationC))
+(defmethod find-referenced-topics ((association AssociationC)
+ &key (revision *TM-REVISION*))
"associations are scopable + typable"
(append
- (when (reifier association)
- (list (reifier association)))
- (list (instance-of association))
- (themes association)
- (mapcan #'find-referenced-topics (roles association))))
+ (when (reifier association :revision revision)
+ (list (reifier association :revision revision)))
+ (list (instance-of association :revision revision))
+ (themes association :revision revision)
+ (mapcan #'(lambda(role)
+ (find-referenced-topics role :revision revision))
+ (roles association :revision revision))))
-(defmethod find-referenced-topics ((top TopicC))
+(defmethod find-referenced-topics ((top TopicC)
+ &key (revision *TM-REVISION*))
"Part 1b of the eGov-Share spec states:
# for each topicname in T export a topic stub for each scope topic
# for each occurrence in T export a topic stub for the occurrence type (if it exists)
@@ -98,52 +120,186 @@
(remove
top
(append
- (list-instanceOf top)
- (mapcan #'find-referenced-topics (names top))
- (mapcan #'find-referenced-topics (mapcan #'variants (names top)))
- (mapcan #'find-referenced-topics (occurrences top))
- (mapcan #'find-referenced-topics (find-associations-for-topic top))))))
+ (list-instanceOf top :revision revision)
+ (mapcan #'(lambda(name)
+ (find-referenced-topics name :revision revision))
+ (names top :revision revision))
+ (mapcan #'(lambda(variant)
+ (find-referenced-topics variant :revision revision))
+ (mapcan #'variants (names top :revision revision)))
+ (mapcan #'(lambda(occ)
+ (find-referenced-topics occ :revision revision))
+ (occurrences top :revision revision))
+ (mapcan #'(lambda(assoc)
+ (find-referenced-topics assoc :revision revision))
+ (find-associations top :revision revision))))))
+(defgeneric initial-version-p (version-info)
+ (:documentation "A helper function for changed-p that returns the passed
+ version-info object if it is the initial version-info object,
+ i.e. it owns the smallest start-revsion of the
+ version-construct.")
+ (:method ((version-info VersionInfoC))
+ (unless (find-if #'(lambda(vi)
+ (< (start-revision vi) (start-revision version-info)))
+ (versions (versioned-construct version-info)))
+ version-info)))
+
+
(defgeneric changed-p (construct revision)
- (:documentation "Has the topic map construct changed in a given revision? 'Changed' can mean:
+ (:documentation "Has the topic map construct changed in a given revision?
+ 'Changed' can mean:
* newly created
+ * deletion of an element
* modified through the addition or removal of identifiers
- * (for associations) modified through the addition or removal of identifiers in the association or one of its roles
- * (for topics) modified through the addition or removal of identifiers or characteristics
- * (for topics) modified through the addition or removal of an association in which it is first player"))
+ * (for associations) modified through the addition or removal of
+ identifiers in the association or one of its roles
+ * (for topics) modified through the addition or removal of identifiers
+ or characteristics
+ * (for topics) modified through the addition or removal of an association
+ in which it is first player"))
+
(defmethod changed-p ((construct TopicMapConstructC) (revision integer))
- "The 'normal' case: changes only when new identifiers are added"
- (find revision (versions construct) :test #'= :key #'start-revision))
+ "changed-p returns nil for TopicMapConstructCs that are not specified
+ more detailed. The actual algorithm is processed for all
+ VersionedConstructCs."
+ (declare (ignorable revision))
+ nil)
-;There is quite deliberately no method specialized on AssociationC as
-;copy-item-identifiers for Associations already guarantees that the
-;version history of an association is only updated when the
-;association itself is really updated
-
-(defmethod changed-p ((topic TopicC) (revision integer))
- "A topic is changed if one of its child elements (identifiers or
-characteristics) or one of the associations in which it is first player has changed"
- (let*
- ((first-player-in-associations
- (remove-if-not
- (lambda (association)
- (eq (player (first (roles association)))
- topic))
- (find-associations-for-topic topic)))
- (all-constructs
- (union
- (get-all-identifiers-of-construct topic)
- (union
- (names topic)
- (union
- (occurrences topic)
- first-player-in-associations)))))
- (some
- (lambda (construct)
- (changed-p construct revision))
- all-constructs)))
+
+(defmethod changed-p ((construct PointerC) (revision integer))
+ "Returns t if the PointerC was added to a construct the first
+ time in the passed revision"
+ (let ((version-info (some #'(lambda(pointer-association)
+ (changed-p pointer-association revision))
+ (slot-p construct 'identified-construct))))
+ (when version-info
+ (initial-version-p version-info))))
+
+
+(defmethod changed-p ((construct VersionedConstructC) (revision integer))
+ "changed-p returns t if there exist a VersionInfoC with the given start-revision."
+ (let ((version-info
+ (find revision (versions construct) :test #'= :key #'start-revision)))
+ (when version-info
+ (initial-version-p version-info))))
+
+
+(defmethod changed-p ((construct CharacteristicC) (revision integer))
+ "Returns t if the CharacteristicC was added to a construct in the passed
+ revision or if <ReifiableConstructC> changed."
+ (or (call-next-method)
+ (let ((version-info
+ (some #'(lambda(characteristic-association)
+ (changed-p characteristic-association revision))
+ (slot-p construct 'parent))))
+ (when version-info
+ (initial-version-p version-info)))))
+
+
+(defmethod changed-p ((construct RoleC) (revision integer))
+ "Returns t if the RoleC was added to a construct in the passed
+ revision or if <ReifiableConstructC> changed."
+ (or (call-next-method)
+ (let ((version-info
+ (some #'(lambda(role-association)
+ (changed-p role-association revision))
+ (slot-p construct 'parent))))
+ (when version-info
+ (initial-version-p version-info)))))
+
+
+(defgeneric end-revision-p (construct revision)
+ (:documentation "A helper function for changed-p. It returns the latest
+ version-info if the passed versioned-construct was
+ marked-as-deleted in the version that is given.")
+ (:method ((construct VersionedConstructC) (revision integer))
+ (let ((version-info (find revision (versions construct)
+ :key #'end-revision :test #'=)))
+ (when (and version-info
+ (not
+ (find-if
+ #'(lambda(vi)
+ (or (> (end-revision vi) (end-revision version-info))
+ (= (end-revision vi) 0)))
+ (versions construct))))
+ version-info))))
+
+
+(defmethod changed-p ((construct ReifiableConstructC) (revision integer))
+ "Returns t if a ReifiableConstructC changed in the given version, i.e.
+ an item-identifier or reifier was added to the construct itself."
+ (or (some #'(lambda(vc)
+ (changed-p vc revision))
+ (union (item-identifiers construct :revision revision)
+ (let ((reifier-top (reifier construct :revision revision)))
+ (when reifier-top
+ (list reifier-top)))))
+ (some #'(lambda(vc)
+ (end-revision-p vc revision))
+ (union (slot-p construct 'item-identifiers)
+ (slot-p construct 'reifier)))))
+
+
+(defmethod changed-p ((construct NameC) (revision integer))
+ "Returns t if the passed NameC changed in the given version, i.e.
+ the <ReifiableConstructC> characteristics or the variants changed."
+ (or (call-next-method)
+ (some #'(lambda(var)
+ (changed-p var revision))
+ (variants construct :revision revision))
+ (some #'(lambda(vc)
+ (end-revision-p vc revision))
+ (slot-p construct 'variants))))
+
+
+(defmethod changed-p ((construct TopicC) (revision integer))
+ "Returns t if the passed TopicC changed in the given version, i.e.
+ the <ReifiableConstructC>, <PersistentIdC>, <LocatorC>, <NameC>,
+ <OccurrenceC>, <AssociationC> or the reified-construct changed."
+ (or (call-next-method)
+ (some #'(lambda(vc)
+ (changed-p vc revision))
+ (union
+ (union
+ (union (psis construct :revision revision)
+ (locators construct :revision revision))
+ (union (names construct :revision revision)
+ (occurrences construct :revision revision)))
+ (remove-if-not
+ (lambda (assoc)
+ (eq (player (first (roles assoc :revision revision))
+ :revision revision)
+ construct))
+ (find-all-associations construct :revision revision))))
+ (let ((rc (reified-construct construct :revision revision)))
+ (when rc
+ (let ((ra (find-if #'(lambda(reifier-assoc)
+ (eql (reifiable-construct reifier-assoc) rc))
+ (slot-p construct 'reified-construct))))
+ (changed-p ra revision))))
+ (some #'(lambda(vc)
+ (end-revision-p vc revision))
+ (union (union (union (slot-p construct 'psis)
+ (slot-p construct 'locators))
+ (union (slot-p construct 'names)
+ (slot-p construct 'occurrences)))
+ (slot-p construct 'reified-construct)))))
+
+
+
+(defmethod changed-p ((construct AssociationC) (revision integer))
+ "Returns t if the passed AssociationC changed in the given version, i.e.
+ the <RoleC> or the <ReifiableConstructC> changed."
+ (or (call-next-method)
+ (some #'(lambda(role)
+ (changed-p role revision))
+ (roles construct :revision revision))
+ (some #'(lambda(vc)
+ (end-revision-p vc revision))
+ (slot-p construct 'roles))))
(defpclass FragmentC ()
@@ -191,15 +347,20 @@
cached-fragments
(remove
nil
- (map 'list
- (lambda (top)
- (when (changed-p top revision)
- (make-instance 'FragmentC
- :revision revision
- :associations (find-associations-for-topic top) ;TODO: this quite probably introduces code duplication with query: Check!
- :referenced-topics (find-referenced-topics top)
- :topic top)))
- (elephant:get-instances-by-class 'TopicC))))))
+ (map
+ 'list
+ (lambda (top)
+ (when (changed-p top revision)
+ (make-instance 'FragmentC
+ :revision revision
+ :associations (find-associations
+ top :revision revision)
+ ;TODO: this quite probably introduces
+ ;code duplication with query: Check!
+ :referenced-topics (find-referenced-topics
+ top :revision revision)
+ :topic top)))
+ (get-all-topics revision))))))
(defun get-fragment (unique-id)
"get a fragment by its unique id"
@@ -208,79 +369,47 @@
'unique-id
unique-id))
-(defgeneric mark-as-deleted (construct &key source-locator revision)
- (:documentation "Mark a construct as deleted if it comes from the source indicated by
-source-locator"))
-
-(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision)
- "Mark a topic as deleted if it comes from the source indicated by
-source-locator"
- (declare (ignorable source-locator))
- (let
- ((last-version ;the last active version
- (find 0 (versions construct) :key #'end-revision)))
- (when last-version
- (setf (end-revision last-version) revision))))
-
-(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
- "Mark an association and its roles as deleted"
- (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator))
- (roles ass))
- (call-next-method))
-
-(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision)
- "Mark a topic as deleted if it comes from the source indicated by
-source-locator"
- ;;Part 1b, 1.4.3.3.1:
- ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
- ;; * Let SI be the value of TopicSI element in ATOM entry E
- ;; * feed F contains E
- ;; * entry E references topic fragment TF
- ;; * Let LTM be the local topic map
- ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
- ;; * For all names, occurrences and associations in which T plays a role, TMC
- ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
- ;; * Merge in the fragment TF using SP as the base all generated source locators.
-
- (when
- (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top))
- (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator))
- (names top))
- (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator))
- (occurrences top))
- (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator))
- (find-associations-for-topic top))
- (call-next-method)))
-
(defgeneric add-source-locator (construct &key source-locator revision)
(:documentation "adds an item identifier to a given construct based on the source
-locator and an internally generated id (ideally a uuid)"))
+ locator and an internally generated id (ideally a uuid)"))
+
(defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision)
- (declare (ignorable revision))
+ (declare (integer revision))
(unless
- (some (lambda (ii) (string-starts-with (uri ii) source-locator)) (item-identifiers construct))
+ (some (lambda (ii)
+ (string-starts-with (uri ii) source-locator))
+ (item-identifiers construct :revision revision))
(let
((ii-uri (format nil "~a/~d" source-locator (internal-id construct))))
- (make-instance 'ItemIdentifierC :uri ii-uri :identified-construct construct :start-revision revision))))
+ (make-construct 'ItemIdentifierC
+ :uri ii-uri
+ :identified-construct construct
+ :start-revision revision))))
+
(defmethod add-source-locator ((top TopicC) &key source-locator revision)
;topics already have the source locator in (at least) one PSI, so we
;do not need to add an extra item identifier to them. However, we
;need to do that for all their characteristics + associations
- (mapc (lambda (name) (add-source-locator name :revision revision :source-locator source-locator))
- (names top))
- (mapc (lambda (occ) (add-source-locator occ :revision revision :source-locator source-locator))
- (occurrences top))
- (mapc (lambda (ass) (add-source-locator ass :revision revision :source-locator source-locator))
- (find-associations-for-topic top)))
+ (mapc (lambda (name)
+ (add-source-locator name :revision revision
+ :source-locator source-locator))
+ (names top :revision revision))
+ (mapc (lambda (occ)
+ (add-source-locator occ :revision revision
+ :source-locator source-locator))
+ (occurrences top :revision revision))
+ (mapc (lambda (ass)
+ (add-source-locator ass :revision revision
+ :source-locator source-locator))
+ (find-associations top :revision revision)))
(defun create-latest-fragment-of-topic (topic-psi)
"Returns the latest fragment of the passed topic-psi"
(declare (string topic-psi))
- (let ((topic
- (get-item-by-psi topic-psi)))
+ (let ((topic (get-latest-topic-by-psi topic-psi)))
(when topic
(let ((start-revision
(start-revision
@@ -297,16 +426,17 @@
existing-fragment
(make-instance 'FragmentC
:revision start-revision
- :associations (find-associations-for-topic topic)
- :referenced-topics (find-referenced-topics topic)
+ :associations (find-associations
+ topic :revision start-revision)
+ :referenced-topics (find-referenced-topics
+ topic :revision start-revision)
:topic topic)))))))
(defun get-latest-fragment-of-topic (topic-psi)
"Returns the latest existing fragment of the passed topic-psi."
(declare (string topic-psi))
- (let ((topic
- (get-item-by-psi topic-psi)))
+ (let ((topic (get-latest-topic-by-psi topic-psi)))
(when topic
(let ((existing-fragments
(elephant:get-instances-by-value 'FragmentC 'topic topic)))
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Sun Oct 10 05:41:19 2010
@@ -7,510 +7,1072 @@
;;+-----------------------------------------------------------------------------
-;-*- standard-indent: 2; indent-tabs-mode: nil -*-
(defpackage :datamodel
(:use :cl :elephant :constants)
(:nicknames :d)
(:import-from :exceptions
- missing-reference-error
- no-identifier-error
- duplicate-identifier-error
- object-not-found-error)
- (:export :AssociationC ;; types
- :CharacteristicC
- :FragmentC
- :IdentifierC
- :IdentityC
- :ItemIdentifierC
- :NameC
- :OccurrenceC
- :PersistentIdC
- :ReifiableConstructC
- :RoleC
- :ScopableC
- :SubjectLocatorC
- :TopicC
- :TopicIdentificationC
- :TopicMapC
- :TopicMapConstructC
+ duplicate-identifier-error
+ object-not-found-error
+ missing-argument-error
+ not-mergable-error
+ tm-reference-error)
+ (:import-from :constants
+ *xml-string*
+ *instance-psi*)
+ (:export ;;classes
+ :TopicMapConstructC
+ :VersionedConstructC
+ :ReifiableConstructC
+ :ScopableC
:TypableC
+ :TopicMapC
+ :AssociationC
+ :RoleC
+ :CharacteristicC
+ :OccurrenceC
+ :NameC
:VariantC
-
- ;; functions and slot accessors
- :in-topicmaps
- :add-to-topicmap
- :add-source-locator
- :associations
- :changed-p
- :charvalue
- :check-for-duplicate-identifiers
- :datatype
- :equivalent-constructs
- :find-item-by-revision
- :find-most-recent-revision
- :get-all-revisions
- :get-all-revisions-for-tm
- :get-fragment
- :get-fragments
- :get-revision
- :get-item-by-content
- :get-item-by-id
- :get-item-by-item-identifier
- :get-item-by-psi
- :identified-construct
- :identified-construct-p
- :in-topicmap
- :internal-id
- :instance-of
- :instance-of-p
- :item-identifiers
- :item-identifiers-p
- :list-instanceOf
- :list-super-types
- :locators
- :locators-p
- :make-construct
- :mark-as-deleted
- :names
- :namevalue
- :occurrences
- :name
- :parent
- :player
- :player-in-roles
- :players
- :psis
- :psis-p
- :referenced-topics
- :revision
- :RoleC-p
- :roleid
- :roles
- :themes
- :xtm-id
- :xtm-id-p
- :topic
- :topicid
- :topic-identifiers
- :topics
- :unique-id
- :uri
- :uri-p
+ :PointerC
+ :IdentifierC
+ :PersistentIdC
+ :ItemIdentifierC
+ :SubjectLocatorC
+ :TopicIdentificationC
+ :TopicC
+ :FragmentC
+
+ ;;methods, functions and macros
+ :xtm-id
+ :uri
+ :identified-construct
+ :item-identifiers
+ :add-item-identifier
+ :delete-item-identifier
+ :reifier
+ :add-reifier
+ :delete-reifier
+ :find-item-by-revision
+ :find-most-recent-revision
+ :themes
+ :add-theme
+ :delete-theme
+ :instance-of
+ :add-type
+ :delete-type
+ :parent
+ :add-parent
+ :delete-parent
+ :variants
+ :add-variant
+ :delete-variant
+ :player
+ :add-player
+ :delete-player
+ :roles
+ :add-role
+ :delete-role
+ :associations
+ :topics
+ :add-to-tm
+ :delete-from-tm
+ :psis
+ :add-psi
+ :delete-psi
+ :topic-identifiers
+ :add-topic-identifier
+ :delete-topic-identifier
+ :topic-id
+ :locators
+ :add-locator
+ :delete-locator
+ :names
+ :add-name
+ :delete-name
+ :occurrences
+ :add-occurrence
+ :delete-occurrence
+ :player-in-roles
:used-as-type
:used-as-theme
- :variants
- :xor
- :create-latest-fragment-of-topic
+ :datatype
+ :charvalue
+ :reified-construct
+ :mark-as-deleted
+ :marked-as-deleted-p
+ :in-topicmaps
+ :delete-construct
+ :get-revision
+ :get-item-by-id
+ :get-item-by-psi
+ :get-item-by-item-identifier
+ :get-item-by-locator
+ :get-item-by-content
+ :string-integer-p
+ :with-revision
:get-latest-fragment-of-topic
- :reified
- :reifier
- :add-reifier
- :remove-reifier
-
- :*current-xtm* ;; special variables
- :*TM-REVISION*
+ :create-latest-fragment-of-topic
+ :PointerC-p
+ :IdentifierC-p
+ :SubjectLocatorC-p
+ :PersistentIdC-p
+ :ItemIdentifierC-p
+ :TopicIdentificationC-p
+ :CharacteristicC-p
+ :OccurrenceC-p
+ :NameC-p
+ :VariantC-p
+ :ScopableC-p
+ :TypableC-p
+ :TopicC-p
+ :AssociationC-p
+ :RoleC-p
+ :TopicMapC-p
+ :ReifiableConstructC-p
+ :TopicMapConstructC-p
+ :VersionedConstructC-p
+ :make-construct
+ :list-instanceOf
+ :list-super-types
+ :in-topicmap
+ :string-starts-with
+ :get-fragments
+ :get-fragment
+ :get-all-revisions
+ :unique-id
+ :topic
+ :referenced-topics
+ :revision
+ :get-all-revisions-for-tm
+ :add-source-locator
+ :changed-p
+ :check-for-duplicate-identifiers
+ :find-item-by-content
+ :rec-remf
+ :get-all-topics
+ :get-all-associations
+ :get-all-tms
+
+
+ ;;globals
+ :*TM-REVISION*
+ :*CURRENT-XTM*))
- :with-revision ;;macros
+(in-package :datamodel)
- :string-starts-with ;;helpers
- ))
-(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))
-(in-package :datamodel)
+;;TODO: implement a macro with-merge-constructs, that merges constructs
+;; after all operations in the body were called
-(defparameter *current-xtm* nil "Represents the currently active TM")
-(defmacro find-max-elem (candidate-list &key (relop #'> relop-p) (key #'identity key-p))
- "Given a non-empty list, return the maximum element in the list.
- If provided, then relop must be a relational operator that determines the ordering;
- else #'> is used. The keyword parameter key may name a function that is used to extract
- the sort key; otherwise the elements themselves are the sort keys."
- (let
- ((candidate-list-value-name (gensym))
- (relop-value-name (gensym))
- (key-value-name (gensym))
- (best-seen-cand-name (gensym))
- (max-key-name (gensym))
- (inspected-cand-name (gensym))
- (inspected-key-name (gensym)))
- (let
- ((max-key-init (if key-p
- `(funcall ,key-value-name ,best-seen-cand-name)
- best-seen-cand-name))
- (inspected-key-init (if key-p
- `(funcall ,key-value-name ,inspected-cand-name)
- inspected-cand-name))
- (relexp (if relop-p
- `(funcall ,relop-value-name ,inspected-key-name ,max-key-name)
- `(> ,inspected-key-name ,max-key-name))))
- (let
- ((initializers `((,candidate-list-value-name ,candidate-list)
- (,best-seen-cand-name (first ,candidate-list-value-name))
- (,max-key-name ,max-key-init))))
- (when relop-p
- (push `(,relop-value-name ,relop) initializers))
- (when key-p
- (push `(,key-value-name ,key) initializers))
- `(let*
- ,initializers
- (dolist (,inspected-cand-name (rest ,candidate-list-value-name))
- (let
- ((,inspected-key-name ,inspected-key-init))
- (when ,relexp
- (setf ,best-seen-cand-name ,inspected-cand-name)
- (setf ,max-key-name ,inspected-key-name))))
- ,best-seen-cand-name)))))
+;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *TM-REVISION* 0)
+
+(defparameter *CURRENT-XTM* nil "Represents the currently active TM.")
+
+
+;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; versioning
+(defpclass VersionInfoC()
+ ((start-revision :initarg :start-revision
+ :accessor start-revision
+ :type integer
+ :initform 0
+ :documentation "The start-revision of the version's
+ interval of a versioned object.")
+ (end-revision :initarg :end-revision
+ :accessor end-revision
+ :type integer
+ :initform 0
+ :documentation "The end-revision of the version's interval
+ of a versioned object.")
+ (versioned-construct :initarg :versioned-construct
+ :accessor versioned-construct
+ :associate VersionedConstructC
+ :documentation "The reference of the versioned
+ object that is described by this
+ VersionInfoC-object."))
+ (:documentation "A VersionInfoC-object describes the revision information
+ of a versioned object in intervals starting by the value
+ start-revision and ending by the value end-revision - 1.
+ end-revision=0 means always the latest version."))
+
+
+(defpclass VersionedConstructC()
+ ((versions :initarg :versions
+ :accessor versions
+ :inherit t
+ :associate (VersionInfoC versioned-construct)
+ :documentation "Version infos for former versions of this base
+ class.")))
+
+
+;;; base classes ...
+(defpclass TopicMapConstructC()
+ ()
+ (:documentation "An abstract base class for all classes that describes
+ Topic Maps data."))
+
+
+(defpclass ScopableC()
+ ((themes :associate (ScopeAssociationC scopable-construct)
+ :inherit t
+ :documentation "Contains all association-objects that contain the
+ actual scope-topics."))
+ (:documentation "An abstract base class for all constructs that are scoped."))
+
+
+(defpclass TypableC()
+ ((instance-of :associate (TypeAssociationC typable-construct)
+ :inherit t
+ :documentation "Contains all association-objects that contain
+ the actual type-topic."))
+ (:documentation "An abstract base class for all typed constructcs."))
+
+
+(defpclass DatatypableC()
+ ((datatype :accessor datatype
+ :initarg :datatype
+ :initform constants:*xml-string*
+ :type string
+ :index t
+ :documentation "The XML Schema datatype of the occurrencevalue
+ (optional, always IRI for resourceRef)."))
+ (:documentation "An abstract base class for characteristics that own
+ an xml-datatype."))
+
+
+;;; pointers ...
+(defpclass PointerC(TopicMapConstructC)
+ ((uri :initarg :uri
+ :accessor uri
+ :inherit t
+ :type string
+ :initform (error (make-missing-argument-condition "From PointerC(): uri must be set for a pointer" 'uri ':uri))
+ :index t
+ :documentation "The actual value of a pointer, i.e. uri or ID.")
+ (identified-construct :associate (PointerAssociationC identifier)
+ :inherit t
+ :documentation "Associates a association-object that
+ additionally stores some
+ version-infos."))
+ (:documentation "An abstract base class for all pointers."))
+
+
+(defpclass IdentifierC(PointerC)
+ ()
+ (:documentation "An abstract base class for all TM-Identifiers."))
+
+
+(defpclass TopicIdentificationC(PointerC)
+ ((xtm-id :initarg :xtm-id
+ :accessor xtm-id
+ :type string
+ :initform (error (make-missing-argument-condition "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" 'xtm-id ':xtm-id))
+ :index t
+ :documentation "ID of the TM this identification came from."))
+ (:index t)
+ (:documentation "Identify topic items through generalized topic-ids.
+ A topic may have many original topicids, the class
+ representing one of them."))
+
+
+(defpclass SubjectLocatorC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-locator that contains an uri-value and an
+ association to SubjectLocatorAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-identifier that contains an uri-value and an
+ association to PersistentIdAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "An item-identifier that contains an uri-value and an
+ association to ItemIdAssociationC's which are in turn
+ associated with RiefiableConstructC's."))
+
+
+;;; reifiables ...
+(defpclass ReifiableConstructC(TopicMapConstructC)
+ ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+ :inherit t
+ :documentation "A relation to all item-identifiers of
+ this construct.")
+ (reifier :associate (ReifierAssociationC reifiable-construct)
+ :inherit t
+ :documentation "A relation to a reifier-topic."))
+ (:documentation "Reifiable constructs as per TMDM."))
+
+
+(defpclass AssociationC(ReifiableConstructC ScopableC TypableC
+ VersionedConstructC)
+ ((roles :associate (RoleAssociationC parent-construct)
+ :documentation "Contains all association-objects of all roles this
+ association contains.")
+ (in-topicmaps :associate (TopicMapC associations)
+ :many-to-many t
+ :documentation "List of all topic maps this association is
+ part of"))
+ (:index t)
+ (:documentation "Association in a Topic Map"))
+
+
+(defpclass RoleC(ReifiableConstructC TypableC)
+ ((parent :associate (RoleAssociationC role)
+ :documentation "Associates this object with a role-association.")
+ (player :associate (PlayerAssociationC parent-construct)
+ :documentation "Associates this object with a player-association.")))
+
+
+(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
+ ((topics :associate (TopicC in-topicmaps)
+ :many-to-many t
+ :accessor topics
+ :documentation "List of topics that explicitly belong to this TM.")
+ (associations :associate (AssociationC in-topicmaps)
+ :many-to-many t
+ :accessor associations
+ :documentation "List of associations that belong to this TM."))
+ (:documentation "Represnets a topic map."))
+
+
+(defpclass TopicC (ReifiableConstructC VersionedConstructC)
+ ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
+ :documentation "Contains all association objects that
+ relate a topic with its actual
+ topic-identifiers.")
+ (psis :associate (PersistentIdAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a topic
+ with its actual psis.")
+ (locators :associate (SubjectLocatorAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a
+ topic with its actual subject-lcoators.")
+ (names :associate (NameAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a topic
+ with its actual names.")
+ (occurrences :associate (OccurrenceAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a
+ topic with its actual occurrences.")
+ (player-in-roles :associate (PlayerAssociationC player-topic)
+ :documentation "Contains all association objects that relate
+ a topic that is a player with its role.")
+ (used-as-type :associate (TypeAssociationC type-topic)
+ :documentation "Contains all association objects that relate a
+ topic that is a type with its typable obejct.")
+ (used-as-theme :associate (ScopeAssociationC theme-topic)
+ :documentation "Contains all association objects that relate a
+ topic that is a theme with its scoppable
+ object.")
+ (reified-construct :associate (ReifierAssociationC reifier-topic)
+ :documentation "Contains all association objects that
+ relate a topic that is a reifier with
+ its reified object.")
+ (in-topicmaps :associate (TopicMapC topics)
+ :many-to-many t
+ :documentation "List of all topic maps this topic is part of."))
+ (:index t)
+ (:documentation "Represents a TM topic."))
+
+
+
+;;; characteristics ...
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+ ((parent :associate (CharacteristicAssociationC characteristic)
+ :inherit t
+ :documentation "Assocates the characterist obejct with the
+ parent-association.")
+ (charvalue :initarg :charvalue
+ :accessor charvalue
+ :type string
+ :inherit t
+ :initform ""
+ :index t
+ :documentation "Contains the actual data of this object."))
+ (:documentation "Scoped characteristic of a topic (meant to be used
+ as an abstract class)."))
+
+
+(defpclass OccurrenceC(CharacteristicC DatatypableC)
+ ()
+ (:documentation "Represents a TM occurrence."))
+
+
+(defpclass NameC(CharacteristicC)
+ ((variants :associate (VariantAssociationC parent-construct)
+ :documentation "Associates this obejct with varian-associations."))
+ (:documentation "Scoped name of a topic."))
+
+
+(defpclass VariantC(CharacteristicC DatatypableC)
+ ()
+ (:documentation "Represents a TM variant."))
+
+
+;;; versioned associations ...
+(defpclass VersionedAssociationC(VersionedConstructC)
+ ()
+ (:documentation "An abstract base class for all versioned associations."))
+
+
+(defpclass TypeAssociationC(VersionedAssociationC)
+ ((type-topic :initarg :type-topic
+ :accessor type-topic
+ :initform (error (make-missing-argument-condition "From TypeAssociationC(): type-topic must be set" 'type-topic ':type-topic))
+ :associate TopicC
+ :documentation "Associates this object with a topic that is used
+ as type.")
+ (typable-construct :initarg :typable-construct
+ :accessor typable-construct
+ :initform (error (make-missing-argument-condition "From TypeAssociationC(): typable-construct must be set" 'typable-construct ':typable-construct))
+ :associate TypableC
+ :documentation "Associates this object with the typable
+ construct that is typed by the
+ type-topic."))
+ (:documentation "This class associates topics that are used as type for
+ typable constructcs. Additionally there are stored some
+ version-infos."))
+
+
+(defpclass ScopeAssociationC(VersionedAssociationC)
+ ((theme-topic :initarg :theme-topic
+ :accessor theme-topic
+ :initform (error (make-missing-argument-condition "From ScopeAssociationC(): theme-topic must be set" 'theme-topic ':theme-topic))
+ :associate TopicC
+ :documentation "Associates this opbject with a topic that is a
+ scopable construct.")
+ (scopable-construct :initarg :scopable-construct
+ :accessor scopable-construct
+ :initform (error (make-missing-argument-condition "From ScopeAssociationC(): scopable-construct must be set" 'scopable-construct ':scopable-construct))
+ :associate ScopableC
+ :documentation "Associates this object with the socpable
+ construct that is scoped by the
+ scope-topic."))
+ (:documentation "This class associates topics that are used as scope with
+ scopable construtcs. Additionally there are stored some
+ version-infos"))
+
+
+(defpclass ReifierAssociationC(VersionedAssociationC)
+ ((reifiable-construct :initarg :reifiable-construct
+ :accessor reifiable-construct
+ :initform (error (make-missing-argument-condition "From ReifierAssociation(): reifiable-construct must be set" 'reifiable-construct ':reifiable-construct))
+ :associate ReifiableConstructC
+ :documentation "The actual construct which is reified
+ by a topic.")
+ (reifier-topic :initarg :reifier-topic
+ :accessor reifier-topic
+ :initform (error (make-missing-argument-condition "From ReifierAssociationC(): reifier-topic must be set" 'reifier-topic ':reifier-topic))
+ :associate TopicC
+ :documentation "The reifier-topic that reifies the
+ reifiable-construct."))
+ (:documentation "A versioned-association that relates a reifiable-construct
+ with a topic."))
+
+
+;;; pointer associations ...
+(defpclass PointerAssociationC (VersionedAssociationC)
+ ((identifier :initarg :identifier
+ :accessor identifier
+ :inherit t
+ :initform (error (make-missing-argument-condition "From PointerAssociationC(): identifier must be set" 'identifier ':identifier))
+ :associate PointerC
+ :documentation "The actual data that is associated with
+ the pointer-association's parent."))
+ (:documentation "An abstract base class for all versioned
+ pointer-associations."))
+
+
+(defpclass SubjectLocatorAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From SubjectLocatorAssociationC(): parent-construct must be set" 'parent-construct ':parent-symbol))
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the subject-locator."))
+ (:documentation "A pointer that associates subject-locators, versions
+ and topics."))
+
+
+(defpclass PersistentIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From PersistentIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the subject-identifier/psi."))
+ (:documentation "A pointer that associates subject-identifiers, versions
+ and topics."))
+
+
+(defpclass TopicIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From TopicIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the topic-identifier."))
+ (:documentation "A pointer that associates topic-identifiers, versions
+ and topics."))
+
+
+(defpclass ItemIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From ItemIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :associate ReifiableConstructC
+ :documentation "The actual parent which is associated
+ with the item-identifier."))
+ (:documentation "A pointer that associates item-identifiers, versions
+ and reifiable-constructs."))
+
+
+;;; characteristic associations ...
+(defpclass CharacteristicAssociationC(VersionedAssociationC)
+ ((characteristic :initarg :characteristic
+ :accessor characteristic
+ :inherit t
+ :initform (error (make-missing-argument-condition "From CharacteristicCAssociation(): characteristic must be set" 'characteristic ':characteristic))
+ :associate CharacteristicC
+ :documentation "Associates this object with the actual
+ characteristic object."))
+ (:documentation "An abstract base class for all association-objects that
+ associates characteristics with topics."))
+
+
+(defpclass VariantAssociationC(CharacteristicAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From VariantAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :associate NameC
+ :documentation "Associates this object with a name."))
+ (:documentation "Associates variant objects with name obejcts.
+ Additionally version-infos are stored."))
+
+
+(defpclass NameAssociationC(CharacteristicAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From NameAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :associate TopicC
+ :documentation "Associates this object with a topic."))
+ (:documentation "Associates name objects with their parent topics.
+ Additionally version-infos are stored."))
+
+
+(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error (make-missing-argument-condition "From OccurrenceAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :associate TopicC
+ :documentation "Associates this object with a topic."))
+ (:documentation "Associates occurrence objects with their parent topics.
+ Additionally version-infos are stored."))
+
+
+;;; roles/association associations ...
+(defpclass PlayerAssociationC(VersionedAssociationC)
+ ((player-topic :initarg :player-topic
+ :accessor player-topic
+ :associate TopicC
+ :initform (error (make-missing-argument-condition "From PlayerAssociationC(): player-topic must be set" 'player-topic ':player-topic))
+ :documentation "Associates this object with a topic that is
+ a player.")
+ (parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate RoleC
+ :initform (error (make-missing-argument-condition "From PlayerAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :documentation "Associates this object with the parent-association."))
+ (:documentation "This class associates roles and their player in given
+ revisions."))
+
+
+(defpclass RoleAssociationC(VersionedAssociationC)
+ ((role :initarg :role
+ :accessor role
+ :associate RoleC
+ :initform (error (make-missing-argument-condition "From RoleAssociationC(): role must be set" 'role ':role))
+ :documentation "Associates this objetc with a role-object.")
+ (parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate AssociationC
+ :initform (error (make-missing-argument-condition "From RoleAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
+ :documentation "Assocates thius object with an
+ association-object."))
+ (:documentation "Associates roles with assoications and adds some
+ version-infos between these realtions."))
+
+
+;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun make-duplicate-identifier-condition (message uri)
+ "Returns an duplicate-identifier-condition with the passed arguments."
+ (make-condition 'duplicate-identifier-error
+ :message message
+ :uri uri))
+
+
+(defun make-object-not-found-condition (message)
+ "Returns an object-not-found-condition with the passed arguments."
+ (make-condition 'object-not-found-error
+ :message message))
+
+
+(defun make-tm-reference-condition (message referenced-construct
+ existing-reference new-reference)
+ "Returns a tm-reference-condition with the passed arguments."
+ (make-condition 'tm-reference-error
+ :message message
+ :referenced-construct referenced-construct
+ :existing-reference existing-reference
+ :new-reference new-reference))
+
+
+(defun make-not-mergable-condition (message construct-1 construct-2)
+ "Returns a not-mergable-condition with the passed arguments."
+ (make-condition 'not-mergable-error
+ :message message
+ :construct-1 construct-1
+ :construct-2 construct-2))
+
+
+(defun make-missing-argument-condition (message argument-symbol function-symbol)
+ "Returns a missing-argument-condition with the passed arguments."
+ (make-condition 'missing-argument-error
+ :message message
+ :argument-symbol argument-symbol
+ :function-symbol function-symbol))
+
+
+(defgeneric get-most-recent-versioned-assoc (construct slot-symbol)
+ (:documentation "Returns the most recent VersionedAssociationC
+ object.")
+ (:method ((construct TopicMapConstructC) (slot-symbol Symbol))
+ (let ((all-assocs (slot-p construct slot-symbol)))
+ (let ((zero-assoc
+ (find-if #'(lambda(assoc)
+ (= (end-revision
+ (get-most-recent-version-info assoc)) 0))
+ all-assocs)))
+ (if zero-assoc
+ zero-assoc
+ (let ((ordered-assocs
+ (sort all-assocs
+ #'(lambda(x y)
+ (> (end-revision
+ (get-most-recent-version-info x))
+ (end-revision
+ (get-most-recent-version-info y)))))))
+ (when ordered-assocs
+ (first ordered-assocs))))))))
+
+
+(defun get-latest-topic-by-psi (topic-psi)
+ "Returns the latest topic bound to the PersistentIdC
+ object corresponding to the given uri."
+ (declare (String topic-psi))
+ (let ((psi-inst
+ (elephant:get-instance-by-value
+ 'PersistentIdC 'uri topic-psi)))
+ (let ((latest-va
+ (get-most-recent-versioned-assoc
+ psi-inst 'identified-construct)))
+ (when (and latest-va (versions latest-va))
+ (identified-construct
+ psi-inst :revision (start-revision (first (versions latest-va))))))))
+
+
+(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*))
+ "Returns all instances of the given type and the given revision that are
+ stored in the db."
+ (declare (symbol class-symbol) (type (or null integer) revision))
+ (let ((db-instances (elephant:get-instances-by-class class-symbol)))
+ (let ((filtered-instances (remove-if-not #'(lambda(inst)
+ (typep inst class-symbol))
+ db-instances)))
+ (if revision
+ (remove-if #'null
+ (map 'list #'(lambda(inst)
+ (find-item-by-revision inst revision))
+ filtered-instances))
+ filtered-instances))))
+
+
+(defun get-all-topics (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'TopicC :revision revision))
+
+
+(defun get-all-associations (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'AssociationC :revision revision))
+
+
+(defun get-all-tms (&optional (revision *TM-REVISION*))
+ (get-db-instances-by-class 'TopicMapC :revision revision))
+
+
+(defun find-version-info (versioned-constructs
+ &key (sort-function #'<) (sort-key 'start-revision))
+ "Returns all version-infos sorted by the function sort-function which is
+ applied on the slot sort-key."
+ (declare (list versioned-constructs))
+ (let ((vis
+ (sort
+ (loop for vc in versioned-constructs
+ append (versions vc))
+ sort-function :key sort-key)))
+ (when vis
+ (first vis))))
+
+
+(defun rec-remf (plist keyword)
+ "Calls remf for the past plist with the given keyword until
+ all key-value-pairs corresponding to the passed keyword were removed."
+ (declare (list plist) (keyword keyword))
+ (loop while (getf plist keyword)
+ do (remf plist keyword))
+ plist)
+
+
+(defun get-item-by-content (content &key (revision *TM-REVISION*))
+ "Finds characteristics by their (atomic) content."
+ (flet
+ ((get-existing-instances (class-symbol)
+ (delete-if-not
+ #'(lambda (constr)
+ (find-item-by-revision constr revision))
+ (elephant:get-instances-by-value class-symbol 'charvalue content))))
+ (nconc (get-existing-instances 'OccurenceC)
+ (get-existing-instances 'NameC)
+ (get-existing-instances 'VariantC))))
+
+
(defmacro with-revision (revision &rest body)
`(let
- ((*TM-REVISION* ,revision))
- ;(format t "*TM-REVISION* is ~a~&" *TM-REVISION*)
- , at body))
-
+ ((*TM-REVISION* ,revision))
+ , at body))
-(defmacro slot-predicate (instance slot)
- (let
- ((inst-name (gensym))
- (slot-name (gensym)))
- `(let
- ((,inst-name ,instance)
- (,slot-name ,slot))
- (and (slot-boundp ,inst-name ,slot-name)
- (slot-value ,inst-name ,slot-name)))))
-(defmacro delete-1-n-association (instance slot)
- (let
- ((inst-name (gensym))
- (slot-name (gensym)))
- `(let
- ((,inst-name ,instance)
- (,slot-name ,slot))
- (when (slot-predicate ,inst-name ,slot-name)
- (elephant:remove-association ,inst-name ,slot-name (slot-value ,inst-name ,slot-name))))))
+(defun slot-p (instance slot-symbol)
+ "Returns t if the slot depending on slot-symbol is bound and not nil."
+ (if (slot-boundp instance slot-symbol)
+ (let ((value (slot-value instance slot-symbol)))
+ (when value
+ value))
+ ;elephant-relations are handled separately, since slot-boundp does not
+ ;work here
+ (handler-case (let ((value (slot-value instance slot-symbol)))
+ (when value
+ value))
+ (error () nil))))
+
+
+(defun delete-1-n-association(instance slot-symbol)
+ (when (slot-p instance slot-symbol)
+ (remove-association
+ instance slot-symbol (slot-value instance slot-symbol))))
-(defun xor (a1 a2)
- (and (or a1 a2) (not (and a1 a2)))
- )
-(defun remove-nil-values (plist)
- (let
- ((result nil))
- (do* ((rest plist (cddr rest))
- (key (first rest) (first rest))
- (val (second rest) (second rest)))
- ((null rest))
- (when val
- (pushnew val result)
- (pushnew key result)))
- result))
+(defgeneric delete-construct (construct)
+ (:documentation "Drops recursively construct and all its dependent objects
+ from the elephant store."))
+
+
+(defmethod delete-construct ((construct elephant:persistent))
+ nil)
+
+
+(defmethod delete-construct :after ((construct elephant:persistent))
+ (drop-instance construct))
+
+
+(defun filter-slot-value-by-revision (construct slot-symbol
+ &key (start-revision
+ 0 start-revision-provided-p))
+ (declare (symbol slot-symbol) (integer start-revision))
+ (let ((revision
+ (cond (start-revision-provided-p
+ start-revision)
+ ((boundp '*TM-REVISION*)
+ *TM-REVISION*)
+ (t 0)))
+ (properties (slot-p construct slot-symbol)))
+ (cond ((not properties)
+ nil) ;no properties were found -> nil
+ ((= 0 revision)
+ (remove-if #'null
+ (map 'list #'find-most-recent-revision properties)))
+ (t
+ (remove-if #'null
+ (map 'list #'(lambda(prop)
+ (find-item-by-revision prop revision))
+ properties))))))
+
(defun get-revision ()
"TODO: replace by something that does not suffer from a 1 second resolution."
(get-universal-time))
-(defgeneric delete-construct (construct)
- (:documentation "drops recursively construct and all its dependent objects from the elephant store"))
-(defmethod delete-construct ((construct elephant:persistent))
- nil)
+(defun string-integer-p (integer-as-string)
+ "Returns t if the passed string can be parsed to an integer."
+ (handler-case (when (parse-integer integer-as-string)
+ t)
+ (condition () nil)))
-(defmethod delete-construct :after ((construct elephant:persistent))
- (elephant:drop-instance construct))
-(defgeneric find-all-equivalent (construct)
- (:method ((construct t)) nil)
- (:documentation "searches an existing object that is equivalent (but not identical) to construct"))
-
-
-;;;;;;;;;;;;;;
-;;
-;; VersionInfoC
-
-
-(elephant:defpclass VersionInfoC ()
- ((start-revision :accessor start-revision
- :initarg :start-revision
- :type integer
- :initform 0 ;TODO: for now
- :documentation "The first revison this AssociationC instance is associated with.")
- (end-revision :accessor end-revision
- :initarg :end-revision
- :type integer
- :initform 0 ;TODO: for now
- :documentation "The first revison this AssociationC instance is no longer associated with.")
- (versioned-construct :associate TopicMapConstructC
- :accessor versioned-construct
- :initarg :versioned-construct
- :documentation "reifiable construct that is described by this info"))
- (:documentation "Version Info for individual revisions"))
-
-(defgeneric versioned-construct-p (vi)
- (:documentation "t if this version info is already bound to a TM construct")
- (:method ((vi VersionInfoC)) (slot-predicate vi 'versioned-construct)))
-
-(defmethod delete-construct :before ((vi VersionInfoC))
- (delete-1-n-association vi 'versioned-construct))
-
-(defgeneric get-most-recent-version-info (construct))
-
-
-;;;;;;;;;;;;;;
-;;
-;; ItemIdentifierC
+(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*))
+ "Merges all constructs contained in the given list."
+ (declare (list constructs-to-be-merged))
+ (cond ((null constructs-to-be-merged)
+ nil)
+ ((= (length constructs-to-be-merged) 1)
+ (first constructs-to-be-merged))
+ (t
+ (let ((constr-1 (first constructs-to-be-merged))
+ (constr-2 (second constructs-to-be-merged))
+ (tail (subseq constructs-to-be-merged 2)))
+ (let ((merged-constr
+ (merge-constructs constr-1 constr-2 :revision revision)))
+ (merge-all-constructs (append (list merged-constr)
+ tail)))))))
-(elephant:defpclass ItemIdentifierC (IdentifierC)
- ()
- (:index t)
- (:documentation "Represents an item identifier"))
+(defgeneric internal-id (construct)
+ (:documentation "Returns the internal id that uniquely identifies a
+ construct (currently simply its OID)."))
-;;;;;;;;;;;;;;
-;;
-;; SubjectLocator
-(elephant:defpclass SubjectLocatorC (IdentifierC)
- ((identified-construct :accessor identified-construct
- :initarg :identified-construct
- :associate TopicC))
- (:index t)
- (:documentation "Represents a subject locator"))
+(defmethod internal-id ((construct TopicMapConstructC))
+ (slot-value construct (find-symbol "OID" 'elephant)))
+
+(defun string-starts-with (str prefix)
+ "Checks if string str starts with a given prefix."
+ (declare (string str prefix))
+ (string= str prefix :start1 0 :end1
+ (min (length prefix)
+ (length str))))
-;;;;;;;;;;;;;;
-;;
-;; IdentifierC
-(elephant:defpclass IdentifierC (PointerC)
- ()
- (:documentation "Abstract base class for ItemIdentifierC and
- PersistentIdC, primarily in view of the equality rules"))
+;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric mark-as-deleted (construct &key source-locator revision)
+ (:documentation "Mark a construct as deleted if it comes from the source
+ indicated by source-locator"))
-;;;;;;;;;;;;;;
-;;
-;; PointerC
-
-(elephant:defpclass PointerC (TopicMapConstructC)
- ((uri :accessor uri
- :initarg :uri
- :type string
- :initform (error "The uri must be set for a pointer")
- :index t)
- (identified-construct :accessor identified-construct
- :initarg :identified-construct
- :associate ReifiableConstructC))
- (:documentation "Abstract base class for all types of pointers and identifiers"))
+(defgeneric marked-as-deleted-p (construct)
+ (:documentation "Returns t if the construct was marked-as-deleted."))
-(defmethod delete-construct :before ((construct PointerC))
- (delete-1-n-association construct 'identified-construct))
-(defmethod find-all-equivalent ((construct PointerC))
- (delete construct
- (elephant:get-instances-by-value (class-of construct)
- 'uri
- (uri construct))
- :key #'internal-id))
-(defgeneric uri-p (construct)
- (:documentation "Check if the slot uri is bound in an identifier and not nil")
- (:method ((identifier PointerC)) (slot-predicate identifier 'uri)))
-
-(defgeneric identified-construct-p (construct)
- (:documentation "Check if the slot identified-construct is bound in an identifier and not nil")
- (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct)))
-
-(defmethod print-object ((identifier PointerC) stream)
- (format stream
- "~a(href: ~a; Construct: ~a)"
- (class-name (class-of identifier))
- (if (uri-p identifier)
- (uri identifier)
- "URI UNDEFINED")
- (if (identified-construct-p identifier)
- (identified-construct identifier)
- "SLOT UNBOUND")))
-
-(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC))
- (string= (uri identifier1) (uri identifier2)))
-
-(defmethod initialize-instance :around ((identifier PointerC) &key
- (start-revision (error "Start revision must be present") )
- (end-revision 0))
- (call-next-method)
- (add-to-version-history identifier
- :start-revision start-revision
- :end-revision end-revision)
- identifier)
-
-
-;;;;;;;;;;;;;;
-;;
-;; TopicMapConstrucC
-
-
-(elephant:defpclass TopicMapConstructC ()
- ((versions :associate (VersionInfoC versioned-construct)
- :accessor versions
- :initarg :versions
- :documentation "version infos for former versions of this reifiable construct")))
-
- ;TODO: if, one day, we allow merges of already existing constructs, we'll need
- ;a tree of predecessors rather then just a list of versions. A case in point
- ;may be if a newly imported topic carries the PSIs of two existing topics,
- ;thereby forcing a merge post factum"
-
-(defmethod delete-construct :before ((construct TopicMapConstructC))
- (dolist (versioninfo (versions construct))
- (delete-construct versioninfo)))
+(defgeneric find-self-or-equal (construct parent-construct &key revision)
+ (:documentation "Returns the construct 'construct' if is owned by the
+ parent-construct or an equal construct or nil if there
+ is no equal one."))
-(defgeneric add-to-version-history (construct &key start-revision end-revision)
- (:documentation "Add version history to a topic map construct"))
+(defgeneric merge-if-equivalent (new-characteristic parent-construct
+ &key revision)
+ (:documentation "Merges the new characteristic/role with one equivalent of the
+ parent's charateristics/roles instead of adding the entire new
+ characteristic/role to the parent."))
-(defmethod add-to-version-history ((construct TopicMapConstructC)
- &key
- (start-revision (error "Start revision must be present") )
- (end-revision 0))
- "Adds relevant information to a construct's version info"
- (let
- ((current-version-info
- (get-most-recent-version-info construct)))
- (cond
- ((and current-version-info
- (= (end-revision current-version-info) start-revision)) ;the item was just marked as deleted
- (setf (end-revision current-version-info) 0) ;just revitalize it, do not create a new version
- current-version-info) ;TODO: this is not quite correct, the topic
- ;might be recreated with new item
- ;identifiers. Consider adding a new parameter
- ;"revitalize"
- ((and
- current-version-info
- (= (end-revision current-version-info) 0))
- (setf (end-revision current-version-info) start-revision)
- (make-instance
- 'VersionInfoC
- :start-revision start-revision
- :end-revision end-revision
- :versioned-construct construct))
- (t
- (make-instance
- 'VersionInfoC
- :start-revision start-revision
- :end-revision end-revision
- :versioned-construct construct)))))
-
-(defgeneric revision (constr)
- (:documentation "Essentially a convenience method for start-revision"))
-
-(defmethod revision ((constr TopicMapConstructC))
- (start-revision constr))
-
-(defmethod (setf revision) ((constr TopicMapConstructC) (revision integer))
- (setf (start-revision constr) revision))
-
-
-(defgeneric find-item-by-revision (constr revision)
- (:documentation "Get a given version of a construct (if any, nil if none can be found)"))
-
-(defmethod find-item-by-revision ((constr TopicMapConstructC) (revision integer))
- (cond
- ((= revision 0)
- (find-most-recent-revision constr))
- (t
- (when (find-if
- (lambda(version)
- (and (>= revision (start-revision version))
- (or
- (< revision (end-revision version))
- (= 0 (end-revision version)))))
- (versions constr))
- constr))))
-(defgeneric find-most-recent-revision (construct)
- (:documentation "Get the most recent version of a construct (nil if
-the construct doesn't have versions yet or not anymore)"))
+(defgeneric parent (construct &key revision)
+ (:documentation "Returns the parent construct of the passed object that
+ corresponds with the given revision. The returned construct
+ can be a TopicC or a NameC."))
+
+
+(defgeneric delete-if-not-referenced (construct)
+ (:documentation "Calls delete-construct for the given object if it is
+ not referenced by any other construct."))
+
+
+(defgeneric add-characteristic (construct characteristic &key revision)
+ (:documentation "Adds the passed characterisitc to the given topic by calling
+ add-name or add-occurrences.
+ Variants are added to names by calling add-name."))
+
+
+(defgeneric private-delete-characteristic (construct characteristic &key revision)
+ (:documentation "Deletes the passed characteristic of the given topic by
+ calling delete-name or delete-occurrence.
+ Variants are deleted from names by calling delete-variant."))
+
+
+(defgeneric delete-characteristic (construct characteristic &key revision)
+ (:documentation "See private-delete-characteristic but adds the parent
+ (if it is a variant also the parent's parent) to the
+ version history of this call's revision"))
+
+
+(defgeneric find-oldest-construct (construct-1 construct-2)
+ (:documentation "Returns the construct which owns the oldes version info.
+ If a construct is not a versioned construct the oldest
+ association determines the construct's version info."))
-(defmethod find-most-recent-revision ((construct TopicMapConstructC))
- (when (find 0 (versions construct) :key #'end-revision)
- construct))
-(defmethod delete-construct :before ((construct TopicMapConstructC))
- (dolist (versionInfo (versions construct))
- (delete-construct versionInfo)))
+(defgeneric merge-constructs (construct-1 construct-2 &key revision)
+ (:documentation "Merges two constructs of the same type if they are
+ mergable. The latest construct will be marked as deleted
+ The older one gets all characteristics of the marked as
+ deleted one. All referenced constructs are also updated
+ with the changeds that are caused by this operation."))
-(defgeneric check-for-duplicate-identifiers (top)
+(defgeneric parent-delete-parent (construct parent-construct &key revision)
+ (:documentation "Sets the assoication-object between the passed
+ constructs as marded-as-deleted."))
+
+
+(defgeneric delete-parent (construct parent-construct &key revision)
+ (:documentation "See private-delete-parent but adds the parent to
+ the given version."))
+
+
+(defgeneric add-parent (construct parent-construct &key revision)
+ (:documentation "Adds the parent-construct (TopicC or NameC) in form of
+ a corresponding association to the given object."))
+
+
+(defgeneric find-item-by-revision (construct revision
+ &optional parent-construct)
+ (:documentation "Returns the given object if it exists in the passed
+ version otherwise nil.
+ Constructs that exist to be owned by parent-constructs
+ must provide their parent-construct to get the corresponding
+ revision of the relationship between the construct itself and
+ its parent-construct."))
+
+
+(defgeneric check-for-duplicate-identifiers (construct &key revision)
(:documentation "Check for possibly duplicate identifiers and signal an
duplicate-identifier-error is such duplicates are found"))
-(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC))
- (declare (ignore construct))
- ;do nothing
- )
-(defgeneric filter-slot-value-by-revision (construct slot-name &key start-revision)
- (:documentation "filter slot values by a given revision that is
- either provided directly through the keyword argument start-revision
- or through a bound variable named '*TM-REVISION*'"))
+(defgeneric get-all-identifiers-of-construct (construct &key revision)
+ (:documentation "Get all identifiers that a given construct has"))
-(defmethod filter-slot-value-by-revision ((construct TopicMapConstructC) (slot-name symbol) &key (start-revision 0 start-revision-provided-p))
- (let
- ((revision ;avoids warnings about undefined variables
- (cond
- (start-revision-provided-p
- start-revision)
- ((boundp '*TM-REVISION*)
- (symbol-value '*TM-REVISION*))
- (t 0)))
- (properties (slot-value construct slot-name)))
- ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision)
- (cond
- ((not properties)
- nil) ;if we don't have any properties, we don't have to worry
- ;about revisions
- ((= 0 revision)
- (remove
- nil
- (map 'list #'find-most-recent-revision
- properties)))
- (t
- (remove nil
- (map 'list
- (lambda (constr)
- (find-item-by-revision constr revision))
- properties))))))
-
-(defgeneric make-construct (classsymbol &key start-revision &allow-other-keys)
- (:documentation "create a new topic map construct if necessary or
-retrieve an equivalent one if available and update the revision
-history accordingly. Return the object in question. Methods use
-specific keyword arguments for their purpose"))
-
-(defmethod make-construct ((classsymbol symbol) &rest args
- &key start-revision)
- (let*
- ((cleaned-args (remove-nil-values args))
- (new-construct (apply #'make-instance classsymbol cleaned-args))
- (existing-construct (first (find-all-equivalent new-construct))))
- (if existing-construct
- (progn
- ;change over new item identifiers to the old construct
- ;the version-history is also changed if the construct was
- ;marked-as-deleted before
- (when (or (copy-item-identifiers new-construct existing-construct)
- (not (find-most-recent-revision existing-construct)))
- (add-to-version-history existing-construct
- :start-revision start-revision))
-
- (delete-construct new-construct)
- existing-construct)
- (progn
- (add-to-version-history new-construct :start-revision start-revision)
- (check-for-duplicate-identifiers new-construct)
- new-construct))))
-
-(defmethod get-most-recent-version-info ((construct TopicMapConstructC))
+
+(defgeneric get-all-characteristics (parent-construct characteristic-symbol)
+ (:documentation "Returns all characterisitcs of the passed type the parent
+ construct was ever associated with."))
+
+
+(defgeneric equivalent-construct (construct &key start-revision
+ &allow-other-keys)
+ (:documentation "Returns t if the passed construct is equivalent to the passed
+ key arguments (TMDM equality rules). Parent-equality is not
+ checked in this methods, so the user has to pass children of
+ the same parent."))
+
+
+(defgeneric equivalent-constructs (construct-1 construct-2 &key revision)
+ (:documentation "Returns t if the passed constructs are equivalent to each
+ other (TMDM equality rules). Parent-equality is not
+ checked in this methods, so the user has to pass children of
+ the same parent."))
+
+
+(defgeneric get-most-recent-version-info (construct)
+ (:documentation "Returns the latest VersionInfoC object of the passed
+ versioned construct.
+ The latest construct is either the one with
+ end-revision=0 or with the highest end-revision value."))
+
+(defgeneric owned-p (construct)
+ (:documentation "Returns t if the passed construct is referenced by a parent
+ TM construct."))
+
+
+(defgeneric in-topicmaps (construct &key revision)
+ (:documentation "Returns all TopicMaps-obejcts where the construct is
+ contained in."))
+
+
+(defgeneric add-to-tm (construct construct-to-add)
+ (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM."))
+
+
+(defgeneric delete-from-tm (construct construct-to-delete)
+ (:documentation "Deletes a TM construct (TopicC or AssociationC) from
+ the TM."))
+
+
+
+;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; VersionInfocC
+(defmethod delete-construct :before ((version-info VersionInfoC))
+ (delete-1-n-association version-info 'versioned-construct))
+
+
+;;; VersionedConstructC
+(defgeneric exist-in-version-history-p (versioned-construct)
+ (:documentation "Returns t if the passed construct does not exist in any
+ revision, i.e. the construct has no version-infos or exactly
+ one whose start-revision is equal to its end-revision.")
+ (:method ((versioned-construct VersionedConstructC))
+ (or (not (versions versioned-construct))
+ (and (= (length (versions versioned-construct)) 1)
+ (= (start-revision (first (versions versioned-construct)))
+ (end-revision (first (versions versioned-construct))))))))
+
+
+(defmethod find-oldest-construct ((construct-1 VersionedConstructC)
+ (construct-2 VersionedConstructC))
+ (let ((vi-1 (find-version-info (list construct-1)))
+ (vi-2 (find-version-info (list construct-2))))
+ (cond ((not (or vi-1 vi-2))
+ construct-1)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
+(defgeneric VersionedConstructC-p (class-symbol)
+ (:documentation "Returns t if the passed class is equal to VersionedConstructC
+ or one of its subtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'VersionedconstructC)
+ (TopicC-p class-symbol)
+ (TopicMapC-p class-symbol)
+ (AssociationC-p class-symbol))))
+
+
+(defmethod delete-construct :before ((construct VersionedConstructC))
+ (dolist (version-info (versions construct))
+ (delete-construct version-info)))
+
+
+(defmethod find-item-by-revision ((construct VersionedConstructC)
+ (revision integer) &optional parent-construct)
+ (declare (ignorable parent-construct))
+ (cond ((= revision 0)
+ (find-most-recent-revision construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions construct))
+ construct))))
+
+
+(defmethod get-most-recent-version-info ((construct VersionedConstructC))
(let ((result (find 0 (versions construct) :key #'end-revision)))
(if result
result ;current version-info -> end-revision = 0
@@ -520,1159 +1082,3313 @@
(when sorted-list
(first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
-(defgeneric equivalent-constructs (construct1 construct2)
- (:documentation "checks if two topic map constructs are equal according to the TMDM equality rules"))
-(defgeneric strictly-equivalent-constructs (construct1 construct2)
- (:documentation "checks if two topic map constructs are not identical but equal according to the TMDM equality rules")
- (:method ((construct1 TopicMapConstructC) (construct2 TopicMapConstructC))
- (and (equivalent-constructs construct1 construct2)
- (not (eq construct1 construct2)))))
+(defgeneric find-most-recent-revision (construct)
+ (:documentation "Returns the latest version-info-object of the passed
+ construct.")
+ (:method ((construct VersionedConstructC))
+ (when (find 0 (versions construct) :key #'end-revision)
+ construct)))
-(defgeneric internal-id (construct)
- (:documentation "returns the internal id that uniquely identifies a
- construct (currently simply its OID)"))
-(defmethod internal-id ((construct TopicMapConstructC))
- (slot-value construct (find-symbol "OID" 'elephant)))
+(defun add-version-info(construct start-revision)
+ "Adds 'construct' to the given version.
+ If the construct is a VersionedConstructC add-to-version-history
+ is called directly. Otherwise there is called a corresponding
+ add-<whatever> method that adds recursively 'construct' to its
+ parent and so on."
+ (declare (type (or TopicMapConstructC VersionedConstructC) construct)
+ (integer start-revision))
+ (cond ((typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision start-revision))
+ ((typep construct 'VariantC)
+ (let ((name (parent construct :revision start-revision)))
+ (when name
+ (add-variant name construct :revision start-revision)
+ (let ((top (parent name :revision start-revision)))
+ (when top
+ (add-name top name :revision start-revision))))))
+ ((typep construct 'CharacteristicC)
+ (let ((top (parent construct :revision start-revision)))
+ (when top
+ (add-characteristic top construct :revision start-revision))))
+ ((typep construct 'RoleC)
+ (let ((assoc (parent construct :revision start-revision)))
+ (when assoc
+ (add-role assoc construct :revision start-revision))))))
-;;;;;;;;;;;;;;
-;;
-;; TopicIdentificationC
-
-(elephant:defpclass TopicIdentificationC (PointerC)
- ((xtm-id
- :accessor xtm-id
- :type string
- :initarg :xtm-id
- :index t
- :documentation "ID of the TM this identification came from"))
- (:documentation "Identify topic items through generalized
- topicids. A topic may have many original topicids, the class
- representing one of them") )
-
-(defmethod find-all-equivalent ((construct TopicIdentificationC))
- (delete (xtm-id construct) (call-next-method) :key #'xtm-id :test #'string=))
-
-(defun init-topic-identification (top id xtm-id &key (revision *TM-REVISION*))
- "create a TopicIdentification object (if necessary) and initialize it with the
- combination of the current topicid and the ID of the current XTM id"
- ;(declare (TopicC top))
- (declare (string id))
-
- (flet ;prevent unnecessary copies of TopicIdentificationC objects
- ((has-topic-identifier (top uri xtm-id)
- (remove-if-not
- (lambda (ident)
- (and (string= (uri ident) uri)
- (string= (xtm-id ident) xtm-id)))
- (topic-identifiers top))))
- (unless (has-topic-identifier top id xtm-id)
- (let
- ((ti
- (make-instance
- 'TopicIdentificationC
- :uri id
- :xtm-id xtm-id
- :identified-construct top
- :start-revision revision)))
- ;(add-to-version-history ti :start-revision revision)
- ti))))
-
-(defun xtm-id-p (xtm-id)
- "checks if a xtm-id has been used before"
- (elephant:get-instance-by-value 'TopicIdentificationC
- 'xtm-id xtm-id))
-
-
-;;;;;;;;;;;;;;
-;;
-;; PSI
-
-(elephant:defpclass PersistentIdC (IdentifierC)
- ((identified-construct :accessor identified-construct
- :initarg :identified-construct
- :associate TopicC))
- (:index t)
- (:documentation "Represents a PSI"))
+(defgeneric add-to-version-history (construct &key start-revision end-revision)
+ (:documentation "Adds version history to a versioned construct")
+ (:method ((construct VersionedConstructC)
+ &key (start-revision (error (make-missing-argument-condition "From add-to-version-history(): start revision must be present" 'start-revision 'add-to-version-history)))
+ (end-revision 0))
+ (let ((eql-version-info
+ (find-if #'(lambda(vi)
+ (and (= (start-revision vi) start-revision)
+ (= (end-revision vi) end-revision)))
+ (versions construct))))
+ (if eql-version-info
+ eql-version-info
+ (let ((current-version-info
+ (get-most-recent-version-info construct)))
+ (cond
+ ((and current-version-info
+ (= (end-revision current-version-info) start-revision))
+ (setf (end-revision current-version-info) end-revision)
+ current-version-info)
+ ((and current-version-info
+ (= (end-revision current-version-info) 0))
+ (setf (end-revision current-version-info) start-revision)
+ (let ((vi (make-instance 'VersionInfoC
+ :start-revision start-revision
+ :end-revision end-revision)))
+ (elephant:add-association vi 'versioned-construct construct)))
+ (t
+ (let ((vi (make-instance 'VersionInfoC
+ :start-revision start-revision
+ :end-revision end-revision)))
+ (elephant:add-association vi 'versioned-construct construct)))))))))
+
+
+
+(defmethod marked-as-deleted-p ((construct VersionedConstructC))
+ (unless (find-if #'(lambda(vi)
+ (= (end-revision vi) 0))
+ (versions construct))
+ t))
+
+
+(defmethod mark-as-deleted ((construct VersionedConstructC)
+ &key source-locator revision)
+ (declare (ignorable source-locator))
+ (let
+ ((last-version ;the last active version
+ (find 0 (versions construct) :key #'end-revision)))
+ (if (and last-version
+ (= (start-revision last-version) revision))
+ (progn
+ (delete-construct last-version)
+ (let ((sorted-versions
+ (sort (versions construct) #'> :key #'end-revision)))
+ (when sorted-versions
+ (setf (end-revision (first sorted-versions)) revision))))
+ (when last-version
+ (setf (end-revision last-version) revision)))))
+
+
+;;; TopicMapconstructC
+(defgeneric strictly-equivalent-constructs (construct-1 construct-2
+ &key revision)
+ (:documentation "Checks if two topic map constructs are not identical but
+ equal according to the TMDM equality rules.")
+ (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (and (equivalent-constructs construct-1 construct-2 :revision revision)
+ (not (eql construct-1 construct-2)))))
+
+
+(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)
+ &key revision)
+ (declare (ignorable revision construct))
+ ;do nothing
+ )
-;;;;;;;;;;;;;;
-;;
-;; ReifiableConstructC
-
-(elephant:defpclass ReifiableConstructC (TopicMapConstructC)
- ((item-identifiers
- :associate (ItemIdentifierC identified-construct)
- :inherit t
- :documentation "Slot that realizes a 1 to N
- relation between reifiable constructs and their
- identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")
- (reifier
- :associate TopicC
- :inherit t
- :documentation "Represents a reifier association to a topic, i.e.
- it stands for a 1:1 association between this class and TopicC"))
- (:documentation "Reifiable constructs as per TMDM"))
+(defmethod get-all-characteristics ((parent-construct TopicC)
+ (characteristic-symbol symbol))
+ (cond ((OccurrenceC-p characteristic-symbol)
+ (map 'list #'characteristic (slot-p parent-construct 'occurrences)))
+ ((NameC-p characteristic-symbol)
+ (map 'list #'characteristic (slot-p parent-construct 'names)))))
+
+
+(defgeneric TopicMapConstructC-p (class-symbol)
+ (:documentation "Returns t if the passed class is equal to TopicMapConstructC
+ or one of its subtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'TopicMapConstructC)
+ (ReifiableConstructC-p class-symbol)
+ (PointerC-p class-symbol))))
+
+
+;;; PointerC
+(defmethod versions ((construct PointerC))
+ "Returns all versions that are indirectly through all PointerAssocitiations
+ bound to the passed pointer object."
+ (loop for p-assoc in (slot-p construct 'identified-construct)
+ append (versions p-assoc)))
+
+
+(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision)
+ "Marks the last active relation between a pointer and its parent construct
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (identified-construct construct :revision 0)))
+ (when owner
+ (cond ((typep construct 'PersistentIdC)
+ (private-delete-psi owner construct :revision revision))
+ ((typep construct 'SubjectLocatorC)
+ (private-delete-locator owner construct :revision revision))
+ ((typep construct 'ItemIdentifierC)
+ (private-delete-item-identifier owner construct :revision revision))
+ ((typep construct 'TopicIdentificationC)
+ (private-delete-topic-identifier owner construct :revision revision))))))
+
+
+(defmethod marked-as-deleted-p ((construct PointerC))
+ (unless (identified-construct construct :revision 0)
+ t))
+
+
+(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
+ (vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
+ (cond ((not (or vi-1 vi-2))
+ construct-1)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
+(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
+ &key (revision nil))
+ (declare (ignorable revision))
+ (string= (uri construct-1) (uri construct-2)))
+
+
+(defgeneric PointerC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol corresponds to the class
+ PointerC or one of its subclasses.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'PointerC)
+ (IdentifierC-p class-symbol)
+ (TopicIdentificationC-p class-symbol)
+ (PersistentIdC-p class-symbol)
+ (ItemIdentifierC-p class-symbol)
+ (SubjectLocatorC-p class-symbol))))
+
+
+(defmethod equivalent-construct ((construct PointerC)
+ &key start-revision (uri ""))
+ "All Pointers are equal if they have the same URI value."
+ (declare (string uri) (ignorable start-revision))
+ (string= (uri construct) uri))
+
+
+(defmethod find-item-by-revision ((construct PointerC)
+ (revision integer) &optional parent-construct)
+ (if parent-construct
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'identified-construct)))))
+ (when assocs
+ (first assocs)))))
+ (when parent-assoc
+ (cond ((= revision 0)
+ (find-most-recent-revision parent-assoc))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
+ nil))
-(defgeneric reifier (construct &key revision)
- (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
- (when (slot-boundp construct 'reifier)
- (slot-value construct 'reifier))))
+(defmethod delete-construct :before ((construct PointerC))
+ (dolist (p-assoc (slot-p construct 'identified-construct))
+ (delete-construct p-assoc)))
-(defgeneric (setf reifier) (topic TopicC)
- (:method (topic (construct ReifiableConstructC))
- (setf (slot-value construct 'reifier) topic)))
-; (setf (reified topic) construct)))
-(defgeneric item-identifiers (construct &key revision)
- (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))
+(defmethod owned-p ((construct PointerC))
+ (when (slot-p construct 'identified-construct)
+ t))
+
+
+(defgeneric identified-construct (construct &key revision)
+ (:documentation "Returns the identified-construct -> ReifiableConstructC or
+ TopicC that corresponds with the passed revision.")
+ (:method ((construct PointerC) &key (revision *TM-REVISION*))
+ (let ((assocs
+ (map 'list #'parent-construct
+ (filter-slot-value-by-revision construct 'identified-construct
+ :start-revision revision))))
+ (when assocs ;result must be nil or a list with one item
+ (first assocs)))))
+
+
+;;; TopicIdentificationC
+(defmethod equivalent-constructs ((construct-1 TopicIdentificationC)
+ (construct-2 TopicIdentificationC)
+ &key (revision nil))
+ (declare (ignorable revision))
+ (and (call-next-method)
+ (string= (xtm-id construct-1) (xtm-id construct-2))))
+
-(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil))
- "adds associations to these ids after the instance was initialized."
- (declare (list item-identifiers))
- (call-next-method)
- (dolist (id item-identifiers)
- (declare (ItemIdentifierC id))
- (setf (identified-construct id) instance))
- (when reifier
- (add-reifier instance reifier))
- ;(setf (reifier instance) reifier))
- instance)
-(defmethod delete-construct :before ((construct ReifiableConstructC))
- (dolist (id (item-identifiers construct))
- (delete-construct id))
- (when (reifier construct)
- (let ((reifier-topic (reifier construct)))
- (remove-reifier construct)
- (delete-construct reifier-topic))))
-
-(defgeneric item-identifiers-p (constr)
- (:documentation "Test for the existence of item identifiers")
- (:method ((construct ReifiableConstructC)) (slot-predicate construct 'item-identifiers)))
-
-(defgeneric topicid (construct &optional xtm-id)
- (:documentation "Return the ID of a construct"))
-
-(defmethod revision ((constr ReifiableConstructC))
- (start-revision constr))
+(defgeneric TopicIdentificationC-p (class-symbol)
+ (:documentation "Returns t if the passed class symbol is equal
+ to TopicIdentificationC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'TopicIdentificationC)))
+
+
+(defmethod equivalent-construct ((construct TopicIdentificationC)
+ &key start-revision (uri "") (xtm-id ""))
+ "TopicIdentifiers are equal if teh URI and XTM-ID values are equal."
+ (declare (string uri xtm-id))
+ (let ((equivalent-pointer (call-next-method
+ construct :start-revision start-revision
+ :uri uri)))
+ (and equivalent-pointer
+ (string= (xtm-id construct) xtm-id))))
+
+
+;;; IdentifierC
+(defgeneric IdentifierC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to IdentifierC
+ or one of its sybtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'IdentifierC)
+ (PersistentIdC-p class-symbol)
+ (SubjectLocatorC-p class-symbol)
+ (ItemIdentifierC-p class-symbol))))
+
+
+;;; PersistentIdC
+(defgeneric PersistentIdC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to PersistentIdC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'PersistentIdC)))
+
+
+;;; ItemIdentifierC
+(defgeneric ItemIdentifierC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to ItemIdentifierC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'ItemIdentifierC)))
+
+;;; SubjectLocatorC
+(defgeneric SubjectLocatorC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to SubjectLocatorC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'SubjectLocatorC)))
+
+
+;;; PointerAssociationC
+(defmethod delete-construct :before ((construct PointerAssociationC))
+ (delete-1-n-association construct 'identifier))
+
+
+;;; ItemIdAssociationC
+(defmethod delete-construct :before ((construct ItemIdAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; TopicIdAssociationC
+(defmethod delete-construct :before ((construct TopicIdAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; PersistentIdAssociationC
+(defmethod delete-construct :before ((construct PersistentIdAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; SubjectLocatorAssociationC
+(defmethod delete-construct :before ((construct SubjectLocatorAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; ReifierAssociationC
+(defmethod delete-construct :before ((construct ReifierAssociationC))
+ (delete-1-n-association construct 'reifiable-construct)
+ (delete-1-n-association construct 'reifier-topic))
+
+
+;;; TypeAssociationC
+(defmethod delete-construct :before ((construct TypeAssociationC))
+ (delete-1-n-association construct 'type-topic)
+ (delete-1-n-association construct 'typable-construct))
+
+
+;;; ScopeAssociationC
+(defmethod delete-construct :before ((construct ScopeAssociationC))
+ (delete-1-n-association construct 'theme-topic)
+ (delete-1-n-association construct 'scopable-construct))
+
+
+;;; CharacteristicAssociationC
+(defmethod delete-construct :before ((construct CharacteristicAssociationC))
+ (delete-1-n-association construct 'characteristic))
+
+
+;;; OccurrenceAssociationC
+(defmethod delete-construct :before ((construct OccurrenceAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; NameAssociationC
+(defmethod delete-construct :before ((construct NameAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; VariantAssociationC
+(defmethod delete-construct :before ((construct VariantAssociationC))
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; RoleAssociationC
+(defmethod delete-construct :before ((construct RoleAssociationC))
+ (delete-1-n-association construct 'role)
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; PlayerAssociationC
+(defmethod delete-construct :before ((construct PlayerAssociationC))
+ (delete-1-n-association construct 'player-topic)
+ (delete-1-n-association construct 'parent-construct))
+
+
+;;; TopicC
+(defmethod mark-as-deleted :around ((top TopicC)
+ &key (source-locator nil sl-provided-p)
+ revision)
+ "Mark a topic as deleted if it comes from the source indicated by
+ source-locator"
+ ;;Part 1b, 1.4.3.3.1:
+ ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
+ ;; * Let SI be the value of TopicSI element in ATOM entry E
+ ;; * feed F contains E)
+ ;; * entry E references topic fragment TF
+ ;; * Let LTM be the local topic map
+ ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
+ ;; * For all names, occurrences and associations in which T plays a role, TMC
+ ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
+ ;; * Merge in the fragment TF using SP as the base all generated source locators.
+ (when (or (and (not source-locator) sl-provided-p)
+ (and sl-provided-p
+ (some (lambda (psi) (string-starts-with (uri psi) source-locator))
+ (psis top :revision 0))))
+ (unless sl-provided-p
+ (mapc (lambda(psi)(mark-as-deleted psi :revision revision
+ :source-locator source-locator))
+ (psis top :revision 0)))
+ (mapc (lambda(sl)(mark-as-deleted sl :revision revision
+ :source-locator source-locator))
+ (locators top :revision 0))
+ (mapc (lambda (name) (mark-as-deleted name :revision revision
+ :source-locator source-locator))
+ (names top :revision 0))
+ (mapc (lambda (occ) (mark-as-deleted occ :revision revision
+ :source-locator source-locator))
+ (occurrences top :revision 0))
+ (mapc (lambda (ass) (mark-as-deleted ass :revision revision
+ :source-locator source-locator))
+ (find-all-associations top :revision 0))
+ (call-next-method)))
-(defgeneric (setf revision) (revision construct)
- (:documentation "The corresponding setter method"))
-(defmethod (setf revision) ((revision integer) (constr ReifiableConstructC))
- (setf (start-revision constr) revision))
+(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((ids-1 (union (union (item-identifiers construct-1 :revision revision)
+ (locators construct-1 :revision revision))
+ (psis construct-1 :revision revision)))
+ (ids-2 (union (union (item-identifiers construct-2 :revision revision)
+ (locators construct-2 :revision revision))
+ (psis construct-2 :revision revision))))
+ (when (intersection ids-1 ids-2)
+ t)))
+
+
+(defgeneric TopicC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to TopicC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'TopicC)))
+
+
+(defmethod equivalent-construct ((construct TopicC)
+ &key (start-revision *TM-REVISION*) (psis nil)
+ (locators nil) (item-identifiers nil)
+ (topic-identifiers nil))
+ "Isidorus handles Topic-equality only by the topic's identifiers
+ 'psis', 'subject locators' and 'item identifiers'. Names and occurences
+ are not checked becuase we don't know when a topic is finalized and owns
+ all its charactersitics. T is returned if the topic owns one of the given
+ identifier-URIs."
+ (declare (integer start-revision) (list psis locators item-identifiers
+ topic-identifiers))
+ (when
+ (intersection
+ (union (union (psis construct :revision start-revision)
+ (locators construct :revision start-revision))
+ (union (item-identifiers construct :revision start-revision)
+ (topic-identifiers construct :revision start-revision)))
+ (union (union psis locators) (union item-identifiers topic-identifiers)))
+ t))
-(defgeneric get-all-identifiers-of-construct (construct)
- (:documentation "Get all identifiers that a given construct has"))
-(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC))
- (item-identifiers construct))
+(defmethod delete-construct :before ((construct TopicC))
+ (let ((psi-assocs-to-delete (slot-p construct 'psis))
+ (sl-assocs-to-delete (slot-p construct 'locators))
+ (name-assocs-to-delete (slot-p construct 'names))
+ (occ-assocs-to-delete (slot-p construct 'occurrences))
+ (role-assocs-to-delete (slot-p construct 'player-in-roles))
+ (type-assocs-to-delete (slot-p construct 'used-as-type))
+ (scope-assocs-to-delete (slot-p construct 'used-as-theme))
+ (reifier-assocs-to-delete (slot-p construct 'reified-construct)))
+ (let ((all-psis (map 'list #'identifier psi-assocs-to-delete))
+ (all-sls (map 'list #'identifier sl-assocs-to-delete))
+ (all-names (map 'list #'characteristic name-assocs-to-delete))
+ (all-occs (map 'list #'characteristic occ-assocs-to-delete))
+ (all-roles (map 'list #'parent-construct role-assocs-to-delete))
+ (all-types (map 'list #'typable-construct type-assocs-to-delete)))
+ (dolist (construct-to-delete (append psi-assocs-to-delete
+ sl-assocs-to-delete
+ name-assocs-to-delete
+ occ-assocs-to-delete
+ role-assocs-to-delete
+ type-assocs-to-delete
+ scope-assocs-to-delete
+ reifier-assocs-to-delete))
+ (delete-construct construct-to-delete))
+ (dolist (candidate-to-delete (append all-psis all-sls all-names all-occs))
+ (unless (owned-p candidate-to-delete)
+ (delete-construct candidate-to-delete)))
+ (dolist (candidate-to-delete all-roles)
+ (unless (player-p candidate-to-delete)
+ (delete-construct candidate-to-delete)))
+ (dolist (candidate-to-delete all-types)
+ (unless (instance-of-p candidate-to-delete)
+ (delete-construct candidate-to-delete)))
+ (dolist (tm (slot-p construct 'in-topicmaps))
+ (remove-association construct 'in-topicmaps tm)))))
+
+
+(defmethod owned-p ((construct TopicC))
+ (when (slot-p construct 'in-topicmaps)
+ t))
+
+
+(defgeneric topic-id (construct &optional revision xtm-id)
+ (:documentation "Returns the primary id of this item
+ (= essentially the OID). If xtm-id is explicitly given,
+ returns one of the topic-ids in that TM
+ (which must then exist).")
+ (:method ((construct TopicC) &optional (revision *TM-REVISION*) (xtm-id nil))
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
+ (if xtm-id
+ (let ((possible-identifiers
+ (remove-if-not
+ #'(lambda(top-id)
+ (string= (xtm-id top-id) xtm-id))
+ (topic-identifiers construct :revision revision))))
+ (unless possible-identifiers
+ (error (make-object-not-found-condition (format nil "Could not find an object ~a in xtm-id ~a" construct xtm-id))))
+ (uri (first possible-identifiers)))
+ (concatenate 'string "t" (write-to-string (internal-id construct))))))
+
+
+(defgeneric topic-identifiers (construct &key revision)
+ (:documentation "Returns the TopicIdentificationC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'topic-identifiers :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric add-topic-identifier (construct topic-identifier &key revision)
+ (:documentation "Adds the passed topic-identifier to the passed topic.
+ If the topic-identifier is already related with the passed
+ topic a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier (slot-p construct 'topic-identifiers)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct topic-identifier
+ :revision revision)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (let ((merged-construct construct))
+ (cond (construct-to-be-merged
+ (setf merged-construct
+ (merge-constructs construct construct-to-be-merged
+ :revision revision)))
+ ((find topic-identifier all-ids)
+ (let ((ti-assoc (loop for ti-assoc in (slot-p construct
+ 'topic-identifiers)
+ when (eql (identifier ti-assoc)
+ topic-identifier)
+ return ti-assoc)))
+ (add-to-version-history ti-assoc :start-revision revision)))
+ (t
+ (make-construct 'TopicIdAssociationC
+ :parent-construct construct
+ :identifier topic-identifier
+ :start-revision revision)))
+ (add-to-version-history merged-construct :start-revision revision)
+ merged-construct))))
+
+
+(defgeneric private-delete-topic-identifier
+ (construct topic-identifier &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-topic-identifier(): revision must be set" 'revision 'private-delete-topic-identifier))))
+ (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers)
+ when (eql (identifier ti-assoc) topic-identifier)
+ return ti-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-topic-identifier
+ (construct topic-identifier &key revision)
+ (:documentation "See private-delete-topic-identifier but adds the parent
+ construct to the given version")
+ (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+ &key (revision (error (make-missing-argument-condition "From delete-topic-identifier(): revision must be set" 'revision 'delete-topic-identifier))))
+ (when (private-delete-topic-identifier construct topic-identifier
+ :revision revision)
+ (add-to-version-history construct :start-revision revision)
+ construct)))
-(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC))
- (dolist (id (get-all-identifiers-of-construct construct))
- (when (> (length
- (union
- (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id))
- (union
- (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
- (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
- 1)
- (error
- (make-condition 'duplicate-identifier-error
- :message (format nil "Duplicate Identifier ~a has been found" (uri id))
- :uri (uri id))))))
-
-(defmethod copy-item-identifiers ((from-construct ReifiableConstructC)
- (to-construct ReifiableConstructC))
- "Internal method to copy over item idenfiers from a construct to
-another on. Returns the set of new identifiers"
- (mapc
- (lambda (identifier)
- (setf (identified-construct identifier)
- to-construct))
- (set-difference (item-identifiers from-construct)
- (item-identifiers to-construct)
- :key #'uri :test #'string=)))
-
-;;;;;;;;;;;;;;
-;;
-;; ScopableC
-
-(elephant:defpclass ScopableC ()
- ((themes :accessor themes
- :associate (TopicC used-as-theme)
- :inherit t
- :many-to-many t
- :documentation "list of this scope's themes; pseudo-initarg is :themes")))
-(defmethod initialize-instance :around ((instance ScopableC) &key (themes nil))
- (declare (list themes))
- (call-next-method)
- (dolist (theme themes)
- (elephant:add-association instance 'themes theme))
- instance)
+(defgeneric psis (construct &key revision)
+ (:documentation "Returns the PersistentIdC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'psis :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric add-psi (construct psi &key revision)
+ (:documentation "Adds the passed psi to the passed topic.
+ If the psi is already related with the passed
+ topic a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct TopicC) (psi PersistentIdC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier (slot-p construct 'psis)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct psi :revision revision)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (let ((merged-construct construct))
+ (cond (construct-to-be-merged
+ (setf merged-construct
+ (merge-constructs construct construct-to-be-merged
+ :revision revision)))
+ ((find psi all-ids)
+ (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
+ when (eql (identifier psi-assoc) psi)
+ return psi-assoc)))
+ (add-to-version-history psi-assoc :start-revision revision)))
+ (t
+ (make-construct 'PersistentIdAssociationC
+ :parent-construct construct
+ :identifier psi
+ :start-revision revision)))
+ (add-to-version-history merged-construct :start-revision revision)
+ merged-construct))))
+
+
+(defgeneric private-delete-psi (construct psi &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (psi PersistentIdC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-psi(): revision must be set" 'revision 'private-delete-psi))))
+ (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis)
+ when (eql (identifier psi-assoc) psi)
+ return psi-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-psi (construct psi &key revision)
+ (:documentation "See private-delete-psis but adds the parent to the given
+ version.")
+ (:method ((construct TopicC) (psi PersistentIdC)
+ &key (revision (error (make-missing-argument-condition "From delete-psi(): revision must be set" 'revision 'delete-psi))))
+ (when (private-delete-psi construct psi :revision revision)
+ (add-to-version-history construct :start-revision revision)
+ construct)))
-(defmethod delete-construct :before ((construct ScopableC))
- (dolist (theme (themes construct))
- (elephant:remove-association construct 'themes theme)))
+(defgeneric locators (construct &key revision)
+ (:documentation "Returns the SubjectLocatorC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'locators :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric add-locator (construct locator &key revision)
+ (:documentation "Adds the passed locator to the passed topic.
+ If the locator is already related with the passed
+ topic a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct TopicC) (locator SubjectLocatorC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier (slot-p construct 'locators)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct locator :revision revision)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (let ((merged-construct construct))
+ (cond (construct-to-be-merged
+ (setf merged-construct
+ (merge-constructs construct construct-to-be-merged
+ :revision revision)))
+ ((find locator all-ids)
+ (let ((loc-assoc
+ (loop for loc-assoc in (slot-p construct 'locators)
+ when (eql (identifier loc-assoc) locator)
+ return loc-assoc)))
+ (add-to-version-history loc-assoc :start-revision revision)))
+ (t
+ (make-construct 'SubjectLocatorAssociationC
+ :parent-construct construct
+ :identifier locator
+ :start-revision revision)))
+ (add-to-version-history merged-construct :start-revision revision)
+ merged-construct))))
+
+
+(defgeneric private-delete-locator (construct locator &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (locator SubjectLocatorC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-locator(): revision must be set" 'revision 'private-delete-locator))))
+ (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators)
+ when (eql (identifier loc-assoc) locator)
+ return loc-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-locator (construct locator &key revision)
+ (:documentation "See private-delete-locator but add the parent construct
+ to the given version.")
+ (:method ((construct TopicC) (locator SubjectLocatorC)
+ &key (revision (error (make-missing-argument-condition "From delete-locator(): revision must be set" 'revision 'delete-locator))))
+ (when (private-delete-locator construct locator :revision revision)
+ (add-to-version-history construct :start-revision revision)
+ construct)))
-;;;;;;;;;;;;;;
-;;
-;; TypableC
-
-(elephant:defpclass TypableC ()
- ((instance-of :accessor instance-of
- :initarg :instance-of
- :associate TopicC
- :inherit t
- :documentation "topic that this construct is an instance of")))
-(defmethod delete-construct :before ((construct TypableC))
- (when (instance-of-p construct)
- (elephant:remove-association construct 'instance-of (instance-of construct))))
+(defmethod get-all-identifiers-of-construct ((construct TopicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (append (psis construct :revision revision)
+ (locators construct :revision revision)
+ (item-identifiers construct :revision revision)))
+
+
+(defgeneric names (construct &key revision)
+ (:documentation "Returns the NameC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'names :start-revision revision)))
+ (map 'list #'characteristic assocs))))
+
+
+(defgeneric add-name (construct name &key revision)
+ (:documentation "Adds the passed name to the passed topic.
+ If the name is already related with the passed
+ topic a new revision is added.
+ If the passed name already owns another object
+ an error is thrown.")
+ (:method ((construct TopicC) (name NameC)
+ &key (revision *TM-REVISION*))
+ (when (and (parent name :revision revision)
+ (not (eql (parent name :revision revision) construct)))
+ (error (make-tm-reference-condition (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ name construct (parent name :revision revision))
+ name (parent name :revision revision) construct)))
+ (if (merge-if-equivalent name construct :revision revision)
+ construct
+ (let ((all-names
+ (map 'list #'characteristic (slot-p construct 'names))))
+ (if (find name all-names)
+ (let ((name-assoc
+ (loop for name-assoc in (slot-p construct 'names)
+ when (eql (parent-construct name-assoc)
+ construct)
+ return name-assoc)))
+ (add-to-version-history name-assoc :start-revision revision))
+ (make-construct 'NameAssociationC
+ :parent-construct construct
+ :characteristic name
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
+
+
+(defgeneric private-delete-name (construct name &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (name NameC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-name(): revision must be set" 'revision 'private-delete-name))))
+ (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
+ when (eql (characteristic name-assoc) name)
+ return name-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-name (construct name &key revision)
+ (:documentation "See private-delete-name but adds the parent to
+ the given version.")
+ (:method ((construct TopicC) (name NameC)
+ &key (revision (error (make-missing-argument-condition "From delete-name(): revision must be set" 'revision 'delete-name))))
+ (when (private-delete-name construct name :revision revision)
+ (add-to-version-history construct :start-revision revision)
+ construct)))
-(defgeneric instance-of-p (construct)
- (:documentation "is the instance-of slot bound and not nil")
- (:method ((construct TypableC)) (slot-predicate construct 'instance-of)))
+(defgeneric occurrences (construct &key revision)
+ (:documentation "Returns the OccurrenceC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'occurrences :start-revision revision)))
+ (map 'list #'characteristic assocs))))
+
+
+(defgeneric add-occurrence (construct occurrence &key revision)
+ (:documentation "Adds the passed occurrence to the passed topic.
+ If the occurrence is already related with the passed
+ topic a new revision is added.
+ If the passed occurrence already owns another object
+ an error is thrown.")
+ (:method ((construct TopicC) (occurrence OccurrenceC)
+ &key (revision *TM-REVISION*))
+ (when (and (parent occurrence :revision revision)
+ (not (eql (parent occurrence :revision revision) construct)))
+ (error (make-tm-reference-condition (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ occurrence construct (parent occurrence :revision revision))
+ occurrence (parent occurrence :revision revision) construct)))
+ (if (merge-if-equivalent occurrence construct :revision revision)
+ construct
+ (let ((all-occurrences
+ (map 'list #'characteristic (slot-p construct 'occurrences))))
+ (if (find occurrence all-occurrences)
+ (let ((occ-assoc
+ (loop for occ-assoc in (slot-p construct 'occurrences)
+ when (eql (parent-construct occ-assoc) construct)
+ return occ-assoc)))
+ (add-to-version-history occ-assoc :start-revision revision))
+ (make-construct 'OccurrenceAssociationC
+ :parent-construct construct
+ :characteristic occurrence
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
+
+
+(defgeneric private-delete-occurrence (construct occurrence &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (occurrence OccurrenceC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-occurrence(): revision must be set" 'revision 'private-delete-occurrence))))
+ (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
+ when (eql (characteristic occ-assoc) occurrence)
+ return occ-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-occurrence (construct occurrence &key revision)
+ (:documentation "See private-delete-occurrence but adds the parent
+ to the given version history.")
+ (:method ((construct TopicC) (occurrence OccurrenceC)
+ &key (revision (error (make-missing-argument-condition "From delete-occurrence(): revision must be set" 'revision 'delete-occurrence))))
+ (when (private-delete-occurrence construct occurrence :revision revision)
+ (add-to-version-history construct :start-revision revision)
+ construct)))
-;; (defmethod equivalent-constructs ((scope1 ScopeC) (scope2 ScopeC))
-;; "scopes are equal if their themes are equal"
-;; (let
-;; ((themes1
-;; (map 'list #'internal-id (themes scope1)))
-;; (themes2
-;; (map 'list #'internal-id (themes scope2))))
-;; (not (set-exclusive-or themes1 themes2 :key #'internal-id))))
-
-;;;;;;;;;;;;;;
-;;
-;; CharacteristicC
-
-(elephant:defpclass CharacteristicC (ReifiableConstructC ScopableC TypableC)
- ((topic :accessor topic
- :initarg :topic
- :associate TopicC
- :documentation "The topic that this characteristic belongs to")
- (charvalue :accessor charvalue
- :type string
- :initarg :charvalue
- :index t
- :documentation "the value of the characteristic in the given scope"))
- (:documentation "Scoped characteristic of a topic (meant to be used
- as an abstract class)"))
+(defmethod add-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (add-name construct characteristic :revision revision)
+ (add-occurrence construct characteristic :revision revision)))
+
+
+(defmethod private-delete-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic))))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (private-delete-name construct characteristic :revision revision)
+ (private-delete-occurrence construct characteristic
+ :revision revision)))
+
+
+(defmethod delete-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic))))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (delete-name construct characteristic :revision revision)
+ (delete-occurrence construct characteristic :revision revision)))
+
+
+(defgeneric player-in-roles (construct &key revision)
+ (:documentation "Returns the RoleC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'player-in-roles :start-revision revision)))
+ (map 'list #'parent-construct assocs))))
+
+
+(defgeneric used-as-type (construct &key revision)
+ (:documentation "Returns the TypableC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'used-as-type :start-revision revision)))
+ (map 'list #'typable-construct assocs))))
+
+
+(defgeneric used-as-theme (construct &key revision)
+ (:documentation "Returns the ScopableC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'used-as-theme :start-revision revision)))
+ (map 'list #'scopable-construct assocs))))
+
+
+(defgeneric reified-construct (construct &key revision)
+ (:documentation "Returns the ReifiableConstructC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'reified-construct :start-revision revision)))
+ (when assocs
+ (reifiable-construct (first assocs))))))
+
+
+(defgeneric add-reified-construct (construct reified-construct &key revision)
+ (:documentation "Sets the passed construct as reified-consturct of the given
+ topic.")
+ (:method ((construct TopicC) (reified-construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (add-reifier reified-construct construct :revision revision)))
+
+
+(defgeneric private-delete-reified-construct
+ (construct reified-construct &key revision)
+ (:documentation "Unsets the passed construct as reified-construct of the
+ given topic.")
+ (:method ((construct TopicC) (reified-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-reified-construct(): revision must be set" 'revision 'private-delete-reified-construct))))
+ (declare (integer revision))
+ (private-delete-reifier reified-construct construct
+ :revision revision)))
+
+
+(defgeneric delete-reified-construct (construct reified-construct &key revision)
+ (:documentation "See private-delete-reified-construct but adds the
+ reifier to the given version.")
+ (:method ((construct TopicC) (reified-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From -delete-reified-construct(): revision must be set" 'revision '-delete-reified-construct))))
+ (declare (integer revision))
+ (delete-reifier reified-construct construct :revision revision)))
+
+
+(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*))
+ (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
+
+
+(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*)
+ (revision *TM-REVISION*) (error-if-nil nil))
+ "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM
+ is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
+ applicable in the correct revision. If revison is provided, then the code checks
+ if the topic already existed in this revision and returns nil otherwise.
+ If no item meeting the constraints was found, then the return value is either
+ NIL or an error is thrown, depending on error-if-nil."
+ (declare (string topic-id) (integer revision))
+ (let ((result
+ (if xtm-id
+ (let ((possible-top-ids
+ (delete-if-not
+ #'(lambda(top-id)
+ (and (typep top-id 'd:TopicIdentificationC)
+ ;fixes a bug in elephant -> all PointerCs are returned
+ (string= (xtm-id top-id) xtm-id)
+ (string= (uri top-id) topic-id)))
+ ;fixes a bug in get-instances-by-value that does a
+ ;case-insensitive comparision
+ (elephant:get-instances-by-value
+ 'TopicIdentificationC
+ 'uri topic-id))))
+ (when (and possible-top-ids
+ (identified-construct (first possible-top-ids)
+ :revision revision))
+ (unless (= (length possible-top-ids) 1)
+ (error (make-duplicate-identifier-condition
+ (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
+ possible-top-ids topic-id xtm-id)
+ topic-id)))
+ (identified-construct (first possible-top-ids)
+ :revision revision)
+ ;no revision need not to be checked, since the revision
+ ;is implicitely checked by the function identified-construct
+ ))
+ (when (and (> (length topic-id) 0)
+ (eql (elt topic-id 0) #\t)
+ (string-integer-p (subseq topic-id 1)))
+ (let ((top-from-oid
+ (elephant::controller-recreate-instance
+ elephant::*store-controller*
+ (parse-integer (subseq topic-id 1)))))
+ (when (find-item-by-revision top-from-oid revision)
+ top-from-oid))))))
+ (if (and error-if-nil (not result))
+ (error (make-object-not-found-condition (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)))
+ result)))
+
+
+(defun get-item-by-identifier (uri &key (revision *TM-REVISION*)
+ (identifier-type-symbol 'PersistentIdC)
+ (error-if-nil nil))
+ "Returns the construct that is bound to the given identifier-uri."
+ (declare (string uri) (integer revision) (symbol identifier-type-symbol))
+ (let ((result
+ (let ((possible-ids
+ (delete-if-not
+ #'(lambda(id)
+ (and (typep id identifier-type-symbol)
+ (string= (uri id) uri)))
+ (get-instances-by-value identifier-type-symbol 'uri uri))))
+ (when (and possible-ids
+ (identified-construct (first possible-ids)
+ :revision revision))
+ (unless (= (length possible-ids) 1)
+ (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri)))
+ (identified-construct (first possible-ids)
+ :revision revision)))))
+ ;no revision need to be checked, since the revision
+ ;is implicitely checked by the function identified-construct
+ (if (and result
+ (let ((parent-elem
+ (when (or (typep result 'CharacteristicC)
+ (typep result 'RoleC))
+ (parent result :revision revision))))
+ (find-item-by-revision result revision parent-elem)))
+ result
+ (when error-if-nil
+ (error (make-object-not-found-condition "No such item is bound to the given identifier uri."))))))
+
+
+(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*)
+ (error-if-nil nil))
+ "Returns a ReifiableConstructC that is bound to the identifier-uri."
+ (get-item-by-identifier uri :revision revision
+ :identifier-type-symbol 'ItemIdentifierC
+ :error-if-nil error-if-nil))
+
+
+(defun get-item-by-psi (uri &key (revision *TM-REVISION*) (error-if-nil nil))
+ "Returns a TopicC that is bound to the identifier-uri."
+ (get-item-by-identifier uri :revision revision
+ :identifier-type-symbol 'PersistentIdC
+ :error-if-nil error-if-nil))
+
+
+(defun get-item-by-locator (uri &key (revision *TM-REVISION*) (error-if-nil nil))
+ "Returns a TopicC that is bound to the identifier-uri."
+ (get-item-by-identifier uri :revision revision
+ :identifier-type-symbol 'SubjectLocatorC
+ :error-if-nil error-if-nil))
+
+
+(defgeneric list-instanceOf (topic &key tm revision)
+ (:documentation "Generates a list of all topics that this topic is an
+ instance of, optionally filtered by a topic map")
+ (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*))
+ (declare (type (or null TopicMapC) tm)
+ (integer revision))
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(x)
+ (when (loop for psi in (psis (instance-of x :revision revision)
+ :revision revision)
+ when (string= (uri psi) constants:*instance-psi*)
+ return t)
+ (loop for role in (roles (parent x :revision revision)
+ :revision revision)
+ when (not (eq role x))
+ return (player role :revision revision))))
+ (if tm
+ (remove-if-not
+ (lambda (role)
+ (in-topicmap tm (parent role :revision revision)
+ :revision revision))
+ (player-in-roles topic :revision revision))
+ (player-in-roles topic :revision revision))))))
+
+
+(defgeneric list-super-types (topic &key tm revision)
+ (:documentation "Generate a list of all topics that this topic is an
+ subclass of, optionally filtered by a topic map")
+ (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*))
+ (declare (type (or null TopicMapC) tm)
+ (integer revision))
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(x)
+ (when (loop for psi in (psis (instance-of x :revision revision)
+ :revision revision)
+ when (string= (uri psi) *subtype-psi*)
+ return t)
+ (loop for role in (roles (parent x :revision revision)
+ :revision revision)
+ when (not (eq role x))
+ return (player role :revision revision))))
+ (if tm
+ (remove-if-not
+ (lambda (role)
+ (in-topicmap tm (parent role :revision revision)
+ :revision revision))
+ (player-in-roles topic :revision revision))
+ (player-in-roles topic :revision revision))))))
+
+
+;;; CharacteristicC
+(defmethod versions ((construct CharacteristicC))
+ "Returns all versions that are indirectly through all
+ CharacteristicAssocitiations bound to the passed characteristic object."
+ (loop for p-assoc in (slot-p construct 'parent)
+ append (versions p-assoc)))
+
+
+(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision)
+ "Marks the last active relation between a characteristic and its parent topic
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (parent construct :revision 0)))
+ (when owner
+ (private-delete-characteristic owner construct :revision revision))))
+
+
+(defmethod marked-as-deleted-p ((construct CharacteristicC))
+ (unless (parent construct :revision 0)
+ t))
+
+
+(defmethod find-self-or-equal ((construct CharacteristicC)
+ (parent-construct TopicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or OccurrenceC NameC) construct))
+ (let ((chars (if (typep construct 'OccurrenceC)
+ (occurrences parent-construct :revision revision)
+ (names parent-construct :revision revision))))
+ (let ((self (find construct chars)))
+ (if self
+ self
+ (let ((equal-char
+ (remove-if #'null
+ (map 'list
+ #'(lambda(char)
+ (strictly-equivalent-constructs
+ char construct :revision revision))
+ chars))))
+ (when equal-char
+ (first equal-char)))))))
+
+
+(defmethod delete-if-not-referenced ((construct CharacteristicC))
+ (let ((references (slot-p construct 'parent)))
+ (when (or (not references)
+ (and (= (length references) 1)
+ (marked-as-deleted-p (first references))))
+ (delete-construct construct))))
+
+
+(defmethod find-oldest-construct ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
+ (vi-2 (find-version-info (slot-p construct-2 'parent))))
+ (cond ((not (or vi-1 vi-2))
+ construct-1)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
+
+
+(defmethod equivalent-constructs ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (and (string= (charvalue construct-1) (charvalue construct-2))
+ (eql (instance-of construct-1 :revision revision)
+ (instance-of construct-2 :revision revision))
+ (not (set-exclusive-or (themes construct-1 :revision revision)
+ (themes construct-2 :revision revision)))))
+
+
+(defgeneric CharacteristicC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to CharacteristicC
+ or one of its subtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'CharacteristicC)
+ (OccurrenceC-p class-symbol)
+ (NameC-p class-symbol)
+ (VariantC-p class-symbol))))
+
+
+(defmethod equivalent-construct ((construct CharacteristicC)
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (instance-of nil) (themes nil))
+ "Equality rule: Characteristics are equal if charvalue, themes and
+ instance-of are equal."
+ (declare (string charvalue) (list themes)
+ (integer start-revision)
+ (type (or null TopicC) instance-of))
+ ;; item-identifiers and reifers are not checked because the equality have to
+ ;; be variafied without them
+ (and (string= (charvalue construct) charvalue)
+ (equivalent-scopable-construct construct themes
+ :start-revision start-revision)
+ (equivalent-typable-construct construct instance-of
+ :start-revision start-revision)))
+
+
+(defmethod find-item-by-revision ((construct CharacteristicC)
+ (revision integer) &optional parent-construct)
+ (if parent-construct
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'parent)))))
+ (when assocs
+ (first assocs)))))
+ (when parent-assoc
+ (cond ((= revision 0)
+ (when
+ (find-most-recent-revision parent-assoc)
+ construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
+ nil))
-(defgeneric CharacteristicC-p (object)
- (:documentation "test if object is a of type CharacteristicC")
- (:method ((object t)) nil)
- (:method ((object CharacteristicC)) object))
(defmethod delete-construct :before ((construct CharacteristicC))
- (delete-1-n-association construct 'topic))
+ (dolist (characteristic-assoc-to-delete (slot-p construct 'parent))
+ (delete-construct characteristic-assoc-to-delete)))
-(defun get-item-by-content (content &key (revision *TM-REVISION*))
- "Find characteristis by their (atomic) content"
- (flet
- ((get-existing-instances (classname)
- (delete-if-not #'(lambda (constr)
- (find-item-by-revision constr revision))
- (elephant:get-instances-by-value classname 'charvalue content))))
- (nconc (get-existing-instances 'OccurenceC)
- (get-existing-instances 'NameC))))
+(defmethod owned-p ((construct CharacteristicC))
+ (when (slot-p construct 'parent)
+ t))
+(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'parent
+ :start-revision revision)))
+ (when valid-associations
+ (parent-construct (first valid-associations)))))
-;;;;;;;;;;;;;;
-;;
-;; VariantC
-(elephant:defpclass VariantC (CharacteristicC)
- ((datatype :accessor datatype
- :initarg :datatype
- :initform nil
- :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")
- (name :accessor name
- :initarg :name
- :associate NameC
- :documentation "references the NameC instance which is the owner of this element")))
+(defmethod add-parent ((construct CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((already-set-parent (parent construct :revision revision))
+ (same-parent-assoc ;should contain an object that was marked as deleted
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct (parent-construct parent-assoc))
+ return parent-assoc)))
+ (when (and already-set-parent
+ (not (eql already-set-parent parent-construct)))
+ (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ construct parent-construct already-set-parent)
+ construct (parent construct :revision revision) parent-construct)))
+ (let ((merged-char
+ (merge-if-equivalent construct parent-construct :revision revision)))
+ (if merged-char
+ merged-char
+ (progn
+ (cond (already-set-parent
+ (let ((parent-assoc
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct
+ (parent-construct parent-assoc))
+ return parent-assoc)))
+ (add-to-version-history parent-assoc
+ :start-revision revision)))
+ (same-parent-assoc
+ (add-to-version-history same-parent-assoc
+ :start-revision revision))
+ (t
+ (let ((association-type (cond ((typep construct 'OccurrenceC)
+ 'OccurrenceAssociationC)
+ ((typep construct 'NameC)
+ 'NameAssociationC)
+ (t
+ 'VariantAssociationC))))
+ (make-construct association-type
+ :characteristic construct
+ :parent-construct parent-construct
+ :start-revision revision))))
+ (when (typep parent-construct 'VersionedConstructC)
+ (add-to-version-history parent-construct :start-revision revision))
+ construct)))))
+
+
+(defmethod private-delete-parent ((construct CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent))))
+ (let ((assoc-to-delete
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql (parent-construct parent-assoc) parent-construct)
+ return parent-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct)))
-(defgeneric VariantC-p (object)
- (:documentation "test if object is a of type VariantC")
- (:method ((object t)) nil)
- (:method ((object VariantC)) object))
+(defmethod delete-parent ((construct CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent))))
+ (let ((parent (parent construct :revision revision)))
+ (when (private-delete-parent construct parent-construct :revision revision)
+ (when parent
+ (add-version-info parent revision))
+ construct)))
-(defmethod delete-construct :before ((construct VariantC))
- (delete-1-n-association construct 'name))
+;;; OccurrenceC
+(defmethod equivalent-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
+ &key (revision *TM-REVISION*))
+ (declare (ignorable revision))
+ (and (call-next-method)
+ (string= (datatype construct-1) (datatype construct-2))))
+
+
+(defgeneric OccurrenceC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to OccurrenceC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'OccurrenceC)))
+
+
+(defmethod equivalent-construct ((construct OccurrenceC)
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (themes nil) (instance-of nil)
+ (datatype ""))
+ "Occurrences are equal if their charvalue, datatype, themes and
+ instance-of properties are equal."
+ (declare (type (or null TopicC) instance-of) (string datatype)
+ (ignorable start-revision charvalue themes instance-of))
+ (let ((equivalent-characteristic (call-next-method)))
+ ;; item-identifiers and reifers are not checked because the equaity have to
+ ;; be variafied without them
+ (and equivalent-characteristic
+ (string= (datatype construct) datatype))))
+
+
+;;; VariantC
+(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((vars (variants parent-construct :revision revision)))
+ (let ((self (find construct vars)))
+ (if self
+ self
+ (let ((equal-var
+ (remove-if #'null
+ (map 'list
+ #'(lambda(var)
+ (strictly-equivalent-constructs
+ var construct :revision revision))
+ vars))))
+ (when equal-var
+ (first equal-var)))))))
+
+
+(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (ignorable revision))
+ (and (call-next-method)
+ (string= (datatype construct-1) (datatype construct-2))))
+
+
+(defgeneric VariantC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to VariantC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'VariantC)))
+
+
+(defmethod equivalent-construct ((construct VariantC)
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (themes nil) (datatype ""))
+ "Variants are equal if their charvalue, datatype and themes
+ properties are equal."
+ (declare (string datatype) (ignorable start-revision charvalue themes))
+ ;; item-identifiers and reifers are not checked because the equality have to
+ ;; be variafied without them
+ (let ((equivalent-characteristic (call-next-method)))
+ (and equivalent-characteristic
+ (string= (datatype construct) datatype))))
+
+
+;;; NameC
+(defmethod get-all-characteristics ((parent-construct NameC)
+ (characteristic-symbol symbol))
+ (when (VariantC-p characteristic-symbol)
+ (map 'list #'characteristic (slot-p parent-construct 'variants))))
+
+
+(defgeneric NameC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to Name.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'NameC)))
+
+
+(defgeneric complete-name (construct variants &key start-revision)
+ (:documentation "Adds all given variants to the passed construct.")
+ (:method ((construct NameC) (variants list)
+ &key (start-revision *TM-REVISION*))
+ (dolist (variant variants)
+ (add-variant construct variant :revision start-revision))
+ construct))
-(defmethod find-all-equivalent ((construct VariantC))
- (let ((parent (and (slot-boundp construct 'name)
- (name construct))))
- (when parent
- (delete-if-not #'(lambda(x)(strictly-equivalent-constructs construct x))
- (slot-value parent 'variants)))))
+(defmethod equivalent-construct ((construct NameC)
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (themes nil) (instance-of nil))
+ "Names are equal if their charvalue, instance-of and themes properties
+ are equal."
+ (declare (type (or null TopicC) instance-of)
+ (ignorable start-revision charvalue instance-of themes))
+ (call-next-method))
+
+(defmethod delete-construct :before ((construct NameC))
+ (let ((variant-assocs-to-delete (slot-p construct 'variants)))
+ (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete)))
+ (dolist (variant-assoc-to-delete variant-assocs-to-delete)
+ (delete-construct variant-assoc-to-delete))
+ (dolist (candidate-to-delete all-variants)
+ (unless (owned-p candidate-to-delete)
+ (delete-construct candidate-to-delete))))))
+
+
+(defgeneric variants (construct &key revision)
+ (:documentation "Returns all variants that correspond with the given revision
+ and that are associated with the passed construct.")
+ (:method ((construct NameC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'variants
+ :start-revision revision)))
+ (map 'list #'characteristic valid-associations))))
+
+
+(defgeneric add-variant (construct variant &key revision)
+ (:documentation "Adds the given theme-topic to the passed
+ scopable-construct.")
+ (:method ((construct NameC) (variant VariantC)
+ &key (revision *TM-REVISION*))
+ (when (and (parent variant :revision revision)
+ (not (eql (parent variant :revision revision) construct)))
+ (error (make-tm-reference-condition (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
+ variant construct (parent variant :revision revision))
+ variant (parent variant :revision revision) construct)))
+ (if (merge-if-equivalent variant construct :revision revision)
+ construct
+ (let ((all-variants
+ (map 'list #'characteristic (slot-p construct 'variants))))
+ (if (find variant all-variants)
+ (let ((variant-assoc
+ (loop for variant-assoc in (slot-p construct 'variants)
+ when (eql (characteristic variant-assoc) variant)
+ return variant-assoc)))
+ (add-to-version-history variant-assoc :start-revision revision))
+ (make-construct 'VariantAssociationC
+ :characteristic variant
+ :parent-construct construct
+ :start-revision revision))
+ (when (parent construct :revision revision)
+ (add-name (parent construct :revision revision) construct
+ :revision revision))
+ construct))))
+
+
+(defgeneric private-delete-variant (construct variant &key revision)
+ (:documentation "Deletes the passed variant by marking it's association as
+ deleted in the passed revision.")
+ (:method ((construct NameC) (variant VariantC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-variant(): revision must be set" 'revision 'private-delete-variant))))
+ (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
+ 'variants)
+ when (eql (characteristic variant-assoc) variant)
+ return variant-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-variant (construct variant &key revision)
+ (:documentation "See private-delete-variant but adds a the parent
+ and the parent's parent to the given version history.")
+ (:method ((construct NameC) (variant VariantC)
+ &key (revision (error (make-missing-argument-condition "From delete-variant(): revision must be set" 'revision 'delete-variant))))
+ (when (private-delete-variant construct variant :revision revision)
+ (when (parent construct :revision revision)
+ (add-name (parent construct :revision revision) construct
+ :revision revision)
+ construct))))
-(defmethod equivalent-constructs ((variant1 VariantC) (variant2 VariantC))
- "variant items are (TMDM(5.5)-)equal if the values of their
- [value], [datatype], [scope], and [parent] properties are equal"
- (and (string= (charvalue variant1) (charvalue variant2))
- (or (and (not (slot-boundp variant1 'datatype)) (not (slot-boundp variant2 'datatype)))
- (and (slot-boundp variant1 'datatype) (slot-boundp variant2 'datatype)
- (string= (datatype variant1) (datatype variant2))))
- (not (set-exclusive-or (themes variant1) (themes variant2) :key #'internal-id))))
-
+(defmethod add-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (add-variant construct characteristic :revision revision))
-
-;;;;;;;;;;;;;;
-;;
-;; NameC
-(elephant:defpclass NameC (CharacteristicC)
- ((variants ;:accessor variants
- :associate (VariantC name)))
- (:documentation "Scoped name of a topic"))
+(defmethod private-delete-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic))))
+ (declare (integer revision))
+ (private-delete-variant construct characteristic :revision revision))
-(defgeneric variants (name &key revision)
- (:method ((name NameC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision name 'variants :start-revision revision)))
+(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic))))
+ (declare (integer revision))
+ (delete-variant construct characteristic :revision revision))
-(defgeneric NameC-p (object)
- (:documentation "test if object is a of type NameC")
- (:method ((object t)) nil)
- (:method ((object NameC)) object))
+;;; AssociationC
+(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
+ "Marks an association and its roles as deleted"
+ (mapc (lambda (role)
+ (mark-as-deleted role :revision revision :source-locator source-locator))
+ (roles ass :revision 0))
+ (call-next-method))
-(defmethod find-all-equivalent ((construct NameC))
- (let
- ((parent (and (slot-boundp construct 'topic)
- (topic construct))))
- (when parent
- (delete-if-not
- #'(lambda (cand) (strictly-equivalent-constructs construct cand))
- (slot-value parent 'names)))))
+(defmethod equivalent-constructs ((construct-1 AssociationC)
+ (construct-2 AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (ignorable revision))
+ (and (eql (instance-of construct-1 :revision revision)
+ (instance-of construct-2 :revision revision))
+ (not (set-exclusive-or (themes construct-1 :revision revision)
+ (themes construct-2 :revision revision)))
+
+ (not (set-exclusive-or
+ (roles construct-1 :revision revision)
+ (roles construct-2 :revision revision)
+ :test #'(lambda(role-1 role-2)
+ (strictly-equivalent-constructs role-1 role-2
+ :revision revision))))))
+
+
+(defgeneric AssociationC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to AssociationC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'AssociationC)))
+
+
+(defmethod equivalent-construct ((construct AssociationC)
+ &key (start-revision *TM-REVISION*)
+ (roles nil) (instance-of nil) (themes nil))
+ "Associations are equal if their themes, instance-of and roles
+ properties are equal.
+ To avoid ceation of duplicate roles the parameter roles is a list of plists
+ of the form: ((:player <TopicC> :instance-of <TopicC>
+ :item-identifiers <(ItemIdentifierC)> :reifier <TopicC>))."
+ (declare (integer start-revision) (list roles themes)
+ (type (or null TopicC) instance-of))
+ ;; item-identifiers and reifers are not checked because the equality have to
+ ;; be variafied without them
+ (let ((checked-roles nil))
+ (loop for plist in roles
+ do (let ((found-role
+ (find-if #'(lambda(assoc-role)
+ (equivalent-construct
+ assoc-role :player (getf plist :player)
+ :start-revision (or (getf plist :start-revision)
+ start-revision)
+ :instance-of (getf plist :instance-of)))
+ (roles construct :revision start-revision))))
+ (when found-role
+ (push found-role checked-roles))))
+ (and
+ (not (set-exclusive-or (roles construct :revision start-revision)
+ checked-roles))
+ (= (length checked-roles) (length roles))
+ (equivalent-typable-construct construct instance-of
+ :start-revision start-revision)
+ (equivalent-scopable-construct construct themes
+ :start-revision start-revision))))
-(defmethod delete-construct :before ((construct NameC))
- (dolist (variant (variants construct))
- (delete-construct variant)))
+(defmethod delete-construct :before ((construct AssociationC))
+ (let ((roles-assocs-to-delete (slot-p construct 'roles)))
+ (let ((all-roles (map 'list #'role roles-assocs-to-delete)))
+ (dolist (role-assoc-to-delete roles-assocs-to-delete)
+ (delete-construct role-assoc-to-delete))
+ (dolist (candidate-to-delete all-roles)
+ (unless (owned-p candidate-to-delete)
+ (delete-construct candidate-to-delete)))
+ (dolist (tm (slot-p construct 'in-topicmaps))
+ (remove-association construct 'in-topicmaps tm)))))
+
+
+(defmethod owned-p ((construct AssociationC))
+ (when (slot-p construct 'in-topicmaps)
+ t))
+
+
+(defgeneric roles (construct &key revision)
+ (:documentation "Returns all topics that correspond with the given revision
+ as a scope for the given topic.")
+ (:method ((construct AssociationC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'roles
+ :start-revision revision)))
+ (map 'list #'role valid-associations))))
+
+
+(defgeneric add-role (construct role &key revision)
+ (:documentation "Adds the given role to the passed association-construct.")
+ (:method ((construct AssociationC) (role RoleC)
+ &key (revision *TM-REVISION*))
+ (if (merge-if-equivalent role construct :revision revision)
+ construct
+ (let ((all-roles
+ (map 'list #'role (slot-p construct 'roles))))
+ (if (find role all-roles)
+ (let ((role-assoc
+ (loop for role-assoc in (slot-p construct 'roles)
+ when (eql (role role-assoc) role)
+ return role-assoc)))
+ (add-to-version-history role-assoc :start-revision revision))
+ (make-construct 'RoleAssociationC
+ :role role
+ :parent-construct construct
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
+
+
+(defgeneric private-delete-role (construct role &key revision)
+ (:documentation "Deletes the passed role by marking it's association as
+ deleted in the passed revision.")
+ (:method ((construct AssociationC) (role RoleC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-role(): revision must be set" 'revision 'private-delete-role))))
+ (let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles)
+ when (eql (role role-assoc) role)
+ return role-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-role (construct role &key revision)
+ (:documentation "See private-delete-role but adds the parent association
+ to the given version.")
+ (:method ((construct AssociationC) (role RoleC)
+ &key (revision (error (make-missing-argument-condition "From delete-role(): revision must be set" 'revision 'delete-role))))
+ (when (private-delete-role construct role :revision revision)
+ (add-to-version-history construct :start-revision revision)
+ construct)))
-(defmethod equivalent-constructs ((name1 NameC) (name2 NameC))
- "check for the equlity of two names by the TMDM's equality
-rules (5.4)"
- (and
- (string= (charvalue name1) (charvalue name2))
- (or (and (instance-of-p name1)
- (instance-of-p name2)
- (= (internal-id (instance-of name1))
- (internal-id (instance-of name2))))
- (and (not (instance-of-p name1)) (not (instance-of-p name2))))
- (not (set-exclusive-or (themes name1) (themes name2) :key #'internal-id))))
-
+(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
+ (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
+;;; RoleC
+(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision)
+ "Marks the last active relation between a role and its parent association
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (parent construct :revision 0)))
+ (when owner
+ (private-delete-role owner construct :revision revision))))
+
+
+(defmethod marked-as-deleted-p ((construct RoleC))
+ (unless (parent construct :revision 0)
+ t))
-;;;;;;;;;;;;;;
-;;
-;; OccurrenceC
-(elephant:defpclass OccurrenceC (CharacteristicC)
- ((datatype :accessor datatype
- :initarg :datatype
- :initform nil
- :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")))
+(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((p-roles (roles parent-construct :revision revision)))
+ (let ((self (find construct p-roles)))
+ (if self
+ self
+ (let ((equal-role
+ (remove-if #'null
+ (map 'list
+ #'(lambda(role)
+ (strictly-equivalent-constructs
+ role construct :revision revision))
+ p-roles))))
+ (when equal-role
+ (first equal-role)))))))
+
+
+(defmethod delete-if-not-referenced ((construct RoleC))
+ (let ((references (slot-p construct 'parent)))
+ (when (or (not references)
+ (and (= (length references) 1)
+ (marked-as-deleted-p (first references))))
+ (delete-construct construct))))
+
+
+(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
+ (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
+ (vi-2 (find-version-info (slot-p construct-2 'parent))))
+ (cond ((not (or vi-1 vi-2))
+ construct-1)
+ ((not vi-1)
+ construct-2)
+ ((not vi-2)
+ construct-1)
+ ((<= (start-revision vi-1) (start-revision vi-2))
+ construct-1)
+ (t
+ construct-2))))
-(defgeneric OccurrenceC-p (object)
- (:documentation "test if object is a of type OccurrenceC")
- (:method ((object t)) nil)
- (:method ((object OccurrenceC)) object))
+(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (and (eql (instance-of construct-1 :revision revision)
+ (instance-of construct-2 :revision revision))
+ (eql (player construct-1 :revision revision)
+ (player construct-2 :revision revision))))
+
+
+(defgeneric RoleC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to RoleC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'RoleC)))
+
+
+(defmethod equivalent-construct ((construct RoleC)
+ &key (start-revision *TM-REVISION*)
+ (player nil) (instance-of nil))
+ "Roles are equal if their instance-of and player properties are equal."
+ (declare (integer start-revision) (type (or null TopicC) player instance-of))
+ ;; item-identifiers and reifers are not checked because the equality have to
+ ;; be variafied without them
+ (and (equivalent-typable-construct construct instance-of
+ :start-revision start-revision)
+ (eql player (player construct :revision start-revision))))
+
+
+(defmethod find-item-by-revision ((construct RoleC)
+ (revision integer) &optional parent-construct)
+ (if parent-construct
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'parent)))))
+ (when assocs
+ (first assocs)))))
+ (when parent-assoc
+ (cond ((= revision 0)
+ (when
+ (find-most-recent-revision parent-assoc)
+ construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
+ nil))
-(defmethod find-all-equivalent ((construct OccurrenceC))
- (let
- ((parent (and (slot-boundp construct 'topic)
- (topic construct))))
- (when parent
- (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand))
- (slot-value parent 'occurrences)))))
-
-(defmethod equivalent-constructs ((occ1 OccurrenceC) (occ2 OccurrenceC))
- "Occurrence items are equal if the values of their [value], [datatype], [scope], [type], and [parent] properties are equal (TMDM 5.6)"
- (and
- (string= (charvalue occ1) (charvalue occ2))
- (not (set-exclusive-or (themes occ1) (themes occ2) :key #'internal-id))
- (= (internal-id (topic occ1)) (internal-id (topic occ2)))
- (or
- (and (instance-of-p occ1) (instance-of-p occ2)
- (=
- (internal-id (instance-of occ1))
- (internal-id (instance-of occ2))))
- (and (not (instance-of-p occ1)) (not (instance-of-p occ2))))))
-
-
-;;;;;;;;;;;;;;;;;
-;;
-;; TopicC
-
-(elephant:defpclass TopicC (ReifiableConstructC)
- ((topic-identifiers
- :accessor topic-identifiers
- :associate (TopicIdentificationC identified-construct))
- (psis ;accessor written below
- :associate (PersistentIdC identified-construct)
- :documentation "list of PSI objects associated with this
- topic")
- (locators
- ;accessor written below
- :associate (SubjectLocatorC identified-construct)
- :documentation "an optional URL that (if given) means that this topic is a subject locator")
- (names ;accessor written below
- :associate (NameC topic)
- :documentation "list of topic names (as TopicC objects)")
- (occurrences ;accessor occurrences explicitly written below
- :associate (OccurrenceC topic)
- :documentation "list of occurrences (as OccurrenceC objects)")
- (player-in-roles ;accessor player-in-roles written below
- :associate (RoleC player)
- :documentation "the list of all role instances where this topic is a player in")
- (used-as-type ;accessor used-as-type written below
- :associate (TypableC instance-of)
- :documentation "list of all constructs that have this topic as their type")
- (used-as-theme ;accessor used-as-theme written below
- :associate (ScopableC themes)
- :many-to-many t
- :documentation "list of all scopable objects this topic is a theme in")
- (in-topicmaps
- :associate (TopicMapC topics)
- :many-to-many t
- :documentation "list of all topic maps this topic is part of")
- (reified
- :associate ReifiableConstructC
- :documentation "contains a reified object, represented as 1:1 association"))
- (:documentation "Topic in a Topic Map"))
-
-
-(defgeneric reified (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (when (slot-boundp topic 'reified)
- (slot-value topic 'reified))))
-
-(defgeneric (setf reified) (reifiable ReifiableConstructC)
- (:method (reifiable (topic TopicC))
- (setf (slot-value topic 'reified) reifiable)))
-; (setf (reifier reifiable) topic)))
-
-(defgeneric occurrences (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision topic 'occurrences :start-revision revision)))
-
-(defgeneric names (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision topic 'names :start-revision revision)))
-
-(defgeneric psis (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision
- topic 'psis :start-revision revision)))
-
-(defgeneric locators (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision
- topic 'locators :start-revision revision)))
-
-(defgeneric player-in-roles (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision
- topic 'player-in-roles :start-revision revision)))
-
-(defgeneric used-as-type (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision topic 'used-as-type :start-revision revision)))
-
-(defgeneric used-as-theme (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision)))
-
-(defgeneric in-topicmaps (topic &key revision)
- (:method ((topic TopicC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)))
-
-(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers))
- "Moves all identifiers from the source-topic to the destination topic."
- (declare (TopicC destination-topic source-topic))
- (let ((all-source-identifiers
- (cond
- ((eql what 'item-identifiers)
- (item-identifiers source-topic))
- ((eql what 'locators)
- (locators source-topic))
- (t
- (psis source-topic))))
- (all-destination-identifiers
- (cond
- ((eql what 'item-identifiers)
- (item-identifiers destination-topic))
- ((eql what 'locators)
- (locators destination-topic))
- ((eql what 'psis)
- (psis destination-topic))
- ((eql what 'topic-identifiers)
- (topic-identifiers destination-topic)))))
- (let ((identifiers-to-move
- (loop for id in all-source-identifiers
- when (not (find-if #'(lambda(x)
- (if (eql what 'topic-identifiers)
- (string= (xtm-id x) (xtm-id id))
- (string= (uri x) (uri id))))
- all-destination-identifiers))
- collect id)))
- (dolist (item identifiers-to-move)
- (remove-association source-topic what item)
- (add-association destination-topic what item)))))
-
-(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil))
- "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators"
- (declare (list psis))
- (declare (list locators))
+
+(defmethod delete-construct :before ((construct RoleC))
+ (dolist (role-assoc-to-delete (slot-p construct 'parent))
+ (delete-construct role-assoc-to-delete))
+ (dolist (player-assoc-to-delete (slot-p construct 'player))
+ (delete-construct player-assoc-to-delete)))
+
+
+(defgeneric player-p (construct)
+ (:documentation "Returns t if a player is set in this role.
+ t is also returned if the player is markes-as-deleted.")
+ (:method ((construct RoleC))
+ (when (slot-p construct 'player)
+ t)))
+
+
+(defmethod owned-p ((construct RoleC))
+ (when (slot-p construct 'parent)
+ t))
+
+
+(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*))
+ "Returns the construct's parent corresponding to the given revision."
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'parent
+ :start-revision revision)))
+ (when valid-associations
+ (parent-construct (first valid-associations)))))
+
+
+(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((already-set-parent (parent construct :revision revision))
+ (same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct (parent-construct parent-assoc))
+ return parent-assoc)))
+ (when (and already-set-parent
+ (not (eql already-set-parent parent-construct)))
+ (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ construct parent-construct already-set-parent)
+ construct (parent construct :revision revision) parent-construct)))
+ (let ((merged-role
+ (merge-if-equivalent construct parent-construct :revision revision)))
+ (if merged-role
+ merged-role
+ (progn
+ (cond (already-set-parent
+ (let ((parent-assoc
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct
+ (parent-construct parent-assoc))
+ return parent-assoc)))
+ (add-to-version-history parent-assoc
+ :start-revision revision)))
+ (same-parent-assoc
+ (add-to-version-history same-parent-assoc
+ :start-revision revision))
+ (t
+ (make-construct 'RoleAssociationC
+ :role construct
+ :parent-construct parent-construct
+ :start-revision revision)))
+ (add-to-version-history parent-construct :start-revision revision)
+ construct)))))
+
+
+(defmethod private-delete-parent ((construct RoleC) (parent-construct AssociationC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent))))
+ (let ((assoc-to-delete
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql (parent-construct parent-assoc) parent-construct)
+ return parent-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct)))
+
+
+(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
+ &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent))))
+ (when (private-delete-parent construct parent-construct :revision revision)
+ (add-to-version-history parent-construct :start-revision revision)
+ construct))
+
+
+(defgeneric player (construct &key revision)
+ (:documentation "Returns the construct's player corresponding to
+ the given revision.")
+ (:method ((construct RoleC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'player
+ :start-revision revision)))
+ (when valid-associations
+ (player-topic (first valid-associations))))))
+
+
+(defgeneric add-player (construct player-topic &key revision)
+ (:documentation "Adds a topic as a player to a role in the given revision.")
+ (:method ((construct RoleC) (player-topic TopicC)
+ &key (revision *TM-REVISION*))
+ (let ((already-set-player (player construct :revision revision))
+ (same-player-assoc
+ (loop for player-assoc in (slot-p construct 'player)
+ when (eql (player-topic player-assoc) player-topic)
+ return player-assoc)))
+ (when (and already-set-player
+ (not (eql already-set-player player-topic)))
+ (error (make-tm-reference-condition (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player)
+ construct (player construct :revision revision) player-topic)))
+ (cond (already-set-player
+ (let ((player-assoc
+ (loop for player-assoc in (slot-p construct 'player)
+ when (eql player-topic (player-topic player-assoc))
+ return player-assoc)))
+ (add-to-version-history player-assoc :start-revision revision)))
+ (same-player-assoc
+ (add-to-version-history same-player-assoc :start-revision revision))
+ (t
+ (make-construct 'PlayerAssociationC
+ :parent-construct construct
+ :player-topic player-topic
+ :start-revision revision))))
+ construct))
+
+
+(defgeneric private-delete-player (construct player-topic &key revision)
+ (:documentation "Deletes the passed topic as a player of the passed role
+ object by marking its association-object as deleted.")
+ (:method ((construct RoleC) (player-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-player(): revision must be set" 'revision 'private-delete-player))))
+ (let ((assoc-to-delete
+ (loop for player-assoc in (slot-p construct 'player)
+ when (eql (parent-construct player-assoc) construct)
+ return player-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-player (construct player-topic &key revision)
+ (:documentation "See delete-player but adds the parent role to
+ the given version.")
+ (:method ((construct RoleC) (player-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From delete-player(): revision must be set" 'revision 'delete-player))))
+ (when (private-delete-player construct player-topic :revision revision)
+ (let ((assoc (parent construct :revision revision)))
+ (when assoc
+ (add-role assoc construct :revision revision)
+ construct)))))
+
+
+;;; ReifiableConstructC
+(defmethod mark-as-deleted :around ((construct ReifiableConstructC)
+ &key source-locator revision)
+ "Marks all item-identifiers of a given reifiable-construct as deleted."
+ (declare (ignorable source-locator))
(call-next-method)
- ;item-identifiers are handled in the around-method for ReifiableConstructs,
- ;TopicIdentificationCs are handled in make-construct of TopicC
- (dolist (persistent-id psis)
- (declare (PersistentIdC persistent-id))
- (setf (identified-construct persistent-id) instance))
- (dolist (subject-locator locators)
- (declare (SubjectLocatorC subject-locator))
- (setf (identified-construct subject-locator) instance))
- (when reified
- (setf (reified instance) reified)))
+ (dolist (ii (item-identifiers construct :revision 0))
+ (private-delete-item-identifier construct ii :revision revision)))
-(defmethod delete-construct :before ((construct TopicC))
- (dolist (dependent (append (topic-identifiers construct)
- (psis construct)
- (locators construct)
- (names construct)
- (occurrences construct)
- (player-in-roles construct)
- (used-as-type construct)))
- (delete-construct dependent))
- (dolist (theme (used-as-theme construct))
- (elephant:remove-association construct 'used-as-theme theme))
- (dolist (tm (in-topicmaps construct))
- (elephant:remove-association construct 'in-topicmaps tm))
- (when (reified construct)
- (slot-makunbound (reified construct) 'reifier)))
-
-(defun get-all-constructs-by-uri (uri)
- (delete
- nil
- (mapcar
- (lambda (identifier)
- (and
- (slot-boundp identifier 'identified-construct)
- (identified-construct identifier)))
- (union
- (union
- (elephant:get-instances-by-value 'ItemIdentifierC 'uri uri)
- (elephant:get-instances-by-value 'PersistentIdC 'uri uri))
- (elephant:get-instances-by-value 'SubjectLocatorC 'uri uri)))))
+(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (dolist (id (get-all-identifiers-of-construct construct :revision revision))
+ (when (>
+ (length
+ (delete-if-not #'(lambda(identifier)
+ (or (typep identifier 'PersistentIdC)
+ (typep identifier 'SubjectLocatorC)
+ (typep identifier 'ItemIdentifierC)))
+ (union
+ (elephant:get-instances-by-value
+ 'ItemIdentifierC 'uri (uri id))
+ (union
+ (elephant:get-instances-by-value
+ 'PersistentIdC 'uri (uri id))
+ (elephant:get-instances-by-value
+ 'SubjectLocatorC 'uri (uri id))))))
+ 1)
+ (error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id))))))
+
+
+(defgeneric ReifiableConstructC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to ReifiableConstructC
+ or one of its subtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'ReifiableconstructC)
+ (TopicMapC-p class-symbol)
+ (TopicC-p class-symbol)
+ (AssociationC-p class-symbol)
+ (RoleC-p class-symbol)
+ (CharacteristicC-p class-symbol))))
+
+
+(defgeneric complete-reifiable (construct item-identifiers reifier
+ &key start-revision)
+ (:documentation "Adds all item-identifiers and the reifier to the passed
+ construct.")
+ (:method ((construct ReifiableConstructC) item-identifiers reifier
+ &key (start-revision *TM-REVISION*))
+ (declare (integer start-revision) (list item-identifiers)
+ (type (or null TopicC) reifier))
+ (let ((merged-construct construct))
+ (dolist (ii item-identifiers)
+ (setf merged-construct
+ (add-item-identifier merged-construct ii
+ :revision start-revision)))
+ (when reifier
+ (setf merged-construct (add-reifier merged-construct reifier
+ :revision start-revision)))
+ merged-construct)))
+
+
+(defgeneric equivalent-reifiable-construct (construct reifier item-identifiers
+ &key start-revision)
+ (:documentation "Returns t if the passed constructs are TMDM equal, i.e
+ the reifiable construct have to share an item identifier
+ or reifier.")
+ (:method ((construct ReifiableConstructC) reifier item-identifiers
+ &key (start-revision *TM-REVISION*))
+ (declare (integer start-revision) (list item-identifiers)
+ (type (or null TopicC) reifier))
+ (or (and (reifier construct :revision start-revision)
+ (eql reifier (reifier construct :revision start-revision)))
+ (and (item-identifiers construct :revision start-revision)
+ (intersection (item-identifiers construct :revision start-revision)
+ item-identifiers)))))
-(defun find-existing-topic (item-identifiers locators psis)
- (let
- ((uris
- (mapcar #'uri
- (union (union item-identifiers locators) psis)))
- (existing-topics nil))
- (dolist (uri uris)
- (setf existing-topics
- (nunion existing-topics
- (get-all-constructs-by-uri uri)
- :key #'internal-id)))
- (assert (<= (length existing-topics) 1))
- (first existing-topics)))
+(defmethod delete-construct :before ((construct ReifiableConstructC))
+ (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers))
+ (reifier-assocs-to-delete (slot-p construct 'reifier)))
+ (let ((all-iis (map 'list #'identifier ii-assocs-to-delete)))
+ (dolist (construct-to-delete (append ii-assocs-to-delete
+ reifier-assocs-to-delete))
+ (delete-construct construct-to-delete))
+ (dolist (ii all-iis)
+ (unless (owned-p ii)
+ (delete-construct ii))))))
-(defmethod make-construct ((class-symbol (eql 'TopicC)) &rest args
- &key start-revision item-identifiers locators psis topicid xtm-id)
- (let
- ((existing-topic
- (find-existing-topic item-identifiers locators psis)))
- (if existing-topic
- (progn
- ;our problem with topics is that we know only after the
- ;addition of all the identifiers and characteristics if
- ;anything has changed. We can't decide that here, so we must
- ;add all revisions (real or imaginary) to version history
- ;and decide the rest in changed-p. Maybe somebody can think
- ;of a better way?
- (add-to-version-history existing-topic
- :start-revision start-revision)
- (init-topic-identification existing-topic topicid xtm-id
- :revision start-revision)
- (let* ;add new identifiers to existing topics
- ((all-new-identifiers
- (union (union item-identifiers locators) psis))
- (all-existing-identifiers
- (get-all-identifiers-of-construct existing-topic)))
- (mapc
- (lambda (identifier)
- (setf (identified-construct identifier) existing-topic))
- (set-difference all-new-identifiers all-existing-identifiers
- :key #'uri :test #'string=))
- (mapc #'delete-construct
- (delete-if
- (lambda (identifier)
- (slot-boundp identifier 'identified-construct))
- all-new-identifiers)))
- (check-for-duplicate-identifiers existing-topic)
- existing-topic)
- (progn
- (let*
- ((cleaned-args (remove-nil-values args))
- (new-topic
- (apply #'make-instance 'TopicC cleaned-args)))
-
- (init-topic-identification new-topic topicid xtm-id
- :revision start-revision)
- (check-for-duplicate-identifiers new-topic)
- (add-to-version-history new-topic
- :start-revision start-revision)
- new-topic)))))
-
-(defmethod make-construct :around ((class-symbol (eql 'TopicC))
- &key start-revision &allow-other-keys)
- (declare (ignorable start-revision))
- (call-next-method))
+(defgeneric item-identifiers (construct &key revision)
+ (:documentation "Returns the ItemIdentifierC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'item-identifiers :start-revision revision)))
+ (map 'list #'identifier assocs))))
-
-(defmethod equivalent-constructs ((topic1 TopicC) (topic2 TopicC))
- "TMDM, 5.3.5: Equality rule: Two topic items are equal if they have:
-* at least one equal string in their [subject identifiers] properties,
+(defgeneric reifier (construct &key revision)
+ (:documentation "Returns the reifier-topic that corresponds
+ with the passed construct and the passed version.")
+ (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'reifier :start-revision revision)))
+ (when assocs ;assocs must be nil or a list with exactly one item
+ (reifier-topic (first assocs))))))
+
+
+(defgeneric add-item-identifier (construct item-identifier &key revision)
+ (:documentation "Adds the passed item-identifier to the passed construct.
+ If the item-identifier is already related with the passed
+ construct a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier (slot-p construct 'item-identifiers)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct item-identifier
+ :revision revision)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (when (and construct-to-be-merged
+ (not (eql (type-of construct-to-be-merged)
+ (type-of construct))))
+ (error (make-not-mergable-condition (format nil "From add-item-identifier(): ~a and ~a can't be merged since the identified-constructs are not of the same type"
+ construct construct-to-be-merged)
+ construct construct-to-be-merged)))
+ (let ((merged-construct construct))
+ (cond (construct-to-be-merged
+ (setf merged-construct
+ (merge-constructs construct construct-to-be-merged
+ :revision revision)))
+ ((find item-identifier all-ids)
+ (let ((ii-assoc
+ (loop for ii-assoc in (slot-p construct 'item-identifiers)
+ when (eql (identifier ii-assoc) item-identifier)
+ return ii-assoc)))
+ (add-to-version-history ii-assoc :start-revision revision)))
+ (t
+ (make-construct 'ItemIdAssociationC
+ :parent-construct construct
+ :identifier item-identifier
+ :start-revision revision)))
+ (add-version-info construct revision)
+ merged-construct))))
+
+
+(defgeneric private-delete-item-identifier (construct item-identifier
+ &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-item-identifier(): revision must be set" 'revision 'private-delete-item-identifier))))
+ (let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers)
+ when (eql (identifier ii-assoc) item-identifier)
+ return ii-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-item-identifier (construct item-identifier
+ &key revision)
+ (:documentation "See private-delete-item-identifier but adds the parent
+ construct to the given version.")
+ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
+ &key (revision (error (make-missing-argument-condition "From delete-item-identifier(): revision must be set" 'revision 'delete-item-identifier))))
+ (when (private-delete-item-identifier construct item-identifier
+ :revision revision)
+ (add-version-info construct revision)
+ construct)))
-* at least one equal string in their [item identifiers] properties,
-* at least one equal string in their [subject locators] properties,
+(defgeneric add-reifier (construct reifier-topic &key revision)
+ (:documentation "Adds the passed reifier-topic as reifier of the construct.
+ If the construct is already reified by the given topic
+ there only is added a new version-info.
+ If the reifier-topic reifies already another construct
+ the reified-constructs are merged.")
+ (:method ((construct ReifiableConstructC) (reifier-topic TopicC)
+ &key (revision *TM-REVISION*))
+ (when (and (reified-construct reifier-topic :revision revision)
+ (not (equivalent-constructs construct
+ (reified-construct
+ reifier-topic :revision revision))))
+ (error (make-not-mergable-condition (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable"
+ reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct)
+ construct (reified-construct reifier-topic :revision revision))))
+ (let ((merged-reifier-topic
+ (if (reifier construct :revision revision)
+ (merge-constructs (reifier construct :revision revision)
+ reifier-topic)
+ reifier-topic)))
+ (let ((all-constructs (map 'list #'reifiable-construct
+ (slot-p reifier-topic 'reified-construct))))
+ (let ((merged-construct construct))
+ (cond ((reified-construct merged-reifier-topic :revision revision)
+ (let ((merged-reified
+ (merge-constructs
+ (reified-construct merged-reifier-topic
+ :revision revision) construct)))
+ (setf merged-construct merged-reified)))
+ ((find construct all-constructs)
+ (let ((reifier-assoc
+ (loop for reifier-assoc in
+ (slot-p merged-reifier-topic 'reified-construct)
+ when (eql (reifiable-construct reifier-assoc)
+ construct)
+ return reifier-assoc)))
+ (add-to-version-history reifier-assoc
+ :start-revision revision)))
+ (t
+ (make-construct 'ReifierAssociationC
+ :reifiable-construct construct
+ :reifier-topic merged-reifier-topic
+ :start-revision revision)))
+ (add-version-info construct revision)
+ merged-construct)))))
+
+
+(defgeneric private-delete-reifier (construct reifier &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct ReifiableConstructC) (reifier TopicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-reifier(): revision must be set" 'revision 'private-delete-reifier))))
+ (let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier)
+ when (eql (reifier-topic reifier-assoc) reifier)
+ return reifier-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-reifier (construct reifier &key revision)
+ (:documentation "See private-delete-reifier but adds the reified-construct
+ to the given version.")
+ (:method ((construct ReifiableConstructC) (reifier TopicC)
+ &key (revision (error (make-missing-argument-condition "From delete-reifier(): revision must be set" 'revision 'delete-reifier))))
+ (when (private-delete-reifier construct reifier :revision revision)
+ (add-version-info construct revision)
+ construct)))
-* an equal string in the [subject identifiers] property of the one
-topic item and the [item identifiers] property of the other, or the
-same information item in their [reified] properties (TODO: this rule
-is currently ignored)"
- ;(declare (optimize (debug 3)))
- (let
- ((psi-uris1
- (map 'list #'uri (psis topic1)))
- (psi-uris2
- (map 'list #'uri (psis topic2)))
- (ii-uris1
- (map 'list #'uri (item-identifiers topic1)))
- (ii-uris2
- (map 'list #'uri (item-identifiers topic2)))
- (locators1
- (map 'list #'uri (locators topic1)))
- (locators2
- (map 'list #'uri (locators topic2))))
- (let
- ((all-uris1
- (union psi-uris1 (union ii-uris1 locators1) :test #'string=))
- (all-uris2
- (union psi-uris2 (union ii-uris2 locators2) :test #'string=)))
- ;;TODO: consider what we should do about this. If the topic at a
- ;;given revision doesn't exist yet, it correctly has no uris
- ;;(for that version)
- ;; (when (= 0 (length all-uris1))
-;; (error (make-condition 'no-identifier-error :message "Topic1 has no identifier" :internal-id (internal-id topic1))))
-;; (when (= 0 (length all-uris2))
-;; (error (make-condition 'no-identifier-error :message "Topic2 has no identifier" :internal-id (internal-id topic2))))
- (intersection
- all-uris1 all-uris2
- :test #'string=))))
-
-(defmethod get-all-identifiers-of-construct ((top TopicC))
- (append (psis top)
- (locators top)
- (item-identifiers top)))
-
-(defmethod topicid ((top TopicC) &optional (xtm-id nil))
- "Return the primary id of this item (= essentially the OID). If
-xtm-id is explicitly given, return one of the topicids in that
-TM (which must then exist)"
- (if xtm-id
- (let
- ((possible-identifications
- (remove-if-not
- (lambda (top-id)
- (string= (xtm-id top-id) xtm-id))
- (elephant:get-instances-by-value
- 'TopicIdentificationC
- 'identified-construct
- top))))
- (unless possible-identifications
- (error (make-condition
- 'object-not-found-error
- :message
- (format nil "Could not find an object ~a in xtm-id ~a" top xtm-id))))
- (uri (first possible-identifications)))
- (format nil "t~a"
- (internal-id top))))
-
+(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (item-identifiers construct :revision revision))
-(defgeneric psis-p (top)
- (:documentation "Test for the existence of PSIs")
- (:method ((top TopicC)) (slot-predicate top 'psis)))
-(defgeneric list-instanceOf (topic &key tm)
- (:documentation "Generate a list of all topics that this topic is an
- instance of, optionally filtered by a topic map"))
+;;; TypableC
+(defgeneric TypableC-p (class-symbol)
+ (:documentation "Returns t if the passed class is equal to TypableC or
+ one of its subtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'TypableC)
+ (AssociationC-p class-symbol)
+ (RoleC-p class-symbol)
+ (CharacteristicC-p class-symbol))))
+
+
+(defgeneric complete-typable (construct instance-of &key start-revision)
+ (:documentation "Adds the passed instance-of to the given construct.")
+ (:method ((construct TypableC) instance-of
+ &key (start-revision *TM-REVISION*))
+ (declare (integer start-revision) (type (or null TopicC) instance-of))
+ (when instance-of
+ (add-type construct instance-of :revision start-revision))
+ construct))
-(defmethod list-instanceOf ((topic TopicC) &key (tm nil))
- (remove-if
- #'null
- (map 'list #'(lambda(x)
- (when (loop for psi in (psis (instance-of x))
- when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance")
- return t)
- (loop for role in (roles (parent x))
- when (not (eq role x))
- return (player role))))
- (if tm
- (remove-if-not
- (lambda (role)
- ;(format t "player: ~a" (player role))
- ;(format t "parent: ~a" (parent role))
- ;(format t "topic: ~a~&" topic)
- (in-topicmap tm (parent role)))
- (player-in-roles topic))
- (player-in-roles topic)))))
+(defgeneric equivalent-typable-construct (construct instance-of
+ &key start-revision)
+ (:documentation "Returns t if the passed constructs are TMDM equal, i.e.
+ the typable constructs have to own the same type.")
+ (:method ((construct TypableC) instance-of &key (start-revision *TM-REVISION*))
+ (declare (integer start-revision)
+ (type (or null TopicC) instance-of))
+ (eql (instance-of construct :revision start-revision) instance-of)))
+
+
+;;; ScopableC
+(defgeneric ScopableC-p (class-symbol)
+ (:documentation "Returns t if the passed class is equal to ScopableC or
+ one of its subtypes.")
+ (:method ((class-symbol symbol))
+ (or (eql class-symbol 'ScopableC)
+ (AssociationC-p class-symbol)
+ (CharacteristicC-p class-symbol))))
+
+
+(defgeneric complete-scopable (construct themes &key start-revision)
+ (:documentation "Adds all passed themes to the given construct.")
+ (:method ((construct ScopableC) (themes list)
+ &key (start-revision *TM-REVISION*))
+ (declare (integer start-revision))
+ (dolist (theme themes)
+ (add-theme construct theme :revision start-revision))
+ construct))
-(defgeneric list-super-types (topic &key tm)
- (:documentation "Generate a list of all topics that this topic is an
- subclass of, optionally filtered by a topic map"))
+(defgeneric equivalent-scopable-construct (construct themes &key start-revision)
+ (:documentation "Returns t if the passed constructs are TMDM equal, i.e.
+ the scopable constructs have to own the same themes.")
+ (:method ((construct ScopableC) themes &key (start-revision *TM-REVISION*))
+ (declare (integer start-revision) (list themes))
+ (not (set-exclusive-or (themes construct :revision start-revision)
+ themes))))
-(defmethod list-super-types ((topic TopicC) &key (tm nil))
- (remove-if
- #'null
- (map 'list #'(lambda(x)
- (when (loop for psi in (psis (instance-of x))
- when (string= (uri psi) *subtype-psi*)
- return t)
- (loop for role in (roles (parent x))
- when (not (eq role x))
- return (player role))))
- (if tm
- (remove-if-not
- (lambda (role)
- (format t "player: ~a" (player role))
- (format t "parent: ~a" (parent role))
- (format t "topic: ~a~&" topic)
- (in-topicmap tm (parent role)))
- (player-in-roles topic))
- (player-in-roles topic)))))
+(defmethod delete-construct :before ((construct ScopableC))
+ (dolist (scope-assoc-to-delete (slot-p construct 'themes))
+ (delete-construct scope-assoc-to-delete)))
-(defun string-starts-with (str prefix)
- "Checks if string str starts with a given prefix"
- (declare (string str prefix))
- (string= str prefix :start1 0 :end1
- (min (length prefix)
- (length str))))
+(defgeneric themes (construct &key revision)
+ (:documentation "Returns all topics that correspond with the given revision
+ as a scope for the given topic.")
+ (:method ((construct ScopableC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'themes
+ :start-revision revision)))
+ (map 'list #'theme-topic valid-associations))))
+
+
+(defgeneric add-theme (construct theme-topic &key revision)
+ (:documentation "Adds the given theme-topic to the passed
+ scopable-construct.")
+ (:method ((construct ScopableC) (theme-topic TopicC)
+ &key (revision *TM-REVISION*))
+ (let ((all-themes
+ (map 'list #'theme-topic (slot-p construct 'themes))))
+ (if (find theme-topic all-themes)
+ (let ((theme-assoc
+ (loop for theme-assoc in (slot-p construct 'themes)
+ when (eql (theme-topic theme-assoc) theme-topic)
+ return theme-assoc)))
+ (add-to-version-history theme-assoc :start-revision revision))
+ (make-construct 'ScopeAssociationC
+ :theme-topic theme-topic
+ :scopable-construct construct
+ :start-revision revision)))
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision revision))
+ construct))
-(defun get-item-by-item-identifier (uri &key revision)
- "get a construct by its item identifier. Returns nil if the item does not exist in a
-particular revision"
- (declare (string uri))
- (declare (integer revision))
- (let
- ((ii-obj
- (elephant:get-instance-by-value 'ItemIdentifierC
- 'uri uri)))
- (when ii-obj
- (find-item-by-revision
- (identified-construct ii-obj) revision))))
+(defgeneric private-delete-theme (construct theme-topic &key revision)
+ (:documentation "Deletes the passed theme by marking it's association as
+ deleted in the passed revision.")
+ (:method ((construct ScopableC) (theme-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-theme(): revision must be set" 'revision 'private-delete-theme))))
+ (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
+ when (eql (theme-topic theme-assoc) theme-topic)
+ return theme-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-theme (construct theme-topic &key revision)
+ (:documentation "See private-delete-theme but adds the parent construct
+ to the given version.")
+ (:method ((construct ScopableC) (theme-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From delete-theme(): revision must be set" 'revision 'delete-theme))))
+ (when (private-delete-theme construct theme-topic :revision revision)
+ (add-version-info construct revision)
+ construct)))
-(defun get-item-by-psi (psi &key (revision 0))
- "get a topic by its PSI. Returns nil if the item does not exist in a
-particular revision"
- (declare (string psi))
- (declare (integer revision))
- (let
- ((psi-obj
- (elephant:get-instance-by-value 'PersistentIdC
- 'uri psi)))
- (when psi-obj
- (find-item-by-revision
- (identified-construct psi-obj) revision))))
-
-(defun get-item-by-id (topicid &key (xtm-id *current-xtm*) (revision 0) (error-if-nil nil))
- "get a topic by its id, assuming a xtm-id. If xtm-id is empty, the current TM
-is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
-applicable in the correct revision. If revison is provided, then the code checks
-if the topic already existed in this revision and returns nil otherwise.
-If no item meeting the constraints was found, then the return value is either
-NIL or an error is thrown, depending on error-if-nil."
+
+;;; TypableC
+(defmethod delete-construct :before ((construct TypableC))
+ (dolist (type-assoc-to-delete (slot-p construct 'instance-of))
+ (delete-construct type-assoc-to-delete)))
+
+
+(defgeneric instance-of-p (construct)
+ (:documentation "Returns t if there is any type set in this object.
+ t is also returned if the type is marked-as-deleted.")
+ (:method ((construct TypableC))
+ (when (slot-p construct 'instance-of)
+ t)))
+
+
+(defgeneric instance-of (construct &key revision)
+ (:documentation "Returns the type topic that is set on the passed
+ revision.")
+ (:method ((construct TypableC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'instance-of
+ :start-revision revision)))
+ (when valid-associations
+ (type-topic (first valid-associations))))))
+
+
+(defgeneric add-type (construct type-topic &key revision)
+ (:documentation "Add the passed type-topic as type to the given
+ typed construct if there is no other type-topic
+ set at the same revision.")
+ (:method ((construct TypableC) (type-topic TopicC)
+ &key (revision *TM-REVISION*))
+ (let ((already-set-type (instance-of construct :revision revision))
+ (same-type-assoc
+ (loop for type-assoc in (slot-p construct 'instance-of)
+ when (eql (type-topic type-assoc) type-topic)
+ return type-assoc)))
+ (when (and already-set-type
+ (not (eql type-topic already-set-type)))
+ (error (make-tm-reference-condition (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
+ construct type-topic already-set-type)
+ construct (instance-of construct :revision revision) type-topic)))
+ (cond (already-set-type
+ (let ((type-assoc
+ (loop for type-assoc in (slot-p construct 'instance-of)
+ when (eql type-topic (type-topic type-assoc))
+ return type-assoc)))
+ (add-to-version-history type-assoc :start-revision revision)))
+ (same-type-assoc
+ (add-to-version-history same-type-assoc :start-revision revision))
+ (t
+ (make-construct 'TypeAssociationC
+ :type-topic type-topic
+ :typable-construct construct
+ :start-revision revision))))
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision revision))
+ construct))
+
+
+(defgeneric private-delete-type (construct type-topic &key revision)
+ (:documentation "Deletes the passed type by marking it's association as
+ deleted in the passed revision.")
+ (:method ((construct TypableC) (type-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type))))
+ (let ((assoc-to-delete
+ (loop for type-assoc in (slot-p construct 'instance-of)
+ when (eql (type-topic type-assoc) type-topic)
+ return type-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ construct))))
+
+
+(defgeneric delete-type (construct type-topic &key revision)
+ (:documentation "See private-delete-type but adds the parent construct
+ to the given version.")
+ (:method ((construct TypableC) (type-topic TopicC)
+ &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type))))
+ (when (private-delete-type construct type-topic :revision revision)
+ (add-version-info construct revision)
+ construct)))
+
+
+;;; TopicMapC
+(defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC)
+ &key (revision *TM-REVISION*))
(declare (integer revision))
- (let
- ((result
- (if xtm-id
- (let
- ((possible-items
- (delete-if-not
- (lambda (top-id)
- (and
- (string= (xtm-id top-id) xtm-id)
- (string= (uri top-id) topicid))) ;fixes a bug in
- ;get-instances-by-value
- ;that does a
- ;case-insensitive
- ;comparision
- (elephant:get-instances-by-value
- 'TopicIdentificationC
- 'uri
- topicid))))
- (when (and possible-items
- (identified-construct-p (first possible-items)))
- (unless (= (length possible-items) 1)
- (error (make-condition 'duplicate-identifier-error
- :message
- (format nil "(length possible-items ~a) for id ~a und xtm-id ~a > 1" possible-items topicid xtm-id)
- :uri topicid)))
- (let
- ((found-topic
- (identified-construct (first possible-items))))
- (if (= revision 0)
- found-topic
- (find-item-by-revision found-topic revision)))))
- (elephant::controller-recreate-instance elephant:*store-controller* (subseq topicid 1)))))
- (if (and error-if-nil (not result))
- (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision))
- result)))
+ (when (intersection (item-identifiers construct-1 :revision revision)
+ (item-identifiers construct-2 :revision revision))
+ t))
-
-;;;;;;;;;;;;;;;;;;
-;;
-;; RoleC
-
-(elephant:defpclass RoleC (ReifiableConstructC TypableC)
- ((parent :accessor parent
- :initarg :parent
- :associate AssociationC
- :documentation "Association that this role belongs to")
- (player :accessor player
- :initarg :player
- :associate TopicC
- :documentation "references the topic that is the player in this role"))
- (:documentation "The role that this topic plays in an association (formerly member)"))
+(defgeneric TopicMapC-p (class-symbol)
+ (:documentation "Returns t if the passed symbol is equal to TopicMapC.")
+ (:method ((class-symbol symbol))
+ (eql class-symbol 'TopicMapC)))
-(defgeneric RoleC-p (object)
- (:documentation "test if object is a of type RoleC")
- (:method ((object t)) nil)
- (:method ((object RoleC)) object))
-
-
-(defgeneric parent-p (vi)
- (:documentation "t if this construct has a parent construct")
- (:method ((constr RoleC)) (slot-predicate constr 'parent)))
+(defmethod equivalent-construct ((construct TopicMapC)
+ &key (start-revision *TM-REVISION*)
+ (reifier nil) (item-identifiers nil))
+ "TopicMaps equality if they share the same item-identier or reifier."
+ (declare (list item-identifiers) (integer start-revision)
+ (type (or null TopicC) reifier))
+ (equivalent-reifiable-construct construct reifier item-identifiers
+ :start-revision start-revision))
-(defmethod delete-construct :before ((construct RoleC))
- ;the way we use roles, we cannot just delete the parent association
- ;(at least the second role won't have one left then and will
- ;complain)
- (delete-1-n-association construct 'parent)
- (delete-1-n-association construct 'player))
+(defmethod delete-construct :before ((construct TopicMapC))
+ (dolist (top (slot-p construct 'topics))
+ (remove-association construct 'topics top))
+ (dolist (assoc (slot-p construct 'associations))
+ (remove-association construct 'associations assoc)))
-(defmethod find-all-equivalent ((construct RoleC))
- (let
- ((parent (and (slot-boundp construct 'parent)
- (parent construct))))
- (when parent
- (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand))
- (slot-value parent 'roles)))))
-
-
-(defmethod equivalent-constructs ((role1 RoleC) (role2 RoleC))
- "Association role items are equal if the values of their [type], [player], and [parent] properties are equal (TMDM 5.8)"
- ;for the purposes for which we use this method (namely the
- ;construction of associations), roles will initially always be
- ;unequal regarding their parent properties
- (and
- (= (internal-id (instance-of role1)) (internal-id (instance-of role2)))
- (= (internal-id (player role1)) (internal-id (player role2)))))
-
-
-;;;;;;;;;;;;;;;;;;
-;;
-;; AssociationC
-
-(elephant:defpclass AssociationC (ReifiableConstructC ScopableC TypableC)
- ((roles :accessor roles
- :associate (RoleC parent)
- :documentation "(non-empty) list of this association's roles")
- (in-topicmaps
- :associate (TopicMapC associations)
- :many-to-many t
- :documentation "list of all topic maps this association is part of"))
- (:documentation "Association in a Topic Map")
- (:index t))
+(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
+ (add-association construct 'topics construct-to-add)
+ construct-to-add)
-(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
- (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
+(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC))
+ (add-association construct 'associations construct-to-add)
+ construct-to-add)
-(defgeneric AssociationC-p (object)
- (:documentation "test if object is a of type AssociationC")
- (:method ((object t)) nil)
- (:method ((object AssociationC)) object))
+(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC))
+ (remove-association construct 'topics construct-to-delete))
-(defmethod initialize-instance :around ((instance AssociationC)
- &key
- (roles nil))
- "implements the pseudo-initarg :roles"
- (declare (list roles))
- (let
- ((association (call-next-method)))
- (dolist (role-data roles)
- (make-instance
- 'RoleC
- :instance-of (getf role-data :instance-of)
- :player (getf role-data :player)
- :item-identifiers (getf role-data :item-identifiers)
- :reifier (getf role-data :reifier)
- :parent association))))
-
-(defmethod make-construct :around ((class-symbol (eql 'AssociationC))
- &key
- start-revision
- &allow-other-keys)
- (declare (ignorable start-revision))
- (let
- ((association
- (call-next-method)))
- (declare (AssociationC association))
- (dolist (role (slot-value association 'roles))
- (unless (versions role)
- (add-to-version-history role
- :start-revision start-revision)))
- association))
-
-(defmethod copy-item-identifiers :around
- ((from-construct AssociationC)
- (to-construct AssociationC))
- "Internal method to copy over item idenfiers from one association
-with its roles to another one. Role identifiers are also
-copied. Returns nil if neither association nor role identifiers had to be copied"
- (let
- ((item-identifiers-copied-p nil)) ;rather brutal solution. find a better one
- (when (call-next-method)
- (setf item-identifiers-copied-p t))
- (do ((from-roles (roles from-construct) (rest from-roles))
- (to-roles (roles to-construct) (rest to-roles)))
- ((null from-roles) 'finished)
- (let
- ((from-role (first from-roles))
- (to-role (first to-roles)))
- (when
- (mapc
- (lambda (identifier)
- (setf (identified-construct identifier)
- to-role))
- (set-difference (item-identifiers from-role)
- (item-identifiers to-role)
- :key #'uri :test #'string=))
- (setf item-identifiers-copied-p t))))
- item-identifiers-copied-p))
-(defmethod delete-construct :before ((construct AssociationC))
- (dolist (role (roles construct))
- (delete-construct role))
- (dolist (tm (in-topicmaps construct))
- (elephant:remove-association construct 'in-topicmaps tm)))
+(defmethod delete-from-tm ((construct TopicMapC)
+ (construct-to-delete AssociationC))
+ (remove-association construct 'associations construct-to-delete))
-(defmethod find-all-equivalent ((construct AssociationC))
- (let
- ((some-player (player (or
- (second (roles construct))
- (first (roles construct)))))) ;; dirty, dirty... but brings a tenfold speedup!
- (delete-if-not
- #'(lambda (cand)
- (unless (eq construct cand)
- (equivalent-constructs construct cand)))
- ;here we need to use the "internal" API and access the players
- ;with slot-value (otherwise we won't be able to merge with
- ;'deleted' associations)
- (mapcar #'parent (slot-value some-player 'player-in-roles)))))
-
-
-(defmethod equivalent-constructs ((assoc1 AssociationC) (assoc2 AssociationC))
- "Association items are equal if the values of their [scope], [type], and [roles] properties are equal (TMDM 5.7)"
- (and
- (= (internal-id (instance-of assoc1)) (internal-id (instance-of assoc2)))
- (not (set-exclusive-or (themes assoc1) (themes assoc2)
- :key #'internal-id))
- (not (set-exclusive-or
- (roles assoc1)
- (roles assoc2)
- :test #'equivalent-constructs))))
-
-
-(elephant:defpclass TopicMapC (ReifiableConstructC)
- ((topics :accessor topics
- :associate (TopicC in-topicmaps)
- :documentation "list of topics that explicitly belong to this TM")
- (associations :accessor associations
- :associate (AssociationC in-topicmaps)
- :documentation "list of associations that belong to this TM"))
- (:documentation "Topic Map"))
-
-(defmethod equivalent-constructs ((tm1 TopicMapC) (tm2 TopicMapC))
- "Topic Map items are equal if one of their identifiers is equal"
- ;Note: TMDM does not make any statement to this effect, but it's the
- ;one logical assumption
- (intersection
- (item-identifiers tm1)
- (item-identifiers tm2)
- :test #'equivalent-constructs))
-
-(defmethod find-all-equivalent ((construct TopicMapC))
- (let
- ((tms (elephant:get-instances-by-class 'd:TopicMapC)))
- (delete-if-not
- (lambda(tm)
- (strictly-equivalent-constructs construct tm))
- tms)))
-
-(defgeneric add-to-topicmap (tm top)
- (:documentation "add a topic or an association to a topic
- map. Return the added construct"))
-
-(defmethod add-to-topicmap ((tm TopicMapC) (top TopicC))
- ;TODO: add logic not to add pure topic stubs unless they don't exist yet in the store
-; (elephant:add-association tm 'topics top) ;by adding the elephant association in this order, there will be missing one site of this association
- (elephant:add-association top 'in-topicmaps tm)
- top)
-
-(defmethod add-to-topicmap ((tm TopicMapC) (ass AssociationC))
- ;(elephant:add-association tm 'associations ass)
- (elephant:add-association ass 'in-topicmaps tm)
- ass)
-(defgeneric in-topicmap (tm constr &key revision)
- (:documentation "Is a given construct (topic or assiciation) in this topic map?"))
+(defgeneric in-topicmap (tm construct &key revision)
+ (:documentation "Is a given construct (topic or assiciation) in this
+ topic map?"))
+
-(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0))
+(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key
+ (revision *TM-REVISION*))
(when (find-item-by-revision top revision)
- (find (d:internal-id top) (d:topics tm) :test #'= :key #'d:internal-id)))
+ (find (internal-id top) (topics tm) :test #'= :key #'internal-id)))
-(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
+(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC)
+ &key (revision *TM-REVISION*))
(when (find-item-by-revision ass revision)
- (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id)))
+ (find (internal-id ass) (associations tm) :test #'= :key #'internal-id)))
-;;;;;;;;;;;;;;;;;
-;; reification
-(defgeneric add-reifier (construct reifier-topic)
- (:method ((construct ReifiableConstructC) reifier-topic)
- (let ((err "From add-reifier(): "))
- (declare (TopicC reifier-topic))
- (cond
- ((and (not (reifier construct))
- (not (reified reifier-topic)))
- (setf (reifier construct) reifier-topic)
- (setf (reified reifier-topic) construct))
- ((and (not (reified reifier-topic))
- (reifier construct))
- (merge-reifier-topics (reifier construct) reifier-topic))
- ((and (not (reifier construct))
- (reified reifier-topic))
- (error "~a~a ~a reifies already another object ~a"
- err (psis reifier-topic) (item-identifiers reifier-topic)
- (reified reifier-topic)))
- (t
- (when (not (eql (reified reifier-topic) construct))
- (error "~a~a ~a reifies already another object ~a"
- err (psis reifier-topic) (item-identifiers reifier-topic)
- (reified reifier-topic)))
- (merge-reifier-topics (reifier construct) reifier-topic)))
- construct)))
+;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun make-construct (class-symbol &rest args)
+ "Creates a new topic map construct if necessary or
+ retrieves an equivalent one if available and updates the revision
+ history accordingly. Returns the object in question. Methods use
+ specific keyword arguments for their purpose."
+ (declare (symbol class-symbol))
+ (when (and (or (VersionedConstructC-p class-symbol)
+ (and (ReifiableConstructC-p class-symbol)
+ (or (getf args :item-identifiers) (getf args :reifier))))
+ (not (getf args :start-revision)))
+ (error (make-missing-argument-condition "From make-construct(): start-revision must be set" 'start-revision 'make-construct)))
+ (let ((construct
+ (cond
+ ((PointerC-p class-symbol)
+ (apply #'make-pointer class-symbol args))
+ ((CharacteristicC-p class-symbol)
+ (apply #'make-characteristic class-symbol args))
+ ((TopicC-p class-symbol)
+ (apply #'make-topic args))
+ ((TopicMapC-p class-symbol)
+ (apply #'make-tm args))
+ ((RoleC-p class-symbol)
+ (apply #'make-role args))
+ ((AssociationC-p class-symbol)
+ (apply #'make-association args))
+ ((VersionedConstructC-p class-symbol)
+ (apply #'make-instance class-symbol
+ (rec-remf args :start-revision)))
+ (t
+ (apply #'make-instance class-symbol args))))
+ (start-revision (or (getf args :start-revision) *TM-REVISION*)))
+ (when (typep construct 'TypableC)
+ (complete-typable construct (getf args :instance-of)
+ :start-revision start-revision))
+ (when (typep construct 'ScopableC)
+ (complete-scopable construct (getf args :themes)
+ :start-revision start-revision))
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision start-revision))
+ (when (or (typep construct 'TopicC) (typep construct 'AssociationC))
+ (dolist (tm (getf args :in-topicmaps))
+ (add-to-tm tm construct)))
+ (if (typep construct 'ReifiableConstructC)
+ (complete-reifiable construct (getf args :item-identifiers)
+ (getf args :reifier) :start-revision start-revision)
+ construct)))
+
+
+(defun make-association (&rest 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 ((instance-of (getf args :instance-of))
+ (start-revision (getf args :start-revision))
+ (themes (getf args :themes))
+ (roles (getf args :roles)))
+ (when (and (or roles instance-of themes)
+ (not start-revision))
+ (error (make-missing-argument-condition "From make-association(): start-revision must be set" 'start-revision 'make-association)))
+ (let ((association
+ (let ((existing-associations
+ (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))
+ (get-all-associations nil)))))
+ (cond ((> (length existing-associations) 1)
+ (merge-all-constructs existing-associations
+ :revision start-revision))
+ (existing-associations
+ (first existing-associations))
+ (t
+ (make-instance 'AssociationC))))))
+ (dolist (role-plist roles)
+ (add-role association
+ (apply #'make-construct 'RoleC
+ (append role-plist (list :parent association)))
+ :revision (getf role-plist :start-revision)))
+ association)))
+
+
+(defun make-role (&rest 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 ((parent (getf args :parent))
+ (instance-of (getf args :instance-of))
+ (player (getf args :player))
+ (start-revision (getf args :start-revision)))
+ (when (and (or instance-of player parent)
+ (not start-revision))
+ (error (make-missing-argument-condition "From make-role(): start-revision must be set" 'start-revision 'make-role)))
+ (let ((role
+ (let ((existing-roles
+ (when parent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-role)
+ (when (equivalent-construct
+ existing-role
+ :start-revision start-revision
+ :player player
+ :instance-of instance-of)
+ existing-role))
+ (map 'list #'role (slot-p parent 'roles)))))))
+ (if (and existing-roles
+ (or (eql parent (parent (first existing-roles)
+ :revision start-revision))
+ (not (parent (first existing-roles)
+ :revision start-revision))))
+ (progn
+ (add-role parent (first existing-roles)
+ :revision start-revision)
+ (first existing-roles))
+ (make-instance 'RoleC)))))
+ (when player
+ (add-player role player :revision start-revision))
+ (when parent
+ (add-parent role parent :revision start-revision))
+ role)))
+
+
+(defun make-tm (&rest 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 args :item-identifiers))
+ (reifier (getf args :reifier))
+ (topics (getf args :topics))
+ (assocs (getf args :associations))
+ (start-revision (getf args :start-revision)))
+ (when (and (or item-identifiers reifier)
+ (not start-revision))
+ (error (make-missing-argument-condition "From make-tm(): start-revision must be set" 'start-revision 'make-tm)))
+ (let ((tm
+ (let ((existing-tms
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-tm)
+ (when (equivalent-construct
+ existing-tm
+ :item-identifiers item-identifiers
+ :reifier reifier)
+ existing-tm))
+ (get-all-tms start-revision)))))
+ (cond ((> (length existing-tms) 1)
+ (merge-all-constructs existing-tms :revision start-revision))
+ (existing-tms
+ (first existing-tms))
+ (t
+ (make-instance 'TopicMapC))))))
+ (dolist (top-or-assoc (union topics assocs))
+ (add-to-tm tm top-or-assoc))
+ tm)))
+
+
+(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 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))
+ (reified-construct (getf args :refied-construct)))
+ (when (and (or psis locators item-identifiers topic-identifiers
+ names occurrences)
+ (not start-revision))
+ (error (make-missing-argument-condition "From make-topic(): start-revision must be set" 'start-revision 'make-topic)))
+ (let ((topic
+ (let ((existing-topics
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-topic)
+ (when (equivalent-construct
+ existing-topic
+ :start-revision start-revision
+ :psis psis :locators locators
+ :item-identifiers item-identifiers
+ :topic-identifiers topic-identifiers)
+ existing-topic))
+ (get-all-topics start-revision)))))
+ (cond ((> (length existing-topics) 1)
+ (merge-all-constructs existing-topics :revision start-revision))
+ (existing-topics
+ (first existing-topics))
+ (t
+ (make-instance 'TopicC))))))
+ (let ((merged-topic topic))
+ (dolist (tid topic-identifiers)
+ (setf merged-topic (add-topic-identifier merged-topic tid
+ :revision start-revision)))
+ (dolist (psi psis)
+ (setf merged-topic (add-psi merged-topic psi
+ :revision start-revision)))
+ (dolist (locator locators)
+ (setf merged-topic (add-locator merged-topic locator
+ :revision start-revision)))
+ (dolist (name names)
+ (setf merged-topic (add-name merged-topic name
+ :revision start-revision)))
+ (dolist (occ occurrences)
+ (add-occurrence merged-topic occ :revision start-revision))
+ (when reified-construct
+ (add-reified-construct merged-topic reified-construct
+ :revision start-revision))
+ merged-topic))))
+
+
+(defun make-characteristic (class-symbol &rest args)
+ "Returns a characteristic object with the passed parameters.
+ If an equivalent construct has already existed this one is returned.
+ To check if there is existing an equivalent construct the parameter
+ parent-construct must be set.
+ This function only exists for being used by make-construct!"
+ (let ((charvalue (or (getf args :charvalue) ""))
+ (start-revision (getf args :start-revision))
+ (datatype (or (getf args :datatype) *xml-string*))
+ (instance-of (getf args :instance-of))
+ (themes (getf args :themes))
+ (variants (getf args :variants))
+ (parent (getf args :parent)))
+ (when (and (or instance-of themes variants parent)
+ (not start-revision))
+ (error (make-missing-argument-condition "From make-characteristic(): start-revision must be set" 'start-revision 'make-characgteristic)))
+ (let ((characteristic
+ (let ((existing-characteristics
+ (when parent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-characteristic)
+ (when (equivalent-construct
+ existing-characteristic
+ :start-revision start-revision
+ :datatype datatype :variants variants
+ :charvalue charvalue :themes themes
+ :instance-of instance-of)
+ existing-characteristic))
+ (get-all-characteristics parent class-symbol))))))
+ (if (and existing-characteristics
+ (or (eql parent (parent (first existing-characteristics)
+ :revision start-revision))
+ (not (parent (first existing-characteristics)
+ :revision start-revision))))
+ (progn
+ (add-characteristic parent (first existing-characteristics)
+ :revision start-revision)
+ (first existing-characteristics))
+ (make-instance class-symbol :charvalue charvalue
+ :datatype datatype)))))
+ (when (typep characteristic 'NameC)
+ (complete-name characteristic variants :start-revision start-revision))
+ (when parent
+ (add-parent characteristic parent :revision start-revision))
+ characteristic)))
+
+
+(defun make-pointer (class-symbol &rest args)
+ "Returns a pointer object with the specified parameters.
+ If an equivalen construct has already existed this one is returned.
+ This function only exists for beoing used by make-construct!"
+ (let ((uri (getf args :uri))
+ (xtm-id (getf args :xtm-id))
+ (start-revision (getf args :start-revision))
+ (identified-construct (getf args :identified-construct))
+ (err "From make-pointer(): "))
+ (when (and identified-construct (not start-revision))
+ (error (make-missing-argument-condition (format nil "~astart-revision must be set" err) 'start-revision 'make-pointer)))
+ (unless uri
+ (error (make-missing-argument-condition (format nil "~auri must be set" err) 'uri 'make-pointer)))
+ (when (and (TopicIdentificationC-p class-symbol)
+ (not xtm-id))
+ (error (make-missing-argument-condition (format nil "~axtm-id must be set" err) 'xtm-id 'make-pointer)))
+ (let ((identifier
+ (let ((existing-pointer
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(existing-pointer)
+ (when (and (typep existing-pointer class-symbol)
+ (equivalent-construct existing-pointer
+ :uri uri
+ :xtm-id xtm-id))
+ existing-pointer))
+ (elephant:get-instances-by-value class-symbol 'd::uri uri)))))
+ (if existing-pointer
+ (first existing-pointer)
+ (make-instance class-symbol :uri uri :xtm-id xtm-id)))))
+ (when identified-construct
+ (cond ((TopicIdentificationC-p class-symbol)
+ (add-topic-identifier identified-construct identifier
+ :revision start-revision))
+ ((PersistentIdC-p class-symbol)
+ (add-psi identified-construct identifier :revision start-revision))
+ ((ItemIdentifierC-p class-symbol)
+ (add-item-identifier identified-construct identifier
+ :revision start-revision))
+ ((SubjectLocatorC-p class-symbol)
+ (add-locator identified-construct identifier
+ :revision start-revision))))
+ identifier)))
+
+
+;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric move-identifiers (source destination &key revision)
+ (:documentation "Sets all identifiers as mark as deleted in the given
+ version and adds the marked identifiers to the
+ destination construct."))
+
+
+(defmethod move-identifiers ((source ReifiableConstructC)
+ (destination ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((iis (item-identifiers source :revision revision)))
+ (dolist (ii iis)
+ (private-delete-item-identifier source ii :revision revision)
+ (add-item-identifier destination ii :revision revision))
+ iis))
-(defgeneric remove-reifier (construct)
- (:method ((construct ReifiableConstructC))
- (let ((reifier-topic (reifier construct)))
- (when reifier-topic
- (elephant:remove-association construct 'reifier reifier-topic)
- (elephant:remove-association reifier-topic 'reified construct)))))
-
-
-(defgeneric merge-reifier-topics (old-topic new-topic)
- ;;the reifier topics are not only merged but also bound to the reified-construct
- (:method ((old-topic TopicC) (new-topic TopicC))
- (unless (eql old-topic new-topic)
- ;merges all identifiers
- (move-identifiers old-topic new-topic)
- (move-identifiers old-topic new-topic :what 'locators)
- (move-identifiers old-topic new-topic :what 'psis)
- (move-identifiers old-topic new-topic :what 'topic-identifiers)
- ;merges all typed-object-associations
- (dolist (typed-construct (used-as-type new-topic))
- (remove-association typed-construct 'instance-of new-topic)
- (add-association typed-construct 'instance-of old-topic))
- ;merges all scope-object-associations
- (dolist (scoped-construct (used-as-theme new-topic))
- (remove-association scoped-construct 'themes new-topic)
- (add-association scoped-construct 'themes old-topic))
- ;merges all topic-maps
- (dolist (tm (in-topicmaps new-topic))
- (add-association tm 'topics old-topic)) ;the new-topic is removed from this tm by deleting it
- ;merges all role-players
- (dolist (a-role (player-in-roles new-topic))
- (remove-association a-role 'player new-topic)
- (add-association a-role 'player old-topic))
- ;merges all names
- (dolist (name (names new-topic))
- (remove-association name 'topic new-topic)
- (add-association name 'topic old-topic))
- ;merges all occurrences
- (dolist (occurrence (occurrences new-topic))
- (remove-association occurrence 'topic new-topic)
- (add-association occurrence 'topic old-topic))
- ;merges all version-infos
- (let ((versions-to-move
- (loop for vrs in (versions new-topic)
- when (not (find-if #'(lambda(x)
- (and (= (start-revision x) (start-revision vrs))
- (= (end-revision x) (end-revision vrs))))
- (versions old-topic)))
- collect vrs)))
- (dolist (vrs versions-to-move)
- (remove-association vrs 'versioned-construct new-topic)
- (add-association vrs 'versioned-construct old-topic)))
- (delete-construct new-topic))
- ;TODO: order/repair all version-infos of the topic itself and add all new
- ; versions to the original existing objects of the topic
- old-topic))
\ No newline at end of file
+(defmethod move-identifiers ((source TopicC) (destination TopicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((iis (call-next-method))
+ (tids (topic-identifiers source :revision revision))
+ (psis (psis source :revision revision))
+ (sls (locators source :revision revision)))
+ (dolist (tid tids)
+ (private-delete-topic-identifier source tid :revision revision)
+ (add-topic-identifier destination tid :revision revision))
+ (dolist (psi psis)
+ (private-delete-psi source psi :revision revision)
+ (add-psi destination psi :revision revision))
+ (dolist (sl sls)
+ (private-delete-locator source sl :revision revision)
+ (add-locator destination sl :revision revision))
+ (append tids iis psis sls)))
+
+
+(defgeneric move-referenced-constructs (source destination &key revision)
+ (:documentation "Moves all referenced constructs in the given version from
+ the source TM-construct to the destination TM-construct."))
+
+
+(defmethod move-referenced-constructs ((source ReifiableConstructC)
+ (destination ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (remove-if
+ #'null
+ (append
+ (move-identifiers source destination :revision revision)
+ (let ((source-reifier (reifier source :revision revision))
+ (destination-reifier (reifier destination :revision revision)))
+ (let ((result
+ (cond ((and source-reifier destination-reifier)
+ (private-delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (private-delete-reifier (reified-construct destination-reifier
+ :revision revision)
+ destination-reifier :revision revision)
+ (let ((merged-reifier
+ (merge-constructs source-reifier destination-reifier
+ :revision revision)))
+ (add-reifier destination merged-reifier :revision revision)
+ merged-reifier))
+ (source-reifier
+ (private-delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (add-reifier destination source-reifier :revision revision)
+ source-reifier)
+ (destination-reifier
+ (add-reifier destination destination-reifier :revision revision)
+ nil))))
+ (when result
+ (list result)))))))
+
+
+(defmethod move-referenced-constructs ((source NameC) (destination NameC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (append (call-next-method)
+ (move-variants source destination :revision revision)))
+
+
+(defmethod move-referenced-constructs ((source TopicC) (destination TopicC)
+ &key (revision *TM-REVISION*))
+ (let ((roles (player-in-roles source :revision revision))
+ (scopables (used-as-theme source :revision revision))
+ (typables (used-as-type source :revision revision))
+ (ids (move-identifiers source destination :revision revision)))
+ (dolist (role roles)
+ (private-delete-player role source :revision revision)
+ (add-player role destination :revision revision))
+ (dolist (scopable scopables)
+ (private-delete-theme scopable source :revision revision)
+ (add-theme scopable destination :revision revision))
+ (dolist (typable typables)
+ (private-delete-type typable source :revision revision)
+ (add-type typable destination :revision revision))
+ (remove-if #'null (append roles scopables typables ids))))
+
+
+(defgeneric move-reified-construct (source destination &key revision)
+ (:documentation "Moves the refied TM-construct from the source topic
+ to the given destination topic.")
+ (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((source-reified (reified-construct source :revision revision))
+ (destination-reified (reified-construct destination
+ :revision revision)))
+ (when (and source-reified destination-reified
+ (not (eql (type-of source-reified)
+ (type-of destination-reified))))
+ (error (make-not-mergable-condition (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
+ source destination source-reified destination-reified)
+ source destination)))
+ (cond ((and source-reified destination-reified)
+ (private-delete-reifier source-reified source :revision revision)
+ (private-delete-reifier destination-reified destination :revision revision)
+ (let ((merged-reified
+ (merge-constructs source-reified destination-reified
+ :revision revision)))
+ (add-reifier merged-reified destination :revision revision)
+ merged-reified))
+ (source-reified
+ (private-delete-reifier source source-reified :revision revision)
+ (add-reifier source-reified destination :revision revision)
+ source-reified)
+ (destination-reified
+ (add-reifier destination-reified destination :revision revision)
+ destination-reified)))))
+
+
+(defgeneric move-occurrences (source destination &key revision)
+ (:documentation "Moves all occurrences from the source topic to the
+ destination topic. If occurrences are TMDM equal
+ they are merged, i.e. one is marked-as-deleted.")
+ (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((occs-to-move (occurrences source :revision revision)))
+ (dolist (occ occs-to-move)
+ (private-delete-occurrence source occ :revision revision)
+ (let ((equivalent-occ
+ (find-if #'(lambda (destination-occ)
+ (when
+ (strictly-equivalent-constructs
+ occ destination-occ :revision revision)
+ destination-occ))
+ (occurrences destination :revision revision))))
+ (if equivalent-occ
+ (progn
+ (add-occurrence destination equivalent-occ :revision revision)
+ (move-referenced-constructs occ equivalent-occ
+ :revision revision))
+ (add-occurrence destination occ :revision revision))))
+ occs-to-move)))
+
+
+(defgeneric move-variants (source destination &key revision)
+ (:documentation "Moves all variants from the source name to the destination
+ name. If any variants are TMDM equal they are merged -->
+ i.e. one of the variants is marked-as-deleted.")
+ (:method ((source NameC) (destination NameC) &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((vars-to-move (variants source :revision revision)))
+ (dolist (var vars-to-move)
+ (private-delete-variant source var :revision revision)
+ (let ((equivalent-var
+ (find-if #'(lambda (destination-var)
+ (when
+ (strictly-equivalent-constructs
+ var destination-var :revision revision)
+ destination-var))
+ (variants destination :revision revision))))
+ (if equivalent-var
+ (progn
+ (add-variant destination equivalent-var :revision revision)
+ (move-referenced-constructs var equivalent-var
+ :revision revision))
+ (add-variant destination var :revision revision))))
+ vars-to-move)))
+
+
+(defgeneric move-names (source destination &key revision)
+ (:documentation "Moves all names from the source topic to the destination
+ topic. If any names are equal they are merged, i.e.
+ one of the names is marked-as-deleted.")
+ (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((names-to-move (names source :revision revision)))
+ (dolist (name names-to-move)
+ (private-delete-name source name :revision revision)
+ (let ((equivalent-name
+ (find-if #'(lambda (destination-name)
+ (when
+ (strictly-equivalent-constructs
+ name destination-name :revision revision)
+ destination-name))
+ (names destination :revision revision))))
+ (if equivalent-name
+ (progn
+ (add-name destination equivalent-name :revision revision)
+ (move-referenced-constructs name equivalent-name
+ :revision revision))
+ (add-name destination name :revision revision))))
+ names-to-move)))
+
+
+(defun merge-changed-constructs (older-topic &key (revision *TM-REVISION*))
+ (declare (TopicC older-topic))
+ (dolist (construct (append (used-as-type older-topic :revision revision)
+ (used-as-theme older-topic :revision revision)
+ (player-in-roles older-topic :revision revision)))
+ (let ((parent (when (or (typep construct 'RoleC)
+ (typep construct 'CharacteristicC))
+ (parent construct :revision revision))))
+ (let ((all-other (cond ((typep construct 'OccurrenceC)
+ (occurrences parent :revision revision))
+ ((typep construct 'NameC)
+ (names parent :revision revision))
+ ((typep construct 'VariantC)
+ (variants parent :revision revision))
+ ((typep construct 'RoleC)
+ (roles parent :revision revision)))))
+ (let ((all-equivalent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(other)
+ (when (strictly-equivalent-constructs
+ construct other :revision revision)
+ other))
+ all-other))))
+ (when all-equivalent
+ (merge-all-constructs (append all-equivalent (list construct))
+ :revision revision))))))
+ (merge-changed-associations older-topic :revision revision))
+
+
+(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*))
+ "Merges all associations that became TMDM-equal since two referenced topics
+ were merged, e.g. the association types."
+ (declare (TopicC older-topic))
+ (let ((all-assocs
+ (remove-duplicates
+ (append
+ (remove-if
+ #'null
+ (map 'list #'(lambda(role)
+ (parent role :revision revision))
+ (player-in-roles older-topic :revision revision)))
+ (remove-if
+ #'null
+ (map
+ 'list #'(lambda(constr)
+ (when (typep constr 'AssociationC)
+ constr))
+ (append (used-as-type older-topic :revision revision)
+ (used-as-theme older-topic :revision revision))))))))
+ (dolist (assoc all-assocs)
+ (let ((all-equivalent
+ (remove-if
+ #'null
+ (map 'list #'(lambda(db-assoc)
+ (when (strictly-equivalent-constructs
+ assoc db-assoc :revision revision)
+ db-assoc))
+ (get-all-associations nil)))))
+ (when all-equivalent
+ (merge-all-constructs (append all-equivalent (list assoc))
+ :revision revision))))))
+
+
+(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
+ &key (revision *TM-REVISION*))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-topic (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-topic (if (eql older-topic construct-1)
+ construct-2
+ construct-1)))
+ (dolist (tm (in-topicmaps newer-topic :revision revision))
+ (add-to-tm tm older-topic))
+ (move-names newer-topic older-topic :revision revision)
+ (move-occurrences newer-topic older-topic :revision revision)
+ (move-referenced-constructs newer-topic older-topic :revision revision)
+ (move-reified-construct newer-topic older-topic :revision revision)
+ (merge-changed-constructs older-topic :revision revision)
+ (mark-as-deleted newer-topic :revision revision :source-locator nil)
+ (when (exist-in-version-history-p newer-topic)
+ (delete-construct newer-topic))
+ older-topic))))
+
+
+(defmethod merge-constructs ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-char (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-char (if (eql older-char construct-1)
+ construct-2
+ construct-1)))
+ (let ((parent-1 (parent older-char :revision revision))
+ (parent-2 (parent newer-char :revision revision)))
+ (unless (strictly-equivalent-constructs construct-1 construct-2
+ :revision revision)
+ (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
+ construct-1 construct-2)))
+ (cond ((and parent-1 (eql parent-1 parent-2))
+ (move-referenced-constructs newer-char older-char
+ :revision revision)
+ (private-delete-characteristic parent-2 newer-char
+ :revision revision)
+ (let ((c-assoc
+ (find-if
+ #'(lambda(c-assoc)
+ (and (eql (characteristic c-assoc) older-char)
+ (eql (parent-construct c-assoc) parent-1)))
+ (cond ((typep older-char 'OccurrenceC)
+ (slot-p parent-1 'occurrences))
+ ((typep older-char 'NameC)
+ (slot-p parent-1 'names))
+ ((typep older-char 'VariantC)
+ (slot-p parent-1 'variants))))))
+ (add-to-version-history c-assoc :start-revision revision))
+ older-char)
+ ((and parent-1 parent-2)
+ (let ((active-parent (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (let ((found-older-char
+ (cond ((typep older-char 'OccurrenceC)
+ (find older-char
+ (occurrences
+ active-parent :revision revision)))
+ ((typep older-char 'NameC)
+ (find older-char
+ (names
+ active-parent :revision revision)))
+ ((typep older-char 'VariantC)
+ (find-if
+ #'(lambda(name)
+ (find older-char
+ (variants name
+ :revision revision)))
+ (if (parent active-parent :revision revision)
+ (names (parent active-parent :revision revision)
+ :revision revision)
+ (list active-parent)))))))
+ (if found-older-char
+ older-char
+ newer-char))))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-char newer-char))
+ (src (if parent-1 newer-char older-char)))
+ (move-referenced-constructs src dst :revision revision)
+ (delete-if-not-referenced src)
+ dst))
+ (t
+ (move-referenced-constructs newer-char older-char
+ :revision revision)
+ (delete-if-not-referenced newer-char)
+ older-char)))))))
+
+
+(defmethod merge-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-tm (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-tm (if (eql older-tm construct-1)
+ construct-2
+ construct-1)))
+ (move-referenced-constructs newer-tm older-tm :revision revision)
+ (dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm)))
+ (add-to-tm older-tm top-or-assoc))
+ (add-to-version-history older-tm :start-revision revision)
+ (mark-as-deleted newer-tm :revision revision)
+ (when (exist-in-version-history-p newer-tm)
+ (delete-construct newer-tm))
+ older-tm))))
+
+
+(defmethod merge-constructs ((construct-1 AssociationC) (construct-2 AssociationC)
+ &key revision)
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-assoc (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-assoc (if (eql older-assoc construct-1)
+ construct-2
+ construct-1)))
+ ;(unless (strictly-equivalent-constructs construct-1 construct-2
+ ; :revision revision)
+ ;;associations that have different roles can be although merged, e.g.
+ ;;two roles are in two different association objects references
+ ;;the same item-identifier or reifier
+ (when (or (set-exclusive-or (themes construct-1 :revision revision)
+ (themes construct-2 :revision revision))
+ (not (eql (instance-of construct-1 :revision revision)
+ (instance-of construct-2 :revision revision))))
+ (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
+ construct-1 construct-2)))
+ (dolist (tm (in-topicmaps newer-assoc :revision revision))
+ (add-to-tm tm older-assoc))
+ (private-delete-type newer-assoc (instance-of newer-assoc :revision revision)
+ :revision revision)
+ (move-referenced-constructs newer-assoc older-assoc)
+ (dolist (newer-role (roles newer-assoc :revision revision))
+ (let ((equivalent-role
+ (find-if #'(lambda(older-role)
+ (strictly-equivalent-constructs
+ older-role newer-role :revision revision))
+ (roles older-assoc :revision revision))))
+ (when equivalent-role
+ (move-referenced-constructs newer-role equivalent-role
+ :revision revision))
+ (private-delete-role newer-assoc newer-role :revision revision)
+ (add-role older-assoc (if equivalent-role
+ equivalent-role
+ newer-role)
+ :revision revision)))
+ (mark-as-deleted newer-assoc :revision revision)
+ (when (exist-in-version-history-p newer-assoc)
+ (delete-construct newer-assoc))
+ older-assoc))))
+
+
+(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC)
+ &key (revision *TM-REVISION*))
+ (declare (integer *TM-REVISION*))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-role (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-role (if (eql older-role construct-1)
+ construct-2
+ construct-1)))
+ (unless (strictly-equivalent-constructs construct-1 construct-2
+ :revision revision)
+ (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
+ construct-1 construct-2)))
+ (let ((parent-1 (parent older-role :revision revision))
+ (parent-2 (parent newer-role :revision revision)))
+ (cond ((and parent-1 (eql parent-1 parent-2))
+ (move-referenced-constructs newer-role older-role
+ :revision revision)
+ (private-delete-role parent-2 newer-role :revision revision)
+ (let ((r-assoc
+ (find-if
+ #'(lambda(r-assoc)
+ (and (eql (role r-assoc) older-role)
+ (eql (parent-construct r-assoc) parent-1)))
+ (slot-p parent-1 'roles))))
+ (add-to-version-history r-assoc :start-revision revision)
+ older-role))
+ ((and parent-1 parent-2)
+ (let ((active-assoc (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (if (find older-role (roles active-assoc
+ :revision revision))
+ older-role
+ newer-role)))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-role newer-role))
+ (src (if parent-1 newer-role older-role)))
+ (move-referenced-constructs src dst :revision revision)
+ (delete-if-not-referenced src)
+ dst))
+ (t
+ (move-referenced-constructs newer-role older-role
+ :revision revision)
+ (delete-if-not-referenced newer-role)
+ older-role)))))))
+
+
+(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((possible-roles
+ (remove-if #'(lambda(role)
+ (when (parent role :revision revision)
+ role))
+ (map 'list #'role (slot-p parent-construct 'roles)))))
+ (let ((equivalent-role
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(role)
+ (when
+ (strictly-equivalent-constructs role new-role
+ :revision revision)
+ role))
+ possible-roles))))
+ (when equivalent-role
+ (merge-constructs (first equivalent-role) new-role
+ :revision revision)))))
+
+
+(defmethod merge-if-equivalent ((new-characteristic CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or TopicC NameC) parent-construct))
+ (let ((all-existing-characteristics
+ (map 'list #'characteristic
+ (cond ((typep new-characteristic 'OccurrenceC)
+ (slot-p parent-construct 'occurrences))
+ ((typep new-characteristic 'NameC)
+ (slot-p parent-construct 'names))
+ ((typep new-characteristic 'VariantC)
+ (slot-p parent-construct 'variants))))))
+ (let ((possible-characteristics ;all characteristics that are not referenced
+ ;other constructs at the given revision
+ (remove-if #'(lambda(char)
+ (parent char :revision revision))
+ all-existing-characteristics)))
+ (let ((equivalent-construct
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(char)
+ (when
+ (strictly-equivalent-constructs char new-characteristic
+ :revision revision)
+ char))
+ possible-characteristics))))
+ (when equivalent-construct
+ (merge-constructs (first equivalent-construct) new-characteristic
+ :revision revision))))))
\ No newline at end of file
Modified: trunk/src/model/exceptions.lisp
==============================================================================
--- trunk/src/model/exceptions.lisp (original)
+++ trunk/src/model/exceptions.lisp Sun Oct 10 05:41:19 2010
@@ -13,7 +13,10 @@
:missing-reference-error
:no-identifier-error
:duplicate-identifier-error
- :object-not-found-error))
+ :object-not-found-error
+ :not-mergable-error
+ :missing-argument-error
+ :tm-reference-error))
(in-package :exceptions)
@@ -22,6 +25,7 @@
:initarg :message
:accessor message)))
+
(define-condition missing-reference-error(error)
((message
:initarg :message
@@ -31,6 +35,7 @@
:initarg :reference))
(:documentation "thrown is a reference is missing"))
+
(define-condition duplicate-identifier-error(error)
((message
:initarg :message
@@ -40,12 +45,14 @@
:initarg :reference))
(:documentation "thrown if the same identifier is already in use"))
+
(define-condition object-not-found-error(error)
((message
:initarg :message
:accessor message))
(:documentation "thrown if the object could not be found"))
+
(define-condition no-identifier-error(error)
((message
:initarg :message
@@ -54,3 +61,48 @@
:initarg :internal-id
:accessor internal-id))
(:documentation "thrown if the topic has no identifier"))
+
+
+(define-condition not-mergable-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (construc-1
+ :initarg :construct-1
+ :accessor construct-1)
+ (construc-2
+ :initarg :construct-2
+ :accessor construct-2))
+ (:documentation "Thrown if two constructs are not mergable since
+ they have e.g. difference types."))
+
+
+(define-condition missing-argument-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (argument-symbol
+ :initarg :argument-symbol
+ :accessor argument-symbol)
+ (function-symbol
+ :initarg :function-symbol
+ :accessor function-symbol))
+ (:documentation "Thrown if a argument is missing in a function."))
+
+
+(define-condition tm-reference-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (referenced-construct
+ :initarg :referenced-construct
+ :accessor referenced-construct)
+ (existing-reference
+ :initarg :existing-reference
+ :accessor existing-reference)
+ (new-reference
+ :initarg :new-reference
+ :accessor new-reference))
+ (:documentation "Thrown of the referenced-construct is already owned by another
+ TM-construct (existing-reference) and is going to be referenced
+ by a second TM-construct (new-reference) at the same time."))
\ No newline at end of file
Modified: trunk/src/rest_interface/read.lisp
==============================================================================
--- trunk/src/rest_interface/read.lisp (original)
+++ trunk/src/rest_interface/read.lisp Sun Oct 10 05:41:19 2010
@@ -67,7 +67,7 @@
(source-locator (source-locator-prefix feed)))
;check if xtm-id has already been imported or if the entry is older
;than the snapshot feed. If so, don't do it again
- (unless (or (xtm-id-p xtm-id) (string> (atom:updated entry) (atom:updated imported-snapshot-entry)))
+ (unless (or (string> (atom:updated entry) (atom:updated imported-snapshot-entry)))
(when top
(mark-as-deleted top :source-locator source-locator :revision revision))
;(format t "Fragment feed: ~a~&" (link entry))
@@ -98,10 +98,11 @@
(find most-recent-update entry-list :key #'updated :test #'string=)))
(defun most-recent-imported-snapshot (all-snapshot-entries)
- (let
- ((all-imported-entries
- (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id)))
- (most-recent-entry all-imported-entries)))
+; (let
+; ((all-imported-entries
+; (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id)))
+; (most-recent-entry all-imported-entries))
+ (most-recent-entry all-snapshot-entries))
(defun import-snapshots-feed (snapshot-feed-url &key tm-id)
"checks if we already imported any of this feed's snapshots. If not,
Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp (original)
+++ trunk/src/rest_interface/rest-interface.lisp Sun Oct 10 05:41:19 2010
@@ -40,8 +40,7 @@
:*ajax-user-interface-url*
:*ajax-user-interface-file-path*
:*ajax-javascript-directory-path*
- :*ajax-javascript-url-prefix*
- :*mark-as-deleted-url*))
+ :*ajax-javascript-url-prefix*))
(in-package :rest-interface)
@@ -63,7 +62,8 @@
(defvar *server-acceptor* nil)
-(defun start-tm-engine (repository-path &key (conffile "atom/conf.lisp") (host-name "localhost") (port 8000))
+(defun start-tm-engine (repository-path &key (conffile "atom/conf.lisp")
+ (host-name "localhost") (port 8000))
"Start the Topic Map Engine on a given port, assuming a given
hostname. Use the repository under repository-path"
(when *server-acceptor*
Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp (original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp Sun Oct 10 05:41:19 2010
@@ -26,7 +26,6 @@
(defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface
(defparameter *ajax-javascript-directory-path* "ajax/javascripts") ;the directory which contains all necessary javascript files
(defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files
-(defparameter *mark-as-deleted-url* "/mark-as-deleted") ; the url suffix that calls the mark-as-deleted handler
(defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*)
(get-rdf-prefix *get-rdf-prefix*)
@@ -44,8 +43,7 @@
(ajax-user-interface-css-prefix *ajax-user-interface-css-prefix*)
(ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*)
(ajax-javascripts-directory-path *ajax-javascript-directory-path*)
- (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)
- (mark-as-deleted-url *mark-as-deleted-url*))
+ (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*))
"registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table
and also registers a file-hanlder to the html-user-interface"
@@ -113,9 +111,6 @@
hunchentoot:*dispatch-table*)
(push
(create-regex-dispatcher json-get-summary-url #'return-topic-summaries)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler)
hunchentoot:*dispatch-table*))
;; =============================================================================
@@ -127,7 +122,7 @@
(declare (ignorable param))
(handler-case (let ((topic-types
(with-reader-lock
- (json-tmcl::return-all-tmcl-types))))
+ (json-tmcl::return-all-tmcl-types :revision 0))))
(setf (hunchentoot:content-type*) "application/json") ;RFC 4627
(json:encode-json-to-string
(map 'list #'(lambda(y)
@@ -138,6 +133,7 @@
(setf (hunchentoot:content-type*) "text")
(format nil "Condition: \"~a\"" err)))))
+
(defun return-all-tmcl-instances(&optional param)
"Returns all topic-psis that are valid instances of any topic type.
The validity is only oriented on the typing of topics, e.g.
@@ -145,7 +141,7 @@
(declare (ignorable param))
(handler-case (let ((topic-instances
(with-reader-lock
- (json-tmcl::return-all-tmcl-instances))))
+ (json-tmcl::return-all-tmcl-instances :revision 0))))
(setf (hunchentoot:content-type*) "application/json") ;RFC 4627
(json:encode-json-to-string
(map 'list #'(lambda(y)
@@ -164,8 +160,9 @@
(let ((topic (d:get-item-by-psi psi)))
(if topic
(let ((topic-json
- (handler-case (with-reader-lock
- (json-exporter::to-json-topicStub-string topic))
+ (handler-case
+ (with-reader-lock
+ (json-exporter::to-json-topicStub-string topic :revision 0))
(condition (err) (progn
(setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
(setf (hunchentoot:content-type*) "text")
@@ -184,25 +181,34 @@
(let ((http-method (hunchentoot:request-method*)))
(if (or (eq http-method :POST)
(eq http-method :PUT))
- (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF)))
- (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t)))
- (handler-case (let ((psis
- (json:decode-json-from-string json-data)))
- (let ((tmcl
- (with-reader-lock
- (json-tmcl:get-constraints-of-fragment psis :treat-as treat-as))))
- (if tmcl
- (progn
- (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
- tmcl)
- (progn
- (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
- (setf (hunchentoot:content-type*) "text")
- (format nil "Topic \"~a\" not found." psis)))))
- (condition (err) (progn
- (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
- (setf (hunchentoot:content-type*) "text")
- (format nil "Condition: \"~a\"" err))))))
+ (let ((external-format
+ (flexi-streams:make-external-format :UTF-8 :eol-style :LF)))
+ (let ((json-data
+ (hunchentoot:raw-post-data :external-format external-format
+ :force-text t)))
+ (handler-case
+ (let ((psis
+ (json:decode-json-from-string json-data)))
+ (let ((tmcl
+ (with-reader-lock
+ (json-tmcl:get-constraints-of-fragment
+ psis :treat-as treat-as :revision 0))))
+ (if tmcl
+ (progn
+ (setf (hunchentoot:content-type*)
+ "application/json") ;RFC 4627
+ tmcl)
+ (progn
+ (setf (hunchentoot:return-code*)
+ hunchentoot:+http-not-found+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Topic \"~a\" not found." psis)))))
+ (condition (err)
+ (progn
+ (setf (hunchentoot:return-code*)
+ hunchentoot:+http-internal-server-error+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Condition: \"~a\"" err))))))
(setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
@@ -215,7 +221,7 @@
(progn
(setf (hunchentoot:content-type*) "application/json") ;RFC 4627
(handler-case (with-reader-lock
- (get-all-topic-psis))
+ (get-all-topic-psis :revision 0))
(condition (err) (progn
(setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
(setf (hunchentoot:content-type*) "text")
@@ -235,7 +241,7 @@
(get-latest-fragment-of-topic identifier))))
(if fragment
(handler-case (with-reader-lock
- (to-json-string fragment))
+ (to-json-string fragment :revision 0))
(condition (err)
(progn
(setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
@@ -302,12 +308,7 @@
(condition () nil))))
(handler-case (with-reader-lock
(let ((topics
- (remove-if
- #'null
- (map 'list #'(lambda(top)
- (when (d:find-item-by-revision top 0)
- top))
- (elephant:get-instances-by-class 'd:TopicC)))))
+ (elephant:get-instances-by-class 'd:TopicC)))
(let ((end
(cond
((not end-idx)
@@ -342,40 +343,17 @@
"Returns a json-object representing a topic map overview as a tree(s)"
(declare (ignorable param))
(with-reader-lock
- (handler-case (let ((json-string
- (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))
- (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
- json-string)
- (Condition (err) (progn
- (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
- (setf (hunchentoot:content-type*) "text")
- (format nil "Condition: \"~a\"" err))))))
-
-
-(defun mark-as-deleted-handler (&optional param)
- "Marks the corresponding elem as deleted.
- {\"type\":<\"'TopicC\" | \"'OccurrenceC\" | \"'NameC\"
- \"'AssociationC\" | \"'RoleC\" | \"VariantC\" >,
- \"object\":<specified json-object: name or occurrence,
- if the deleted object is a topic this field
- has to be set to null>,
- \"parent-topic\":<psis or null>,
- \"parent-name\": <specified json-object: name>}."
- (declare (ignorable param)) ;param is currently not used
- (let ((http-method (hunchentoot:request-method*)))
- (if (or (eq http-method :PUT)
- (eq http-method :POST))
- (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF)))
- (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t)))
- (handler-case
- (with-writer-lock
- (json-tmcl::mark-as-deleted-from-json json-data))
- (condition (err)
- (progn
- (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
- (setf (hunchentoot:content-type*) "text")
- (format nil "Condition: \"~a\"" err))))))
- (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+ (handler-case
+ (let ((json-string
+ (json-tmcl::tree-view-to-json-string
+ (json-tmcl::make-tree-view :revision 0))))
+ (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+ json-string)
+ (Condition (err)
+ (progn
+ (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Condition: \"~a\"" err))))))
;; =============================================================================
@@ -386,18 +364,22 @@
concatenated of the url-prefix and the relative path of all all files in the
passed directory and its subdirectories"
(let ((start-position-of-relative-path
- (- (length (write-to-string (com.gigamonkeys.pathnames:file-exists-p path-to-files-directory))) 2)))
+ (- (length (write-to-string (com.gigamonkeys.pathnames:file-exists-p
+ path-to-files-directory))) 2)))
(let ((files-and-urls nil))
- (com.gigamonkeys.pathnames:walk-directory path-to-files-directory
- #'(lambda(current-path)
- (let ((current-path-string
- (write-to-string current-path)))
- (let ((last-position-of-current-path
- (- (length current-path-string) 1)))
- (let ((current-url
- (concatenate 'string url-prefix
- (subseq current-path-string start-position-of-relative-path last-position-of-current-path))))
- (push (list :path current-path :url current-url) files-and-urls))))))
+ (com.gigamonkeys.pathnames:walk-directory
+ path-to-files-directory
+ #'(lambda(current-path)
+ (let ((current-path-string
+ (write-to-string current-path)))
+ (let ((last-position-of-current-path
+ (- (length current-path-string) 1)))
+ (let ((current-url
+ (concatenate
+ 'string url-prefix
+ (subseq current-path-string start-position-of-relative-path
+ last-position-of-current-path))))
+ (push (list :path current-path :url current-url) files-and-urls))))))
files-and-urls)))
@@ -421,4 +403,4 @@
(setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx))))
(incf idx)))
(unless (< idx (length str))
- (return ret-str)))))))
\ No newline at end of file
+ (return ret-str)))))))
Modified: trunk/src/unit_tests/atom_test.lisp
==============================================================================
--- trunk/src/unit_tests/atom_test.lisp (original)
+++ trunk/src/unit_tests/atom_test.lisp Sun Oct 10 05:41:19 2010
@@ -58,7 +58,7 @@
(atom:subfeeds atom:*tm-feed*)
:test #'string=
:key #'atom:id))
- (datetime-revision3
+ (datetime-revision3
(atom::datetime-in-iso-format fixtures::revision3))
(datetime-revision1
(atom::datetime-in-iso-format fixtures::revision1))
@@ -66,7 +66,7 @@
(format nil "<a:feed xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Topicmaps on psi.egovpt.org</a:title><a:id>http://london.ztt.fh-worms.de:8000/feeds</a:id><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds\" rel=\"self\"></a:link><a:updated>~a</a:updated><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Data behind the portal of the city of Worms</a:title><a:id>http://psi.egovpt.org/tm/worms/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"alternate\" type=\"application/atom+xml\"></a:link><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"http://www.egovpt.org/sdshare/collectionfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>eGov Reference Ontology</a:title><a:id>http://psi.egovpt.org/tm/egov-ontology/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/egov-ontology\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/egov-ontology\" rel=\"alternate\" type=\"application/atom+xml\"></a:link><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/egov-ontology\" rel=\"http://www.egovpt.org/sdshare/collectionfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry></a:feed>" datetime-revision3 datetime-revision3 datetime-revision1))
(worms-feed-string
(format nil "<a:feed xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Data behind the portal of the city of Worms</a:title><a:id>http://london.ztt.fh-worms.de:8000/feeds/worms</a:id><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"self\"></a:link><e:dependency>http://london.ztt.fh-worms.de:8000/feeds/egov-ontology</e:dependency><a:updated>~a</a:updated><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Snapshots of the Worms data</a:title><a:id>http://psi.egovpt.org/tm/worms/snapshots/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots\" rel=\"http://www.egovpt.org/sdshare/snapshotsfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>A list of all change fragments for the Worms data</a:title><a:id>http://psi.egovpt.org/tm/worms/fragments/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/fragments\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/fragments\" rel=\"http://www.egovpt.org/sdshare/fragmentsfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry></a:feed>" datetime-revision3 datetime-revision3 datetime-revision3)))
- (is
+ (is
(string=
collection-feed-string
(cxml:with-xml-output
@@ -103,9 +103,13 @@
(find 'atom::snapshots-feed
(atom:subfeeds worms-feed)
:key #'type-of)))
+
+ (format t "~a~%~%~a~%" fragments-feed (map 'list #'atom::psi (atom:entries fragments-feed)))
(is (= 11 (length (atom:entries fragments-feed))))
- (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" (link fragments-feed)))
- (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" (link snapshots-feed)))
+ (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments"
+ (link fragments-feed)))
+ (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots"
+ (link snapshots-feed)))
(format t "~a" (cxml:with-xml-output
(cxml:make-string-sink :canonical t)
Copied: trunk/src/unit_tests/datamodel_test.lisp (from r324, /branches/new-datamodel/src/unit_tests/datamodel_test.lisp)
==============================================================================
--- /branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ trunk/src/unit_tests/datamodel_test.lisp Sun Oct 10 05:41:19 2010
@@ -599,13 +599,10 @@
(is-false (get-item-by-id "any-psi-id"))
(signals object-not-found-error
(get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0))
- (signals object-not-found-error
- (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-psi "any-psi-id"))
(add-psi top-1 psi-3-1 :revision rev-1)
(add-psi top-1 psi-3-2 :revision rev-1)
(is-false (get-item-by-locator "psi-3" :revision rev-1))
- (is-false (get-item-by-item-identifier "psi-3" :revision rev-1))
(signals duplicate-identifier-error
(get-item-by-psi "psi-3" :revision rev-1))
(add-psi top-2 psi-1)
Modified: trunk/src/unit_tests/exporter_xtm1.0_test.lisp
==============================================================================
--- trunk/src/unit_tests/exporter_xtm1.0_test.lisp (original)
+++ trunk/src/unit_tests/exporter_xtm1.0_test.lisp Sun Oct 10 05:41:19 2010
@@ -14,7 +14,8 @@
(test test-std-topics-xtm1.0
(with-fixture refill-test-db ()
(export-xtm *out-xtm1.0-file* :xtm-format '1.0)
- (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))
+ (let ((document (dom:document-element
+ (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))
(topic-counter 0))
(check-document-structure document 38 2 :ns-uri *xtm1.0-ns*)
(loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic")
@@ -22,47 +23,74 @@
(xpath-single-child-elem-by-qname
topic *xtm1.0-ns* "subjectIdentity")
*xtm1.0-ns* "subjectIndicatorRef")
- do (let ((href (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href")))
+ do (let ((href (dom:get-attribute-ns subjectIndicatorRef
+ *xtm1.0-xlink* "href")))
(cond
((string= core-topic-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-association-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-occurrence-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-class-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-class-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-superclass-subclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-superclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-subclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-sort-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-display-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-type-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-type-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))
((string= core-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name")))))))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm1.0-ns*
+ "name")))))))
(is (= topic-counter 13)))))
@@ -362,12 +390,10 @@
when (string= (uri item) psi)
return (identified-construct item)))
(t100-start-revision (d::start-revision (first (d::versions t100)))))
-
(d:get-fragments t100-start-revision)
(let ((t100-fragment (loop for item in (elephant:get-instances-by-class 'FragmentC)
when (eq (topic item) t100)
return item)))
-
(with-open-file (stream *out-xtm1.0-file* :direction :output)
(write-string (export-xtm-fragment t100-fragment :xtm-format '1.0) stream))))
@@ -415,7 +441,9 @@
(with-fixture merge-test-db ()
(handler-case (delete-file *out-xtm1.0-file*)(error () )) ;deletes file - if exist
(export-xtm *out-xtm1.0-file* :revision fixtures::revision1 :xtm-format '1.0)
- (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))
+ (let ((document
+ (dom:document-element
+ (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))
(t100-occurrences-resourceData (list "The ISO 19115 standard ..." "2003-01-01"))) ;local value->no type
(check-document-structure document 47 7 :ns-uri *xtm1.0-ns*)
(loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic")
@@ -974,8 +1002,7 @@
(xpath-child-elems-by-qname name *xtm1.0-ns* "variant")))
(is (= (length variant-nodes) 1))
(elt variant-nodes 0))))
- (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi)
- t101-variant-name nil)))))
+ (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) t101-variant-name nil)))))
(check-single-instanceOf document topic t3a-psi :xtm-format '1.0)
(loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence")
do (let ((instanceOf
@@ -1090,27 +1117,27 @@
(test test-fragments-xtm1.0-versions
(with-fixture merge-test-db ()
(handler-case (delete-file *out-xtm1.0-file*)(error () )) ;deletes file - if exist
-
- (let ((new-t100 (loop for item in (elephant:get-instances-by-class 'PersistentIdC)
- when (string= (uri item) new-t100-psi)
- return (identified-construct item))))
-
+ (let ((new-t100
+ (loop for item in (elephant:get-instances-by-class 'd:PersistentIdC)
+ when (string= (uri item) new-t100-psi)
+ return (identified-construct item :revision fixtures::revision3))))
(d:get-fragments fixtures::revision3)
- (let ((fragment (loop for item in (elephant:get-instances-by-class 'FragmentC)
+ (let ((fragment (loop for item in (elephant:get-instances-by-class 'd:FragmentC)
when (eq (topic item) new-t100)
return item)))
-
(with-open-file (stream *out-xtm1.0-file* :direction :output)
(write-string (export-xtm-fragment fragment :xtm-format '1.0) stream))))
-
- (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))))
+ (let ((document
+ (dom:document-element
+ (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))))
(check-document-structure document 6 0 :ns-uri *xtm1.0-ns*)
(loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic")
do (loop for subjectIndicatorRef across (xpath-child-elems-by-qname
(xpath-single-child-elem-by-qname
topic *xtm1.0-ns* "subjectIdentity")
*xtm1.0-ns* "subjectIndicatorRef")
- do (let ((href (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href")))
+ do (let ((href (dom:get-attribute-ns subjectIndicatorRef
+ *xtm1.0-xlink* "href")))
(cond
((string= href core-sort-psi)
(check-topic-id topic))
@@ -1125,28 +1152,35 @@
((string= href new-t100-psi)
(check-topic-id topic)
(check-single-instanceOf document topic t3-psi :xtm-format '1.0)
- (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence")
+ (loop for occurrence across (xpath-child-elems-by-qname
+ topic *xtm1.0-ns* "occurrence")
do (let ((resourceRef
(let ((resourceRef-nodes
- (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "resourceRef")))
+ (xpath-child-elems-by-qname
+ occurrence *xtm1.0-ns* "resourceRef")))
(is (= (length resourceRef-nodes) 1))
- (dom:get-attribute-ns (elt resourceRef-nodes 0) *xtm1.0-xlink* "href")))
+ (dom:get-attribute-ns (elt resourceRef-nodes 0)
+ *xtm1.0-xlink* "href")))
(instanceOf
(let ((instanceOf-nodes
- (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "instanceOf")))
+ (xpath-child-elems-by-qname
+ occurrence *xtm1.0-ns* "instanceOf")))
(is (= (length instanceOf-nodes) 1))
(let ((topicRef-nodes
(xpath-child-elems-by-qname
- (elt instanceOf-nodes 0) *xtm1.0-ns* "topicRef")))
+ (elt instanceOf-nodes 0) *xtm1.0-ns*
+ "topicRef")))
(is (= (length topicRef-nodes) 1))
(get-subjectIndicatorRef-by-ref
document
(dom:get-attribute-ns
(elt topicRef-nodes 0) *xtm1.0-xlink* "href"))))))
(cond
- ((string= resourceRef (first new-t100-occurrence-resourceRef-merge-2))
+ ((string= resourceRef
+ (first new-t100-occurrence-resourceRef-merge-2))
(is (string= instanceOf t55-psi)))
- ((string= resourceRef (second new-t100-occurrence-resourceRef-merge-2))
+ ((string= resourceRef
+ (second new-t100-occurrence-resourceRef-merge-2))
(is (string= instanceOf t55-psi)))
(t
(is-true
Modified: trunk/src/unit_tests/exporter_xtm2.0_test.lisp
==============================================================================
--- trunk/src/unit_tests/exporter_xtm2.0_test.lisp (original)
+++ trunk/src/unit_tests/exporter_xtm2.0_test.lisp Sun Oct 10 05:41:19 2010
@@ -51,7 +51,8 @@
:test-exporter-xtm2.0-versions-1 :test-exporter-xtm2.0-versions-2
:test-exporter-xtm2.0-versions-3 :test-fragments-versions
:test-exporter-xtm1.0-versions-1 :test-exporter-xtm1.0-versions-2
- :test-exporter-xtm1.0-versions-3 :test-fragments-xtm1.0-versions))
+ :test-exporter-xtm1.0-versions-3 :test-fragments-xtm1.0-versions
+ :exporter-tests))
(in-package :exporter-test)
(def-suite exporter-tests)
@@ -69,7 +70,8 @@
(error () )) ;do nothing
(handler-case (delete-file *out-xtm1.0-file*)
(error () )) ;do nothing
- (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm")
+ (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm"
+ :tm-id "http://isidorus.org/test-tm")
(elephant:open-store (get-store-spec "data_base")))
@@ -551,52 +553,82 @@
(test test-std-topics
(with-fixture refill-test-db ()
(export-xtm *out-xtm2.0-file*)
- (let ((document (dom:document-element (cxml:parse-file *out-xtm2.0-file* (cxml-dom:make-dom-builder))))
+ (let ((document (dom:document-element
+ (cxml:parse-file *out-xtm2.0-file*
+ (cxml-dom:make-dom-builder))))
(topic-counter 0))
(check-document-structure document 38 2)
(loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic")
- do (loop for subjectIdentifier across (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier")
- do (let ((href (dom:node-value (dom:get-attribute-node subjectIdentifier "href"))))
+ do (loop for subjectIdentifier across
+ (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier")
+ do (let ((href (dom:node-value
+ (dom:get-attribute-node subjectIdentifier "href"))))
(cond
((string= core-topic-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-association-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-occurrence-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-class-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-class-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-superclass-subclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-superclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-subclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-sort-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-display-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-type-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-type-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))))))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))))))
(is (= topic-counter 13)))))
Modified: trunk/src/unit_tests/fixtures.lisp
==============================================================================
--- trunk/src/unit_tests/fixtures.lisp (original)
+++ trunk/src/unit_tests/fixtures.lisp Sun Oct 10 05:41:19 2010
@@ -37,7 +37,8 @@
:*XTM-MERGE1-TM*
:*XTM-MERGE2-TM*
:rdf-init-db
- :rdf-test-db))
+ :rdf-test-db
+ :with-empty-db))
(in-package :fixtures)
@@ -93,14 +94,14 @@
(tear-down-test-db))
(def-fixture initialized-test-db (&optional (xtm *NOTIFICATIONBASE-TM*))
- (let
- ((revision (get-revision)))
+ (let ((revision (get-revision)))
(declare (ignorable revision))
+ (setf *TM-REVISION* revision)
(setf *XTM-TM* xtm)
(set-up-test-db revision)
- (let
- ((tm
- (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm" :revision (d:get-revision))))
+ (let ((tm
+ (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm"
+ :revision revision)))
(declare (ignorable tm))
(&body)
(tear-down-test-db))))
@@ -210,4 +211,11 @@
(&body)
(handler-case (delete-file exported-file-path)
(error () )) ;do nothing
- (tear-down-test-db)))
\ No newline at end of file
+ (tear-down-test-db)))
+
+
+(def-fixture with-empty-db (dir)
+ (clean-out-db dir)
+ (elephant:open-store (xml-importer:get-store-spec dir))
+ (&body)
+ (tear-down-test-db))
\ No newline at end of file
Modified: trunk/src/unit_tests/importer_test.lisp
==============================================================================
--- trunk/src/unit_tests/importer_test.lisp (original)
+++ trunk/src/unit_tests/importer_test.lisp Sun Oct 10 05:41:19 2010
@@ -22,7 +22,8 @@
xpath-select-location-path)
(:import-from :exceptions
missing-reference-error
- duplicate-identifier-error)
+ duplicate-identifier-error
+ not-mergable-error )
(:export :importer-test
:test-error-detection
:run-importer-tests
@@ -57,19 +58,19 @@
"Test the from-type-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((type-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "occurrence")
- (*xtm2.0-ns* "type")))))
+ (let ((type-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "occurrence")
+ (*xtm2.0-ns* "type"))))
+ (rev-1 *TM-REVISION*))
(loop for type-elem in type-elems do
- (is (typep (from-type-elem type-elem) 'TopicC)))
- (is-false (from-type-elem nil))
+ (is (typep (from-type-elem type-elem rev-1) 'TopicC)))
+ (is-false (from-type-elem nil rev-1))
(let
((t100-occtype
- (from-type-elem (first type-elems))))
+ (from-type-elem (first type-elems) rev-1)))
(format t "occtype: ~a~&" t100-occtype)
(format t "occtype: ~a~&" (psis t100-occtype))
(is
@@ -82,77 +83,74 @@
(declare (optimize (debug 3)))
(with-fixture
initialized-test-db()
- (let
- ((scope-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "name")
- (*xtm2.0-ns* "scope")))))
+ (let ((scope-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "name")
+ (*xtm2.0-ns* "scope"))))
+ (rev-1 *TM-REVISION*))
(loop for scope-elem in scope-elems do
- (is (>= (length (from-scope-elem scope-elem)) 1)))
- (is-false (from-scope-elem nil))
+ (is (>= (length (from-scope-elem scope-elem rev-1)) 1)))
+ (is-false (from-scope-elem nil rev-1))
(let
((t101-themes
- (from-scope-elem (first scope-elems))))
+ (from-scope-elem (first scope-elems) rev-1)))
(is (= 1 (length t101-themes)))
(is
(string=
- (topicid (first t101-themes) *TEST-TM*)
+ (topic-id (first t101-themes) rev-1 *TEST-TM*)
"t50a"))))))
(test test-from-name-elem
"Test the from-name-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((name-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "name"))))
- (top (get-item-by-id "t1"))) ;an arbitrary topic
+ (let ((name-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "name"))))
+ (top (get-item-by-id "t1")) ;an arbitrary topic
+ (rev-1 *TM-REVISION*))
(loop for name-elem in name-elems do
- (is (typep (from-name-elem name-elem top revision) 'NameC)))
+ (is (typep (from-name-elem name-elem top rev-1) 'NameC)))
(let
- ((t1-name (from-name-elem (first name-elems) top revision))
- (t1-name-copy (from-name-elem (first name-elems) top revision))
- (t101-longname (from-name-elem (nth 27 name-elems) top revision)))
+ ((t1-name (from-name-elem (first name-elems) top rev-1))
+ (t1-name-copy (from-name-elem (first name-elems) top rev-1))
+ (t101-longname (from-name-elem (nth 27 name-elems) top rev-1)))
(is (string= (charvalue t1-name) "Topic Type"))
- (is (string=
- (charvalue t101-longname)
- "ISO/IEC 13250:2002: Topic Maps"))
- (is (= 1 (length (item-identifiers t101-longname))))
-
- (is (string=
- (uri (first (psis (instance-of t101-longname))))
- "http://psi.egovpt.org/types/long-name"))
- (is (themes t101-longname))
+ (is (string= (charvalue t101-longname)
+ "ISO/IEC 13250:2002: Topic Maps"))
+ (is (= 1 (length (item-identifiers t101-longname :revision rev-1))))
+ (is (string= (uri (first (psis (instance-of t101-longname))))
+ "http://psi.egovpt.org/types/long-name"))
+ (is (themes t101-longname :revision rev-1))
(is (string=
- (topicid (first (themes t101-longname)) *TEST-TM*)
+ (topic-id (first (themes t101-longname :revision rev-1))
+ rev-1 *TEST-TM*)
"t50a"))
- (is (eq t1-name t1-name-copy)) ;must be merged
- ))))
+ (is (eq t1-name t1-name-copy)))))) ;must be merged
+
(test test-from-occurrence-elem
"Test the form-occurrence-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((occ-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "occurrence"))))
- (top (get-item-by-id "t1"))) ;an abritrary topic
-
+ (let ((occ-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "occurrence"))))
+ (top (get-item-by-id "t1")) ;an abritrary topic
+ (rev-1 *TM-REVISION*))
(loop for occ-elem in occ-elems do
- (is (typep (from-occurrence-elem occ-elem top revision)
- 'OccurrenceC)))
+ (is (typep (from-occurrence-elem occ-elem top rev-1)
+ 'OccurrenceC)))
(is (= 1 (length (elephant:get-instances-by-value
- 'ItemIdentifierC
- 'uri
- "http://psi.egovpt.org/itemIdentifiers#t100_o1"))))
+ 'ItemIdentifierC
+ 'uri
+ "http://psi.egovpt.org/itemIdentifiers#t100_o1"))))
(let
((t100-occ1
(identified-construct
@@ -166,9 +164,9 @@
'ItemIdentifierC
'uri
"http://psi.egovpt.org/itemIdentifiers#t100_o2"))))
- (is (= 1 (length (item-identifiers t100-occ1))));just to double-check
+ (is (= 1 (length (item-identifiers t100-occ1 :revision rev-1)))) ;just to double-check
(is (string=
- (uri (first (item-identifiers t100-occ1)))
+ (uri (first (item-identifiers t100-occ1 :revision rev-1)))
"http://psi.egovpt.org/itemIdentifiers#t100_o1"))
(is (string= (charvalue t100-occ1) "http://www.budabe.de/"))
(is (string= (datatype t100-occ1) "http://www.w3.org/2001/XMLSchema#anyURI"))
@@ -179,40 +177,39 @@
"Test the merge-topic-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((topic-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")))))
-
+ (let ((topic-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic"))))
+ (rev-1 *TM-REVISION*))
(loop for topic-elem in topic-elems do
(is (typep
- (merge-topic-elem topic-elem revision :tm fixtures::tm)
+ (merge-topic-elem topic-elem rev-1 :tm fixtures::tm)
'TopicC)))
(let
((top-t1 (merge-topic-elem (first topic-elems)
- revision :tm fixtures::tm))
+ rev-1 :tm fixtures::tm))
(top-t57 (get-item-by-id "t57"))
(top-t101 (get-item-by-id "t101"))
(top-t301 (get-item-by-id "t301"))
(top-t301a (get-item-by-id "t301a"))
;one of the core PSIs
(top-sup-sub (get-item-by-id "supertype-subtype" :xtm-id "core.xtm")))
- (is (= (internal-id top-t301)
- (internal-id top-t301a)))
- (is (= (length (occurrences top-t1)) 0))
- (is (= (length (occurrences top-t101)) 4))
- (is (= (length (names top-t57)) 1))
- (is (string= (uri (first (item-identifiers top-t57)))
+ (is (= (elephant::oid top-t301) (elephant::oid top-t301a)))
+ (is-true top-t301a)
+ (is (= (length (occurrences top-t1 :revision rev-1)) 0))
+ (is (= (length (occurrences top-t101 :revision rev-1)) 4))
+ (is (= (length (names top-t57 :revision rev-1)) 1))
+ (is (string= (uri (first (item-identifiers top-t57 :revision rev-1)))
"http://psi.egovpt.org/itemIdentifiers#t57"))
- (is (= 2 (length (names top-t101))))
- (is (= 2 (length (names top-t301)))) ;after merge
- (is-true (item-identifiers (first (names top-t301)))) ;after merge
- (is (= 2 (length (psis top-t301)))) ;after merge
- (is (= 3 (length (occurrences top-t301)))) ;after merge
+ (is (= 2 (length (names top-t101 :revision rev-1))))
+ (is (= 2 (length (names top-t301 :revision rev-1)))) ;after merge
+ (is-true (item-identifiers (first (names top-t301 :revision rev-1))
+ :revision rev-1)) ;after merge
+ (is (= 2 (length (psis top-t301 :revision rev-1)))) ;after merge
+ (is (= 3 (length (occurrences top-t301 :revision rev-1)))) ;after merge
(is (string= "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype"
- (uri (first (psis top-sup-sub)))))))
-
+ (uri (first (psis top-sup-sub :revision rev-1)))))))
;34 topics in 35 topic elements in notificationbase.xtm and 13
;core topics
(is (= (+ 34 13) (length (elephant:get-instances-by-class 'TopicC))))))
@@ -226,51 +223,49 @@
(xpath-select-location-path
*XTM-TM*
'((*xtm2.0-ns* "association")
- (*xtm2.0-ns* "role")))))
+ (*xtm2.0-ns* "role"))))
+ (rev-1 *TM-REVISION*))
(loop for role-elem in role-elems do
(is (typep (from-role-elem role-elem revision) 'list)))
(let
((12th-role
(from-role-elem (nth 11 role-elems) revision)))
(is (string= "t101"
- (topicid
- (getf 12th-role :player) *TEST-TM*)))
+ (topic-id
+ (getf 12th-role :player) rev-1 *TEST-TM*)))
(is (string= "t62"
- (topicid
- (getf 12th-role :instance-of) *TEST-TM*)))))))
+ (topic-id
+ (getf 12th-role :instance-of) rev-1 *TEST-TM*)))))))
+
(test test-from-association-elem
"Test the form-association-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((assoc-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "association")))))
+ (let ((assoc-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "association"))))
+ (rev-1 *TM-REVISION*))
(loop for assoc-elem in assoc-elems do
(is
- (typep (from-association-elem assoc-elem revision :tm fixtures::tm)
+ (typep (from-association-elem assoc-elem rev-1 :tm fixtures::tm)
'AssociationC)))
- ;(trace datamodel:item-identifiers datamodel::filter-slot-value-by-revision)
- (let
- ((6th-assoc
- (sixth (elephant:get-instances-by-class 'AssociationC)))
- (last-assoc
- (seventh (elephant:get-instances-by-class 'AssociationC))))
- (is (= 2 (length (roles last-assoc))))
- (is (= 1 (length (item-identifiers last-assoc))))
+ (let ((6th-assoc
+ (sixth (elephant:get-instances-by-class 'AssociationC)))
+ (last-assoc
+ (seventh (elephant:get-instances-by-class 'AssociationC))))
+ (is (= 2 (length (roles last-assoc :revision rev-1))))
+ (is (= 1 (length (item-identifiers last-assoc :revision rev-1))))
(is (string= "t300"
- (topicid (player (first (roles 6th-assoc))) *TEST-TM*)))
+ (topic-id (player (first (roles 6th-assoc :revision rev-1))
+ :revision rev-1) rev-1 *TEST-TM*)))
(is (string= "t63"
- (topicid (instance-of (first (roles 6th-assoc)))
- *TEST-TM*)))
+ (topic-id (instance-of (first (roles 6th-assoc :revision rev-1))
+ :revision rev-1) rev-1 *TEST-TM*)))
(is (string= "t301"
- (topicid (player (first (roles last-assoc)))
- *TEST-TM*))))
- ;(untrace datamodel:item-identifiers datamodel::filter-slot-value-by-revision))
- )
- ;(map 'list (lambda (a) (format t "~a" (exporter:to-string a))) (elephant:get-instances-by-class 'AssociationC))
+ (topic-id (player (first (roles last-assoc :revision rev-1))
+ :revision rev-1) rev-1 *TEST-TM*)))))
(is (= 7
(length (elephant:get-instances-by-class 'AssociationC))))))
@@ -280,64 +275,60 @@
(declare (optimize (debug 3)))
(with-fixture
initialized-test-db()
- (let
- ((topic-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")))))
+ (let ((topic-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic"))))
+ (rev-1 *TM-REVISION*))
(loop for topic-elem in topic-elems do
- (let
- (
- ;this already implicitly creates the instanceOf
- ;associations as needed
- (topic (merge-topic-elem topic-elem revision :tm fixtures::tm)))
- ;(format t "instanceof-topicrefs: ~a~&" instanceof-topicrefs)
- (dolist (io-role
- (elephant:get-instances-by-value
- 'RoleC
- 'player topic))
- (let
- ((io-assoc (parent io-role)))
- ;(format t "(io-topicref: ~a, topic: ~a)~&" io-topicref topic)
- (is
- (typep io-assoc
- 'AssociationC))
- (is (string= (topicid topic)
- (topicid (player (second (roles io-assoc))))))))))
-
- (let*
- ((t101-top (get-item-by-id "t101"))
+ (let (;this already implicitly creates the instanceOf
+ ;associations as needed
+ (topic (merge-topic-elem topic-elem rev-1 :tm fixtures::tm)))
+ (dolist (io-role (map 'list #'d::parent-construct
+ (d::slot-p topic 'd::player-in-roles)))
+ (let ((io-assoc (parent io-role :revision rev-1)))
+ (is (typep io-assoc 'AssociationC))
+ (is (string= (topic-id topic rev-1)
+ (topic-id (player (second
+ (roles io-assoc :revision rev-1))
+ :revision rev-1) rev-1)))))))
+ (let* ((t101-top (get-item-by-id "t101" :revision rev-1))
;get all the roles t101 is involved in
- (roles-101 (elephant:get-instances-by-value 'RoleC 'player t101-top))
+ (roles-101 (map 'list #'d::parent-construct
+ (d::slot-p t101-top 'd::player-in-roles)))
;and filter those whose roletype is "instance"
;(returning, of course, a list)
-
;TODO: what we'd really need
;is a filter that works
;directly on the indices
;rather than instantiating
;many unnecessary role objects
- (role-101 (remove-if-not
- (lambda (role)
- (string= (uri (first (psis (instance-of role))))
- "http://psi.topicmaps.org/iso13250/model/instance")) roles-101)))
+ (role-101 (remove-if-not
+ (lambda (role)
+ (string= (uri (first (psis
+ (instance-of role :revision rev-1)
+ :revision rev-1)))
+ "http://psi.topicmaps.org/iso13250/model/instance"))
+ roles-101)))
;Topic t101 (= Topic Maps 2002
;standard) is subclass of
;topic t3a (semantic standard)
-
(is-true t101-top)
(is (= 1 (length role-101)))
- ;(is (= 1 (length (d::versions role-101))))
(is (string= "t3a"
- (topicid (player (first (roles (parent (first role-101))))) *TEST-TM*)))
+ (topic-id (player (first (roles (parent (first role-101))
+ :revision rev-1))
+ :revision rev-1)
+ rev-1 *TEST-TM*)))
(is (string= "type-instance"
- (topicid (instance-of
- (parent (first role-101))) "core.xtm")))
- ))))
+ (topic-id (instance-of
+ (parent (first role-101) :revision rev-1))
+ rev-1 "core.xtm")))))))
+
(test test-error-detection
"Test for the detection of common errors such as dangling
-references, duplicate PSIs or item identifiers"
+ references, duplicate PSIs or item identifiers"
(declare (optimize (debug 3)))
(with-fixture bare-test-db()
(signals missing-reference-error
@@ -356,7 +347,7 @@
(importer xtm-dom :xtm-id "missing-reference-error-2"
:tm-id "http://www.isidor.us/unittests/baretests"))))
(with-fixture bare-test-db()
- (signals duplicate-identifier-error
+ (signals not-mergable-error
(let
((xtm-dom
(dom:document-element
@@ -373,49 +364,52 @@
(xml-importer:setup-repository *t100.xtm* dir :xtm-id *TEST-TM*
:tm-id "http://www.isidor.us/unittests/topic-t100")
(elephant:open-store (xml-importer:get-store-spec dir))
-
(is (= 25 (length (elephant:get-instances-by-class 'TopicC)))) ;; are all topics in the db +std topics
- (is-true (get-item-by-id "t100")) ;; main topic
- (is-true (get-item-by-id "t3a")) ;; instanceOf
- (is-true (get-item-by-id "t50a")) ;; scope
- (is-true (get-item-by-id "t51")) ;; occurrence/type
- (is-true (get-item-by-id "t52")) ;; occurrence/resourceRef
- (is-true (get-item-by-id "t53")) ;; occurrence/type
- (is-true (get-item-by-id "t54")) ;; occurrence/type
- (is-true (get-item-by-id "t55")) ;; occurrence/type
- (let ((t100 (get-item-by-id "t100")))
+ (is-true (get-item-by-id "t100" :revision 0)) ;; main topic
+ (is-true (get-item-by-id "t3a" :revision 0)) ;; instanceOf
+ (is-true (get-item-by-id "t50a" :revision 0)) ;; scope
+ (is-true (get-item-by-id "t51" :revision 0)) ;; occurrence/type
+ (is-true (get-item-by-id "t52" :revision 0)) ;; occurrence/resourceRef
+ (is-true (get-item-by-id "t53" :revision 0)) ;; occurrence/type
+ (is-true (get-item-by-id "t54" :revision 0)) ;; occurrence/type
+ (is-true (get-item-by-id "t55" :revision 0)) ;; occurrence/type
+ (let ((t100 (get-item-by-id "t100" :revision 0)))
;; checks instanceOf
- (is (= 1 (length (player-in-roles t100))))
- (let*
- ((role-t100 (first (player-in-roles t100)))
- (assoc (parent role-t100))
- (role-t3a (first (roles assoc))))
- (is (= 1 (length (psis (instance-of role-t100)))))
- (is (string= (uri (first (psis (instance-of role-t100)))) "http://psi.topicmaps.org/iso13250/model/instance"))
- (is (= 1 (length (psis (instance-of role-t3a)))))
- (is (string= (uri (first (psis (instance-of role-t3a)))) "http://psi.topicmaps.org/iso13250/model/type")))
-
+ (is (= 1 (length (player-in-roles t100 :revision 0))))
+ (let* ((role-t100 (first (player-in-roles t100 :revision 0)))
+ (assoc (parent role-t100 :revision 0))
+ (role-t3a (first (roles assoc :revision 0))))
+ (is (= 1 (length (psis (instance-of role-t100 :revision 0) :revision 0))))
+ (is (string= (uri (first (psis (instance-of role-t100 :revision 0)
+ :revision 0)))
+ "http://psi.topicmaps.org/iso13250/model/instance"))
+ (is (= 1 (length (psis (instance-of role-t3a :revision 0) :revision 0))))
+ (is (string= (uri (first (psis (instance-of role-t3a :revision 0)
+ :revision 0)))
+ "http://psi.topicmaps.org/iso13250/model/type")))
;; checks subjectIdentifier
- (is (= 1 (length (psis t100))))
+ (is (= 1 (length (psis t100 :revision 0))))
(is (string= "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata"
- (uri (first (psis t100)))))
- (is (equal (identified-construct (first (psis t100))) t100)) ;;other association part
-
+ (uri (first (psis t100 :revision 0)))))
+ (is (equal (identified-construct (first (psis t100 :revision 0))
+ :revision 0) t100)) ;;other association part
;; checks names
- (is (= 2 (length (names t100))))
- (loop for item in (names t100)
+ (is (= 2 (length (names t100 :revision 0))))
+ (loop for item in (names t100 :revision 0)
do (is (or (string= (charvalue item) "ISO 19115")
(and (string= (charvalue item) "ISO 19115:2003 Geographic Information - Metadata")
- (= (length (themes item)) 1)
- (= (length (psis (first (themes item)))))
- (string= (uri (first (psis (first (themes item))))) "http://psi.egovpt.org/types/long-name")))))
- (is-true (used-as-theme (get-item-by-id "t50a"))) ;checks the other part of the association -> fails
-
+ (= (length (themes item :revision 0)) 1)
+ (= (length (psis (first (themes item :revision 0))
+ :revision 0)))
+ (string= (uri (first (psis (first (themes item :revision 0))
+ :revision 0)))
+ "http://psi.egovpt.org/types/long-name")))))
+ (is-true (used-as-theme (get-item-by-id "t50a" :revision 0)
+ :revision 0)) ;checks the other part of the association -> fails
;; checks occurrences
+ (setf *TM-REVISION* 0)
(is (= 4 (length (occurrences (get-item-by-id "t100")))))
(loop for item in (occurrences t100)
- ;;(elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item)
- ;; fails with all 4 occurrences because the association is missing in the topics
when (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item)
do (progn
(is (string= (charvalue item) "#t52"))
@@ -433,12 +427,7 @@
when (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item)
do (progn
(is (string= (charvalue item) "http://www.editeur.org/standards/ISO19115.pdf"))
- (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links")))
- when (and (not (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item))
- (not (elephant:associatedp (get-item-by-id "t53") 'datamodel::used-as-type item))
- (not (elephant:associatedp (get-item-by-id "t54") 'datamodel::used-as-type item))
- (not (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item)))
- do (is-true nil))))))
+ (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links"))))))))
(test test-setup-repository-xtm1.0
@@ -450,31 +439,47 @@
*sample_objects.xtm* dir
:tm-id "http://www.isidor.us/unittests/xtm1.0-tests"
:xtm-id *TEST-TM* :xtm-format '1.0)
-
+ (setf *TM-REVISION* 0)
(elephant:open-store (xml-importer:get-store-spec dir))
- (is (= 36 (length (elephant:get-instances-by-class 'TopicC)))) ;13 + (23 core topics)
- (is (= 13 (length (elephant:get-instances-by-class 'AssociationC)))) ;2 + (11 instanceOf)
- (is (= 26 (length (elephant:get-instances-by-class 'RoleC)))) ;4 + (22 instanceOf-associations)
- (is (= 36 (length (elephant:get-instances-by-class 'PersistentIdC)))) ;23 + (13 core topics)
+ ;13 + (23 core topics)
+ (is (= 36 (length (elephant:get-instances-by-class 'TopicC))))
+ ;2 + (11 instanceOf)
+ (is (= 13 (length (elephant:get-instances-by-class 'AssociationC))))
+ ;4 + (22 instanceOf-associations)
+ (is (= 26 (length (elephant:get-instances-by-class 'RoleC))))
+ ;23 + (13 core topics)
+ (is (= 36 (length (elephant:get-instances-by-class 'PersistentIdC))))
(is (= 0 (length (elephant:get-instances-by-class 'SubjectLocatorC))))
- (is (= 2 (length (elephant:get-instances-by-class 'OccurrenceC)))) ;2 + (0 core topics)
- (is (= 18 (length (elephant:get-instances-by-class 'NameC)))) ;18 + (0 core topics)
+ ;2 + (0 core topics)
+ (is (= 2 (length (elephant:get-instances-by-class 'OccurrenceC))))
+ ;18 + (0 core topics)
+ (is (= 18 (length (elephant:get-instances-by-class 'NameC))))
(let ((t-2526 (get-item-by-id "t-2526"))
(t-2656 (get-item-by-id "t-2656"))
(assoc (first (used-as-type (get-item-by-id "t89671052499")))))
(is (= (length (player-in-roles t-2526)) 1))
(is (= (length (psis t-2526)) 1))
- (is (string= (uri (first (psis t-2526))) "http://psi.egovpt.org/types/serviceUsesTechnology"))
+ (is (string= (uri (first (psis t-2526)))
+ "http://psi.egovpt.org/types/serviceUsesTechnology"))
(is (= (length (names t-2526)) 3))
- (is (or (string= (charvalue (first (names t-2526))) "service uses technology")
- (string= (charvalue (second (names t-2526))) "service uses technology")
- (string= (charvalue (third (names t-2526))) "service uses technology")))
- (is (or (string= (charvalue (first (names t-2526))) "uses technology")
- (string= (charvalue (second (names t-2526))) "uses technology")
- (string= (charvalue (third (names t-2526))) "uses technology")))
- (is (or (string= (charvalue (first (names t-2526))) "used by service")
- (string= (charvalue (second (names t-2526))) "used by service")
- (string= (charvalue (third (names t-2526))) "used by service")))
+ (is (or (string= (charvalue (first (names t-2526)))
+ "service uses technology")
+ (string= (charvalue (second (names t-2526)))
+ "service uses technology")
+ (string= (charvalue (third (names t-2526)))
+ "service uses technology")))
+ (is (or (string= (charvalue (first (names t-2526)))
+ "uses technology")
+ (string= (charvalue (second (names t-2526)))
+ "uses technology")
+ (string= (charvalue (third (names t-2526)))
+ "uses technology")))
+ (is (or (string= (charvalue (first (names t-2526)))
+ "used by service")
+ (string= (charvalue (second (names t-2526)))
+ "used by service")
+ (string= (charvalue (third (names t-2526)))
+ "used by service")))
(loop for name in (names t-2526)
when (string= (charvalue name) "uses technology")
do (is (= (length (themes name)) 1))
@@ -484,15 +489,18 @@
(is (eq (first (themes name)) (get-item-by-id "t-2593"))))
(is (= (length (player-in-roles t-2656)) 2)) ;association + instanceOf
(is (= (length (psis t-2656)) 1))
- (is (string= (uri (first (psis t-2656))) "http://psi.egovpt.org/types/DO-NOT-SIGNAL-no-identifier-error"))
+ (is (string= (uri (first (psis t-2656)))
+ "http://psi.egovpt.org/types/DO-NOT-SIGNAL-no-identifier-error"))
(is (= (length (occurrences t-2656)) 2))
(loop for occ in (occurrences t-2656)
when (eq (instance-of occ) (get-item-by-id "t-2625"))
do (is (string= (charvalue occ) "0"))
- (is (string= (datatype occ) "http://www.w3.org/2001/XMLSchema#string"))
+ (is (string= (datatype occ)
+ "http://www.w3.org/2001/XMLSchema#string"))
when (eq (instance-of occ) (get-item-by-id "t-2626"))
do (is (string= (charvalue occ) "unbounded"))
- (is (string= (datatype occ) "http://www.w3.org/2001/XMLSchema#string"))
+ (is (string= (datatype occ)
+ "http://www.w3.org/2001/XMLSchema#string"))
when (not (or (eq (instance-of occ) (get-item-by-id "t-2625"))
(eq (instance-of occ) (get-item-by-id "t-2626"))))
do (is-true (format t "bad occurrence found in t-2526")))
@@ -504,8 +512,8 @@
do (is (eq (instance-of role) (get-item-by-id "narrower-term")))
when (not (or (eq (player role) (get-item-by-id "all-subjects"))
(eq (player role) (get-item-by-id "t1106723946"))))
- do (is-true (format t "bad role found in association: ~A" (topic-identifiers (player role)))))))))
-
+ do (is-true (format t "bad role found in association: ~A"
+ (topic-identifiers (player role)))))))))
(test test-variants
@@ -513,8 +521,9 @@
((dir "data_base"))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
- *notificationbase.xtm* dir :xtm-id *TEST-TM*)
-
+ *notificationbase.xtm* dir :xtm-id *TEST-TM*
+ :tm-id "http://isidorus.org/test-tm")
+ (setf *TM-REVISION* 0)
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((variants (elephant:get-instances-by-class 'VariantC)))
(is (= (length variants) 4))
@@ -523,7 +532,7 @@
(d-type (datatype variant))
(string-type "http://www.w3.org/2001/XMLSchema#string")
(itemIdentities (map 'list #'uri (item-identifiers variant)))
- (parent-name-value (charvalue (name variant)))
+ (parent-name-value (charvalue (parent variant)))
(scopes (map 'list #'uri
(map 'list #'(lambda(x)
(first (psis x))) ;these topics have only one psi
@@ -534,8 +543,8 @@
(cond
((string= resourceData "Long-Version")
(is (string= parent-name-value "long version of a name"))
- (is (= (length (variants (name variant))) 1))
- (is (eql variant (first (variants (name variant)))))
+ (is (= (length (variants (parent variant))) 1))
+ (is (eql variant (first (variants (parent variant)))))
(check-for-duplicate-identifiers variant)
(is-false itemIdentities)
(is (= (length scopes) 1))
@@ -543,26 +552,28 @@
(is (string= d-type string-type)))
((string= resourceData "Geographic Information - Metadata")
(is (string= parent-name-value "ISO 19115"))
- (is (= (length (variants (name variant))) 2))
- (is (or (eql variant (first (variants (name variant))))
- (eql variant (second (variants (name variant))))))
+ (is (= (length (variants (parent variant))) 2))
+ (is (or (eql variant (first (variants (parent variant))))
+ (eql variant (second (variants (parent variant))))))
(check-for-duplicate-identifiers variant)
(is (= (length scopes) 1))
(is (string= (first scopes) display-psi))
(is (= (length itemIdentities) 1))
- (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1"))
+ (is (string= (first itemIdentities)
+ "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1"))
(is (string= d-type string-type)))
((string= resourceData "ISO-19115")
(check-for-duplicate-identifiers variant)
(is (= (length itemIdentities) 1))
- (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2"))
+ (is (string= (first itemIdentities)
+ "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2"))
(is (= (length scopes) 1))
(is (string= (first scopes) sort-psi))
(is (string= d-type string-type)))
((string= resourceData "ISO/IEC-13250:2002")
(is (string= parent-name-value "ISO/IEC 13250:2002: Topic Maps"))
- (is (= (length (variants (name variant))) 1))
- (is (eql variant (first (variants (name variant)))))
+ (is (= (length (variants (parent variant))) 1))
+ (is (eql variant (first (variants (parent variant)))))
(check-for-duplicate-identifiers variant)
(check-for-duplicate-identifiers variant)
(is (= (length scopes) 2))
@@ -571,10 +582,14 @@
(is (or (string= (second scopes) t50a-psi)
(string= (second scopes) sort-psi)))
(is (= (length itemIdentities) 2))
- (is (or (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1")
- (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2")))
- (is (or (string= (second itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1")
- (string= (second itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2")))
+ (is (or (string= (first itemIdentities)
+ "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1")
+ (string= (first itemIdentities)
+ "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2")))
+ (is (or (string= (second itemIdentities)
+ "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1")
+ (string= (second itemIdentities)
+ "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2")))
(is (string= d-type string-type)))
(t
(is-true (format t "found bad resourceData in variant object: ~A~%" resourceData))))))))))
@@ -583,12 +598,11 @@
(test test-variants-xtm1.0
"tests the importer-xtm1.0 -> variants"
- (let
- ((dir "data_base"))
+ (let ((dir "data_base"))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
- *sample_objects.xtm* dir :xtm-id *TEST-TM* :xtm-format '1.0)
-
+ *sample_objects.xtm* dir :xtm-id *TEST-TM* :xtm-format '1.0
+ :tm-id "http://isidorus.org/test-tm")
(elephant:open-store (xml-importer:get-store-spec dir))
(is (= (length (elephant:get-instances-by-class 'VariantC)) 5))
(let ((t-2526 (get-item-by-id "t-2526")))
@@ -596,48 +610,59 @@
do (let ((baseNameString (charvalue baseName))
(name-variants (variants baseName)))
(loop for variant in name-variants
- do (is (string= (datatype variant) "http://www.w3.org/2001/XMLSchema#string")))
+ do (is (string= (datatype variant)
+ "http://www.w3.org/2001/XMLSchema#string")))
(cond
((string= baseNameString "service uses technology")
(is (= (length name-variants) 2))
(loop for variant in name-variants
- do (is (eql baseName (name variant)))
+ do (is (eql baseName (parent variant)))
(let ((variantName (charvalue variant)))
(cond
((string= variantName "service-uses-technology")
(is (= (length (themes variant)) 1))
- (is (eql (first (themes variant)) (get-item-by-id "sort"))))
+ (is (eql (first (themes variant))
+ (get-item-by-id "sort"))))
((string= variantName "service uses technology")
(is (= (length (themes variant)) 1))
- (is (eql (first (themes variant)) (get-item-by-id "display"))))
+ (is (eql (first (themes variant))
+ (get-item-by-id "display"))))
(t
(is-true (format t "basevariantName found in t-2526: ~A~%" variantName)))))))
((string= baseNameString "uses technology")
(is (= (length name-variants) 2))
(loop for variant in name-variants
- do (is (eql baseName (name variant)))
+ do (is (eql baseName (parent variant)))
(let ((variantName (charvalue variant)))
(cond
((string= variantName "uses technology")
(is (= (length (themes variant)) 2))
- (is-true (find (get-item-by-id "t-2555") (themes variant) :test #'eql))
- (is-true (find (get-item-by-id "display") (themes variant) :test #'eql)))
+ (is-true (find (get-item-by-id "t-2555")
+ (themes variant) :test #'eql))
+ (is-true (find (get-item-by-id "display")
+ (themes variant) :test #'eql)))
((string= variantName "uses-technology")
(is (= (length (themes variant)) 3))
- (is-true (find (get-item-by-id "t-2555") (themes variant) :test #'eql))
- (is-true (find (get-item-by-id "display") (themes variant) :test #'eql))
- (is-true (find (get-item-by-id "sort") (themes variant) :test #'eql)))
+ (is-true (find (get-item-by-id "t-2555")
+ (themes variant) :test #'eql))
+ (is-true (find (get-item-by-id "display")
+ (themes variant) :test #'eql))
+ (is-true (find (get-item-by-id "sort")
+ (themes variant) :test #'eql)))
(t
(is-true (format t "bad variantName found in t-2526: ~A~%" variantName)))))))
((string= baseNameString "used by service")
(is (= (length name-variants) 1))
(loop for variant in name-variants
- do (is (eql baseName (name variant)))
+ do (is (eql baseName (parent variant)))
(is (string= (charvalue variant) "used-by-service"))
(is (= (length (themes variant)) 3))
- (is-true (find (get-item-by-id "t-2593") (themes variant) :test #'eql))
- (is-true (find (get-item-by-id "display") (themes variant) :test #'eql))
- (is-true (find (get-item-by-id "sort") (themes variant) :test #'eql))))
+ (is-true (find (get-item-by-id "t-2593")
+ (themes variant) :test #'eql))
+ (is-true (find (get-item-by-id "display")
+ (themes variant) :test #'eql))
+ (is-true (find (get-item-by-id "sort")
+ (themes variant) :test #'eql))))
(t
(is-true (format t "bad baseNameString found in names of t-2526: ~A~%" baseNameString))))))))))
@@ -654,7 +679,7 @@
'("http://www.isidor.us/unittests/testtm"
"http://www.topicmaps.org/xtm/1.0/core.xtm")
(mapcan (lambda (tm)
- (mapcar #'uri (item-identifiers tm)))
+ (mapcar #'uri (item-identifiers tm :revision 0)))
tms) :test #'string=)))))
Modified: trunk/src/unit_tests/json_test.lisp
==============================================================================
--- trunk/src/unit_tests/json_test.lisp (original)
+++ trunk/src/unit_tests/json_test.lisp Sun Oct 10 05:41:19 2010
@@ -59,96 +59,112 @@
(test test-to-json-string-topics
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
- :xtm-id *TEST-TM*)
-
+ :xtm-id *TEST-TM*)
(elephant:open-store (xml-importer:get-store-spec dir))
- (let ((t50a (get-item-by-id "t50a")))
- (let ((t50a-string (to-json-string t50a))
+ (let ((t50a (get-item-by-id "t50a" :xtm-id *TEST-TM* :revision rev-0)))
+ (let ((t50a-string (to-json-string t50a :revision 0))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" )))
+ (concatenate 'string "{\"id\":\"" (topic-id t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" )))
(is (string= t50a-string json-string)))
- (let ((t8 (get-item-by-id "t8")))
- (let ((t8-string (to-json-string t8))
+ (let ((t8 (get-item-by-id "t8" :revision rev-0 :xtm-id *TEST-TM*)))
+ (let ((t8-string (to-json-string t8 :revision rev-0 :xtm-id *TEST-TM*))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}")))
(is (string= t8-string json-string))))
- (let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm")))
- (let ((t-topic-string (to-json-string t-topic))
+ (let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm" :revision rev-0)))
+ (let ((t-topic-string (to-json-string t-topic :xtm-id "core.xtm"
+ :revision rev-0))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}")))
(is (string= t-topic-string json-string))))
- (let ((t301 (get-item-by-id "t301")))
- (let ((t301-string (to-json-string t301))
+ (let ((t301 (get-item-by-id "t301" :xtm-id *TEST-TM* :revision rev-0)))
+ (let ((t301-string (to-json-string t301 :xtm-id *TEST-TM* :revision rev-0))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}")))
(is (string= t301-string json-string))))
- (let ((t100 (get-item-by-id "t100")))
- (let ((t100-string (to-json-string t100))
+ (let ((t100 (get-item-by-id "t100" :revision rev-0 :xtm-id *TEST-TM*)))
+ (let ((t100-string (to-json-string t100 :revision rev-0 :xtm-id *TEST-TM*))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}")))
(is (string= t100-string json-string))))))))
(test test-to-json-string-associations
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
- (let ((t57 (get-item-by-id "t57"))
- (t59 (get-item-by-id "t59"))
- (t202 (get-item-by-id "t202"))
- (t58 (get-item-by-id "t58"))
- (t203 (get-item-by-id "t203"))
- (t64 (get-item-by-id "t64"))
- (t62 (get-item-by-id "t62")))
+ (let ((t57 (get-item-by-id "t57" :revision rev-0 :xtm-id *TEST-TM*))
+ (t59 (get-item-by-id "t59" :revision rev-0 :xtm-id *TEST-TM*))
+ (t202 (get-item-by-id "t202" :revision rev-0 :xtm-id *TEST-TM*))
+ (t58 (get-item-by-id "t58" :revision rev-0 :xtm-id *TEST-TM*))
+ (t203 (get-item-by-id "t203" :revision rev-0 :xtm-id *TEST-TM*))
+ (t64 (get-item-by-id "t64" :revision rev-0 :xtm-id *TEST-TM*))
+ (t62 (get-item-by-id "t62" :revision rev-0 :xtm-id *TEST-TM*)))
(let ((association-1
- (loop for association in (elephant:get-instances-by-class 'AssociationC)
- when (and (eq t57 (instance-of association))
- (eq t59 (instance-of (first (roles association))))
- (eq t202 (player (first (roles association))))
- (eq t58 (instance-of (second (roles association))))
- (eq t203 (player (second (roles association)))))
+ (loop for association in
+ (elephant:get-instances-by-class 'AssociationC)
+ when (and (eq t57 (instance-of association :revision rev-0))
+ (eq t59 (instance-of
+ (first (roles association :revision rev-0))
+ :revision rev-0))
+ (eq t202 (player
+ (first (roles association :revision rev-0))
+ :revision rev-0))
+ (eq t58 (instance-of
+ (second (roles association :revision rev-0))
+ :revision rev-0))
+ (eq t203 (player
+ (second (roles association :revision rev-0))
+ :revision rev-0)))
return association))
(association-7
(identified-construct
- (elephant:get-instance-by-value 'ItemIdentifierC 'uri
- "http://psi.egovpt.org/itemIdentifiers#assoc_7"))))
- (let ((association-1-string (to-json-string association-1))
+ (elephant:get-instance-by-value
+ 'ItemIdentifierC 'uri
+ "http://psi.egovpt.org/itemIdentifiers#assoc_7")
+ :revision rev-0)))
+ (let ((association-1-string
+ (to-json-string association-1 :revision rev-0 :xtm-id *TEST-TM*))
(json-string
(concatenate 'string "{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/isNarrowerSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/broaderSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Data\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/narrowerSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]}")))
(is (string= association-1-string json-string)))
- (let ((association-7-string (to-json-string association-7))
+ (let ((association-7-string
+ (to-json-string association-7 :revision rev-0 :xtm-id *TEST-TM*))
(json-string
(concatenate 'string "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}")))
(is (string= association-7-string json-string)))
- (elephant:remove-association association-7 'roles (first (roles association-7)))
- (elephant:remove-association association-7 'roles (first (roles association-7)))
- (elephant:remove-association association-7 'instance-of t64)
- (elephant:add-association association-7 'themes t64)
- (elephant:add-association association-7 'themes t62)
- (let ((association-7-string (to-json-string association-7))
+ (let ((rev-1 (get-revision)))
+ (delete-role association-7 (first (roles association-7 :revision 0))
+ :revision rev-1)
+ (delete-role association-7 (first (roles association-7 :revision 0))
+ :revision rev-1)
+ (delete-type association-7 (instance-of association-7 :revision 0)
+ :revision rev-1)
+ (add-theme association-7 t62 :revision rev-1)
+ (add-theme association-7 t64 :revision rev-1))
+ (let ((association-7-string
+ (to-json-string association-7 :revision rev-0 :xtm-id *TEST-TM*))
(json-string
(concatenate 'string "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]],\"roles\":null}")))
(is (string= association-7-string json-string))))))))
(test test-to-json-string-fragments
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((frag-t100
(create-latest-fragment-of-topic
@@ -156,34 +172,40 @@
(frag-topic
(create-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic")))
(let ((frag-t100-string
- (concatenate 'string "{\"topic\":{\"id\":\"" (d:topicid (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}"))
+ (concatenate 'string "{\"topic\":{\"id\":\"" (d:topic-id (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}"))
(frag-topic-string
- (concatenate 'string "{\"topic\":{\"id\":\"" (topicid (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}")))
- (is (string= frag-t100-string (to-json-string frag-t100)))
- (is (string= frag-topic-string (to-json-string frag-topic))))))))
+ (concatenate 'string "{\"topic\":{\"id\":\"" (topic-id (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}")))
+ (is (string=
+ frag-t100-string
+ (to-json-string frag-t100 :xtm-id *TEST-TM* :revision rev-0)))
+ (is (string=
+ frag-topic-string
+ (to-json-string frag-topic :xtm-id *TEST-TM* :revision rev-0))))))))
(test test-get-fragment-values-from-json-list-general
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((json-fragment
(let ((fragment-obj
(create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002")))
- (to-json-string fragment-obj))))
+ (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*))))
(let ((fragment-list
(json-importer::get-fragment-values-from-json-list
(json:decode-json-from-string json-fragment))))
(let ((topic (getf fragment-list :topic)))
(is (string= (getf topic :ID)
- (d:topicid
- (d:identified-construct (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri
- "http://psi.egovpt.org/standard/Topic+Maps+2002")))))
+ (d:topic-id
+ (d:identified-construct
+ (elephant:get-instance-by-value
+ 'd:PersistentIdC 'd:uri
+ "http://psi.egovpt.org/standard/Topic+Maps+2002")
+ :revision rev-0))))
(is-false (getf topic :itemIdentities))
(is-false (getf topic :subjectLocators))
(is (= (length (getf topic :subjectIdentifiers)) 1))
@@ -196,18 +218,17 @@
(test test-get-fragment-values-from-json-list-names
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((json-fragment
(let ((fragment-obj
(create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002")))
- (to-json-string fragment-obj))))
+ (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*))))
(let ((fragment-list
(json-importer::get-fragment-values-from-json-list
(json:decode-json-from-string json-fragment))))
@@ -263,18 +284,17 @@
(test test-get-fragment-values-from-json-list-occurrences
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((json-fragment
(let ((fragment-obj
(create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002")))
- (to-json-string fragment-obj))))
+ (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*))))
(let ((fragment-list
(json-importer::get-fragment-values-from-json-list
(json:decode-json-from-string json-fragment))))
@@ -294,7 +314,7 @@
"http://psi.egovpt.org/types/standardHasStatus"))
(is-false (getf occurrence-1 :scopes))
(is (string= (getf occurrence-1 :resourceRef)
- (concatenate 'string "#" (d:topicid ref-topic))))
+ (concatenate 'string "#" (d:topic-id ref-topic))))
(is-false (getf occurrence-1 :resourceData))
(is-false (getf occurrence-2 :itemIdentities))
(is (= (length (getf occurrence-2 :type)) 1))
@@ -326,18 +346,17 @@
(test test-get-fragment-values-from-json-list-topicStubs
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((json-fragment
(let ((fragment-obj
(create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002")))
- (to-json-string fragment-obj))))
+ (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*))))
(let ((fragment-list
(json-importer::get-fragment-values-from-json-list
(json:decode-json-from-string json-fragment))))
@@ -357,35 +376,43 @@
subjectIdentifier))))
(is-true topic)
(is-false subjectLocators)
- (is (string= (d:topicid topic) id))
+ (is (string= (d:topic-id topic) id))
(cond
- ((string= subjectIdentifier "http://psi.egovpt.org/types/semanticstandard")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/semanticstandard")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t3a")))
- ((string= subjectIdentifier "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
+ ((string= subjectIdentifier
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
(is-false itemIdentities))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/long-name")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/long-name")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t50a")))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/standardHasStatus")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/standardHasStatus")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t51")))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/description")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/description")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t53")))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/standardValidFromDate")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/standardValidFromDate")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t54")))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/links")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/links")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t55")))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/standardIsAboutSubject")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/standardIsAboutSubject")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t60")))
@@ -393,23 +420,29 @@
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t61")))
- ((string= subjectIdentifier "http://psi.egovpt.org/subject/Semantic+Description")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/subject/Semantic+Description")
(is-false itemIdentities))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/serviceUsesStandard")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/serviceUsesStandard")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t64")))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/ServiceRoleType")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/ServiceRoleType")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t63")))
- ((string= subjectIdentifier "http://psi.egovpt.org/service/Norwegian+National+Curriculum")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/service/Norwegian+National+Curriculum")
(is-false itemIdentities))
- ((string= subjectIdentifier "http://psi.egovpt.org/types/StandardRoleType")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/types/StandardRoleType")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t62")))
- ((string= subjectIdentifier "http://psi.egovpt.org/status/InternationalStandard")
+ ((string= subjectIdentifier
+ "http://psi.egovpt.org/status/InternationalStandard")
(is (= (length itemIdentities) 1))
(is (string= (first itemIdentities)
"http://psi.egovpt.org/itemIdentifiers#t52")))
@@ -419,18 +452,17 @@
(test test-get-fragment-values-from-json-list-associations
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
:xtm-id *TEST-TM*)
-
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((json-fragment
(let ((fragment-obj
(create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002")))
- (to-json-string fragment-obj))))
+ (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*))))
(let ((fragment-list
(json-importer::get-fragment-values-from-json-list
(json:decode-json-from-string json-fragment))))
@@ -491,12 +523,10 @@
(test test-json-importer-general-1
- (let
- ((dir "data_base"))
+ (let ((dir "data_base"))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(is (= (length (elephant:get-instances-by-class 'TopicC)) 13))
(is (= (length (elephant:get-instances-by-class 'AssociationC)) 0))
(is (= (length (elephant:get-instances-by-class 'TopicMapC)) 1))
@@ -522,12 +552,10 @@
(test test-json-importer-general-2
- (let
- ((dir "data_base"))
+ (let ((dir "data_base"))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(let ((test-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
@@ -580,16 +608,14 @@
(test test-json-importer-general-3
- (let
- ((dir "data_base"))
+ (let ((dir "data_base"))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(json-importer:json-to-elem *t100-3*)
- (is (= (length (elephant:get-instances-by-class 'TopicC)) 28)) ;13 new topics
- (is (= (length (elephant:get-instances-by-class 'AssociationC)) 5)) ;4 new associations
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28)) ;13 new topics
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 5)) ;4 new associations
(is (= (length (elephant:get-instances-by-class 'TopicMapC)) 2))
(let ((core-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
@@ -609,162 +635,195 @@
(test test-json-importer-topics-1
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(json-importer:json-to-elem *t100-3*)
(let ((topics (elephant:get-instances-by-class 'TopicC)))
(loop for topic in topics
- do (let ((psi (uri (first (psis topic)))))
+ do (let ((psi (uri (first (psis topic :revision rev-0)))))
(cond
((string= psi "http://psi.egovpt.org/types/semanticstandard") ;t3a
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string= (uri (first (item-identifiers topic :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#t3a")))
- ((string= psi "http://www.networkedplanet.com/psi/npcl/meta-types/association-type") ;t7
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
+ ((string= psi
+ "http://www.networkedplanet.com/psi/npcl/meta-types/association-type") ;t7
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string= (uri (first (item-identifiers topic :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#t7")))
((string= psi "http://psi.egovpt.org/types/standardHasStatus") ;t51
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string= (uri (first (item-identifiers topic :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#t51")))
((string= psi "http://psi.egovpt.org/types/description") ;t53
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string= (uri (first (item-identifiers topic :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#t53")))
((string= psi "http://psi.egovpt.org/types/standardValidFromDate") ;t54
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t54"))))))))))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t54"))))))))))
(test test-json-importer-topics-2
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(json-importer:json-to-elem *t100-3*)
(let ((topics (elephant:get-instances-by-class 'TopicC)))
(loop for topic in topics
- do (let ((psi (uri (first (psis topic)))))
+ do (let ((psi (uri (first (psis topic :revision rev-0)))))
(cond ((string= psi "http://psi.egovpt.org/types/links") ;t55
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t55")))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t55")))
((string= psi "http://psi.egovpt.org/types/standardIsAboutSubject") ;t60
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t60")))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t60")))
((string= psi "http://psi.egovpt.org/types/SubjectRoleType") ;t61
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t61")))
- ((string= psi "http://psi.egovpt.org/types/StandardRoleType") ;t62
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t62")))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t61")))
+ ((string= psi
+ "http://psi.egovpt.org/types/StandardRoleType") ;t62
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t62")))
((string= psi "http://psi.egovpt.org/types/ServiceRoleType") ;t63
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t63")))
- ((string= psi "http://psi.egovpt.org/types/serviceUsesStandard") ;t64
- (is (= (length (names topic)) 1))
- (is (string= (charvalue (first (names topic)))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t63")))
+ ((string= psi
+ "http://psi.egovpt.org/types/serviceUsesStandard") ;t64
+ (is (= (length (names topic :revision rev-0)) 1))
+ (is (string= (charvalue (first (names topic :revision rev-0)))
"service uses standard"))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t64"))))))))))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t64"))))))))))
(test test-json-importer-topics-3
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(json-importer:json-to-elem *t100-3*)
(let ((topics (elephant:get-instances-by-class 'TopicC)))
(loop for topic in topics
- do (let ((psi (uri (first (psis topic)))))
+ do (let ((psi (uri (first (psis topic :revision rev-0)))))
(cond ((string= psi "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata") ;t100
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t100"))
- (is (= (length (names topic)) 1))
- (is (string= (charvalue (first (names topic)))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100"))
+ (is (= (length (names topic :revision rev-0)) 1))
+ (is (string= (charvalue (first (names topic :revision rev-0)))
"ISO 19115"))
- (is (= (length (item-identifiers (first (names topic))))))
- (is (string= (uri (first (item-identifiers (first (names topic)))))
+ (is (= (length (item-identifiers
+ (first (names topic :revision rev-0))
+ :revision rev-0))))
+ (is (string= (uri (first
+ (item-identifiers
+ (first (names topic :revision rev-0))
+ :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#t100_n1"))
- (is (= (length (variants (first (names topic)))) 2))
- (let ((variant-1 (first (variants (first (names topic)))))
- (variant-2 (second (variants (first (names topic))))))
- (is (= (length (item-identifiers variant-1)) 1))
- (is (string= (uri (first (item-identifiers variant-1)))
- "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1"))
- (is (= (length (item-identifiers variant-2)) 1))
- (is (string= (uri (first (item-identifiers variant-2)))
- "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2"))
- (is (= (length (themes variant-1)) 1))
- (is (string= (uri (first (psis (first (themes variant-1)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm#display"))
- (is (= (length (themes variant-2)) 1))
- (is (string= (uri (first (psis (first (themes variant-2)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm#sort"))
+ (is (= (length (variants
+ (first (names topic :revision rev-0))
+ :revision rev-0)) 2))
+ (let ((variant-1 (first
+ (variants
+ (first (names topic :revision rev-0))
+ :revision rev-0)))
+ (variant-2 (second
+ (variants
+ (first (names topic :revision rev-0))
+ :revision rev-0))))
+ (is (= (length
+ (item-identifiers variant-1 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers variant-1
+ :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1"))
+ (is (= (length
+ (item-identifiers variant-2 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers
+ variant-2 :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2"))
+ (is (= (length (themes variant-1 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (psis (first (themes variant-1
+ :revision rev-0)))))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#display"))
+ (is (= (length (themes variant-2 :revision rev-0)) 1))
+ (is (string=
+ (uri (first
+ (psis (first (themes variant-2
+ :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort"))
(is (string= (charvalue variant-1)
"Geographic Information - Metadata"))
(is (string= (datatype variant-1)
@@ -773,31 +832,39 @@
"ISO-19115"))
(is (string= (datatype variant-2)
"http://www.w3.org/2001/XMLSchema#string")))
- (is (= (length (occurrences topic)) 4))
- (let ((occ-1 (first (occurrences topic)))
- (occ-2 (second (occurrences topic)))
- (occ-3 (third (occurrences topic)))
- (occ-4 (fourth (occurrences topic))))
- (is (= (length (item-identifiers occ-1)) 1))
- (is (string= (uri (first (item-identifiers occ-1)))
- "http://psi.egovpt.org/itemIdentifiers#t100_o1"))
- (is (= (length (item-identifiers occ-2)) 1))
- (is (string= (uri (first (item-identifiers occ-2)))
- "http://psi.egovpt.org/itemIdentifiers#t100_o2"))
- (is (= (length (item-identifiers occ-3)) 1))
- (is (string= (uri (first (item-identifiers occ-3)))
- "http://psi.egovpt.org/itemIdentifiers#t100_o3"))
- (is (= (length (item-identifiers occ-4)) 1))
- (is (string= (uri (first (item-identifiers occ-4)))
- "http://psi.egovpt.org/itemIdentifiers#t100_o4"))
- (is (string= (uri (first (psis (instance-of occ-1))))
- "http://psi.egovpt.org/types/standardHasStatus"))
- (is (string= (uri (first (psis (instance-of occ-2))))
- "http://psi.egovpt.org/types/description"))
- (is (string= (uri (first (psis (instance-of occ-3))))
- "http://psi.egovpt.org/types/standardValidFromDate"))
- (is (string= (uri (first (psis (instance-of occ-4))))
- "http://psi.egovpt.org/types/links"))
+ (is (= (length (occurrences topic :revision rev-0)) 4))
+ (let ((occ-1 (first (occurrences topic :revision rev-0)))
+ (occ-2 (second (occurrences topic :revision rev-0)))
+ (occ-3 (third (occurrences topic :revision rev-0)))
+ (occ-4 (fourth (occurrences topic :revision rev-0))))
+ (is (= (length (item-identifiers occ-1 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers occ-1 :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100_o1"))
+ (is (= (length (item-identifiers occ-2 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers occ-2 :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100_o2"))
+ (is (= (length (item-identifiers occ-3 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers occ-3 :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100_o3"))
+ (is (= (length (item-identifiers occ-4 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers occ-4 :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t100_o4"))
+ (is (string=
+ (uri (first (psis (instance-of occ-1 :revision rev-0))))
+ "http://psi.egovpt.org/types/standardHasStatus"))
+ (is (string=
+ (uri (first (psis (instance-of occ-2 :revision rev-0))))
+ "http://psi.egovpt.org/types/description"))
+ (is (string=
+ (uri (first (psis (instance-of occ-3 :revision rev-0))))
+ "http://psi.egovpt.org/types/standardValidFromDate"))
+ (is (string=
+ (uri (first (psis (instance-of occ-4 :revision rev-0))))
+ "http://psi.egovpt.org/types/links"))
(is (string= (datatype occ-1)
"http://www.w3.org/2001/XMLSchema#anyURI"))
(is (string= (charvalue occ-1)
@@ -817,86 +884,94 @@
(test test-json-importer-topics-4
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(json-importer:json-to-elem *t100-3*)
(let ((topics (elephant:get-instances-by-class 'TopicC)))
(loop for topic in topics
- do (let ((psi (uri (first (psis topic)))))
- (cond ((string= psi "http://psi.egovpt.org/subject/Semantic+Description") ;t201
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is-false (item-identifiers topic)))
+ do (let ((psi (uri (first (psis topic :revision rev-0)))))
+ (cond ((string=
+ psi
+ "http://psi.egovpt.org/subject/Semantic+Description") ;t201
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is-false (item-identifiers topic :revision rev-0)))
((string= psi "http://psi.egovpt.org/subject/GeoData") ;t203
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is-false (item-identifiers topic)))
- ((or (string= psi "http://psi.egovpt.org/service/Google+Maps") ;t301a
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is-false (item-identifiers topic :revision rev-0)))
+ ((or (string= psi
+ "http://psi.egovpt.org/service/Google+Maps") ;t301a
(string= psi "http://maps.google.com"))
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 2))
- (is (or (string= (uri (first (psis topic)))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 2))
+ (is (or (string= (uri (first (psis topic :revision rev-0)))
"http://psi.egovpt.org/service/Google+Maps")
- (string= (uri (first (psis topic)))
+ (string= (uri (first (psis topic :revision rev-0)))
"http://maps.google.com")))
- (is (or (string= (uri (second (psis topic)))
+ (is (or (string= (uri (second (psis topic :revision rev-0)))
"http://psi.egovpt.org/service/Google+Maps")
- (string= (uri (second (psis topic)))
+ (string= (uri (second (psis topic :revision rev-0)))
"http://maps.google.com")))
- (is-false (item-identifiers topic))))))))))
+ (is-false (item-identifiers topic :revision rev-0))))))))))
(test test-json-importer-associations
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store
(json-importer:json-to-elem *t64*)
(json-importer:json-to-elem *t100-3*)
(let ((assoc-7
(identified-construct
- (elephant:get-instance-by-value 'ItemidentifierC 'uri
- "http://psi.egovpt.org/itemIdentifiers#assoc_7"))))
- (is (= (length (item-identifiers assoc-7))))
- (is (string= (uri (first (item-identifiers assoc-7)))
+ (elephant:get-instance-by-value
+ 'ItemidentifierC 'uri
+ "http://psi.egovpt.org/itemIdentifiers#assoc_7")
+ :revision rev-0)))
+ (is (= (length (item-identifiers assoc-7 :revision rev-0))))
+ (is (string= (uri (first (item-identifiers assoc-7 :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#assoc_7"))
- (is (= (length (roles assoc-7)) 2))
- (is (string= (uri (first (psis (instance-of assoc-7))))
+ (is (= (length (roles assoc-7 :revision rev-0)) 2))
+ (is (string= (uri (first (psis (instance-of assoc-7 :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/types/serviceUsesStandard"))
- (let ((role-1 (first (roles assoc-7)))
- (role-2 (second (roles assoc-7))))
- (is (string= (uri (first (psis (instance-of role-1))))
+ (let ((role-1 (first (roles assoc-7 :revision rev-0)))
+ (role-2 (second (roles assoc-7 :revision rev-0))))
+ (is (string= (uri (first (psis (instance-of role-1 :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/types/ServiceRoleType"))
- (is (or (string= (uri (first (psis (player role-1))))
+ (is (or (string= (uri (first (psis (player role-1 :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/service/Google+Maps")
- (string= (uri (first (psis (player role-1))))
+ (string= (uri (first (psis (player role-1 :revision rev-0)
+ :revision rev-0)))
"http://maps.google.com")))
- (is (string= (uri (first (psis (instance-of role-2))))
+ (is (string= (uri (first (psis (instance-of role-2 :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/types/StandardRoleType"))
- (is (string= (uri (first (psis (player role-2))))
+ (is (string= (uri (first (psis (player role-2 :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata")))))))
(test test-json-importer-merge-1
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isidorus closes the store
(is (= (length (elephant:get-instances-by-class 'TopicC)) 13))
(is (= (length (elephant:get-instances-by-class 'AssociationC)) 0))
(is (= (length (elephant:get-instances-by-class 'TopicMapC)) 1))
@@ -906,12 +981,12 @@
(is (= (length (elephant:get-instances-by-class 'TopicMapC)) 2))
(let ((core-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.topicmaps.org/xtm/1.0/core.xtm")
return tm))
(test-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.isidor.us/unittests/testtm")
return tm)))
(is-true (and core-tm test-tm)))
@@ -921,141 +996,194 @@
(is (= (length (elephant:get-instances-by-class 'TopicMapC)) 2))
(let ((core-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.topicmaps.org/xtm/1.0/core.xtm")
return tm))
(test-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.isidor.us/unittests/testtm")
return tm)))
(is-true (and core-tm test-tm)))
(let ((topics (elephant:get-instances-by-class 'TopicC)))
(loop for topic in topics
- do (let ((psi (uri (first (psis topic)))))
+ do (let ((psi (uri (first (psis topic :revision rev-0)))))
(cond
((string= psi "http://psi.egovpt.org/types/standard") ;t3
- (is (= (length (in-topicmaps topic)) 1))
- (is (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
- "http://www.isidor.us/unittests/testtm"))
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 2))
- (is (or (string= (uri (first (item-identifiers topic)))
- "http://www.egovpt.org/itemIdentifiers#t3")
- (string= (uri (second (item-identifiers topic)))
- "http://www.egovpt.org/itemIdentifiers#t3")))
- (is (or (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t3")
- (string= (uri (second (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t3"))))
+ (is (= (length (in-topicmaps topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.isidor.us/unittests/testtm"))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 2))
+ (is (or (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t3")
+ (string=
+ (uri (second (item-identifiers topic :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t3")))
+ (is (or (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t3")
+ (string=
+ (uri (second (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t3"))))
((string= psi "http://psi.egovpt.org/types/long-name") ;t50a
- (is (= (length (in-topicmaps topic)) 1))
- (is (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
+ (is (= (length (in-topicmaps topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
"http://www.isidor.us/unittests/testtm"))
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 1))
- (is (string= (uri (first (item-identifiers topic)))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 1))
+ (is (string= (uri (first (item-identifiers topic :revision rev-0)))
"http://psi.egovpt.org/itemIdentifiers#t50a")))
((string= psi "http://psi.egovpt.org/types/links") ;t50
- (is (= (length (in-topicmaps topic)) 1))
- (is (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
- "http://www.isidor.us/unittests/testtm"))
- (is-false (names topic))
- (is-false (occurrences topic))
- (is-false (locators topic))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 2))
- (is (or (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t55")
- (string= (uri (second (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t55")))
- (is (or (string= (uri (first (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t55_1")
- (string= (uri (second (item-identifiers topic)))
- "http://psi.egovpt.org/itemIdentifiers#t55_1")))))))))))
+ (is (= (length (in-topicmaps topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.isidor.us/unittests/testtm"))
+ (is-false (names topic :revision rev-0))
+ (is-false (occurrences topic :revision rev-0))
+ (is-false (locators topic :revision rev-0))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 2))
+ (is (or (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t55")
+ (string=
+ (uri (second (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t55")))
+ (is (or (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t55_1")
+ (string=
+ (uri (second (item-identifiers topic :revision rev-0)))
+ "http://psi.egovpt.org/itemIdentifiers#t55_1")))))))))))
(test test-json-importer-merge-2
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isidorus closes the store
(json-importer:json-to-elem *t100-1*)
(let ((core-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.topicmaps.org/xtm/1.0/core.xtm")
- return tm))
+ return tm))
(test-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.isidor.us/unittests/testtm")
return tm)))
(is-true (and core-tm test-tm)))
(json-importer:json-to-elem *t100-2*)
(let ((topics (elephant:get-instances-by-class 'TopicC)))
(loop for topic in topics
- do (let ((psi (uri (first (psis topic)))))
+ do (let ((psi (uri (first (psis topic :revision rev-0)))))
(cond
- ((string= psi "http://psi.egovpt.org/types/standard") t) ;was already checked
- ((string= psi "http://psi.egovpt.org/types/long-name") t) ;was already checked
- ((string= psi "http://psi.egovpt.org/types/links") t) ;was already checked
+ ((string= psi "http://psi.egovpt.org/types/standard")
+ t) ;was already checked
+ ((string= psi "http://psi.egovpt.org/types/long-name")
+ t) ;was already checked
+ ((string= psi "http://psi.egovpt.org/types/links")
+ t) ;was already checked
((string= psi "http://psi.egovpt.org/standard/Common+Lisp") ;t100
- (is (= (length (in-topicmaps topic)) 1))
- (is (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
- "http://www.isidor.us/unittests/testtm"))
- (is (= (length (psis topic)) 1))
- (is (= (length (item-identifiers topic)) 2))
- (is (or (string= (uri (first (item-identifiers topic)))
- "http://www.egovpt.org/itemIdentifiers#t100")
- (string= (uri (second (item-identifiers topic)))
- "http://www.egovpt.org/itemIdentifiers#t100")))
- (is (or (string= (uri (first (item-identifiers topic)))
- "http://www.egovpt.org/itemIdentifiers#t100_new")
- (string= (uri (second (item-identifiers topic)))
- "http://www.egovpt.org/itemIdentifiers#t100_new")))
- (is (= (length (names topic))))
- (let ((name (first (names topic))))
- (is (= (length (item-identifiers name)) 2))
- (is (or (string= (uri (first (item-identifiers name)))
- "http://www.egovpt.org/itemIdentifiers#t100_n1")
- (string= (uri (second (item-identifiers name)))
- "http://www.egovpt.org/itemIdentifiers#t100_n1")))
- (is (or (string= (uri (first (item-identifiers name)))
- "http://www.egovpt.org/itemIdentifiers#t100_n1a")
- (string= (uri (second (item-identifiers name)))
- "http://www.egovpt.org/itemIdentifiers#t100_n1a")))
+ (is (= (length (in-topicmaps topic :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.isidor.us/unittests/testtm"))
+ (is (= (length (psis topic :revision rev-0)) 1))
+ (is (= (length (item-identifiers topic :revision rev-0)) 2))
+ (is (or (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100")
+ (string=
+ (uri (second (item-identifiers topic :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100")))
+ (is (or (string=
+ (uri (first (item-identifiers topic :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_new")
+ (string=
+ (uri (second (item-identifiers topic :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_new")))
+ (is (= (length (names topic :revision rev-0))))
+ (let ((name (first (names topic :revision rev-0))))
+ (is (= (length (item-identifiers name :revision rev-0)) 2))
+ (is (or (string=
+ (uri (first (item-identifiers name :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_n1")
+ (string=
+ (uri (second (item-identifiers name :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_n1")))
+ (is (or (string=
+ (uri (first (item-identifiers name :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_n1a")
+ (string=
+ (uri (second (item-identifiers name :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_n1a")))
(is (string= (charvalue name)
"Common Lisp"))
- (is (= (length (variants name)) 2))
- (let ((variant-1 (first (variants name)))
- (variant-2 (second (variants name))))
- (is (= (length (item-identifiers variant-1)) 1))
- (is (string= (uri (first (item-identifiers variant-1)))
- "http://www.egovpt.org/itemIdentifiers#t100_n_v1"))
- (is (= (length (item-identifiers variant-2)) 1))
- (is (string= (uri (first (item-identifiers variant-2)))
- "http://www.egovpt.org/itemIdentifiers#t100_n_v2"))
- (is (= (length (themes variant-1)) 2))
- (is (or (string= (uri (first (psis (first (themes variant-1)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
- (string= (uri (first (psis (second (themes variant-1)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")))
- (is (or (string= (uri (first (psis (first (themes variant-1)))))
- "http://psi.egovpt.org/types/long-name")
- (string= (uri (first (psis (second (themes variant-1)))))
- "http://psi.egovpt.org/types/long-name")))
- (is (= (length (themes variant-2)) 1))
- (is (string= (uri (first (psis (first (themes variant-2)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm#display"))
+ (is (= (length (variants name :revision rev-0)) 2))
+ (let ((variant-1 (first (variants name :revision rev-0)))
+ (variant-2 (second (variants name :revision rev-0))))
+ (is (= (length (item-identifiers variant-1 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers variant-1 :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_n_v1"))
+ (is (= (length (item-identifiers variant-2 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers variant-2 :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_n_v2"))
+ (is (= (length (themes variant-1 :revision rev-0)) 2))
+ (is (or (string=
+ (uri
+ (first
+ (psis
+ (first (themes variant-1 :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
+ (string=
+ (uri
+ (first
+ (psis (second (themes variant-1 :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")))
+ (is (or (string=
+ (uri
+ (first
+ (psis (first (themes variant-1 :revision rev-0))
+ :revision rev-0)))
+ "http://psi.egovpt.org/types/long-name")
+ (string=
+ (uri
+ (first
+ (psis (second (themes variant-1 :revision rev-0))
+ :revision rev-0)))
+ "http://psi.egovpt.org/types/long-name")))
+ (is (= (length (themes variant-2 :revision rev-0)) 1))
+ (is (string=
+ (uri
+ (first
+ (psis (first (themes variant-2 :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#display"))
(is (string= (datatype variant-1)
"http://www.w3.org/2001/XMLSchema#string"))
(is (string= (charvalue variant-1)
@@ -1064,19 +1192,25 @@
"http://www.w3.org/2001/XMLSchema#string"))
(is (string= (charvalue variant-2)
"CL"))))
- (is (= (length (occurrences topic)) 2))
- (let ((occ-1 (first (occurrences topic)))
- (occ-2 (second (occurrences topic))))
- (is (= (length (item-identifiers occ-1)) 1))
- (is (string= (uri (first (item-identifiers occ-1)))
- "http://www.egovpt.org/itemIdentifiers#t100_o1"))
- (is (= (length (item-identifiers occ-2)) 1))
- (is (string= (uri (first (item-identifiers occ-2)))
- "http://www.egovpt.org/itemIdentifiers#t100_o2"))
- (is (string= (uri (first (psis (instance-of occ-1))))
- "http://psi.egovpt.org/types/links"))
- (is (string= (uri (first (psis (instance-of occ-2))))
- "http://psi.egovpt.org/types/links"))
+ (is (= (length (occurrences topic :revision rev-0)) 2))
+ (let ((occ-1 (first (occurrences topic :revision rev-0)))
+ (occ-2 (second (occurrences topic :revision rev-0))))
+ (is (= (length (item-identifiers occ-1 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers occ-1 :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_o1"))
+ (is (= (length (item-identifiers occ-2 :revision rev-0)) 1))
+ (is (string=
+ (uri (first (item-identifiers occ-2 :revision rev-0)))
+ "http://www.egovpt.org/itemIdentifiers#t100_o2"))
+ (is (string=
+ (uri (first (psis (instance-of occ-1 :revision rev-0)
+ :revision rev-0)))
+ "http://psi.egovpt.org/types/links"))
+ (is (string=
+ (uri (first (psis (instance-of occ-2 :revision rev-0)
+ :revision rev-0)))
+ "http://psi.egovpt.org/types/links"))
(is (string= (datatype occ-1)
"http://www.w3.org/2001/XMLSchema#anyURI"))
(is (string= (charvalue occ-1)
@@ -1086,178 +1220,277 @@
(is (string= (charvalue occ-2)
"http://www.cliki.net/"))))
(t
- (if (or (string= psi "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
- (string= psi "http://www.topicmaps.org/xtm/1.0/core.xtm#display"))
+ (if (or (string=
+ psi
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
+ (string=
+ psi
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#display"))
(progn
- (is (= (length (in-topicmaps topic)) 2))
- (is (or (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm")
- (string= (uri (first (item-identifiers (second (in-topicmaps topic)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm")))
- (is (or (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
- "http://www.isidor.us/unittests/testtm")
- (string= (uri (first (item-identifiers (second (in-topicmaps topic)))))
- "http://www.isidor.us/unittests/testtm"))))
+ (is (= (length (in-topicmaps topic :revision rev-0)) 2))
+ (is (or (string=
+ (uri
+ (first
+ (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm")
+ (string=
+ (uri
+ (first
+ (item-identifiers
+ (second (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm")))
+ (is (or (string=
+ (uri
+ (first
+ (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.isidor.us/unittests/testtm")
+ (string=
+ (uri
+ (first
+ (item-identifiers
+ (second (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.isidor.us/unittests/testtm"))))
(progn
- (is (= (length (in-topicmaps topic)) 1))
- (is (string= (uri (first (item-identifiers (first (in-topicmaps topic)))))
- "http://www.topicmaps.org/xtm/1.0/core.xtm"))))))))))))
+ (is (= (length (in-topicmaps topic :revision rev-0)) 1))
+ (is (string=
+ (uri
+ (first
+ (item-identifiers
+ (first (in-topicmaps topic :revision rev-0))
+ :revision rev-0)))
+ "http://www.topicmaps.org/xtm/1.0/core.xtm"))))))))))))
(test test-json-importer-merge-3
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(xml-importer:init-isidorus)
- (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isidorus closes the store
(json-importer:json-to-elem *t100-1*)
(let ((core-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.topicmaps.org/xtm/1.0/core.xtm")
return tm))
(test-tm
(loop for tm in (elephant:get-instances-by-class 'TopicMapC)
- when (string= (uri (first (item-identifiers tm)))
+ when (string= (uri (first (item-identifiers tm :revision rev-0)))
"http://www.isidor.us/unittests/testtm")
return tm)))
(is-true (and core-tm test-tm)))
(json-importer:json-to-elem *t100-2*)
(let ((instanceOf-assoc
(first (elephant:get-instances-by-class 'AssociationC))))
- (is (string= (uri (first (psis (instance-of instanceOf-assoc))))
- constants::*type-instance-psi*))
- (is-false (d:themes instanceOf-assoc))
- (is (string= (d:uri (first (d:item-identifiers (first (d:in-topicmaps instanceOf-assoc)))))
- "http://www.isidor.us/unittests/testtm"))
- (is-false (d:item-identifiers instanceOf-assoc))
+ (is (string=
+ (uri (first (psis (instance-of instanceOf-assoc :revision rev-0)
+ :revision rev-0)))
+ constants::*type-instance-psi*))
+ (is-false (d:themes instanceOf-assoc :revision rev-0))
+ (is (string=
+ (d:uri
+ (first
+ (d:item-identifiers
+ (first (d:in-topicmaps instanceOf-assoc :revision rev-0))
+ :revision rev-0)))
+ "http://www.isidor.us/unittests/testtm"))
+ (is-false (d:item-identifiers instanceOf-assoc :revision rev-0))
(let ((super-type-role
- (loop for role in (roles instanceOf-assoc)
- when (string= (uri (first (psis (instance-of role))))
- constants:*type-psi*)
+ (loop for role in (roles instanceOf-assoc :revision rev-0)
+ when (string=
+ (uri (first (psis (instance-of role :revision rev-0)
+ :revision rev-0)))
+ constants:*type-psi*)
return role))
(sub-type-role
- (loop for role in (roles instanceOf-assoc)
- when (string= (uri (first (psis (instance-of role))))
+ (loop for role in (roles instanceOf-assoc :revision rev-0)
+ when (string= (uri (first (psis (instance-of role :revision rev-0)
+ :revision rev-0)))
constants:*instance-psi*)
return role)))
(is-true (and super-type-role sub-type-role))
- (is (string= (uri (first (psis (player super-type-role))))
+ (is (string= (uri (first (psis (player super-type-role :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/types/standard"))
- (is (string= (uri (first (psis (player sub-type-role))))
+ (is (string= (uri (first (psis (player sub-type-role :revision rev-0)
+ :revision rev-0)))
"http://psi.egovpt.org/standard/Common+Lisp")))))))
(test test-get-all-topic-psis
- (let
- ((dir "data_base"))
+ (let ((dir "data_base")
+ (rev-0 0))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
- *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*)
-
+ *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm"
+ :xtm-id *TEST-TM*)
(elephant:open-store (xml-importer:get-store-spec dir))
- (let ((json-psis (json:decode-json-from-string (get-all-topic-psis))))
- (is (= (length json-psis) (length (elephant:get-instances-by-class 'd:TopicC))))
+ (let ((json-psis
+ (json:decode-json-from-string (get-all-topic-psis :revision rev-0))))
+ (is (= (length json-psis)
+ (length (elephant:get-instances-by-class 'd:TopicC))))
(loop for topic-psis in json-psis
do (cond
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#topic")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#topic")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#association")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#association")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#occurrence")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#occurrence")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#class-instance")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#class-instance")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#class")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#class")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype")
+ ((string=
+ (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#subtype")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#subtype")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#display")
+ ((string= (first topic-psis)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#display")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.topicmaps.org/iso13250/model/type-instance")
+ ((string= (first topic-psis)
+ "http://psi.topicmaps.org/iso13250/model/type-instance")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.topicmaps.org/iso13250/model/type")
+ ((string= (first topic-psis)
+ "http://psi.topicmaps.org/iso13250/model/type")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.topicmaps.org/iso13250/model/instance")
+ ((string= (first topic-psis)
+ "http://psi.topicmaps.org/iso13250/model/instance")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/topic-type")
+ ((string=
+ (first topic-psis)
+ "http://www.networkedplanet.com/psi/npcl/meta-types/topic-type")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/service")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/service")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/standard")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/standard")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/semanticstandard")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/semanticstandard")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/technicalstandard")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/technicalstandard")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/subject")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/subject")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/occurrence-type")
+ ((string=
+ (first topic-psis)
+ "http://www.networkedplanet.com/psi/npcl/meta-types/occurrence-type")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/association-type")
+ ((string=
+ (first topic-psis)
+ "http://www.networkedplanet.com/psi/npcl/meta-types/association-type")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/association-role-type")
+ ((string=
+ (first topic-psis)
+ "http://www.networkedplanet.com/psi/npcl/meta-types/association-role-type")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/topicInTaxonomy")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/topicInTaxonomy")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/long-name")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/long-name")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/standardHasStatus")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/standardHasStatus")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/status/InternationalStandard")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/status/InternationalStandard")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/description")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/description")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/standardValidFromDate")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/standardValidFromDate")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/links")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/links")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/topicIsAboutSubject")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/topicIsAboutSubject")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/isNarrowerSubject")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/isNarrowerSubject")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/narrowerSubject")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/narrowerSubject")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/broaderSubject")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/broaderSubject")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/standardIsAboutSubject")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/standardIsAboutSubject")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/SubjectRoleType")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/SubjectRoleType")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/StandardRoleType")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/StandardRoleType")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/ServiceRoleType")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/ServiceRoleType")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/types/serviceUsesStandard")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/types/serviceUsesStandard")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata")
+ ((string=
+ (first topic-psis)
+ "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/standard/Topic+Maps+2002")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/standard/Topic+Maps+2002")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/subject/Web+Services")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/subject/Web+Services")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/subject/Semantic+Description")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/subject/Semantic+Description")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/subject/Data")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/subject/Data")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/subject/GeoData")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/subject/GeoData")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/subject/Legal+Data")
+ ((string= (first topic-psis)
+ "http://psi.egovpt.org/subject/Legal+Data")
(is (= (length topic-psis) 1)))
- ((string= (first topic-psis) "http://psi.egovpt.org/service/Norwegian+National+Curriculum")
+ ((string=
+ (first topic-psis)
+ "http://psi.egovpt.org/service/Norwegian+National+Curriculum")
(is (= (length topic-psis) 1)))
- ((or (string= (first topic-psis) "http://psi.egovpt.org/service/Google+Maps")
- (string= (first topic-psis) "http://maps.google.com"))
+ ((or (string= (first topic-psis)
+ "http://psi.egovpt.org/service/Google+Maps")
+ (string= (first topic-psis)
+ "http://maps.google.com"))
(is (= (length topic-psis) 2))
- (is (or (string= (second topic-psis) "http://psi.egovpt.org/service/Google+Maps")
- (string= (second topic-psis) "http://maps.google.com"))))
+ (is (or (string= (second topic-psis)
+ "http://psi.egovpt.org/service/Google+Maps")
+ (string= (second topic-psis)
+ "http://maps.google.com"))))
(t
(is-true (format t "found bad topic-psis: ~a" topic-psis)))))))))
Modified: trunk/src/unit_tests/rdf_exporter_test.lisp
==============================================================================
--- trunk/src/unit_tests/rdf_exporter_test.lisp (original)
+++ trunk/src/unit_tests/rdf_exporter_test.lisp Sun Oct 10 05:41:19 2010
@@ -349,14 +349,14 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "28.08.1749"))))))
(died-id (concatenate
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "22.03.1832")))))))
(is-true (property-p me *sw-arc* "born" :nodeID born-id))
@@ -395,7 +395,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "31.12.1782")))))))
(is-true (property-p me *sw-arc* "dateRange"
@@ -423,7 +423,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "01.01.1772")))))))
(is-true (property-p me *sw-arc* "dateRange"
@@ -431,7 +431,7 @@
(test test-zauberlehrling
- "Tests the resoruce zauberlehrling."
+ "Tests the resource zauberlehrling."
(with-fixture rdf-exporter-test-db ()
(let ((zauberlehrlings (get-resources-by-uri
"http://some.where/poem/Der_Zauberlehrling")))
@@ -465,7 +465,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "01.01.1797")))))))
(is-true (property-p me *sw-arc* "dateRange"
@@ -600,7 +600,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value 'd:OccurrenceC
'd:charvalue
"28.08.1749")))))))
@@ -627,7 +627,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value 'd:OccurrenceC
'd:charvalue
"22.03.1832")))))))
@@ -654,7 +654,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value 'd:OccurrenceC
'd:charvalue
"01.01.1797")))))))
@@ -675,7 +675,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value 'd:OccurrenceC
'd:charvalue
"01.01.1782")))))))
@@ -696,7 +696,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value 'd:OccurrenceC
'd:charvalue
"01.01.1772")))))))
@@ -717,7 +717,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue
"http://de.wikipedia.org/wiki/Schiller")))))))
@@ -872,7 +872,7 @@
'string "id_"
(write-to-string
(elephant::oid
- (d:topic
+ (d:parent
(elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue
"http://de.wikipedia.org/wiki/Schiller")))))))
Modified: trunk/src/unit_tests/rdf_importer_test.lisp
==============================================================================
--- trunk/src/unit_tests/rdf_importer_test.lisp (original)
+++ trunk/src/unit_tests/rdf_importer_test.lisp Sun Oct 10 05:41:19 2010
@@ -1054,9 +1054,11 @@
:document-id document-id)
(is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20))
(let ((first-node (get-item-by-id "http://test-tm/first-node"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(first-type (get-item-by-id "http://test-tm/first-type"
- :xtm-id document-id)))
+ :xtm-id document-id
+ :revision 0)))
(is-true first-node)
(is (= (length (d::versions first-node)) 1))
(is (= (d::start-revision (first (d::versions first-node)))
@@ -1066,11 +1068,12 @@
(is (= (length (d:player-in-roles first-node)) 1))
(is (= (length (d:player-in-roles first-type)) 1))
(let ((instance-role
- (first (d:player-in-roles first-node)))
+ (first (d:player-in-roles first-node :revision 0)))
(type-role
- (first (d:player-in-roles first-type)))
+ (first (d:player-in-roles first-type :revision 0)))
(type-assoc
- (d:parent (first (d:player-in-roles first-node)))))
+ (d:parent (first (d:player-in-roles first-node :revision 0))
+ :revision 0)))
(is (= (length (d::versions type-assoc)) 1))
(is (= (d::start-revision (first (d::versions type-assoc)))
revision-2))
@@ -1080,7 +1083,7 @@
(d:get-item-by-psi *type-psi*)))
(is (eql (d:instance-of type-assoc)
(d:get-item-by-psi *type-instance-psi*)))
- (is (= (length (d:roles type-assoc)) 2))
+ (is (= (length (d:roles type-assoc :revision 0)) 2))
(is (= (length (d:psis first-node)) 1))
(is (= (length (d:psis first-type)) 1))
(is (string= (d:uri (first (d:psis first-node)))
@@ -1095,19 +1098,24 @@
tm-id revision-3
:document-id document-id))
(let ((first-node (get-item-by-id "http://test-tm/first-node"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(first-type (get-item-by-id "http://test-tm/first-type"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(second-node (get-item-by-id "second-node"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(second-type (get-item-by-id "http://test-tm/second-type"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(third-node (get-item-by-id "http://test-tm#third-node"
- :xtm-id document-id)))
+ :xtm-id document-id
+ :revision 0)))
(is-true second-node)
- (is-false (d:psis second-node))
- (is-false (d:occurrences second-node))
- (is-false (d:names second-node))
+ (is-false (d:psis second-node :revision 0))
+ (is-false (d:occurrences second-node :revision 0))
+ (is-false (d:names second-node :revision 0))
(is-true first-node)
(is (= (length (d::versions first-node)) 2))
(is-true (find-if #'(lambda(x)
@@ -1119,18 +1127,22 @@
(= (d::end-revision x) 0)))
(d::versions first-node)))
(let ((instance-role
- (first (d:player-in-roles first-node)))
+ (first (d:player-in-roles first-node :revision 0)))
(type-role
- (first (d:player-in-roles first-type)))
+ (first (d:player-in-roles first-type :revision 0)))
(type-assoc
- (d:parent (first (d:player-in-roles first-node))))
- (type-topic (get-item-by-psi *type-psi*))
- (instance-topic (get-item-by-psi *instance-psi*))
- (type-instance-topic (get-item-by-psi *type-instance-psi*))
- (supertype-topic (get-item-by-psi *supertype-psi*))
- (subtype-topic (get-item-by-psi *subtype-psi*))
+ (d:parent (first (d:player-in-roles first-node
+ :revision 0))))
+ (type-topic (get-item-by-psi *type-psi* :revision 0))
+ (instance-topic (get-item-by-psi *instance-psi* :revision 0))
+ (type-instance-topic (get-item-by-psi *type-instance-psi*
+ :revision 0))
+ (supertype-topic (get-item-by-psi *supertype-psi*
+ :revision 0))
+ (subtype-topic (get-item-by-psi *subtype-psi*
+ :revision 0))
(supertype-subtype-topic
- (get-item-by-psi *supertype-subtype-psi*))
+ (get-item-by-psi *supertype-subtype-psi* :revision 0))
(arc2-occurrence (elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "arc-2"))
(arc3-occurrence
@@ -1138,18 +1150,19 @@
'd:OccurrenceC 'd:charvalue
"<root><content type=\"anyContent\">content</content></root>"))
(fifth-node (d:get-item-by-id "http://test-tm#fifth-node"
- :xtm-id document-id)))
- (is (eql (d:instance-of instance-role)
- (d:get-item-by-psi *instance-psi*)))
- (is (eql (d:instance-of type-role)
- (d:get-item-by-psi *type-psi*)))
- (is (eql (d:instance-of type-assoc)
- (d:get-item-by-psi *type-instance-psi*)))
- (is (= (length (d:roles type-assoc)) 2))
- (is (= (length (d:psis first-node)) 1))
- (is (= (length (d:psis first-type)) 1))
- (is (= (length (d::versions type-assoc)) 1))
- (is (= (length (d:player-in-roles second-node)) 2))
+ :xtm-id document-id
+ :revision 0)))
+ (is (eql (d:instance-of instance-role :revision 0)
+ (d:get-item-by-psi *instance-psi* :revision 0)))
+ (is (eql (d:instance-of type-role :revision 0)
+ (d:get-item-by-psi *type-psi* :revision 0)))
+ (is (eql (d:instance-of type-assoc :revision 0)
+ (d:get-item-by-psi *type-instance-psi* :revision 0)))
+ (is (= (length (d:roles type-assoc :revision 0)) 2))
+ (is (= (length (d:psis first-node :revision 0)) 1))
+ (is (= (length (d:psis first-type :revision 0)) 1))
+ (is (= (length (d::versions type-assoc)) 2))
+ (is (= (length (d:player-in-roles second-node :revision 0)) 2))
(is-true (find-if
#'(lambda(x)
(and (eql (d:instance-of x) instance-topic)
@@ -1176,16 +1189,16 @@
(d:player-in-roles third-node)))
(is-true arc2-occurrence)
(is (string= (d:datatype arc2-occurrence) "http://test-tm/dt"))
- (is-false (d:psis (d:topic arc2-occurrence)))
- (is (= (length (d::versions (d:topic arc2-occurrence))) 1))
+ (is-false (d:psis (d:parent arc2-occurrence)))
+ (is (= (length (d::versions (d:parent arc2-occurrence))) 1))
(is (= (d::start-revision
- (first (d::versions (d:topic arc2-occurrence))))
+ (first (d::versions (d:parent arc2-occurrence))))
revision-3))
(is (= (d::end-revision
- (first (d::versions (d:topic arc2-occurrence)))) 0))
+ (first (d::versions (d:parent arc2-occurrence)))) 0))
(is-true arc3-occurrence)
- (is (= (length (d:psis (d:topic arc3-occurrence)))))
- (is (string= (d:uri (first (d:psis (d:topic arc3-occurrence))))
+ (is (= (length (d:psis (d:parent arc3-occurrence)))))
+ (is (string= (d:uri (first (d:psis (d:parent arc3-occurrence))))
"http://test-tm/fourth-node"))
(is (string= (d:datatype arc3-occurrence)
*xml-string*))
@@ -1592,8 +1605,8 @@
(concatenate 'string arcs "firstName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
goethe)))
occs)
1))
@@ -1604,8 +1617,8 @@
(concatenate 'string arcs "lastName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
goethe)))
occs)
1))
@@ -1616,8 +1629,8 @@
(concatenate 'string arcs "fullName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
weimar)))
occs)
1))
@@ -1628,8 +1641,8 @@
(concatenate 'string arcs "fullName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
frankfurt)))
occs)
1))
@@ -1641,8 +1654,8 @@
(string= *xml-string* (d:datatype x))
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
germany)))
occs)
1))
@@ -1655,8 +1668,8 @@
(string= (d:charvalue x) "Der Zauberlehrling")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
zauberlehrling)))
occs)
1))
@@ -1668,8 +1681,8 @@
(= 0 (length (d:themes x)))
(string= (d:charvalue x) "Prometheus")
(string= *xml-string* (d:datatype x))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
prometheus)))
occs)
1))
@@ -1682,8 +1695,8 @@
(string= (d:charvalue x) "Der Erlkönig")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
erlkoenig)))
occs)
1))
@@ -1696,8 +1709,8 @@
(string= (d:charvalue x) "Hat der alte Hexenmeister ...")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
zauberlehrling)))
occs)
1))
@@ -1711,8 +1724,8 @@
" Bedecke deinen Himmel, Zeus, ... ")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
prometheus)))
occs)
1))
@@ -1726,8 +1739,8 @@
"Wer reitet so spät durch Nacht und Wind? ...")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
erlkoenig)))
occs)
1))
@@ -1738,8 +1751,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
weimar)))
occs)
1))
@@ -1750,8 +1763,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
frankfurt)))
occs)
1))
@@ -1762,8 +1775,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
berlin)))
occs)
1))
@@ -1774,8 +1787,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
germany)))
occs)
1))
@@ -1786,7 +1799,7 @@
(concatenate 'string arcs "date"))
(string= date (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
2))
(is (= (count-if
@@ -1797,7 +1810,7 @@
(string= date (d:datatype x))
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
1))
@@ -1808,7 +1821,7 @@
(concatenate 'string arcs "start"))
(string= date (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
2))
@@ -1820,7 +1833,7 @@
(string= date (d:datatype x))
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
1))
(is (= (count-if
@@ -1830,7 +1843,7 @@
(concatenate 'string arcs "end"))
(string= date (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
2)))))
@@ -2937,16 +2950,18 @@
(is-true marge-ln)
(is (string= (d:charvalue marge-fn) "Marjorie"))
(is (string= (d:charvalue marge-ln) "Simpson"))
- (is (= (length (d:variants marge-fn)) 1))
- (is (= (length (d:themes (first (d:variants marge-fn)))) 1))
- (is (eql (first (d:themes (first (d:variants marge-fn)))) display))
- (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge"))
- (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*))
+ (is (= (length (d:variants marge-fn :revision 0)) 1))
+ (is (= (length (d:themes (first (d:variants marge-fn :revision 0))
+ :revision 0)) 1))
+ (is (eql (first (d:themes (first (d:variants marge-fn :revision 0))
+ :revision 0)) display))
+ (is (string= (d:charvalue (first (d:variants marge-fn :revision 0))) "Marge"))
+ (is (string= (d:datatype (first (d:variants marge-fn :revision 0))) *xml-string*))
(is-true marge-occ)
(is (string= (d:charvalue marge-occ) "Housewife"))
(is (string= (d:datatype marge-occ) *xml-string*))
- (is (= (length (d:themes marge-occ)) 0))
- (is (= (length (d:psis marge)) 2))))))
+ (is (= (length (d:themes marge-occ :revision 0)) 0))
+ (is (= (length (d:psis marge :revision 0)) 2))))))
(test test-full-mapping-homer
Modified: trunk/src/unit_tests/reification_test.lisp
==============================================================================
--- trunk/src/unit_tests/reification_test.lisp (original)
+++ trunk/src/unit_tests/reification_test.lisp Sun Oct 10 05:41:19 2010
@@ -58,7 +58,7 @@
(test test-merge-reifier-topics
- "Tests the function merge-reifier-topics."
+ "Tests the function merge-constructs."
(let ((db-dir "data_base")
(revision-1 100)
(revision-2 200))
@@ -147,7 +147,7 @@
:start-revision revision-1)))
(let ((name-1-1 (make-construct 'NameC
:item-identifiers nil
- :topic topic-1
+ :parent topic-1
:themes (list scope-1)
:instance-of name-type
:charvalue "name-1-1"
@@ -156,7 +156,7 @@
:item-identifiers (list (make-instance 'ItemIdentifierC
:uri "name-2-1-ii-1"
:start-revision revision-1))
- :topic topic-2
+ :parent topic-2
:themes (list scope-2)
:instance-of nil
:charvalue "name-2-1"
@@ -165,7 +165,7 @@
:item-identifiers (list (make-instance 'ItemIdentifierC
:uri "occurrence-1-1-ii-1"
:start-revision revision-1))
- :topic topic-2
+ :parent topic-2
:themes (list scope-1 scope-2)
:instance-of occurrence-type
:charvalue "occurrence-2-1"
@@ -173,7 +173,7 @@
:start-revision revision-2))
(occurrence-2-2 (make-construct 'OccurrenceC
:item-identifiers nil
- :topic topic-2
+ :parent topic-2
:themes nil
:instance-of occurrence-type
:charvalue "occurrence-2-2"
@@ -181,7 +181,7 @@
:start-revision revision-2))
(test-name (make-construct 'NameC
:item-identifiers nil
- :topic scope-2
+ :parent scope-2
:themes (list scope-1 topic-2)
:instance-of topic-2
:charvalue "test-name"
@@ -194,19 +194,21 @@
(list
(list :instance-of role-type
:player topic-1
+ :start-revision revision-2
:item-identifiers
(list (make-instance 'ItemIdentifierC
:uri "role-1"
- :start-revision revision-1)))
+ :start-revision revision-2)))
(list :instance-of role-type
:player topic-2
+ :start-revision revision-2
:item-identifiers
(list (make-instance 'ItemIdentifierC
:uri "role-2"
- :start-revision revision-1))))
- :start-revision revision-1)))
+ :start-revision revision-2))))
+ :start-revision revision-2)))
(is (= (length (elephant:get-instances-by-class 'TopicC)) 8))
- (datamodel::merge-reifier-topics topic-1 topic-2)
+ (d::merge-constructs topic-1 topic-2 :revision revision-2)
(is (= (length (elephant:get-instances-by-class 'TopicC)) 7))
(is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2)
(item-identifiers topic-1)))
@@ -220,7 +222,7 @@
(is (= (length (union (names topic-1)
(list name-1-1 name-2-1)))
(length (list name-1-1 name-2-1))))
- (is (= (length (union (occurrences topic-1)
+ (is (= (length (union (occurrences topic-1 :revision 0)
(list occurrence-2-1 occurrence-2-2)))
(length (list occurrence-2-1 occurrence-2-2))))
(is (= (length (union (d:used-as-type topic-1)
@@ -229,9 +231,9 @@
(is (= (length (union (d:used-as-theme topic-1)
(list test-name)))
(length (list test-name))))
- (is (eql (player (first (roles assoc))) topic-1))
- (is (eql (player (second (roles assoc))) topic-1))
- ;;TODO: check all objects and their version-infos
+ (is (= (length (roles assoc :revision 0)) 1))
+ (is (= (length (d::slot-p assoc 'd::roles)) 2))
+ (is (eql (player (first (roles assoc :revision 0)) :revision 0) topic-1))
(elephant:close-store))))))
@@ -282,21 +284,21 @@
(is-true reifier-married-assoc)
(is-true reifier-husband-role)
(is (eql (reifier homer-occurrence) reifier-occurrence))
- (is (eql (reified reifier-occurrence) homer-occurrence))
+ (is (eql (reified-construct reifier-occurrence) homer-occurrence))
(is (eql (reifier homer-name) reifier-name))
- (is (eql (reified reifier-name) homer-name))
+ (is (eql (reified-construct reifier-name) homer-name))
(is (eql (reifier homer-variant) reifier-variant))
- (is (eql (reified reifier-variant) homer-variant))
+ (is (eql (reified-construct reifier-variant) homer-variant))
(is (eql (reifier married-assoc) reifier-married-assoc))
- (is (eql (reified reifier-married-assoc) married-assoc))
+ (is (eql (reified-construct reifier-married-assoc) married-assoc))
(is (eql (reifier husband-role) reifier-husband-role))
- (is (eql (reified reifier-husband-role) husband-role))
+ (is (eql (reified-construct reifier-husband-role) husband-role))
(is-true (handler-case
(progn (d::delete-construct homer-occurrence)
t)
(condition () nil)))
(is-false (occurrences homer))
- (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12))
(elephant:close-store))))))
@@ -346,21 +348,21 @@
(is-true reifier-married-assoc)
(is-true reifier-husband-role)
(is (eql (reifier homer-occurrence) reifier-occurrence))
- (is (eql (reified reifier-occurrence) homer-occurrence))
+ (is (eql (reified-construct reifier-occurrence) homer-occurrence))
(is (eql (reifier homer-name) reifier-name))
- (is (eql (reified reifier-name) homer-name))
+ (is (eql (reified-construct reifier-name) homer-name))
(is (eql (reifier homer-variant) reifier-variant))
- (is (eql (reified reifier-variant) homer-variant))
+ (is (eql (reified-construct reifier-variant) homer-variant))
(is (eql (reifier married-assoc) reifier-married-assoc))
- (is (eql (reified reifier-married-assoc) married-assoc))
+ (is (eql (reified-construct reifier-married-assoc) married-assoc))
(is (eql (reifier husband-role) reifier-husband-role))
- (is (eql (reified reifier-husband-role) husband-role))
+ (is (eql (reified-construct reifier-husband-role) husband-role))
(is-true (handler-case
(progn (d::delete-construct homer-occurrence)
t)
(condition () nil)))
(is-false (occurrences homer))
- (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12))
(elephant:close-store))))))
@@ -621,9 +623,9 @@
"http://test/arcs/arc4"))
(is (= (length (d:used-as-type arc1)) 1))
(is (eql (reifier (first (d:used-as-type arc1))) reification-1))
- (is (eql (reified reification-1) (first (d:used-as-type arc1))))
+ (is (eql (reified-construct reification-1) (first (d:used-as-type arc1))))
(is (eql (reifier (first (d:used-as-type arc3))) reification-2))
- (is (eql (reified reification-2) (first (d:used-as-type arc3))))))))
+ (is (eql (reified-construct reification-2) (first (d:used-as-type arc3))))))))
(elephant:close-store))
@@ -647,13 +649,13 @@
(is-true married)
(is (= (length (used-as-type married)) 1))
(is-true (reifier (first (used-as-type married))))
- (is-true (reified (reifier (first (used-as-type married)))))
+ (is-true (reified-construct (reifier (first (used-as-type married)))))
(is (= (length (psis (reifier (first (used-as-type married))))) 1))
(is (string= (uri (first (psis (reifier (first (used-as-type married))))))
"http://test-tm#married-arc"))
(is (= (length (occurrences bart)) 1))
(is-true (reifier (first (occurrences bart))))
- (is-true (reified (reifier (first (occurrences bart)))))
+ (is-true (reified-construct (reifier (first (occurrences bart)))))
(is (string= (uri (first (psis (reifier (first (occurrences bart))))))
"http://test-tm#lastName-arc"))))
(elephant:close-store))
@@ -680,17 +682,17 @@
(is (= (length (variants name)) 1))
(let ((variant (first (variants name))))
(is-true (reifier name))
- (is-true (reified (reifier name)))
+ (is-true (reified-construct (reifier name)))
(is (= (length (psis (reifier name))) 1))
(is (string= (uri (first (psis (reifier name))))
(concatenate 'string tm-id "lisa-name")))
(is-true (reifier variant))
- (is-true (reified (reifier variant)))
+ (is-true (reified-construct (reifier variant)))
(is (= (length (psis (reifier variant))) 1))
(is (string= (uri (first (psis (reifier variant))))
(concatenate 'string tm-id "lisa-name-variant")))
(is-true (reifier occurrence))
- (is-true (reified (reifier occurrence)))
+ (is-true (reified-construct (reifier occurrence)))
(is (= (length (psis (reifier occurrence))) 1))
(is (string= (uri (first (psis (reifier occurrence))))
(concatenate 'string tm-id "lisa-occurrence")))))))
@@ -717,7 +719,7 @@
(is (typep (first (used-as-type friendship)) 'd:AssociationC))
(let ((friendship-association (first (used-as-type friendship))))
(is-true (reifier friendship-association))
- (is-true (reified (reifier friendship-association)))
+ (is-true (reified-construct (reifier friendship-association)))
(is (= (length (psis (reifier friendship-association))) 1))
(is (string= (uri (first (psis (reifier friendship-association))))
(concatenate 'string tm-id "friendship-association")))
@@ -728,7 +730,7 @@
(roles friendship-association))))
(is-true carl-role)
(is-true (reifier carl-role))
- (is-true (reified (reifier carl-role)))
+ (is-true (reified-construct (reifier carl-role)))
(is (= (length (psis (reifier carl-role))) 1))
(is (string= (uri (first (psis (reifier carl-role))))
(concatenate 'string tm-id "friend-role")))))))
Modified: trunk/src/unit_tests/versions_test.lisp
==============================================================================
--- trunk/src/unit_tests/versions_test.lisp (original)
+++ trunk/src/unit_tests/versions_test.lisp Sun Oct 10 05:41:19 2010
@@ -28,6 +28,7 @@
:test-get-item-by-id-t301
:test-get-item-by-id-common-lisp
:test-mark-as-deleted
+ :test-instance-of-t64
:test-norwegian-curriculum-association
:test-change-lists
:test-changed-p
@@ -43,327 +44,327 @@
(in-suite versions-test)
(test test-get-item-by-id-t100 ()
- "test certain characteristics of
-http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata
-of which two revisions are created, the original one and then one during the
-merge with *XTM-MERGE1*"
- (with-fixture merge-test-db ()
-
- (let
- ((top-t100-current (get-item-by-id "t100" :xtm-id *TEST-TM*))
- (top-t100-first (get-item-by-id "t100" :xtm-id *TEST-TM* :revision fixtures::revision1))
- (top-t100-second (get-item-by-id "t100" :xtm-id *TEST-TM* :revision fixtures::revision2))
- (link-topic (get-item-by-id "t55" :xtm-id *TEST-TM* :revision fixtures::revision2)))
-
- (is (eq top-t100-current top-t100-second))
- (is (eq top-t100-current top-t100-first))
-
- (is (= 2 (length (names top-t100-current))))
- (with-revision fixtures::revision1
- (is (= 1 (length (names top-t100-first)))))
- (is (string= (charvalue (first (names top-t100-first)))
- "ISO 19115"))
- (with-revision fixtures::revision2
- (is (= 2 (length (names top-t100-second))))
- (is (= 5 (length (occurrences top-t100-second))))
- (is (eq link-topic (get-item-by-id "t50" :xtm-id "merge1"))) ;the topic with t55 in notificationbase has the id t50 in merge1
- (is (eq link-topic (instance-of (fifth (occurrences top-t100-second))))))
-
- (is (string= (charvalue (first (names top-t100-second)))
- "ISO 19115"))
- (is (string= (charvalue (second (names top-t100-second)))
- "Geo Data"))
-
- (is (= 5 (length (occurrences top-t100-current))))
- (is (= 2 (length (item-identifiers top-t100-current))))
-
- (with-revision fixtures::revision1
- (is (= 4 (length (occurrences top-t100-first))))
- (is (= 1 (length (item-identifiers top-t100-first)))))
+ "test certain characteristics of
+ http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata
+ of which two revisions are created, the original one and then one during the
+ merge with *XTM-MERGE1*"
+ (with-fixture merge-test-db ()
+ (let
+ ((top-t100-current (get-item-by-id "t100" :xtm-id *TEST-TM*))
+ (top-t100-first (get-item-by-id "t100" :xtm-id *TEST-TM*
+ :revision fixtures::revision1))
+ (top-t100-second (get-item-by-id "t100" :xtm-id *TEST-TM*
+ :revision fixtures::revision2))
+ (link-topic (get-item-by-id "t55" :xtm-id *TEST-TM*
+ :revision fixtures::revision2)))
+ (is (eq top-t100-current top-t100-second))
+ (is (eq top-t100-current top-t100-first))
+ (is (= 2 (length (names top-t100-current))))
+ (with-revision fixtures::revision1
+ (is (= 1 (length (names top-t100-first)))))
+ (is (string= (charvalue (first (names top-t100-first)))
+ "ISO 19115"))
+ (with-revision fixtures::revision2
+ (is (= 2 (length (names top-t100-second))))
+ (is (= 5 (length (occurrences top-t100-second))))
+ (is (eq link-topic (get-item-by-id "t50" :xtm-id "merge1"))) ;the topic with t55 in notificationbase has the id t50 in merge1
+ (is (eq link-topic (instance-of (fifth (occurrences top-t100-second))))))
+ (is (string= (charvalue (first (names top-t100-second)))
+ "ISO 19115"))
+ (is (string= (charvalue (second (names top-t100-second)))
+ "Geo Data"))
+ (is (= 5 (length (occurrences top-t100-current))))
+ (is (= 2 (length (item-identifiers top-t100-current))))
+ (with-revision fixtures::revision1
+ (is (= 4 (length (occurrences top-t100-first))))
+ (is (= 1 (length (item-identifiers top-t100-first)))))
+ (is (= 2 (length (elephant:get-instances-by-class 'd:TopicMapC)))))))
- (is (= 2 (length (elephant:get-instances-by-class 'd:TopicMapC)))))))
(test test-get-item-by-id-t301 ()
- "test characteristics of http://psi.egovpt.org/service/Google+Maps which
-occurs twice in notificationbase.xtm but is not subsequently revised"
- (with-fixture merge-test-db ()
- (let
- ((top-t301-current (get-item-by-id "t301" :xtm-id *TEST-TM*))
- (top-t301-first (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision1))
- (top-t301-second (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision2)))
+ "test characteristics of http://psi.egovpt.org/service/Google+Maps which
+ occurs twice in notificationbase.xtm but is not subsequently revised"
+ (with-fixture merge-test-db ()
+ (let
+ ((top-t301-current (get-item-by-id "t301" :xtm-id *TEST-TM*))
+ (top-t301-first (get-item-by-id "t301a" :xtm-id *TEST-TM*
+ :revision fixtures::revision1))
+ (top-t301-second (get-item-by-id "t301a" :xtm-id *TEST-TM*
+ :revision fixtures::revision2)))
+ (is (eq top-t301-current top-t301-first))
+ (is (eq top-t301-current top-t301-second)))))
- (is (eq top-t301-current top-t301-first))
- (is (eq top-t301-current top-t301-second)))))
(test test-get-item-by-id-common-lisp ()
- "Get the http://psi.egovpt.org/standard/Common+Lisp topic that was first
-introduced in merge1 and then modified in merge2"
- (with-fixture merge-test-db ()
- (let
- ((top-cl-current (get-item-by-id "t100" :xtm-id "merge2"))
- (top-cl-first (get-item-by-id "t100" :xtm-id "merge2" :revision fixtures::revision1))
- (top-cl-second (get-item-by-id "t100" :xtm-id "merge2" :revision fixtures::revision2)))
- (is-false top-cl-first) ;did not yet exist then and should thus be nil
- (is (eq top-cl-second top-cl-current))
- (is (= 1 (length (names top-cl-current))))
- (with-revision fixtures::revision2
- (is (= 1 (length (item-identifiers top-cl-second)))))
- (is (= 2 (length (item-identifiers top-cl-current))))
- (with-revision fixtures::revision2
- (is (= 1 (length (occurrences top-cl-second)))))
- (is (= 2 (length (occurrences top-cl-current)))))))
+ "Get the http://psi.egovpt.org/standard/Common+Lisp topic that was first
+ introduced in merge1 and then modified in merge2"
+ (with-fixture merge-test-db ()
+ (let
+ ((top-cl-current (get-item-by-id "t100" :xtm-id "merge2"
+ :revision fixtures::revision3))
+ (top-cl-first (get-item-by-id "t100" :xtm-id "merge2"
+ :revision fixtures::revision1))
+ (top-cl-second (get-item-by-id "t100" :xtm-id "merge1"
+ :revision fixtures::revision2)))
+ (is-false top-cl-first)
+ (is (eq top-cl-second top-cl-current))
+ (is (= 1 (length (names top-cl-current))))
+ (with-revision fixtures::revision2
+ (is (= 1 (length (item-identifiers top-cl-second)))))
+ (is (= 2 (length (item-identifiers top-cl-current))))
+ (with-revision fixtures::revision2
+ (is (= 1 (length (occurrences top-cl-second)))))
+ (is (= 2 (length (occurrences top-cl-current)))))))
-;; tests for: - history of roles and associations
-;; - get list of all revisions
-;; - get changes
-
(test test-norwegian-curriculum-association ()
- "Check the various incarnations of the norwegian curriculum
-associations across its revisions"
- (with-fixture merge-test-db ()
- (let*
- ((norwegian-curr-topic
- (get-item-by-id "t300" :xtm-id *TEST-TM*))
-
- (curriculum-assoc ;this is the only "true" association in which the
- ;Norwegian Curriculum is a player in revision1
- (parent
- (second ;the first one is the instanceOf association
- (player-in-roles
- norwegian-curr-topic))))
- (scoped-curriculum-assoc ;this one is added in revision3
- (parent
- (third
- (player-in-roles
- norwegian-curr-topic))))
- (semantic-standard-topic
- (get-item-by-id "t3a" :xtm-id *TEST-TM*)))
- (is (string= "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
- (uri (first (psis norwegian-curr-topic)))))
- (is (= 1 (length (item-identifiers curriculum-assoc))))
- (is (= 3 (length (psis semantic-standard-topic))))
-
- (with-revision fixtures::revision1
- ;one explicit association and the association resulting
- ;from instanceOf
- (is (= 2 (length (player-in-roles norwegian-curr-topic))))
- (is-false (item-identifiers curriculum-assoc))
- (is-false (used-as-theme semantic-standard-topic))
- )
- (with-revision fixtures::revision2
- ;one explicit association and the association resulting
- ;from instanceOf
- (is (= 2 (length (player-in-roles norwegian-curr-topic))))
- (is (= 1 (length (item-identifiers curriculum-assoc))))
- (is (= 1 (length (item-identifiers (first (roles curriculum-assoc))))))
- (is (= 2 (length (item-identifiers (second (roles curriculum-assoc))))))
- (is-false (used-as-theme semantic-standard-topic)))
-
- (with-revision fixtures::revision3
- ;two explicit associations and the association resulting
- ;from instanceOf
- (is (= 3 (length (player-in-roles norwegian-curr-topic))))
- (is (= 1 (length (item-identifiers curriculum-assoc))))
- (is (eq semantic-standard-topic (first (themes scoped-curriculum-assoc))))
- (is (= 1 (length (used-as-theme semantic-standard-topic))))
- (is (= 1 (length (item-identifiers (first (roles curriculum-assoc))))))
- (is (= 3 (length (item-identifiers (second (roles curriculum-assoc))))))))))
+ "Check the various incarnations of the norwegian curriculum
+ associations across its revisions"
+ (with-fixture merge-test-db ()
+ (let*
+ ((norwegian-curr-topic
+ (get-item-by-id "t300" :xtm-id *TEST-TM* :revision fixtures::revision3))
+
+ (curriculum-assoc ;this is the only "true" association in which the
+ ;Norwegian Curriculum is a player in revision1
+ (parent
+ (second ;the first one is the instanceOf association
+ (player-in-roles
+ norwegian-curr-topic :revision fixtures::revision3))
+ :revision fixtures::revision3))
+ (scoped-curriculum-assoc ;this one is added in revision3
+ (parent
+ (third
+ (player-in-roles
+ norwegian-curr-topic :revision fixtures::revision3))
+ :revision fixtures::revision3))
+ (semantic-standard-topic
+ (get-item-by-id "t3a" :xtm-id *TEST-TM* :revision fixtures::revision3)))
+ (is (string= "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
+ (uri (first (psis norwegian-curr-topic
+ :revision fixtures::revision3)))))
+ (is (= 1 (length (item-identifiers curriculum-assoc
+ :revision fixtures::revision3))))
+ (is (= 3 (length (psis semantic-standard-topic
+ :revision fixtures::revision3))))
+ (with-revision fixtures::revision1
+ ;one explicit association and the association resulting
+ ;from instanceOf
+ (is (= 2 (length (player-in-roles norwegian-curr-topic))))
+ (is-false (item-identifiers curriculum-assoc))
+ (is-false (used-as-theme semantic-standard-topic)))
+ (with-revision fixtures::revision2
+ ;one explicit association and the association resulting
+ ;from instanceOf
+ (is (= 2 (length (player-in-roles norwegian-curr-topic))))
+ (is (= 1 (length (item-identifiers curriculum-assoc))))
+ (is (= 1 (length (item-identifiers (first (roles curriculum-assoc))))))
+ (is (= 2 (length (item-identifiers (second (roles curriculum-assoc))))))
+ (is-false (used-as-theme semantic-standard-topic)))
+ (with-revision fixtures::revision3
+ ;two explicit associations and the association resulting
+ ;from instanceOf
+ (is (= 3 (length (player-in-roles norwegian-curr-topic))))
+ (is (= 1 (length (item-identifiers curriculum-assoc))))
+ (is (eq semantic-standard-topic (first (themes scoped-curriculum-assoc))))
+ (is (= 1 (length (used-as-theme semantic-standard-topic))))
+ (is (= 1 (length (item-identifiers (first (roles curriculum-assoc))))))
+ (is (= 3 (length (item-identifiers (second (roles curriculum-assoc))))))))))
(test test-instance-of-t64 ()
- "Check if all instances of t64 are properly registered."
- (with-fixture merge-test-db ()
- (let
- ((t63 (get-item-by-id "t63" :xtm-id *TEST-TM*))
- (t64 (get-item-by-id "t64" :xtm-id *TEST-TM*))
- (t300 (get-item-by-id "t300" :xtm-id *TEST-TM*)))
- (with-revision fixtures::revision1
- (let
- ((assocs (used-as-type t64)))
- (is (= 2 (length assocs)))
- (is (= (internal-id t63)
- (internal-id (instance-of (first (roles (first assocs)))))))
- (is (= (internal-id t300)
- (internal-id (player (first (roles (first assocs)))))))))
- (with-revision fixtures::revision2
- (let
- ((assocs (used-as-type t64)))
- (is (= 2 (length assocs)))))
- (with-revision fixtures::revision3
- (let
- ((assocs (used-as-type t64)))
- (is (= 3 (length assocs))))))))
+ "Check if all instances of t64 are properly registered."
+ (with-fixture merge-test-db ()
+ (let ((t63 (get-item-by-id "t63" :xtm-id *TEST-TM*
+ :revision fixtures::revision3))
+ (t64 (get-item-by-id "t64" :xtm-id *TEST-TM*
+ :revision fixtures::revision3))
+ (t300 (get-item-by-id "t300" :xtm-id *TEST-TM*
+ :revision fixtures::revision3)))
+ (with-revision fixtures::revision1
+ (let ((assocs (used-as-type t64)))
+ (is (= 2 (length assocs)))
+ (is (= (d::internal-id t63)
+ (d::internal-id (instance-of (first (roles (first assocs)))))))
+ (is (= (d::internal-id t300)
+ (d::internal-id (player (first (roles (first assocs)))))))))
+ (with-revision fixtures::revision2
+ (let ((assocs (used-as-type t64)))
+ (is (= 2 (length assocs)))))
+ (with-revision fixtures::revision3
+ (let ((assocs (used-as-type t64)))
+ (is (= 3 (length assocs))))))))
+
(test test-change-lists ()
- "Check various properties of changes applied to Isidor in this
-test suite"
- (with-fixture merge-test-db ()
- (let
- ((all-revision-set (get-all-revisions))
- (fragments-revision2
- (get-fragments fixtures::revision2))
- (fragments-revision3
- (get-fragments fixtures::revision3)))
- (is (= 3 (length all-revision-set)))
- (is (= fixtures::revision1 (first all-revision-set)))
- (is (= fixtures::revision2 (second all-revision-set)))
- (is (= fixtures::revision3 (third all-revision-set)))
-
- ;topics changed in revision2 / merge1: topic type, service,
- ;standard, semantic standard, standardHasStatus, geo data
- ;standard, common lisp, norwegian curriculum
- (is (= 8 (length fragments-revision2)))
-
- ;topics changed in revision3 / merge2: semantic standard, norwegian curriculum, common lisp
- (is (= 3 (length fragments-revision3)))
- (is (= fixtures::revision3
- (revision (first fragments-revision3))))
- (is (string=
- "http://psi.egovpt.org/types/semanticstandard"
- (uri (first (psis (topic (first fragments-revision3)))))))
-
- (format t "semantic-standard: ~a~&"
- (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3))))
- :test #'string=))
- (is-false
- (set-exclusive-or
- '("http://psi.egovpt.org/types/standard")
- (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3))))
- :test #'string=)
- :test #'string=))
- ; 0 if we ignore instanceOf associations
- (is (= 0 (length (associations (first fragments-revision3)))))
-
- (is (string=
- "http://psi.egovpt.org/standard/Common+Lisp"
- (uri (first (psis (topic (third fragments-revision3)))))))
- (is-false
- (set-exclusive-or
- '("http://psi.egovpt.org/types/standard"
- "http://psi.egovpt.org/types/links";)
- "http://www.topicmaps.org/xtm/1.0/core.xtm#sort"
- "http://www.topicmaps.org/xtm/1.0/core.xtm#display"
- "http://psi.egovpt.org/types/long-name")
- (remove-duplicates
- (map 'list
- #'uri
- (mapcan #'psis (referenced-topics (third fragments-revision3))))
- :test #'string=)
- :test #'string=))
- ;0 if we ignore instanceOf associations
- (is (= 0 (length (associations (third fragments-revision3)))))
-
- (is (string=
- "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
- (uri (first (psis (topic (second fragments-revision3)))))))
- (is-false
- (set-exclusive-or
- '("http://psi.egovpt.org/types/service"
- "http://psi.egovpt.org/types/description"
- "http://psi.egovpt.org/types/links"
- "http://psi.egovpt.org/types/serviceUsesStandard"
- "http://psi.egovpt.org/types/StandardRoleType"
- "http://psi.egovpt.org/standard/Topic+Maps+2002"
- "http://psi.egovpt.org/types/ServiceRoleType"
- "http://psi.egovpt.org/types/semanticstandard" ;these three PSIS all stand for the same topic
- "http://psi.egovpt.org/types/greatstandard"
- "http://psi.egovpt.org/types/knowledgestandard")
- (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (second fragments-revision3))))
- :test #'string=)
- :test #'string=))
- ;the second time round the object should be fetched from the
- ;cache
- (is (equal fragments-revision3
- (get-fragments fixtures::revision3)))
- )))
+ "Check various properties of changes applied to Isidor in this
+ test suite"
+ (with-fixture merge-test-db ()
+ (let ((all-revision-set (get-all-revisions))
+ (fragments-revision2
+ (get-fragments fixtures::revision2))
+ (fragments-revision3
+ (get-fragments fixtures::revision3)))
+ (is (= 3 (length all-revision-set)))
+ (is (= fixtures::revision1 (first all-revision-set)))
+ (is (= fixtures::revision2 (second all-revision-set)))
+ (is (= fixtures::revision3 (third all-revision-set)))
+ ;topics changed in revision2 / merge1: topic type, service,
+ ;standard, semantic standard, standardHasStatus, geo data
+ ;standard, common lisp, norwegian curriculum
+ (is (= 8 (length fragments-revision2)))
+ ;topics changed in revision3 / merge2: semantic standard,
+ ;norwegian curriculum, common lisp
+ (is (= 3 (length fragments-revision3)))
+ (is (= fixtures::revision3
+ (revision (first fragments-revision3))))
+ (is (string=
+ "http://psi.egovpt.org/types/semanticstandard"
+ (uri (first (psis (topic (first fragments-revision3)))))))
+ (format t "semantic-standard: ~a~&"
+ (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3))))
+ :test #'string=))
+ (is-false
+ (set-exclusive-or
+ '("http://psi.egovpt.org/types/standard")
+ (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3))))
+ :test #'string=)
+ :test #'string=))
+ ;0 if we ignore instanceOf associations
+ (is (= 0 (length (associations (first fragments-revision3)))))
+ (is (string= "http://psi.egovpt.org/standard/Common+Lisp"
+ (uri (first (psis (topic (third fragments-revision3)))))))
+ (is-false
+ (set-exclusive-or
+ '("http://psi.egovpt.org/types/standard"
+ "http://psi.egovpt.org/types/links";)
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#sort"
+ "http://www.topicmaps.org/xtm/1.0/core.xtm#display"
+ "http://psi.egovpt.org/types/long-name")
+ (remove-duplicates
+ (map 'list
+ #'uri
+ (mapcan #'psis (referenced-topics (third fragments-revision3))))
+ :test #'string=)
+ :test #'string=))
+ ;0 if we ignore instanceOf associations
+ (is (= 0 (length (associations (third fragments-revision3)))))
+ (is (string=
+ "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
+ (uri (first (psis (topic (second fragments-revision3)))))))
+ (is-false
+ (set-exclusive-or
+ '("http://psi.egovpt.org/types/service"
+ "http://psi.egovpt.org/types/description"
+ "http://psi.egovpt.org/types/links"
+ "http://psi.egovpt.org/types/serviceUsesStandard"
+ "http://psi.egovpt.org/types/StandardRoleType"
+ "http://psi.egovpt.org/standard/Topic+Maps+2002"
+ "http://psi.egovpt.org/types/ServiceRoleType"
+ ;these three PSIS all stand for the same topic
+ "http://psi.egovpt.org/types/semanticstandard"
+ "http://psi.egovpt.org/types/greatstandard"
+ "http://psi.egovpt.org/types/knowledgestandard")
+ (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (second fragments-revision3))))
+ :test #'string=)
+ :test #'string=))
+ ;the second time round the object should be fetched from the
+ ;cache
+ (is (equal fragments-revision3
+ (get-fragments fixtures::revision3))))))
+
(test test-changed-p ()
- "Check the is-changed mechanism"
- (with-fixture merge-test-db ()
- (let*
- ((service-topic ;changed in merge1
- (get-item-by-id "t2" :xtm-id *TEST-TM*))
- (service-name ;does not change after creation
- (first (names service-topic)))
- (google-maps-topic ;does not change after creation
- (get-item-by-id "t301a" :xtm-id *TEST-TM*))
- (norwegian-curr-topic ;changes in merge1 (only through
+ "Check the is-changed mechanism"
+ (with-fixture merge-test-db ()
+ (let*
+ ((service-topic ;changed in merge1
+ (get-item-by-id "t2" :xtm-id *TEST-TM* :revision fixtures::revision1))
+ (service-name ;does not change after creation
+ (first (names service-topic :revision fixtures::revision1)))
+ (google-maps-topic ;does not change after creation
+ (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision1))
+ (norwegian-curr-topic ;changes in merge1 (only through
;association) and merge2 (again through association)
- (get-item-by-id "t300" :xtm-id *TEST-TM*))
- (geodata-topic ;does not change after creation
- (get-item-by-id "t203" :xtm-id *TEST-TM*)) ;the subject "geodata", not the standard
- (semantic-standard-topic ;changes in merge1 and merge2
- (get-item-by-id "t3a" :xtm-id *TEST-TM*))
- (common-lisp-topic ;created in merge1 and changed in merge2
- (get-item-by-id "t100" :xtm-id "merge1"))
- (subject-geodata-assoc ;does not change after creation
- (parent
- (second ;the first one is the instanceOf association
- (player-in-roles
- geodata-topic))))
- (norwegian-curriculum-assoc ;changes in merge1 and merge2
- (identified-construct
- (elephant:get-instance-by-value 'ItemIdentifierC 'uri
- "http://psi.egovpt.org/itemIdentifiers#assoc_6"))))
-
- (is-true (changed-p service-name fixtures::revision1))
- (is-false (changed-p service-name fixtures::revision2))
- (is-false (changed-p service-name fixtures::revision3))
-
- (is-true (changed-p service-topic fixtures::revision1))
- (is-true (changed-p service-topic fixtures::revision2))
- (is-false (changed-p service-topic fixtures::revision3))
-
- (is-true (changed-p google-maps-topic fixtures::revision1))
- (is-false (changed-p google-maps-topic fixtures::revision2))
- (is-false (changed-p google-maps-topic fixtures::revision3))
-
- (is-true (changed-p norwegian-curr-topic fixtures::revision1))
- (is-true (changed-p norwegian-curr-topic fixtures::revision2))
- (is-true (changed-p norwegian-curr-topic fixtures::revision3))
-
- (is-true (changed-p geodata-topic fixtures::revision1))
- (is-false (changed-p geodata-topic fixtures::revision2))
- (is-false (changed-p geodata-topic fixtures::revision3))
-
- (is-true (changed-p semantic-standard-topic fixtures::revision1))
- (is-true (changed-p semantic-standard-topic fixtures::revision2))
- (is-true (changed-p semantic-standard-topic fixtures::revision3))
-
- (is-false (changed-p common-lisp-topic fixtures::revision1)) ;didn't even exist then
- (is-true (changed-p common-lisp-topic fixtures::revision2))
- (is-true (changed-p common-lisp-topic fixtures::revision3))
-
- (is-true (changed-p subject-geodata-assoc fixtures::revision1))
- (is-false (changed-p subject-geodata-assoc fixtures::revision2))
- (is-false (changed-p subject-geodata-assoc fixtures::revision3))
-
- (is-true (changed-p norwegian-curriculum-assoc fixtures::revision1))
- (is-true (changed-p norwegian-curriculum-assoc fixtures::revision2))
- (is-true (changed-p norwegian-curriculum-assoc fixtures::revision3)))))
+ (get-item-by-id "t300" :xtm-id *TEST-TM* :revision fixtures::revision1))
+ (geodata-topic ;does not change after creation
+ (get-item-by-id "t203" :xtm-id *TEST-TM* :revision fixtures::revision1)) ;the subject "geodata", not the standard
+ (semantic-standard-topic ;changes in merge1 and merge2
+ (get-item-by-id "t3a" :xtm-id *TEST-TM* :revision fixtures::revision1))
+ (common-lisp-topic ;created in merge1 and changed in merge2
+ (get-item-by-id "t100" :xtm-id "merge1" :revision fixtures::revision2))
+ (subject-geodata-assoc ;does not change after creation
+ (parent
+ (second ;the first one is the instanceOf association
+ (player-in-roles
+ geodata-topic :revision fixtures::revision1))
+ :revision fixtures::revision1))
+ (norwegian-curriculum-assoc ;changes in merge1 and merge2
+ (identified-construct
+ (elephant:get-instance-by-value
+ 'ItemIdentifierC 'uri
+ "http://psi.egovpt.org/itemIdentifiers#assoc_6")
+ :revision fixtures::revision2)))
+ (is-true (changed-p service-name fixtures::revision1))
+ (is-false (changed-p service-name fixtures::revision2))
+ (is-false (changed-p service-name fixtures::revision3))
+ (is-true (changed-p service-topic fixtures::revision1))
+ (is-true (changed-p service-topic fixtures::revision2))
+ (is-false (changed-p service-topic fixtures::revision3))
+ (is-true (changed-p google-maps-topic fixtures::revision1))
+ (is-false (changed-p google-maps-topic fixtures::revision2))
+ (is-false (changed-p google-maps-topic fixtures::revision3))
+ (is-true (changed-p norwegian-curr-topic fixtures::revision1))
+ (is-true (changed-p norwegian-curr-topic fixtures::revision2))
+ (is-true (changed-p norwegian-curr-topic fixtures::revision3))
+ (is-true (changed-p geodata-topic fixtures::revision1))
+ (is-false (changed-p geodata-topic fixtures::revision2))
+ (is-false (changed-p geodata-topic fixtures::revision3))
+ (is-true (changed-p semantic-standard-topic fixtures::revision1))
+ (is-true (changed-p semantic-standard-topic fixtures::revision2))
+ (is-true (changed-p semantic-standard-topic fixtures::revision3))
+ (is-false (changed-p common-lisp-topic fixtures::revision1)) ;didn't even exist then
+ (is-true (changed-p common-lisp-topic fixtures::revision2))
+ (is-true (changed-p common-lisp-topic fixtures::revision3))
+ (is-true (changed-p subject-geodata-assoc fixtures::revision1))
+ (is-false (changed-p subject-geodata-assoc fixtures::revision2))
+ (is-false (changed-p subject-geodata-assoc fixtures::revision3))
+ (is-true (changed-p norwegian-curriculum-assoc fixtures::revision1))
+ (is-true (changed-p norwegian-curriculum-assoc fixtures::revision2))
+ (is-true (changed-p norwegian-curriculum-assoc fixtures::revision3))
+ (delete-name service-topic service-name :revision fixtures::revision3)
+ (is-true (changed-p service-topic fixtures::revision3)))))
+
(test test-mark-as-deleted ()
- "Check the pseudo-deletion mechanism"
- (with-fixture merge-test-db ()
- (let
- ((norwegian-curriculum-topic
- (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" :revision fixtures::revision3))
- (semantic-standard-topic
- (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" :revision fixtures::revision3)))
- (is-true norwegian-curriculum-topic)
- (is-true semantic-standard-topic)
- (mark-as-deleted norwegian-curriculum-topic :source-locator "http://psi.egovpt.org/"
- :revision fixtures::revision3)
- (is-false (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
- :revision (1+ fixtures::revision3)))
- (mark-as-deleted semantic-standard-topic :source-locator "http://blablub.egovpt.org/"
- :revision fixtures::revision3)
- (is-true (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard"
- :revision (1+ fixtures::revision3)))
- (is (= 0 (d::end-revision (d::get-most-recent-version-info semantic-standard-topic))))
- (is (= (d::end-revision (first (last (d::versions norwegian-curriculum-topic))))
- (d::end-revision (d::get-most-recent-version-info norwegian-curriculum-topic)))))))
+ "Check the pseudo-deletion mechanism"
+ (with-fixture merge-test-db ()
+ (let
+ ((norwegian-curriculum-topic
+ (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
+ :revision fixtures::revision3))
+ (semantic-standard-topic
+ (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard"
+ :revision fixtures::revision3)))
+ (is-true norwegian-curriculum-topic)
+ (is-true semantic-standard-topic)
+ (mark-as-deleted norwegian-curriculum-topic
+ :source-locator "http://psi.egovpt.org/"
+ :revision fixtures::revision3)
+ (is-false (get-item-by-psi
+ "http://psi.egovpt.org/service/Norwegian+National+Curriculum"
+ :revision (1+ fixtures::revision3)))
+ (mark-as-deleted semantic-standard-topic
+ :source-locator "http://blablub.egovpt.org/"
+ :revision fixtures::revision3)
+ (is-true (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard"
+ :revision (1+ fixtures::revision3)))
+ (is (= 0 (d::end-revision
+ (d::get-most-recent-version-info semantic-standard-topic))))
+ (is (= (d::end-revision
+ (first (last (d::versions norwegian-curriculum-topic))))
+ (d::end-revision
+ (d::get-most-recent-version-info norwegian-curriculum-topic)))))))
Modified: trunk/src/xml/rdf/exporter.lisp
==============================================================================
--- trunk/src/xml/rdf/exporter.lisp (original)
+++ trunk/src/xml/rdf/exporter.lisp Sun Oct 10 05:41:19 2010
@@ -60,7 +60,7 @@
(defun init-*ns-map* ()
- "Initializes the variable *ns-map* woith some prefixes and corresponding
+ "Initializes the variable *ns-map* with some prefixes and corresponding
namepsaces. So the predifend namespaces are not contain ed twice."
(setf *ns-map* (list
(list :prefix "isi"
@@ -75,8 +75,8 @@
(defmacro with-property (construct &body body)
"Generates a property element with a corresponding namespace
- and tag name before executing the body. This macro is for usin
- in occurrences and association that are mapped to RDF properties."
+ and tag name before executing the body. This macro is for using
+ in occurrences and associations that are mapped to RDF properties."
`(let ((ns-list
(separate-uri (rdf-li-or-uri
(uri (first (psis (instance-of ,construct))))))))
@@ -216,7 +216,7 @@
(declare (TopicC topic))
(if (psis topic)
(cxml:attribute "rdf:resource"
- (if (reified topic)
+ (if (reified-construct topic)
(let ((psi (get-reifier-psi topic)))
(if psi
(concatenate 'string "#" (get-reifier-uri topic))
@@ -306,7 +306,7 @@
(make-isi-type *tm2rdf-name-type-uri*)
(export-reifier-as-mapping construct)
(map 'list #'to-rdf-elem (item-identifiers construct))
- (when (slot-boundp construct 'instance-of)
+ (when (instance-of construct)
(cxml:with-element "isi:nametype"
(make-topic-reference (instance-of construct))))
(scopes-to-rdf-elems construct)
@@ -592,7 +592,7 @@
(t-occs (occurrences construct))
(t-assocs (list-rdf-mapped-associations construct)))
(if psi
- (if (reified construct)
+ (if (reified-construct construct)
(let ((reifier-uri (get-reifier-uri construct)))
(if reifier-uri
(cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct)))
@@ -627,7 +627,7 @@
(ii (item-identifiers construct))
(sl (locators construct)))
(if psi
- (if (reified construct)
+ (if (reified-construct construct)
(let ((reifier-uri (get-reifier-uri construct)))
(if reifier-uri
(cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct)))
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Sun Oct 10 05:41:19 2010
@@ -20,9 +20,9 @@
(xml-importer:init-isidorus)
(init-rdf-module)
(rdf-importer rdf-xml-path repository-path :tm-id tm-id
- :document-id document-id))
-; (when elephant:*store-controller*
-; (elephant:close-store)))
+ :document-id document-id)
+ (when elephant:*store-controller*
+ (elephant:close-store)))
(defun rdf-importer (rdf-xml-path repository-path
@@ -46,7 +46,7 @@
(format t "#Objects in the store: Topics: ~a, Associations: ~a~%"
(length (elephant:get-instances-by-class 'TopicC))
(length (elephant:get-instances-by-class 'AssociationC)))
-; (elephant:close-store)
+ (elephant:close-store)
(setf *_n-map* nil)))
@@ -67,12 +67,12 @@
((top
(from-topic-elem-to-stub top-elem revision
:xtm-id *rdf-core-xtm*)))
- (add-to-topicmap xml-importer::tm top))))))))
+ (add-to-tm xml-importer::tm top))))))))
(defun import-dom (rdf-dom start-revision
&key (tm-id nil) (document-id *document-id*))
- "Imports the entire dom of a rdf-xml-file."
+ "Imports the entire dom of an rdf-xml-file."
(setf *_n-map* nil) ;in case of an failed last call
(tm-id-p tm-id "import-dom")
(let ((xml-base (get-xml-base rdf-dom))
@@ -137,7 +137,7 @@
(defun import-arc (elem tm-id start-revision
&key (document-id *document-id*)
(parent-xml-base nil) (parent-xml-lang nil))
- "Imports a property that is an blank_node and continues the recursion
+ "Imports a property that is a blank_node and continues the recursion
on this element."
(declare (dom:element elem))
(let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang))
@@ -351,11 +351,13 @@
(error "~aone of the role types ~a ~a is missing!"
err-pref *supertype-psi* *subtype-psi*))
(let ((a-roles (list (list :instance-of role-type-1
- :player super-top)
+ :player super-top
+ :start-revision start-revision)
(list :instance-of role-type-2
- :player sub-top))))
+ :player sub-top
+ :start-revision start-revision))))
(let ((assoc
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct 'AssociationC
:start-revision start-revision
@@ -392,11 +394,13 @@
(error "~aone of the role types ~a ~a is missing!"
err-pref *type-psi* *instance-psi*))
(let ((a-roles (list (list :instance-of roletype-1
- :player type-top)
+ :player type-top
+ :start-revision start-revision)
(list :instance-of roletype-2
- :player instance-top))))
+ :player instance-top
+ :start-revision start-revision))))
(let ((assoc
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct 'AssociationC
:start-revision start-revision
@@ -420,40 +424,35 @@
(ii-uri (unless (or about ID)
(concatenate 'string *rdf2tm-blank-node-prefix*
(or nodeID UUID)))))
- (let ((top
- ;seems like there is a bug in d:get-item-by-id:
- ;this functions returns an emtpy topic although there is no one
- ;with a corresponding topic id and/or version.
- ;Thus the version is temporary checked manually.
- (let ((inner-top
- (get-item-by-id topic-id :xtm-id document-id
- :revision start-revision)))
- (when inner-top
- (let ((versions (d::versions inner-top)))
- (when (find-if #'(lambda(version)
- (= start-revision
- (d::start-revision version)))
- versions)
- inner-top))))))
+ (let ((top (get-item-by-id topic-id :xtm-id document-id
+ :revision start-revision)))
(if top
- top
+ (progn
+ (d::add-to-version-history top :start-revision start-revision)
+ top)
(elephant:ensure-transaction (:txn-nosync t)
(let ((psis (when psi-uri
(list
- (make-instance 'PersistentIdC
+ (make-construct 'PersistentIdC
:uri psi-uri
:start-revision start-revision))))
(iis (when ii-uri
(list
- (make-instance 'ItemIdentifierC
+ (make-construct 'ItemIdentifierC
:uri ii-uri
- :start-revision start-revision)))))
+ :start-revision start-revision))))
+ (topic-ids (when topic-id
+ (list
+ (make-construct 'TopicIdentificationC
+ :uri topic-id
+ :xtm-id document-id
+ :start-revision start-revision)))))
(handler-case (let ((top
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct
- 'TopicC
- :topicid topic-id
+ 'TopicC
+ :topic-identifiers topic-ids
:psis psis
:item-identifiers iis
:xtm-id document-id
@@ -498,11 +497,13 @@
(type-top (make-topic-stub type nil nil nil start-revision
tm :document-id document-id)))
(let ((roles (list (list :instance-of role-type-1
- :player player-1)
+ :player player-1
+ :start-revision start-revision)
(list :instance-of role-type-2
- :player top))))
+ :player top
+ :start-revision start-revision))))
(let ((assoc
- (add-to-topicmap tm (make-construct 'AssociationC
+ (add-to-tm tm (make-construct 'AssociationC
:start-revision start-revision
:instance-of type-top
:roles roles))))
@@ -527,11 +528,13 @@
(make-topic-stub *rdf2tm-object* nil nil nil start-revision
tm :document-id document-id)))
(let ((roles (list (list :instance-of role-type-1
- :player subject-topic)
+ :player subject-topic
+ :start-revision start-revision)
(list :instance-of role-type-2
- :player object-topic))))
+ :player object-topic
+ :start-revision start-revision))))
(let ((assoc
- (add-to-topicmap
+ (add-to-tm
tm (make-construct 'AssociationC
:start-revision start-revision
:instance-of associationtype-topic
@@ -541,13 +544,14 @@
-(defun make-reification(reifier-id reifiable-construct start-revision tm &key (document-id *document-id*))
+(defun make-reification(reifier-id reifiable-construct start-revision tm &key
+ (document-id *document-id*))
(declare (string reifier-id))
(declare (ReifiableConstructC reifiable-construct))
(declare (TopicMapC tm))
(let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm
:document-id document-id)))
- (add-reifier reifiable-construct reifier-topic)))
+ (add-reifier reifiable-construct reifier-topic :revision start-revision)))
(defun make-occurrence (top literal start-revision tm-id
@@ -572,7 +576,7 @@
(let ((occurrence
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes (when lang-top
(list lang-top))
:instance-of type-top
Modified: trunk/src/xml/rdf/map_to_tm.lisp
==============================================================================
--- trunk/src/xml/rdf/map_to_tm.lisp (original)
+++ trunk/src/xml/rdf/map_to_tm.lisp Sun Oct 10 05:41:19 2010
@@ -57,42 +57,51 @@
(let ((type-topic (get-item-by-psi type-psi
:revision start-revision)))
(when type-topic
- (when (and (not (player-in-roles type-topic))
- (not (used-as-type type-topic))
- (not (used-as-theme type-topic)))
+ (when (and (not (player-in-roles type-topic :revision start-revision))
+ (not (used-as-type type-topic :revision start-revision))
+ (not (used-as-theme type-topic :revision start-revision)))
(d::delete-construct type-topic)))))
-(defun delete-instance-of-association(instance-topic type-topic)
+(defun delete-instance-of-association(instance-topic type-topic start-revision)
"Deletes a type-instance associaiton that corresponds with the passed
parameters."
(when (and instance-topic type-topic)
- (let ((instance (get-item-by-psi *instance-psi*))
- (type-instance (get-item-by-psi *type-instance-psi*))
- (type (get-item-by-psi *type-psi*)))
- (declare (TopicC instance-topic type-topic))
+ (let ((instance (get-item-by-psi *instance-psi* :revision start-revision))
+ (type-instance (get-item-by-psi *type-instance-psi*
+ :revision start-revision))
+ (type (get-item-by-psi *type-psi* :revision start-revision)))
+ (declare (TopicC instance-topic type-topic)
+ (integer start-revision))
(let ((assocs (remove-if
#'null
(map 'list
#'(lambda(role)
- (when (and (eql (instance-of role) instance)
- (eql (instance-of (parent role))
- type-instance))
- (parent role)))
- (player-in-roles instance-topic)))))
+ (when (and
+ (eql (instance-of role :revision start-revision)
+ instance)
+ (eql (instance-of
+ (parent role :revision start-revision)
+ :revision start-revision)
+ type-instance))
+ (parent role :revision start-revision)))
+ (player-in-roles instance-topic :revision start-revision)))))
(map 'list #'(lambda(assoc)
- (when (find-if #'(lambda(role)
- (and (eql (instance-of role) type)
- (eql (player role) type-topic)))
- (roles assoc))
+ (when (find-if
+ #'(lambda(role)
+ (and (eql (instance-of role :revision start-revision)
+ type)
+ (eql (player role :revision start-revision)
+ type-topic)))
+ (roles assoc :revision start-revision))
(d::delete-construct assoc)))
assocs)
nil))))
-(defun delete-related-associations (top)
+(defun delete-related-associations (top start-revision)
"Deletes all associaitons related to the passed topic."
- (dolist (assoc-role (player-in-roles top))
+ (dolist (assoc-role (player-in-roles top :revision start-revision))
(d::delete-construct (parent assoc-role)))
top)
@@ -141,11 +150,12 @@
(when (= 0 (length role-players))
(error "~aexpect one player but found: ~a"
err-pref (length role-players)))
- (delete-related-associations role-top)
+ (delete-related-associations role-top start-revision)
(d::delete-construct role-top)
(list :instance-of (first types)
:player (first role-players)
:item-identifiers ids
+ :start-revision start-revision
:reifiers reifiers)))))
@@ -185,10 +195,10 @@
(when (= 0 (length assoc-roles))
(error "~aexpect at least one role but found: ~a"
err-pref (length assoc-roles)))
- (delete-related-associations assoc-top)
+ (delete-related-associations assoc-top start-revision)
(d::delete-construct assoc-top)
(with-tm (start-revision document-id tm-id)
- (add-to-topicmap
+ (add-to-tm
xml-importer::tm
(let ((association
(make-construct 'AssociationC
@@ -208,10 +218,11 @@
assoc-roles)))
(when found-item
(dolist (reifier-topic (getf found-item :reifiers))
- (add-reifier association-role reifier-topic)))))
- (roles association))
+ (add-reifier association-role reifier-topic
+ :revision start-revision)))))
+ (roles association :revision start-revision))
(dolist (reifier-topic reifier-topics)
- (add-reifier association reifier-topic))
+ (add-reifier association reifier-topic :revision start-revision))
association)))))))
@@ -229,9 +240,9 @@
(new-item-ids (map-isi-identifiers top start-revision))
(occurrence-topics (get-isi-occurrences top start-revision))
(name-topics (get-isi-names top start-revision)))
- (bound-subject-identifiers top new-psis)
- (bound-subject-locators top new-locators)
- (bound-item-identifiers top new-item-ids)
+ (bound-subject-identifiers top new-psis start-revision)
+ (bound-subject-locators top new-locators start-revision)
+ (bound-item-identifiers top new-item-ids start-revision)
(map 'list #'(lambda(occurrence-topic)
(map-isi-occurrence top occurrence-topic start-revision))
occurrence-topics)
@@ -267,7 +278,7 @@
variant-top start-revision *tm2rdf-scope-property*
*rdf2tm-subject*))
(value-type-topic
- (get-item-by-psi *tm2rdf-value-property*)))
+ (get-item-by-psi *tm2rdf-value-property* :revision start-revision)))
(let ((scopes (get-players-by-role-type
scope-assocs start-revision *rdf2tm-object*))
(value-and-datatype
@@ -283,7 +294,7 @@
(reifiers (get-isi-reifiers variant-top start-revision)))
(elephant:ensure-transaction (:txn-nosync t)
(map 'list #'d::delete-construct scope-assocs)
- (delete-related-associations variant-top)
+ (delete-related-associations variant-top start-revision)
(d::delete-construct variant-top)
(let ((variant
(make-construct 'VariantC
@@ -292,9 +303,9 @@
:themes scopes
:charvalue (getf value-and-datatype :value)
:datatype (getf value-and-datatype :datatype)
- :name name)))
+ :parent name)))
(dolist (reifier-topic reifiers)
- (add-reifier variant reifier-topic))
+ (add-reifier variant reifier-topic :revision start-revision))
variant)))))
@@ -312,7 +323,7 @@
name-top start-revision *tm2rdf-scope-property*
*rdf2tm-subject*))
(value-type-topic
- (get-item-by-psi *tm2rdf-value-property*))
+ (get-item-by-psi *tm2rdf-value-property* :revision start-revision))
(variant-topics (get-isi-variants name-top start-revision)))
(let ((type (let ((fn-types
(get-players-by-role-type
@@ -335,7 +346,7 @@
(map 'list #'d::delete-construct scope-assocs)
(let ((name (make-construct 'NameC
:start-revision start-revision
- :topic top
+ :parent top
:charvalue value
:instance-of type
:item-identifiers ids
@@ -344,10 +355,10 @@
(map-isi-variant name variant-topic
start-revision))
variant-topics)
- (delete-related-associations name-top)
+ (delete-related-associations name-top start-revision)
(d::delete-construct name-top)
(dolist (reifier-topic reifiers)
- (add-reifier name reifier-topic))
+ (add-reifier name reifier-topic :revision start-revision))
name)))))
@@ -403,19 +414,19 @@
(when (/= 1 (length types))
(error "~aexpect one type topic but found: ~a"
err-pref (length types)))
- (delete-related-associations occ-top)
+ (delete-related-associations occ-top start-revision)
(d::delete-construct occ-top)
(let ((occurrence
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes scopes
:item-identifiers ids
:instance-of (first types)
:charvalue (getf value-and-datatype :value)
:datatype (getf value-and-datatype :datatype))))
(dolist (reifier-topic reifiers)
- (add-reifier occurrence reifier-topic))
+ (add-reifier occurrence reifier-topic :revision start-revision))
occurrence)))))
@@ -448,12 +459,15 @@
(let ((topics-in-tm
(with-tm (start-revision document-id tm-id)
(intersection isi-topics (topics xml-importer::tm)))))
- (map 'list #'(lambda(top)
- (map 'list
- #'(lambda(role)
- (when (find (parent role) assocs)
- (d::delete-construct (parent role))))
- (player-in-roles top)))
+ (map 'list
+ #'(lambda(top)
+ (map 'list
+ #'(lambda(role)
+ (when (find (parent role :revision start-revision)
+ assocs)
+ (d::delete-construct
+ (parent role :revision start-revision))))
+ (player-in-roles top :revision start-revision)))
topics-in-tm)
topics-in-tm))))))
@@ -497,11 +511,13 @@
(map 'list
#'(lambda(assoc)
(let ((role
- (find-if #'(lambda(role)
- (eql role-type (instance-of role)))
- (roles assoc))))
+ (find-if
+ #'(lambda(role)
+ (eql role-type (instance-of role
+ :revision start-revision)))
+ (roles assoc :revision start-revision))))
(when role
- (player role))))
+ (player role :revision start-revision))))
associations))))
players)))
@@ -517,16 +533,18 @@
(remove-if #'null
(map 'list
#'(lambda(occurrence)
- (let ((type (instance-of occurrence)))
+ (let ((type
+ (instance-of occurrence
+ :revision start-revision)))
(let ((type-psi
(find-if #'(lambda(psi)
(string=
occurrence-type-uri
(uri psi)))
- (psis type))))
+ (psis type :revision start-revision))))
(when type-psi
occurrence))))
- (occurrences top)))))
+ (occurrences top :revision start-revision)))))
identifier-occs)))
@@ -560,42 +578,45 @@
ids)))))
-(defun bound-item-identifiers (construct identifiers)
+(defun bound-item-identifiers (construct identifiers start-revision)
"Bounds the passed item-identifier to the passed construct."
(declare (ReifiableConstructC construct))
(dolist (id identifiers)
(declare (ItemIdentifierC id))
(if (find-if #'(lambda(ii)
- (string= (uri ii) (uri id)))
- (item-identifiers construct))
+ (and (string= (uri ii) (uri id))
+ (not (eql ii id))))
+ (item-identifiers construct :revision start-revision))
(d::delete-construct id)
- (setf (identified-construct id) construct)))
+ (add-item-identifier construct id :revision start-revision)))
construct)
-(defun bound-subject-identifiers (top identifiers)
+(defun bound-subject-identifiers (top identifiers start-revision)
"Bounds the passed psis to the passed topic."
(declare (TopicC top))
(dolist (id identifiers)
(declare (PersistentIdC id))
(if (find-if #'(lambda(psi)
- (string= (uri psi) (uri id)))
- (psis top))
+ (and (string= (uri psi) (uri id))
+ (not (eql psi id))))
+ (psis top :revision start-revision))
(d::delete-construct id)
- (setf (identified-construct id) top)))
+ (add-psi top id :revision start-revision)))
top)
-(defun bound-subject-locators (top locators)
+(defun bound-subject-locators (top locators start-revision)
"Bounds the passed locators to the passed topic."
(declare (TopicC top))
(dolist (id locators)
(declare (SubjectLocatorC id))
(if (find-if #'(lambda(locator)
- (string= (uri locator) (uri id)))
- (locators top))
+ (and (string= (uri locator) (uri id))
+ (not (eql locator id))))
+ (locators top :revision start-revision))
(d::delete-construct id)
- (setf (identified-construct id) top)))
+ (add-locator top id :revision start-revision)))
top)
Modified: trunk/src/xml/xtm/exporter.lisp
==============================================================================
--- trunk/src/xml/xtm/exporter.lisp (original)
+++ trunk/src/xml/xtm/exporter.lisp Sun Oct 10 05:41:19 2010
@@ -10,26 +10,35 @@
(in-package :exporter)
-;; (defun instanceofs-to-elem (ios)
-;; (when ios
-;; (map 'list (lambda (io) (cxml:with-element "t:instanceOf" (ref-to-elem io))) ios)))
-
-
-(defun list-extern-associations ()
+(defun list-extern-associations (&key (revision *TM-REVISION*))
"gets all instances of AssociationC - which does not realize an instanceOf relationship in the db"
(let ((instance-topic
(identified-construct
- (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/instance")))
+ (elephant:get-instance-by-value 'PersistentIdC 'uri *instance-psi*)))
(type-topic
(identified-construct
- (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/type"))))
- (loop for item in (elephant:get-instances-by-class 'AssociationC)
- when (not (and (or (eq instance-topic (instance-of (first (roles item))))
- (eq instance-topic (instance-of (second (roles item)))))
- (or (eq type-topic (instance-of (first (roles item))))
- (eq type-topic (instance-of (second (roles item)))))))
+ (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*))))
+ (loop for item in (d:get-all-associations revision)
+ when (and (= (length (roles item :revision revision)) 2)
+ (not (and (or (eq instance-topic
+ (instance-of (first (roles item
+ :revision revision))
+ :revision revision))
+ (eq instance-topic
+ (instance-of (second (roles item
+ :revision revision))
+ :revision revision)))
+ (or (eq type-topic
+ (instance-of (first (roles item
+ :revision revision))
+ :revision revision))
+ (eq type-topic
+ (instance-of (second (roles item
+ :revision revision))
+ :revision revision))))))
collect item)))
+
(defmacro with-xtm2.0 (&body body)
"helper macro to build the Topic Map element"
`(cxml:with-namespace ("t" *xtm2.0-ns*)
@@ -47,6 +56,7 @@
"t:topicMap" :empty
, at body))))
+
(defmacro export-to-elem (tm to-elem)
`(setf *export-tm* ,tm)
`(format t "*export-tm*: ~a" *export-tm*)
@@ -57,12 +67,13 @@
(map 'list
#'(lambda(top)
(d:find-item-by-revision top revision))
- (if ,tm
- (union
- (d:topics ,tm) (d:associations ,tm))
- (union
- (elephant:get-instances-by-class 'd:TopicC)
- (list-extern-associations)))))))
+ (if ,tm
+ (union
+ (d:topics ,tm) (d:associations ,tm))
+ (union
+ (elephant:get-instances-by-class 'd:TopicC)
+ (list-extern-associations :revision revision)))))))
+
(defun export-xtm (xtm-path &key
tm-id
@@ -80,9 +91,11 @@
(cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil)
(if (eq xtm-format '2.0)
(with-xtm2.0
- (export-to-elem tm #'to-elem))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem elem revision))))
(with-xtm1.0
- (export-to-elem tm #'to-elem-xtm1.0)))))))))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem-xtm1.0 elem revision)))))))))))
(defun export-xtm-to-string (&key
@@ -97,9 +110,11 @@
(cxml:with-xml-output (cxml:make-string-sink :canonical nil)
(if (eq xtm-format '2.0)
(with-xtm2.0
- (export-to-elem tm #'to-elem))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem elem revision))))
(with-xtm1.0
- (export-to-elem tm #'to-elem-xtm1.0))))))))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem-xtm1.0 elem revision))))))))))
(defun export-xtm-fragment (fragment &key (xtm-format '2.0))
@@ -109,7 +124,6 @@
(cxml:with-xml-output (cxml:make-string-sink :canonical nil)
(if (eq xtm-format '2.0)
(with-xtm2.0
- (to-elem fragment))
+ (to-elem fragment (revision fragment)))
(with-xtm1.0
- (to-elem-xtm1.0 fragment)))))))
-
\ No newline at end of file
+ (to-elem-xtm1.0 fragment (revision fragment))))))))
\ No newline at end of file
Modified: trunk/src/xml/xtm/exporter_xtm1.0.lisp
==============================================================================
--- trunk/src/xml/xtm/exporter_xtm1.0.lisp (original)
+++ trunk/src/xml/xtm/exporter_xtm1.0.lisp Sun Oct 10 05:41:19 2010
@@ -12,7 +12,11 @@
(:import-from :constants
*XTM2.0-NS*
*XTM1.0-NS*
- *XTM1.0-XLINK*)
+ *XTM1.0-XLINK*
+ *type-psi*
+ *instance-psi*
+ *xml-uri*
+ *xml-string*)
(:export :to-elem
:to-string
:list-extern-associations
@@ -24,35 +28,40 @@
(defparameter *export-tm* nil "TopicMap which is exported (nil if all is to be exported")
-(defgeneric to-elem-xtm1.0 (instance)
+(defgeneric to-elem-xtm1.0 (instance revision)
(:documentation "converts the Topic Maps construct instance to an XTM 1.0 element"))
-(defun to-topicRef-elem-xtm1.0 (topic)
- (declare (TopicC topic))
+(defun to-topicRef-elem-xtm1.0 (topic revision)
+ (declare (TopicC topic)
+ (type (or integer nil) revision))
(cxml:with-element "t:topicRef"
- (cxml:attribute "xlink:href" (format nil "#~a" (topicid topic)))))
+ (cxml:attribute "xlink:href" (format nil "#~a" (topic-id topic revision)))))
-(defun to-reifier-elem-xtm1.0 (reifiable-construct)
+(defun to-reifier-elem-xtm1.0 (reifiable-construct revision)
"Exports an ID indicating a reifier.
The reifier is only exported if the reifier-topic contains a PSI starting with #.
This may cause differences since the xtm2.0 defines the referencing
of reifiers with item-identifiers."
- (declare (ReifiableConstructC reifiable-construct))
- (when (reifier reifiable-construct)
+ (declare (ReifiableConstructC reifiable-construct)
+ (type (or integer nil) revision))
+ (when (reifier reifiable-construct :revision revision)
(let ((reifier-psi
(find-if #'(lambda(x)
(when (and (stringp (uri x))
(> (length (uri x)) 0))
(eql (elt (uri x) 0) #\#)))
- (psis (reifier reifiable-construct)))))
+ (psis (reifier reifiable-construct :revision revision)
+ :revision revision))))
(when reifier-psi
- (cxml:attribute "id" (subseq (uri reifier-psi) 1 (length (uri reifier-psi))))))))
+ (cxml:attribute "id" (subseq (uri reifier-psi) 1
+ (length (uri reifier-psi))))))))
-(defun to-resourceX-elem-xtm1.0 (characteristic)
- (declare (CharacteristicC characteristic))
+(defun to-resourceX-elem-xtm1.0 (characteristic revision)
+ (declare (CharacteristicC characteristic)
+ (type (or integer nil) revision))
(let ((characteristic-value
(if (slot-boundp characteristic 'charvalue)
(charvalue characteristic)
@@ -66,136 +75,175 @@
(cxml:attribute "xlink:href"
(let ((ref-topic (when (and (> (length characteristic-value) 0)
(eql (elt characteristic-value 0) #\#))
- (get-item-by-id (subseq characteristic-value 1)))))
- (if ref-topic (concatenate 'string "#" (topicid ref-topic)) characteristic-value))))
+ (get-item-by-id (subseq characteristic-value 1) :revision revision))))
+ (if ref-topic (concatenate 'string "#" (topic-id ref-topic revision)) characteristic-value))))
(cxml:with-element "t:resourceData"
(cxml:text characteristic-value)))))
-(defmethod to-elem-xtm1.0 ((psi PersistentIdC))
+(defmethod to-elem-xtm1.0 ((psi PersistentIdC) revision)
"subjectIndocatorRef = element subjectIndicatorRef { href }"
+ (declare (ignorable revision))
(cxml:with-element "t:subjectIndicatorRef"
(cxml:attribute "xlink:href" (uri psi))))
-(defun to-instanceOf-elem-xtm1.0 (topic)
+(defun to-instanceOf-elem-xtm1.0 (topic revision)
"instanceOf = element instanceOf { topicRef | subjectIndicatorRef }"
- (declare (TopicC topic))
+ (declare (TopicC topic)
+ (type (or integer nil) revision))
(cxml:with-element "t:instanceOf"
(cxml:with-element "t:topicRef"
- (cxml:attribute "xlink:href" (concatenate 'string "#" (topicid topic))))))
+ (cxml:attribute "xlink:href" (concatenate 'string "#" (topic-id topic revision))))))
-(defun to-subjectIdentity-elem-xtm1.0 (psis locator)
+(defun to-subjectIdentity-elem-xtm1.0 (psis locator revision)
"subjectIdentity = element subjectIdentity { resourceRef?,
(topicRef | subjectIndicatorRef)* }"
+ (declare (type (or integer nil) revision))
(when (or psis locator)
(cxml:with-element "t:subjectIdentity"
- (map 'list #'to-elem-xtm1.0 psis)
+ (map 'list #'(lambda(x)
+ (to-elem-xtm1.0 x revision))
+ psis)
(when locator
(cxml:with-element "t:resourceRef"
(cxml:attribute "xlink:href" (uri locator)))))))
-(defun to-scope-elem-xtm1.0 (scopable)
+(defun to-scope-elem-xtm1.0 (scopable revision)
"scope = element scope { (topicRef | resourceRef | subjectIndicatorRef)+ }"
- (declare (ScopableC scopable))
+ (declare (ScopableC scopable)
+ (type (or integer nil) revision))
(cxml:with-element "t:scope"
- (to-topicRef-elem-xtm1.0 (first (themes scopable)))))
+ (to-topicRef-elem-xtm1.0 (first (themes scopable :revision revision)) revision)))
-(defmethod to-elem-xtm1.0 ((variant VariantC))
+(defmethod to-elem-xtm1.0 ((variant VariantC) revision)
"variant = element { parameters, variantName?, variant* }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:variant"
- (to-reifier-elem-xtm1.0 variant)
- (when (themes variant)
+ (to-reifier-elem-xtm1.0 variant revision)
+ (when (themes variant :revision revision)
(cxml:with-element "t:parameters"
- (map 'list #'to-topicRef-elem-xtm1.0 (themes variant))))
+ (map 'list #'(lambda(x)
+ (to-topicRef-elem-xtm1.0 x revision))
+ (themes variant :revision revision))))
(cxml:with-element "t:variantName"
- (to-resourceX-elem-xtm1.0 variant))))
+ (to-resourceX-elem-xtm1.0 variant revision))))
-(defmethod to-elem-xtm1.0 ((name NameC))
+(defmethod to-elem-xtm1.0 ((name NameC) revision)
"baseName = element baseName { scope?, baseNameString, variant* }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:baseName"
- (to-reifier-elem-xtm1.0 name)
- (when (themes name)
- (to-scope-elem-xtm1.0 name))
+ (to-reifier-elem-xtm1.0 name revision)
+ (when (themes name :revision revision)
+ (to-scope-elem-xtm1.0 name revision))
(cxml:with-element "t:baseNameString"
(cxml:text (if (slot-boundp name 'charvalue)
(charvalue name)
"")))
- (when (variants name)
- (map 'list #'to-elem-xtm1.0 (variants name)))))
+ (when (variants name :revision revision)
+ (map 'list #'(lambda(x)
+ (to-elem-xtm1.0 x revision))
+ (variants name :revision revision)))))
-(defmethod to-elem-xtm1.0 ((occurrence OccurrenceC))
+(defmethod to-elem-xtm1.0 ((occurrence OccurrenceC) revision)
"occurrence = element occurrence { instanceOf?, scope?,
(resourceRef | resourceData) }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:occurrence"
- (to-reifier-elem-xtm1.0 occurrence)
- (when (instance-of occurrence)
- (to-instanceOf-elem-xtm1.0 (instance-of occurrence)))
- (when (themes occurrence)
- (to-scope-elem-xtm1.0 occurrence))
- (to-resourceX-elem-xtm1.0 occurrence)))
+ (to-reifier-elem-xtm1.0 occurrence revision)
+ (when (instance-of occurrence :revision revision)
+ (to-instanceOf-elem-xtm1.0 (instance-of occurrence :revision revision)
+ revision))
+ (when (themes occurrence :revision revision)
+ (to-scope-elem-xtm1.0 occurrence revision))
+ (to-resourceX-elem-xtm1.0 occurrence revision)))
-(defmethod to-elem-xtm1.0 ((topic TopicC))
+(defmethod to-elem-xtm1.0 ((topic TopicC) revision)
"topic = element topic { id, instanceOf*, subjectIdentity,
(baseName | occurrence)* }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
- (when (list-instanceOf topic :tm *export-tm*)
- (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic :tm *export-tm*)))
- (when (or (psis topic) (locators topic))
- (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic))))
- (when (names topic)
- (map 'list #'to-elem-xtm1.0 (names topic)))
- (when (occurrences topic)
- (map 'list #'to-elem-xtm1.0 (occurrences topic)))))
+ (cxml:attribute "id" (topic-id topic revision))
+ (let ((ios (list-instanceOf topic :tm *export-tm* :revision revision)))
+ (when ios
+ (map 'list #'(lambda(x)
+ (to-instanceOf-elem-xtm1.0 x revision))
+ ios)))
+ (let ((t-psis (psis topic :revision revision))
+ (first-locator (when (locators topic :revision revision)
+ (first (locators topic :revision revision)))))
+ (when (or t-psis first-locator)
+ (to-subjectIdentity-elem-xtm1.0 t-psis first-locator revision)))
+ (when (names topic :revision revision)
+ (map 'list #'(lambda(x)
+ (to-elem-xtm1.0 x revision))
+ (names topic :revision revision)))
+ (when (occurrences topic :revision revision)
+ (map 'list #'(lambda(x)
+ (to-elem-xtm1.0 x revision))
+ (occurrences topic :revision revision)))))
-(defun to-roleSpec-elem-xtm1.0 (topic)
+(defun to-roleSpec-elem-xtm1.0 (topic revision)
"roleSpec = element roleSpec { topicRef | subjectIndicatorRef }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:roleSpec"
- (to-topicRef-elem-xtm1.0 topic)))
+ (to-topicRef-elem-xtm1.0 topic revision)))
-(defmethod to-elem-xtm1.0 ((role RoleC))
+(defmethod to-elem-xtm1.0 ((role RoleC) revision)
"member = element member { roleSpec?,
(topicRef | resourceRef | subjectIndicatorRef)+ }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:member"
- (to-reifier-elem-xtm1.0 role)
- (when (instance-of role)
- (to-roleSpec-elem-xtm1.0 (instance-of role)))
- (to-topicRef-elem-xtm1.0 (player role))))
+ (to-reifier-elem-xtm1.0 role revision)
+ (when (instance-of role :revision revision)
+ (to-roleSpec-elem-xtm1.0 (instance-of role :revision revision) revision))
+ (to-topicRef-elem-xtm1.0 (player role :revision revision) revision)))
-(defmethod to-elem-xtm1.0 ((association AssociationC))
+(defmethod to-elem-xtm1.0 ((association AssociationC) revision)
"association = element association { instanceOf?, scope?, member+ }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:association"
- (to-reifier-elem-xtm1.0 association)
- (when (instance-of association)
- (to-instanceOf-elem-xtm1.0 (instance-of association)))
- (when (themes association)
- (to-scope-elem-xtm1.0 association))
- (map 'list #'to-elem-xtm1.0 (roles association))))
+ (to-reifier-elem-xtm1.0 association revision)
+ (when (instance-of association :revision revision)
+ (to-instanceOf-elem-xtm1.0 (instance-of association :revision revision) revision))
+ (when (themes association :revision revision)
+ (to-scope-elem-xtm1.0 association revision))
+ (map 'list #'(lambda(x)
+ (to-elem-xtm1.0 x revision))
+ (roles association :revision revision))))
-(defun to-stub-elem-xtm1.0 (topic)
+(defun to-stub-elem-xtm1.0 (topic revision)
"transforms a TopicC object to a topic stub element
with a topicid, psis and subjectLocators"
- (declare (TopicC topic))
+ (declare (TopicC topic)
+ (type (or integer nil) revision))
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
- (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic)))))
+ (cxml:attribute "id" (topic-id topic revision))
+ (to-subjectIdentity-elem-xtm1.0 (psis topic :revision revision)
+ (when (locators topic :revision revision)
+ (first (locators topic :revision revision)))
+ revision)))
-(defmethod to-elem-xtm1.0 ((fragment FragmentC))
+(defmethod to-elem-xtm1.0 ((fragment FragmentC) revision)
"transforms all sub-elements of the passed FragmentC instance"
- (to-elem-xtm1.0 (topic fragment))
- (map 'list #'to-stub-elem-xtm1.0 (referenced-topics fragment))
- (map 'list #'to-elem-xtm1.0 (associations fragment)))
+ (declare (type (or integer nil) revision))
+ (to-elem-xtm1.0 (topic fragment) revision)
+ (map 'list #'(lambda(x)
+ (to-stub-elem-xtm1.0 x revision))
+ (referenced-topics fragment))
+ (map 'list #'(lambda(x)
+ (to-elem-xtm1.0 x revision))
+ (associations fragment)))
Modified: trunk/src/xml/xtm/exporter_xtm2.0.lisp
==============================================================================
--- trunk/src/xml/xtm/exporter_xtm2.0.lisp (original)
+++ trunk/src/xml/xtm/exporter_xtm2.0.lisp Sun Oct 10 05:41:19 2010
@@ -9,54 +9,69 @@
(in-package :exporter)
-(defun to-reifier-elem (reifiable-construct)
+(defun to-reifier-elem (reifiable-construct revision)
"Exports the reifier-attribute.
The attribute is only exported if the reifier-topic contains at least
one item-identifier."
- (declare (ReifiableConstructC reifiable-construct))
- (when (and (reifier reifiable-construct)
- (item-identifiers (reifier reifiable-construct)))
+ (declare (ReifiableConstructC reifiable-construct)
+ (type (or integer nil) revision))
+ (when (and (reifier reifiable-construct :revision revision)
+ (item-identifiers (reifier reifiable-construct :revision revision)
+ :revision revision))
(cxml:attribute "reifier"
- (uri (first (item-identifiers (reifier reifiable-construct)))))))
-
-(defun ref-to-elem (topic)
- (declare (TopicC topic))
+ (uri (first (item-identifiers (reifier reifiable-construct
+ :revision revision)
+ :revision revision))))))
+
+(defun ref-to-elem (topic revision)
+ (declare (TopicC topic)
+ (type (or integer nil) revision))
(cxml:with-element "t:topicRef"
;;TODO: this is pretty much of a hack that works only for local
;;references
(cxml:attribute "href"
- (format nil "#~a" (topicid topic)))))
+ (format nil "#~a" (topic-id topic revision)))))
+
-(defgeneric to-elem (instance)
+(defgeneric to-elem (instance revision)
(:documentation "converts the Topic Maps construct instance to an XTM 2.0 element"))
-(defmethod to-elem ((psi PersistentIdC))
+
+(defmethod to-elem ((psi PersistentIdC) revision)
+ (declare (ignorable revision))
(cxml:with-element "t:subjectIdentifier"
(cxml:attribute "href" (uri psi))))
-(defmethod to-elem ((name NameC))
+(defmethod to-elem ((name NameC) revision)
"name = element name { reifiable,
type?, scope?, value, variant* }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:name"
- (to-reifier-elem name)
- (map 'list #'to-elem (item-identifiers name))
- (when (slot-boundp name 'instance-of)
+ (to-reifier-elem name revision)
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers name :revision revision))
+ (when (instance-of name :revision revision)
(cxml:with-element "t:type"
- (ref-to-elem (instance-of name))))
- (when (themes name)
+ (ref-to-elem (instance-of name :revision revision) revision)))
+ (when (themes name :revision revision)
(cxml:with-element "t:scope"
- (map 'list #'ref-to-elem (themes name))))
+ (map 'list #'(lambda(x)
+ (ref-to-elem x revision))
+ (themes name :revision revision))))
(cxml:with-element "t:value"
(cxml:text
(if (slot-boundp name 'charvalue)
(charvalue name)
"")))
- (when (variants name)
- (map 'list #'to-elem (variants name)))))
+ (when (variants name :revision revision)
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (variants name :revision revision)))))
-(defun to-resourceX-elem (characteristic)
+(defun to-resourceX-elem (characteristic revision)
"returns a resourceData or resourceRef element"
(declare (CharacteristicC characteristic))
(let ((characteristic-value
@@ -67,14 +82,15 @@
(if (slot-boundp characteristic 'datatype)
(datatype characteristic)
"")))
- (if (string= characteristic-type "http://www.w3.org/2001/XMLSchema#anyURI") ;-> resourceRef
+ (if (string= characteristic-type *xml-uri*) ;-> resourceRef
(cxml:with-element "t:resourceRef"
(let ((ref-topic (when (and (> (length characteristic-value) 0)
(eql (elt characteristic-value 0) #\#))
- (get-item-by-id (subseq characteristic-value 1)))))
+ (get-item-by-id (subseq characteristic-value 1)
+ :revision revision))))
(cxml:attribute "href"
(if ref-topic
- (concatenate 'string "#" (topicid ref-topic))
+ (concatenate 'string "#" (topic-id ref-topic revision))
characteristic-value))))
(cxml:with-element "t:resourceData"
(when (slot-boundp characteristic 'datatype)
@@ -82,112 +98,151 @@
(cxml:text characteristic-value)))))
-(defmethod to-elem ((variant VariantC))
+(defmethod to-elem ((variant VariantC) revision)
"variant = element variant { reifiable, scope, (resourceRef | resourceData) }"
(cxml:with-element "t:variant"
- (to-reifier-elem variant)
- (map 'list #'to-elem (item-identifiers variant))
- (when (themes variant)
+ (to-reifier-elem variant revision)
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers variant :revision revision))
+ (when (themes variant :revision revision)
(cxml:with-element "t:scope"
- (map 'list #'ref-to-elem (themes variant))))
- (to-resourceX-elem variant)))
+ (map 'list #'(lambda(x)
+ (ref-to-elem x revision))
+ (themes variant :revision revision))))
+ (to-resourceX-elem variant revision)))
-(defmethod to-elem ((ii ItemIdentifierC))
+(defmethod to-elem ((ii ItemIdentifierC) revision)
"itemIdentity = element itemIdentity { href }"
+ (declare (ignorable revision))
(cxml:with-element "t:itemIdentity"
(cxml:attribute "href" (uri ii))))
-(defmethod to-elem ((occ OccurrenceC))
+(defmethod to-elem ((occ OccurrenceC) revision)
"occurrence = element occurrence { reifiable,
type, scope?, (resourceRef | resourceData) }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:occurrence"
- (to-reifier-elem occ)
- (map 'list #'to-elem (item-identifiers occ))
+ (to-reifier-elem occ revision)
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers occ :revision revision))
(cxml:with-element "t:type"
- (ref-to-elem (instance-of occ)))
+ (ref-to-elem (instance-of occ :revision revision) revision))
(map 'list #'(lambda(x)
(cxml:with-element "t:scope"
- (ref-to-elem x))) (themes occ))
- (to-resourceX-elem occ)))
+ (ref-to-elem x revision))) (themes occ :revision revision))
+ (to-resourceX-elem occ revision)))
-(defmethod to-elem ((locator SubjectLocatorC))
+(defmethod to-elem ((locator SubjectLocatorC) revision)
"subjectLocator = element subjectLocator { href }"
+ (declare (ignorable revision))
(cxml:with-element "t:subjectLocator"
(cxml:attribute "href" (uri locator))))
-(defmethod to-elem ((topic TopicC))
+(defmethod to-elem ((topic TopicC) revision)
"topic = element topic { id,
(itemIdentity | subjectLocator | subjectIdentifier)*,
instanceOf?, (name | occurrence)* }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
- (map 'list #'to-elem (item-identifiers topic))
- (map 'list #'to-elem (locators topic))
- (map 'list #'to-elem (psis topic))
- (when (list-instanceOf topic :tm *export-tm*)
- (cxml:with-element "t:instanceOf"
- (loop for item in (list-instanceOf topic :tm *export-tm*)
- do (cxml:with-element "t:topicRef"
- (cxml:attribute "href" (concatenate 'string "#" (topicid item)))))))
- (map 'list #'to-elem (names topic))
- (map 'list #'to-elem (occurrences topic))))
+ (cxml:attribute "id" (topic-id topic revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers topic :revision revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (locators topic :revision revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (psis topic :revision revision))
+ (let ((ios (list-instanceOf topic :tm *export-tm* :revision revision)))
+ (when ios
+ (cxml:with-element "t:instanceOf"
+ (loop for item in ios
+ do (cxml:with-element "t:topicRef"
+ (cxml:attribute "href" (concatenate 'string "#" (topic-id item revision))))))))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (names topic :revision revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (occurrences topic :revision revision))))
-(defun to-stub-elem (topic)
+(defun to-stub-elem (topic revision)
"transforms a TopicC object to a topic stub element
with a topicid, a subjectLocator and an itemIdentity element"
- (declare (TopicC topic))
+ (declare (TopicC topic)
+ (type (or nil integer) revision))
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
- (map 'list #'to-elem (psis topic))
- (map 'list #'to-elem (item-identifiers topic))
- (map 'list #'to-elem (locators topic))))
+ (cxml:attribute "id" (topic-id topic revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (psis topic :revision revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers topic :revision revision))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (locators topic :revision revision))))
-(defmethod to-elem ((role RoleC))
+(defmethod to-elem ((role RoleC) revision)
"role = element role { reifiable, type, topicRef }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:role"
- (to-reifier-elem role)
- (map 'list #'to-elem (item-identifiers role))
+ (to-reifier-elem role revision)
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers role :revision revision))
(cxml:with-element "t:type"
- (ref-to-elem (instance-of role)))
- (ref-to-elem (player role))))
+ (ref-to-elem (instance-of role) revision))
+ (ref-to-elem (player role :revision revision) revision)))
-(defmethod to-elem ((assoc AssociationC))
+(defmethod to-elem ((assoc AssociationC) revision)
"association = element association { reifiable, type, scope?, role+ }"
+ (declare (type (or integer nil) revision))
(cxml:with-element "t:association"
- (to-reifier-elem assoc)
- (map 'list #'to-elem (item-identifiers assoc))
+ (to-reifier-elem assoc revision)
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (item-identifiers assoc :revision revision))
(cxml:with-element "t:type"
- (ref-to-elem (instance-of assoc)))
- (when (themes assoc)
+ (ref-to-elem (instance-of assoc :revision revision) revision))
+ (when (themes assoc :revision revision)
(cxml:with-element "t:scope"
- (map 'list #'ref-to-elem (themes assoc))))
- (map 'list #'to-elem (roles assoc))))
-
+ (map 'list #'(lambda(x)
+ (ref-to-elem x revision))
+ (themes assoc :revision revision))))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (roles assoc :revision revision))))
-(defmethod to-elem ((fragment FragmentC))
+(defmethod to-elem ((fragment FragmentC) revision)
"transforms all sub-elements of the passed FragmentC instance"
- (to-elem (topic fragment))
- (map 'list #'to-stub-elem (referenced-topics fragment))
- (map 'list #'to-elem (associations fragment)))
+ (declare (type (or integer nil) revision))
+ (to-elem (topic fragment) revision)
+ (map 'list #'(lambda(x)
+ (to-stub-elem x revision))
+ (referenced-topics fragment))
+ (map 'list #'(lambda(x)
+ (to-elem x revision))
+ (associations fragment)))
-(defgeneric to-string (construct)
+(defgeneric to-string (construct &key revision)
(:documentation "Print the string representation of a TM element"))
-
-(defmethod to-string ((construct TopicMapConstructC))
+(defmethod to-string ((construct TopicMapConstructC) &key (revision *TM-REVISION*))
(cxml:with-xml-output (cxml:make-string-sink :indentation 2 :canonical nil)
(cxml:with-namespace ("t" *xtm2.0-ns*)
- ;(sb-pcl:class-slots (find-class 'PersistentIdC))
- ;(format t "~a" (length (dom:child-nodes (to-elem construct))))
- (to-elem construct))))
+ (to-elem construct revision))))
Modified: trunk/src/xml/xtm/importer.lisp
==============================================================================
--- trunk/src/xml/xtm/importer.lisp (original)
+++ trunk/src/xml/xtm/importer.lisp Sun Oct 10 05:41:19 2010
@@ -23,7 +23,9 @@
*instance-psi*
*XTM2.0-NS*
*XTM1.0-NS*
- *XTM1.0-XLINK*)
+ *XTM1.0-XLINK*
+ *XML-STRING*
+ *XML-URI*)
(:import-from :xml-constants
*core_psis.xtm*)
(:import-from :xml-tools
@@ -94,32 +96,30 @@
(error "cannot handle topicrefs that don't start with #"))
(subseq topicref 1)))
-(defun get-topicid-by-psi (uri &key (xtm-id d:*current-xtm*))
+(defun get-topicid-by-psi (uri &key (xtm-id d:*current-xtm*) (revision *TM-REVISION*))
(when uri
(loop for item in
(topic-identifiers
- (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri uri)))
+ (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri uri)) :revision revision)
when (string= xtm-id (xtm-id item))
return (uri item))))
+
(defmacro with-tm ((revision xtm-id tm-id) &body body)
"creates a topic map object called tm and puts it into the local scope"
- `(let
- ((ii (make-instance 'ItemIdentifierC
- :uri ,tm-id
- :start-revision ,revision)))
- ;(add-to-version-history ii :start-revision ,revision)
- (let
- ((tm
- (make-construct 'TopicMapC
- :start-revision ,revision
- :xtm-id ,xtm-id
- :item-identifiers (list ii))))
+ `(let ((ii (make-construct 'ItemIdentifierC
+ :uri ,tm-id
+ :start-revision ,revision)))
+ (let ((tm
+ (make-construct 'TopicMapC
+ :start-revision ,revision
+ :xtm-id ,xtm-id
+ :item-identifiers (list ii))))
(declare (ItemIdentifierC ii))
(declare (TopicMapC tm))
-
, at body)))
-
+
+
(defun init-isidorus (&optional (revision (get-revision)))
"Initiatlize the database with the stubs of the core topics + PSIs
defined in the XTM 1.0 spec. This includes a topic that represents the
@@ -136,7 +136,7 @@
(let
((top
(from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm")))
- (add-to-topicmap tm top)))))))
+ (add-to-tm tm top)))))))
;TODO: replace the two importers with this macro
(defmacro importer-mac
@@ -172,25 +172,23 @@
(declare (TopicMapC tm))
(let
((associationtype
- (get-item-by-psi *type-instance-psi*))
+ (get-item-by-psi *type-instance-psi* :revision start-revision))
(roletype1
- (get-item-by-psi *type-psi*))
+ (get-item-by-psi *type-psi* :revision start-revision))
(roletype2
- (get-item-by-psi *instance-psi*))
+ (get-item-by-psi *instance-psi* :revision start-revision))
(player1
(get-item-by-id topicid-of-supertype
:xtm-id xtm-id
:revision start-revision)))
-
(unless (and associationtype roletype1 roletype2)
(error "Error in the creation of an instanceof association: core topics are missing"))
-
(unless player1
(error
(make-condition 'missing-reference-error
:message "could not find type topic (first player)"
:reference topicid-of-supertype)))
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct
'AssociationC
@@ -198,5 +196,9 @@
:themes nil
:start-revision start-revision
:instance-of associationtype
- :roles (list (list :instance-of roletype1 :player player1)
- (list :instance-of roletype2 :player player2-obj))))))
+ :roles (list (list :start-revision start-revision
+ :instance-of roletype1
+ :player player1)
+ (list :start-revision start-revision
+ :instance-of roletype2
+ :player player2-obj))))))
Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp
==============================================================================
--- trunk/src/xml/xtm/importer_xtm1.0.lisp (original)
+++ trunk/src/xml/xtm/importer_xtm1.0.lisp Sun Oct 10 05:41:19 2010
@@ -9,7 +9,7 @@
(in-package :xml-importer)
-(defun get-reifier-topic-xtm1.0 (reifiable-elem)
+(defun get-reifier-topic-xtm1.0 (reifiable-elem start-revision)
"Returns a reifier topic of the reifiable-element or nil."
(declare (dom:element reifiable-elem))
(let ((reifier-uri
@@ -21,7 +21,7 @@
(elephant:get-instance-by-value 'd:PersistentIdC 'd:uri
(concatenate 'string "#" reifier-uri))))
(when psi
- (let ((reifier-topic (identified-construct psi)))
+ (let ((reifier-topic (identified-construct psi :revision start-revision)))
(when reifier-topic
reifier-topic)))))))
@@ -56,8 +56,8 @@
(let ((data-elem (xpath-single-child-elem-by-qname parent-elem *xtm1.0-ns* "resourceData")))
(declare (dom:element parent-elem))
(if data-elem
- "http://www.w3.org/2001/XMLSchema#string"
- "http://www.w3.org/2001/XMLSchema#anyURI"))))
+ *XML-STRING*
+ *XML-URI*))))
(unless data
(error "from-resourceX-elem-xtm1.0: one of resourceRef or resourceData must be set"))
(list :data data :type type))))
@@ -68,7 +68,6 @@
variant = element variant { parameters, variantName?, variant* }"
(declare (dom:element variant-elem))
(declare (CharacteristicC parent-construct)) ;;parent name or parent variant object
- (declare (optimize (debug 3)))
(let ((parameters
(remove-duplicates
(remove-if #'null
@@ -76,17 +75,17 @@
(from-parameters-elem-xtm1.0
(xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "parameters")
start-revision :xtm-id xtm-id)
- (themes parent-construct)))))
+ (themes parent-construct :revision start-revision)))))
(variantName (from-resourceX-elem-xtm1.0
(xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "variantName")))
(parent-name (cond
((typep parent-construct 'NameC)
parent-construct)
((typep parent-construct 'VariantC)
- (name parent-construct))
+ (parent parent-construct))
(t
(error "from-variant-elem-xtm1.0: parent-construct is neither NameC nor VariantC"))))
- (reifier-topic (get-reifier-topic-xtm1.0 variant-elem)))
+ (reifier-topic (get-reifier-topic-xtm1.0 variant-elem start-revision)))
(unless (and variantName parameters)
(error "from-variant-elem-xtm1.0: parameters and variantName must be set"))
(let ((variant (make-construct 'VariantC
@@ -95,7 +94,7 @@
:charvalue (getf variantName :data)
:datatype (getf variantName :type)
:reifier reifier-topic
- :name parent-name)))
+ :parent parent-name)))
(let ((inner-variants
(map 'list #'(lambda(x)
(from-variant-elem-xtm1.0 x variant start-revision :xtm-id xtm-id))
@@ -110,15 +109,18 @@
(let ((parameters
(let ((topicRefs
(map 'list #'from-topicRef-elem-xtm1.0
- (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* "topicRef")))
+ (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns*
+ "topicRef")))
(subjectIndicatorRefs
(map 'list #'(lambda(x)
(get-xlink-attribute x "href"))
- (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* "subjectIndicatorRef"))))
+ (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns*
+ "subjectIndicatorRef"))))
(let ((topic-list
(append
(map 'list #'(lambda(x)
- (get-item-by-id x :xtm-id xtm-id :revision start-revision))
+ (get-item-by-id x :xtm-id xtm-id
+ :revision start-revision))
topicRefs)
(map 'list #'(lambda(x)
(get-item-by-psi x :revision start-revision))
@@ -146,16 +148,15 @@
(let ((themes (when (xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "scope")
(from-scope-elem-xtm1.0
(xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "scope")
- :xtm-id xtm-id)))
+ start-revision :xtm-id xtm-id)))
(baseNameString (xpath-fn-string
(xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "baseNameString")))
- (reifier-topic (get-reifier-topic-xtm1.0 baseName-elem)))
+ (reifier-topic (get-reifier-topic-xtm1.0 baseName-elem start-revision)))
(unless baseNameString
(error "A baseName must have exactly one baseNameString"))
-
(let ((name (make-construct 'NameC
:start-revision start-revision
- :topic top
+ :parent top
:charvalue baseNameString
:reifier reifier-topic
:themes themes)))
@@ -182,41 +183,61 @@
(when parent-elem
(let ((instanceOf-elems (xpath-child-elems-by-qname parent-elem *xtm1.0-ns* "instanceOf")))
(when (> (length instanceOf-elems) 0)
- (let ((topicRefs (map 'list #'(lambda(x)
- (when (xpath-single-child-elem-by-qname x *xtm1.0-ns* "topicRef")
- (from-topicRef-elem-xtm1.0
- (xpath-single-child-elem-by-qname x *xtm1.0-ns* "topicRef"))))
+ (let ((topicRefs
+ (map 'list #'(lambda(x)
+ (when (xpath-single-child-elem-by-qname
+ x *xtm1.0-ns* "topicRef")
+ (from-topicRef-elem-xtm1.0
+ (xpath-single-child-elem-by-qname x *xtm1.0-ns*
+ "topicRef"))))
instanceOf-elems))
- (subjectIndicatorRefs (map 'list #'(lambda(x)
- (when (xpath-single-child-elem-by-qname
- x *xtm1.0-ns* "subjectIndicatorRef")
- (get-xlink-attribute
- (xpath-single-child-elem-by-qname
- x *xtm1.0-ns* "subjectIndicatorRef") "href")))
- instanceOf-elems)))
- (let ((ids (remove-if #'null(append
- (map 'list #'(lambda(x)
- (get-topicid-by-psi x :xtm-id xtm-id))
- subjectIndicatorRefs)
- topicRefs))))
+ (subjectIndicatorRefs
+ (map 'list #'(lambda(x)
+ (when (xpath-single-child-elem-by-qname
+ x *xtm1.0-ns* "subjectIndicatorRef")
+ (get-xlink-attribute
+ (xpath-single-child-elem-by-qname
+ x *xtm1.0-ns* "subjectIndicatorRef") "href")))
+ instanceOf-elems)))
+ (let ((ids
+ (remove-if #'null
+ (append
+ (map 'list #'(lambda(x)
+ (get-topicid-by-psi x :xtm-id xtm-id))
+ subjectIndicatorRefs)
+ topicRefs))))
(declare (dom:element parent-elem))
ids))))))
-(defun from-roleSpec-elem-xtm1.0 (roleSpec-elem &key (xtm-id *current-xtm*))
+(defun from-roleSpec-elem-xtm1.0 (roleSpec-elem start-revision
+ &key (xtm-id *current-xtm*))
"returns the referenced topic of the roleSpec's topicRef and subjectIndicatorRef element."
(when roleSpec-elem
- (let ((top-id (when (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* "topicRef")
- (from-topicRef-elem-xtm1.0
- (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* "topicRef"))))
- (sIRs (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id))
+ (let ((top-id
+ (when (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns*
+ "topicRef")
+ (from-topicRef-elem-xtm1.0
+ (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns*
+ "topicRef"))))
+ (sIRs (map 'list #'(lambda(uri)
+ (get-topicid-by-psi uri :xtm-id xtm-id
+ :revision start-revision))
(map 'list #'(lambda(x)
(dom:get-attribute-ns x *xtm1.0-xlink* "href"))
- (xpath-child-elems-by-qname roleSpec-elem *xtm1.0-ns* "subjectIndicatorRef")))))
- (let ((ref-topic (first (remove-if #'null
- (append
- (list (get-item-by-id top-id :xtm-id xtm-id))
- (map 'list #'(lambda(id)(get-item-by-id id :xtm-id xtm-id)) sIRs))))))
+ (xpath-child-elems-by-qname roleSpec-elem *xtm1.0-ns*
+ "subjectIndicatorRef")))))
+ (let ((ref-topic
+ (first (remove-if #'null
+ (append
+ (when top-id
+ (list (get-item-by-id top-id :xtm-id xtm-id
+ :revision start-revision)))
+ (map 'list #'(lambda(id)
+ (get-item-by-id
+ id :xtm-id xtm-id
+ :revision start-revision))
+ sIRs))))))
(declare (dom:element roleSpec-elem))
(unless ref-topic
(error (make-condition 'missing-reference-error
@@ -224,21 +245,26 @@
ref-topic))))
-(defun from-scope-elem-xtm1.0 (scope-elem &key (xtm-id *current-xtm*))
+(defun from-scope-elem-xtm1.0 (scope-elem start-revision &key (xtm-id *current-xtm*))
"returns the topics referenced by this scope element.
the nested elements resourceRef and subjectIndicatorRef are ignored"
(when scope-elem
(when (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "topicRef")
(let ((refs
(append (map 'list #'from-topicRef-elem-xtm1.0
- (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "topicRef"))
+ (xpath-child-elems-by-qname scope-elem *xtm1.0-ns*
+ "topicRef"))
(map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id))
(map 'list #'(lambda(x)
- (dom:get-attribute-ns x *xtm1.0-xlink* "href"))
- (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "subjectIndicatorRef"))))))
+ (dom:get-attribute-ns x *xtm1.0-xlink*
+ "href"))
+ (xpath-child-elems-by-qname scope-elem *xtm1.0-ns*
+ "subjectIndicatorRef"))))))
(let ((ref-topics (map 'list
#'(lambda(x)
- (let ((ref-topic (get-item-by-id x :xtm-id xtm-id)))
+ (let ((ref-topic
+ (get-item-by-id x :xtm-id xtm-id
+ :revision start-revision)))
(if ref-topic
ref-topic
(error (make-condition 'missing-reference-error
@@ -258,21 +284,26 @@
(declare (integer start-revision))
(let*
((instanceOf (when (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id)
- (get-item-by-id (first (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id)) :xtm-id xtm-id)))
+ (get-item-by-id
+ (first (get-instanceOf-refs-xtm1.0 occ-elem
+ :xtm-id xtm-id))
+ :xtm-id xtm-id :revision start-revision)))
(themes (from-scope-elem-xtm1.0
(xpath-single-child-elem-by-qname occ-elem *xtm1.0-ns* "scope")
- :xtm-id xtm-id))
+ start-revision :xtm-id xtm-id))
(occurrence-value
(from-resourceX-elem-xtm1.0 occ-elem))
- (reifier-topic (get-reifier-topic-xtm1.0 occ-elem)))
+ (reifier-topic (get-reifier-topic-xtm1.0 occ-elem start-revision)))
(unless occurrence-value
(error "from-occurrence-elem-xtm1.0: one of resourceRef and resourceData must be set"))
(unless instanceOf
- (format t "from-occurrence-elem-xtm1.0: type is missing -> http://psi.topicmaps.org/iso13250/model/type-instance~%")
- (setf instanceOf (get-item-by-id "type-instance" :xtm-id "core.xtm")))
+ (format t "from-occurrence-elem-xtm1.0: type is missing -> ~a~%"
+ *type-instance-psi*)
+ (setf instanceOf (get-item-by-psi *type-instance-psi*
+ :revision start-revision)))
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes themes
:instance-of instanceOf
:charvalue (getf occurrence-value :data)
@@ -283,60 +314,75 @@
(defun from-subjectIdentity-elem-xtm1.0 (subjectIdentity-elem start-revision)
"creates PersistentIdC's from the element subjectIdentity"
(when subjectIdentity-elem
- (let ((psi-refs (map 'list #'(lambda(x)
- (get-xlink-attribute x "href"))
- (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* "subjectIndicatorRef")))
- (locator-refs (map 'list #'(lambda(x)
- (get-xlink-attribute x "href"))
- (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* "resourceRef"))))
-
- (let ((psis (map 'list #'(lambda(uri)
- (let ((id (make-instance 'PersistentIdC
- :uri uri
- :start-revision start-revision)))
- ;(add-to-version-history id :start-revision start-revision)
- id))
- psi-refs))
- (locators (map 'list #'(lambda(uri)
- (let ((loc (make-instance 'SubjectLocatorC
- :uri uri
- :start-revision start-revision)))
- ;(add-to-version-history loc :start-revision start-revision)
- loc))
+ (let ((psi-refs
+ (map 'list #'(lambda(x)
+ (get-xlink-attribute x "href"))
+ (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns*
+ "subjectIndicatorRef")))
+ (locator-refs
+ (map 'list #'(lambda(x)
+ (get-xlink-attribute x "href"))
+ (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns*
+ "resourceRef"))))
+ (let ((psis
+ (map 'list #'(lambda(uri)
+ (let ((id
+ (make-construct 'PersistentIdC
+ :uri uri
+ :start-revision start-revision)))
+ id))
+ psi-refs))
+ (locators (map 'list
+ #'(lambda(uri)
+ (let ((loc
+ (make-construct 'SubjectLocatorC
+ :uri uri
+ :start-revision start-revision)))
+ loc))
locator-refs)))
(declare (dom:element subjectIdentity-elem))
(declare (integer start-revision))
(list :psis psis :locators locators)))))
-(defun from-member-elem-xtm1.0 (member-elem &key (xtm-id *current-xtm*))
+(defun from-member-elem-xtm1.0 (member-elem start-revision
+ &key (xtm-id *current-xtm*))
"returns a list with the role- type, player and itemIdentities"
(when member-elem
(elephant:ensure-transaction (:txn-nosync t)
- (let
- ((type (from-rolespec-elem-xtm1.0 (xpath-single-child-elem-by-qname member-elem *xtm1.0-ns* "roleSpec") :xtm-id xtm-id))
- (player (remove-if #'null
- (append
- (list (get-item-by-id (from-topicRef-elem-xtm1.0
- (xpath-single-child-elem-by-qname
- member-elem
- *xtm1.0-ns*
- "topicRef"))
- :xtm-id xtm-id))
- (map 'list #'(lambda(topicid)
- (get-item-by-id topicid :xtm-id xtm-id))
- (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id))
- (map 'list #'(lambda(x)
- (get-xlink-attribute x "href"))
- (xpath-child-elems-by-qname
- member-elem
- *xtm1.0-ns*
- "subjectIndicatorRef")))))))
- (reifier-topic (get-reifier-topic-xtm1.0 member-elem)))
+ (let ((type (from-roleSpec-elem-xtm1.0
+ (xpath-single-child-elem-by-qname member-elem *xtm1.0-ns*
+ "roleSpec")
+ start-revision :xtm-id xtm-id))
+ (player
+ (let ((topicRef
+ (from-topicRef-elem-xtm1.0 (xpath-single-child-elem-by-qname
+ member-elem *xtm1.0-ns* "topicRef")))
+ (sIRs (xpath-child-elems-by-qname
+ member-elem *xtm1.0-ns* "subjectIndicatorRef")))
+ (remove-if
+ #'null
+ (append
+ (when topicRef
+ (list (get-item-by-id topicRef
+ :xtm-id xtm-id
+ :revision start-revision)))
+ (map 'list #'(lambda(topicid)
+ (get-item-by-id
+ topicid
+ :xtm-id xtm-id
+ :revision start-revision))
+ (map 'list #'(lambda(uri)
+ (get-topicid-by-psi uri :xtm-id xtm-id))
+ (map 'list #'(lambda(x)
+ (get-xlink-attribute x "href"))
+ sIRs)))))))
+ (reifier-topic (get-reifier-topic-xtm1.0 member-elem start-revision)))
(declare (dom:element member-elem))
(unless player ; if no type is given a standard type will be assigend later in from-assoc...
(error "from-member-elem-xtm1.0: missing player in role"))
- (list :instance-of type
+ (list :start-revision start-revision
+ :instance-of type
:player (first player)
:item-identifiers nil
:reifier reifier-topic)))))
@@ -347,19 +393,22 @@
(xtm-id *current-xtm*))
"creates a TopicC instance with a start-revision, all psis, the topicid and the xtm-id"
(declare (dom:element topic-elem))
- (declare (integer start-revision))
- ;(declare (optimize (debug 3)))
+ (declare (integer start-revision))
(elephant:ensure-transaction (:txn-nosync t)
- (let ((identifiers (from-subjectIdentity-elem-xtm1.0 (xpath-single-child-elem-by-qname
- topic-elem
- *xtm1.0-ns*
- "subjectIdentity")
- start-revision)))
+ (let ((identifiers (from-subjectIdentity-elem-xtm1.0
+ (xpath-single-child-elem-by-qname
+ topic-elem
+ *xtm1.0-ns*
+ "subjectIdentity")
+ start-revision))
+ (topic-identifiers
+ (list (make-construct 'TopicIdentificationC
+ :uri (get-topic-id-xtm1.0 topic-elem)
+ :xtm-id xtm-id))))
(make-construct 'TopicC :start-revision start-revision
:psis (getf identifiers :psis)
:locators (getf identifiers :locators)
- :topicid (get-topic-id-xtm1.0 topic-elem)
- :xtm-id xtm-id))))
+ :topic-identifiers topic-identifiers))))
(defun merge-topic-elem-xtm1.0 (topic-elem start-revision
@@ -372,16 +421,20 @@
(declare (integer start-revision))
(declare (TopicMapC tm))
(elephant:ensure-transaction (:txn-nosync t)
- (let
- ((top
- (get-item-by-id
- (get-topic-id-xtm1.0 topic-elem)
- :xtm-id xtm-id :revision start-revision))
- (instanceOf-topicRefs (remove-if #'null (get-instanceOf-refs-xtm1.0 topic-elem :xtm-id xtm-id)))
- (baseName-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "baseName"))
- (occ-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "occurrence")))
+ (let ((top
+ (get-item-by-id
+ (get-topic-id-xtm1.0 topic-elem)
+ :xtm-id xtm-id :revision start-revision))
+ (instanceOf-topicRefs
+ (remove-if #'null (get-instanceOf-refs-xtm1.0 topic-elem
+ :xtm-id xtm-id)))
+ (baseName-elems
+ (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "baseName"))
+ (occ-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "occurrence")))
(unless top
- (error "topic ~a could not be found" (get-attribute topic-elem "id")))
+ (error (make-condition 'missing-reference-error
+ :message (format nil "topic ~a could not be found"
+ (get-attribute topic-elem "id")))))
;;names
(map 'list #'(lambda(x)
(from-baseName-elem-xtm1.0 x top start-revision :xtm-id xtm-id))
@@ -392,45 +445,49 @@
occ-elems)
;;instanceOf
(dolist (instanceOf-topicRef instanceOf-topicRefs)
- (create-instanceof-association instanceOf-topicRef top start-revision :xtm-id xtm-id
- :tm tm))
- (add-to-topicmap tm top))))
+ (create-instanceof-association instanceOf-topicRef top start-revision
+ :xtm-id xtm-id :tm tm))
+ (add-to-tm tm top))))
-(defun from-association-elem-xtm1.0 (assoc-elem start-revision &key tm (xtm-id *current-xtm*))
+(defun from-association-elem-xtm1.0 (assoc-elem start-revision
+ &key tm (xtm-id *current-xtm*))
(declare (dom:element assoc-elem))
(declare (integer start-revision))
(declare (TopicMapC tm))
(elephant:ensure-transaction (:txn-nosync t)
(let ((type (when (get-instanceOf-refs-xtm1.0 assoc-elem :xtm-id xtm-id)
- (get-item-by-id (first (get-instanceOf-refs-xtm1.0 assoc-elem :xtm-id xtm-id)) :xtm-id xtm-id)))
+ (get-item-by-id (first (get-instanceOf-refs-xtm1.0 assoc-elem
+ :xtm-id xtm-id))
+ :xtm-id xtm-id
+ :revision start-revision)))
(themes
(from-scope-elem-xtm1.0
(xpath-single-child-elem-by-qname assoc-elem *xtm1.0-ns* "scope")
- :xtm-id xtm-id))
+ start-revision :xtm-id xtm-id))
(roles (map 'list
#'(lambda(member-elem)
- (from-member-elem-xtm1.0
- member-elem :xtm-id xtm-id))
+ (from-member-elem-xtm1.0 member-elem start-revision
+ :xtm-id xtm-id))
(xpath-child-elems-by-qname assoc-elem *xtm1.0-ns* "member")))
- (reifier-topic (get-reifier-topic-xtm1.0 assoc-elem)))
+ (reifier-topic (get-reifier-topic-xtm1.0 assoc-elem start-revision)))
(unless roles
(error "from-association-elem-xtm1.0: roles are missing in association"))
- (setf roles (set-standard-role-types roles))
+ (setf roles (set-standard-role-types roles start-revision))
(unless type
(format t "from-association-elem-xtm1.0: type is missing -> http://www.topicmaps.org/xtm/1.0/core.xtm#association~%")
- (setf type (get-item-by-id "association" :xtm-id "core.xtm")))
- (add-to-topicmap tm
- (make-construct 'AssociationC
- :start-revision start-revision
- :instance-of type
- :themes themes
- :reifier reifier-topic
- :roles roles)))))
-
-
+ (setf type (get-item-by-id "association" :xtm-id "core.xtm"
+ :revision start-revision)))
+ (add-to-tm tm
+ (make-construct 'AssociationC
+ :start-revision start-revision
+ :instance-of type
+ :themes themes
+ :reifier reifier-topic
+ :roles roles)))))
+
-(defun set-standard-role-types (roles)
+(defun set-standard-role-types (roles start-revision)
"sets the missing role types of the passed roles to the default types."
(when roles
(let ((empty-roles (loop for role in roles
@@ -440,22 +497,25 @@
(let ((is-type (loop for role in roles
when (and (getf role :instance-of)
(loop for psi in (psis (getf role :instance-of))
- when (string= (uri psi)
- "http://psi.topicmaps.org/iso13250/model/type")
+ when (string= (uri psi) *type-psi*)
return t))
return t)))
(declare (list roles))
(when (not is-type)
(loop for role in roles
when (not (getf role :instance-of))
- do (setf (getf role :instance-of) (get-item-by-id "type" :xtm-id "core.xtm"))
- (format t "set-standard-role-types: role type is missing -> http://psi.topicmaps.org/iso13250/model/type~%")
+ do (setf (getf role :instance-of)
+ (get-item-by-psi *type-psi* :revision start-revision))
+ (format t "set-standard-role-types: role type is missing -> ~a~%"
+ *type-psi*)
(return t)))
(when (or (> (length empty-roles) 1) (and empty-roles (not is-type)))
(loop for role in roles
when (not (getf role :instance-of))
- do (setf (getf role :instance-of) (get-item-by-id "instance" :xtm-id "core.xtm"))
- (format t "set-standard-role-types: role type is missing -> http://psi.topicmaps.org/iso13250/model/instance~%"))))))
+ do (setf (getf role :instance-of)
+ (get-item-by-psi *instance-psi* :revision start-revision))
+ (format t "set-standard-role-types: role type is missing -> ~a~%"
+ *instance-psi*))))))
roles))
Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp
==============================================================================
--- trunk/src/xml/xtm/importer_xtm2.0.lisp (original)
+++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sun Oct 10 05:41:19 2010
@@ -9,7 +9,7 @@
(in-package :xml-importer)
-(defun get-reifier-topic(reifiable-elem)
+(defun get-reifier-topic(reifiable-elem start-revision)
"Returns the reifier topic of the reifierable-element or nil."
(declare (dom:element reifiable-elem))
(let ((reifier-uri (get-attribute reifiable-elem "reifier"))
@@ -19,7 +19,7 @@
(let ((ii
(elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri reifier-uri)))
(if ii
- (let ((reifier-topic (identified-construct ii)))
+ (let ((reifier-topic (identified-construct ii :revision start-revision)))
(if reifier-topic
reifier-topic
(error "~aitem-identifier ~a not found" err reifier-uri)))
@@ -34,7 +34,7 @@
(declare (dom:element elem))
(declare (integer start-revision))
(let
- ((id (make-instance classsymbol
+ ((id (make-construct classsymbol
:uri (get-attribute elem "href")
:start-revision start-revision)))
id))
@@ -49,7 +49,7 @@
*xtm2.0-ns* elem-name)))
-(defun from-type-elem (type-elem &key (xtm-id *current-xtm*))
+(defun from-type-elem (type-elem start-revision &key (xtm-id *current-xtm*))
"Returns the topic that reifies this type or nil if no element is
input"
; type = element type { topicRef }
@@ -62,7 +62,7 @@
(xpath-single-child-elem-by-qname
type-elem
*xtm2.0-ns* "topicRef")))
- (top (get-item-by-id topicid :xtm-id xtm-id)))
+ (top (get-item-by-id topicid :xtm-id xtm-id :revision start-revision)))
(declare (dom:element type-elem))
(unless top
(error (make-condition 'missing-reference-error
@@ -70,7 +70,7 @@
top)))
-(defun from-scope-elem (scope-elem &key (xtm-id *current-xtm*))
+(defun from-scope-elem (scope-elem start-revision &key (xtm-id *current-xtm*))
"Generate set of themes (= topics) from this scope element and
return that set. If the input is nil, the list of themes is empty
scope = element scope { topicRef+ }"
@@ -89,15 +89,14 @@
(lambda (topicid)
(let
((top
- (get-item-by-id
- topicid :xtm-id xtm-id)))
+ (get-item-by-id topicid :xtm-id xtm-id
+ :revision start-revision)))
(if top
top
(error (make-condition 'missing-reference-error
:message (format nil "from-scope-elem: could not resolve reference ~a" topicid))))))
topicrefs)))
(declare (dom:element scope-elem))
-
(unless (>= (length tops) 1)
(error "need at least one topic in a scope"))
tops)))
@@ -121,19 +120,18 @@
(themes
(from-scope-elem
(xpath-single-child-elem-by-qname
- name-elem
- *xtm2.0-ns* "scope") :xtm-id xtm-id))
+ name-elem *xtm2.0-ns* "scope")
+ start-revision :xtm-id xtm-id))
(instance-of
(from-type-elem (xpath-single-child-elem-by-qname
name-elem
- *xtm2.0-ns* "type") :xtm-id xtm-id))
- (reifier-topic (get-reifier-topic name-elem)))
+ *xtm2.0-ns* "type") start-revision :xtm-id xtm-id))
+ (reifier-topic (get-reifier-topic name-elem start-revision)))
(unless namevalue
(error "A name must have exactly one namevalue"))
-
(let ((name (make-construct 'NameC
:start-revision start-revision
- :topic top
+ :parent top
:charvalue namevalue
:instance-of instance-of
:item-identifiers item-identifiers
@@ -188,13 +186,13 @@
((item-identifiers (make-identifiers 'ItemIdentifierC variant-elem "itemIdentity" start-revision))
;;all themes of the parent name element are inherited to the variant elements
(themes (append
- (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") :xtm-id xtm-id)
- (themes name)))
+ (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope")
+ start-revision :xtm-id xtm-id)
+ (themes name :revision start-revision)))
(variant-value (from-resourceX-elem variant-elem))
- (reifier-topic (get-reifier-topic variant-elem)))
+ (reifier-topic (get-reifier-topic variant-elem start-revision)))
(unless variant-value
(error "VariantC: one of resourceRef and resourceData must be set"))
-
(make-construct 'VariantC
:start-revision start-revision
:item-identifiers item-identifiers
@@ -202,7 +200,7 @@
:charvalue (getf variant-value :data)
:datatype (getf variant-value :type)
:reifier reifier-topic
- :name name)))
+ :parent name)))
(defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*))
@@ -212,25 +210,23 @@
(declare (dom:element occ-elem))
(declare (TopicC top))
(declare (integer start-revision))
-
(let
((themes
(from-scope-elem (xpath-single-child-elem-by-qname
- occ-elem
- *xtm2.0-ns* "scope")))
+ occ-elem *xtm2.0-ns* "scope") start-revision :xtm-id xtm-id))
(item-identifiers
(make-identifiers 'ItemIdentifierC occ-elem "itemIdentity" start-revision))
(instance-of
(from-type-elem (xpath-single-child-elem-by-qname
occ-elem
- *xtm2.0-ns* "type") :xtm-id xtm-id))
+ *xtm2.0-ns* "type") start-revision :xtm-id xtm-id))
(occurrence-value (from-resourceX-elem occ-elem))
- (reifier-topic (get-reifier-topic occ-elem)))
+ (reifier-topic (get-reifier-topic occ-elem start-revision)))
(unless occurrence-value
(error "OccurrenceC: one of resourceRef and resourceData must be set"))
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes themes
:item-identifiers item-identifiers
:instance-of instance-of
@@ -248,7 +244,6 @@
applicable"
(declare (dom:element topic-elem))
(declare (integer start-revision))
- ;(declare (optimize (debug 3)))
(elephant:ensure-transaction (:txn-nosync t)
(let
((itemidentifiers
@@ -256,32 +251,30 @@
(subjectidentifiers
(make-identifiers 'PersistentIdC topic-elem "subjectIdentifier" start-revision))
(subjectlocators
- (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision)))
+ (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision))
+ (topic-ids (when (get-attribute topic-elem "id")
+ (list (make-construct 'TopicIdentificationC
+ :uri (get-attribute topic-elem "id")
+ :xtm-id xtm-id)))))
(make-construct 'TopicC
:start-revision start-revision
:item-identifiers itemidentifiers
:locators subjectlocators
:psis subjectidentifiers
- :topicid (get-attribute topic-elem "id")
- :xtm-id xtm-id))))
+ :topic-identifiers topic-ids))))
(defun merge-topic-elem (topic-elem start-revision
- &key
- tm
- (xtm-id *current-xtm*))
+ &key tm (xtm-id *current-xtm*))
"Adds further elements (names, occurrences) and instanceOf
associations to the topic"
- ;TODO: solve merging through reifying
(declare (dom:element topic-elem))
(declare (integer start-revision))
(declare (TopicMapC tm))
- ;(format t "xtm-id: ~a current-xtm: ~a revision: ~a~&" xtm-id *current-xtm* start-revision)
(elephant:ensure-transaction (:txn-nosync t)
(let
((top ;retrieve the already existing topic stub
- (get-item-by-id
- (get-attribute topic-elem "id")
+ (get-item-by-id (get-attribute topic-elem "id")
:xtm-id xtm-id :revision start-revision)))
(let
((instanceof-topicrefs
@@ -292,7 +285,8 @@
'((*xtm2.0-ns* "instanceOf")
(*xtm2.0-ns* "topicRef"))))))
(unless top
- (error "topic ~a could not be found" (get-attribute topic-elem "id")))
+ (error "topic ~a could not be found (xtm-id: ~a, revision: ~a)"
+ (get-attribute topic-elem "id") xtm-id start-revision))
(map 'list
(lambda
(name-elem)
@@ -313,7 +307,7 @@
(create-instanceof-association topicref top start-revision
:tm tm
:xtm-id xtm-id))
- (add-to-topicmap tm top)
+ (add-to-tm tm top)
top))))
@@ -330,24 +324,22 @@
(instance-of
(from-type-elem
(xpath-single-child-elem-by-qname
- role-elem
- *xtm2.0-ns*
- "type") :xtm-id xtm-id))
+ role-elem *xtm2.0-ns* "type")
+ start-revision :xtm-id xtm-id))
(player
- (get-item-by-id
- (get-topicref-uri
- (xpath-single-child-elem-by-qname
- role-elem
- *xtm2.0-ns*
- "topicRef")) :xtm-id xtm-id))
- (reifier-topic (get-reifier-topic role-elem)))
+ (get-item-by-id (get-topicref-uri
+ (xpath-single-child-elem-by-qname
+ role-elem *xtm2.0-ns* "topicRef"))
+ :xtm-id xtm-id :revision start-revision))
+ (reifier-topic (get-reifier-topic role-elem start-revision)))
(unless player ;instance-of will be set later - if there is no one
(error "Role in association with topicref ~a not complete" (get-topicref-uri
(xpath-single-child-elem-by-qname
role-elem
*xtm2.0-ns*
"topicRef"))))
- (list :reifier reifier-topic
+ (list :start-revision start-revision
+ :reifier reifier-topic
:instance-of instance-of
:player player
:item-identifiers item-identifiers))))
@@ -363,19 +355,18 @@
(declare (integer start-revision))
(declare (TopicMapC tm))
(elephant:ensure-transaction (:txn-nosync t)
- (let
- ((item-identifiers
+ (let
+ ((item-identifiers
(make-identifiers 'ItemIdentifierC assoc-elem "itemIdentity" start-revision))
(instance-of
(from-type-elem
(xpath-single-child-elem-by-qname
- assoc-elem
- *xtm2.0-ns* "type") :xtm-id xtm-id))
+ assoc-elem *xtm2.0-ns* "type")
+ start-revision :xtm-id xtm-id))
(themes
(from-scope-elem
- (xpath-single-child-elem-by-qname
- assoc-elem
- *xtm2.0-ns* "scope")))
+ (xpath-single-child-elem-by-qname assoc-elem *xtm2.0-ns* "scope")
+ start-revision :xtm-id xtm-id))
(roles ;a list of tuples
(map 'list
(lambda
@@ -384,9 +375,9 @@
(xpath-child-elems-by-qname
assoc-elem
*xtm2.0-ns* "role")))
- (reifier-topic (get-reifier-topic assoc-elem)))
- (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them
- (add-to-topicmap
+ (reifier-topic (get-reifier-topic assoc-elem start-revision)))
+ (setf roles (set-standard-role-types roles start-revision)); sets standard role types if there are missing some of them
+ (add-to-tm
tm
(make-construct 'AssociationC
:start-revision start-revision
@@ -415,7 +406,7 @@
(let
((topic-vector (get-topic-elems xtm-dom)))
(loop for top-elem across topic-vector do
- (add-to-topicmap
+ (add-to-tm
tm
(from-topic-elem-to-stub top-elem revision
:xtm-id xtm-id))))))
Modified: trunk/src/xml/xtm/setup.lisp
==============================================================================
--- trunk/src/xml/xtm/setup.lisp (original)
+++ trunk/src/xml/xtm/setup.lisp Sun Oct 10 05:41:19 2010
@@ -22,9 +22,9 @@
importer for the XTM version. Does *not* close the store afterwards"
(declare ((or pathname string) xtm-path))
(declare ((or pathname string) repository-path))
- (let
- ((xtm-dom (dom:document-element (cxml:parse-file
- (truename xtm-path) (cxml-dom:make-dom-builder)))))
+ (let ((xtm-dom (dom:document-element
+ (cxml:parse-file
+ (truename xtm-path) (cxml-dom:make-dom-builder)))))
(unless elephant:*store-controller*
(elephant:open-store
(get-store-spec repository-path)))
@@ -40,7 +40,7 @@
(defun setup-repository (xtm-path repository-path
&key
- tm-id
+ (tm-id (error "you must provide a stable identifier (PSI-style) for this TM"))
(xtm-id (get-uuid))
(xtm-format '2.0))
"Initializes a repository and imports a XTM file into it"
@@ -50,6 +50,6 @@
(elephant:open-store
(get-store-spec repository-path)))
(init-isidorus)
- (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format))
-; (when elephant:*store-controller*
-; (elephant:close-store)))
\ No newline at end of file
+ (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)
+ (when elephant:*store-controller*
+ (elephant:close-store)))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list