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