Author: lgiessmann Date: Sat Jul 4 06:54:10 2009 New Revision: 85
Log: json-server: fixed a bug with collecting constraint topics for a give topic-type or topic-instance
Modified: trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_validation.lisp
Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Sat Jul 4 06:54:10 2009 @@ -991,8 +991,24 @@ (let ((akos-and-isas-of-this (remove-duplicates (if (eql treat-as 'type) - (topictype-p topic-instance) - (valid-instance-p topic-instance))))) + (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) @@ -1068,8 +1084,9 @@ (defun get-all-constraint-topics-of-association(associationtype-topic) "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*)) (let ((akos-and-isas-of-this - (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*)))) + (get-all-upper-constrainted-topics associationtype-topic))) (let ((all-associationrole-constraints nil) (all-roleplayer-constraints nil) (all-otherrole-constraints nil))
Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Sat Jul 4 06:54:10 2009 @@ -420,4 +420,31 @@ (remove-if #'(lambda(x) (when (eql topictype-constraint x) t)) (get-direct-instances-of-topic topictype-constraint)))))) - ttc)))) \ No newline at end of file + ttc)))) + + +(defun list-all-supertypes (topic-instance &optional (checked-topics nil)) + "Returns all supertypes of the given topic recursively." + (let ((current-checked-topics (append checked-topics (list topic-instance))) + (akos-of-this (get-direct-supertypes-of-topic topic-instance))) + (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))) + (dolist (new-topic new-checked-topics) + (pushnew new-topic current-checked-topics))))) + current-checked-topics)) + + +(defun get-all-upper-constrainted-topics (topic) + "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." + ;; find all direct types + (let ((direct-isas-of-this + (get-direct-types-of-topic topic))) + + ;; find all supertypes (recursive -> transitive relationship + (let ((all-akos-of-this + (list-all-supertypes topic))) + (remove-duplicates (union direct-isas-of-this all-akos-of-this))))) \ No newline at end of file