Author: lgiessmann Date: Tue Nov 9 15:52:19 2010 New Revision: 335
Log: changed the function invoke-on, so an additional cast-operation can't be passed, since the casting can be done in the main-operation directly; added the functions: names-by-type, names-by-value, occurrences-by-type, occurrences-by-value, characterisitcs-by-type, characterisitcs-by-value; added the condition bad-type-error
Modified: trunk/src/model/datamodel.lisp trunk/src/model/exceptions.lisp trunk/src/model/trivial-queries.lisp
Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 9 15:52:19 2010 @@ -15,7 +15,8 @@ object-not-found-error missing-argument-error not-mergable-error - tm-reference-error) + tm-reference-error + bad-type-error) (:import-from :constants *xml-string* *instance-psi*) @@ -167,7 +168,13 @@ :direct-supertypes :supertypes :direct-instance-of - :invoke-on)) + :invoke-on + :names-by-type + :occurrencs-by-type + :characteristics-by-type + :occurrences-by-value + :names-by-value + :characteristics-by-value))
(in-package :datamodel)
@@ -648,6 +655,14 @@ :new-reference new-reference))
+(defun make-bad-type-condition (message expected-type result-object) + (make-condition + 'bad-type-error + :message message + :expected-type expected-type + :result-object result-object)) + + (defun make-not-mergable-condition (message construct-1 construct-2) "Returns a not-mergable-condition with the passed arguments." (make-condition 'not-mergable-error
Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Tue Nov 9 15:52:19 2010 @@ -16,7 +16,8 @@ :object-not-found-error :not-mergable-error :missing-argument-error - :tm-reference-error)) + :tm-reference-error + :bad-type-error))
(in-package :exceptions)
@@ -103,6 +104,20 @@ (new-reference :initarg :new-reference :accessor new-reference)) - (:documentation "Thrown of the referenced-construct is already owned by another + (:documentation "Thrown if the referenced-construct is already owned by another TM-construct (existing-reference) and is going to be referenced - by a second TM-construct (new-reference) at the same time.")) \ No newline at end of file + by a second TM-construct (new-reference) at the same time.")) + + +(define-condition bad-type-error (error) + ((message + :initarg :message + :accessor message) + (expected-type + :initarg :expected-type + :accessor expected-type) + (result-object + :initarg :result-object + :accessor result-object)) + (:documentation "Thrown if a bad result object with respect to the expected + type was found.")) \ No newline at end of file
Modified: trunk/src/model/trivial-queries.lisp ============================================================================== --- trunk/src/model/trivial-queries.lisp (original) +++ trunk/src/model/trivial-queries.lisp Tue Nov 9 15:52:19 2010 @@ -225,15 +225,88 @@ (remove-if #'null all-types)))))
-(defgeneric invoke-on (construct main-operation &key cast-operation) +(defgeneric invoke-on (construct 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 + (:method ((construct TopicC) (operation Function)) + (funcall operation (charvalue construct)))) + + +(defgeneric names-by-type (construct type-identifier &key revision) + (:documentation "Returns all names that are of the corresponding type.") + (:method ((construct TopicC) (type-identifier IdentifierC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((type-topic (identified-construct type-identifier :revision revision))) + (unless (typep type-topic 'TopicC) + (error (make-bad-type-condition (format nil "from name-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic))) + (let ((results + (map 'list #'(lambda(name) + (when (instance-of name :revision revision) + name)) + (names construct :revision revision)))) + (remove-if #'null results))))) + + +(defgeneric occurrences-by-type (construct type-identifier &key revision) + (:documentation "Returns all names that are of the corresponding type.") + (:method ((construct TopicC) (type-identifier IdentifierC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((type-topic (identified-construct type-identifier :revision revision))) + (unless (typep type-topic 'TopicC) + (error (make-bad-type-condition (format nil "from occurrence-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic))) + (let ((results + (map 'list #'(lambda(occ) + (when (instance-of occ :revision revision) + occ)) + (occurrences construct :revision revision)))) + (remove-if #'null results))))) + + +(defgeneric characteristic-by-type (construct type-identifier &key revision) + (:documentation "Returns all characteristics that are of the + corresponding type.") + (:method ((construct TopicC) (type-identifier IdentifierC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (union (names-by-type construct type-identifier :revision revision) + (occurrences-by-type construct type-identifier :revision revision)))) + + +(defgeneric occurrences-by-value (construct filter &key revision) + (:documentation "Returns a list of all occurrences of the passed + topic, that return a true value when calling filter + on their charvalue.") + (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) + (let ((results + (map 'list #'(lambda(occ) + (when (invoke-on occ filter) + occ)) + (occurrences construct :revision revision)))) + (remove-if #'null results)))) + + +(defgeneric names-by-value (construct filter &key revision) + (:documentation "Returns a list of all names of the passed + topic, that return a true value when calling filter + on their charvalue.") + (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) + (let ((results + (map 'list #'(lambda(name) + (when (invoke-on name filter) + name)) + (names construct :revision revision)))) + (remove-if #'null results)))) + + +(defgeneric characteristic-by-value (construct filter &key revision) + (:documentation "Returns a list of all characteristics of the passed + topic, that return a true value when calling filter.") + (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (union (names-by-value construct filter :revision revision) + (occurrences-by-value construct filter :revision revision)))) \ No newline at end of file