Author: lgiessmann Date: Thu Mar 18 08:39:15 2010 New Revision: 232 Log: new-datamodel: added the helper function "make-characteristic" for "make-construct"; fixed a bug in all add-<construct> generics that are defined for "VersionedConstruct"s, so currently adding a charactersistic or pointer calls add-to-version-history with the given revision for the called parent-construct and signals that the parent-construct was changed in the given revision. 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 Thu Mar 18 08:39:15 2010 @@ -125,7 +125,8 @@ ;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier, ;; add-psi, add-locator - +;;TODO: all add-<construct> methods hve to add an version info to the +;; owner-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -662,6 +663,11 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric get-all-characteristics (parent-construct characteristic-symbol) + (:documentation "Returns all characterisitcs of the passed type the parent + construct was ever associated with.")) + + (defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) (:documentation "Returns t if the passed construct is equivalent to the passed @@ -810,6 +816,14 @@ ;;; TopicMapconstructC +(defmethod get-all-characteristics ((parent-construct TopicC) + (characteristic-symbol symbol)) + (cond ((OccurrenceC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'occurrences))) + ((NameC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'names))))) + + (defgeneric TopicMapConstructC-p (class-symbol) (:documentation "Returns t if the passed class is equal to TopicMapConstructC or one of its subtypes.") @@ -1091,6 +1105,8 @@ :parent-construct construct :identifier topic-identifier))) (add-to-version-history assoc :start-revision revision)))) + (when (typep construct 'TopicC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1144,6 +1160,7 @@ :parent-construct construct :identifier psi))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct))) @@ -1197,6 +1214,7 @@ :parent-construct construct :identifier locator))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct))) @@ -1247,6 +1265,7 @@ :parent-construct construct :characteristic name))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct)) @@ -1296,6 +1315,7 @@ :parent-construct construct :characteristic occurrence))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct)) @@ -1600,6 +1620,12 @@ ;;; NameC +(defmethod get-all-characteristics ((parent-construct NameC) + (characteristic-symbol symbol)) + (when (VariantC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'variants)))) + + (defgeneric NameC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to Name.") (:method ((class-symbol symbol)) @@ -1747,6 +1773,7 @@ :role role :parent-construct construct))) (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history construct :start-revision revision) construct)) @@ -1842,6 +1869,7 @@ :role construct :parent-construct parent-construct))) (add-to-version-history assoc :start-revision revision))))) + (add-to-version-history parent-construct :start-revision revision) construct) @@ -1999,6 +2027,10 @@ :parent-construct construct :identifier item-identifier))) (add-to-version-history assoc :start-revision revision)))) + (when (or (typep construct 'TopicC) + (typep construct 'AssociationC) + (typep construct 'TopicMapC)) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2049,6 +2081,10 @@ :reifiable-construct construct :reifier-topic merged-reifier-topic))) (add-to-version-history assoc :start-revision revision)))) + (when (or (typep construct 'TopicC) + (typep construct 'AssociationC) + (typep construct 'TopicMapC)) + (add-to-version-history construct :start-revision revision)) construct)))) @@ -2137,6 +2173,8 @@ :theme-topic theme-topic :scopable-construct construct))) (add-to-version-history assoc :start-revision revision)))) + (when (typep construct 'AssociationC) + (add-to-version-history construct :start-revision revision)) construct)) @@ -2207,6 +2245,8 @@ :type-topic type-topic :typable-construct construct))) (add-to-version-history assoc :start-revision revision))))) + (when (typep construct 'AssociationC) + (add-to-version-history construct :start-revision revision)) construct)) @@ -2300,11 +2340,53 @@ construct))) +(defun make-characteristic (class-symbol charvalue + &key (start-revision *TM-REVISION*) + (datatype *xml-string*) (themes nil) + (instance-of nil) (variants nil) + (parent-construct nil)) + "Returns a characteristic object with the passed parameters. + If an equivalent construct has already existed this one is returned. + To check if there is existing an equivalent construct the parameter + parent-construct must be set." + (declare (symbol class-symbol) (string charvalue) (integer start-revision) + (list themes variants) + (type (or null string) datatype) + (type (or null TopicC) instance-of) + (type (or null TopicC NameC) parent-construct)) + (let ((characteristic + (let ((existing-characteristic + (when parent-construct + (remove-if + #'null + (map 'list #'(lambda(existing-characteristic) + (when (equivalent-construct + existing-characteristic + :start-revision start-revision + :datatype datatype :themes themes + :instance-of instance-of) + existing-characteristic)) + (get-all-characteristics parent-construct + class-symbol)))))) + (if existing-characteristic + existing-characteristic + (make-instance class-symbol :charvalue charvalue + :datatype datatype))))) + (dolist (theme themes) + (add-theme characteristic theme :revision start-revision)) + (when instance-of + (add-type characteristic instance-of :revision start-revision)) + (dolist (variant variants) + (add-variant characteristic variant :revision start-revision)) + (when parent-construct + (add-parent characteristic parent-construct :revision start-revision)))) + (defun make-pointer (class-symbol uri &key (start-revision *TM-REVISION*) (xtm-id nil) (identified-construct nil)) - "Returns a pointer object with the specified parameters." + "Returns a pointer object with the specified parameters. + If an equivalen construct has already existed this one is returned." (declare (symbol class-symbol) (string uri) (integer start-revision) (type (or null string) xtm-id) (type (or null ReifiableconstructC)))