Author: lgiessmann Date: Sun Mar 21 05:14:10 2010 New Revision: 237 Log: new-datamodel: fixed some sections that cauesd errors with the "changes.lisp" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 21 05:14:10 2010 @@ -14,6 +14,8 @@ duplicate-identifier-error) (:import-from :constants *xml-string*) + (:import-from :constants + *instance-psi*) (:export ;;classes :TopicMapC :AssociationC @@ -114,6 +116,9 @@ :TopicMapConstructC-p :VersionedConstructC-p :make-construct + :list-instanceOf + :in-topicmap + :string-start-with ;;globals :*TM-REVISION* @@ -315,9 +320,11 @@ (elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) ((topics :associate (TopicC in-topicmaps) :many-to-many t + :accessor topics :documentation "List of topics that explicitly belong to this TM.") (associations :associate (AssociationC in-topicmaps) :many-to-many t + :accessor associations :documentation "List of associations that belong to this TM.")) (:documentation "Represnets a topic map.")) @@ -673,7 +680,28 @@ (merge-constructs merged-construct construct-to-be-merged))))) +(defgeneric internal-id (construct) + (:documentation "Returns the internal id that uniquely identifies a + construct (currently simply its OID).")) + + +(defmethod internal-id ((construct TopicMapConstructC)) + (slot-value construct (find-symbol "OID" 'elephant))) + + +(defun string-starts-with (str prefix) + "Checks if string str starts with a given prefix." + (declare (string str prefix)) + (string= str prefix :start1 0 :end1 + (min (length prefix) + (length str)))) + + ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric get-all-identifiers-of-construct (construct &key revision) + (:documentation "Get all identifiers that a given construct has")) + + (defgeneric get-all-characteristics (parent-construct characteristic-symbol) (:documentation "Returns all characterisitcs of the passed type the parent construct was ever associated with.")) @@ -700,7 +728,7 @@ (defgeneric in-topicmaps (construct &key revision) - (:documentation "Returns all TopicMapS-obejcts where the constrict is + (:documentation "Returns all TopicMaps-obejcts where the construct is contained in.")) @@ -1250,6 +1278,14 @@ construct))) +(defmethod get-all-identifiers-of-construct ((construct TopicC) + &key (revision 0)) + (declare (integer revision)) + (append (psis construct :revision revision) + (locators construct :revision revision) + (item-identifiers construct :revision revision))) + + (defgeneric names (construct &key revision) (:documentation "Returns the NameC-objects that correspond with the passed construct and the passed version.") @@ -1489,6 +1525,30 @@ :error-if-nil error-if-nil)) + +(defgeneric list-instanceOf (topic &key tm) + (:documentation "Generates a list of all topics that this topic is an + instance of, optionally filtered by a topic map")) + + +(defmethod list-instanceOf ((topic TopicC) &key (tm nil)) + (remove-if + #'null + (map 'list #'(lambda(x) + (when (loop for psi in (psis (instance-of x)) + when (string= (uri psi) constants:*instance-psi*) + return t) + (loop for role in (roles (parent x)) + when (not (eq role x)) + return (player role)))) + (if tm + (remove-if-not + (lambda (role) + (in-topicmap tm (parent role))) + (player-in-roles topic)) + (player-in-roles topic))))) + + ;;; CharacteristicC (defgeneric CharacteristicC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to CharacteristicC @@ -2135,6 +2195,13 @@ (mark-as-deleted assoc-to-delete :revision revision)) construct))) + +(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC) + &key (revision 0)) + (declare (integer revision)) + (item-identifiers construct :revision revision)) + + ;;; TypableC (defgeneric TypableC-p (class-symbol) (:documentation "Returns t if the passed class is equal to TypableC or @@ -2343,20 +2410,6 @@ (remove-association construct 'associations assoc))) -(defgeneric topics (construct &key revision) - (:documentation "Returns all TopicC-objects that are contained in the tm.") - (:method ((construct TopicMapC) &key (revision 0)) - (filter-slot-value-by-revision construct 'topics - :start-revision revision))) - - -(defgeneric associations (construct &key revision) - (:documentation "Returns all AssociationC-objects that are contained in the tm.") - (:method ((construct TopicMapC) &key (revision 0)) - (filter-slot-value-by-revision construct 'associations - :start-revision revision))) - - (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) (add-association construct 'topics construct-to-add)) @@ -2374,6 +2427,21 @@ (remove-association construct 'associations construct-to-delete)) +(defgeneric in-topicmap (tm construct &key revision) + (:documentation "Is a given construct (topic or assiciation) in this + topic map?")) + + +(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0)) + (when (find-item-by-revision top revision) + (find (internal-id top) (topics tm) :test #'= :key #'internal-id))) + + +(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) + (when (find-item-by-revision ass revision) + (find (internal-id ass) (associations tm) :test #'= :key #'internal-id))) + + ;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun make-construct (class-symbol &rest args) "Creates a new topic map construct if necessary or @@ -2386,7 +2454,7 @@ ((PointerC-p class-symbol) (make-pointer class-symbol (getf args :uri) args)) ((CharacteristicC-p class-symbol) - (make-characteristic class-symbol (getf args :charvalue) args)) + (make-characteristic class-symbol args)) ((TopicC-p class-symbol) (make-topic args)) ((TopicMapC-p class-symbol)