isidorus-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
March 2010
- 1 participants
- 37 discussions
[isidorus-cvs] r234 - in branches/new-datamodel/src: json model rest_interface unit_tests xml/rdf xml/xtm
by Lukas Giessmann 20 Mar '10
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
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
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
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
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
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
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
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
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
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