- isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

[isidorus-cvs] r234 - in branches/new-datamodel/src: json model rest_interface unit_tests xml/rdf xml/xtm
by Lukas Giessmann 20 Mar '10

20 Mar '10

Author: lgiessmann Date: Sat Mar 20 16:33:55 2010 New Revision: 234 Log: new-datamodel: implemented "make-topic" and other helper functions for "make-cosntruct"; fixed a bug in "add-topic-identifier", "add-psi", "add-item-identifier" and "add-locator" with "merge-constructs" Modified: branches/new-datamodel/src/json/json_importer.lisp branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/rest_interface/rest-interface.lisp branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp branches/new-datamodel/src/xml/rdf/importer.lisp branches/new-datamodel/src/xml/xtm/setup.lisp Modified: branches/new-datamodel/src/json/json_importer.lisp ============================================================================== --- branches/new-datamodel/src/json/json_importer.lisp (original) +++ branches/new-datamodel/src/json/json_importer.lisp Sat Mar 20 16:33:55 2010 @@ -32,13 +32,19 @@ (topicStubs-values (getf fragment-values :topicStubs)) (associations-values (getf fragment-values :associations)) (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment - (elephant:ensure-transaction (:txn-nosync nil) - (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) - (loop for topicStub-values in (append topicStubs-values (list topic-values)) - do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) - (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) - (loop for association-values in associations-values - do (json-to-association association-values rev :tm xml-importer::tm)))))))) + (let ((psi-of-topic + (let ((psi-uris (getf topic-values :subjectIdentifiers))) + (when psi-uris + (first psi-uris))))) + (elephant:ensure-transaction (:txn-nosync nil) + (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) + (loop for topicStub-values in (append topicStubs-values (list topic-values)) + do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) + (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) + (loop for association-values in associations-values + do (json-to-association association-values rev :tm xml-importer::tm)))) + (when psi-of-topic + (create-latest-fragment-of-topic psi-of-topic))))))) (defun json-to-association (json-decoded-list start-revision Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Sat Mar 20 16:33:55 2010 @@ -277,7 +277,7 @@ (defun create-latest-fragment-of-topic (topic-psi) - "returns the latest fragment of the passed topic-psi" + "Returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) (let ((topic (get-item-by-psi topic-psi))) @@ -299,4 +299,18 @@ :revision start-revision :associations (find-associations-for-topic topic) :referenced-topics (find-referenced-topics topic) - :topic topic))))))) \ No newline at end of file + :topic topic))))))) + + +(defun get-latest-fragment-of-topic (topic-psi) + "Returns the latest existing fragment of the passed topic-psi." + (declare (string topic-psi)) + (let ((topic + (get-item-by-psi topic-psi))) + (when topic + (let ((existing-fragments + (elephant:get-instances-by-value 'FragmentC 'topic topic))) + (when existing-fragments + (first (sort existing-fragments + #'(lambda(frg-1 frg-2) + (> (revision frg-1) (revision frg-2)))))))))) \ No newline at end of file Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sat Mar 20 16:33:55 2010 @@ -92,6 +92,8 @@ :get-item-by-locator :string-integer-p :with-revision + :get-latest-fragment-of-topic + :create-latest-fragment-of-topic :PointerC-p :IdentifierC-p :SubjectLocatorC-p @@ -122,9 +124,10 @@ -;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier -;; (can merge the parent construct and the parent's parent construct), -;; add-psi, add-locator +;;TODO: check merge-constructs in add-topic-identifier, +;; add-item-identifier/add-reifier (can merge the parent construct +;; and the parent's parent construct), add-psi, add-locator +;; (--> duplicate-identifier-error) ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -1007,19 +1010,22 @@ (defmethod equivalent-construct ((construct TopicC) &key (start-revision 0) (psis nil) - (locators nil) (item-identifiers nil)) + (locators nil) (item-identifiers nil) + (topic-identifiers nil)) "Isidorus handles Topic-equality only by the topic's identifiers 'psis', 'subject locators' and 'item identifiers'. Names and occurences are not checked becuase we don't know when a topic is finalized and owns all its charactersitics. T is returned if the topic owns one of the given identifier-URIs." - (declare (integer start-revision) (list psis locators item-identifiers)) + (declare (integer start-revision) (list psis locators item-identifiers + topic-identifiers)) (when (intersection (union (union (psis construct :revision start-revision) (locators construct :revision start-revision)) - (item-identifiers construct :revision start-revision)) - (union (union psis locators) item-identifiers)) + (union (item-identifiers construct :revision start-revision) + (topic-identifiers construct :revision start-revision))) + (union (union psis locators) (union item-identifiers topic-identifiers))) t)) @@ -1088,24 +1094,25 @@ (let ((id-owner (identified-construct topic-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged :revision revision)) - ((find topic-identifier all-ids) - (let ((ti-assoc (loop for ti-assoc in (slot-p construct - 'topic-identifiers) - when (eql (identifier ti-assoc) - topic-identifier) - return ti-assoc))) - (add-to-version-history ti-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'TopicIdAssociationC - :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))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find topic-identifier all-ids) + (let ((ti-assoc (loop for ti-assoc in (slot-p construct + 'topic-identifiers) + when (eql (identifier ti-assoc) + topic-identifier) + return ti-assoc))) + (add-to-version-history ti-assoc :start-revision revision))) + (t + (let ((assoc (make-instance 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier))) + (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) (defgeneric delete-topic-identifier (construct topic-identifier &key revision) @@ -1144,22 +1151,23 @@ (let ((id-owner (identified-construct psi))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged - :revision revision)) - ((find psi all-ids) - (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) - when (eql (identifier psi-assoc) psi) - return psi-assoc))) - (add-to-version-history psi-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'PersistentIdAssociationC - :parent-construct construct - :identifier psi))) - (add-to-version-history assoc :start-revision revision)))) - (add-to-version-history construct :start-revision revision) - construct))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find psi all-ids) + (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) + when (eql (identifier psi-assoc) psi) + return psi-assoc))) + (add-to-version-history psi-assoc :start-revision revision))) + (t + (let ((assoc (make-instance 'PersistentIdAssociationC + :parent-construct construct + :identifier psi))) + (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) (defgeneric delete-psi (construct psi &key revision) @@ -1198,22 +1206,25 @@ (let ((id-owner (identified-construct locator))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged - :revision revision)) - ((find locator all-ids) - (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators) - when (eql (identifier loc-assoc) locator) - return loc-assoc))) - (add-to-version-history loc-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'SubjectLocatorAssociationC - :parent-construct construct - :identifier locator))) - (add-to-version-history assoc :start-revision revision)))) - (add-to-version-history construct :start-revision revision) - construct))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find locator all-ids) + (let ((loc-assoc + (loop for loc-assoc in (slot-p construct 'locators) + when (eql (identifier loc-assoc) locator) + return loc-assoc))) + (add-to-version-history loc-assoc :start-revision revision))) + (t + (let ((assoc + (make-instance 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator))) + (add-to-version-history assoc :start-revision revision)))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) (defgeneric delete-locator (construct locator &key revision) @@ -1480,21 +1491,20 @@ (defmethod equivalent-construct ((construct CharacteristicC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (instance-of nil) (themes nil)) "Equality rule: Characteristics are equal if charvalue, themes and instance-of are equal." - (declare (string charvalue) (list themes item-identifiers) + (declare (string charvalue) (list themes) (integer start-revision) - (type (or null TopicC) instance-of reifier)) - (or (and (string= (charvalue construct) charvalue) - (equivalent-scopable-construct construct themes - :start-revision start-revision) - (equivalent-typable-construct construct instance-of - :start-revision start-revision)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision))) + (type (or null TopicC) instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and (string= (charvalue construct) charvalue) + (equivalent-scopable-construct construct themes + :start-revision start-revision) + (equivalent-typable-construct construct instance-of + :start-revision start-revision))) (defmethod delete-construct :before ((construct CharacteristicC)) @@ -1578,20 +1588,18 @@ (defmethod equivalent-construct ((construct OccurrenceC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (themes nil) (instance-of nil) (datatype "")) "Occurrences are equal if their charvalue, datatype, themes and instance-of properties are equal." - (declare (type (or null TopicC) instance-of reifier) (string datatype) - (list item-identifiers) + (declare (type (or null TopicC) instance-of) (string datatype) (ignorable start-revision charvalue themes instance-of)) (let ((equivalent-characteristic (call-next-method))) - (or (and equivalent-characteristic - (string= (datatype construct) datatype)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision)))) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and equivalent-characteristic + (string= (datatype construct) datatype)))) ;;; VariantC @@ -1602,19 +1610,16 @@ (defmethod equivalent-construct ((construct VariantC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (themes nil) (datatype "")) "Variants are equal if their charvalue, datatype and themes properties are equal." - (declare (string datatype) (list item-identifiers) - (ignorable start-revision charvalue themes) - (type (or null TopicC) reifier)) + (declare (string datatype) (ignorable start-revision charvalue themes)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them (let ((equivalent-characteristic (call-next-method))) - (or (and equivalent-characteristic - (string= (datatype construct) datatype)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision)))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) ;;; NameC @@ -1630,15 +1635,22 @@ (eql class-symbol 'NameC))) +(defgeneric initialize-name (construct variants &key start-revision) + (:documentation "Adds all given variants to the passed construct.") + (:method ((construct NameC) (variants list) + &key (start-revision *TM-REVISION*)) + (dolist (variant variants) + (add-variant construct variant :revision start-revision)) + construct)) + + (defmethod equivalent-construct ((construct NameC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (charvalue "") + &key (start-revision 0) (charvalue "") (themes nil) (instance-of nil)) "Names are equal if their charvalue, instance-of and themes properties are equal." (declare (type (or null TopicC) instance-of) - (ignorable start-revision charvalue instance-of themes - reifier item-identifiers)) + (ignorable start-revision charvalue instance-of themes)) (call-next-method)) @@ -1709,22 +1721,20 @@ (defmethod equivalent-construct ((construct AssociationC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (roles nil) + &key (start-revision 0) (roles nil) (instance-of nil) (themes nil)) "Associations are equal if their themes, instance-of and roles properties are equal." - (declare (integer start-revision) (list roles themes item-identifiers) - (type (or null TopicC) instance-of reifier)) - (or - (and - (not (set-exclusive-or roles (roles construct :revision start-revision))) - (equivalent-typable-construct construct instance-of - :start-revision start-revision) - (equivalent-scopable-construct construct themes - :start-revision start-revision)) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision))) + (declare (integer start-revision) (list roles themes) + (type (or null TopicC) instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and + (not (set-exclusive-or roles (roles construct :revision start-revision))) + (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (equivalent-scopable-construct construct themes + :start-revision start-revision))) (defmethod delete-construct :before ((construct AssociationC)) @@ -1800,18 +1810,15 @@ (defmethod equivalent-construct ((construct RoleC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil) (player nil) + &key (start-revision 0) (player nil) (instance-of nil)) "Roles are equal if their instance-of and player properties are equal." - (declare (integer start-revision) - (type (or null TopicC) player instance-of reifier) - (list item-identifiers)) - (or (and (equivalent-typable-construct construct instance-of - :start-revision start-revision) - (eql player (player construct :revision start-revision))) - (equivalent-reifiable-construct construct reifier item-identifiers - :start-revision start-revision))) + (declare (integer start-revision) (type (or null TopicC) player instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (eql player (player construct :revision start-revision)))) (defmethod delete-construct :before ((construct RoleC)) @@ -1949,6 +1956,25 @@ (CharacteristicC-p class-symbol)))) +(defgeneric initialize-reifiable (construct item-identifiers reifier + &key start-revision) + (:documentation "Adds all item-identifiers and the reifier to the passed + construct.") + (:method ((construct ReifiableConstructC) item-identifiers reifier + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (let ((merged-construct construct)) + (dolist (ii item-identifiers) + (setf merged-construct + (add-item-identifier merged-construct ii + :revision start-revision))) + (when reifier + (setf merged-construct (add-reifier merged-construct reifier + :revision start-revision))) + merged-construct))) + + (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e @@ -2010,26 +2036,27 @@ (let ((id-owner (identified-construct item-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond (construct-to-be-merged - (merge-constructs construct construct-to-be-merged - :revision revision)) - ((find item-identifier all-ids) - (let ((ii-assoc (loop for ii-assoc in (slot-p construct - 'item-identifiers) - when (eql (identifier ii-assoc) item-identifier) - return ii-assoc))) - (add-to-version-history ii-assoc :start-revision revision))) - (t - (let ((assoc - (make-instance 'ItemIdAssociationC - :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))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find item-identifier all-ids) + (let ((ii-assoc + (loop for ii-assoc in (slot-p construct 'item-identifiers) + when (eql (identifier ii-assoc) item-identifier) + return ii-assoc))) + (add-to-version-history ii-assoc :start-revision revision))) + (t + (let ((assoc (make-instance 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier))) + (add-to-version-history assoc :start-revision revision)))) + (when (or (typep merged-construct 'TopicC) + (typep merged-construct 'AssociationC) + (typep merged-construct 'TopicMapC)) + (add-to-version-history merged-construct :start-revision revision)) + merged-construct)))) (defgeneric delete-item-identifier (construct item-identifier &key revision) @@ -2062,28 +2089,28 @@ :revision revision))) (when inner-construct (list inner-construct))))) - (cond ((find construct all-constructs) - (let ((reifier-assoc - (loop for reifier-assoc in - (slot-p merged-reifier-topic 'reified-construct) - when (eql (reifiable-construct reifier-assoc) - construct) - return reifier-assoc))) - (add-to-version-history reifier-assoc :start-revision revision) - construct)) - (all-constructs - (merge-constructs (first all-constructs) construct)) - (t - (let ((assoc - (make-instance 'ReifierAssociationC - :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)))) + (let ((merged-construct construct)) + (cond ((find construct all-constructs) + (let ((reifier-assoc + (loop for reifier-assoc in + (slot-p merged-reifier-topic 'reified-construct) + when (eql (reifiable-construct reifier-assoc) + construct) + return reifier-assoc))) + (add-to-version-history reifier-assoc + :start-revision revision))) + (all-constructs + (merge-constructs (first all-constructs) construct)) + (t + (let ((assoc (make-instance 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic))) + (add-to-version-history assoc :start-revision revision)))) + (when (or (typep merged-construct 'TopicC) + (typep merged-construct 'AssociationC) + (typep merged-construct 'TopicMapC)) + (add-to-version-history merged-construct :start-revision revision)) + merged-construct))))) (defgeneric delete-reifier (construct reifier &key revision) @@ -2109,6 +2136,16 @@ (CharacteristicC-p class-symbol)))) +(defgeneric initialize-typable (construct instance-of &key start-revision) + (:documentation "Adds the passed instance-of to the given construct.") + (:method ((construct TypableC) instance-of + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision) (type (or null TopicC) instance-of)) + (when instance-of + (add-type construct instance-of :revision start-revision)) + construct)) + + (defgeneric equivalent-typable-construct (construct instance-of &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. @@ -2129,6 +2166,16 @@ (CharacteristicC-p class-symbol)))) +(defgeneric initialize-scopable (construct themes &key start-revision) + (:documentation "Adds all passed themes to the given construct.") + (:method ((construct ScopableC) (themes list) + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision)) + (dolist (theme themes) + (add-theme construct theme :revision start-revision)) + construct)) + + (defgeneric equivalent-scopable-construct (construct themes &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the scopable constructs have to own the same themes.") @@ -2324,114 +2371,189 @@ history accordingly. Returns the object in question. Methods use specific keyword arguments for their purpose." (declare (symbol class-symbol)) - (let ((start-revision (getf args :start-revision)) - (uri (getf args :uri)) - (xtm-id (getf args :xtm-id)) - (identified-construct (getf args :identified-construct)) - (charvalue (getf args :charvalue)) - (datatype (getf args :datatype)) - (parent-construct (getf args :parent-construct)) - (themes (getf args :themes)) - (variants (getf args :variants)) - (instance-of (getf args :instance-of)) - (reifier-topic (getf args :reifier)) - (item-identifiers (getf args :item-identifiers))) - (let ((construct - (cond - ((PointerC-p class-symbol) - (make-pointer class-symbol uri :start-revision start-revision - :xtm-id xtm-id - :identified-construct identified-construct)) - ((CharacteristicC-p class-symbol) - (make-characteristic class-symbol charvalue - :start-revision start-revision - :datatype datatype :themes themes - :instance-of instance-of :variants variants - :parent-construct parent-construct))))) - - (when (typep construct 'ReifiableConstructC) - (when reifier-topic - (add-reifier construct reifier-topic :revision start-revision)) - (dolist (ii item-identifiers) - (add-item-identifier construct ii :revision start-revision))) - construct))) + (let ((construct + (cond + ((PointerC-p class-symbol) + (make-pointer class-symbol (getf args :uri) args)) + ((CharacteristicC-p class-symbol) + (make-characteristic class-symbol (getf args :charvalue) args)) + ((TopicC-p class-symbol) + (make-topic args))))) + 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 +(defun merge-all-constructs(constructs-to-be-merged) + "Merges all constructs contained in the given list." + (declare (list constructs-to-be-merged)) + (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1)) + (merged-construct (elt constructs-to-be-merged 0))) + (loop for construct-to-be-merged in constructs-to-be-merged + do (setf merged-construct + (merge-constructs merged-construct construct-to-be-merged))))) + + +(defun make-tm (&rest args) + "Returns a topic map object. If the topic map has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((item-identifiers (getf (first args) :item-identifiers)) + (reifier (getf (first args) :reifier)) + (topics (getf (first args) :topics)) + (assocs (getf (first args) :associations)) + (start-revision (getf (first args) :start-revision))) + (let ((tm + (let ((existing-tms + (remove-if + #'null + (map 'list #'(lambda(existing-tm) + (when (equivalent-construct + existing-tm + :item-identifiers item-identifiers + :reifier reifier) + existing-tm)) + (elephant:get-instances-by-class 'TopicMapC))))) + (cond ((and existing-tms (> (length existing-tms) 1)) + (merge-all-constructs existing-tms)) + (existing-tms + (first existing-tms)) + (t + (make-instance 'TopicMapC)))))) + (dolist (top-or-assoc (union topics assocs)) + (add-to-tm tm top-or-assoc)) + (add-to-version-history tm :start-revision start-revision) + tm))) + + +(defun make-topic (&rest args) + "Returns a topic object. If the topic has already existed the existing one is + returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((start-revision (getf (first args) :start-revision)) + (psis (getf (first args) :psis)) + (locators (getf (first args) :locators)) + (item-identifiers (getf (first args) :item-identifiers)) + (topic-identifiers (getf (first args) :topic-identifiers)) + (names (getf (first args) :names)) + (occurrences (getf (first args) :occurrences))) + (let ((topic + (let ((existing-topics (remove-if #'null - (map 'list #'(lambda(existing-characteristic) + (map 'list #'(lambda(existing-topic) (when (equivalent-construct - existing-characteristic + existing-topic :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)))) + :psis psis :locators locators + :item-identifiers item-identifiers + :topic-identifiers topic-identifiers) + existing-topic)) + (elephant:get-instances-by-class 'TopicC))))) + (cond ((and existing-topics (> (length existing-topics) 1)) + (merge-all-constructs existing-topics)) + (existing-topics + (first existing-topics)) + (t + (make-instance 'TopicC)))))) + (initialize-reifiable topic item-identifiers nil + :start-revision start-revision) + (let ((merged-topic topic)) + (dolist (psi psis) + (setf merged-topic (add-psi merged-topic psi + :revision start-revision))) + (dolist (locator locators) + (setf merged-topic (add-locator merged-topic locator + :revision start-revision))) + (dolist (name names) + (setf merged-topic (add-name topic name :revision start-revision))) + (dolist (occ occurrences) + (add-occurrence merged-topic occ :revision start-revision)) + (add-to-version-history merged-topic :start-revision start-revision) + merged-topic)))) + + +(defun make-characteristic (class-symbol &rest args) + "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. + This function only exists for being used by make-construct!" + (let ((charvalue (getf (first args) :charvalue)) + (start-revision (getf (first args) :start-revision)) + (datatype (getf (first args) :datatype)) + (instance-of (getf (first args) :instance-of)) + (themes (getf (first args) :themes)) + (variants (getf (first args) :variants)) + (reifier (getf (first args) :reifier)) + (parent-construct (getf (first args) :parent-construct)) + (item-identifiers (getf (first args) :item-identifiers))) + (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 :variants variants + :charvalue charvalue :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))))) + (let ((merged-characteristic characteristic)) + (setf merged-characteristic + (initialize-reifiable merged-characteristic item-identifiers + reifier :start-revision start-revision)) + (initialize-scopable merged-characteristic themes + :start-revision start-revision) + (initialize-typable merged-characteristic instance-of + :start-revision start-revision) + (initialize-name merged-characteristic variants + :start-revision start-revision) + (when parent-construct + (add-parent merged-characteristic parent-construct + :revision start-revision)) + merged-characteristic)))) -(defun make-pointer (class-symbol uri - &key (start-revision *TM-REVISION*) (xtm-id nil) - (identified-construct nil)) +(defun make-pointer (class-symbol &rest args) "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))) - (let ((identifier - (let ((existing-pointer - (remove-if - #'null - (map 'list - #'(lambda(existing-pointer) - (when (equivalent-construct existing-pointer :uri uri - :xtm-id xtm-id) - existing-pointer)) - (elephant:get-instances-by-value class-symbol 'd::uri uri))))) - (if existing-pointer existing-pointer - (make-instance class-symbol :uri uri :xtm-id xtm-id))))) - (when identified-construct - (cond ((TopicIdentificationC-p class-symbol) - (add-topic-identifier identified-construct identifier - :revision start-revision)) - ((PersistentIdC-p class-symbol) - (add-psi identified-construct identifier :revision start-revision)) - ((ItemIdentifierC-p class-symbol) - (add-item-identifier identified-construct identifier - :revision start-revision)) - ((SubjectLocatorC-p class-symbol) - (add-locator identified-construct identifier - :revision start-revision)))) - identifier)) + If an equivalen construct has already existed this one is returned. + This function only exists for beoing used by make-construct!" + (let ((uri (getf (first args) :uri)) + (xtm-id (getf (first args) :xtm-id)) + (start-revision (getf (first args) :start-revision)) + (identified-construct (getf (first args) :identified-construct))) + (let ((identifier + (let ((existing-pointer + (remove-if + #'null + (map 'list + #'(lambda(existing-pointer) + (when (equivalent-construct existing-pointer uri + xtm-id) + existing-pointer)) + (elephant:get-instances-by-value class-symbol 'd::uri uri))))) + (if existing-pointer existing-pointer + (make-instance class-symbol :uri uri :xtm-id xtm-id))))) + (when identified-construct + (cond ((TopicIdentificationC-p class-symbol) + (add-topic-identifier identified-construct identifier + :revision start-revision)) + ((PersistentIdC-p class-symbol) + (add-psi identified-construct identifier :revision start-revision)) + ((ItemIdentifierC-p class-symbol) + (add-item-identifier identified-construct identifier + :revision start-revision)) + ((SubjectLocatorC-p class-symbol) + (add-locator identified-construct identifier + :revision start-revision)))) + identifier))) Modified: branches/new-datamodel/src/rest_interface/rest-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/rest-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/rest-interface.lisp Sat Mar 20 16:33:55 2010 @@ -71,8 +71,9 @@ (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) - (elephant:open-store - (xml-importer:get-store-spec repository-path)) + (unless elephant:*store-controller* + (elephant:open-store + (xml-importer:get-store-spec repository-path))) (load conffile) (publish-feed atom:*tm-feed*) (set-up-json-interface) Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Sat Mar 20 16:33:55 2010 @@ -226,8 +226,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (to-json-string fragment)) @@ -251,8 +251,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (rdf-exporter:to-rdf-string fragment)) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Sat Mar 20 16:33:55 2010 @@ -1375,10 +1375,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (revision-0-5 50) (version-1 100)) (setf *TM-REVISION* version-1) @@ -1403,13 +1399,7 @@ :instance-of type-1 :themes (list scope-1 scope-2))) (is-false (d::equivalent-construct occ-1 :charvalue "occ-2" :datatype constants:*xml-string* - :instance-of type-1 :themes (list scope-2 scope-1))) - (add-item-identifier occ-1 ii-1) - (is-true (d::equivalent-construct occ-1 :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct occ-1 :item-identifiers (list ii-2))) - (add-reifier occ-1 reifier-1) - (is-true (d::equivalent-construct occ-1 :reifier reifier-1)) - (is-false (d::equivalent-construct occ-1 :reifier reifier-2))))) + :instance-of type-1 :themes (list scope-2 scope-1)))))) (test test-equivalent-NameC () @@ -1421,10 +1411,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (revision-0-5 50) (version-1 100)) (setf *TM-REVISION* version-1) @@ -1446,13 +1432,7 @@ :themes (list scope-3 scope-2))) (is-false (d::equivalent-construct nam-1 :charvalue "nam-2" :instance-of type-1 - :themes (list scope-2 scope-1))) - (add-item-identifier nam-1 ii-1) - (is-true (d::equivalent-construct nam-1 :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct nam-1 :item-identifiers (list ii-2))) - (add-reifier nam-1 reifier-1) - (is-true (d::equivalent-construct nam-1 :reifier reifier-1)) - (is-false (d::equivalent-construct nam-1 :reifier reifier-2))))) + :themes (list scope-2 scope-1)))))) (test test-equivalent-VariantC () @@ -1462,10 +1442,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (revision-0-5 50) (version-1 100)) (setf *TM-REVISION* version-1) @@ -1486,13 +1462,7 @@ :themes (list scope-1 scope-2))) (is-false (d::equivalent-construct var-1 :charvalue "var-2" :datatype constants:*xml-string* - :themes (list scope-2 scope-1))) - (add-item-identifier var-1 ii-1) - (is-true (d::equivalent-construct var-1 :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct var-1 :item-identifiers (list ii-2))) - (add-reifier var-1 reifier-1) - (is-true (d::equivalent-construct var-1 :reifier reifier-1)) - (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) + :themes (list scope-2 scope-1)))))) (test test-equivalent-RoleC () @@ -1503,55 +1473,28 @@ (type-2 (make-instance 'd:TopicC)) (player-1 (make-instance 'd:TopicC)) (player-2 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) - (ii-3 (make-instance 'd:ItemIdentifierC :uri "ii-3")) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) (revision-1 100) (revision-2 200)) (setf *TM-REVISION* revision-1) (add-type role-1 type-1) (add-player role-1 player-1) - (add-item-identifier role-1 ii-1) - (add-item-identifier role-1 ii-2) - (add-reifier role-1 reifier-1) (is-true (d::equivalent-construct role-1 :player player-1 :instance-of type-1)) - (is-true (d::equivalent-construct role-1 - :item-identifiers (list ii-1 ii-3))) - (is-true (d::equivalent-construct role-1 :reifier reifier-1)) (is-false (d::equivalent-construct role-1 :player player-2 :instance-of type-1)) (is-false (d::equivalent-construct role-1 :player player-1 :instance-of type-2)) - (is-false (d::equivalent-construct role-1 - :item-identifiers (list ii-3))) - (is-false (d::equivalent-construct role-1 :reifier reifier-2)) (setf *TM-REVISION* revision-2) - (delete-item-identifier role-1 ii-1 :revision revision-2) (delete-player role-1 player-1 :revision revision-2) (add-player role-1 player-2) (delete-type role-1 type-1 :revision revision-2) (add-type role-1 type-2) - (delete-reifier role-1 reifier-1 :revision revision-2) - (add-reifier role-1 reifier-2) (is-true (d::equivalent-construct role-1 :player player-2 :instance-of type-2)) - (is-true (d::equivalent-construct role-1 - :item-identifiers (list ii-2))) - (is-true (d::equivalent-construct role-1 :reifier reifier-2)) (is-false (d::equivalent-construct role-1 :player player-1 :instance-of type-2)) (is-false (d::equivalent-construct role-1 :player player-2 - :instance-of type-1)) - (is-false (d::equivalent-construct role-1 - :item-identifiers (list ii-1))) - (is-false (d::equivalent-construct role-1 :reifier reifier-1)) - (is-true (d::equivalent-construct role-1 :start-revision revision-1 - :item-identifiers (list ii-1))) - (is-true (d::equivalent-construct role-1 :reifier reifier-1 - :start-revision revision-1))))) + :instance-of type-1))))) (test test-equivalent-AssociationC () @@ -1566,10 +1509,6 @@ (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) - (reifier-1 (make-instance 'd:TopicC)) - (reifier-2 (make-instance 'd:TopicC)) (revision-1 100)) (setf *TM-REVISION* revision-1) (d:add-role assoc-1 role-1) @@ -1577,14 +1516,9 @@ (d:add-type assoc-1 type-1) (d:add-theme assoc-1 scope-1) (d:add-theme assoc-1 scope-2) - (d:add-item-identifier assoc-1 ii-1) - (d:add-reifier assoc-1 reifier-1) (is-true (d::equivalent-construct assoc-1 :roles (list role-1 role-2) :instance-of type-1 :themes (list scope-1 scope-2))) - (is-true (d::equivalent-construct assoc-1 - :item-identifiers (list ii-1 ii-2))) - (is-true (d::equivalent-construct assoc-1 :reifier reifier-1)) (is-false (d::equivalent-construct assoc-1 :roles (list role-1 role-2 role-3) :instance-of type-1 :themes (list scope-1 scope-2))) @@ -1593,9 +1527,7 @@ :themes (list scope-1 scope-2))) (is-false (d::equivalent-construct assoc-1 :roles (list role-1 role-2) :instance-of type-1 - :themes (list scope-1 scope-3 scope-2))) - (is-false (d::equivalent-construct assoc-1 :item-identifiers (list ii-2))) - (is-false (d::equivalent-construct assoc-1 :reifeir reifier-2))))) + :themes (list scope-1 scope-3 scope-2)))))) (test test-equivalent-TopicC () @@ -1608,11 +1540,16 @@ (sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2")) (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")) (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2")) + (tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-id-1")) + (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-id-2")) (revision-1 100)) (setf *TM-REVISION* revision-1) (d:add-item-identifier top-1 ii-1) (d:add-locator top-1 sl-1) (d:add-psi top-1 psi-1) + (d:add-topic-identifier top-1 tid-1) (is-true (d::equivalent-construct top-1 :item-identifiers (list ii-1 ii-2))) (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2) @@ -1620,6 +1557,8 @@ :item-identifiers (list ii-1 ii-2))) (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) + (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1))) + (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2))) (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) :psis (list psi-2) :locators (list sl-2)))))) Modified: branches/new-datamodel/src/xml/rdf/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/importer.lisp (original) +++ branches/new-datamodel/src/xml/rdf/importer.lisp Sat Mar 20 16:33:55 2010 @@ -20,9 +20,9 @@ (xml-importer:init-isidorus) (init-rdf-module) (rdf-importer rdf-xml-path repository-path :tm-id tm-id - :document-id document-id) - (when elephant:*store-controller* - (elephant:close-store))) + :document-id document-id)) +; (when elephant:*store-controller* +; (elephant:close-store))) (defun rdf-importer (rdf-xml-path repository-path @@ -46,7 +46,7 @@ (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC))) - (elephant:close-store) +; (elephant:close-store) (setf *_n-map* nil))) Modified: branches/new-datamodel/src/xml/xtm/setup.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/setup.lisp (original) +++ branches/new-datamodel/src/xml/xtm/setup.lisp Sat Mar 20 16:33:55 2010 @@ -50,6 +50,6 @@ (elephant:open-store (get-store-spec repository-path))) (init-isidorus) - (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) - (when elephant:*store-controller* - (elephant:close-store))) \ No newline at end of file + (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)) +; (when elephant:*store-controller* +; (elephant:close-store))) \ No newline at end of file

1 0

[isidorus-cvs] r233 - branches/new-datamodel/src/model
by Lukas Giessmann 18 Mar '10

18 Mar '10

Author: lgiessmann Date: Thu Mar 18 08:50:36 2010 New Revision: 233 Log: new-datamodel: added the handling of "ReifiableConstructC" to "make-construct" 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:50:36 2010 @@ -122,11 +122,9 @@ -;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier, +;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier +;; (can merge the parent construct and the parent's parent construct), ;; 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 @@ -2329,14 +2327,33 @@ (let ((start-revision (getf args :start-revision)) (uri (getf args :uri)) (xtm-id (getf args :xtm-id)) - (identified-construct (getf args :identified-construct))) + (identified-construct (getf args :identified-construct)) + (charvalue (getf args :charvalue)) + (datatype (getf args :datatype)) + (parent-construct (getf args :parent-construct)) + (themes (getf args :themes)) + (variants (getf args :variants)) + (instance-of (getf args :instance-of)) + (reifier-topic (getf args :reifier)) + (item-identifiers (getf args :item-identifiers))) (let ((construct (cond ((PointerC-p class-symbol) (make-pointer class-symbol uri :start-revision start-revision :xtm-id xtm-id - :identified-construct identified-construct))))) - + :identified-construct identified-construct)) + ((CharacteristicC-p class-symbol) + (make-characteristic class-symbol charvalue + :start-revision start-revision + :datatype datatype :themes themes + :instance-of instance-of :variants variants + :parent-construct parent-construct))))) + + (when (typep construct 'ReifiableConstructC) + (when reifier-topic + (add-reifier construct reifier-topic :revision start-revision)) + (dolist (ii item-identifiers) + (add-item-identifier construct ii :revision start-revision))) construct)))

1 0

[isidorus-cvs] r232 - branches/new-datamodel/src/model
by Lukas Giessmann 18 Mar '10

18 Mar '10

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)))

1 0

[isidorus-cvs] r231 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 18 Mar '10

18 Mar '10

Author: lgiessmann Date: Thu Mar 18 07:40:32 2010 New Revision: 231 Log: new-datamodel: added the helper function "make-pointer" for "make-construct"; added the generics <class>-p to all class-symbols and a unit-test fort these methods. Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.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 07:40:32 2010 @@ -92,6 +92,26 @@ :get-item-by-locator :string-integer-p :with-revision + :PointerC-p + :IdentifierC-p + :SubjectLocatorC-p + :PersistentIdC-p + :ItemIdentifierC-p + :TopicIdentificationC-p + :CharacteristicC-p + :OccurrenceC-p + :NameC-p + :VariantC-p + :ScopableC-p + :TypableC-p + :TopicC-p + :AssociationC-p + :RoleC-p + :TopicMapC-p + :ReifiableConstructC-p + :TopicMapConstructC-p + :VersionedConstructC-p + :make-construct ;;globals :*TM-REVISION* @@ -100,6 +120,12 @@ (in-package :datamodel) + + +;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier, +;; add-psi, add-locator + + ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -108,8 +134,6 @@ ;; and a merge should be done ;;TODO: use some exceptions --> more than one type, ;; identifier, not-mergable merges, missing-init-args... -;;TODO: implement make-construct -> symbol -;; replace the latest make-construct-method ;;TODO: implement merge-construct -> ReifiableConstructC -> ... ;; the method should merge two constructs that are inherited from ;; ReifiableConstructC @@ -583,17 +607,6 @@ (error () nil)))) -(defun make-construct (class-symbol &key start-revision &allow-other-keys) - "Creates a new topic map construct if necessary or - retrieves an equivalent one if available and updates the revision - history accordingly. Returns the object in question. Methods use - specific keyword arguments for their purpose." - (or class-symbol start-revision) - ;TODO: implement - ) - - - (defun delete-1-n-association(instance slot-symbol) (when (slot-p instance slot-symbol) (remove-association @@ -691,6 +704,16 @@ ;;; VersionedConstructC +(defgeneric VersionedConstructC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to VersionedConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'VersionedconstructC) + (TopicC-p class-symbol) + (TopicMapC-p class-symbol) + (AssociationC-p class-symbol)))) + + (defmethod delete-construct :before ((construct VersionedConstructC)) (dolist (version-info (versions construct)) (delete-construct version-info))) @@ -786,7 +809,29 @@ (setf (end-revision last-version) revision))))) +;;; TopicMapconstructC +(defgeneric TopicMapConstructC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to TopicMapConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'TopicMapConstructC) + (ReifiableConstructC-p class-symbol) + (PointerC-p class-symbol)))) + + ;;; PointerC +(defgeneric PointerC-p (class-symbol) + (:documentation "Returns t if the passed symbol corresponds to the class + PointerC or one of its subclasses.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'PointerC) + (IdentifierC-p class-symbol) + (TopicIdentificationC-p class-symbol) + (PersistentIdC-p class-symbol) + (ItemIdentifierC-p class-symbol) + (SubjectLocatorC-p class-symbol)))) + + (defmethod equivalent-construct ((construct PointerC) &key start-revision (uri "")) "All Pointers are equal if they have the same URI value." @@ -817,6 +862,13 @@ ;;; TopicIdentificationC +(defgeneric TopicIdentificationC-p (class-symbol) + (:documentation "Returns t if the passed class symbol is equal + to TopicIdentificationC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicIdentificationC))) + + (defmethod equivalent-construct ((construct TopicIdentificationC) &key start-revision (uri "") (xtm-id "")) "TopicIdentifiers are equal if teh URI and XTM-ID values are equal." @@ -828,6 +880,37 @@ (string= (xtm-id construct) xtm-id)))) +;;; IdentifierC +(defgeneric IdentifierC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to IdentifierC + or one of its sybtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'IdentifierC) + (PersistentIdC-p class-symbol) + (SubjectLocatorC-p class-symbol) + (ItemIdentifierC-p class-symbol)))) + + +;;; PersistentIdC +(defgeneric PersistentIdC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to PersistentIdC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'PersistentIdC))) + + +;;; ItemIdentifierC +(defgeneric ItemIdentifierC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to ItemIdentifierC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'ItemIdentifierC))) + +;;; SubjectLocatorC +(defgeneric SubjectLocatorC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to SubjectLocatorC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'SubjectLocatorC))) + + ;;; PointerAssociationC (defmethod delete-construct :before ((construct PointerAssociationC)) (delete-1-n-association construct 'identifier)) @@ -904,6 +987,12 @@ ;;; TopicC +(defgeneric TopicC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to TopicC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicC))) + + (defmethod equivalent-construct ((construct TopicC) &key (start-revision 0) (psis nil) (locators nil) (item-identifiers nil)) @@ -1362,6 +1451,16 @@ ;;; CharacteristicC +(defgeneric CharacteristicC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to CharacteristicC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'CharacteristicC) + (OccurrenceC-p class-symbol) + (NameC-p class-symbol) + (VariantC-p class-symbol)))) + + (defmethod equivalent-construct ((construct CharacteristicC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1454,6 +1553,12 @@ ;;; OccurrenceC +(defgeneric OccurrenceC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to OccurrenceC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'OccurrenceC))) + + (defmethod equivalent-construct ((construct OccurrenceC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1472,6 +1577,12 @@ ;;; VariantC +(defgeneric VariantC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to VariantC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'VariantC))) + + (defmethod equivalent-construct ((construct VariantC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1489,6 +1600,12 @@ ;;; NameC +(defgeneric NameC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to Name.") + (:method ((class-symbol symbol)) + (eql class-symbol 'NameC))) + + (defmethod equivalent-construct ((construct NameC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") @@ -1561,6 +1678,12 @@ ;;; AssociationC +(defgeneric AssociationC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to AssociationC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'AssociationC))) + + (defmethod equivalent-construct ((construct AssociationC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (roles nil) @@ -1645,6 +1768,12 @@ ;;; RoleC +(defgeneric RoleC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to RoleC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'RoleC))) + + (defmethod equivalent-construct ((construct RoleC) &key (start-revision 0) (reifier nil) (item-identifiers nil) (player nil) @@ -1782,6 +1911,18 @@ ;;; ReifiableConstructC +(defgeneric ReifiableConstructC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to ReifiableConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'ReifiableconstructC) + (TopicMapC-p class-symbol) + (TopicC-p class-symbol) + (AssociationC-p class-symbol) + (RoleC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e @@ -1924,6 +2065,16 @@ construct))) ;;; TypableC +(defgeneric TypableC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to TypableC or + one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'TypableC) + (AssociationC-p class-symbol) + (RoleC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + (defgeneric equivalent-typable-construct (construct instance-of &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. @@ -1935,6 +2086,15 @@ ;;; ScopableC +(defgeneric ScopableC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to ScopableC or + one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'ScopableC) + (AssociationC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + (defgeneric equivalent-scopable-construct (construct themes &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the scopable constructs have to own the same themes.") @@ -2065,6 +2225,12 @@ ;;; TopicMapC +(defgeneric TopicMapC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to TopicMapC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicMapC))) + + (defmethod equivalent-construct ((construct TopicMapC) &key (start-revision 0) (reifier nil) (item-identifiers nil)) @@ -2113,9 +2279,83 @@ (remove-association construct 'associations construct-to-delete)) +;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun make-construct (class-symbol &rest args) + "Creates a new topic map construct if necessary or + retrieves an equivalent one if available and updates the revision + history accordingly. Returns the object in question. Methods use + specific keyword arguments for their purpose." + (declare (symbol class-symbol)) + (let ((start-revision (getf args :start-revision)) + (uri (getf args :uri)) + (xtm-id (getf args :xtm-id)) + (identified-construct (getf args :identified-construct))) + (let ((construct + (cond + ((PointerC-p class-symbol) + (make-pointer class-symbol uri :start-revision start-revision + :xtm-id xtm-id + :identified-construct identified-construct))))) + + construct))) + + + +(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." + (declare (symbol class-symbol) (string uri) (integer start-revision) + (type (or null string) xtm-id) + (type (or null ReifiableconstructC))) + (let ((identifier + (let ((existing-pointer + (remove-if + #'null + (map 'list + #'(lambda(existing-pointer) + (when (equivalent-construct existing-pointer :uri uri + :xtm-id xtm-id) + existing-pointer)) + (elephant:get-instances-by-value class-symbol 'd::uri uri))))) + (if existing-pointer existing-pointer + (make-instance class-symbol :uri uri :xtm-id xtm-id))))) + (when identified-construct + (cond ((TopicIdentificationC-p class-symbol) + (add-topic-identifier identified-construct identifier + :revision start-revision)) + ((PersistentIdC-p class-symbol) + (add-psi identified-construct identifier :revision start-revision)) + ((ItemIdentifierC-p class-symbol) + (add-item-identifier identified-construct identifier + :revision start-revision)) + ((SubjectLocatorC-p class-symbol) + (add-locator identified-construct identifier + :revision start-revision)))) + identifier)) + + + + + + + + + + + + + + + + + + + + Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Thu Mar 18 07:40:32 2010 @@ -57,7 +57,8 @@ :test-equivalent-RoleC :test-equivalent-AssociationC :test-equivalent-TopicC - :test-equivalent-TopicMapC)) + :test-equivalent-TopicMapC + :test-class-p)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1643,6 +1644,61 @@ (is-false (d::equivalent-construct tm-1 :reifier reifier-2))))) +(test test-class-p () + "Tests the functions <class>-p." + (let ((identifier (list 'd::IdentifierC 'd::ItemIdentifierC 'd:PersistentIdC + 'd:SubjectLocatorC)) + (topic-identifier (list 'd::TopicIdentificationC)) + (characteristic (list 'd::CharacteristicC 'd:OccurrenceC 'd:NameC + 'd:VariantC)) + (topic (list 'd:TopicC)) + (assoc (list 'd:AssociationC)) + (role (list 'd:AssociationC)) + (tm (list 'd:TopicMapC))) + (let ((pointer (append identifier topic-identifier)) + (reifiable (append topic assoc role tm characteristic)) + (typable (append characteristic assoc role)) + (scopable (append characteristic assoc))) + (dolist (class pointer) + (is-true (d:PointerC-p class))) + (dolist (class identifier) + (is-true (d:IdentifierC-p class))) + (dolist (class topic-identifier) + (is-true (d:TopicIdentificationC-p class))) + (is-true (d:PersistentIdC-p 'd:PersistentIdC)) + (is-true (d:SubjectLocatorC-p 'd:SubjectLocatorC)) + (is-true (d:ItemIdentifierC-p 'd:ItemIdentifierC)) + (dolist (class characteristic) + (is-true (d:CharacteristicC-p class))) + (is-true (d:OccurrenceC-p 'd:OccurrenceC)) + (is-true (d:VariantC-p 'd:VariantC)) + (is-true (d:NameC-p 'd:NameC)) + (is-true (d:RoleC-p 'd:RoleC)) + (is-true (d:AssociationC-p 'd:AssociationC)) + (is-true (d:TopicC-p 'd:TopicC)) + (is-true (d:TopicMapC-p 'd:TopicMapC)) + (dolist (class reifiable) + (is-true (d:ReifiableconstructC-p class))) + (dolist (class scopable) + (is-true (d:ScopableC-p class))) + (dolist (class typable) + (is-true (d:TypableC-p class))) + (dolist (class (append reifiable pointer)) + (is-true (d:TopicMapConstructC-p class))) + (dolist (class (append topic tm assoc)) + (is-true (d:VersionedConstructC-p class))) + (dolist (class identifier) + (is-false (d:TopicIdentificationC-p class))) + (dolist (class topic-identifier) + (is-false (d:IdentifierC-p class))) + (dolist (class characteristic) + (is-false (d:PointerC-p class)))))) + + + + + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -1683,4 +1739,5 @@ (it.bese.fiveam:run! 'test-equivalent-AssociationC) (it.bese.fiveam:run! 'test-equivalent-TopicC) (it.bese.fiveam:run! 'test-equivalent-TopicMapC) + (it.bese.fiveam:run! 'test-class-p) ) \ No newline at end of file

1 0

[isidorus-cvs] r230 - branches/new-datamodel/src/threading trunk/src/threading
by Lukas Giessmann 17 Mar '10

17 Mar '10

Author: lgiessmann Date: Wed Mar 17 17:35:49 2010 New Revision: 230 Log: fixed ticket #68 --> http://trac.common-lisp.net/isidorus/ticket/68 Modified: branches/new-datamodel/src/threading/reader-writer.lisp trunk/src/threading/reader-writer.lisp Modified: branches/new-datamodel/src/threading/reader-writer.lisp ============================================================================== --- branches/new-datamodel/src/threading/reader-writer.lisp (original) +++ branches/new-datamodel/src/threading/reader-writer.lisp Wed Mar 17 17:35:49 2010 @@ -65,5 +65,5 @@ (do ((remaining-readers (current-readers) (current-readers))) ((null remaining-readers)) - (sleep 0.5)) + (sleep 0.05)) ,@body)) \ No newline at end of file Modified: trunk/src/threading/reader-writer.lisp ============================================================================== --- trunk/src/threading/reader-writer.lisp (original) +++ trunk/src/threading/reader-writer.lisp Wed Mar 17 17:35:49 2010 @@ -65,5 +65,5 @@ (do ((remaining-readers (current-readers) (current-readers))) ((null remaining-readers)) - (sleep 0.5)) + (sleep 0.05)) ,@body)) \ No newline at end of file

1 0

[isidorus-cvs] r229 - in trunk/src: json model rest_interface xml/rdf xml/xtm
by Lukas Giessmann 16 Mar '10

16 Mar '10

Author: lgiessmann Date: Tue Mar 16 18:24:22 2010 New Revision: 229 Log: fixed ticket #69 --> changed the mechanism of the json-reader and -writer, so there can be used with-reader-lock instead of with-writer-lock Modified: trunk/src/json/json_importer.lisp trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/xtm/setup.lisp Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Tue Mar 16 18:24:22 2010 @@ -32,13 +32,19 @@ (topicStubs-values (getf fragment-values :topicStubs)) (associations-values (getf fragment-values :associations)) (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment - (elephant:ensure-transaction (:txn-nosync nil) - (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) - (loop for topicStub-values in (append topicStubs-values (list topic-values)) - do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) - (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) - (loop for association-values in associations-values - do (json-to-association association-values rev :tm xml-importer::tm)))))))) + (let ((psi-of-topic + (let ((psi-uris (getf topic-values :subjectIdentifiers))) + (when psi-uris + (first psi-uris))))) + (elephant:ensure-transaction (:txn-nosync nil) + (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) + (loop for topicStub-values in (append topicStubs-values (list topic-values)) + do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) + (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) + (loop for association-values in associations-values + do (json-to-association association-values rev :tm xml-importer::tm))) + (when psi-of-topic + (create-latest-fragment-of-topic psi-of-topic)))))))) (defun json-to-association (json-decoded-list start-revision Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Tue Mar 16 18:24:22 2010 @@ -277,7 +277,7 @@ (defun create-latest-fragment-of-topic (topic-psi) - "returns the latest fragment of the passed topic-psi" + "Returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) (let ((topic (get-item-by-psi topic-psi))) @@ -299,4 +299,18 @@ :revision start-revision :associations (find-associations-for-topic topic) :referenced-topics (find-referenced-topics topic) - :topic topic))))))) \ No newline at end of file + :topic topic))))))) + + +(defun get-latest-fragment-of-topic (topic-psi) + "Returns the latest existing fragment of the passed topic-psi." + (declare (string topic-psi)) + (let ((topic + (get-item-by-psi topic-psi))) + (when topic + (let ((existing-fragments + (elephant:get-instances-by-value 'FragmentC 'topic topic))) + (when existing-fragments + (first (sort existing-fragments + #'(lambda(frg-1 frg-2) + (> (revision frg-1) (revision frg-2)))))))))) \ No newline at end of file Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Mar 16 18:24:22 2010 @@ -101,6 +101,7 @@ :variants :xor :create-latest-fragment-of-topic + :get-latest-fragment-of-topic :reified :reifier :add-reifier Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Tue Mar 16 18:24:22 2010 @@ -71,14 +71,20 @@ (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) - (elephant:open-store - (xml-importer:get-store-spec repository-path)) + (unless elephant:*store-controller* + (elephant:open-store + (xml-importer:get-store-spec repository-path))) (load conffile) (publish-feed atom:*tm-feed*) (set-up-json-interface) (setf *server-acceptor* (make-instance 'hunchentoot:acceptor :address host-name :port port)) (setf hunchentoot:*lisp-errors-log-level* :info) (setf hunchentoot:*message-log-pathname* "./hunchentoot-errors.log") + (map 'list #'(lambda(top) + (let ((psis-of-top (psis top))) + (when psis-of-top + (create-latest-fragment-of-topic (uri (first psis-of-top)))))) + (elephant:get-instances-by-class 'd:TopicC)) (hunchentoot:start *server-acceptor*)) (defun shutdown-tm-engine () Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Tue Mar 16 18:24:22 2010 @@ -226,8 +226,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (to-json-string fragment)) @@ -251,8 +251,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (rdf-exporter:to-rdf-string fragment)) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Tue Mar 16 18:24:22 2010 @@ -20,9 +20,9 @@ (xml-importer:init-isidorus) (init-rdf-module) (rdf-importer rdf-xml-path repository-path :tm-id tm-id - :document-id document-id) - (when elephant:*store-controller* - (elephant:close-store))) + :document-id document-id)) +; (when elephant:*store-controller* +; (elephant:close-store))) (defun rdf-importer (rdf-xml-path repository-path @@ -46,7 +46,7 @@ (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC))) - (elephant:close-store) +; (elephant:close-store) (setf *_n-map* nil))) Modified: trunk/src/xml/xtm/setup.lisp ============================================================================== --- trunk/src/xml/xtm/setup.lisp (original) +++ trunk/src/xml/xtm/setup.lisp Tue Mar 16 18:24:22 2010 @@ -50,6 +50,6 @@ (elephant:open-store (get-store-spec repository-path))) (init-isidorus) - (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) - (when elephant:*store-controller* - (elephant:close-store))) \ No newline at end of file + (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)) +; (when elephant:*store-controller* +; (elephant:close-store))) \ No newline at end of file

1 0

[isidorus-cvs] r228 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 16 Mar '10

16 Mar '10

Author: lgiessmann Date: Tue Mar 16 08:56:24 2010 New Revision: 228 Log: new-datamodel: added some unit-tests for equivalent-construct --> RoleC, AssociationC, TopicC, TopicMapC; added equivalent-construct to TopicMapC; fixed a bug in equivalent-construct for all classes derived from ReifiableConstructC. Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Mar 16 08:56:24 2010 @@ -649,9 +649,12 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) +(defgeneric equivalent-construct (construct &key start-revision + &allow-other-keys) (:documentation "Returns t if the passed construct is equivalent to the passed - key arguments (TMDM equality rules.")) + key arguments (TMDM equality rules. Parent-equality is not + checked in this methods, so the user has to pass children of + the same parent.")) (defgeneric get-most-recent-version-info (construct) @@ -786,6 +789,7 @@ ;;; PointerC (defmethod equivalent-construct ((construct PointerC) &key start-revision (uri "")) + "All Pointers are equal if they have the same URI value." (declare (string uri) (ignorable start-revision)) (string= (uri construct) uri)) @@ -815,6 +819,7 @@ ;;; TopicIdentificationC (defmethod equivalent-construct ((construct TopicIdentificationC) &key start-revision (uri "") (xtm-id "")) + "TopicIdentifiers are equal if teh URI and XTM-ID values are equal." (declare (string uri xtm-id)) (let ((equivalent-pointer (call-next-method construct :start-revision start-revision @@ -902,6 +907,11 @@ (defmethod equivalent-construct ((construct TopicC) &key (start-revision 0) (psis nil) (locators nil) (item-identifiers nil)) + "Isidorus handles Topic-equality only by the topic's identifiers + 'psis', 'subject locators' and 'item identifiers'. Names and occurences + are not checked becuase we don't know when a topic is finalized and owns + all its charactersitics. T is returned if the topic owns one of the given + identifier-URIs." (declare (integer start-revision) (list psis locators item-identifiers)) (when (intersection @@ -1356,8 +1366,8 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") (instance-of nil) (themes nil)) - "Equality rule: Characteristics are equal if charvalue, themes and the parent- - constructs are equal." + "Equality rule: Characteristics are equal if charvalue, themes and + instance-of are equal." (declare (string charvalue) (list themes item-identifiers) (integer start-revision) (type (or null TopicC) instance-of reifier)) @@ -1449,9 +1459,11 @@ (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil) (datatype "")) - (declare (type (or null TopicC) instance-of) (string datatype) - (ignorable start-revision charvalue themes instance-of - reifier item-identifiers)) + "Occurrences are equal if their charvalue, datatype, themes and + instance-of properties are equal." + (declare (type (or null TopicC) instance-of reifier) (string datatype) + (list item-identifiers) + (ignorable start-revision charvalue themes instance-of)) (let ((equivalent-characteristic (call-next-method))) (or (and equivalent-characteristic (string= (datatype construct) datatype)) @@ -1464,8 +1476,11 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") (themes nil) (datatype "")) - (declare (string datatype) (ignorable start-revision charvalue themes - reifier item-identifiers)) + "Variants are equal if their charvalue, datatype and themes + properties are equal." + (declare (string datatype) (list item-identifiers) + (ignorable start-revision charvalue themes) + (type (or null TopicC) reifier)) (let ((equivalent-characteristic (call-next-method))) (or (and equivalent-characteristic (string= (datatype construct) datatype)) @@ -1478,6 +1493,8 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil)) + "Names are equal if their charvalue, instance-of and themes properties + are equal." (declare (type (or null TopicC) instance-of) (ignorable start-revision charvalue instance-of themes reifier item-identifiers)) @@ -1548,6 +1565,8 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (roles nil) (instance-of nil) (themes nil)) + "Associations are equal if their themes, instance-of and roles + properties are equal." (declare (integer start-revision) (list roles themes item-identifiers) (type (or null TopicC) instance-of reifier)) (or @@ -1630,6 +1649,7 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (player nil) (instance-of nil)) + "Roles are equal if their instance-of and player properties are equal." (declare (integer start-revision) (type (or null TopicC) player instance-of reifier) (list item-identifiers)) @@ -1764,7 +1784,9 @@ ;;; ReifiableConstructC (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers &key start-revision) - (:documentation "Returns t if the passed constructs are TMDM equal.") + (:documentation "Returns t if the passed constructs are TMDM equal, i.e + the reifiable construct have to share an item identifier + or reifier.") (:method ((construct ReifiableConstructC) reifier item-identifiers &key (start-revision 0)) (declare (integer start-revision) (list item-identifiers) @@ -1904,7 +1926,8 @@ ;;; TypableC (defgeneric equivalent-typable-construct (construct instance-of &key start-revision) - (:documentation "Returns t if the passed constructs are TMDM equal.") + (:documentation "Returns t if the passed constructs are TMDM equal, i.e. + the typable constructs have to own the same type.") (:method ((construct TypableC) instance-of &key (start-revision 0)) (declare (integer start-revision) (type (or null TopicC) instance-of)) @@ -1913,7 +1936,8 @@ ;;; ScopableC (defgeneric equivalent-scopable-construct (construct themes &key start-revision) - (:documentation "Returns t if the passed constructs are TMDM equal.") + (:documentation "Returns t if the passed constructs are TMDM equal, i.e. + the scopable constructs have to own the same themes.") (:method ((construct ScopableC) themes &key (start-revision 0)) (declare (integer start-revision) (list themes)) (not (set-exclusive-or (themes construct :revision start-revision) @@ -2041,6 +2065,16 @@ ;;; TopicMapC +(defmethod equivalent-construct ((construct TopicMapC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil)) + "TopicMaps equality if they share the same item-identier or reifier." + (declare (list item-identifiers) (integer start-revision) + (type (or null TopicC) reifier)) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)) + + (defmethod delete-construct :before ((construct TopicMapC)) (dolist (top (slot-p construct 'topics)) (remove-association construct 'topics top)) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Tue Mar 16 08:56:24 2010 @@ -53,7 +53,11 @@ :test-equivalent-PointerC :test-equivalent-OccurrenceC :test-equivalent-NameC - :test-equivalent-VariantC)) + :test-equivalent-VariantC + :test-equivalent-RoleC + :test-equivalent-AssociationC + :test-equivalent-TopicC + :test-equivalent-TopicMapC)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1490,6 +1494,154 @@ (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) +(test test-equivalent-RoleC () + "Tests the functions equivalent-construct depending on RoleC." + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'd:RoleC)) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (player-1 (make-instance 'd:TopicC)) + (player-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (ii-3 (make-instance 'd:ItemIdentifierC :uri "ii-3")) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-type role-1 type-1) + (add-player role-1 player-1) + (add-item-identifier role-1 ii-1) + (add-item-identifier role-1 ii-2) + (add-reifier role-1 reifier-1) + (is-true (d::equivalent-construct role-1 :player player-1 + :instance-of type-1)) + (is-true (d::equivalent-construct role-1 + :item-identifiers (list ii-1 ii-3))) + (is-true (d::equivalent-construct role-1 :reifier reifier-1)) + (is-false (d::equivalent-construct role-1 :player player-2 + :instance-of type-1)) + (is-false (d::equivalent-construct role-1 :player player-1 + :instance-of type-2)) + (is-false (d::equivalent-construct role-1 + :item-identifiers (list ii-3))) + (is-false (d::equivalent-construct role-1 :reifier reifier-2)) + (setf *TM-REVISION* revision-2) + (delete-item-identifier role-1 ii-1 :revision revision-2) + (delete-player role-1 player-1 :revision revision-2) + (add-player role-1 player-2) + (delete-type role-1 type-1 :revision revision-2) + (add-type role-1 type-2) + (delete-reifier role-1 reifier-1 :revision revision-2) + (add-reifier role-1 reifier-2) + (is-true (d::equivalent-construct role-1 :player player-2 + :instance-of type-2)) + (is-true (d::equivalent-construct role-1 + :item-identifiers (list ii-2))) + (is-true (d::equivalent-construct role-1 :reifier reifier-2)) + (is-false (d::equivalent-construct role-1 :player player-1 + :instance-of type-2)) + (is-false (d::equivalent-construct role-1 :player player-2 + :instance-of type-1)) + (is-false (d::equivalent-construct role-1 + :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct role-1 :reifier reifier-1)) + (is-true (d::equivalent-construct role-1 :start-revision revision-1 + :item-identifiers (list ii-1))) + (is-true (d::equivalent-construct role-1 :reifier reifier-1 + :start-revision revision-1))))) + + +(test test-equivalent-AssociationC () + "Tests the functions equivalent-construct depending on AssociationC." + (with-fixture with-empty-db (*db-dir*) + (let ((assoc-1 (make-instance 'd:AssociationC)) + (role-1 (make-instance 'd:RoleC)) + (role-2 (make-instance 'd:RoleC)) + (role-3 (make-instance 'd:RoleC)) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (d:add-role assoc-1 role-1) + (d:add-role assoc-1 role-2) + (d:add-type assoc-1 type-1) + (d:add-theme assoc-1 scope-1) + (d:add-theme assoc-1 scope-2) + (d:add-item-identifier assoc-1 ii-1) + (d:add-reifier assoc-1 reifier-1) + (is-true (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) :instance-of type-1 + :themes (list scope-1 scope-2))) + (is-true (d::equivalent-construct assoc-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct assoc-1 :reifier reifier-1)) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2 role-3) :instance-of type-1 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) :instance-of type-2 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) :instance-of type-1 + :themes (list scope-1 scope-3 scope-2))) + (is-false (d::equivalent-construct assoc-1 :item-identifiers (list ii-2))) + (is-false (d::equivalent-construct assoc-1 :reifeir reifier-2))))) + + +(test test-equivalent-TopicC () + "Tests the functions equivalent-construct depending on TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((top-1 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (sl-1 (make-instance 'd:SubjectLocatorC :uri "sl-1")) + (sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2")) + (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")) + (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2")) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (d:add-item-identifier top-1 ii-1) + (d:add-locator top-1 sl-1) + (d:add-psi top-1 psi-1) + (is-true (d::equivalent-construct top-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2) + :psis (list psi-1 psi-2) + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) + (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) + (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) + :psis (list psi-2) + :locators (list sl-2)))))) + + +(test test-equivalent-TopicMapC () + "Tests the functions equivalent-construct depending on TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((tm-1 (make-instance 'd:TopicMapC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (d:add-item-identifier tm-1 ii-1) + (d:add-reifier tm-1 reifier-1) + (is-true (d::equivalent-construct tm-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct tm-1 :reifier reifier-1)) + (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2))) + (is-false (d::equivalent-construct tm-1 :reifier reifier-2))))) + (defun run-datamodel-tests() "Runs all tests of this test-suite." @@ -1527,4 +1679,8 @@ (it.bese.fiveam:run! 'test-equivalent-OccurrenceC) (it.bese.fiveam:run! 'test-equivalent-NameC) (it.bese.fiveam:run! 'test-equivalent-VariantC) + (it.bese.fiveam:run! 'test-equivalent-RoleC) + (it.bese.fiveam:run! 'test-equivalent-AssociationC) + (it.bese.fiveam:run! 'test-equivalent-TopicC) + (it.bese.fiveam:run! 'test-equivalent-TopicMapC) ) \ No newline at end of file

1 0

[isidorus-cvs] r227 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 16 Mar '10

16 Mar '10

Author: lgiessmann Date: Tue Mar 16 07:32:28 2010 New Revision: 227 Log: new-datamodel: added some unit-tests for equivalent-constructs --> OccurrenceC, NameC, VariantC; changed some "dangerous" code-sections in equivalent-construct Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Mar 16 07:32:28 2010 @@ -1445,32 +1445,42 @@ ;;; OccurrenceC (defmethod equivalent-construct ((construct OccurrenceC) - &key (start-revision 0) (charvalue "") + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil) - (datatype *xml-string*)) + (datatype "")) (declare (type (or null TopicC) instance-of) (string datatype) - (ignorable start-revision charvalue themes instance-of)) + (ignorable start-revision charvalue themes instance-of + reifier item-identifiers)) (let ((equivalent-characteristic (call-next-method))) - (and equivalent-characteristic - (string= (datatype construct) datatype)))) + (or (and equivalent-characteristic + (string= (datatype construct) datatype)) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)))) ;;; VariantC (defmethod equivalent-construct ((construct VariantC) - &key (start-revision 0) (charvalue "") - (themes nil) (datatype *xml-string*)) - (declare (string datatype) (ignorable start-revision charvalue themes)) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") + (themes nil) (datatype "")) + (declare (string datatype) (ignorable start-revision charvalue themes + reifier item-identifiers)) (let ((equivalent-characteristic (call-next-method))) - (and equivalent-characteristic - (string= (datatype construct) datatype)))) + (or (and equivalent-characteristic + (string= (datatype construct) datatype)) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)))) ;;; NameC (defmethod equivalent-construct ((construct NameC) - &key (start-revision 0) (charvalue "") + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil)) (declare (type (or null TopicC) instance-of) - (ignorable start-revision charvalue instance-of themes)) + (ignorable start-revision charvalue instance-of themes + reifier item-identifiers)) (call-next-method)) @@ -1759,9 +1769,11 @@ &key (start-revision 0)) (declare (integer start-revision) (list item-identifiers) (type (or null TopicC) reifier)) - (or (eql reifier (reifier construct :revision start-revision)) - (intersection (item-identifiers construct :revision start-revision) - item-identifiers)))) + (or (and (reifier construct :revision start-revision) + (eql reifier (reifier construct :revision start-revision))) + (and (item-identifiers construct :revision start-revision) + (intersection (item-identifiers construct :revision start-revision) + item-identifiers))))) (defmethod delete-construct :before ((construct ReifiableConstructC)) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Tue Mar 16 07:32:28 2010 @@ -16,6 +16,8 @@ :unittests-constants) (:import-from :exceptions duplicate-identifier-error) + (:import-from :constants + *xml-string*) (:export :run-datamodel-tests :datamodel-test :test-VersionInfoC @@ -48,7 +50,10 @@ :test-delete-ScopableC :test-delete-AssociationC :test-delete-RoleC - :test-equivalent-PointerC)) + :test-equivalent-PointerC + :test-equivalent-OccurrenceC + :test-equivalent-NameC + :test-equivalent-VariantC)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1356,6 +1361,136 @@ (is-false (d::equivalent-construct psi-1 :uri "psi-2"))))) +(test test-equivalent-OccurrenceC () + "Tests the functions equivalent-construct depending on OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'd:OccurrenceC :charvalue "occ-1")) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (revision-0-5 50) + (version-1 100)) + (setf *TM-REVISION* version-1) + (add-type occ-1 type-1) + (add-theme occ-1 scope-1) + (add-theme occ-1 scope-2) + (is-true (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-2 scope-1) + :start-revision revision-0-5)) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-2 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-2" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-2 scope-1))) + (add-item-identifier occ-1 ii-1) + (is-true (d::equivalent-construct occ-1 :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct occ-1 :item-identifiers (list ii-2))) + (add-reifier occ-1 reifier-1) + (is-true (d::equivalent-construct occ-1 :reifier reifier-1)) + (is-false (d::equivalent-construct occ-1 :reifier reifier-2))))) + + +(test test-equivalent-NameC () + "Tests the functions equivalent-construct depending on NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((nam-1 (make-instance 'd:NameC :charvalue "nam-1")) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (revision-0-5 50) + (version-1 100)) + (setf *TM-REVISION* version-1) + (add-type nam-1 type-1) + (add-theme nam-1 scope-1) + (add-theme nam-1 scope-2) + (is-true (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-1 + :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-1 + :themes (list scope-2 scope-1) + :start-revision revision-0-5)) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-2 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-1 + :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-2" :instance-of type-1 + :themes (list scope-2 scope-1))) + (add-item-identifier nam-1 ii-1) + (is-true (d::equivalent-construct nam-1 :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct nam-1 :item-identifiers (list ii-2))) + (add-reifier nam-1 reifier-1) + (is-true (d::equivalent-construct nam-1 :reifier reifier-1)) + (is-false (d::equivalent-construct nam-1 :reifier reifier-2))))) + + +(test test-equivalent-VariantC () + "Tests the functions equivalent-construct depending on VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((var-1 (make-instance 'd:OccurrenceC :charvalue "var-1")) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (revision-0-5 50) + (version-1 100)) + (setf *TM-REVISION* version-1) + (add-theme var-1 scope-1) + (add-theme var-1 scope-2) + (is-true (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-2 scope-1) + :start-revision revision-0-5)) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-2" :datatype constants:*xml-string* + :themes (list scope-2 scope-1))) + (add-item-identifier var-1 ii-1) + (is-true (d::equivalent-construct var-1 :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct var-1 :item-identifiers (list ii-2))) + (add-reifier var-1 reifier-1) + (is-true (d::equivalent-construct var-1 :reifier reifier-1)) + (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) + + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -1389,4 +1524,7 @@ (it.bese.fiveam:run! 'test-delete-AssociationC) (it.bese.fiveam:run! 'test-delete-RoleC) (it.bese.fiveam:run! 'test-equivalent-PointerC) + (it.bese.fiveam:run! 'test-equivalent-OccurrenceC) + (it.bese.fiveam:run! 'test-equivalent-NameC) + (it.bese.fiveam:run! 'test-equivalent-VariantC) ) \ No newline at end of file

1 0

[isidorus-cvs] r226 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 14 Mar '10

14 Mar '10

Author: lgiessmann Date: Sun Mar 14 16:28:40 2010 New Revision: 226 Log: new-datamodel: added some unit-tests for equivalent-construct depending on PointerC Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.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 14 16:28:40 2010 @@ -1362,9 +1362,10 @@ (integer start-revision) (type (or null TopicC) instance-of reifier)) (or (and (string= (charvalue construct) charvalue) - (not (set-exclusive-or (themes construct :revision start-revision) - themes)) - (eql instance-of (instance-of construct :revision start-revision))) + (equivalent-scopable-construct construct themes + :start-revision start-revision) + (equivalent-typable-construct construct instance-of + :start-revision start-revision)) (equivalent-reifiable-construct construct reifier item-identifiers :start-revision start-revision))) @@ -1542,9 +1543,10 @@ (or (and (not (set-exclusive-or roles (roles construct :revision start-revision))) - (eql instance-of (instance-of construct :revision start-revision)) - (not (set-exclusive-or themes - (themes construct :revision start-revision)))) + (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (equivalent-scopable-construct construct themes + :start-revision start-revision)) (equivalent-reifiable-construct construct reifier item-identifiers :start-revision start-revision))) @@ -1621,7 +1623,8 @@ (declare (integer start-revision) (type (or null TopicC) player instance-of reifier) (list item-identifiers)) - (or (and (eql instance-of (instance-of construct :revision start-revision)) + (or (and (equivalent-typable-construct construct instance-of + :start-revision start-revision) (eql player (player construct :revision start-revision))) (equivalent-reifiable-construct construct reifier item-identifiers :start-revision start-revision))) @@ -1886,8 +1889,25 @@ (mark-as-deleted assoc-to-delete :revision revision)) construct))) +;;; TypableC +(defgeneric equivalent-typable-construct (construct instance-of + &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct TypableC) instance-of &key (start-revision 0)) + (declare (integer start-revision) + (type (or null TopicC) instance-of)) + (eql (instance-of construct :revision start-revision) instance-of))) + ;;; ScopableC +(defgeneric equivalent-scopable-construct (construct themes &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct ScopableC) themes &key (start-revision 0)) + (declare (integer start-revision) (list themes)) + (not (set-exclusive-or (themes construct :revision start-revision) + themes)))) + + (defmethod delete-construct :before ((construct ScopableC)) (dolist (scope-assoc-to-delete (slot-p construct 'themes)) (delete-construct scope-assoc-to-delete))) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Sun Mar 14 16:28:40 2010 @@ -47,7 +47,8 @@ :test-delete-TypableC :test-delete-ScopableC :test-delete-AssociationC - :test-delete-RoleC)) + :test-delete-RoleC + :test-equivalent-PointerC)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1337,6 +1338,24 @@ (is-false (elephant:get-instances-by-class 'd::PlayerAssociationC))))) +(test test-equivalent-PointerC () + "Tests the functions equivalent-construct depending on PointerC + and its subclasses." + (with-fixture with-empty-db (*db-dir*) + (let ((p-1 (make-instance 'd::PointerC :uri "p-1")) + (tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))) + (is-true (d::equivalent-construct p-1 :uri "p-1")) + (is-false (d::equivalent-construct p-1 :uri "p-2")) + (is-true (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-1")) + (is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-1")) + (is-false (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-2")) + (is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-2")) + (is-true (d::equivalent-construct psi-1 :uri "psi-1")) + (is-false (d::equivalent-construct psi-1 :uri "psi-2"))))) + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -1369,4 +1388,5 @@ (it.bese.fiveam:run! 'test-delete-ScopableC) (it.bese.fiveam:run! 'test-delete-AssociationC) (it.bese.fiveam:run! 'test-delete-RoleC) + (it.bese.fiveam:run! 'test-equivalent-PointerC) ) \ No newline at end of file

1 0

[isidorus-cvs] r225 - branches/new-datamodel/src/model
by Lukas Giessmann 14 Mar '10

14 Mar '10

Author: lgiessmann Date: Sun Mar 14 11:50:40 2010 New Revision: 225 Log: new-datamodel: added "equivalent-costruct" to PointerC, TopicIdentificationC, CharactersiticC, OccurrenceC, NameC, VariantC, RoleC, AssociationC, TopicC 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 14 11:50:40 2010 @@ -12,6 +12,8 @@ (:nicknames :d) (:import-from :exceptions duplicate-identifier-error) + (:import-from :constants + *xml-string*) (:export ;;classes :TopicMapC :AssociationC @@ -77,6 +79,7 @@ :used-as-type :used-as-theme :datatype + :charvalue :reified-construct :mark-as-deleted :mark-as-deleted-p @@ -97,7 +100,6 @@ (in-package :datamodel) -;;TODO: implement delete-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -186,9 +188,9 @@ :initarg :datatype :initform constants:*xml-string* :type string + :index t :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef).")) - (:index t) (:documentation "An abstract base class for characteristics that own an xml-datatype.")) @@ -581,6 +583,17 @@ (error () nil)))) +(defun make-construct (class-symbol &key start-revision &allow-other-keys) + "Creates a new topic map construct if necessary or + retrieves an equivalent one if available and updates the revision + history accordingly. Returns the object in question. Methods use + specific keyword arguments for their purpose." + (or class-symbol start-revision) + ;TODO: implement + ) + + + (defun delete-1-n-association(instance slot-symbol) (when (slot-p instance slot-symbol) (remove-association @@ -635,6 +648,39 @@ (condition () nil))) +;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) + (:documentation "Returns t if the passed construct is equivalent to the passed + key arguments (TMDM equality rules.")) + + +(defgeneric get-most-recent-version-info (construct) + (:documentation "Returns the latest VersionInfoC object of the passed + versioned construct. + The latest construct is either the one with + end-revision=0 or with the highest end-revision value.")) + + +(defgeneric owned-p (construct) + (:documentation "Returns t if the passed construct is referenced by a parent + TM construct.")) + + +(defgeneric in-topicmaps (construct &key revision) + (:documentation "Returns all TopicMapS-obejcts where the constrict is + contained in.")) + + +(defgeneric add-to-tm (construct construct-to-add) + (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) + + +(defgeneric delete-from-tm (construct construct-to-delete) + (:documentation "Deletes a TM construct (TopicC or AssociationC) from + the TM.")) + + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) @@ -647,13 +693,6 @@ (delete-construct version-info))) -(defgeneric get-most-recent-version-info (construct) - (:documentation "Returns the latest VersionInfoC object of the passed - versioned construct. - The latest construct is either the one with - end-revision=0 or with the highest end-revision value.")) - - (defmethod get-most-recent-version-info ((construct VersionedConstructC)) (let ((result (find 0 (versions construct) :key #'end-revision))) (if result @@ -690,38 +729,36 @@ (defgeneric add-to-version-history (construct &key start-revision end-revision) - (:documentation "Adds version history to a versioned construct")) - - -(defmethod add-to-version-history ((construct VersionedConstructC) - &key (start-revision (error "From add-to-version-history(): start revision must be present")) - (end-revision 0)) - (let ((eql-version-info - (find-if #'(lambda(vi) - (and (= (start-revision vi) start-revision) - (= (end-revision vi) end-revision))) - (versions construct)))) - (if eql-version-info - eql-version-info - (let ((current-version-info - (get-most-recent-version-info construct))) - (cond - ((and current-version-info - (= (end-revision current-version-info) start-revision)) - (setf (end-revision current-version-info) 0) - current-version-info) - ((and current-version-info - (= (end-revision current-version-info) 0)) - (setf (end-revision current-version-info) start-revision) - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)) - (t - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct))))))) + (:documentation "Adds version history to a versioned construct") + (:method ((construct VersionedConstructC) + &key (start-revision (error "From add-to-version-history(): start revision must be present")) + (end-revision 0)) + (let ((eql-version-info + (find-if #'(lambda(vi) + (and (= (start-revision vi) start-revision) + (= (end-revision vi) end-revision))) + (versions construct)))) + (if eql-version-info + eql-version-info + (let ((current-version-info + (get-most-recent-version-info construct))) + (cond + ((and current-version-info + (= (end-revision current-version-info) start-revision)) + (setf (end-revision current-version-info) 0) + current-version-info) + ((and current-version-info + (= (end-revision current-version-info) 0)) + (setf (end-revision current-version-info) start-revision) + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct)) + (t + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct)))))))) (defgeneric marked-as-deleted-p (construct) @@ -736,32 +773,28 @@ (defgeneric mark-as-deleted (construct &key source-locator revision) (:documentation "Mark a construct as deleted if it comes from the source - indicated by source-locator")) - + indicated by source-locator") + (:method ((construct VersionedConstructC) &key source-locator revision) + (declare (ignorable source-locator)) + (let + ((last-version ;the last active version + (find 0 (versions construct) :key #'end-revision))) + (when last-version + (setf (end-revision last-version) revision))))) + -(defmethod mark-as-deleted ((construct VersionedConstructC) - &key source-locator revision) - "Mark a topic as deleted if it comes from the source indicated by - source-locator" - (declare (ignorable source-locator)) - (let - ((last-version ;the last active version - (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision)))) +;;; PointerC +(defmethod equivalent-construct ((construct PointerC) + &key start-revision (uri "")) + (declare (string uri) (ignorable start-revision)) + (string= (uri construct) uri)) -;;; PointerC (defmethod delete-construct :before ((construct PointerC)) (dolist (p-assoc (slot-p construct 'identified-construct)) (delete-construct p-assoc))) -(defgeneric owned-p (construct) - (:documentation "Returns t if the passed construct is referenced by a parent - TM construct.")) - - (defmethod owned-p ((construct PointerC)) (when (slot-p construct 'identified-construct) t)) @@ -779,6 +812,17 @@ (first assocs))))) +;;; TopicIdentificationC +(defmethod equivalent-construct ((construct TopicIdentificationC) + &key start-revision (uri "") (xtm-id "")) + (declare (string uri xtm-id)) + (let ((equivalent-pointer (call-next-method + construct :start-revision start-revision + :uri uri))) + (and equivalent-pointer + (string= (xtm-id construct) xtm-id)))) + + ;;; PointerAssociationC (defmethod delete-construct :before ((construct PointerAssociationC)) (delete-1-n-association construct 'identifier)) @@ -855,6 +899,19 @@ ;;; TopicC +(defmethod equivalent-construct ((construct TopicC) + &key (start-revision 0) (psis nil) + (locators nil) (item-identifiers nil)) + (declare (integer start-revision) (list psis locators item-identifiers)) + (when + (intersection + (union (union (psis construct :revision start-revision) + (locators construct :revision start-revision)) + (item-identifiers construct :revision start-revision)) + (union (union psis locators) item-identifiers)) + t)) + + (defmethod delete-construct :before ((construct TopicC)) (let ((psi-assocs-to-delete (slot-p construct 'psis)) (sl-assocs-to-delete (slot-p construct 'locators)) @@ -1193,10 +1250,6 @@ (reifiable-construct (first assocs)))))) -(defgeneric in-topicmaps (construct &key revision) - (:documentation "Returns all TopicMapS-obejcts where the constrict is - contained in.")) - (defmethod in-topicmaps ((topic TopicC) &key (revision 0)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) @@ -1298,67 +1351,24 @@ :error-if-nil error-if-nil)) -;;; NameC -(defmethod delete-construct :before ((construct NameC)) - (let ((variant-assocs-to-delete (slot-p construct 'variants))) - (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) - (dolist (variant-assoc-to-delete variant-assocs-to-delete) - (delete-construct variant-assoc-to-delete)) - (dolist (candidate-to-delete all-variants) - (unless (owned-p candidate-to-delete) - (delete-construct candidate-to-delete)))))) - - -(defgeneric variants (construct &key revision) - (:documentation "Returns all variants that correspond with the given revision - and that are associated with the passed construct.") - (:method ((construct NameC) &key (revision 0)) - (let ((valid-associations - (filter-slot-value-by-revision construct 'variants - :start-revision revision))) - (map 'list #'characteristic valid-associations)))) - - -(defgeneric add-variant (construct variant &key revision) - (:documentation "Adds the given theme-topic to the passed - scopable-construct.") - (:method ((construct NameC) (variant VariantC) - &key (revision *TM-REVISION*)) - (when (and (parent variant :revision revision) - (not (eql (parent variant :revision revision) construct))) - (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" - variant construct (parent variant))) - (let ((all-variants - (map 'list #'characteristic (slot-p construct 'variants)))) - (if (find variant all-variants) - (let ((variant-assoc - (loop for variant-assoc in (slot-p construct 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (add-to-version-history variant-assoc :start-revision revision)) - (let ((assoc - (make-instance 'VariantAssociationC - :characteristic variant - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) - construct)) - - -(defgeneric delete-variant (construct variant &key revision) - (:documentation "Deletes the passed variant by marking it's association as - deleted in the passed revision.") - (:method ((construct NameC) (variant VariantC) - &key (revision (error "From delete-variant(): revision must be set"))) - (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct - 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct))) +;;; CharacteristicC +(defmethod equivalent-construct ((construct CharacteristicC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") + (instance-of nil) (themes nil)) + "Equality rule: Characteristics are equal if charvalue, themes and the parent- + constructs are equal." + (declare (string charvalue) (list themes item-identifiers) + (integer start-revision) + (type (or null TopicC) instance-of reifier)) + (or (and (string= (charvalue construct) charvalue) + (not (set-exclusive-or (themes construct :revision start-revision) + themes)) + (eql instance-of (instance-of construct :revision start-revision))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) -;;; CharacteristicC (defmethod delete-construct :before ((construct CharacteristicC)) (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) (delete-construct characteristic-assoc-to-delete))) @@ -1432,7 +1442,113 @@ construct))) +;;; OccurrenceC +(defmethod equivalent-construct ((construct OccurrenceC) + &key (start-revision 0) (charvalue "") + (themes nil) (instance-of nil) + (datatype *xml-string*)) + (declare (type (or null TopicC) instance-of) (string datatype) + (ignorable start-revision charvalue themes instance-of)) + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; VariantC +(defmethod equivalent-construct ((construct VariantC) + &key (start-revision 0) (charvalue "") + (themes nil) (datatype *xml-string*)) + (declare (string datatype) (ignorable start-revision charvalue themes)) + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; NameC +(defmethod equivalent-construct ((construct NameC) + &key (start-revision 0) (charvalue "") + (themes nil) (instance-of nil)) + (declare (type (or null TopicC) instance-of) + (ignorable start-revision charvalue instance-of themes)) + (call-next-method)) + + +(defmethod delete-construct :before ((construct NameC)) + (let ((variant-assocs-to-delete (slot-p construct 'variants))) + (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) + (dolist (variant-assoc-to-delete variant-assocs-to-delete) + (delete-construct variant-assoc-to-delete)) + (dolist (candidate-to-delete all-variants) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete)))))) + + +(defgeneric variants (construct &key revision) + (:documentation "Returns all variants that correspond with the given revision + and that are associated with the passed construct.") + (:method ((construct NameC) &key (revision 0)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'variants + :start-revision revision))) + (map 'list #'characteristic valid-associations)))) + + +(defgeneric add-variant (construct variant &key revision) + (:documentation "Adds the given theme-topic to the passed + scopable-construct.") + (:method ((construct NameC) (variant VariantC) + &key (revision *TM-REVISION*)) + (when (and (parent variant :revision revision) + (not (eql (parent variant :revision revision) construct))) + (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" + variant construct (parent variant))) + (let ((all-variants + (map 'list #'characteristic (slot-p construct 'variants)))) + (if (find variant all-variants) + (let ((variant-assoc + (loop for variant-assoc in (slot-p construct 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (add-to-version-history variant-assoc :start-revision revision)) + (let ((assoc + (make-instance 'VariantAssociationC + :characteristic variant + :parent-construct construct))) + (add-to-version-history assoc :start-revision revision)))) + construct)) + + +(defgeneric delete-variant (construct variant &key revision) + (:documentation "Deletes the passed variant by marking it's association as + deleted in the passed revision.") + (:method ((construct NameC) (variant VariantC) + &key (revision (error "From delete-variant(): revision must be set"))) + (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct + 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + ;;; AssociationC +(defmethod equivalent-construct ((construct AssociationC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (roles nil) + (instance-of nil) (themes nil)) + (declare (integer start-revision) (list roles themes item-identifiers) + (type (or null TopicC) instance-of reifier)) + (or + (and + (not (set-exclusive-or roles (roles construct :revision start-revision))) + (eql instance-of (instance-of construct :revision start-revision)) + (not (set-exclusive-or themes + (themes construct :revision start-revision)))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) + + (defmethod delete-construct :before ((construct AssociationC)) (let ((roles-assocs-to-delete (slot-p construct 'roles))) (let ((all-roles (map 'list #'role roles-assocs-to-delete))) @@ -1498,6 +1614,19 @@ ;;; RoleC +(defmethod equivalent-construct ((construct RoleC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (player nil) + (instance-of nil)) + (declare (integer start-revision) + (type (or null TopicC) player instance-of reifier) + (list item-identifiers)) + (or (and (eql instance-of (instance-of construct :revision start-revision)) + (eql player (player construct :revision start-revision))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) + + (defmethod delete-construct :before ((construct RoleC)) (dolist (role-assoc-to-delete (slot-p construct 'parent)) (delete-construct role-assoc-to-delete)) @@ -1620,6 +1749,18 @@ ;;; ReifiableConstructC +(defgeneric equivalent-reifiable-construct (construct reifier item-identifiers + &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct ReifiableConstructC) reifier item-identifiers + &key (start-revision 0)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (or (eql reifier (reifier construct :revision start-revision)) + (intersection (item-identifiers construct :revision start-revision) + item-identifiers)))) + + (defmethod delete-construct :before ((construct ReifiableConstructC)) (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers)) (reifier-assocs-to-delete (slot-p construct 'reifier))) @@ -1889,10 +2030,6 @@ :start-revision revision))) -(defgeneric add-to-tm (construct construct-to-add) - (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) - - (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) (add-association construct 'topics construct-to-add)) @@ -1901,11 +2038,6 @@ (add-association construct 'associations construct-to-add)) -(defgeneric delete-from-tm (construct construct-to-delete) - (:documentation "Deletes a TM construct (TopicC or AssociationC) from - the TM.")) - - (defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) (remove-association construct 'topics construct-to-delete)) @@ -1923,15 +2055,22 @@ + + + + + + + + + + + + ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric merge-constructs(construct-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) (or revision) (if construct-1 construct-1 construct-2))) - - -(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) - (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*)) - (or class-symbol start-revision))) ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file

1 0