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
