isidorus-cvs

isidorus-cvs@common-lisp.net

1037 discussions

[isidorus-cvs] r304 - in branches/new-datamodel/src: json rest_interface unit_tests
by Lukas Giessmann 23 Jun '10

23 Jun '10

Author: lgiessmann Date: Wed Jun 23 14:00:14 2010 New Revision: 304 Log: new-datamodel: adapted the json im- and exporter to the new datamodel --> the unit-tests must be changed Modified: branches/new-datamodel/src/json/json_exporter.lisp branches/new-datamodel/src/json/json_importer.lisp branches/new-datamodel/src/json/json_tmcl.lisp branches/new-datamodel/src/json/json_tmcl_validation.lisp branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/json/json_exporter.lisp ============================================================================== --- branches/new-datamodel/src/json/json_exporter.lisp (original) +++ branches/new-datamodel/src/json/json_exporter.lisp Wed Jun 23 14:00:14 2010 @@ -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,66 @@ "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 "#" (topic-id 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)))) + "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 +116,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,210 +186,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 (topic-id instance)))) + (concatenate + 'string "\"id\":" + (json:encode-json-to-string (topic-id instance :revision 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) + (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) + (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 (topic-id topic)))) + (concatenate + 'string "\"id\":" + (json:encode-json-to-string (topic-id topic :revision 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 #'psis (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\":\"" (topic-id topic) "\"")) + (concatenate 'string "\"id\":\"" (topic-id topic :revision 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")) \ No newline at end of file Modified: branches/new-datamodel/src/json/json_importer.lisp ============================================================================== --- branches/new-datamodel/src/json/json_importer.lisp (original) +++ branches/new-datamodel/src/json/json_importer.lisp Wed Jun 23 14:00:14 2010 @@ -23,11 +23,11 @@ (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)) @@ -38,17 +38,20 @@ (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 (append topicStubs-values (list topic-values)) - do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) + (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)))) + 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 +60,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,7 +70,7 @@ (declare (list json-decoded-list)) (declare (integer start-revision)) (declare (TopicMapC tm)) - (setf roles (xml-importer::set-standard-role-types roles)) + (setf roles (xml-importer::set-standard-role-types roles start-revision)) (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -87,14 +90,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 @@ -113,11 +121,11 @@ (declare (TopicMapC tm)) (unless top (error "topic ~a could not be found" (getf json-decoded-list :id))) - (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) @@ -126,8 +134,9 @@ (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)) -; (add-to-tm tm top) ; will be done in "json-to-stub" + (json-create-instanceOf-association instanceOf-top top start-revision + :tm tm)) + ;(add-to-tm tm top) ; will be done in "json-to-stub" top))))) @@ -146,7 +155,11 @@ (subject-locators (map 'list #'(lambda(uri) (make-identifier 'SubjectLocatorC uri start-revision)) - (getf json-decoded-list :subjectLocators)))) + (getf json-decoded-list :subjectLocators))) + (topic-ids + (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 @@ -155,8 +168,7 @@ :item-identifiers item-identifiers :locators subject-locators :psis subject-identifiers - :topicid (getf json-decoded-list :id) - :xtm-id xtm-id))) + :topic-identifiers topic-ids))) (add-to-tm tm top) top))))) @@ -166,13 +178,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))) @@ -180,7 +192,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 @@ -194,27 +206,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 @@ -223,9 +238,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)))) @@ -241,23 +255,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)))) @@ -269,19 +280,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) @@ -311,22 +323,18 @@ 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-tm tm (make-construct @@ -335,8 +343,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) Modified: branches/new-datamodel/src/json/json_tmcl.lisp ============================================================================== --- branches/new-datamodel/src/json/json_tmcl.lisp (original) +++ branches/new-datamodel/src/json/json_tmcl.lisp Wed Jun 23 14:00:14 2010 @@ -13,17 +13,23 @@ ;; ============================================================================= ;; --- 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))) @@ -33,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) @@ -112,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)) @@ -128,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 @@ -156,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 @@ -174,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) @@ -283,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!")) @@ -398,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))) @@ -423,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\":" @@ -452,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))) @@ -510,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))))) @@ -526,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 "[")) @@ -566,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>], @@ -599,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. @@ -706,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 @@ -824,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 @@ -834,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)) @@ -860,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 @@ -887,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 @@ -911,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>." @@ -923,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) @@ -944,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 @@ -980,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. @@ -988,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)) @@ -1104,105 +1615,172 @@ :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) + 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) @@ -1214,95 +1792,130 @@ "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))))))) (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)) isas-of-this) :subtypes (map 'list #'(lambda(x) - (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) - akos-of-this))))) + (make-nodes (getf x :topic) + (getf x :is-type) + (getf x :is-instance) + :revision revision)) + akos-of-this))))) -(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 - (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: branches/new-datamodel/src/json/json_tmcl_validation.lisp ============================================================================== --- branches/new-datamodel/src/json/json_tmcl_validation.lisp (original) +++ branches/new-datamodel/src/json/json_tmcl_validation.lisp Wed Jun 23 14:00:14 2010 @@ -19,261 +19,324 @@ (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) + (TopicC topictype) + (list checked-topics) + (type (or TopicC null) topictype-constraint topictype)) (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> <...>)" + (declare (type (or integer null) revision) + (list checked-topics) + (TopicC topic-instance) + (type (or TopicC null) topictype topictype-constraint)) (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,170 +344,211 @@ (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." + (declare (type (or integer null) revision) + (TopicC topic-instance) + (type (or TopicC null) topictype topictype-constraint)) (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 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 - (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 - (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: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Wed Jun 23 14:00:14 2010 @@ -122,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) @@ -140,7 +140,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) @@ -159,8 +159,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") @@ -181,23 +182,29 @@ (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)))))) + (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+)))) @@ -210,7 +217,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") @@ -230,7 +237,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+) @@ -332,14 +339,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)))))) + (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)))))) ;; ============================================================================= Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Wed Jun 23 14:00:14 2010 @@ -482,7 +482,7 @@ (is (eql top-3 (get-item-by-id (concatenate 'string "t" (write-to-string - (elephant::oid top-3))) + (elephant::oid top-3))) :revision rev-0))) (is-false (get-item-by-id (concatenate 'string "t" (write-to-string

1 0

[isidorus-cvs] r303 - in branches/new-datamodel/src: unit_tests xml/xtm
by Lukas Giessmann 17 Jun '10

17 Jun '10

Author: lgiessmann Date: Thu Jun 17 13:44:08 2010 New Revision: 303 Log: new-datamodel: adapted the xtm 1.0 exporter to the new datamodel and all corresponding unit-tests; fixed a bug in to-elem-xtm1.0-> TopicC Modified: branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp branches/new-datamodel/src/xml/xtm/exporter.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Modified: branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp Thu Jun 17 13:44:08 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))))) Modified: branches/new-datamodel/src/xml/xtm/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter.lisp Thu Jun 17 13:44:08 2010 @@ -56,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*) @@ -94,7 +95,7 @@ (to-elem elem revision)))) (with-xtm1.0 (export-to-elem tm #'(lambda(elem) - (to-elem elem revision))))))))))) + (to-elem-xtm1.0 elem revision))))))))))) (defun export-xtm-to-string (&key @@ -109,13 +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 elem revision)))))))))) + (to-elem-xtm1.0 elem revision)))))))))) (defun export-xtm-fragment (fragment &key (xtm-format '2.0)) @@ -127,5 +126,4 @@ (with-xtm2.0 (to-elem fragment (revision fragment))) (with-xtm1.0 - (to-elem-xtm1.0 fragment (revision fragment)))))))) - \ No newline at end of file + (to-elem-xtm1.0 fragment (revision fragment)))))))) \ No newline at end of file Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Thu Jun 17 13:44:08 2010 @@ -52,9 +52,11 @@ (when (and (stringp (uri x)) (> (length (uri x)) 0)) (eql (elt (uri x) 0) #\#))) - (psis (reifier reifiable-construct :revision revision) :revision revision)))) + (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 revision) @@ -177,9 +179,9 @@ (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 topic))) + (to-subjectIdentity-elem-xtm1.0 t-psis first-locator revision))) (when (names topic :revision revision) - (map 'list #'(lambda(x) + (map 'list #'(lambda(x) (to-elem-xtm1.0 x revision)) (names topic :revision revision))) (when (occurrences topic :revision revision)

1 0

[isidorus-cvs] r302 - in branches/new-datamodel/src: model xml/xtm
by Lukas Giessmann 17 Jun '10

17 Jun '10

Author: lgiessmann Date: Thu Jun 17 12:37:12 2010 New Revision: 302 Log: new-datamodel: fixed two potential problems when requesting the db for all topics Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/xml/xtm/exporter.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Thu Jun 17 12:37:12 2010 @@ -225,7 +225,7 @@ :associations (find-associations-for-topic top :revision revision) ;TODO: this quite probably introduces code duplication with query: Check! :referenced-topics (find-referenced-topics top :revision revision) :topic top))) - (elephant:get-instances-by-class 'TopicC)))))) + (get-all-topics revision)))))) (defun get-fragment (unique-id) "get a fragment by its unique id" Modified: branches/new-datamodel/src/xml/xtm/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter.lisp Thu Jun 17 12:37:12 2010 @@ -18,7 +18,7 @@ (type-topic (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*)))) - (loop for item in (elephant:get-instances-by-class 'AssociationC) + (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

1 0

[isidorus-cvs] r301 - in branches/new-datamodel/src: unit_tests xml/xtm
by Lukas Giessmann 17 Jun '10

17 Jun '10

Author: lgiessmann Date: Thu Jun 17 12:10:37 2010 New Revision: 301 Log: new-datamodel: adapted the xtm 1.0 exporter to the new datamodel; fixed a bug in list-extern-associations Modified: branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp branches/new-datamodel/src/xml/xtm/exporter.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Modified: branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp Thu Jun 17 12:10:37 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,8 +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") - (elephant:open-store (get-store-spec "data_base"))) + (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm")) + ;(elephant:open-store (get-store-spec "data_base"))) (def-fixture refill-test-db () @@ -551,52 +552,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: branches/new-datamodel/src/xml/xtm/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter.lisp Thu Jun 17 12:10:37 2010 @@ -10,19 +10,32 @@ (in-package :exporter) -(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")))) + (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*)))) (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))))))) + 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))) @@ -53,12 +66,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 @@ -76,9 +90,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 elem revision))))))))))) (defun export-xtm-to-string (&key @@ -93,9 +109,13 @@ (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 #'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 #'to-elem-xtm1.0)))))))) + (export-to-elem tm #'(lambda(elem) + (to-elem elem revision)))))))))) (defun export-xtm-fragment (fragment &key (xtm-format '2.0)) Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Thu Jun 17 12:10:37 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 Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Thu Jun 17 12:10:37 2010 @@ -32,9 +32,11 @@ (cxml:attribute "href" (format nil "#~a" (topic-id topic revision))))) + (defgeneric to-elem (instance revision) (:documentation "converts the Topic Maps construct instance to an XTM 2.0 element")) + (defmethod to-elem ((psi PersistentIdC) revision) (declare (ignorable revision)) (cxml:with-element "t:subjectIdentifier" @@ -80,7 +82,7 @@ (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) #\#))

1 0

[isidorus-cvs] r300 - branches/new-datamodel/src/model
by Lukas Giessmann 15 Jun '10

15 Jun '10

Author: lgiessmann Date: Tue Jun 15 16:44:14 2010 New Revision: 300 Log: new-datamodel: fixed a bug in merging an entire list of constructs in the function merge-all-constructs Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Jun 15 16:44:14 2010 @@ -831,12 +831,18 @@ (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)) - (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1)) - (merged-construct (elt constructs-to-be-merged 0))) - (loop for construct-to-be-merged in constructs-to-be-merged - do (setf merged-construct - (merge-constructs merged-construct construct-to-be-merged - :revision revision))))) + (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))))))) (defgeneric internal-id (construct)

1 0

[isidorus-cvs] r299 - in branches/new-datamodel/src: unit_tests xml/xtm
by Lukas Giessmann 14 Jun '10

14 Jun '10

Author: lgiessmann Date: Mon Jun 14 04:24:35 2010 New Revision: 299 Log: new-datamodel: adpted all unittests for the xml-importer in version xtm1.0; fixed a bug when setting default role-types; Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp branches/new-datamodel/src/xml/xtm/importer.lisp branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/importer_test.lisp Mon Jun 14 04:24:35 2010 @@ -99,7 +99,7 @@ (is (= 1 (length t101-themes))) (is (string= - (topic-id (first t101-themes) *TEST-TM*) + (topic-id (first t101-themes) rev-1 *TEST-TM*) "t50a")))))) (test test-from-name-elem @@ -410,8 +410,6 @@ (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")) @@ -442,30 +440,46 @@ :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) + ;(elephant:open-store (xml-importer:get-store-spec dir)) + ;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)) @@ -475,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"))) @@ -495,7 +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 @@ -540,12 +558,14 @@ (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))) @@ -561,10 +581,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)))))))))) @@ -573,61 +597,70 @@ (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) - - (elephant:open-store (xml-importer:get-store-spec dir)) + ;(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"))) (loop for baseName in (names t-2526) 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)))))))))) Modified: branches/new-datamodel/src/xml/xtm/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer.lisp Mon Jun 14 04:24:35 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 Modified: branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp Mon Jun 14 04:24:35 2010 @@ -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 @@ -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)) @@ -154,7 +156,7 @@ (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))) @@ -181,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 @@ -230,14 +252,19 @@ (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 :revision start-revision))) + (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 @@ -257,7 +284,10 @@ (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") start-revision :xtm-id xtm-id)) @@ -267,11 +297,13 @@ (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) @@ -282,58 +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))) - id)) - psi-refs)) - (locators (map 'list #'(lambda(uri) - (let ((loc (make-instance 'SubjectLocatorC - :uri uri - :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 start-revision &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 start-revision))) + (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))))) @@ -346,16 +395,20 @@ (declare (dom:element topic-elem)) (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 @@ -368,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)) @@ -388,18 +445,22 @@ occ-elems) ;;instanceOf (dolist (instanceOf-topicRef instanceOf-topicRefs) - (create-instanceof-association instanceOf-topicRef top start-revision :xtm-id xtm-id - :tm tm)) + (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") @@ -412,20 +473,21 @@ (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"))) + (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))))) + (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 @@ -435,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: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Mon Jun 14 04:24:35 2010 @@ -89,7 +89,8 @@ (lambda (topicid) (let ((top - (get-item-by-id topicid :xtm-id xtm-id :revision start-revision))) + (get-item-by-id topicid :xtm-id xtm-id + :revision start-revision))) (if top top (error (make-condition 'missing-reference-error @@ -244,7 +245,6 @@ applicable" (declare (dom:element topic-elem)) (declare (integer start-revision)) - ;(declare (optimize (debug 3))) (elephant:ensure-transaction (:txn-nosync t) (let ((itemidentifiers @@ -262,8 +262,7 @@ :item-identifiers itemidentifiers :locators subjectlocators :psis subjectidentifiers - :topic-identifiers topic-ids - :xtm-id xtm-id)))) + :topic-identifiers topic-ids)))) (defun merge-topic-elem (topic-elem start-revision @@ -378,7 +377,7 @@ assoc-elem *xtm2.0-ns* "role"))) (reifier-topic (get-reifier-topic assoc-elem start-revision))) - (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them + (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

1 0

[isidorus-cvs] r298 - in branches/new-datamodel/src: model unit_tests xml/xtm
by Lukas Giessmann 13 Jun '10

13 Jun '10

Author: lgiessmann Date: Sun Jun 13 10:42:34 2010 New Revision: 298 Log: new-datamodel: adpted all unit-test for the xtm-importer (xtm2.0); fixed two bug in make-pointerc; fixed a bug when importing topics, names, occurrences, variants and tm-identifiers; fixed a bug in add-to-tm; fixed a bug when mergin was caused by an item-identifier Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/fixtures.lisp branches/new-datamodel/src/unit_tests/importer_test.lisp branches/new-datamodel/src/xml/xtm/importer.lisp branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Jun 13 10:42:34 2010 @@ -160,7 +160,6 @@ (in-package :datamodel) -;;TODO: adapt changes.lisp --> changed-p ;;TODO: implement a macro with-merge-constructs, that merges constructs ;; after all operations in the body were called @@ -1586,8 +1585,9 @@ (= 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 (xtm-id nil) (revision *TM-REVISION*)) - (declare (type (or null string) xtm-id) (integer revision)) + (: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 @@ -3127,6 +3127,12 @@ :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 @@ -3485,11 +3491,13 @@ (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) - (add-association construct 'topics construct-to-add)) + (add-association construct 'topics construct-to-add) + construct-to-add) (defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC)) - (add-association construct 'associations construct-to-add)) + (add-association construct 'associations construct-to-add) + construct-to-add) (defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) @@ -3806,11 +3814,12 @@ #'null (map 'list #'(lambda(existing-pointer) - (when (equivalent-construct existing-pointer uri - xtm-id) + (when (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 existing-pointer + (if existing-pointer + (first existing-pointer) (make-instance class-symbol :uri uri :xtm-id xtm-id))))) (when identified-construct (cond ((TopicIdentificationC-p class-symbol) Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/fixtures.lisp (original) +++ branches/new-datamodel/src/unit_tests/fixtures.lisp Sun Jun 13 10:42:34 2010 @@ -94,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)))) Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/importer_test.lisp Sun Jun 13 10:42:34 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,19 +83,19 @@ (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= @@ -105,54 +106,51 @@ "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= - (topic-id (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,7 +223,8 @@ (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 @@ -234,43 +232,40 @@ (from-role-elem (nth 11 role-elems) revision))) (is (string= "t101" (topic-id - (getf 12th-role :player) *TEST-TM*))) + (getf 12th-role :player) rev-1 *TEST-TM*))) (is (string= "t62" (topic-id - (getf 12th-role :instance-of) *TEST-TM*))))))) + (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" - (topic-id (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" - (topic-id (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" - (topic-id (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,60 +275,56 @@ (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= (topic-id topic) - (topic-id (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" - (topic-id (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" (topic-id (instance-of - (parent (first role-101))) "core.xtm"))) - )))) + (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 @@ -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,45 +364,50 @@ (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+-+Metada…" - (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) @@ -433,12 +429,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,7 +441,7 @@ *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) @@ -507,14 +498,13 @@ do (is-true (format t "bad role found in association: ~A" (topic-identifiers (player role))))))))) - (test test-variants (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :xtm-id *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 +513,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 +524,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,9 +533,9 @@ (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)) @@ -561,8 +551,8 @@ (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)) @@ -654,7 +644,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: branches/new-datamodel/src/xml/xtm/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer.lisp Sun Jun 13 10:42:34 2010 @@ -196,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: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Sun Jun 13 10:42:34 2010 @@ -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)) @@ -130,7 +130,7 @@ (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 @@ -200,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*)) @@ -226,7 +226,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 @@ -252,13 +252,17 @@ (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") + :topic-identifiers topic-ids :xtm-id xtm-id)))) @@ -283,7 +287,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) @@ -335,7 +340,8 @@ 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))))

1 0

[isidorus-cvs] r297 - branches/new-datamodel/src/xml/xtm
by Lukas Giessmann 12 Jun '10

12 Jun '10

Author: lgiessmann Date: Sat Jun 12 16:55:30 2010 New Revision: 297 Log: new-datamodel: adapted exporter.lisp, exporter_xtm1.0.lisp and exporter_xtm2.0.lisp to the new datamodel Modified: branches/new-datamodel/src/xml/xtm/exporter.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Modified: branches/new-datamodel/src/xml/xtm/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter.lisp Sat Jun 12 16:55:30 2010 @@ -10,11 +10,6 @@ (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 () "gets all instances of AssociationC - which does not realize an instanceOf relationship in the db" (let ((instance-topic @@ -30,6 +25,7 @@ (eq type-topic (instance-of (second (roles item))))))) collect item))) + (defmacro with-xtm2.0 (&body body) "helper macro to build the Topic Map element" `(cxml:with-namespace ("t" *xtm2.0-ns*) @@ -109,7 +105,7 @@ (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))))))) + (to-elem-xtm1.0 fragment (revision fragment)))))))) \ No newline at end of file Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Sat Jun 12 16:55:30 2010 @@ -24,35 +24,38 @@ (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" (topic-id 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)))))))) -(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 +69,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 "#" (topic-id 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 "#" (topic-id 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" (topic-id 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 topic))) + (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" (topic-id 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: branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Sat Jun 12 16:55:30 2010 @@ -9,54 +9,67 @@ (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" (topic-id 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 @@ -71,10 +84,11 @@ (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 "#" (topic-id ref-topic)) + (concatenate 'string "#" (topic-id ref-topic revision)) characteristic-value)))) (cxml:with-element "t:resourceData" (when (slot-boundp characteristic 'datatype) @@ -82,112 +96,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" (topic-id 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 "#" (topic-id 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" (topic-id 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))))

1 0

[isidorus-cvs] r296 - in branches/new-datamodel/src: model unit_tests xml/xtm
by Lukas Giessmann 09 Jun '10

09 Jun '10

Author: lgiessmann Date: Wed Jun 9 16:35:07 2010 New Revision: 296 Log: new-datamodel: adapted importer_xtm1.0.lisp and importer_xtm2.0.lisp to the new datamodel Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/atom_test.lisp branches/new-datamodel/src/xml/xtm/importer.lisp branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Wed Jun 9 16:35:07 2010 @@ -71,7 +71,7 @@ (when (reifier characteristic :revision revision) (list (reifier characteristic :revision revision))) (themes characteristic :revision revision) - (when (instance-of-p characteristic :revision revision) + (when (instance-of characteristic :revision revision) (list (instance-of characteristic :revision revision))) (when (and (typep characteristic 'OccurrenceC) (> (length (charvalue characteristic)) 0) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Wed Jun 9 16:35:07 2010 @@ -1208,6 +1208,13 @@ ;;; 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." @@ -2177,6 +2184,13 @@ ;;; 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." Modified: branches/new-datamodel/src/unit_tests/atom_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/atom_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/atom_test.lisp Wed Jun 9 16:35:07 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 Modified: branches/new-datamodel/src/xml/xtm/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer.lisp Wed Jun 9 16:35:07 2010 @@ -94,11 +94,11 @@ (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)))) @@ -172,19 +172,17 @@ (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 Modified: branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp Wed Jun 9 16:35:07 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))))))) @@ -86,7 +86,7 @@ (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 @@ -146,13 +146,12 @@ (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 @@ -224,7 +223,7 @@ 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 @@ -238,7 +237,7 @@ (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 @@ -261,10 +260,10 @@ (get-item-by-id (first (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id)) :xtm-id xtm-id))) (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 @@ -294,14 +293,12 @@ (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)) locator-refs))) (declare (dom:element subjectIdentity-elem)) @@ -309,7 +306,7 @@ (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) @@ -332,7 +329,7 @@ member-elem *xtm1.0-ns* "subjectIndicatorRef"))))))) - (reifier-topic (get-reifier-topic-xtm1.0 member-elem))) + (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")) @@ -347,8 +344,7 @@ (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 @@ -407,13 +403,13 @@ (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)) @@ -427,8 +423,7 @@ :themes themes :reifier reifier-topic :roles roles))))) - - + (defun set-standard-role-types (roles) "sets the missing role types of the passed roles to the default types." Modified: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Wed Jun 9 16:35:07 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))) @@ -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,13 @@ (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,16 +119,15 @@ (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 @@ -188,10 +185,11 @@ ((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) + (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") + start-revision :xtm-id xtm-id) (themes name))) (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")) @@ -212,20 +210,18 @@ (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 @@ -267,21 +263,16 @@ (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 @@ -330,17 +321,14 @@ (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 @@ -369,13 +357,12 @@ (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,7 +371,7 @@ (xpath-child-elems-by-qname assoc-elem *xtm2.0-ns* "role"))) - (reifier-topic (get-reifier-topic assoc-elem))) + (reifier-topic (get-reifier-topic assoc-elem start-revision))) (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them (add-to-tm tm

1 0

[isidorus-cvs] r295 - branches/new-datamodel/src branches/new-datamodel/src/json branches/new-datamodel/src/model trunk/src
by Lukas Giessmann 25 May '10

25 May '10

Author: lgiessmann Date: Tue May 25 14:10:18 2010 New Revision: 295 Log: fixed a problem with sbcl/asdf and the sb-impl::*default-external-format* --> now it is set to :utf-8 during the loading process and then set to its old value Modified: branches/new-datamodel/src/isidorus.asd branches/new-datamodel/src/json/json_importer.lisp branches/new-datamodel/src/model/changes.lisp trunk/src/isidorus.asd Modified: branches/new-datamodel/src/isidorus.asd ============================================================================== --- branches/new-datamodel/src/isidorus.asd (original) +++ branches/new-datamodel/src/isidorus.asd Tue May 25 14:10:18 2010 @@ -12,6 +12,9 @@ (:use :asdf :cl)) (in-package :isidorus-system) +(defvar *old-external-format* sb-impl::*default-external-format*) +(setf sb-impl::*default-external-format* :UTF-8) + (asdf:defsystem "isidorus" :description "The future ingenious, self-evaluating Lisp TM engine" :version "0.1" @@ -202,6 +205,9 @@ :uuid :cl-json)) +(setf sb-impl::*default-external-format* *old-external-format*) + + ;; ;; For the package pathnames, create a link from ~/.sbcl/systems ;; to the file pathnames.asd in Seibel's pathname-library. Modified: branches/new-datamodel/src/json/json_importer.lisp ============================================================================== --- branches/new-datamodel/src/json/json_importer.lisp (original) +++ branches/new-datamodel/src/json/json_importer.lisp Tue May 25 14:10:18 2010 @@ -244,12 +244,10 @@ (json-to-scope (getf json-decoded-list :scopes))) (instance-of (psis-to-topic (getf json-decoded-list :type)))) - (declare (list json-decoded-list)) - (declare (TopicC top)) - + ;(declare (list json-decoded-list)) causes problems with sbcl 1.0.34.0.debian + ;(declare (TopicC top)) (unless namevalue (error "A name must have exactly one namevalue")) - (let ((name (make-construct 'NameC :start-revision start-revision :topic top Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Tue May 25 14:10:18 2010 @@ -140,7 +140,7 @@ * (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" + "The 'normal' case: changes only when new identifiers are added" (find revision (versions construct) :test #'= :key #'start-revision)) ;There is quite deliberately no method specialized on AssociationC as Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue May 25 14:10:18 2010 @@ -12,6 +12,9 @@ (:use :asdf :cl)) (in-package :isidorus-system) +(defvar *old-external-format* sb-impl::*default-external-format*) +(setf sb-impl::*default-external-format* :UTF-8) + (asdf:defsystem "isidorus" :description "The future ingenious, self-evaluating Lisp TM engine" :version "0.1" @@ -201,6 +204,9 @@ :uuid :cl-json)) + +(setf sb-impl::*default-external-format* *old-external-format*) + ;; ;; For the package pathnames, create a link from ~/.sbcl/systems ;; to the file pathnames.asd in Seibel's pathname-library.

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs