[isidorus-cvs] r30 - in trunk: docs src src/json
Lukas Giessmann
lgiessmann at common-lisp.net
Tue May 5 19:18:12 UTC 2009
Author: lgiessmann
Date: Tue May 5 15:18:11 2009
New Revision: 30
Log:
some structural improvements in the json module
Added:
trunk/src/json/json_tmcl_validation.lisp
Modified:
trunk/docs/xtm_json.txt
trunk/src/isidorus.asd
trunk/src/json/json_tmcl.lisp
Modified: trunk/docs/xtm_json.txt
==============================================================================
--- trunk/docs/xtm_json.txt (original)
+++ trunk/docs/xtm_json.txt Tue May 5 15:18:11 2009
@@ -294,7 +294,7 @@
"occurrenceTypes" : [ {
"occurrenceType" : [ "psi-1", "psi-2", "..." ],
"scopeConstraints" : [ <scopeConstraints> ],
- "datatypeConstraint" : "datatype",
+ "datatypeConstraint" : "datatype"
},
<...>
],
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Tue May 5 15:18:11 2009
@@ -128,9 +128,11 @@
(:module "json"
:components ((:file "json_exporter")
(:file "json_importer")
+ (:file "json_tmcl_validation"
+ :depends-on ("json_tmcl_constants" "json_exporter" ))
(:file "json_tmcl_constants")
(:file "json_tmcl"
- :depends-on ("json_tmcl_constants" "json_exporter")))
+ :depends-on ("json_tmcl_validation")))
:depends-on ("model" "xml"))
(:module "ajax"
:components ((:static-file "isidorus.html")
Modified: trunk/src/json/json_tmcl.lisp
==============================================================================
--- trunk/src/json/json_tmcl.lisp (original)
+++ trunk/src/json/json_tmcl.lisp Tue May 5 15:18:11 2009
@@ -7,13 +7,6 @@
;;+-----------------------------------------------------------------------------
-(defpackage :json-tmcl
- (:use :cl :datamodel :constants :json-tmcl-constants)
- (:export :get-constraints-of-fragment
- :topictype-p
- :abstract-p
- :list-subtypes))
-
(in-package :json-tmcl)
@@ -525,14 +518,13 @@
(defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics)
"Returns all topicoccurrence constraints as a list of the following form:
- ( ( :type <occurrencetype-topic>
- :constraints ( ( :regexp <string> :card-min <string> :card-max <string>)
- <...>)
- :scopes ( ( :scope <scope-topic> :regexp <string> :card-min <string> :card-max <string>)
- <...>)
- :datatype <string>
- :uniqe ( ( :regexp <string> :dard-min <string> :card-max <string> ) )
- <...>)."
+ [{occurrenceTypes:[{occurrenceType:[psi-1,psi-2],
+ scopeConstraints:[<scopeConstraints>],
+ datatypeConstraint:datatype},
+ <...>],
+ 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*))
@@ -855,173 +847,6 @@
(string= (getf lst-1 :card-max) (getf lst-2 :card-max)))))
-;; --- checks if the given topic is a valid topictype --------------------------
-(defun get-direct-types-of-topic(topic-instance)
- "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"
- (let ((type-instance (get-item-by-psi *type-instance-psi*))
- (instance (get-item-by-psi *instance-psi*))
- (type (get-item-by-psi *type-psi*)))
- (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))
- when (and (not (eq role other-role))
- (eq type-instance (instance-of (parent role)))
- (eq type (instance-of other-role)))
- return (player other-role)))))
- (when topic-types
- (remove-if #'null topic-types)))))
-
-
-(defun get-direct-supertypes-of-topic(topic-instance)
- "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"
- (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
- (supertype (get-item-by-psi *supertype-psi*))
- (subtype (get-item-by-psi *subtype-psi*)))
- (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))
- when (and (not (eq role other-role))
- (eq supertype-subtype (instance-of (parent role)))
- (eq supertype (instance-of other-role)))
- collect (player other-role)))))
- (remove-if #'null supertypes))))
-
-
-(defun subtype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) (checked-topics nil))
- "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 topictype or it is the topictype-topic itself."
- ;(format t "~%~%subtype-p ~a~%" (uri (first (psis topic-instance))))
- (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)
- (return-from subtype-p nil))
-
- (let ((supertypes-of-this (get-direct-supertypes-of-topic topic-instance)))
- (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)))
- (when (not further-supertypes)
- (return-from subtype-p nil))
-
- (dolist (item further-supertypes)
- (pushnew item current-checked-topics))))))
-
- current-checked-topics))
-
-
-(defun topictype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
- (checked-topics nil))
- "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))))
- (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)))
-
- (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)))))
- (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)))
- (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))))))))
-
- (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)))
- (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)))))
-
- (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)))
- (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)))))))))))
- current-checked-topics))
-
-
-(defun topictype-of-p (topic-instance type-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
- checked-topics)
- "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."
- (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)))
-
- (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)))
- (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)))
- (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)))
-
-
;; --- gets all constraint topics ----------------------------------------------
(defun get-direct-constraint-topics-of-topic (topic-instance)
"Returns all constraint topics defined for the passed topic-instance"
@@ -1129,22 +954,6 @@
:uniqueoccurrence-constraints all-uniqueoccurrence-constraints))))
-(defun abstract-p (topic-instance)
- "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))
- (eq abstract-topictype-constraint (player other-role)))
- return t))))
-
-
(defun get-direct-constraint-topics-of-association(associationtype-topic)
"Returns all direct constraint topics defined for associations if
the passed associationtype-topic"
@@ -1245,74 +1054,9 @@
all-available-associationtypes)))
-(defun list-subtypes (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
- (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
- (checked-topics nil) (valid-subtypes nil))
- "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> <...>)"
- (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*))
- (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)))
- (let ((new-values
- (list-subtypes (player other-role) topictype topictype-constraint current-checked-topics current-valid-subtypes)))
- (dolist (item (getf new-values :subtypes))
- (pushnew item current-valid-subtypes))
- (dolist (item (getf new-values :checked-topics))
- (pushnew item current-checked-topics))))))
- (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 (get-item-by-psi *topictype-constraint-psi*)))
- "Returns the topic-instance, all subtypes found by the function lis-subtypes and all direct
- instances for the found subtypes."
- (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*)))
- (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)))))))
- (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))))))
- (remove-if #'null
- (map 'list #'(lambda(x)
- (handler-case (progn
- (topictype-of-p x nil)
- x)
- (condition () nil)))
- all-subtypes-of-all-instances))))))
-
-
(defun topics-to-json-list (topics)
"Returns a json list of psi-lists."
(json:encode-json-to-string
(map 'list #'(lambda(topic)
(map 'list #'uri (psis topic)))
- topics)))
\ No newline at end of file
+ topics)))
Added: trunk/src/json/json_tmcl_validation.lisp
==============================================================================
--- (empty file)
+++ trunk/src/json/json_tmcl_validation.lisp Tue May 5 15:18:11 2009
@@ -0,0 +1,271 @@
+;;+-----------------------------------------------------------------------------
+;;+ Isidorus
+;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
+;;+
+;;+ Isidorus is freely distributable under the LGPL license.
+;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+
+(defpackage :json-tmcl
+ (:use :cl :datamodel :constants :json-tmcl-constants)
+ (:export :get-constraints-of-fragment
+ :topictype-p
+ :abstract-p
+ :list-subtypes))
+
+
+(in-package :json-tmcl)
+
+
+(defun abstract-p (topic-instance)
+ "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))
+ (eq abstract-topictype-constraint (player other-role)))
+ return t))))
+
+
+(defun topictype-of-p (topic-instance type-instance &optional (topictype (get-item-by-psi *topictype-psi*))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
+ checked-topics)
+ "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."
+ (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)))
+
+ (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)))
+ (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)))
+ (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 (get-item-by-psi *topictype-constraint-psi*))
+ (checked-topics nil))
+ "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))))
+ (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)))
+
+ (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)))))
+ (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)))
+ (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))))))))
+
+ (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)))
+ (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)))))
+
+ (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)))
+ (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)))))))))))
+ current-checked-topics))
+
+
+(defun subtype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) (checked-topics nil))
+ "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)))))
+
+ (when (eq topictype topic-instance)
+ (return-from subtype-p current-checked-topics))
+
+ (when (get-direct-types-of-topic topic-instance)
+ (return-from subtype-p nil))
+
+ (let ((supertypes-of-this (get-direct-supertypes-of-topic topic-instance)))
+ (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)))
+ (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)
+ "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*)))
+ (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))
+ when (and (not (eq role other-role))
+ (eq type-instance (instance-of (parent role)))
+ (eq type (instance-of other-role)))
+ return (player other-role)))))
+ (when topic-types
+ (remove-if #'null topic-types)))))
+
+
+(defun get-direct-supertypes-of-topic(topic-instance)
+ "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*)))
+ (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))
+ when (and (not (eq role other-role))
+ (eq supertype-subtype (instance-of (parent role)))
+ (eq supertype (instance-of other-role)))
+ collect (player other-role)))))
+ (remove-if #'null supertypes))))
+
+
+(defun list-subtypes (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))
+ (checked-topics nil) (valid-subtypes nil))
+ "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> <...>)"
+ (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*))
+ (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)))
+ (let ((new-values
+ (list-subtypes (player other-role) topictype topictype-constraint current-checked-topics current-valid-subtypes)))
+ (dolist (item (getf new-values :subtypes))
+ (pushnew item current-valid-subtypes))
+ (dolist (item (getf new-values :checked-topics))
+ (pushnew item current-checked-topics))))))
+ (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 (get-item-by-psi *topictype-constraint-psi*)))
+ "Returns the topic-instance, all subtypes found by the function lis-subtypes and all direct
+ instances for the found subtypes."
+ (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*)))
+ (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)))))))
+ (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))))))
+ (remove-if #'null
+ (map 'list #'(lambda(x)
+ (handler-case (progn
+ (topictype-of-p x nil)
+ x)
+ (condition () nil)))
+ all-subtypes-of-all-instances))))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list