[isidorus-cvs] r334 - in trunk/src: . base-tools model xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Nov 9 20:00:21 UTC 2010
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 '/'."
More information about the Isidorus-cvs
mailing list