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

[Lukas Giessmann]

Author: lgiessmann
Date: Sun Apr 11 13:55:05 2010
New Revision: 273

Log:
registry: modified "make-tree-view" -->  currently all constraints and types are not displayed, except the user-defined topic-types

Modified:
   trunk/src/json/json_tmcl.lisp
   trunk/src/json/json_tmcl_constants.lisp

Modified: trunk/src/json/json_tmcl.lisp
==============================================================================
--- trunk/src/json/json_tmcl.lisp	(original)
+++ trunk/src/json/json_tmcl.lisp	Sun Apr 11 13:55:05 2010
@@ -1275,15 +1275,43 @@
 			    (remove-if #'(lambda(x) (when (eql topic-instance x)
 						      t))
 				       (get-direct-subtypes-of-topic topic-instance)))))))
-      (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)))
-			    isas-of-this)
-	    :subtypes (map 'list #'(lambda(x)
-				      (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance)))
-			    akos-of-this)))))
+      (let ((cleaned-isas ;;all constraint topics are removed
+	     (remove-if #'null (map 'list #'(lambda(top-entry)
+					      (when (find-if #'(lambda(psi)
+								   (unless (or (string= (uri psi) *constraint-psi*)
+									       (string= (uri psi) *occurrencetype-psi*)
+									       (string= (uri psi) *nametype-psi*)
+									       (string= (uri psi) *associationtype-psi*)
+									       (string= (uri psi) *roletype-psi*)
+									       (string= (uri psi) *scopetype-psi*)
+									       (string= (uri psi) *schema-psi*))
+								     top-entry))
+							       (psis (getf top-entry :topic)))
+						top-entry))
+				    isas-of-this)))
+	    (cleaned-akos ;;all constraint topics are removed
+	     (remove-if #'null (map 'list #'(lambda(top-entry)
+					      (when (find-if #'(lambda(psi)
+								   (unless (or (string= (uri psi) *constraint-psi*)
+									       (string= (uri psi) *occurrencetype-psi*)
+									       (string= (uri psi) *nametype-psi*)
+									       (string= (uri psi) *associationtype-psi*)
+									       (string= (uri psi) *roletype-psi*)
+									       (string= (uri psi) *scopetype-psi*)
+									       (string= (uri psi) *schema-psi*))
+								     top-entry))
+							       (psis (getf top-entry :topic)))
+						top-entry))
+				    akos-of-this))))
+	(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)))
+			      cleaned-isas)
+	      :subtypes (map 'list #'(lambda(x)
+				       (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance)))
+			     cleaned-akos))))))
 
 
 (defun get-all-tree-roots ()

Modified: trunk/src/json/json_tmcl_constants.lisp
==============================================================================
--- trunk/src/json/json_tmcl_constants.lisp	(original)
+++ trunk/src/json/json_tmcl_constants.lisp	Sun Apr 11 13:55:05 2010
@@ -9,7 +9,9 @@
 
 (defpackage :json-tmcl-constants
   (:use :cl)
-  (:export :*topictype-psi*
+  (:export :*schema-psi*
+	   :*constraint-psi*
+	   :*topictype-psi*
 	   :*topictype-constraint-psi*
 	   :*associationtype-psi*
 	   :*associationtype-constraint-psi*
@@ -51,6 +53,9 @@
 
 (in-package :json-tmcl-constants)
 
+
+(defparameter *schema-psi* "http://psi.topicmaps.org/tmcl/schema")
+(defparameter *constraint-psi* "http://psi.topicmaps.org/tmcl/constraint")
 (defparameter *topictype-psi* "http://psi.topicmaps.org/tmcl/topic-type")
 (defparameter *topictype-constraint-psi* "http://psi.topicmaps.org/tmcl/topic-type-constraint")
 (defparameter *associationtype-psi* "http://psi.topicmaps.org/tmcl/association-type")