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
22 Mar '10
Author: lgiessmann
Date: Mon Mar 22 09:04:20 2010
New Revision: 244
Log:
new-datamodel: add "find-item-by-revision" to classes that are non-VersionedConstructC classes but that are related with their parent-constructs via VersionedAssociationCs. added alsome some unit-tests for this generic
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 Mon Mar 22 09:04:20 2010
@@ -156,12 +156,13 @@
-
+;;TOOD: replace the key argument (revision 0)/(start-revision 0)
+;; by (start-revision *TM-REVISION*) (revision *TM-REVISION*)
+;; to be compatible to the macro with-revision
;;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
+;; add-item-identifier/add-reifier (can merge the parent constructs
+;; and the parent's parent construct + the reifier constructs),
+;; add-psi, add-locator (--> duplicate-identifier-error)
;;TODO: implement a macro "with-merge-construct" that merges constructs
;; after some data-operations are completed (should be passed as body)
;; and a merge should be done
@@ -171,7 +172,7 @@
;; the method should merge two constructs that are inherited from
;; ReifiableConstructC
;;TODO: implement find-item-by-revision for all classes that don't have their
-;; one revision-infos
+;; one revision-infos --> PointerC, CharacteristicC, RoleC
;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -746,6 +747,16 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric find-item-by-revision (construct revision
+ &optional parent-construct)
+ (:documentation "Returns the given object if it exists in the passed
+ version otherwise nil.
+ Constructs that exist to be owned by parent-constructs
+ must provide their parent-construct to get the corresponding
+ revision of the relationship between the construct itself and
+ its parent-construct."))
+
+
(defgeneric check-for-duplicate-identifiers (construct)
(:documentation "Check for possibly duplicate identifiers and signal an
duplicate-identifier-error is such duplicates are found"))
@@ -817,6 +828,21 @@
(delete-construct version-info)))
+(defmethod find-item-by-revision ((construct VersionedConstructC)
+ (revision integer) &optional parent-construct)
+ (declare (ignorable parent-construct))
+ (cond ((= revision 0)
+ (find-most-recent-revision construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions construct))
+ construct))))
+
+
(defmethod get-most-recent-version-info ((construct VersionedConstructC))
(let ((result (find 0 (versions construct) :key #'end-revision)))
(if result
@@ -836,22 +862,6 @@
construct)))
-(defgeneric find-item-by-revision (construct revision)
- (:documentation "Returns the given object if it exists in the passed
- version otherwise nil.")
- (:method ((construct VersionedConstructC) (revision integer))
- (cond ((= revision 0)
- (find-most-recent-revision construct))
- (t
- (when (find-if
- #'(lambda(vi)
- (and (>= revision (start-revision vi))
- (or (< revision (end-revision vi))
- (= 0 (end-revision vi)))))
- (versions construct))
- construct)))))
-
-
(defgeneric add-to-version-history (construct &key start-revision end-revision)
(:documentation "Adds version history to a versioned construct")
(:method ((construct VersionedConstructC)
@@ -951,6 +961,33 @@
(string= (uri construct) uri))
+(defmethod find-item-by-revision ((construct PointerC)
+ (revision integer) &optional parent-construct)
+ (if parent-construct
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'identified-construct)))))
+ (when assocs
+ (first assocs)))))
+ (cond ((= revision 0)
+ (find-most-recent-revision parent-assoc))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct))))
+ nil))
+
+
(defmethod delete-construct :before ((construct PointerC))
(dolist (p-assoc (slot-p construct 'identified-construct))
(delete-construct p-assoc)))
@@ -1685,6 +1722,35 @@
:start-revision start-revision)))
+(defmethod find-item-by-revision ((construct CharacteristicC)
+ (revision integer) &optional parent-construct)
+ (if parent-construct
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'parent)))))
+ (when assocs
+ (first assocs)))))
+ (cond ((= revision 0)
+ (when
+ (find-most-recent-revision parent-assoc)
+ construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct))))
+ nil))
+
+
(defmethod delete-construct :before ((construct CharacteristicC))
(dolist (characteristic-assoc-to-delete (slot-p construct 'parent))
(delete-construct characteristic-assoc-to-delete)))
@@ -1997,6 +2063,33 @@
(eql player (player construct :revision start-revision))))
+(defmethod find-item-by-revision ((construct RoleC)
+ (revision integer) &optional parent-construct)
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'parent)))))
+ (when assocs
+ (first assocs)))))
+ (cond ((= revision 0)
+ (when
+ (find-most-recent-revision parent-assoc)
+ construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
+
+
(defmethod delete-construct :before ((construct RoleC))
(dolist (role-assoc-to-delete (slot-p construct 'parent))
(delete-construct role-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 Mon Mar 22 09:04:20 2010
@@ -58,9 +58,12 @@
:test-equivalent-AssociationC
:test-equivalent-TopicC
:test-equivalent-TopicMapC
- :test-class-p))
+ :test-class-p
+ :test-find-item-by-revision))
+;;TODO: complete all test of the form test-add-<whatever>
+;; --> indirect call of add-to-version-history
;;TODO: test make-construct
;;TODO: test merge-constructs
@@ -1627,6 +1630,80 @@
(is-false (d:PointerC-p class))))))
+(test test-find-item-by-revision ()
+ "Tests the function find-item-by-revision."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((top-1 (make-instance 'TopicC))
+ (top-2 (make-instance 'TopicC))
+ (assoc-1 (make-instance 'AssociationC))
+ (assoc-2 (make-instance 'AssociationC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (psi-1 (make-instance 'PersistentIdC :uri "psi-1"))
+ (name-1 (make-instance 'NameC))
+ (name-2 (make-instance 'NameC))
+ (variant-1 (make-instance 'VariantC))
+ (role-1 (make-instance 'RoleC))
+ (rev-0 0)
+ (rev-0-5 50)
+ (rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (rev-4 400)
+ (rev-5 500))
+ (setf *TM-REVISION* rev-1)
+ (d::add-to-version-history top-1 :start-revision rev-1)
+ (d::add-to-version-history top-1 :start-revision rev-3)
+ (is (eql top-1 (find-item-by-revision top-1 rev-1)))
+ (is (eql top-1 (find-item-by-revision top-1 rev-0)))
+ (is (eql top-1 (find-item-by-revision top-1 rev-4)))
+ (is (eql top-1 (find-item-by-revision top-1 rev-2)))
+ (is-false (find-item-by-revision top-1 rev-0-5))
+ (add-item-identifier top-1 ii-1 :revision rev-3)
+ (add-item-identifier top-1 ii-2 :revision rev-3)
+ (add-item-identifier top-1 ii-1 :revision rev-4)
+ (delete-item-identifier top-1 ii-1 :revision rev-5)
+ (add-item-identifier top-2 ii-1 :revision rev-5)
+ (add-psi top-2 psi-1 :revision rev-1)
+ (is (eql ii-1 (find-item-by-revision ii-1 rev-3 top-1)))
+ (is (eql ii-1 (find-item-by-revision ii-1 rev-4 top-1)))
+ (is-false (find-item-by-revision ii-1 rev-2 top-1))
+ (is-false (find-item-by-revision ii-1 rev-5 top-1))
+ (is-false (find-item-by-revision ii-1 rev-3))
+ (is-false (find-item-by-revision ii-1 rev-0 top-1))
+ (is (eql ii-1 (find-item-by-revision ii-1 rev-5 top-2)))
+ (add-role assoc-1 role-1 :revision rev-1)
+ (delete-role assoc-1 role-1 :revision rev-3)
+ (add-role assoc-2 role-1 :revision rev-5)
+ (is (eql role-1 (find-item-by-revision role-1 rev-1 assoc-1)))
+ (is (eql role-1 (find-item-by-revision role-1 rev-2 assoc-1)))
+ (is (eql role-1 (find-item-by-revision role-1 rev-5 assoc-2)))
+ (is (eql role-1 (find-item-by-revision role-1 rev-0 assoc-2)))
+ (is-false (find-item-by-revision role-1 rev-0-5 assoc-1))
+ (is-false (find-item-by-revision role-1 rev-0 assoc-1))
+ (is-false (find-item-by-revision role-1 rev-3 assoc-1))
+ (is-false (find-item-by-revision role-1 rev-3 assoc-2))
+ (add-name top-1 name-1 :revision rev-1)
+ (delete-name top-1 name-1 :revision rev-3)
+ (add-name top-2 name-1 :revision rev-3)
+ (is (eql name-1 (find-item-by-revision name-1 rev-1 top-1)))
+ (is (eql name-1 (find-item-by-revision name-1 rev-2 top-1)))
+ (is (eql name-1 (find-item-by-revision name-1 rev-5 top-2)))
+ (is (eql name-1 (find-item-by-revision name-1 rev-0 top-2)))
+ (is-false (find-item-by-revision name-1 rev-0-5 top-1))
+ (is-false (find-item-by-revision name-1 rev-0 top-1))
+ (is-false (find-item-by-revision name-1 rev-3 top-1))
+ (add-variant name-1 variant-1 :revision rev-1)
+ (delete-variant name-1 variant-1 :revision rev-3)
+ (add-variant name-2 variant-1 :revision rev-3)
+ (is (eql variant-1 (find-item-by-revision variant-1 rev-1 name-1)))
+ (is (eql variant-1 (find-item-by-revision variant-1 rev-2 name-1)))
+ (is (eql variant-1 (find-item-by-revision variant-1 rev-5 name-2)))
+ (is (eql variant-1 (find-item-by-revision variant-1 rev-0 name-2)))
+ (is-false (find-item-by-revision variant-1 rev-0-5 name-1))
+ (is-false (find-item-by-revision variant-1 rev-0 name-1))
+ (is-false (find-item-by-revision variant-1 rev-3 name-1)))))
+
@@ -1672,4 +1749,5 @@
(it.bese.fiveam:run! 'test-equivalent-TopicC)
(it.bese.fiveam:run! 'test-equivalent-TopicMapC)
(it.bese.fiveam:run! 'test-class-p)
+ (it.bese.fiveam:run! 'test-find-item-by-revision)
)
\ No newline at end of file
1
0
22 Mar '10
Author: lgiessmann
Date: Mon Mar 22 07:54:27 2010
New Revision: 243
Log:
new-datamodel: added "make-construct" for VersionedAssocitionC and unknown classes via "(apply make-instance class-symbol args)" replaced all "make-instance" and "add-to-version-history" calls by "make-construct" in all add-<whatever> generics
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 Mon Mar 22 07:54:27 2010
@@ -146,6 +146,7 @@
:changed-p
:check-for-duplicate-identifiers
:find-item-by-content
+ :rec-remf
;;globals
:*TM-REVISION*
@@ -161,8 +162,6 @@
;; 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
;;TODO: implement a macro "with-merge-construct" that merges constructs
;; after some data-operations are completed (should be passed as body)
;; and a merge should be done
@@ -623,6 +622,15 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun rec-remf (plist keyword)
+ "Calls remf for the past plist with the given keyword until
+ all key-value-pairs corresponding to the passed keyword were removed."
+ (declare (list plist) (keyword keyword))
+ (loop while (getf plist keyword)
+ do (remf plist keyword))
+ plist)
+
+
(defun get-item-by-content (content &key (revision *TM-REVISION*))
"Finds characteristics by their (atomic) content."
(flet
@@ -1220,10 +1228,10 @@
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))))
+ (make-construct 'TopicIdAssociationC
+ :parent-construct construct
+ :identifier topic-identifier
+ :start-revision revision)))
(add-to-version-history merged-construct :start-revision revision)
merged-construct))))
@@ -1275,10 +1283,10 @@
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))))
+ (make-construct 'PersistentIdAssociationC
+ :parent-construct construct
+ :identifier psi
+ :start-revision revision)))
(add-to-version-history merged-construct :start-revision revision)
merged-construct))))
@@ -1331,11 +1339,10 @@
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))))
+ (make-construct 'SubjectLocatorAssociationC
+ :parent-construct construct
+ :identifier locator
+ :start-revision revision)))
(add-to-version-history merged-construct :start-revision revision)
merged-construct))))
@@ -1390,11 +1397,10 @@
construct)
return name-assoc)))
(add-to-version-history name-assoc :start-revision revision))
- (let ((assoc
- (make-instance 'NameAssociationC
- :parent-construct construct
- :characteristic name)))
- (add-to-version-history assoc :start-revision revision))))
+ (make-construct 'NameAssociationC
+ :parent-construct construct
+ :characteristic name
+ :start-revision revision)))
(add-to-version-history construct :start-revision revision)
construct))
@@ -1440,11 +1446,10 @@
when (eql (parent-construct occ-assoc) construct)
return occ-assoc)))
(add-to-version-history occ-assoc :start-revision revision))
- (let ((assoc
- (make-instance 'OccurrenceAssociationC
- :parent-construct construct
- :characteristic occurrence)))
- (add-to-version-history assoc :start-revision revision))))
+ (make-construct 'OccurrenceAssociationC
+ :parent-construct construct
+ :characteristic occurrence
+ :start-revision revision)))
(add-to-version-history construct :start-revision revision)
construct))
@@ -1732,10 +1737,10 @@
'NameAssociationC)
(t
'VariantAssociationC))))
- (let ((assoc (make-instance association-type
- :characteristic construct
- :parent-construct parent-construct)))
- (add-to-version-history assoc :start-revision revision))))))
+ (make-construct association-type
+ :characteristic construct
+ :parent-construct parent-construct
+ :start-revision revision)))))
construct))
@@ -1864,11 +1869,10 @@
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))))
+ (make-construct 'VariantAssociationC
+ :characteristic variant
+ :parent-construct construct
+ :start-revision revision)))
construct))
@@ -1949,11 +1953,10 @@
when (eql (role role-assoc) role)
return role-assoc)))
(add-to-version-history role-assoc :start-revision revision))
- (let ((assoc
- (make-instance 'RoleAssociationC
- :role role
- :parent-construct construct)))
- (add-to-version-history assoc :start-revision revision))))
+ (make-construct 'RoleAssociationC
+ :role role
+ :parent-construct construct
+ :start-revision revision)))
(add-to-version-history construct :start-revision revision)
construct))
@@ -2043,10 +2046,10 @@
(same-parent-assoc
(add-to-version-history same-parent-assoc :start-revision revision))
(t
- (let ((assoc (make-instance 'RoleAssociationC
- :role construct
- :parent-construct parent-construct)))
- (add-to-version-history assoc :start-revision revision)))))
+ (make-construct 'RoleAssociationC
+ :role construct
+ :parent-construct parent-construct
+ :start-revision revision))))
(add-to-version-history parent-construct :start-revision revision)
construct)
@@ -2095,10 +2098,10 @@
(same-player-assoc
(add-to-version-history same-player-assoc :start-revision revision))
(t
- (let ((assoc (make-instance 'PlayerAssociationC
- :parent-construct construct
- :player-topic player-topic)))
- (add-to-version-history assoc :start-revision revision)))))
+ (make-construct 'PlayerAssociationC
+ :parent-construct construct
+ :player-topic player-topic
+ :start-revision revision))))
construct))
@@ -2237,10 +2240,10 @@
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))))
+ (make-construct 'ItemIdAssociationC
+ :parent-construct construct
+ :identifier item-identifier
+ :start-revision revision)))
(when (or (typep merged-construct 'TopicC)
(typep merged-construct 'AssociationC)
(typep merged-construct 'TopicMapC))
@@ -2291,10 +2294,10 @@
(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))))
+ (make-construct 'ReifierAssociationC
+ :reifiable-construct construct
+ :reifier-topic merged-reifier-topic
+ :start-revision revision)))
(when (or (typep merged-construct 'TopicC)
(typep merged-construct 'AssociationC)
(typep merged-construct 'TopicMapC))
@@ -2409,11 +2412,10 @@
when (eql (theme-topic theme-assoc) theme-topic)
return theme-assoc)))
(add-to-version-history theme-assoc :start-revision revision))
- (let ((assoc
- (make-instance 'ScopeAssociationC
- :theme-topic theme-topic
- :scopable-construct construct)))
- (add-to-version-history assoc :start-revision revision))))
+ (make-construct 'ScopeAssociationC
+ :theme-topic theme-topic
+ :scopable-construct construct
+ :start-revision revision)))
(when (typep construct 'AssociationC)
(add-to-version-history construct :start-revision revision))
construct))
@@ -2481,11 +2483,10 @@
(same-type-assoc
(add-to-version-history same-type-assoc :start-revision revision))
(t
- (let ((assoc
- (make-instance 'TypeAssociationC
- :type-topic type-topic
- :typable-construct construct)))
- (add-to-version-history assoc :start-revision revision)))))
+ (make-construct 'TypeAssociationC
+ :type-topic type-topic
+ :typable-construct construct
+ :start-revision revision))))
(when (typep construct 'AssociationC)
(add-to-version-history construct :start-revision revision))
construct))
@@ -2582,6 +2583,8 @@
(apply #'make-role args))
((AssociationC-p class-symbol)
(apply #'make-association args))
+ ((VersionedConstructC-p class-symbol)
+ (apply #'make-instance (rec-remf args :start-revision)))
(t
(apply #'make-instance class-symbol args))))
(start-revision (getf args :start-revision)))
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 Mon Mar 22 07:54:27 2010
@@ -908,7 +908,6 @@
(topics tm-1))) 1))
(is (= (length (union (list tm-1)
(in-topicmaps top-1))) 1))
- (is-false (topics tm-1 :revision revision-0-5))
(is-false (in-topicmaps top-1 :revision revision-0-5))
(d::add-to-version-history assoc-1 :start-revision revision-1)
(add-to-tm tm-1 assoc-1)
@@ -916,14 +915,12 @@
(associations tm-1))) 1))
(is (= (length (union (list tm-1)
(in-topicmaps assoc-1))) 1))
- (is-false (associations tm-1 :revision revision-0-5))
(is-false (in-topicmaps assoc-1 :revision revision-0-5))
(add-to-tm tm-2 top-1)
(is (= (length (union (list top-1)
(topics tm-2))) 1))
(is (= (length (union (list tm-2 tm-1)
(in-topicmaps top-1))) 2))
- (is-false (topics tm-2 :revision revision-0-5))
(is-false (in-topicmaps top-1 :revision revision-0-5))
(d::add-to-version-history assoc-1 :start-revision revision-1)
(add-to-tm tm-2 assoc-1)
@@ -931,7 +928,6 @@
(associations tm-2))) 1))
(is (= (length (union (list tm-2 tm-1)
(in-topicmaps assoc-1))) 2))
- (is-false (associations tm-2 :revision revision-0-5))
(is-false (in-topicmaps assoc-1 :revision revision-0-5)))))
1
0
21 Mar '10
Author: lgiessmann
Date: Sun Mar 21 15:25:42 2010
New Revision: 242
Log:
new-datamodel: changed some code sections that caused problems with the package "json" --> the compilation of isidorus succeeds now without errors and warnings but most likely there currently exist some semantic errors
Modified:
branches/new-datamodel/src/json/json_importer.lisp
branches/new-datamodel/src/xml/xtm/importer.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 Sun Mar 21 15:25:42 2010
@@ -68,7 +68,7 @@
(declare (integer start-revision))
(declare (TopicMapC tm))
(setf roles (xml-importer::set-standard-role-types roles))
- (add-to-topicmap tm
+ (add-to-tm tm
(make-construct 'AssociationC
:start-revision start-revision
:item-identifiers item-identifiers
@@ -127,7 +127,7 @@
do (json-to-occurrence occurrence-values top start-revision))
(dolist (instanceOf-top instanceof-topics)
(json-create-instanceOf-association instanceOf-top top start-revision :tm tm))
-; (add-to-topicmap tm top) ; will be done in "json-to-stub"
+; (add-to-tm tm top) ; will be done in "json-to-stub"
top)))))
@@ -157,7 +157,7 @@
:psis subject-identifiers
:topicid (getf json-decoded-list :id)
:xtm-id xtm-id)))
- (add-to-topicmap tm top)
+ (add-to-tm tm top)
top)))))
@@ -329,7 +329,7 @@
(unless (and associationtype roletype1 roletype2)
(error "Error in the creation of an instanceof association: core topics are missing"))
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct
'AssociationC
Modified: branches/new-datamodel/src/xml/xtm/importer.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/importer.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/importer.lisp Sun Mar 21 15:25:42 2010
@@ -136,7 +136,7 @@
(let
((top
(from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm")))
- (add-to-topicmap tm top)))))))
+ (add-to-tm tm top)))))))
;TODO: replace the two importers with this macro
(defmacro importer-mac
@@ -190,7 +190,7 @@
(make-condition 'missing-reference-error
:message "could not find type topic (first player)"
:reference topicid-of-supertype)))
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct
'AssociationC
1
0
21 Mar '10
Author: lgiessmann
Date: Sun Mar 21 15:17:59 2010
New Revision: 241
Log:
new-datamodel: changed some code sections that caused problems with the package "xml"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/xml/rdf/importer.lisp
branches/new-datamodel/src/xml/rdf/map_to_tm.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 21 15:17:59 2010
@@ -22,6 +22,8 @@
:TopicMapConstructC
:VersionedConstructC
:ReifiableConstructC
+ :ScopableC
+ :TypableC
:TopicMapC
:AssociationC
:RoleC
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 Sun Mar 21 15:17:59 2010
@@ -67,7 +67,7 @@
((top
(from-topic-elem-to-stub top-elem revision
:xtm-id *rdf-core-xtm*)))
- (add-to-topicmap xml-importer::tm top))))))))
+ (add-to-tm xml-importer::tm top))))))))
(defun import-dom (rdf-dom start-revision
@@ -355,7 +355,7 @@
(list :instance-of role-type-2
:player sub-top))))
(let ((assoc
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct 'AssociationC
:start-revision start-revision
@@ -396,7 +396,7 @@
(list :instance-of roletype-2
:player instance-top))))
(let ((assoc
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct 'AssociationC
:start-revision start-revision
@@ -449,7 +449,7 @@
:uri ii-uri
:start-revision start-revision)))))
(handler-case (let ((top
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct
'TopicC
@@ -502,7 +502,7 @@
(list :instance-of role-type-2
:player top))))
(let ((assoc
- (add-to-topicmap tm (make-construct 'AssociationC
+ (add-to-tm tm (make-construct 'AssociationC
:start-revision start-revision
:instance-of type-top
:roles roles))))
@@ -531,7 +531,7 @@
(list :instance-of role-type-2
:player object-topic))))
(let ((assoc
- (add-to-topicmap
+ (add-to-tm
tm (make-construct 'AssociationC
:start-revision start-revision
:instance-of associationtype-topic
Modified: branches/new-datamodel/src/xml/rdf/map_to_tm.lisp
==============================================================================
--- branches/new-datamodel/src/xml/rdf/map_to_tm.lisp (original)
+++ branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Sun Mar 21 15:17:59 2010
@@ -188,7 +188,7 @@
(delete-related-associations assoc-top)
(d::delete-construct assoc-top)
(with-tm (start-revision document-id tm-id)
- (add-to-topicmap
+ (add-to-tm
xml-importer::tm
(let ((association
(make-construct 'AssociationC
@@ -229,9 +229,9 @@
(new-item-ids (map-isi-identifiers top start-revision))
(occurrence-topics (get-isi-occurrences top start-revision))
(name-topics (get-isi-names top start-revision)))
- (bound-subject-identifiers top new-psis)
- (bound-subject-locators top new-locators)
- (bound-item-identifiers top new-item-ids)
+ (bound-subject-identifiers top new-psis start-revision)
+ (bound-subject-locators top new-locators start-revision)
+ (bound-item-identifiers top new-item-ids start-revision)
(map 'list #'(lambda(occurrence-topic)
(map-isi-occurrence top occurrence-topic start-revision))
occurrence-topics)
@@ -560,7 +560,7 @@
ids)))))
-(defun bound-item-identifiers (construct identifiers)
+(defun bound-item-identifiers (construct identifiers start-revision)
"Bounds the passed item-identifier to the passed construct."
(declare (ReifiableConstructC construct))
(dolist (id identifiers)
@@ -569,11 +569,12 @@
(string= (uri ii) (uri id)))
(item-identifiers construct))
(d::delete-construct id)
- (setf (identified-construct id) construct)))
+ (add-item-identifier (identified-construct id :revision start-revision)
+ construct :revision start-revision)))
construct)
-(defun bound-subject-identifiers (top identifiers)
+(defun bound-subject-identifiers (top identifiers start-revision)
"Bounds the passed psis to the passed topic."
(declare (TopicC top))
(dolist (id identifiers)
@@ -582,11 +583,12 @@
(string= (uri psi) (uri id)))
(psis top))
(d::delete-construct id)
- (setf (identified-construct id) top)))
+ (add-psi (identified-construct id :revision start-revision)
+ top :revision start-revision)))
top)
-(defun bound-subject-locators (top locators)
+(defun bound-subject-locators (top locators start-revision)
"Bounds the passed locators to the passed topic."
(declare (TopicC top))
(dolist (id locators)
@@ -595,7 +597,8 @@
(string= (uri locator) (uri id)))
(locators top))
(d::delete-construct id)
- (setf (identified-construct id) top)))
+ (add-locator (identified-construct id :revision start-revision)
+ top :revision start-revision)))
top)
1
0
[isidorus-cvs] r240 - in branches/new-datamodel/src: model rest_interface xml/rdf xml/xtm
by Lukas Giessmann 21 Mar '10
by Lukas Giessmann 21 Mar '10
21 Mar '10
Author: lgiessmann
Date: Sun Mar 21 14:15:47 2010
New Revision: 240
Log:
new-datamodel: changed some code sections that caused problems with "rdf_exporter.lisp"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/rest_interface/read.lisp
branches/new-datamodel/src/xml/rdf/exporter.lisp
branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp
branches/new-datamodel/src/xml/xtm/importer_xtm2.0.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 21 14:15:47 2010
@@ -20,12 +20,17 @@
*instance-psi*)
(:export ;;classes
:TopicMapConstructC
+ :VersionedConstructC
+ :ReifiableConstructC
:TopicMapC
:AssociationC
:RoleC
+ :CharacteristicC
:OccurrenceC
:NameC
:VariantC
+ :PointerC
+ :IdentifierC
:PersistentIdC
:ItemIdentifierC
:SubjectLocatorC
@@ -124,6 +129,7 @@
:VersionedConstructC-p
:make-construct
:list-instanceOf
+ :list-super-types
:in-topicmap
:string-starts-with
:get-fragments
@@ -131,6 +137,7 @@
:get-all-revisions
:unique-id
:topic
+ :referenced-topics
:revision
:get-all-revisions-for-tm
:add-source-locator
@@ -1591,28 +1598,56 @@
:error-if-nil error-if-nil))
-
-(defgeneric list-instanceOf (topic &key tm)
+(defgeneric list-instanceOf (topic &key tm revision)
(:documentation "Generates a list of all topics that this topic is an
- instance of, optionally filtered by a topic map"))
-
-
-(defmethod list-instanceOf ((topic TopicC) &key (tm nil))
- (remove-if
- #'null
- (map 'list #'(lambda(x)
- (when (loop for psi in (psis (instance-of x))
- when (string= (uri psi) constants:*instance-psi*)
- return t)
- (loop for role in (roles (parent x))
- when (not (eq role x))
- return (player role))))
- (if tm
- (remove-if-not
- (lambda (role)
- (in-topicmap tm (parent role)))
- (player-in-roles topic))
- (player-in-roles topic)))))
+ instance of, optionally filtered by a topic map")
+ (:method ((topic TopicC) &key (tm nil) (revision 0))
+ (declare (type (or null TopicMapC) tm)
+ (integer revision))
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(x)
+ (when (loop for psi in (psis (instance-of x :revision revision)
+ :revision revision)
+ when (string= (uri psi) constants:*instance-psi*)
+ return t)
+ (loop for role in (roles (parent x :revision revision)
+ :revision revision)
+ when (not (eq role x))
+ return (player role :revision revision))))
+ (if tm
+ (remove-if-not
+ (lambda (role)
+ (in-topicmap tm (parent role :revision revision)))
+ (player-in-roles topic :revision revision))
+ (player-in-roles topic :revision revision))))))
+
+
+(defgeneric list-super-types (topic &key tm revision)
+ (:documentation "Generate a list of all topics that this topic is an
+ subclass of, optionally filtered by a topic map")
+ (:method ((topic TopicC) &key (tm nil) (revision 0))
+ (declare (type (or null TopicMapC) tm)
+ (integer revision))
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(x)
+ (when (loop for psi in (psis (instance-of x :revision revision)
+ :revision revision)
+ when (string= (uri psi) *subtype-psi*)
+ return t)
+ (loop for role in (roles (parent x :revision revision)
+ :revision revision)
+ when (not (eq role x))
+ return (player role :revision revision))))
+ (if tm
+ (remove-if-not
+ (lambda (role)
+ (in-topicmap tm (parent role :revision revision)))
+ (player-in-roles topic :revision revision))
+ (player-in-roles topic :revision revision))))))
;;; CharacteristicC
Modified: branches/new-datamodel/src/rest_interface/read.lisp
==============================================================================
--- branches/new-datamodel/src/rest_interface/read.lisp (original)
+++ branches/new-datamodel/src/rest_interface/read.lisp Sun Mar 21 14:15:47 2010
@@ -67,7 +67,7 @@
(source-locator (source-locator-prefix feed)))
;check if xtm-id has already been imported or if the entry is older
;than the snapshot feed. If so, don't do it again
- (unless (or (xtm-id-p xtm-id) (string> (atom:updated entry) (atom:updated imported-snapshot-entry)))
+ (unless (or (string> (atom:updated entry) (atom:updated imported-snapshot-entry)))
(when top
(mark-as-deleted top :source-locator source-locator :revision revision))
;(format t "Fragment feed: ~a~&" (link entry))
@@ -98,10 +98,11 @@
(find most-recent-update entry-list :key #'updated :test #'string=)))
(defun most-recent-imported-snapshot (all-snapshot-entries)
- (let
- ((all-imported-entries
- (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id)))
- (most-recent-entry all-imported-entries)))
+; (let
+; ((all-imported-entries
+; (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id)))
+; (most-recent-entry all-imported-entries))
+ (most-recent-entry all-snapshot-entries))
(defun import-snapshots-feed (snapshot-feed-url &key tm-id)
"checks if we already imported any of this feed's snapshots. If not,
Modified: branches/new-datamodel/src/xml/rdf/exporter.lisp
==============================================================================
--- branches/new-datamodel/src/xml/rdf/exporter.lisp (original)
+++ branches/new-datamodel/src/xml/rdf/exporter.lisp Sun Mar 21 14:15:47 2010
@@ -216,7 +216,7 @@
(declare (TopicC topic))
(if (psis topic)
(cxml:attribute "rdf:resource"
- (if (reified topic)
+ (if (reified-construct topic)
(let ((psi (get-reifier-psi topic)))
(if psi
(concatenate 'string "#" (get-reifier-uri topic))
@@ -592,7 +592,7 @@
(t-occs (occurrences construct))
(t-assocs (list-rdf-mapped-associations construct)))
(if psi
- (if (reified construct)
+ (if (reified-construct construct)
(let ((reifier-uri (get-reifier-uri construct)))
(if reifier-uri
(cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct)))
@@ -627,7 +627,7 @@
(ii (item-identifiers construct))
(sl (locators construct)))
(if psi
- (if (reified construct)
+ (if (reified-construct construct)
(let ((reifier-uri (get-reifier-uri construct)))
(if reifier-uri
(cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct)))
Modified: branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp Sun Mar 21 14:15:47 2010
@@ -83,7 +83,7 @@
((typep parent-construct 'NameC)
parent-construct)
((typep parent-construct 'VariantC)
- (name parent-construct))
+ (parent parent-construct))
(t
(error "from-variant-elem-xtm1.0: parent-construct is neither NameC nor VariantC"))))
(reifier-topic (get-reifier-topic-xtm1.0 variant-elem)))
@@ -394,7 +394,7 @@
(dolist (instanceOf-topicRef instanceOf-topicRefs)
(create-instanceof-association instanceOf-topicRef top start-revision :xtm-id xtm-id
:tm tm))
- (add-to-topicmap tm top))))
+ (add-to-tm tm top))))
(defun from-association-elem-xtm1.0 (assoc-elem start-revision &key tm (xtm-id *current-xtm*))
@@ -420,7 +420,7 @@
(unless type
(format t "from-association-elem-xtm1.0: type is missing -> http://www.topicmaps.org/xtm/1.0/core.xtm#association~%")
(setf type (get-item-by-id "association" :xtm-id "core.xtm")))
- (add-to-topicmap tm
+ (add-to-tm tm
(make-construct 'AssociationC
:start-revision start-revision
:instance-of type
Modified: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Sun Mar 21 14:15:47 2010
@@ -313,7 +313,7 @@
(create-instanceof-association topicref top start-revision
:tm tm
:xtm-id xtm-id))
- (add-to-topicmap tm top)
+ (add-to-tm tm top)
top))))
@@ -386,7 +386,7 @@
*xtm2.0-ns* "role")))
(reifier-topic (get-reifier-topic assoc-elem)))
(setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them
- (add-to-topicmap
+ (add-to-tm
tm
(make-construct 'AssociationC
:start-revision start-revision
@@ -415,7 +415,7 @@
(let
((topic-vector (get-topic-elems xtm-dom)))
(loop for top-elem across topic-vector do
- (add-to-topicmap
+ (add-to-tm
tm
(from-topic-elem-to-stub top-elem revision
:xtm-id xtm-id))))))
1
0
Author: lgiessmann
Date: Sun Mar 21 13:26:05 2010
New Revision: 239
Log:
new-datamodel: optimized "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 Sun Mar 21 13:26:05 2010
@@ -2534,17 +2534,19 @@
(let ((construct
(cond
((PointerC-p class-symbol)
- (make-pointer class-symbol (getf args :uri) args))
+ (apply #'make-pointer class-symbol args))
((CharacteristicC-p class-symbol)
- (make-characteristic class-symbol args))
+ (apply #'make-characteristic class-symbol args))
((TopicC-p class-symbol)
- (make-topic args))
+ (apply #'make-topic args))
((TopicMapC-p class-symbol)
- (make-tm args))
+ (apply #'make-tm args))
((RoleC-p class-symbol)
- (make-role args))
+ (apply #'make-role args))
((AssociationC-p class-symbol)
- (make-association args))))
+ (apply #'make-association args))
+ (t
+ (apply #'make-instance class-symbol args))))
(start-revision (getf args :start-revision)))
(when (typep construct 'TypableC)
(complete-typable construct (getf args :instance-of)
@@ -2552,6 +2554,10 @@
(when (typep construct 'ScopableC)
(complete-scopable construct (getf args :themes)
:start-revision start-revision))
+ (when (typep construct 'VersionedConstructC)
+ (unless start-revision
+ (error "From make-construct(): start-revision must be set"))
+ (add-to-version-history construct :start-revision start-revision))
(if (typep construct 'ReifiableConstructC)
(complete-reifiable construct (getf args :item-identtifiers)
(getf args :reifier) :start-revision start-revision)
@@ -2562,14 +2568,13 @@
"Returns an association object. If the association 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 ((instance-of (getf (first args) :instance-of))
- (start-revision (getf (first args) :start-revision))
- (themes (get (first args) :themes))
- (roles (get (first args) :roles))
- (err "From make-association(): "))
- (unless start-revision (error "~astart-revision must be set" err))
- (unless roles (error "~aroles must be set" err))
- (unless instance-of (error "~ainstance-of must be set" err))
+ (let ((instance-of (getf args :instance-of))
+ (start-revision (getf args :start-revision))
+ (themes (get args :themes))
+ (roles (get args :roles)))
+ (when (and (or roles instance-of themes)
+ (not start-revision))
+ (error "From make-association(): start-revision must be set"))
(let ((association
(let ((existing-association
(remove-if
@@ -2597,11 +2602,10 @@
(let ((parent (getf args :parent))
(instance-of (getf args :instance-of))
(player (getf args :player))
- (start-revision (getf args :start-revision))
- (err "From make-role(): "))
- (unless start-revision (error "~astart-revision must be set" err))
- (unless instance-of (error "~ainstance-of must be set" err))
- (unless player (error "~aplayer must be set" err))
+ (start-revision (getf args :start-revision)))
+ (when (and (or instance-of player parent)
+ (not start-revision))
+ (error "From make-role(): start-revision must be set"))
(let ((role
(let ((existing-role
(remove-if
@@ -2631,10 +2635,10 @@
(reifier (getf args :reifier))
(topics (getf args :topics))
(assocs (getf args :associations))
- (start-revision (getf args :start-revision))
- (err "From make-tm(): "))
- (unless item-identifiers (error "~aitem-identifiers must be set" err))
- (unless start-revision (error "~astart-revision must be set" err))
+ (start-revision (getf args :start-revision)))
+ (when (and (or item-identifiers reifier)
+ (not start-revision))
+ (error "From make-tm(): start-revision must be set"))
(let ((tm
(let ((existing-tms
(remove-if
@@ -2667,10 +2671,11 @@
(item-identifiers (getf args :item-identifiers))
(topic-identifiers (getf args :topic-identifiers))
(names (getf args :names))
- (occurrences (getf args :occurrences))
- (err "From make-topic(): "))
- (unless topic-identifiers (error "~atopic-identifiers must be set" err))
- (unless start-revision (error "~astart-revision must be set" err))
+ (occurrences (getf args :occurrences)))
+ (when (and (or psis locators item-identifiers topic-identifiers
+ names occurrences)
+ (not start-revision))
+ (error "From make-topic(): start-revision must be set"))
(let ((topic
(let ((existing-topics
(remove-if
@@ -2711,19 +2716,16 @@
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))
- (parent (getf (first args) :parent))
- (err "From make-characteristic(): "))
- (unless start-revision (error "~astart-revision must be set" err))
- (unless charvalue (error "~acharvalue must be set" err))
- (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol))
- (not instance-of))
- (error "~ainstance-of must be set" err))
+ (let ((charvalue (getf args :charvalue))
+ (start-revision (getf args :start-revision))
+ (datatype (getf args :datatype))
+ (instance-of (getf args :instance-of))
+ (themes (getf args :themes))
+ (variants (getf args :variants))
+ (parent (getf args :parent)))
+ (when (and (or instance-of themes variants parent)
+ (not start-revision))
+ (error "From make-characteristic(): start-revision must be set"))
(let ((characteristic
(let ((existing-characteristic
(when parent
@@ -2752,13 +2754,12 @@
"Returns a pointer object with the specified parameters.
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))
- (err "From make-pointer(): "))
+ (let ((uri (getf args :uri))
+ (xtm-id (getf args :xtm-id))
+ (start-revision (getf args :start-revision))
+ (identified-construct (getf args :identified-construct)))
(when (and identified-construct (not start-revision))
- (error "~astart-revision must be set" err))
+ (error "From make-pointer(): start-revision must be set"))
(let ((identifier
(let ((existing-pointer
(remove-if
1
0
[isidorus-cvs] r238 - in branches/new-datamodel/src: json model unit_tests xml/xtm
by Lukas Giessmann 21 Mar '10
by Lukas Giessmann 21 Mar '10
21 Mar '10
Author: lgiessmann
Date: Sun Mar 21 12:53:44 2010
New Revision: 238
Log:
new-datamodel: changed some sections that causes errors with other packages
Modified:
branches/new-datamodel/src/json/json_exporter.lisp
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/importer_test.lisp
branches/new-datamodel/src/unit_tests/json_test.lisp
branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp
branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp
Modified: branches/new-datamodel/src/json/json_exporter.lisp
==============================================================================
--- branches/new-datamodel/src/json/json_exporter.lisp (original)
+++ branches/new-datamodel/src/json/json_exporter.lisp Sun Mar 21 12:53:44 2010
@@ -46,7 +46,7 @@
(eql (elt value 0) #\#))
(get-item-by-id (subseq value 1) :xtm-id xtm-id))))
(if ref-topic
- (concatenate 'string "#" (topicid ref-topic))
+ (concatenate 'string "#" (topic-id ref-topic))
value))))
(json:encode-json-to-string inner-value))
",\"resourceData\":null")
@@ -147,7 +147,7 @@
(defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*))
"transforms an TopicC object to a json string"
(let ((id
- (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid instance))))
+ (concatenate 'string "\"id\":" (json:encode-json-to-string (topic-id instance))))
(itemIdentity
(concatenate 'string "\"itemIdentities\":"
(identifiers-to-json-string instance :what 'item-identifiers)))
@@ -188,7 +188,7 @@
subjectIdentifiers"
(when topic
(let ((id
- (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid topic))))
+ (concatenate 'string "\"id\":" (json:encode-json-to-string (topic-id topic))))
(itemIdentity
(concatenate 'string "\"itemIdentities\":"
(identifiers-to-json-string topic :what 'item-identifiers)))
@@ -310,7 +310,7 @@
*occurrences (jonly the resourceRef and resourceData elements)"
(declare (TopicC topic))
(let ((id
- (concatenate 'string "\"id\":\"" (topicid topic) "\""))
+ (concatenate 'string "\"id\":\"" (topic-id topic) "\""))
(itemIdentity
(concatenate 'string "\"itemIdentities\":"
(identifiers-to-json-string topic :what 'item-identifiers)))
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 21 12:53:44 2010
@@ -12,11 +12,14 @@
(:nicknames :d)
(:import-from :exceptions
duplicate-identifier-error)
+ (:import-from :exceptions
+ object-not-found-error)
(:import-from :constants
*xml-string*)
(:import-from :constants
*instance-psi*)
(:export ;;classes
+ :TopicMapConstructC
:TopicMapC
:AssociationC
:RoleC
@@ -28,6 +31,7 @@
:SubjectLocatorC
:TopicIdentificationC
:TopicC
+ :FragmentC
;;methods, functions and macros
:xtm-id
@@ -40,6 +44,7 @@
:add-reifier
:delete-reifier
:find-item-by-revision
+ :find-most-recent-revision
:themes
:add-theme
:delete-theme
@@ -68,6 +73,7 @@
:topic-identifiers
:add-topic-identifier
:delete-topic-identifier
+ :topic-id
:locators
:add-locator
:delete-locator
@@ -92,6 +98,7 @@
:get-item-by-psi
:get-item-by-item-identifier
:get-item-by-locator
+ :get-item-by-content
:string-integer-p
:with-revision
:get-latest-fragment-of-topic
@@ -118,7 +125,18 @@
:make-construct
:list-instanceOf
:in-topicmap
- :string-start-with
+ :string-starts-with
+ :get-fragments
+ :get-fragment
+ :get-all-revisions
+ :unique-id
+ :topic
+ :revision
+ :get-all-revisions-for-tm
+ :add-source-locator
+ :changed-p
+ :check-for-duplicate-identifiers
+ :find-item-by-content
;;globals
:*TM-REVISION*
@@ -596,6 +614,19 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun get-item-by-content (content &key (revision *TM-REVISION*))
+ "Finds characteristics by their (atomic) content."
+ (flet
+ ((get-existing-instances (class-symbol)
+ (delete-if-not
+ #'(lambda (constr)
+ (find-item-by-revision constr revision))
+ (elephant:get-instances-by-value class-symbol 'charvalue content))))
+ (nconc (get-existing-instances 'OccurenceC)
+ (get-existing-instances 'NameC)
+ (get-existing-instances 'VariantC))))
+
+
(defmacro with-revision (revision &rest body)
`(let
((*TM-REVISION* ,revision))
@@ -698,6 +729,11 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric check-for-duplicate-identifiers (construct)
+ (:documentation "Check for possibly duplicate identifiers and signal an
+ duplicate-identifier-error is such duplicates are found"))
+
+
(defgeneric get-all-identifiers-of-construct (construct &key revision)
(:documentation "Get all identifiers that a given construct has"))
@@ -855,6 +891,12 @@
;;; TopicMapconstructC
+(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC))
+ (declare (ignore construct))
+ ;do nothing
+ )
+
+
(defmethod get-all-characteristics ((parent-construct TopicC)
(characteristic-symbol symbol))
(cond ((OccurrenceC-p characteristic-symbol)
@@ -1109,6 +1151,30 @@
t))
+(defgeneric topic-id (construct &optional revision xtm-id)
+ (:documentation "Returns the primary id of this item
+ (= essentially the OID). If xtm-id is explicitly given,
+ returns one of the topic-ids in that TM
+ (which must then exist).")
+ (:method ((construct TopicC) &optional (xtm-id nil) (revision 0))
+ (declare (type (or null string) xtm-id) (integer revision))
+ (if xtm-id
+ (let ((possible-identifiers
+ (remove-if-not
+ #'(lambda(top-id)
+ (string= (xtm-id top-id) xtm-id))
+ (topic-identifiers construct :revision revision))))
+ (unless possible-identifiers
+ (error (make-condition
+ 'object-not-found-error
+ :message
+ (format nil "Could not find an object ~a in xtm-id ~a"
+ construct xtm-id))))
+ (uri (first possible-identifiers)))
+ (concatenate 'string "t" (write-to-string (internal-id construct))))))
+
+
+
(defgeneric topic-identifiers (construct &key revision)
(:documentation "Returns the TopicIdentificationC-objects that correspond
with the passed construct and the passed version.")
@@ -2014,6 +2080,22 @@
;;; ReifiableConstructC
+(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC))
+ (dolist (id (get-all-identifiers-of-construct construct))
+ (when (>
+ (length
+ (union
+ (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id))
+ (union
+ (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
+ (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
+ 1)
+ (error
+ (make-condition 'duplicate-identifier-error
+ :message (format nil "Duplicate Identifier ~a has been found" (uri id))
+ :uri (uri id))))))
+
+
(defgeneric ReifiableConstructC-p (class-symbol)
(:documentation "Returns t if the passed symbol is equal to ReifiableConstructC
or one of its subtypes.")
Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/importer_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/importer_test.lisp Sun Mar 21 12:53:44 2010
@@ -98,7 +98,7 @@
(is (= 1 (length t101-themes)))
(is
(string=
- (topicid (first t101-themes) *TEST-TM*)
+ (topic-id (first t101-themes) *TEST-TM*)
"t50a"))))))
(test test-from-name-elem
@@ -129,7 +129,7 @@
"http://psi.egovpt.org/types/long-name"))
(is (themes t101-longname))
(is (string=
- (topicid (first (themes t101-longname)) *TEST-TM*)
+ (topic-id (first (themes t101-longname)) *TEST-TM*)
"t50a"))
(is (eq t1-name t1-name-copy)) ;must be merged
))))
@@ -233,10 +233,10 @@
((12th-role
(from-role-elem (nth 11 role-elems) revision)))
(is (string= "t101"
- (topicid
+ (topic-id
(getf 12th-role :player) *TEST-TM*)))
(is (string= "t62"
- (topicid
+ (topic-id
(getf 12th-role :instance-of) *TEST-TM*)))))))
(test test-from-association-elem
@@ -261,12 +261,12 @@
(is (= 2 (length (roles last-assoc))))
(is (= 1 (length (item-identifiers last-assoc))))
(is (string= "t300"
- (topicid (player (first (roles 6th-assoc))) *TEST-TM*)))
+ (topic-id (player (first (roles 6th-assoc))) *TEST-TM*)))
(is (string= "t63"
- (topicid (instance-of (first (roles 6th-assoc)))
+ (topic-id (instance-of (first (roles 6th-assoc)))
*TEST-TM*)))
(is (string= "t301"
- (topicid (player (first (roles last-assoc)))
+ (topic-id (player (first (roles last-assoc)))
*TEST-TM*))))
;(untrace datamodel:item-identifiers datamodel::filter-slot-value-by-revision))
)
@@ -302,8 +302,8 @@
(is
(typep io-assoc
'AssociationC))
- (is (string= (topicid topic)
- (topicid (player (second (roles io-assoc))))))))))
+ (is (string= (topic-id topic)
+ (topic-id (player (second (roles io-assoc))))))))))
(let*
((t101-top (get-item-by-id "t101"))
@@ -329,9 +329,9 @@
(is (= 1 (length role-101)))
;(is (= 1 (length (d::versions role-101))))
(is (string= "t3a"
- (topicid (player (first (roles (parent (first role-101))))) *TEST-TM*)))
+ (topic-id (player (first (roles (parent (first role-101))))) *TEST-TM*)))
(is (string= "type-instance"
- (topicid (instance-of
+ (topic-id (instance-of
(parent (first role-101))) "core.xtm")))
))))
Modified: branches/new-datamodel/src/unit_tests/json_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/json_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/json_test.lisp Sun Mar 21 12:53:44 2010
@@ -70,27 +70,27 @@
(let ((t50a (get-item-by-id "t50a")))
(let ((t50a-string (to-json-string t50a))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" )))
+ (concatenate 'string "{\"id\":\"" (topic-id t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" )))
(is (string= t50a-string json-string)))
(let ((t8 (get-item-by-id "t8")))
(let ((t8-string (to-json-string t8))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}")))
(is (string= t8-string json-string))))
(let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm")))
(let ((t-topic-string (to-json-string t-topic))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}")))
(is (string= t-topic-string json-string))))
(let ((t301 (get-item-by-id "t301")))
(let ((t301-string (to-json-string t301))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}")))
(is (string= t301-string json-string))))
(let ((t100 (get-item-by-id "t100")))
(let ((t100-string (to-json-string t100))
(json-string
- (concatenate 'string "{\"id\":\"" (topicid t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}")))
+ (concatenate 'string "{\"id\":\"" (topic-id t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}")))
(is (string= t100-string json-string))))))))
@@ -156,9 +156,9 @@
(frag-topic
(create-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic")))
(let ((frag-t100-string
- (concatenate 'string "{\"topic\":{\"id\":\"" (d:topicid (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}"))
+ (concatenate 'string "{\"topic\":{\"id\":\"" (d:topic-id (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}"))
(frag-topic-string
- (concatenate 'string "{\"topic\":{\"id\":\"" (topicid (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}")))
+ (concatenate 'string "{\"topic\":{\"id\":\"" (topic-id (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}")))
(is (string= frag-t100-string (to-json-string frag-t100)))
(is (string= frag-topic-string (to-json-string frag-topic))))))))
@@ -181,7 +181,7 @@
(json:decode-json-from-string json-fragment))))
(let ((topic (getf fragment-list :topic)))
(is (string= (getf topic :ID)
- (d:topicid
+ (d:topic-id
(d:identified-construct (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri
"http://psi.egovpt.org/standard/Topic+Maps+2002")))))
(is-false (getf topic :itemIdentities))
@@ -294,7 +294,7 @@
"http://psi.egovpt.org/types/standardHasStatus"))
(is-false (getf occurrence-1 :scopes))
(is (string= (getf occurrence-1 :resourceRef)
- (concatenate 'string "#" (d:topicid ref-topic))))
+ (concatenate 'string "#" (d:topic-id ref-topic))))
(is-false (getf occurrence-1 :resourceData))
(is-false (getf occurrence-2 :itemIdentities))
(is (= (length (getf occurrence-2 :type)) 1))
@@ -357,7 +357,7 @@
subjectIdentifier))))
(is-true topic)
(is-false subjectLocators)
- (is (string= (d:topicid topic) id))
+ (is (string= (d:topic-id topic) id))
(cond
((string= subjectIdentifier "http://psi.egovpt.org/types/semanticstandard")
(is (= (length itemIdentities) 1))
Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Sun Mar 21 12:53:44 2010
@@ -31,7 +31,7 @@
(defun to-topicRef-elem-xtm1.0 (topic)
(declare (TopicC topic))
(cxml:with-element "t:topicRef"
- (cxml:attribute "xlink:href" (format nil "#~a" (topicid topic)))))
+ (cxml:attribute "xlink:href" (format nil "#~a" (topic-id topic)))))
(defun to-reifier-elem-xtm1.0 (reifiable-construct)
@@ -67,7 +67,7 @@
(let ((ref-topic (when (and (> (length characteristic-value) 0)
(eql (elt characteristic-value 0) #\#))
(get-item-by-id (subseq characteristic-value 1)))))
- (if ref-topic (concatenate 'string "#" (topicid ref-topic)) characteristic-value))))
+ (if ref-topic (concatenate 'string "#" (topic-id ref-topic)) characteristic-value))))
(cxml:with-element "t:resourceData"
(cxml:text characteristic-value)))))
@@ -83,7 +83,7 @@
(declare (TopicC topic))
(cxml:with-element "t:instanceOf"
(cxml:with-element "t:topicRef"
- (cxml:attribute "xlink:href" (concatenate 'string "#" (topicid topic))))))
+ (cxml:attribute "xlink:href" (concatenate 'string "#" (topic-id topic))))))
(defun to-subjectIdentity-elem-xtm1.0 (psis locator)
@@ -145,7 +145,7 @@
"topic = element topic { id, instanceOf*, subjectIdentity,
(baseName | occurrence)* }"
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
+ (cxml:attribute "id" (topic-id topic))
(when (list-instanceOf topic :tm *export-tm*)
(map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic :tm *export-tm*)))
(when (or (psis topic) (locators topic))
@@ -188,7 +188,7 @@
with a topicid, psis and subjectLocators"
(declare (TopicC topic))
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
+ (cxml:attribute "id" (topic-id topic))
(to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic)))))
Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Sun Mar 21 12:53:44 2010
@@ -25,7 +25,7 @@
;;TODO: this is pretty much of a hack that works only for local
;;references
(cxml:attribute "href"
- (format nil "#~a" (topicid topic)))))
+ (format nil "#~a" (topic-id topic)))))
(defgeneric to-elem (instance)
(:documentation "converts the Topic Maps construct instance to an XTM 2.0 element"))
@@ -74,7 +74,7 @@
(get-item-by-id (subseq characteristic-value 1)))))
(cxml:attribute "href"
(if ref-topic
- (concatenate 'string "#" (topicid ref-topic))
+ (concatenate 'string "#" (topic-id ref-topic))
characteristic-value))))
(cxml:with-element "t:resourceData"
(when (slot-boundp characteristic 'datatype)
@@ -124,7 +124,7 @@
(itemIdentity | subjectLocator | subjectIdentifier)*,
instanceOf?, (name | occurrence)* }"
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
+ (cxml:attribute "id" (topic-id topic))
(map 'list #'to-elem (item-identifiers topic))
(map 'list #'to-elem (locators topic))
(map 'list #'to-elem (psis topic))
@@ -132,7 +132,7 @@
(cxml:with-element "t:instanceOf"
(loop for item in (list-instanceOf topic :tm *export-tm*)
do (cxml:with-element "t:topicRef"
- (cxml:attribute "href" (concatenate 'string "#" (topicid item)))))))
+ (cxml:attribute "href" (concatenate 'string "#" (topic-id item)))))))
(map 'list #'to-elem (names topic))
(map 'list #'to-elem (occurrences topic))))
@@ -142,7 +142,7 @@
with a topicid, a subjectLocator and an itemIdentity element"
(declare (TopicC topic))
(cxml:with-element "t:topic"
- (cxml:attribute "id" (topicid topic))
+ (cxml:attribute "id" (topic-id topic))
(map 'list #'to-elem (psis topic))
(map 'list #'to-elem (item-identifiers topic))
(map 'list #'to-elem (locators topic))))
1
0
Author: lgiessmann
Date: Sun Mar 21 05:14:10 2010
New Revision: 237
Log:
new-datamodel: fixed some sections that cauesd errors with the "changes.lisp"
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 21 05:14:10 2010
@@ -14,6 +14,8 @@
duplicate-identifier-error)
(:import-from :constants
*xml-string*)
+ (:import-from :constants
+ *instance-psi*)
(:export ;;classes
:TopicMapC
:AssociationC
@@ -114,6 +116,9 @@
:TopicMapConstructC-p
:VersionedConstructC-p
:make-construct
+ :list-instanceOf
+ :in-topicmap
+ :string-start-with
;;globals
:*TM-REVISION*
@@ -315,9 +320,11 @@
(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
((topics :associate (TopicC in-topicmaps)
:many-to-many t
+ :accessor topics
:documentation "List of topics that explicitly belong to this TM.")
(associations :associate (AssociationC in-topicmaps)
:many-to-many t
+ :accessor associations
:documentation "List of associations that belong to this TM."))
(:documentation "Represnets a topic map."))
@@ -673,7 +680,28 @@
(merge-constructs merged-construct construct-to-be-merged)))))
+(defgeneric internal-id (construct)
+ (:documentation "Returns the internal id that uniquely identifies a
+ construct (currently simply its OID)."))
+
+
+(defmethod internal-id ((construct TopicMapConstructC))
+ (slot-value construct (find-symbol "OID" 'elephant)))
+
+
+(defun string-starts-with (str prefix)
+ "Checks if string str starts with a given prefix."
+ (declare (string str prefix))
+ (string= str prefix :start1 0 :end1
+ (min (length prefix)
+ (length str))))
+
+
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric get-all-identifiers-of-construct (construct &key revision)
+ (:documentation "Get all identifiers that a given construct has"))
+
+
(defgeneric get-all-characteristics (parent-construct characteristic-symbol)
(:documentation "Returns all characterisitcs of the passed type the parent
construct was ever associated with."))
@@ -700,7 +728,7 @@
(defgeneric in-topicmaps (construct &key revision)
- (:documentation "Returns all TopicMapS-obejcts where the constrict is
+ (:documentation "Returns all TopicMaps-obejcts where the construct is
contained in."))
@@ -1250,6 +1278,14 @@
construct)))
+(defmethod get-all-identifiers-of-construct ((construct TopicC)
+ &key (revision 0))
+ (declare (integer revision))
+ (append (psis construct :revision revision)
+ (locators construct :revision revision)
+ (item-identifiers construct :revision revision)))
+
+
(defgeneric names (construct &key revision)
(:documentation "Returns the NameC-objects that correspond
with the passed construct and the passed version.")
@@ -1489,6 +1525,30 @@
:error-if-nil error-if-nil))
+
+(defgeneric list-instanceOf (topic &key tm)
+ (:documentation "Generates a list of all topics that this topic is an
+ instance of, optionally filtered by a topic map"))
+
+
+(defmethod list-instanceOf ((topic TopicC) &key (tm nil))
+ (remove-if
+ #'null
+ (map 'list #'(lambda(x)
+ (when (loop for psi in (psis (instance-of x))
+ when (string= (uri psi) constants:*instance-psi*)
+ return t)
+ (loop for role in (roles (parent x))
+ when (not (eq role x))
+ return (player role))))
+ (if tm
+ (remove-if-not
+ (lambda (role)
+ (in-topicmap tm (parent role)))
+ (player-in-roles topic))
+ (player-in-roles topic)))))
+
+
;;; CharacteristicC
(defgeneric CharacteristicC-p (class-symbol)
(:documentation "Returns t if the passed symbol is equal to CharacteristicC
@@ -2135,6 +2195,13 @@
(mark-as-deleted assoc-to-delete :revision revision))
construct)))
+
+(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC)
+ &key (revision 0))
+ (declare (integer revision))
+ (item-identifiers construct :revision revision))
+
+
;;; TypableC
(defgeneric TypableC-p (class-symbol)
(:documentation "Returns t if the passed class is equal to TypableC or
@@ -2343,20 +2410,6 @@
(remove-association construct 'associations assoc)))
-(defgeneric topics (construct &key revision)
- (:documentation "Returns all TopicC-objects that are contained in the tm.")
- (:method ((construct TopicMapC) &key (revision 0))
- (filter-slot-value-by-revision construct 'topics
- :start-revision revision)))
-
-
-(defgeneric associations (construct &key revision)
- (:documentation "Returns all AssociationC-objects that are contained in the tm.")
- (:method ((construct TopicMapC) &key (revision 0))
- (filter-slot-value-by-revision construct 'associations
- :start-revision revision)))
-
-
(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
(add-association construct 'topics construct-to-add))
@@ -2374,6 +2427,21 @@
(remove-association construct 'associations construct-to-delete))
+(defgeneric in-topicmap (tm construct &key revision)
+ (:documentation "Is a given construct (topic or assiciation) in this
+ topic map?"))
+
+
+(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0))
+ (when (find-item-by-revision top revision)
+ (find (internal-id top) (topics tm) :test #'= :key #'internal-id)))
+
+
+(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
+ (when (find-item-by-revision ass revision)
+ (find (internal-id ass) (associations tm) :test #'= :key #'internal-id)))
+
+
;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-construct (class-symbol &rest args)
"Creates a new topic map construct if necessary or
@@ -2386,7 +2454,7 @@
((PointerC-p class-symbol)
(make-pointer class-symbol (getf args :uri) args))
((CharacteristicC-p class-symbol)
- (make-characteristic class-symbol (getf args :charvalue) args))
+ (make-characteristic class-symbol args))
((TopicC-p class-symbol)
(make-topic args))
((TopicMapC-p class-symbol)
1
0
Author: lgiessmann
Date: Sun Mar 21 04:36:20 2010
New Revision: 236
Log:
new-datamodel: optimized "make-construct"
Modified:
branches/new-datamodel/src/model/changes.lisp
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/changes.lisp
==============================================================================
--- branches/new-datamodel/src/model/changes.lisp (original)
+++ branches/new-datamodel/src/model/changes.lisp Sun Mar 21 04:36:20 2010
@@ -1,4 +1,4 @@
-#;;+-----------------------------------------------------------------------------
+;;+-----------------------------------------------------------------------------
;;+ Isidorus
;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
;;+
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 21 04:36:20 2010
@@ -1645,7 +1645,7 @@
(eql class-symbol 'NameC)))
-(defgeneric initialize-name (construct variants &key start-revision)
+(defgeneric complete-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*))
@@ -1966,7 +1966,7 @@
(CharacteristicC-p class-symbol))))
-(defgeneric initialize-reifiable (construct item-identifiers reifier
+(defgeneric complete-reifiable (construct item-identifiers reifier
&key start-revision)
(:documentation "Adds all item-identifiers and the reifier to the passed
construct.")
@@ -2146,7 +2146,7 @@
(CharacteristicC-p class-symbol))))
-(defgeneric initialize-typable (construct instance-of &key start-revision)
+(defgeneric complete-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*))
@@ -2176,7 +2176,7 @@
(CharacteristicC-p class-symbol))))
-(defgeneric initialize-scopable (construct themes &key start-revision)
+(defgeneric complete-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*))
@@ -2394,17 +2394,25 @@
((RoleC-p class-symbol)
(make-role args))
((AssociationC-p class-symbol)
- (make-association args)))))
- construct))
+ (make-association args))))
+ (start-revision (getf args :start-revision)))
+ (when (typep construct 'TypableC)
+ (complete-typable construct (getf args :instance-of)
+ :start-revision start-revision))
+ (when (typep construct 'ScopableC)
+ (complete-scopable construct (getf args :themes)
+ :start-revision start-revision))
+ (if (typep construct 'ReifiableConstructC)
+ (complete-reifiable construct (getf args :item-identtifiers)
+ (getf args :reifier) :start-revision start-revision)
+ construct)))
(defun make-association (args)
"Returns an association object. If the association 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))
- (instance-of (getf (first args) :instance-of))
+ (let ((instance-of (getf (first args) :instance-of))
(start-revision (getf (first args) :start-revision))
(themes (get (first args) :themes))
(roles (get (first args) :roles))
@@ -2427,23 +2435,16 @@
(if existing-association
existing-association
(make-instance 'AssociationC)))))
- (initialize-typable association instance-of :start-revision
- start-revision)
(dolist (role roles)
(add-role association role :revision start-revision))
- (dolist (theme themes)
- (add-theme association theme :revision start-revision))
- (initialize-reifiable association item-identifiers reifier
- :start-revision start-revision))))
+ association)))
(defun make-role (args)
"Returns a role object. If the role 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 args :item-identifiers))
- (reifier (getf args :reifier))
- (parent (getf args :parent))
+ (let ((parent (getf args :parent))
(instance-of (getf args :instance-of))
(player (getf args :player))
(start-revision (getf args :start-revision))
@@ -2467,11 +2468,9 @@
(make-instance 'RoleC)))))
(when player
(add-player role player :revision start-revision))
- (initialize-typable role instance-of :start-revision start-revision)
(when parent
(add-parent role parent :revision start-revision))
- (initialize-reifiable role item-identifiers reifier
- :start-revision start-revision))))
+ role)))
(defun make-tm (args)
@@ -2505,8 +2504,7 @@
(make-instance 'TopicMapC))))))
(dolist (top-or-assoc (union topics assocs))
(add-to-tm tm top-or-assoc))
- (initialize-reifiable tm item-identifiers reifier
- :start-revision start-revision))))
+ tm)))
(defun make-topic (&rest args)
@@ -2543,9 +2541,6 @@
(t
(make-instance 'TopicC))))))
(let ((merged-topic topic))
- (setf merged-topic
- (initialize-reifiable topic item-identifiers nil
- :start-revision start-revision))
(dolist (psi psis)
(setf merged-topic (add-psi merged-topic psi
:revision start-revision)))
@@ -2572,9 +2567,7 @@
(instance-of (getf (first args) :instance-of))
(themes (getf (first args) :themes))
(variants (getf (first args) :variants))
- (reifier (getf (first args) :reifier))
(parent (getf (first args) :parent))
- (item-identifiers (getf (first args) :item-identifiers))
(err "From make-characteristic(): "))
(unless start-revision (error "~astart-revision must be set" err))
(unless charvalue (error "~acharvalue must be set" err))
@@ -2599,14 +2592,10 @@
existing-characteristic
(make-instance class-symbol :charvalue charvalue
:datatype datatype)))))
- (initialize-scopable characteristic themes :start-revision start-revision)
- (initialize-typable characteristic instance-of
- :start-revision start-revision)
- (initialize-name characteristic variants :start-revision start-revision)
+ (complete-name characteristic variants :start-revision start-revision)
(when parent
(add-parent characteristic parent :revision start-revision))
- (initialize-reifiable characteristic item-identifiers
- reifier :start-revision start-revision))))
+ characteristic)))
(defun make-pointer (class-symbol &rest args)
1
0
20 Mar '10
Author: lgiessmann
Date: Sat Mar 20 18:00:40 2010
New Revision: 235
Log:
new-datamodel: finalized "make-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 Sat Mar 20 18:00:40 2010
@@ -663,6 +663,16 @@
(condition () nil)))
+(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)))))
+
+
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric get-all-characteristics (parent-construct characteristic-symbol)
(:documentation "Returns all characterisitcs of the passed type the parent
@@ -2378,29 +2388,104 @@
((CharacteristicC-p class-symbol)
(make-characteristic class-symbol (getf args :charvalue) args))
((TopicC-p class-symbol)
- (make-topic args)))))
+ (make-topic args))
+ ((TopicMapC-p class-symbol)
+ (make-tm args))
+ ((RoleC-p class-symbol)
+ (make-role args))
+ ((AssociationC-p class-symbol)
+ (make-association args)))))
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-association (args)
+ "Returns an association object. If the association 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))
+ (instance-of (getf (first args) :instance-of))
+ (start-revision (getf (first args) :start-revision))
+ (themes (get (first args) :themes))
+ (roles (get (first args) :roles))
+ (err "From make-association(): "))
+ (unless start-revision (error "~astart-revision must be set" err))
+ (unless roles (error "~aroles must be set" err))
+ (unless instance-of (error "~ainstance-of must be set" err))
+ (let ((association
+ (let ((existing-association
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-association)
+ (when (equivalent-construct
+ existing-association
+ :start-revision start-revision
+ :roles roles :themes themes
+ :instance-of instance-of)
+ existing-association))
+ (elephant:get-instances-by-class 'AssociationC)))))
+ (if existing-association
+ existing-association
+ (make-instance 'AssociationC)))))
+ (initialize-typable association instance-of :start-revision
+ start-revision)
+ (dolist (role roles)
+ (add-role association role :revision start-revision))
+ (dolist (theme themes)
+ (add-theme association theme :revision start-revision))
+ (initialize-reifiable association item-identifiers reifier
+ :start-revision start-revision))))
-(defun make-tm (&rest args)
+(defun make-role (args)
+ "Returns a role object. If the role 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 args :item-identifiers))
+ (reifier (getf args :reifier))
+ (parent (getf args :parent))
+ (instance-of (getf args :instance-of))
+ (player (getf args :player))
+ (start-revision (getf args :start-revision))
+ (err "From make-role(): "))
+ (unless start-revision (error "~astart-revision must be set" err))
+ (unless instance-of (error "~ainstance-of must be set" err))
+ (unless player (error "~aplayer must be set" err))
+ (let ((role
+ (let ((existing-role
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-role)
+ (when (equivalent-construct
+ existing-role
+ :player player
+ :instance-of instance-of)
+ existing-role))
+ (slot-p parent 'roles)))))
+ (if existing-role
+ existing-role
+ (make-instance 'RoleC)))))
+ (when player
+ (add-player role player :revision start-revision))
+ (initialize-typable role instance-of :start-revision start-revision)
+ (when parent
+ (add-parent role parent :revision start-revision))
+ (initialize-reifiable role item-identifiers reifier
+ :start-revision start-revision))))
+
+
+(defun make-tm (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 ((item-identifiers (getf args :item-identifiers))
+ (reifier (getf args :reifier))
+ (topics (getf args :topics))
+ (assocs (getf args :associations))
+ (start-revision (getf args :start-revision))
+ (err "From make-tm(): "))
+ (unless item-identifiers (error "~aitem-identifiers must be set" err))
+ (unless start-revision (error "~astart-revision must be set" err))
(let ((tm
(let ((existing-tms
(remove-if
@@ -2420,21 +2505,24 @@
(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)))
+ (initialize-reifiable tm item-identifiers reifier
+ :start-revision start-revision))))
(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 ((start-revision (getf args :start-revision))
+ (psis (getf args :psis))
+ (locators (getf args :locators))
+ (item-identifiers (getf args :item-identifiers))
+ (topic-identifiers (getf args :topic-identifiers))
+ (names (getf args :names))
+ (occurrences (getf args :occurrences))
+ (err "From make-topic(): "))
+ (unless topic-identifiers (error "~atopic-identifiers must be set" err))
+ (unless start-revision (error "~astart-revision must be set" err))
(let ((topic
(let ((existing-topics
(remove-if
@@ -2454,9 +2542,10 @@
(first existing-topics))
(t
(make-instance 'TopicC))))))
- (initialize-reifiable topic item-identifiers nil
- :start-revision start-revision)
(let ((merged-topic topic))
+ (setf merged-topic
+ (initialize-reifiable topic item-identifiers nil
+ :start-revision start-revision))
(dolist (psi psis)
(setf merged-topic (add-psi merged-topic psi
:revision start-revision)))
@@ -2464,10 +2553,10 @@
(setf merged-topic (add-locator merged-topic locator
:revision start-revision)))
(dolist (name names)
- (setf merged-topic (add-name topic name :revision start-revision)))
+ (setf merged-topic (add-name merged-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))))
@@ -2484,11 +2573,17 @@
(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)))
+ (parent (getf (first args) :parent))
+ (item-identifiers (getf (first args) :item-identifiers))
+ (err "From make-characteristic(): "))
+ (unless start-revision (error "~astart-revision must be set" err))
+ (unless charvalue (error "~acharvalue must be set" err))
+ (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol))
+ (not instance-of))
+ (error "~ainstance-of must be set" err))
(let ((characteristic
(let ((existing-characteristic
- (when parent-construct
+ (when parent
(remove-if
#'null
(map 'list #'(lambda(existing-characteristic)
@@ -2499,26 +2594,19 @@
:charvalue charvalue :themes themes
:instance-of instance-of)
existing-characteristic))
- (get-all-characteristics parent-construct
- class-symbol))))))
+ (get-all-characteristics parent 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))))
+ (initialize-scopable characteristic themes :start-revision start-revision)
+ (initialize-typable characteristic instance-of
+ :start-revision start-revision)
+ (initialize-name characteristic variants :start-revision start-revision)
+ (when parent
+ (add-parent characteristic parent :revision start-revision))
+ (initialize-reifiable characteristic item-identifiers
+ reifier :start-revision start-revision))))
(defun make-pointer (class-symbol &rest args)
@@ -2528,7 +2616,10 @@
(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)))
+ (identified-construct (getf (first args) :identified-construct))
+ (err "From make-pointer(): "))
+ (when (and identified-construct (not start-revision))
+ (error "~astart-revision must be set" err))
(let ((identifier
(let ((existing-pointer
(remove-if
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 18:00:40 2010
@@ -61,11 +61,8 @@
:test-class-p))
-;;TODO: test merge-constructs when merging was caused by an item-dentifier,
-;; a psi, a subject-locator, a topic-id
-;;TODO: test merge-constructs when merging was caused by reifiers
-;; (occurrences, names, variants, associations, roles)
-;;TODO: test ReifiableConstructC --> reifier has to be merged
+;;TODO: test make-construct
+;;TODO: test merge-constructs
1
0