[isidorus-cvs] r29 - in trunk: docs src/json src/rest_interface
Lukas Giessmann
lgiessmann at common-lisp.net
Tue May 5 16:28:19 UTC 2009
Author: lgiessmann
Date: Tue May 5 12:28:18 2009
New Revision: 29
Log:
changed the tmcl-json-model and the tmcl-json-exporter. so there will be exported to every constraint the original topictypes e.g. nametypes and all valid subtypes, the second point is that there will be exported all possible player-psis of associationrole, so the user is able to choose a player directly without further communication with the server
Modified:
trunk/docs/xtm_json.txt
trunk/src/json/json_tmcl.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
Modified: trunk/docs/xtm_json.txt
==============================================================================
--- trunk/docs/xtm_json.txt (original)
+++ trunk/docs/xtm_json.txt Tue May 5 12:28:18 2009
@@ -226,7 +226,7 @@
//+ subjectLocator, this member contains an unsigendInt or the string
//+ "MAX_INT".
//+-----------------------------------------------------------------------------
-<simepleConstraint>
+<simpleConstraint>
//+-----------------------------------------------------------------------------
@@ -249,20 +249,18 @@
//+-----------------------------------------------------------------------------
//+ topicNameConstraint
-//+ The topicNameConstraint describes how the topic's names have to be
-//+ defined.
-//+ The nameType is a topic representation in form of a list of psis of the
-//+ topic representing the name's type.
-//+ regexp defines the content of the name.
-//+ cardMin defines the minimum number of names a topic must have.
-//+ cardMax defines the maximum number of names a topic must have.
-//+ nameTypeScopes describes how many scopes there must exist and of what
-//+ type the scopes have to be .
+//+ nametypescope constains the original nametype and all valid subtypes
+//+ with the specific scope constraints.
+//+ constriants contains the constraints for the owner topic.
//+-----------------------------------------------------------------------------
{
- "nameType" : [ "topic-psi-1", "topic-psi-2", "..." ],
- "constraints" : [ <simpleConstraint>, < ... > ],
- "scopeConstraints" : { <scopeConstraint> }
+ "nametypescopes" : [ {
+ "nametype" : [psi-1, psi-2, "..." ],
+ "scopeConstraints" : [ <scopeConstraints> ]
+ },
+ <...>
+ ]
+ "constraints" : [ <simpleConstraint>, < ... > ]
}
@@ -282,16 +280,26 @@
//+-----------------------------------------------------------------------------
//+ topicOccurrenceConstraint
-//+ The topicOccurrenceConstraint describes how the topic's occurrences have
-//+ to be defined.
-//+
-//+-----------------------------------------------------------------------------
-{
- "occurrenceType" : [ "topic-psi-1", "topic-psi-2", "..." ],
- "constraints" : [ <simpleConstraint>, < ... > ],
- "scopeConstraints" : { <scopeConstraint> },
- "dataConstraint" : "datatype",
- "uniqueConstraints" : [ <uniqueOccurrenceConstraint>, <...> ]
+//+ occurrenceTypes contains a list of a json-sub-object. This sub-object
+//+ contains an occurrenceType a specific list of scopeConstraints for
+//+ the occurrenceType and a scpecific datatypeConstraint which contains
+//+ the datatype for the occurrenceType.
+//+ The entire list of occurrenceTypes contains the not only the
+//+ original occurrenceType but also the subtypes of this occurrenceType.
+//+ constraints is a constraint list of depending to the owner topic.
+//+ unqiqueConstraint is a list of uniqeConstraints which also depends on
+//+ the owner topic.
+//+-----------------------------------------------------------------------------
+{
+ "occurrenceTypes" : [ {
+ "occurrenceType" : [ "psi-1", "psi-2", "..." ],
+ "scopeConstraints" : [ <scopeConstraints> ],
+ "datatypeConstraint" : "datatype",
+ },
+ <...>
+ ],
+ "constraints" : [ <simpleConstraints>, <...>],
+ "uniqueConstraint" : [ <uniqueConstraints>, <...> ]
}
@@ -303,7 +311,7 @@
//+ in an association of a certain associationtype (the objects owner).
//+-----------------------------------------------------------------------------
{
- "roleType" : [ "topic-psi-1", "topic-psi-2", "..." ],
+ "roleType" : [ [ "topic-psi-1", "topic-psi-2", "..." ], ["subtype-1-psi-1", "..."], <...> ],
"cardMin" : "unsigned integer in string representation",
"cardMax" : "unsigend integer in string representation or the string MAX_INT"
}
@@ -312,17 +320,17 @@
//+-----------------------------------------------------------------------------
//+ rolePlayerConstraint
//+ Defines the player of a certain role with a given type in an association
-//+ with a given type.
-//+ playerType is the psi-list representation of the player-topic.
-//+ roleType is the is a list of topic-psis representing a topic which can
-//+ be a player in the given role.
+//+ of a given type.
+//+ palyers is the psi-list representation of a list of all available
+//+ players.
+//+ roleTypes is a list of topics represented by a list of psi-lists.
//+ cardMin and cardMax defines the number of times the topicType (= player)
//+ can be the player in a role of a given type (= roleTypes) in an
//+ association of a given type (= objects owner).
//+-----------------------------------------------------------------------------
{
- "playerType" : [ "topic-psi-1", "topic-psi-2", "..." ],
- "roleType" : [ "topic-psi-1", "topic-psi-2", "..." ],
+ "players" : [ [ "topic-psi-1", "topic-psi-2", "..." ], [ "topic-2-psi-1", "..."], <...> ]
+ "roleTypes" : [ [ "topic-psi-1", "topic-psi-2", "..." ], [ "subtype-psi-1", "..." ], <...> ],
"cardMin" : "unsigned integer in string representation",
"cardMax" : "unsigend integer in string representation or the string MAX_INT"
}
Modified: trunk/src/json/json_tmcl.lisp
==============================================================================
--- trunk/src/json/json_tmcl.lisp (original)
+++ trunk/src/json/json_tmcl.lisp Tue May 5 12:28:18 2009
@@ -11,14 +11,15 @@
(:use :cl :datamodel :constants :json-tmcl-constants)
(:export :get-constraints-of-fragment
:topictype-p
- :abstract-p))
+ :abstract-p
+ :list-subtypes))
(in-package :json-tmcl)
-;; -----------------------------------------------------------------------------
+;; =============================================================================
;; --- all fragment constraints ------------------------------------------------
-;; -----------------------------------------------------------------------------
+;; =============================================================================
(defun get-constraints-of-fragment(topic-psi &key (treat-as 'type))
(let ((associationtype (get-item-by-psi *associationtype-psi*))
(associationtype-constraint (get-item-by-psi *associationtype-constraint-psi*))
@@ -54,9 +55,9 @@
json-string)))))))
-;; -----------------------------------------------------------------------------
+;; =============================================================================
;; --- all association constraints ---------------------------------------------
-;; -----------------------------------------------------------------------------
+;; =============================================================================
(defun get-constraints-of-association (associationtype-topic)
"Returns a list of constraints which are describing associations of the
passed associationtype-topic."
@@ -94,7 +95,9 @@
(othertopictype-role (get-item-by-psi *othertopictype-role-psi*))
(otherroletype-role (get-item-by-psi *otherroletype-role-psi*))
(roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (get-item-by-psi *roletype-constraint-psi*)))
+ (roletype-constraint (get-item-by-psi *roletype-constraint-psi*))
+ (topictype (get-item-by-psi *topictype-psi*))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))
(let ((otherrole-constraints
(loop for constraint-topic in constraint-topics
append (let ((players nil)
@@ -177,17 +180,21 @@
(uri (first (psis (getf involved-topic-tupple :otherrole))))
constraint-lists))
(let ((json-player
- (concatenate 'string "\"playerType\":"
- (json-exporter::identifiers-to-json-string (getf involved-topic-tupple :player))))
+ (concatenate 'string "\"players\":"
+ (topics-to-json-list
+ (list-instances (getf involved-topic-tupple :player) topictype topictype-constraint))))
(json-role
- (concatenate 'string "\"roleType\":"
- (json-exporter::identifiers-to-json-string (getf involved-topic-tupple :role))))
+ (concatenate 'string "\"roleTypes\":"
+ (topics-to-json-list
+ (getf (list-subtypes (getf involved-topic-tupple :role) roletype roletype-constraint) :subtypes))))
(json-otherplayer
- (concatenate 'string "\"otherPlayerType\":"
- (json-exporter::identifiers-to-json-string (getf involved-topic-tupple :player))))
+ (concatenate 'string "\"otherPlayers\":"
+ (topics-to-json-list
+ (list-instances (getf involved-topic-tupple :otherplayer) topictype topictype-constraint))))
(json-otherrole
(concatenate 'string "\"otherRoleType\":"
- (json-exporter::identifiers-to-json-string (getf involved-topic-tupple :role))))
+ (topics-to-json-list
+ (getf (list-subtypes (getf involved-topic-tupple :otherrole) roletype roletype-constraint) :subtypes))))
(card-min
(concatenate 'string "\"cardMin\":" (getf (first constraint-lists) :card-min)))
(card-max
@@ -212,7 +219,9 @@
(topictype-role (get-item-by-psI *topictype-role-psi*))
(roletype-role (get-item-by-psi *roletype-role-psi*))
(roletype (get-item-by-psi *roletype-psi*))
- (roletype-constraint (get-item-by-psi *roletype-constraint-psi*)))
+ (roletype-constraint (get-item-by-psi *roletype-constraint-psi*))
+ (topictype (get-item-by-psi *topictype-psi*))
+ (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))
(let ((roleplayer-constraints
(loop for constraint-topic in constraint-topics
append (let ((constraint-list
@@ -251,11 +260,11 @@
(topictype-p current-player)
(topictype-p current-role roletype roletype-constraint)
(list :player current-player
- :role current-role)))
+ :role current-role)))
:test #'(lambda(x y)
(and (eq (getf x :player) (getf y :player))
(eq (getf x :role) (getf y :role)))))))
-
+
(let ((cleaned-roleplayer-constraints "["))
(loop for role-player-tupple in role-player-tupples
do (let ((constraint-lists
@@ -269,19 +278,21 @@
(uri (first (psis (getf role-player-tupple :role))))
(uri (first (psis (getf role-player-tupple :player))))
constraint-lists))
- (let ((json-player
- (concatenate 'string "\"playerType\":"
- (json-exporter::identifiers-to-json-string (getf role-player-tupple :player))))
+ (let ((json-players
+ (concatenate 'string "\"players\":"
+ (topics-to-json-list
+ (list-instances (getf role-player-tupple :player) topictype topictype-constraint))))
(json-role
- (concatenate 'string "\"roleType\":"
- (json-exporter::identifiers-to-json-string (getf role-player-tupple :role))))
+ (concatenate 'string "\"roleTypes\":"
+ (topics-to-json-list
+ (getf (list-subtypes (getf role-player-tupple :role) roletype roletype-constraint) :subtypes))))
(card-min
(concatenate 'string "\"cardMin\":" (getf (first constraint-lists) :card-min)))
(card-max
(concatenate 'string "\"cardMax\":" (getf (first constraint-lists) :card-max))))
(setf cleaned-roleplayer-constraints
(concatenate 'string cleaned-roleplayer-constraints
- "{" json-player "," json-role "," card-min "," card-max "},")))))
+ "{" json-players "," json-role "," card-min "," card-max "},")))))
(if (string= cleaned-roleplayer-constraints "[")
(setf cleaned-roleplayer-constraints "null")
(setf cleaned-roleplayer-constraints
@@ -325,12 +336,17 @@
collect (getf associationrole-constraint :constraint)))))
(when (> (length constraint-lists) 1)
(error "found contrary associationrole-constraints: ~a ~a~%" (uri (first (psis associationroletype-topic))) constraint-lists))
+ (let ((roletype-with-subtypes
+ (json:encode-json-to-string
+ (map 'list #'(lambda(topic)
+ (map 'list #'uri (psis topic)))
+ (getf (list-subtypes associationroletype-topic roletype roletype-constraint) :subtypes)))))
(setf cleaned-associationrole-constraints
(concatenate 'string
cleaned-associationrole-constraints
- "{\"roleType\":" (json-exporter::identifiers-to-json-string associationroletype-topic)
+ "{\"roleType\":" roletype-with-subtypes
",\"cardMin\":" (getf (first constraint-lists) :card-min)
- ",\"cardMax\":" (getf (first constraint-lists) :card-max) "},"))))
+ ",\"cardMax\":" (getf (first constraint-lists) :card-max) "},")))))
(if (string= cleaned-associationrole-constraints "[")
(setf cleaned-associationrole-constraints "null")
@@ -339,9 +355,9 @@
cleaned-associationrole-constraints)))))
-;; -----------------------------------------------------------------------------
+;; =============================================================================
;; --- all topic constraints ---------------------------------------------------
-;; -----------------------------------------------------------------------------
+;; =============================================================================
(defun get-constraints-of-topic (topic-instance &key(treat-as 'type))
"Returns a constraint list with the constraints:
subjectidentifier-constraints, subjectlocator-constraints,
@@ -425,7 +441,7 @@
"Transforms a list of simple constraint lists of the form
((:regexp <string> :card-min <string> :card-max <string>) <...>)
to a valid json list of the form
- [{\"regexp\":\"expr\",\"cardMin\":\"123\",\"cardMax\":\"456\"}, <...>]."
+ [{regexp: expr, cardMin: 123, cardMax: 456}, <...>]."
(let ((constraints "["))
(loop for constraint in simple-constraints
do (let ((constraint (concatenate 'string "{\"regexp\":"
@@ -446,12 +462,10 @@
(defun get-topicname-constraints(constraint-topics)
"Returns all topicname constraints as a list of the following form:
- ( ( :type <nametype-topic>
- :constraints ( ( :regexp <string> :card-min <string> :card-max <string>)
- <...>)
- :scopes ( ( :scope <scope-topic> :regexp <string> :card-min <string> :card-max <string>)
- <...>))
- <...>)."
+ [{nametypescopes:[{nameType: [psi-1, psi-2], scopeConstraints: [<scopeConstraint>]},
+ {nameType: [subtype-1-psi-1], scopeConstriants: [<scopeConstraints>]},
+ constraints: [<simpleConstraint>, <...>]},
+ <...>]."
(let ((constraint-role (get-item-by-psi *constraint-role-psi*))
(applies-to (get-item-by-psi *applies-to-psi*))
(nametype-role (get-item-by-psi *nametype-role-psi*))
@@ -466,16 +480,15 @@
append (loop for other-role in (roles (parent role))
when (eq nametype-role (instance-of other-role))
collect (let ((nametype-topic (player other-role))
- (constraint-list (get-constraint-topic-values constraint-topic)))
+ (constraint-list (get-constraint-topic-values constraint-topic)))
(list :type nametype-topic :constraint constraint-list))))))))
-
(let ((nametype-topics
- (remove-duplicates (map 'list #'(lambda(x)
- (let ((topicname-type
- (getf x :type)))
- (topictype-p topicname-type nametype nametype-constraint)
- topicname-type))
- topicname-constraints))))
+ (map 'list #'(lambda(x)
+ (let ((topicname-type
+ (getf x :type)))
+ (topictype-p topicname-type nametype nametype-constraint)
+ topicname-type))
+ topicname-constraints)))
(let ((cleaned-topicname-constraints "["))
(loop for nametype-topic in nametype-topics
do (let ((constraint-lists
@@ -487,17 +500,22 @@
(find-contrary-constraints constraint-lists)))
(when contrary-constraints
(error "found contrary topicname-constraints: ~a~%" contrary-constraints)))
- (let ((typescope-constraints
- (let ((current-scopes
- (get-typescope-constraints nametype-topic :what 'topicname)))
- (concatenate 'string "\"scopeConstraints\":" current-scopes)))
- (json-constraint-lists
- (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists)))
- (type-topic
- (concatenate 'string "\"nameType\":"
- (json-exporter::identifiers-to-json-string nametype-topic))))
- (setf cleaned-topicname-constraints
- (concatenate 'string cleaned-topicname-constraints "{" type-topic "," json-constraint-lists "," typescope-constraints "},")))))
+ (let ((nametype-with-subtypes
+ (remove-if #'null (getf (list-subtypes nametype-topic nametype nametype-constraint) :subtypes))))
+ (let ((nametypescopes "\"nametypescopes\":["))
+ (loop for current-topic in nametype-with-subtypes
+ do (let ((current-json-string
+ (concatenate 'string "{\"nameType\":" (json-exporter::identifiers-to-json-string current-topic)
+ ",\"scopeConstraints\":" (get-typescope-constraints current-topic :what 'topicname) "}")))
+ (setf nametypescopes (concatenate 'string nametypescopes current-json-string ","))))
+ (if (string= nametypescopes "\"nametypescopes\"[")
+ (setf nametypescopes "null")
+ (setf nametypescopes
+ (concatenate 'string (subseq nametypescopes 0 (- (length nametypescopes) 1)) "]")))
+ (let ((json-constraint-lists
+ (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists))))
+ (setf cleaned-topicname-constraints
+ (concatenate 'string cleaned-topicname-constraints "{" nametypescopes "," json-constraint-lists "},")))))))
(if (string= cleaned-topicname-constraints "[")
(setf cleaned-topicname-constraints "null")
(setf cleaned-topicname-constraints
@@ -548,24 +566,32 @@
(find-contrary-constraints constraint-lists)))
(when contrary-constraints
(error "found contrary topicname-constraints: ~a~%" contrary-constraints)))
- (let ((type-topic
- (concatenate 'string "\"occurrenceType\":"
- (json-exporter::identifiers-to-json-string occurrencetype-topic)))
- (typescope-constraints
- (let ((current-scopes
- (get-typescope-constraints occurrencetype-topic :what 'topicoccurrence)))
- (concatenate 'string "\"scopeConstraints\":" current-scopes)))
- (datatype-constraint
- (concatenate 'string "\"datatypeConstraint\":"
- (get-occurrence-datatype-constraint occurrencetype-topic)))
- (unique-constraints
- (concatenate 'string "\"uniqueConstraints\":"
- (get-simple-constraints unique-constraint-topics)))
- (json-constraint-lists
- (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists))))
- (setf cleaned-topicoccurrence-constraints
- (concatenate 'string cleaned-topicoccurrence-constraints
- "{" type-topic "," json-constraint-lists "," typescope-constraints "," datatype-constraint "," unique-constraints "},")))))
+
+
+ (let ((occurrencetype-with-subtypes
+ (getf (list-subtypes occurrencetype-topic occurrencetype occurrencetype-constraint) :subtypes)))
+
+ (let ((occurrencetypes-json-string "\"occurrenceTypes\":["))
+ (loop for current-topic in occurrencetype-with-subtypes
+ do (let ((current-json-string
+ (concatenate 'string "{\"occurrenceType\":" (json-exporter::identifiers-to-json-string current-topic)
+ ",\"scopeConstraints\":" (get-typescope-constraints current-topic :what 'topicoccurrence)
+ ",\"datatypeConstraint\":" (get-occurrence-datatype-constraint current-topic) "}")))
+ (setf occurrencetypes-json-string (concatenate 'string occurrencetypes-json-string current-json-string ","))))
+
+ (if (string= occurrencetypes-json-string "\"occurrenceTypes\"[")
+ (setf occurrencetypes-json-string "null")
+ (setf occurrencetypes-json-string
+ (concatenate 'string (subseq occurrencetypes-json-string 0 (- (length occurrencetypes-json-string) 1)) "]")))
+ (let ((unique-constraints
+ (concatenate 'string "\"uniqueConstraints\":"
+ (get-simple-constraints unique-constraint-topics)))
+ (json-constraint-lists
+ (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists))))
+ (let ((current-json-string
+ (concatenate 'string "{" occurrencetypes-json-string "," json-constraint-lists "," unique-constraints "}")))
+ (setf cleaned-topicoccurrence-constraints
+ (concatenate 'string cleaned-topicoccurrence-constraints current-json-string ","))))))))
(if (string= cleaned-topicoccurrence-constraints "[")
(setf cleaned-topicoccurrence-constraints "null")
(setf cleaned-topicoccurrence-constraints
@@ -609,9 +635,10 @@
a topicname, a topicoccurrence or an association. To specifiy of what kind
of element the scopes should be there is the key-variable what.
It can be set to 'topicname, 'topicoccurrence or 'association.
- The return value is of the form
- ( :scope <scope-topic>
- :constraint (:card-min <string> :card-max <string> ))."
+ The return value is of the form:
+ [{scopeTypes:[[[psi-1-1, psi-1-2], [subtype-1-psi-1, subtype-1-psi-2]], [[psi-2-1],
+ [subtype-1-psi-1], [subtype-2-psi-1]]], cardMin: <int-as-string>,
+ cardMax <int-as-string | MAX_INT>}, <...>]."
(let ((element-type-role-and-scope-constraint
(cond
((eq what 'topicname)
@@ -627,7 +654,8 @@
(get-item-by-psi *associationtypescope-constraint-psi*)))))
(scopetype-role (get-item-by-psi *scopetype-role-psi*))
(constraint-role (get-item-by-psi *constraint-role-psi*))
- (applies-to (get-item-by-psi *applies-to-psi*)))
+ (applies-to (get-item-by-psi *applies-to-psi*))
+ (scopetype (get-item-by-psi *scopetype-psi*)))
(when (and (= (length element-type-role-and-scope-constraint) 2)
(first element-type-role-and-scope-constraint)
(second element-type-role-and-scope-constraint))
@@ -677,13 +705,22 @@
constraint-lists))
(let ((card-min (getf (first constraint-lists) :card-min))
(card-max (getf (first constraint-lists) :card-max)))
- (let ((json-scopes "\"scopeTypes\":["))
- (dolist (item scopetype-group)
- (let ((json-list (json-exporter::identifiers-to-json-string item)))
- (setf json-scopes (concatenate 'string json-scopes json-list ","))))
- (setf json-scopes (subseq json-scopes 0 (- (length json-scopes) 1)))
+ (let ((json-scopes
+ (concatenate 'string "\"scopeTypes\":"
+
+ (let ((scopetypes-with-subtypes
+ (remove-if #'null
+ (loop for current-scopetype in scopetype-group
+ collect (getf (list-subtypes current-scopetype scopetype nil) :subtypes)))))
+
+ (json:encode-json-to-string
+ (map 'list #'(lambda(topic-group)
+ (map 'list #'(lambda(topic)
+ (map 'list #'uri (psis topic)))
+ topic-group))
+ scopetypes-with-subtypes))))))
(let ((current-json-string
- (concatenate 'string "{" json-scopes "],\"cardMin\":\"" card-min "\",\"cardMax\":\"" card-max "\"}")))
+ (concatenate 'string "{" json-scopes ",\"cardMin\":\"" card-min "\",\"cardMax\":\"" card-max "\"}")))
(setf cleaned-typescope-constraints
(concatenate 'string cleaned-typescope-constraints current-json-string ",")))))))
(if (string= cleaned-typescope-constraints "[")
@@ -693,9 +730,9 @@
cleaned-typescope-constraints)))))))
-;; -----------------------------------------------------------------------------
+;; =============================================================================
;; --- some basic helpers ------------------------------------------------------
-;; -----------------------------------------------------------------------------
+;; =============================================================================
(defun get-constraint-topic-values(topic)
"Returns all constraint values of the passed topic in the
following form (list :regexp regexp :card-min card-min :card-max card-max)"
@@ -946,11 +983,14 @@
current-checked-topics))
-(defun topictype-of-p (topic-instance type-instance &optional 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"
+ 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)))
- (topictype (get-item-by-psi *topictype-psi*))
(isas-of-this (get-direct-types-of-topic topic-instance))
(akos-of-this (get-direct-supertypes-of-topic topic-instance)))
@@ -962,7 +1002,7 @@
(return-from topictype-of-p nil))
(loop for isa-of-this in isas-of-this
- do (let ((found-topics (topictype-p isa-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)
@@ -970,13 +1010,15 @@
(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 current-checked-topics)))
+ 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))))
- (when (find type-instance current-checked-topics)
+ (if type-instance
+ (when (find type-instance current-checked-topics)
+ current-checked-topics)
current-checked-topics)))
@@ -1170,6 +1212,8 @@
(constraint-role (get-item-by-psi *constraint-role-psi*))
(othertopictype-role (get-item-by-psi *othertopictype-role-psi*))
(associationtype-role (get-item-by-psi *associationtype-role-psi*))
+ (associationtype (get-item-by-psi *associationtype-psi*))
+ (associationtype-constraint (get-item-by-psi *associationtype-constraint-psi*))
(roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*))
(otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*))
(all-possible-player-topics
@@ -1178,9 +1222,6 @@
(topictype-p topic-instance)
(loop for topic in (union (get-direct-types-of-topic topic-instance) (get-direct-supertypes-of-topic topic-instance))
append (topictype-p topic))))))
-
-
- ;what's with associationrole-constraints without a player-constraint???
(let ((all-available-associationtypes
(remove-duplicates
(loop for possible-player-topic in all-possible-player-topics
@@ -1197,5 +1238,81 @@
(eq applies-to (instance-of (parent c-role))))
append (loop for type-role in (roles (parent c-role))
when (eq associationtype-role (instance-of type-role))
- collect (player type-role)))))))))
- all-available-associationtypes)))
\ No newline at end of file
+ append (map 'list #'(lambda(x)
+ (topictype-p x associationtype associationtype-constraint)
+ x)
+ (getf (list-subtypes (player type-role) associationtype associationtype-constraint) :subtypes))))))))))
+ 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
Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp (original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp Tue May 5 12:28:18 2009
@@ -14,7 +14,7 @@
(defparameter *json-get-all-psis* "/json/psis/?$") ;the url to get all topic psis of isidorus -> localhost:8000/json/psis
(defparameter *json-get-summary-url* "/json/summary/?$") ;the url to get a summary od all topic stored in isidorus; you have to set the GET-parameter "start" for the start index of all topics within elephant and the GET-paramter "end" for the last index of the topic sequence -> http://localhost:8000/json/summary/?start=12&end=13
(defparameter *json-get-all-type-psis* "/json/tmcl/types/?$") ;returns a list of all psis that can be a type
-(defparameter *json-get-topic-stub-prefix* "/json/tmcl/topicstubs/(.+)$") ;the json prefix for getting some topic stub information of a topic and its "derived" topics
+(defparameter *json-get-topic-stub-prefix* "/json/topicstubs/(.+)$") ;the json prefix for getting some topic stub information of a topic
(defparameter *json-get-type-tmcl-prefix* "/json/tmcl/type/(.+)$") ;the json prefix for getting some tmcl information of a topic treated as a type
(defparameter *json-get-instance-tmcl-prefix* "/json/tmcl/instance/(.+)$") ;the json prefix for getting some tmcl information of a topic treated as an instance
(defparameter *ajax-user-interface-url* "/isidorus/?$") ;the url to the user interface; if you want to get all topics set start=0&end=nil -> localhost:8000/isidorus
More information about the Isidorus-cvs
mailing list