[isidorus-cvs] r85 - trunk/src/json

[Lukas Giessmann]

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