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