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*) - ,@body)) - + ((*TM-REVISION* ,revision)) + ,@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+-+Metadat..." - (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+-+Metadat...") ;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+-+Metadat..."))))))) (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+-+Metadat...") + ((string= + (first topic-psis) + "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadat...") (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+-+Metadat... -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+-+Metadat... + 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 ,@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)) - ,@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