[isidorus-cvs] r304 - in branches/new-datamodel/src: json rest_interface unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Jun 23 18:00:14 UTC 2010
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
More information about the Isidorus-cvs
mailing list