Author: lgiessmann Date: Tue Nov 9 15:00:20 2010 New Revision: 334 Log: added the file trivial-queries.lisp => currently it contains trivial query functions for roles and associations and an invoke-on method for characteristics that invokes a method with the characteristics value as parameter, additionally a cast-operation can be passed to cast the string-value to a certain type, e.g. integer. Added: trunk/src/base-tools/ trunk/src/base-tools/base-tools.lisp trunk/src/model/trivial-queries.lisp Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp Added: trunk/src/base-tools/base-tools.lisp ============================================================================== --- (empty file) +++ trunk/src/base-tools/base-tools.lisp Tue Nov 9 15:00:20 2010 @@ -0,0 +1,33 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(defpackage :base-tools + (:use :cl) + (:nicknames :tools) + (:export :push-string + :when-do)) + +(in-package :base-tools) + + +(defmacro push-string (obj place) + "Imitates the push macro but instead of pushing object in a list, + there will be appended the given string to the main string object." + `(setf ,place (concatenate 'string ,place ,obj))) + + +(defmacro when-do (result-bounding condition-statement do-with-result) + "Executes the first statement and stores its result in the variable result. + If result isn't nil the second statement is called. + The second statement can use the variable tools:result as a parameter." + `(let ((,result-bounding ,condition-statement)) + (if ,result-bounding + ,do-with-result + nil))) + Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Nov 9 15:00:20 2010 @@ -27,12 +27,16 @@ (:file "xml-constants" :depends-on ("xml/xtm/core_psis.xtm" "constants")) + (:module "base-tools" + :components ((:file "base-tools"))) (:module "model" :components ((:file "exceptions") (:file "datamodel" :depends-on ("exceptions")) + (:file "trivial-queries" + :depends-on ("datamodel")) (:file "changes" - :depends-on ("datamodel")) + :depends-on ("datamodel" "trivial-queries")) (:file "model_tools" :depends-on ("exceptions"))) :depends-on ("constants")) @@ -65,7 +69,8 @@ :depends-on ("constants" "xml-constants" "model" - "threading")) + "threading" + "base-tools")) (:module "atom" :components ((:file "atom") ;; (:file "configuration" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 9 15:00:20 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :datamodel - (:use :cl :elephant :constants) + (:use :cl :elephant :constants :base-tools) (:nicknames :d) (:import-from :exceptions duplicate-identifier-error @@ -152,10 +152,22 @@ :get-all-associations :get-all-tms - ;;globals :*TM-REVISION* - :*CURRENT-XTM*)) + :*CURRENT-XTM* + + ;;trivial-queries + :roles-by-type + :roles-by-player + :filter-associations-by-type + :filter-associations-by-role + :associations-of + :instance-of-associations + :supertype-associations + :direct-supertypes + :supertypes + :direct-instance-of + :invoke-on)) (in-package :datamodel) Added: trunk/src/model/trivial-queries.lisp ============================================================================== --- (empty file) +++ trunk/src/model/trivial-queries.lisp Tue Nov 9 15:00:20 2010 @@ -0,0 +1,239 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(in-package :datamodel) + + +(defgeneric roles-by-type (construct role-type &key revision) + (:documentation "Returns all roles of the passed topic or + association that is of the specified role-type. + If role-type is set to nil all roles are returned.")) + + +(defmethod roles-by-type ((construct TopicC) role-type &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-type)) + (if role-type + (remove-if #'null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + role-type) + role)) + (player-in-roles construct :revision revision))) + (player-in-roles construct :revision revision))) + + +(defmethod roles-by-type ((construct AssociationC) role-type + &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-type)) + (if role-type + (remove-if #'null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + role-type) + role)) + (roles construct :revision revision))) + (roles construct :revision revision))) + + +(defgeneric roles-by-player (construct role-player &key revision) + (:documentation "Returns all roles that contains the corresponding player. + If the player is set to nil all roles are returned.") + (:method ((construct AssociationC) role-player &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-player)) + (if role-player + (remove-if #'null + (map 'list #'(lambda(role) + (when (eql (player role :revision revision) + role-player) + role)) + (roles construct :revision revision))) + (roles construct :revision revision)))) + + +(defun filter-associations-by-type (associations association-type + &key (revision *TM-REVISION*)) + "Returns a list of associations that are an instance-of of the given + association-type. If association-type is set to nil, all associations + are returned." + (declare (List associations) + (type (or Null TopicC) association-type) + (integer revision)) + (if association-type + (remove-if #'(lambda(assoc) + (not (eql (instance-of assoc :revision revision) + association-type))) + associations) + associations)) + + +(defun filter-associations-by-role (associations role-type role-player + &key (revision *TM-REVISION*)) + "Returns associations that have a role corresponding to the passed + values. If any of the passed role-values is set to nil, it won't be used + for the evaluation of the result." + (declare (List associations) + (type (or Null TopicC) role-type role-player)) + (remove-if #'null + (intersection + (map 'list #'(lambda(assoc) + (when (roles-by-type assoc role-type + :revision revision) + assoc)) + associations) + (map 'list #'(lambda(assoc) + (when (roles-by-player assoc role-player + :revision revision) + assoc)) + associations)))) + + +(defgeneric associations-of (construct role-type association-type + other-role-type other-player + &key revision) + (:documentation "Returns all associations of the passed topic (construct) + that corresponds to the given values. + If any of the passed values is set to nil, it won't be + used to evaluate the result.") + (:method ((construct TopicC) role-type association-type other-role-type + other-player &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-type association-type + other-role-type other-player)) + (let ((assocs-by-role (map 'list #'(lambda(role) + (parent role :revision revision)) + (roles-by-type construct role-type + :revision revision)))) + (let ((assocs-by-type + (filter-associations-by-type assocs-by-role association-type + :revision revision))) + (filter-associations-by-role assocs-by-type other-role-type + other-player :revision revision))))) + + +(defgeneric instance-of-associations (construct &key revision) + (:documentation "Returns all type-instance associations of + the passed instance topic.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((type-top + (get-item-by-psi *type-psi* :revision revision :error-if-nil t)) + (instance-top + (get-item-by-psi *instance-psi* :revision revision :error-if-nil t)) + (type-instance-top + (get-item-by-psi *type-instance-psi* :revision revision + :error-if-nil t))) + (let ((possible-assocs + (map 'list #'(lambda(role) + (parent role :revision revision)) + (roles-by-type construct instance-top :revision revision)))) + (let ((type-instance-assocs + (filter-associations-by-type possible-assocs type-instance-top + :revision revision))) + (filter-associations-by-role type-instance-assocs type-top nil + :revision revision)))))) + + +(defgeneric supertype-associations (construct &key revision) + (:documentation "Returns all supertype-subtype associations of + the passed subtype topic.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((supertype-top + (get-item-by-psi *supertype-psi* :revision revision :error-if-nil t)) + (subtype-top + (get-item-by-psi *subtype-psi* :revision revision :error-if-nil t)) + (supertype-subtype-top + (get-item-by-psi *supertype-subtype-psi* :revision revision + :error-if-nil t))) + (let ((possible-assocs + (map 'list #'(lambda(role) + (parent role :revision revision)) + (roles-by-type construct subtype-top :revision revision)))) + (let ((type-instance-assocs + (filter-associations-by-type possible-assocs supertype-subtype-top + :revision revision))) + (filter-associations-by-role type-instance-assocs supertype-top nil + :revision revision)))))) + + +(defgeneric direct-supertypes (construct &key revision) + (:documentation "Returns all direct super type topics of the passed + construct.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((assocs (supertype-associations construct :revision revision))) + (remove-if #'null + (map 'list #'(lambda(assoc) + (find-if-not + #'(lambda(role) + (eql (player role :revision revision) + construct)) + (roles assoc :revision revision))) + assocs))))) + + +(defgeneric supertypes (construct &key revision valid-supertypes) + (:documentation "Returns all super type topics of the passed + construct, also the transitive ones.") + (:method ((construct TopicC) &key (revision *TM-REVISION*) valid-supertypes) + (declare (integer revision)) + (let ((direct-super-types (direct-supertypes construct :revision revision))) + (let ((current-valid-super-types + (append valid-supertypes direct-super-types))) + (let ((recursive-super-types + (loop for direct-super-type in direct-super-types + append (supertypes + direct-super-type :revision revision + :valid-supertypes current-valid-super-types)))) + (remove-duplicates + (remove-if #'null recursive-super-types))))))) + + +(defgeneric direct-instance-of (construct &key revision) + (:documentation "Returns all direct type topics of the passed instance topic.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((assocs (instance-of-associations construct :revision revision))) + (remove-if #'null + (map 'list #'(lambda(assoc) + (find-if-not + #'(lambda(role) + (eql (player role :revision revision) + construct)) + (roles assoc :revision revision))) + assocs))))) + + +(defmethod instance-of (construct &key (revision *TM-REVISION*)) + "Returns all type topics of the passed construct and their super-types." + (declare (integer revision)) + (let ((all-super-types (supertypes construct :revision revision))) + (let ((all-types + (loop for topic in (append (list construct) all-super-types) + append (direct-instance-of topic :revision revision)))) + (remove-duplicates + (remove-if #'null all-types))))) + + +(defgeneric invoke-on (construct main-operation &key cast-operation) + (:documentation "Invokes the passed main operation on the characteristic's + value. + If cast-operation is set to a function the characteristic's + value is first casted by the cast-operation to another type + and afterwords processed by main-opertion.") + (:method ((construct TopicC) (main-operation Function) &key cast-operation) + (declare (type (or Null Function) cast-operation)) + (let ((value (if cast-operation + (apply cast-operation (list (charvalue construct))) + (charvalue construct)))) + (funcall main-operation value)))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Tue Nov 9 15:00:20 2010 @@ -8,7 +8,8 @@ ;;+----------------------------------------------------------------------------- (defpackage :rdf-importer - (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel + :base-tools) (:import-from :constants *rdf-ns* *rdfs-ns* @@ -78,7 +79,6 @@ absolutize-value absolutize-id concatenate-uri - push-string node-to-string) (:import-from :xml-importer get-uuid Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Tue Nov 9 15:00:20 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :xml-tools - (:use :cl :cxml) + (:use :cl :cxml :base-tools) (:import-from :constants *xml-ns* *xmlns-ns* @@ -29,17 +29,10 @@ :absolutize-value :absolutize-id :concatenate-uri - :push-string :node-to-string)) (in-package :xml-tools) -(defmacro push-string (obj place) - "Imitates the push macro but instead of pushing object in a list, - there will be appended the given string to the main string object." - `(setf ,place (concatenate 'string ,place ,obj))) - - (defun concatenate-uri (absolute-ns value) "Returns a string conctenated of the absolut namespace an the given value separated by either '#' or '/'."