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")