isidorus-cvs
Threads by month
- ----- 2025 -----
- July
- June
- May
- April
- March
- 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
- 1037 discussions
[isidorus-cvs] r204 - branches/new-datamodel/src/model trunk/src/model
by Lukas Giessmann 24 Feb '10
by Lukas Giessmann 24 Feb '10
24 Feb '10
Author: lgiessmann
Date: Wed Feb 24 11:04:46 2010
New Revision: 204
Log:
new-datamodel: added the functions get-item-by-item-identifier, get-item-by-psi, get-item-by-locator; fixed a bug in the function get-item-by-id -> ticket #65
Modified:
branches/new-datamodel/src/model/datamodel.lisp
trunk/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 Wed Feb 24 11:04:46 2010
@@ -10,6 +10,8 @@
(defpackage :datamodel
(:use :cl :elephant :constants)
(:nicknames :d)
+ (:import-from :exceptions
+ duplicate-identifier-error)
(:export ;;classes
:TopicMapC
:AssociationC
@@ -79,6 +81,11 @@
:in-topicmaps
:delete-construct
:get-revision
+ :get-item-by-id
+ :get-item-by-psi
+ :get-item-by-item-identnfier
+ :get-item-by-locator
+ :string-integer-p
;;globals
:*TM-REVISION*
@@ -87,6 +94,12 @@
(in-package :datamodel)
+;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1)))))
+;; in get-item-by-id
+;;TODO: implement get-item-by-id(TopicC) + unit-tests
+;;TODO: implement get-item-by-psi(TopicC) + unit-tests
+;;TODO: implement get-item-by-locator(TopicC) + unit-tests
+;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests
;;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
@@ -609,6 +622,13 @@
(get-universal-time))
+(defun string-integer-p (integer-as-string)
+ "Returns t if the passed string can be parsed to an integer."
+ (handler-case (when (parse-integer integer-as-string)
+ t)
+ (condition () nil)))
+
+
;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; VersionInfocC
(defmethod delete-construct :before ((version-info VersionInfoC))
@@ -1061,6 +1081,96 @@
(filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
+(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) (revision 0) (error-if-nil nil))
+ "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM
+ is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
+ applicable in the correct revision. If revison is provided, then the code checks
+ if the topic already existed in this revision and returns nil otherwise.
+ If no item meeting the constraints was found, then the return value is either
+ NIL or an error is thrown, depending on error-if-nil."
+ (declare (string topic-id) (integer revision) (string xtm-id))
+ (let ((result
+ (if xtm-id
+ (let ((possible-top-ids
+ (delete-if-not
+ #'(lambda(top-id)
+ (and (string= (xtm-id top-id) xtm-id)
+ (string= (uri top-id) topic-id)))
+ ;fixes a bug in get-instances-by-value that does a
+ ;case-insensitive comparision
+ (elephant:get-instances-by-value
+ 'TopicIdentificationC
+ 'uri
+ topic-id))))
+ (when (and possible-top-ids
+ (identified-construct (first possible-top-ids) :revision revision))
+ (unless (= (length possible-top-ids) 1)
+ (error (make-condition 'duplicate-identifier-error
+ :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
+ possible-top-ids topic-id xtm-id)
+ :uri topic-id)))
+ (identified-construct (first possible-top-ids)
+ :revision revision)
+ ;no revision need not to be chaecked, since the revision
+ ;is implicitely checked by the function identified-construct
+ ))
+ (when (and (> (length topic-id) 0)
+ (eql (elt 0 topic-id) #\t)
+ (string-integer-p (subseq topic-id 1)))
+ (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1))))))
+ (if (and error-if-nil (not result))
+ (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)
+ result)))
+
+
+(defun get-item-by-identifier (uri &key (revision 0)
+ (identifier-type-symbol 'PersistentIdC)
+ (error-if-nil nil))
+ "Returns the construct that is bound to the given identifier-uri."
+ (declare (string uri) (integer revision) (symbol identifier-type-symbol))
+ (let ((result
+ (let ((possible-ids
+ (delete-if-not
+ #'(lambda(id)
+ (string= (uri id) uri))
+ (get-instances-by-class identifier-type-symbol))))
+ (when (and possible-ids
+ (identified-construct (first possible-ids) :revision revision))
+ (unless (= (length possible-ids) 1)
+ (error (make-condition 'duplicate-identifier-error
+ :message (format nil "(length possible-items ~a) for id ~a"
+ possible-ids uri)
+ :uri uri)))
+ (identified-construct (first possible-ids)
+ :revision revision)))))
+ ;no revision need not to be checked, since the revision
+ ;is implicitely checked by the function identified-construct
+ (if result
+ result
+ (when error-if-nil
+ (error "No such item is bound to the given identifier uri.")))))
+
+
+(defun get-item-by-item-identifier (uri &key (revision 0) (error-if-nil nil))
+ "Returns a ReifiableConstructC that is bound to the identifier-uri."
+ (get-item-by-identifier uri :revision revision
+ :identifier-type-symbol 'ItemIdentifierC
+ :error-if-nil error-if-nil))
+
+
+(defun get-item-by-psi (uri &key (revision 0) (error-if-nil nil))
+ "Returns a TopicC that is bound to the identifier-uri."
+ (get-item-by-identifier uri :revision revision
+ :identifier-type-symbol 'PersistentIdC
+ :error-if-nil error-if-nil))
+
+
+(defun get-item-by-locator (uri &key (revision 0) (error-if-nil nil))
+ "Returns a TopicC that is bound to the identifier-uri."
+ (get-item-by-identifier uri :revision revision
+ :identifier-type-symbol 'SubjectLocatorC
+ :error-if-nil error-if-nil))
+
;;; NameC
(defgeneric variants (construct &key revision)
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Wed Feb 24 11:04:46 2010
@@ -1360,7 +1360,7 @@
(if (= revision 0)
found-topic
(find-item-by-revision found-topic revision)))))
- (make-instance 'TopicC :from-oid (subseq topicid 1)))))
+ (elephant::controller-recreate-instance elephant:*store-controller* (subseq topicid 1)))))
(if (and error-if-nil (not result))
(error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision))
result)))
1
0
23 Feb '10
Author: lgiessmann
Date: Tue Feb 23 14:49:01 2010
New Revision: 203
Log:
new-datamode: added some unit-tests for TopicIdentificationC; fixed some bugs related to TopicIdentifiecationC
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Feb 23 14:49:01 2010
@@ -773,26 +773,29 @@
(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
&key (revision *TM-REVISION*))
(let ((all-ids
- (map 'list #'identifier
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'topic-identifiers)))))
- (cond ((find topic-identifier all-ids)
+ (map 'list #'identifier (slot-p construct 'topic-identifiers)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct topic-identifier)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (cond (construct-to-be-merged
+ (merge-constructs (identified-construct construct-to-be-merged
+ :revision revision)
+ construct))
+ ((find topic-identifier all-ids)
(let ((ti-assoc (loop for ti-assoc in (slot-p construct
'topic-identifiers)
when (eql (identifier ti-assoc)
topic-identifier)
return ti-assoc)))
(add-to-version-history ti-assoc :start-revision revision)))
- (all-ids
- (merge-constructs (identified-construct (first all-ids)
- :revision revision)
- construct))
(t
- (make-instance 'TopicIdAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier topic-identifier)
- construct)))))
+ (let ((assoc
+ (make-instance 'TopicIdAssociationC
+ :parent-construct construct
+ :identifier topic-identifier)))
+ (add-to-version-history assoc :start-revision revision))))
+ construct)))
(defgeneric delete-topic-identifier (construct topic-identifier &key 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 Tue Feb 23 14:49:01 2010
@@ -19,12 +19,14 @@
:test-VersionedConstructC
:test-ItemIdentifierC
:test-PersistentIdC
- :test-SubjectLocatorC))
+ :test-SubjectLocatorC
+ :test-TopicIdentificationC))
;;TODO: test merges-constructs when merging was caused by an item-dentifier
;;TODO: test merges-constructs when merging was caused by an psi
;;TODO: test merges-constructs when merging was caused by an subject-locator
+;;TODO: test merges-constructs when merging was caused by a topic-id
@@ -246,10 +248,65 @@
(is-false (locators topic-1 :revision revision-3-5)))))
+(test test-TopicIdentificationC ()
+ "Tests various functions of the TopicIdentificationC class."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((ti-1 (make-instance 'TopicIdentificationC
+ :uri "ti-1"
+ :xtm-id "xtm-id-1"))
+ (ti-2 (make-instance 'TopicIdentificationC
+ :uri "ti-2"
+ :xtm-id "xtm-id-2"))
+ (topic-1 (make-instance 'TopicC))
+ (revision-0 0)
+ (revision-1 100)
+ (revision-2 200)
+ (revision-3 300)
+ (revision-3-5 350)
+ (revision-4 400))
+ (setf d:*TM-REVISION* revision-1)
+ (is-false (identified-construct ti-1))
+ (signals error (make-instance 'TopicIdentificationC
+ :uri "ti-1"))
+ (signals error (make-instance 'TopicIdentificationC
+ :xtm-id "xtm-id-1"))
+ (is-false (topic-identifiers topic-1))
+ (add-topic-identifier topic-1 ti-1)
+ (is (= (length (topic-identifiers topic-1)) 1))
+ (is (eql (first (topic-identifiers topic-1)) ti-1))
+ (is (eql (identified-construct ti-1) topic-1))
+ (add-topic-identifier topic-1 ti-2 :revision revision-2)
+ (is (= (length (topic-identifiers topic-1 :revision revision-0)) 2))
+ (is (= (length (topic-identifiers topic-1 :revision revision-1)) 1))
+ (is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1))
+ (is (= (length (union (list ti-1 ti-2)
+ (topic-identifiers topic-1 :revision revision-2)))
+ 2))
+ (is (= (length (union (list ti-1 ti-2)
+ (topic-identifiers topic-1 :revision revision-0)))
+ 2))
+ (delete-topic-identifier topic-1 ti-1 :revision revision-3)
+ (is (= (length (union (list ti-2)
+ (topic-identifiers topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (union (list ti-1 ti-2)
+ (topic-identifiers topic-1 :revision revision-2)))
+ 2))
+ (delete-topic-identifier topic-1 ti-2 :revision revision-3)
+ (is-false (topic-identifiers topic-1 :revision revision-3))
+ (add-topic-identifier topic-1 ti-1 :revision revision-4)
+ (is (= (length (union (list ti-1)
+ (topic-identifiers topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (d::slot-p topic-1 'd::topic-identifiers)) 2))
+ (is-false (topic-identifiers topic-1 :revision revision-3-5)))))
+
+
(defun run-datamodel-tests()
(it.bese.fiveam:run! 'test-VersionInfoC)
(it.bese.fiveam:run! 'test-VersionedConstructC)
(it.bese.fiveam:run! 'test-ItemIdentifierC)
(it.bese.fiveam:run! 'test-PersistentIdC)
(it.bese.fiveam:run! 'test-SubjectLocatorC)
+ (it.bese.fiveam:run! 'test-TopicIdentificationC)
)
\ No newline at end of file
1
0
23 Feb '10
Author: lgiessmann
Date: Tue Feb 23 14:35:31 2010
New Revision: 202
Log:
new-datamode: added some unit-tests for PersistentIdC and SubjectLocatorC; fixed some bugs related to PersistentIdC, SubjectLocatorC and TopicC
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Feb 23 14:35:31 2010
@@ -87,6 +87,8 @@
(in-package :datamodel)
+;;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
@@ -287,7 +289,7 @@
(psis :associate (PersistentIdAssociationC parent-construct)
:documentation "Contains all association objects that relate a topic
with its actual psis.")
- (locators :associate (PersistentIdAssociationC parent-construct)
+ (locators :associate (SubjectLocatorAssociationC parent-construct)
:documentation "Contains all association objects that relate a
topic with its actual subject-lcoators.")
(names :associate (NameAssociationC parent-construct)
@@ -824,24 +826,27 @@
(:method ((construct TopicC) (psi PersistentIdC)
&key (revision *TM-REVISION*))
(let ((all-ids
- (map 'list #'identifier
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'psis)))))
- (cond ((find psi all-ids)
+ (map 'list #'identifier (slot-p construct 'psis)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct psi)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (cond (construct-to-be-merged
+ (merge-constructs (identified-construct construct-to-be-merged
+ :revision revision)
+ construct))
+ ((find psi all-ids)
(let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
when (eql (identifier psi-assoc) psi)
return psi-assoc)))
(add-to-version-history psi-assoc :start-revision revision)))
- (all-ids
- (merge-constructs (identified-construct (first all-ids)
- :revision revision)
- construct))
(t
- (make-instance 'PersistentIdAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier psi)
- construct)))))
+ (let ((assoc
+ (make-instance 'PersistentIdAssociationC
+ :parent-construct construct
+ :identifier psi)))
+ (add-to-version-history assoc :start-revision revision))))
+ construct)))
(defgeneric delete-psi (construct psi &key revision)
@@ -875,24 +880,27 @@
(:method ((construct TopicC) (locator SubjectLocatorC)
&key (revision *TM-REVISION*))
(let ((all-ids
- (map 'list #'identifier
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'locators)))))
- (cond ((find locator all-ids)
+ (map 'list #'identifier (slot-p construct 'locators)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct locator)))
+ (when (not (eql id-owner construct))
+ id-owner))))
+ (cond (construct-to-be-merged
+ (merge-constructs (identified-construct construct-to-be-merged
+ :revision revision)
+ construct))
+ ((find locator all-ids)
(let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators)
when (eql (identifier loc-assoc) locator)
return loc-assoc)))
(add-to-version-history loc-assoc :start-revision revision)))
- (all-ids
- (merge-constructs (identified-construct (first all-ids)
- :revision revision)
- construct))
(t
- (make-instance 'SubjectLocatorAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier locator)
- construct)))))
+ (let ((assoc
+ (make-instance 'SubjectLocatorAssociationC
+ :parent-construct construct
+ :identifier locator)))
+ (add-to-version-history assoc :start-revision revision))))
+ construct)))
(defgeneric delete-locator (construct locator &key revision)
@@ -1513,16 +1521,16 @@
(let ((id-owner (identified-construct item-identifier)))
(when (not (eql id-owner construct))
id-owner))))
- (cond ((find item-identifier all-ids)
+ (cond (construct-to-be-merged
+ (merge-constructs (identified-construct construct-to-be-merged
+ :revision revision)
+ construct))
+ ((find item-identifier all-ids)
(let ((ii-assoc (loop for ii-assoc in (slot-p construct
'item-identifiers)
when (eql (identifier ii-assoc) item-identifier)
return ii-assoc)))
(add-to-version-history ii-assoc :start-revision revision)))
- (construct-to-be-merged
- (merge-constructs (identified-construct construct-to-be-merged
- :revision revision)
- construct))
(t
(let ((assoc
(make-instance 'ItemIdAssociationC
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Tue Feb 23 14:35:31 2010
@@ -17,7 +17,15 @@
(:export :run-datamodel-tests
:test-VersionInfoC
:test-VersionedConstructC
- :test-ItemIdentifierC))
+ :test-ItemIdentifierC
+ :test-PersistentIdC
+ :test-SubjectLocatorC))
+
+
+;;TODO: test merges-constructs when merging was caused by an item-dentifier
+;;TODO: test merges-constructs when merging was caused by an psi
+;;TODO: test merges-constructs when merging was caused by an subject-locator
+
(declaim (optimize (debug 3)))
@@ -44,9 +52,7 @@
(is (= (d::end-revision vi-1) 300))
(is (= (d::start-revision vi-2) 300))
(is (= (d::end-revision vi-2) 0))
- (is-false (d::versioned-construct-p vi-1))
- (setf (d::versioned-construct vi-1) vc)
- (is-true (d::versioned-construct-p vi-1)))))
+ (setf (d::versioned-construct vi-1) vc))))
(test test-VersionedConstructC ()
@@ -78,9 +84,6 @@
(= sr-2 100) (= er-2 500)))))
(d::add-to-version-history vc :start-revision 600)
(is (= (length (d::versions vc)) 3))
- (map 'list #'(lambda(vi)
- (is-true (d::versioned-construct-p vi)))
- (d::versions vc))
(d::add-to-version-history vc
:start-revision 100
:end-revision 500)
@@ -95,13 +98,13 @@
(test test-ItemIdentifierC ()
- "Tests various functions of the VersionedCoinstructC class."
+ "Tests various functions of the ItemIdentifierC class."
(with-fixture with-empty-db (*db-dir*)
- (let ((ii-1 (make-instance 'd:ItemIdentifierC
+ (let ((ii-1 (make-instance 'ItemIdentifierC
:uri "ii-1"))
- (ii-2 (make-instance 'd:ItemIdentifierC
+ (ii-2 (make-instance 'ItemIdentifierC
:uri "ii-2"))
- (topic-1 (make-instance 'd:TopicC))
+ (topic-1 (make-instance 'TopicC))
(revision-0 0)
(revision-1 100)
(revision-2 200)
@@ -109,14 +112,14 @@
(revision-3-5 350)
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
- (is-false (d:identified-construct ii-1))
- (signals error (make-instance 'd:ItemIdentifierC))
+ (is-false (identified-construct ii-1))
+ (signals error (make-instance 'ItemIdentifierC))
(is-false (item-identifiers topic-1))
- (d:add-item-identifier topic-1 ii-1)
+ (add-item-identifier topic-1 ii-1)
(is (= (length (item-identifiers topic-1)) 1))
(is (eql (first (item-identifiers topic-1)) ii-1))
(is (eql (identified-construct ii-1) topic-1))
- (d:add-item-identifier topic-1 ii-2 :revision revision-2)
+ (add-item-identifier topic-1 ii-2 :revision revision-2)
(is (= (length (item-identifiers topic-1 :revision revision-0)) 2))
(is (= (length (item-identifiers topic-1 :revision revision-1)) 1))
(is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1))
@@ -128,11 +131,11 @@
2))
(delete-item-identifier topic-1 ii-1 :revision revision-3)
(is (= (length (union (list ii-2)
- (d:item-identifiers topic-1
+ (item-identifiers topic-1
:revision revision-0)))
1))
(is (= (length (union (list ii-1 ii-2)
- (d:item-identifiers topic-1
+ (item-identifiers topic-1
:revision revision-2)))
2))
(delete-item-identifier topic-1 ii-2 :revision revision-3)
@@ -143,10 +146,110 @@
1))
(is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2))
(is-false (item-identifiers topic-1 :revision revision-3-5)))))
-
+
+
+(test test-PersistentIdC ()
+ "Tests various functions of the PersistentIdC class."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((psi-1 (make-instance 'PersistentIdC
+ :uri "psi-1"))
+ (psi-2 (make-instance 'PersistentIdC
+ :uri "psi-2"))
+ (topic-1 (make-instance 'TopicC))
+ (revision-0 0)
+ (revision-1 100)
+ (revision-2 200)
+ (revision-3 300)
+ (revision-3-5 350)
+ (revision-4 400))
+ (setf d:*TM-REVISION* revision-1)
+ (is-false (identified-construct psi-1))
+ (signals error (make-instance 'PersistentIdC))
+ (is-false (psis topic-1))
+ (add-psi topic-1 psi-1)
+ (is (= (length (psis topic-1)) 1))
+ (is (eql (first (psis topic-1)) psi-1))
+ (is (eql (identified-construct psi-1) topic-1))
+ (add-psi topic-1 psi-2 :revision revision-2)
+ (is (= (length (psis topic-1 :revision revision-0)) 2))
+ (is (= (length (psis topic-1 :revision revision-1)) 1))
+ (is (eql (first (psis topic-1 :revision revision-1)) psi-1))
+ (is (= (length (union (list psi-1 psi-2)
+ (psis topic-1 :revision revision-2)))
+ 2))
+ (is (= (length (union (list psi-1 psi-2)
+ (psis topic-1 :revision revision-0)))
+ 2))
+ (delete-psi topic-1 psi-1 :revision revision-3)
+ (is (= (length (union (list psi-2)
+ (psis topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (union (list psi-1 psi-2)
+ (psis topic-1 :revision revision-2)))
+ 2))
+ (delete-psi topic-1 psi-2 :revision revision-3)
+ (is-false (psis topic-1 :revision revision-3))
+ (add-psi topic-1 psi-1 :revision revision-4)
+ (is (= (length (union (list psi-1)
+ (psis topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (d::slot-p topic-1 'd::psis)) 2))
+ (is-false (psis topic-1 :revision revision-3-5)))))
+
+
+(test test-SubjectLocatorC ()
+ "Tests various functions of the SubjectLocatorC class."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((sl-1 (make-instance 'SubjectLocatorC
+ :uri "sl-1"))
+ (sl-2 (make-instance 'SubjectLocatorC
+ :uri "sl-2"))
+ (topic-1 (make-instance 'TopicC))
+ (revision-0 0)
+ (revision-1 100)
+ (revision-2 200)
+ (revision-3 300)
+ (revision-3-5 350)
+ (revision-4 400))
+ (setf d:*TM-REVISION* revision-1)
+ (is-false (identified-construct sl-1))
+ (signals error (make-instance 'SubjectLocatorC))
+ (is-false (locators topic-1))
+ (add-locator topic-1 sl-1)
+ (is (= (length (locators topic-1)) 1))
+ (is (eql (first (locators topic-1)) sl-1))
+ (is (eql (identified-construct sl-1) topic-1))
+ (add-locator topic-1 sl-2 :revision revision-2)
+ (is (= (length (locators topic-1 :revision revision-0)) 2))
+ (is (= (length (locators topic-1 :revision revision-1)) 1))
+ (is (eql (first (locators topic-1 :revision revision-1)) sl-1))
+ (is (= (length (union (list sl-1 sl-2)
+ (locators topic-1 :revision revision-2)))
+ 2))
+ (is (= (length (union (list sl-1 sl-2)
+ (locators topic-1 :revision revision-0)))
+ 2))
+ (delete-locator topic-1 sl-1 :revision revision-3)
+ (is (= (length (union (list sl-2)
+ (locators topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (union (list sl-1 sl-2)
+ (locators topic-1 :revision revision-2)))
+ 2))
+ (delete-locator topic-1 sl-2 :revision revision-3)
+ (is-false (locators topic-1 :revision revision-3))
+ (add-locator topic-1 sl-1 :revision revision-4)
+ (is (= (length (union (list sl-1)
+ (locators topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (d::slot-p topic-1 'd::locators)) 2))
+ (is-false (locators topic-1 :revision revision-3-5)))))
+
(defun run-datamodel-tests()
(it.bese.fiveam:run! 'test-VersionInfoC)
(it.bese.fiveam:run! 'test-VersionedConstructC)
(it.bese.fiveam:run! 'test-ItemIdentifierC)
+ (it.bese.fiveam:run! 'test-PersistentIdC)
+ (it.bese.fiveam:run! 'test-SubjectLocatorC)
)
\ No newline at end of file
1
0
22 Feb '10
Author: lgiessmann
Date: Mon Feb 22 14:55:40 2010
New Revision: 201
Log:
new-datamodel: fixed some bugs in item-identifiers, add-item-identifier and delete-item-identifier; added a unit-test for item-identifiers
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 Feb 22 14:55:40 2010
@@ -1508,17 +1508,19 @@
(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
&key (revision *TM-REVISION*))
(let ((all-ids
- (map 'list #'identifier
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'item-identifiers)))))
+ (map 'list #'identifier (slot-p construct 'item-identifiers)))
+ (construct-to-be-merged
+ (let ((id-owner (identified-construct item-identifier)))
+ (when (not (eql id-owner construct))
+ id-owner))))
(cond ((find item-identifier all-ids)
(let ((ii-assoc (loop for ii-assoc in (slot-p construct
'item-identifiers)
when (eql (identifier ii-assoc) item-identifier)
return ii-assoc)))
(add-to-version-history ii-assoc :start-revision revision)))
- (all-ids
- (merge-constructs (identified-construct (first all-ids)
+ (construct-to-be-merged
+ (merge-constructs (identified-construct construct-to-be-merged
:revision revision)
construct))
(t
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 Feb 22 14:55:40 2010
@@ -97,19 +97,52 @@
(test test-ItemIdentifierC ()
"Tests various functions of the VersionedCoinstructC class."
(with-fixture with-empty-db (*db-dir*)
- (setf d:*TM-REVISION* 100)
(let ((ii-1 (make-instance 'd:ItemIdentifierC
:uri "ii-1"))
(ii-2 (make-instance 'd:ItemIdentifierC
:uri "ii-2"))
- (topic (make-instance 'd:TopicC)))
+ (topic-1 (make-instance 'd:TopicC))
+ (revision-0 0)
+ (revision-1 100)
+ (revision-2 200)
+ (revision-3 300)
+ (revision-3-5 350)
+ (revision-4 400))
+ (setf d:*TM-REVISION* revision-1)
(is-false (d:identified-construct ii-1))
(signals error (make-instance 'd:ItemIdentifierC))
- (is-false (item-identifiers topic))
- (d:add-item-identifier topic ii-1)
- (format t ">>> ~a~%" (d::parent-construct ii-1))
- (is (= (length (d:item-identifiers topic)) 1))
- )))
+ (is-false (item-identifiers topic-1))
+ (d:add-item-identifier topic-1 ii-1)
+ (is (= (length (item-identifiers topic-1)) 1))
+ (is (eql (first (item-identifiers topic-1)) ii-1))
+ (is (eql (identified-construct ii-1) topic-1))
+ (d:add-item-identifier topic-1 ii-2 :revision revision-2)
+ (is (= (length (item-identifiers topic-1 :revision revision-0)) 2))
+ (is (= (length (item-identifiers topic-1 :revision revision-1)) 1))
+ (is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1))
+ (is (= (length (union (list ii-1 ii-2)
+ (item-identifiers topic-1 :revision revision-2)))
+ 2))
+ (is (= (length (union (list ii-1 ii-2)
+ (item-identifiers topic-1 :revision revision-0)))
+ 2))
+ (delete-item-identifier topic-1 ii-1 :revision revision-3)
+ (is (= (length (union (list ii-2)
+ (d:item-identifiers topic-1
+ :revision revision-0)))
+ 1))
+ (is (= (length (union (list ii-1 ii-2)
+ (d:item-identifiers topic-1
+ :revision revision-2)))
+ 2))
+ (delete-item-identifier topic-1 ii-2 :revision revision-3)
+ (is-false (item-identifiers topic-1 :revision revision-3))
+ (add-item-identifier topic-1 ii-1 :revision revision-4)
+ (is (= (length (union (list ii-1)
+ (item-identifiers topic-1 :revision revision-0)))
+ 1))
+ (is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2))
+ (is-false (item-identifiers topic-1 :revision revision-3-5)))))
(defun run-datamodel-tests()
1
0
Author: lgiessmann
Date: Mon Feb 22 14:05:06 2010
New Revision: 200
Log:
new-datamode: fixed a problem with elephant-associaitons in the PointerAssociationC-classes
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 Mon Feb 22 14:05:06 2010
@@ -144,29 +144,56 @@
class.")))
-;;; pointers ...
-(defpclass SubjectLocatorC(IdentifierC)
+;;; base classes ...
+(defpclass TopicMapConstructC()
()
- (:index t)
- (:documentation "A subject-locator that contains an uri-value and an
- association to SubjectLocatorAssociationC's which are in
- turn associated with TopicC's."))
+ (:documentation "An abstract base class for all classes that describes
+ Topic Maps data."))
-(defpclass PersistentIdC(IdentifierC)
- ()
- (:index t)
- (:documentation "A subject-identifier that contains an uri-value and an
- association to PersistentIdAssociationC's which are in
- turn associated with TopicC's."))
+(defpclass ScopableC()
+ ((themes :associate (ScopeAssociationC scopable-construct)
+ :inherit t
+ :documentation "Contains all association-objects that contain the
+ actual scope-topics."))
+ (:documentation "An abstract base class for all constructs that are scoped."))
-(defpclass ItemIdentifierC(IdentifierC)
- ()
+(defpclass TypableC()
+ ((instance-of :associate (TypeAssociationC type-topic)
+ :inherit t
+ :documentation "Contains all association-objects that contain
+ the actual type-topic."))
+ (:documentation "An abstract base class for all typed constructcs."))
+
+
+(defpclass DatatypableC()
+ ((datatype :accessor datatype
+ :initarg :datatype
+ :initform constants:*xml-string*
+ :type string
+ :documentation "The XML Schema datatype of the occurrencevalue
+ (optional, always IRI for resourceRef)."))
(:index t)
- (:documentation "An item-identifier that contains an uri-value and an
- association to ItemIdAssociationC's which are in turn
- associated with RiefiableConstructC's."))
+ (:documentation "An abstract base class for characteristics that own
+ an xml-datatype."))
+
+
+;;; pointers ...
+(defpclass PointerC(TopicMapConstructC)
+ ((uri :initarg :uri
+ :accessor uri
+ :inherit t
+ :type string
+ :initform (error "From PointerC(): uri must be set for a pointer")
+ :index t
+ :documentation "The actual value of a pointer, i.e. uri or ID.")
+ (identified-construct :associate (PointerAssociationC identifier)
+ :inherit t
+ :documentation "Associates a association-object that
+ additionally stores some
+ version-infos."))
+ (:documentation "An abstract base class for all pointers."))
(defpclass IdentifierC(PointerC)
@@ -187,23 +214,42 @@
representing one of them."))
-(defpclass PointerC(TopicMapConstructC)
- ((uri :initarg :uri
- :accessor uri
- ;:inherit t
- :type string
- :initform (error "From PointerC(): uri must be set for a pointer")
- :index t
- :documentation "The actual value of a pointer, i.e. uri or ID.")
- (identified-construct :associate (PointerAssociationC identifier)
- :inherit t
- :documentation "Associates a association-object that
- additionally stores some
- version-infos."))
- (:documentation "An abstract base class for all pointers."))
+(defpclass SubjectLocatorC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-locator that contains an uri-value and an
+ association to SubjectLocatorAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-identifier that contains an uri-value and an
+ association to PersistentIdAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "An item-identifier that contains an uri-value and an
+ association to ItemIdAssociationC's which are in turn
+ associated with RiefiableConstructC's."))
;;; reifiables ...
+(defpclass ReifiableConstructC(TopicMapConstructC)
+ ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+ :inherit t
+ :documentation "A relation to all item-identifiers of
+ this construct.")
+ (reifier :associate (ReifierAssociationC reified-construct)
+ :inherit t
+ :documentation "A relation to a reifier-topic."))
+ (:documentation "Reifiable constructs as per TMDM."))
+
+
(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
((roles :associate (RoleAssociationC association)
:documentation "Contains all association-objects of all roles this
@@ -223,17 +269,6 @@
:documentation "Associates this object with a player-association.")))
-(defpclass ReifiableConstructC(TopicMapConstructC)
- ((item-identifiers :associate (ItemIdAssociationC parent-construct)
- :inherit t
- :documentation "A relation to all item-identifiers of
- this construct.")
- (reifier :associate (ReifierAssociationC reified-construct)
- :inherit t
- :documentation "A relation to a reifier-topic."))
- (:documentation "Reifiable constructs as per TMDM."))
-
-
(elephant:defpclass TopicMapC (ReifiableConstructC)
((topics :accessor topics
:associate (TopicC in-topicmaps)
@@ -284,6 +319,22 @@
;;; characteristics ...
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+ ((parent :associate (CharacteriticAssociationC characteristic)
+ :inherit t
+ :documentation "Assocates the characterist obejct with the
+ parent-association.")
+ (charvalue :initarg :charvalue
+ :accessor charvalue
+ :type string
+ :inherit t
+ :initform ""
+ :index t
+ :documentation "Contains the actual data of this object."))
+ (:documentation "Scoped characteristic of a topic (meant to be used
+ as an abstract class)."))
+
+
(defpclass OccurrenceC(CharacteristicC DatatypableC)
()
(:documentation "Represents a TM occurrence."))
@@ -300,23 +351,12 @@
(:documentation "Represents a TM variant."))
-(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
- ((parent :associate (CharacteriticAssociationC characteristic)
- :inherit t
- :documentation "Assocates the characterist obejct with the
- parent-association.")
- (charvalue :initarg :charvalue
- :accessor charvalue
- :type string
- ;:inherit t
- :initform ""
- :index t
- :documentation "Contains the actual data of this object."))
- (:documentation "Scoped characteristic of a topic (meant to be used
- as an abstract class)."))
+;;; versioned associations ...
+(defpclass VersionedAssociationC(VersionedConstructC)
+ ()
+ (:documentation "An abstract base class for all versioned associations."))
-;;; versioned associations ...
(defpclass TypeAssociationC(VersionedAssociationC)
((type-topic :initarg :type-topic
:accessor type-topic
@@ -372,13 +412,19 @@
with a topic."))
-(defpclass VersionedAssociationC(VersionedConstructC)
- ()
- (:documentation "An abstract base class for all versioned associations."))
-
+;;; pointer associations ...
+(defpclass PointerAssociationC (VersionedAssociationC)
+ ((identifier :initarg :identifier
+ :accessor identifier
+ :inherit t
+ :initform (error "From PointerAssociationC(): identifier must be set")
+ :associate PointerC
+ :documentation "The actual data that is associated with
+ the pointer-association's parent."))
+ (:documentation "An abstract base class for all versioned
+ pointer-associations."))
-;;; pointer associations ...
(defpclass SubjectLocatorAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
@@ -423,19 +469,19 @@
and reifiable-constructs."))
-(defpclass PointerAssociationC (VersionedAssociationC)
- ((identifier :initarg :identifier
- :accessor identifier
- ;:inherit t
- :initform (error "From PointerAssociationC(): identifier must be set")
- :associate PointerC
- :documentation "The actual data that is associated with
- the pointer-association's parent."))
- (:documentation "An abstract base class for all versioned
- pointer-associations."))
+;;; characteristic associations ...
+(defpclass CharacteristicAssociationC(VersionedAssociationC)
+ ((characteristic :initarg :characteristic
+ :accessor characteristic
+ :inherit t
+ :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+ :associate CharactersiticC
+ :documentation "Associates this object with the actual
+ characteristic object."))
+ (:documentation "An abstract base class for all association-objects that
+ associates characteristics with topics."))
-;;; characteristic associations ...
(defpclass VariantAssociationC(CharateristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
@@ -466,18 +512,6 @@
Additionally version-infos are stored."))
-(defpclass CharacteristicAssociationC(VersionedAssociationC)
- ((characteristic :initarg :characteristic
- :accessor characteristic
- ;:inherit t
- :initform (error "From CharacteristicCAssociation(): characteristic must be set")
- :associate CharactersiticC
- :documentation "Associates this object with the actual
- characteristic object."))
- (:documentation "An abstract base class for all association-objects that
- associates characteristics with topics."))
-
-
;;; roles/association associations ...
(defpclass PlayerAssociationC(VersionedAssociationC)
((player-topic :initarg :player-topic
@@ -511,48 +545,19 @@
version-infos between these realtions."))
-;;; base classes ...
-(defpclass TopicMapConstructC()
- ()
- (:documentation "An abstract base class for all classes that describes
- Topic Maps data."))
-
-
-(defpclass ScopableC()
- ((themes :associate (ScopeAssociationC scopable-construct)
- :inherit t
- :documentation "Contains all association-objects that contain the
- actual scope-topics."))
- (:documentation "An abstract base class for all constructs that are scoped."))
-
-
-(defpclass TypableC()
- ((instance-of :associate (TypeAssociationC type-topic)
- :inherit t
- :documentation "Contains all association-objects that contain
- the actual type-topic."))
- (:documentation "An abstract base class for all typed constructcs."))
-
-
-(defpclass DatatypableC()
- ((datatype :accessor datatype
- :initarg :datatype
- :initform constants:*xml-string*
- :type string
- :documentation "The XML Schema datatype of the occurrencevalue
- (optional, always IRI for resourceRef)."))
- (:index t)
- (:documentation "An abstract base class for characteristics that own
- an xml-datatype."))
-
-
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun slot-p (instance slot-symbol)
"Returns t if the slot depending on slot-symbol is bound and not nil."
- (when (slot-boundp instance slot-symbol)
- (let ((value (slot-value instance slot-symbol)))
- (when value
- value))))
+ (if (slot-boundp instance slot-symbol)
+ (let ((value (slot-value instance slot-symbol)))
+ (when value
+ value))
+ ;elephant-relations are handled separately, since slot-boundp does not
+ ;here
+ (handler-case (let ((value (slot-value instance slot-symbol)))
+ (when value
+ value))
+ (error () nil))))
(defun delete-1-n-association(instance slot-symbol)
@@ -1517,10 +1522,11 @@
:revision revision)
construct))
(t
- (make-instance 'ItemIdAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier item-identifier)))
+ (let ((assoc
+ (make-instance 'ItemIdAssociationC
+ :parent-construct construct
+ :identifier item-identifier)))
+ (add-to-version-history assoc :start-revision revision))))
construct)))
1
0
21 Feb '10
Author: lgiessmann
Date: Sun Feb 21 15:34:01 2010
New Revision: 199
Log:
new-datamodel: added some example code files that analyses certain situations and elephant's behviour
Added:
branches/new-datamodel/playground/
branches/new-datamodel/playground/ii_versioned_association.lisp
branches/new-datamodel/playground/system_crash.lisp
branches/new-datamodel/playground/versioned-pointer.lisp
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Added: branches/new-datamodel/playground/ii_versioned_association.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/playground/ii_versioned_association.lisp Sun Feb 21 15:34:01 2010
@@ -0,0 +1,117 @@
+(asdf:operate 'asdf:load-op 'elephant)
+(use-package :elephant)
+
+(defpclass VersionInfoC()
+ ((start-revision :initarg :start-revision
+ :accessor start-revision
+ :type integer
+ :initform 0)
+ (end-revision :initarg :end-revision
+ :accessor end-revision
+ :type integer
+ :initform 0)
+ (versioned-construct :initarg :versioned-construct
+ :accessor versioned-construct
+ :associate VersionedConstructC)))
+
+(defpclass VersionedConstructC()
+ ((versions :initarg :versions
+ :accessor versions
+ :inherit t
+ :associate (VersionInfoC versioned-construct))))
+
+
+(defpclass VersionedAssociationC(VersionedConstructC)
+ ())
+
+
+(defpclass PointerAssociationC (VersionedAssociationC)
+ ((identifier :initarg :identifier
+ :accessor identifier
+ :inherit t
+ :initform (error "From PointerAssociationC(): identifier must be set")
+ :associate PointerC)))
+
+
+(defpclass ItemIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+ :associate ReifiableConstructC)))
+
+
+(defpclass TopicMapConstructC()
+ ())
+
+
+(defpclass ReifiableConstructC(TopicMapConstructC)
+ ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+ :inherit t)))
+
+
+(defpclass PointerC(TopicMapConstructC)
+ ((uri :initarg :uri
+ :accessor uri
+ :inherit t
+ :type string
+ :initform (error "From PointerC(): uri must be set for a pointer")
+ :index t)
+ (identified-construct :associate (PointerAssociationC identifier)
+ :inherit t)))
+
+
+(defpclass IdentifierC(PointerC)
+ ())
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+ ()
+ (:index t))
+
+
+(open-store '(:BDB "data_base"))
+(defvar *p* (make-instance 'PointerC
+ :uri "anyUri"))
+(defvar *pa* (make-instance 'PointerAssociationC
+ :identifier *p*))
+
+(defvar *ii* (make-instance 'ItemIdentifierC
+ :uri "anyUri"))
+
+(defvar *pa-ii* (make-instance 'PointerAssociationC
+ :identifier *ii*))
+
+(defvar *ii-2* (make-instance 'ItemIdentifierC
+ :uri "anyUri"))
+
+(defvar *rc* (make-instance 'ReifiableConstructC))
+
+
+(defvar *ia* (make-instance 'ItemIdAssociationC
+ :identifier *ii-2*
+ :parent-construct *rc*))
+
+
+(when (not (slot-value *p* 'identified-construct))
+ (error ">> 1"))
+
+(when (not (slot-value *pa* 'identifier))
+ (error ">> 2"))
+
+(when (not (slot-value *ii* 'identified-construct))
+ (error ">> 3"))
+
+(when (not (slot-value *pa-ii* 'identifier))
+ (error ">> 4"))
+
+(when (not (slot-value *ii-2* 'identified-construct))
+ (error ">> 5"))
+
+(when (not (slot-value *rc* 'item-identifiers))
+ (error ">> 6"))
+
+(when (not (slot-value *ia* 'parent-construct))
+ (error ">> 7"))
+
+(when (not (slot-value *ia* 'identifier))
+ (error ">> 8"))
\ No newline at end of file
Added: branches/new-datamodel/playground/system_crash.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/playground/system_crash.lisp Sun Feb 21 15:34:01 2010
@@ -0,0 +1,3 @@
+(sb-mop:class-slots (find-class 'd:ItemIdentifierC))
+(sb-mop:class-finalized-p (find-class 'd:ItemIdentifierC))
+(sb-mop:finalize-inheritance (find-class 'd:ItemIdentifierC))
Added: branches/new-datamodel/playground/versioned-pointer.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/playground/versioned-pointer.lisp Sun Feb 21 15:34:01 2010
@@ -0,0 +1,28 @@
+(asdf:operate 'asdf:load-op 'elephant)
+(elephant:open-store '(:BDB "data_base"))
+(defpclass Relation()
+ ((to-a :associate NodeA
+ :accessor to-a
+ :initarg :to-a)
+ (to-b :associate NodeB
+ :accessor to-b
+ :initarg :to-b)
+ (version :initarg :version
+ :accessor version
+ :type integer
+ :index t))
+ (:index t))
+(defpclass NodeA()
+ ((relation-to-b :associate (Relation to-a)
+ :accessor relation-to-b
+ :initarg :relation-to-b))
+ (:index t))
+(defpclass NodeB()
+ ((relation-to-a :associate (Relation to-b)
+ :accessor relation-to-a
+ :initarg :relation-to-a))
+ (:index t))
+(defvar *rel* (make-instance 'Relation
+ :to-a (make-instance 'NodeA)
+ :to-b (make-instance 'NodeB)
+ :version 1))
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Sun Feb 21 15:34:01 2010
@@ -190,7 +190,7 @@
(defpclass PointerC(TopicMapConstructC)
((uri :initarg :uri
:accessor uri
- :inherit t
+ ;:inherit t
:type string
:initform (error "From PointerC(): uri must be set for a pointer")
:index t
@@ -308,7 +308,7 @@
(charvalue :initarg :charvalue
:accessor charvalue
:type string
- :inherit t
+ ;:inherit t
:initform ""
:index t
:documentation "Contains the actual data of this object."))
@@ -426,7 +426,7 @@
(defpclass PointerAssociationC (VersionedAssociationC)
((identifier :initarg :identifier
:accessor identifier
- :inherit t
+ ;:inherit t
:initform (error "From PointerAssociationC(): identifier must be set")
:associate PointerC
:documentation "The actual data that is associated with
@@ -469,7 +469,7 @@
(defpclass CharacteristicAssociationC(VersionedAssociationC)
((characteristic :initarg :characteristic
:accessor characteristic
- :inherit t
+ ;:inherit t
:initform (error "From CharacteristicCAssociation(): characteristic must be set")
:associate CharactersiticC
:documentation "Associates this object with the actual
1
0
20 Feb '10
Author: lgiessmann
Date: Sat Feb 20 09:49:30 2010
New Revision: 198
Log:
new-datamodel: fixed some accessor/slot-names; restructured the file datamodel.lisp
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 Feb 20 09:49:30 2010
@@ -78,9 +78,11 @@
:mark-as-deleted-p
:in-topicmaps
:delete-construct
+ :get-revision
;;globals
- :*TM-REVISION*))
+ :*TM-REVISION*
+ :*CURRENT-XTM*))
(in-package :datamodel)
@@ -89,7 +91,7 @@
;; after some data-operations are completed (should be passed as body)
;; and a merge should be done
;;TODO: use some exceptions --> more than one type,
-;; identifier, not-mergable merges, ...
+;; identifier, not-mergable merges, missing-init-args...
;;TODO: implement make-construct -> symbol
;; replace the latest make-construct-method
;;TODO: implement merge-construct -> ReifiableConstructC -> ...
@@ -103,6 +105,447 @@
(defvar *TM-REVISION* 0)
+(defparameter *CURRENT-XTM* nil "Represents the currently active TM.")
+
+
+;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; versioning
+(defpclass VersionInfoC()
+ ((start-revision :initarg :start-revision
+ :accessor start-revision
+ :type integer
+ :initform 0
+ :documentation "The start-revision of the version's
+ interval of a versioned object.")
+ (end-revision :initarg :end-revision
+ :accessor end-revision
+ :type integer
+ :initform 0
+ :documentation "The end-revision of the version's interval
+ of a versioned object.")
+ (versioned-construct :initarg :versioned-construct
+ :accessor versioned-construct
+ :associate VersionedConstructC
+ :documentation "The reference of the versioned
+ object that is described by this
+ VersionInfoC-object."))
+ (:documentation "A VersionInfoC-object describes the revision information
+ of a versioned object in intervals starting by the value
+ start-revision and ending by the value end-revision - 1.
+ end-revision=0 means always the latest version."))
+
+
+(defpclass VersionedConstructC()
+ ((versions :initarg :versions
+ :accessor versions
+ :inherit t
+ :associate (VersionInfoC versioned-construct)
+ :documentation "Version infos for former versions of this base
+ class.")))
+
+
+;;; pointers ...
+(defpclass SubjectLocatorC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-locator that contains an uri-value and an
+ association to SubjectLocatorAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-identifier that contains an uri-value and an
+ association to PersistentIdAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "An item-identifier that contains an uri-value and an
+ association to ItemIdAssociationC's which are in turn
+ associated with RiefiableConstructC's."))
+
+
+(defpclass IdentifierC(PointerC)
+ ()
+ (:documentation "An abstract base class for all TM-Identifiers."))
+
+
+(defpclass TopicIdentificationC(PointerC)
+ ((xtm-id :initarg :xtm-id
+ :accessor xtm-id
+ :type string
+ :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+ :index t
+ :documentation "ID of the TM this identification came from."))
+ (:index t)
+ (:documentation "Identify topic items through generalized topic-ids.
+ A topic may have many original topicids, the class
+ representing one of them."))
+
+
+(defpclass PointerC(TopicMapConstructC)
+ ((uri :initarg :uri
+ :accessor uri
+ :inherit t
+ :type string
+ :initform (error "From PointerC(): uri must be set for a pointer")
+ :index t
+ :documentation "The actual value of a pointer, i.e. uri or ID.")
+ (identified-construct :associate (PointerAssociationC identifier)
+ :inherit t
+ :documentation "Associates a association-object that
+ additionally stores some
+ version-infos."))
+ (:documentation "An abstract base class for all pointers."))
+
+
+;;; reifiables ...
+(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
+ ((roles :associate (RoleAssociationC association)
+ :documentation "Contains all association-objects of all roles this
+ association contains.")
+ (in-topicmaps :associate (TopicMapC associations)
+ :many-to-many t
+ :documentation "List of all topic maps this association is
+ part of"))
+ (:index t)
+ (:documentation "Association in a Topic Map"))
+
+
+(defpclass RoleC(ReifiableConstructC TypableC)
+ ((parent :associate (RoleAssociationC role)
+ :documentation "Associates this object with a role-association.")
+ (player :associate (PlayerAssociationC parent-construct)
+ :documentation "Associates this object with a player-association.")))
+
+
+(defpclass ReifiableConstructC(TopicMapConstructC)
+ ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+ :inherit t
+ :documentation "A relation to all item-identifiers of
+ this construct.")
+ (reifier :associate (ReifierAssociationC reified-construct)
+ :inherit t
+ :documentation "A relation to a reifier-topic."))
+ (:documentation "Reifiable constructs as per TMDM."))
+
+
+(elephant:defpclass TopicMapC (ReifiableConstructC)
+ ((topics :accessor topics
+ :associate (TopicC in-topicmaps)
+ :documentation "List of topics that explicitly belong to this TM.")
+ (associations :accessor associations
+ :associate (AssociationC in-topicmaps)
+ :documentation "List of associations that belong to this TM."))
+ (:documentation "Represnets a topic map."))
+
+
+(defpclass TopicC (ReifiableConstructC)
+ ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
+ :documentation "Contains all association objects that
+ relate a topic with its actual
+ topic-identifiers.")
+ (psis :associate (PersistentIdAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a topic
+ with its actual psis.")
+ (locators :associate (PersistentIdAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a
+ topic with its actual subject-lcoators.")
+ (names :associate (NameAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a topic
+ with its actual names.")
+ (occurrences :associate (OccurrenceAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a
+ topic with its actual occurrences.")
+ (player-in-roles :associate (PlayerAssociationC player-topic)
+ :documentation "Contains all association objects that relate
+ a topic that is a player with its role.")
+ (used-as-type :associate (TypeAssociationC type-topic)
+ :documentation "Contains all association objects that relate a
+ topic that is a type with its typable obejct.")
+ (used-as-theme :associate (ScopeAssociationC theme-topic)
+ :documentation "Contains all association objects that relate a
+ topic that is a theme with its scoppable
+ object.")
+ (reified-construct :associate (ReifiedAssociationC reifier-topic)
+ :documentation "Contains all association objects that
+ relate a topic that is a reifier with
+ its reified object.")
+ (in-topicmaps :associate (TopicMapC topics)
+ :many-to-many t
+ :documentation "List of all topic maps this topic is part of."))
+ (:index t)
+ (:documentation "Represents a TM topic."))
+
+
+
+;;; characteristics ...
+(defpclass OccurrenceC(CharacteristicC DatatypableC)
+ ()
+ (:documentation "Represents a TM occurrence."))
+
+
+(defpclass NameC(CharacteristicC)
+ ((variants :associate (VariantAssociationC parent-construct)
+ :documentation "Associates this obejct with varian-associations."))
+ (:documentation "Scoped name of a topic."))
+
+
+(defpclass VariantC(CharacteristicC DatatypableC)
+ ()
+ (:documentation "Represents a TM variant."))
+
+
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+ ((parent :associate (CharacteriticAssociationC characteristic)
+ :inherit t
+ :documentation "Assocates the characterist obejct with the
+ parent-association.")
+ (charvalue :initarg :charvalue
+ :accessor charvalue
+ :type string
+ :inherit t
+ :initform ""
+ :index t
+ :documentation "Contains the actual data of this object."))
+ (:documentation "Scoped characteristic of a topic (meant to be used
+ as an abstract class)."))
+
+
+;;; versioned associations ...
+(defpclass TypeAssociationC(VersionedAssociationC)
+ ((type-topic :initarg :type-topic
+ :accessor type-topic
+ :initform (error "From TypeAssociationC(): type-topic must be set")
+ :associate TopicC
+ :documentation "Associates this object with a topic that is used
+ as type.")
+ (typable-construct :initarg :typable-construct
+ :accessor typable-construct
+ :initform (error "From TypeAssociationC(): typable-construct must be set")
+ :associate TypableC
+ :documentation "Associates this object with the typable
+ construct that is typed by the
+ type-topic."))
+ (:documentation "This class associates topics that are used as type for
+ typable constructcs. Additionally there are stored some
+ version-infos."))
+
+
+(defpclass ScopeAssociationC(VersionedAssociationC)
+ ((theme-topic :initarg :theme-topic
+ :accessor theme-topic
+ :initform (error "From ScopeAssociationC(): theme-topic must be set")
+ :associate TopicC
+ :documentation "Associates this opbject with a topic that is a
+ scopable construct.")
+ (scopable-construct :initarg :scopable-construct
+ :accessor scopable-construct
+ :initform (error "From ScopeAssociationC(): scopable-construct must be set")
+ :associate ScopableC
+ :documentation "Associates this object with the socpable
+ construct that is scoped by the
+ scope-topic."))
+ (:documentation "This class associates topics that are used as scope with
+ scopable construtcs. Additionally there are stored some
+ version-infos"))
+
+
+(defpclass ReifierAssociationC(VersionedAssociationC)
+ ((reifiable-construct :initarg :reifiable-construct
+ :accessor reifiable-construct
+ :initform (error "From ReifierAssociation(): reifiable-construct must be set")
+ :associate ReifiableConstructC
+ :documentation "The actual construct which is reified
+ by a topic.")
+ (reifier-topic :initarg :reifier-topic
+ :accessor reifier-topic
+ :initform (error "From ReifierAssociationC(): reifier-topic must be set")
+ :associate TopicC
+ :documentation "The reifier-topic that reifies the
+ reifiable-construct."))
+ (:documentation "A versioned-association that relates a reifiable-construct
+ with a topic."))
+
+
+(defpclass VersionedAssociationC(VersionedConstructC)
+ ()
+ (:documentation "An abstract base class for all versioned associations."))
+
+
+
+;;; pointer associations ...
+(defpclass SubjectLocatorAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the subject-locator."))
+ (:documentation "A pointer that associates subject-locators, versions
+ and topics."))
+
+
+(defpclass PersistentIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the subject-identifier/psi."))
+ (:documentation "A pointer that associates subject-identifiers, versions
+ and topics."))
+
+
+(defpclass TopicIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From TopicIdAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "The actual topic which is associated
+ with the topic-identifier."))
+ (:documentation "A pointer that associates topic-identifiers, versions
+ and topics."))
+
+
+(defpclass ItemIdAssociationC(PointerAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+ :associate ReifiableConstructC
+ :documentation "The actual parent which is associated
+ with the item-identifier."))
+ (:documentation "A pointer that associates item-identifiers, versions
+ and reifiable-constructs."))
+
+
+(defpclass PointerAssociationC (VersionedAssociationC)
+ ((identifier :initarg :identifier
+ :accessor identifier
+ :inherit t
+ :initform (error "From PointerAssociationC(): identifier must be set")
+ :associate PointerC
+ :documentation "The actual data that is associated with
+ the pointer-association's parent."))
+ (:documentation "An abstract base class for all versioned
+ pointer-associations."))
+
+
+;;; characteristic associations ...
+(defpclass VariantAssociationC(CharateristicAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From VariantAssociationC(): parent-construct must be set")
+ :associate NameC
+ :documentation "Associates this object with a name."))
+ (:documentation "Associates variant objects with name obejcts.
+ Additionally version-infos are stored."))
+
+
+(defpclass NameAssociationC(CharacteristicAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From NameAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "Associates this object with a topic."))
+ (:documentation "Associates name objects with their parent topics.
+ Additionally version-infos are stored."))
+
+
+(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "Associates this object with a topic."))
+ (:documentation "Associates occurrence objects with their parent topics.
+ Additionally version-infos are stored."))
+
+
+(defpclass CharacteristicAssociationC(VersionedAssociationC)
+ ((characteristic :initarg :characteristic
+ :accessor characteristic
+ :inherit t
+ :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+ :associate CharactersiticC
+ :documentation "Associates this object with the actual
+ characteristic object."))
+ (:documentation "An abstract base class for all association-objects that
+ associates characteristics with topics."))
+
+
+;;; roles/association associations ...
+(defpclass PlayerAssociationC(VersionedAssociationC)
+ ((player-topic :initarg :player-topic
+ :accessor player-topic
+ :associate TopicC
+ :initform (error "From PlayerAssociationC(): player-topic must be set")
+ :documentation "Associates this object with a topic that is
+ a player.")
+ (parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate RoleC
+ :initform (error "From PlayerAssociationC(): parent-construct must be set")
+ :documentation "Associates this object with the parent-association."))
+ (:documentation "This class associates roles and their player in given
+ revisions."))
+
+
+(defpclass RoleAssociationC(VersionedAssociationC)
+ ((role :initarg :role
+ :accessor role
+ :associate RoleC
+ :initform (error "From RoleAssociationC(): role must be set")
+ :documentation "Associates this objetc with a role-object.")
+ (parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate AssociationC
+ :initform (error "From RoleAssociationC(): parent-construct must be set")
+ :documentation "Assocates thius object with an
+ association-object."))
+ (:documentation "Associates roles with assoications and adds some
+ version-infos between these realtions."))
+
+
+;;; base classes ...
+(defpclass TopicMapConstructC()
+ ()
+ (:documentation "An abstract base class for all classes that describes
+ Topic Maps data."))
+
+
+(defpclass ScopableC()
+ ((themes :associate (ScopeAssociationC scopable-construct)
+ :inherit t
+ :documentation "Contains all association-objects that contain the
+ actual scope-topics."))
+ (:documentation "An abstract base class for all constructs that are scoped."))
+
+
+(defpclass TypableC()
+ ((instance-of :associate (TypeAssociationC type-topic)
+ :inherit t
+ :documentation "Contains all association-objects that contain
+ the actual type-topic."))
+ (:documentation "An abstract base class for all typed constructcs."))
+
+
+(defpclass DatatypableC()
+ ((datatype :accessor datatype
+ :initarg :datatype
+ :initform constants:*xml-string*
+ :type string
+ :documentation "The XML Schema datatype of the occurrencevalue
+ (optional, always IRI for resourceRef)."))
+ (:index t)
+ (:documentation "An abstract base class for characteristics that own
+ an xml-datatype."))
+
+
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun slot-p (instance slot-symbol)
"Returns t if the slot depending on slot-symbol is bound and not nil."
@@ -154,46 +597,18 @@
properties))))))
-;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass VersionInfoC()
- ((start-revision :initarg :start-revision
- :accessor start-revision
- :type integer
- :initform 0
- :documentation "The start-revision of the version's
- interval of a versioned object.")
- (end-revision :initarg :end-revision
- :accessor end-revision
- :type integer
- :initform 0
- :documentation "The end-revision of the version's interval
- of a versioned object.")
- (versioned-construct :initarg :versioned-construct
- :accessor versioned-construct
- :associate VersionedConstructC
- :documentation "The reference of the versioned
- object that is described by this
- VersionInfoC-object."))
- (:documentation "A VersionInfoC-object describes the revision information
- of a versioned object in intervals starting by the value
- start-revision and ending by the value end-revision - 1.
- end-revision=0 means always the latest version."))
+(defun get-revision ()
+ "TODO: replace by something that does not suffer from a 1 second resolution."
+ (get-universal-time))
+;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; VersionInfocC
(defmethod delete-construct :before ((version-info VersionInfoC))
(delete-1-n-association version-info 'versioned-construct))
-;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass VersionedConstructC()
- ((versions :initarg :versions
- :accessor versions
- :inherit t
- :associate (VersionInfoC versioned-construct)
- :documentation "Version infos for former versions of this base
- class.")))
-
-
+;;; VersionedConstructC
(defmethod delete-construct :before ((construct VersionedConstructC))
(dolist (version-info (versions construct))
(delete-construct version-info)))
@@ -303,80 +718,7 @@
(setf (end-revision last-version) revision))))
-;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(elephant:defpclass TopicMapC (ReifiableConstructC)
- ((topics :accessor topics
- :associate (TopicC in-topicmaps)
- :documentation "List of topics that explicitly belong to this TM.")
- (associations :accessor associations
- :associate (AssociationC in-topicmaps)
- :documentation "List of associations that belong to this TM."))
- (:documentation "Represnets a topic map."))
-
-
-;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; SubjectLocatorC
-;;; PersistentIdC
-;;; ItemIdentifierC
-;;; IdentifierC
-;;; TopicIdentificationC
;;; PointerC
-(defpclass SubjectLocatorC(IdentifierC)
- ()
- (:index t)
- (:documentation "A subject-locator that contains an uri-value and an
- association to SubjectLocatorAssociationC's which are in
- turn associated with TopicC's."))
-
-
-(defpclass PersistentIdC(IdentifierC)
- ()
- (:index t)
- (:documentation "A subject-identifier that contains an uri-value and an
- association to PersistentIdAssociationC's which are in
- turn associated with TopicC's."))
-
-
-(defpclass ItemIdentifierC(IdentifierC)
- ()
- (:index t)
- (:documentation "An item-identifier that contains an uri-value and an
- association to ItemIdAssociationC's which are in turn
- associated with RiefiableConstructC's."))
-
-
-(defpclass IdentifierC(PointerC)
- ()
- (:documentation "An abstract base class for all TM-Identifiers."))
-
-
-(defpclass TopicIdentificationC(PointerC)
- ((xtm-id :initarg :xtm-id
- :accessor xtm-id
- :type string
- :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
- :index t
- :documentation "ID of the TM this identification came from."))
- (:index t)
- (:documentation "Identify topic items through generalized topic-ids.
- A topic may have many original topicids, the class
- representing one of them."))
-
-
-(defpclass PointerC(TopicMapConstructC)
- ((uri :initarg :uri
- :accessor uri
- :inherit t
- :type string
- :initform (error "From PointerC(): uri must be set for a pointer")
- :index t
- :documentation "The actual value of a pointer, i.e. uri or ID.")
- (identified-construct :initarg :identified-construct
- :associate (PointerAssociationC identifier)
- :inherit t))
- (:documentation "An abstract base class for all pointers."))
-
-
(defgeneric identified-construct (construct &key revision)
(:documentation "Returns the identified-construct -> ReifiableConstructC or
TopicC that corresponds with the passed revision.")
@@ -389,77 +731,7 @@
(first assocs)))))
-;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass TopicC (ReifiableConstructC)
- ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
- :documentation "Contains all association objects that
- relate a topic with its actual
- topic-identifiers.")
- (psis :associate (PersistentIdAssociationC parent-construct)
- :documentation "Contains all association objects that relate a topic
- with its actual psis.")
- (locators :associate (PersistentIdAssociationC parent-construct)
- :documentation "Contains all association objects that relate a
- topic with its actual subject-lcoators.")
- (names :associate (NameAssociationC parent-construct)
- :documentation "Contains all association objects that relate a topic
- with its actual names.")
- (occurrences :associate (OccurrenceAssociationC parent-construct)
- :documentation "Contains all association objects that relate a
- topic with its actual occurrences.")
- (player-in-roles :associate (PlayerAssociationC player-topic)
- :documentation "Contains all association objects that relate
- a topic that is a player with its role.")
- (used-as-type :associate (TypeAssociationC type-topic)
- :documentation "Contains all association objects that relate a
- topic that is a type with its typable obejct.")
- (used-as-theme :associate (ScopeAssociationC theme-topic)
- :documentation "Contains all association objects that relate a
- topic that is a theme with its scoppable
- object.")
- (reified-construct :associate (ReifiedAssociationC reifier-topic)
- :documentation "Contains all association objects that
- relate a topic that is a reifier with
- its reified object.")
- (in-topicmaps :associate (TopicMapC topics)
- :many-to-many t
- :documentation "List of all topic maps this topic is part of."))
- (:index t)
- (:documentation "Represents a TM topic."))
-
-
-(defpclass OccurrenceC(CharacteristicC DatatypableC)
- ()
- (:documentation "Represents a TM occurrence."))
-
-
-(defpclass NameC(CharacteristicC)
- ((variants :associate (VariantAssociationC parent-construct)
- :documentation "Associates this obejct with varian-associations."))
- (:documentation "Scoped name of a topic."))
-
-
-(defpclass VariantC(CharacteristicC DatatypableC)
- ()
- (:documentation "Represents a TM variant."))
-
-
-(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
- ((parent :associate (CharacteriticAssociationC characteristic)
- :inherit t
- :documentation "Assocates the characterist obejct with the
- parent-association.")
- (charvalue :initarg :charvalue
- :accessor charvalue
- :type string
- :inherit t
- :initform ""
- :index t
- :documentation "Contains the actual data of this object."))
- (:documentation "Scoped characteristic of a topic (meant to be used
- as an abstract class)."))
-
-
+;;; TopicC
(defmethod delete-construct :before ((construct TopicC))
"Deletes all association objects of the passed construct."
(dolist (assoc (append (slot-p construct 'topic-identifiers)
@@ -509,10 +781,10 @@
:revision revision)
construct))
(t
- (make-construct 'TopicIdAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier topic-identifier)
+ (make-instance 'TopicIdAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier topic-identifier)
construct)))))
@@ -560,10 +832,10 @@
:revision revision)
construct))
(t
- (make-construct 'PersistentIdAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier psi)
+ (make-instance 'PersistentIdAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier psi)
construct)))))
@@ -611,10 +883,10 @@
:revision revision)
construct))
(t
- (make-construct 'SubjectLocatorAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier locator)
+ (make-instance 'SubjectLocatorAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier locator)
construct)))))
@@ -660,10 +932,10 @@
when (eql (parent-construct name-assoc) name)
return name-assoc)))
(add-to-version-history name-assoc :start-revision revision))
- (make-construct 'NameAssociationC
- :start-revision revision
- :parent-construct construct
- :characteristic name))
+ (make-instance 'NameAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :characteristic name))
construct)))
@@ -709,10 +981,10 @@
when (eql (parent-construct occ-assoc) occurrence)
return occ-assoc)))
(add-to-version-history occ-assoc :start-revision revision))
- (make-construct 'OccurrenceAssociationC
- :start-revision revision
- :parent-construct construct
- :characteristic occurrence))
+ (make-instance 'OccurrenceAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :characteristic occurrence))
construct)))
@@ -773,6 +1045,8 @@
(filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
+
+;;; NameC
(defgeneric variants (construct &key revision)
(:documentation "Returns all variants that correspond with the given revision
and that are associated with the passed construct.")
@@ -786,7 +1060,7 @@
(defgeneric add-variant (construct variant &key revision)
(:documentation "Adds the given theme-topic to the passed
scopable-construct.")
- (:method ((construct ScopableC) (variant VariantC)
+ (:method ((construct NameC) (variant VariantC)
&key (revision *TM-REVISION*))
(when (not (eql (parent variant) construct))
(error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
@@ -822,6 +1096,7 @@
construct)))
+;;; CharacteristicC
(defmethod delete-construct :before ((construct CharacteristicC))
"Deletes all association-obejcts."
(dolist (parent-assoc (slot-p construct 'parent))
@@ -923,66 +1198,20 @@
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
when (eql (characteristic parent-assoc) parent-construct)
- return parent-assoc)))
- (when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- construct))
-
-
-;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; PlayerAssociationC
-;;; RoleAssociationC
-;;; VariantAssociationC
-;;; NameAssociationC
-;;; OccurrenceAssociationC
-;;; CharacteristicAssociationC
-;;; TypeAssociationC
-;;; ScopeAssociationC
-;;; ReifierAssociationC
-;;; SubjectLocatorAssociationC
-;;; PersistentIdAssociationC
-;;; TopicIdAssociationC
-;;; ItemIdAssociationC
-;;; PointerAssociationC
-;;; VersionedAssociationC
-(defpclass PlayerAssociationC(VersionedAssociationC)
- ((player-topic :initarg :player-topic
- :accessor player-topic
- :associate TopicC
- :initform (error "From PlayerAssociationC(): player-topic must be set")
- :documentation "Associates this object with a topic that is
- a player.")
- (parent-construct :initarg :parent-construct
- :accessor parent-construct
- :associate RoleC
- :initform (error "From PlayerAssociationC(): parent-construct must be set")
- :documentation "Associates this object with the parent-association."))
- (:documentation "This class associates roles and their player in given
- revisions."))
+ return parent-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct))
+;;; PlayerAssociationC
(defmethod delete-construct :before ((construct PlayerAssociationC))
"Deletes all elephant-associations."
(delete-1-n-association construct 'player-topic)
(delete-1-n-association construct 'parent-construct))
-(defpclass RoleAssociationC(VersionedAssociationC)
- ((role :initarg :role
- :accessor role
- :associate RoleC
- :initform (error "From RoleAssociationC(): role must be set")
- :documentation "Associates this objetc with a role-object.")
- (parent-construct :initarg :parent-construct
- :accessor parent-construct
- :associate AssociationC
- :initform (error "From RoleAssociationC(): parent-construct must be set")
- :documentation "Assocates thius object with an
- association-object."))
- (:documentation "Associates roles with assoications and adds some
- version-infos between these realtions."))
-
-
+;;; RoleAssociationC
(defmethod delete-construct :before ((construct RoleAssociationC))
"Deletes all elephant-associations and the entire role if it is not
associated with another AssociationC object."
@@ -993,60 +1222,22 @@
(delete-1-n-association construct 'parent-construct)))
-(defpclass VariantAssociationC(CharateristicAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From VariantAssociationC(): parent-construct must be set")
- :associate NameC
- :documentation "Associates this object with a name."))
- (:documentation "Associates variant objects with name obejcts.
- Additionally version-infos are stored."))
-
-
+;;; VariantAssociationC
(defmethod delete-construct :before ((construct VariantAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass NameAssociationC(CharacteristicAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From NameAssociationC(): parent-construct must be set")
- :associate TopicC
- :documentation "Associates this object with a topic."))
- (:documentation "Associates name objects with their parent topics.
- Additionally version-infos are stored."))
-
-
+;;; NameAssociationC
(defmethod delete-construct :before ((construct NameAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
- :associate TopicC
- :documentation "Associates this object with a topic."))
- (:documentation "Associates occurrence objects with their parent topics.
- Additionally version-infos are stored."))
-
-
+;;; OccurrenceAssociationC
(defmethod delete-construct :before ((construct OccurrenceAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass CharacteristicAssociationC(VersionedAssociationC)
- ((characteristic :initarg :characteristic
- :accessor characteristic
- :inherit t
- :initform (error "From CharacteristicCAssociation(): characteristic must be set")
- :associate CharactersiticC
- :documentation "Associates this object with the actual
- characteristic object."))
- (:documentation "An abstract base class for all association-objects that
- associates characteristics with topics."))
-
-
+;;; CharacteristicAssociationC
(defmethod delete-construct :before ((construct CharacteristicAssociationC))
"Deletes all elephant-associations."
(let ((characteristic (characteristic construct)))
@@ -1056,73 +1247,21 @@
(delete-construct characteristic))))
-(defpclass TypeAssociationC(VersionedAssociationC)
- ((type-topic :initarg :type-topic
- :accessor type-topic
- :initform (error "From TypeAssociationC(): type-topic must be set")
- :associate TopicC
- :documentation "Associates this object with a topic that is used
- as type.")
- (typable-construct :initarg :typable-construct
- :accessor typable-construct
- :initform (error "From TypeAssociationC(): typable-construct must be set")
- :associate TypableC
- :documentation "Associates this object with the typable
- construct that is typed by the
- type-topic."))
- (:documentation "This class associates topics that are used as type for
- typable constructcs. Additionally there are stored some
- version-infos."))
-
-
+;;; TypeAssociationC
(defmethod delete-construct :before ((construct TypeAssociationC))
"Deletes all elephant-associations of the given construct."
(delete-1-n-association construct 'type-topic)
(delete-1-n-association construct 'typable-construct))
-(defpclass ScopeAssociationC(VersionedAssociationC)
- ((theme-topic :initarg :theme-topic
- :accessor theme-topic
- :initform (error "From ScopeAssociationC(): theme-topic must be set")
- :associate TopicC
- :documentation "Associates this opbject with a topic that is a
- scopable construct.")
- (scopable-construct :initarg :scopable-construct
- :accessor scopable-construct
- :initform (error "From ScopeAssociationC(): scopable-construct must be set")
- :associate ScopableC
- :documentation "Associates this object with the socpable
- construct that is scoped by the
- scope-topic."))
- (:documentation "This class associates topics that are used as scope with
- scopable construtcs. Additionally there are stored some
- version-infos"))
-
-
+;;; ScopeAssociationC
(defmethod delete-construct :before ((construct ScopeAssociationC))
"Deletes all elephant-associations of this construct."
(delete-1-n-association construct 'theme-topic)
(delete-1-n-association construct 'scopable-topic))
-(defpclass ReifierAssociationC(VersionedAssociationC)
- ((reifiable-construct :initarg :reifiable-construct
- :accessor reifiable-construct
- :initform (error "From ReifierAssociation(): reifiable-construct must be set")
- :associate ReifiableConstructC
- :documentation "The actual construct which is reified
- by a topic.")
- (reifier-topic :initarg :reifier-topic
- :accessor reifier-topic
- :initform (error "From ReifierAssociationC(): reifier-topic must be set")
- :associate TopicC
- :documentation "The reifier-topic that reifies the
- reifiable-construct."))
- (:documentation "A versioned-association that relates a reifiable-construct
- with a topic."))
-
-
+;;; ReifierAssociationC
(defmethod delete-construct :before ((construct ReifierAssociationC))
"Deletes the association-construct and the reifier-topic when it
is not used as a reifier of another construct."
@@ -1133,78 +1272,27 @@
(delete-construct reifier-top))))
-(defpclass SubjectLocatorAssociationC(PointerAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
- :associate TopicC
- :documentation "The actual topic which is associated
- with the subject-locator."))
- (:documentation "A pointer that associates subject-locators, versions
- and topics."))
-
-
+;;; SubjectLocatorAssociationC
(defmethod delete-construct :before ((construct SubjectLocatorAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass PersistentIdAssociationC(PointerAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
- :associate TopicC
- :documentation "The actual topic which is associated
- with the subject-identifier/psi."))
- (:documentation "A pointer that associates subject-identifiers, versions
- and topics."))
-
-
+;;; PersistentIdAssociationC
(defmethod delete-construct :before ((construct PersistentIdAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass TopicIdAssociationC(PointerAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From TopicIdAssociationC(): parent-construct must be set")
- :associate TopicC
- :documentation "The actual topic which is associated
- with the topic-identifier."))
- (:documentation "A pointer that associates topic-identifiers, versions
- and topics."))
-
-
+;;; TopicIdAssociationC
(defmethod delete-construct :before ((construct TopicIdAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass ItemIdAssociationC(PointerAssociationC)
- ((parent-construct :initarg :parent-construct
- :accessor parent-construct
- :initform (error "From ItemIDAssociationC(): parent-construct must be set")
- :associate ReifiableConstructC
- :documentation "The actual parent which is associated
- with the item-identifier."))
- (:documentation "A pointer that associates item-identifiers, versions
- and reifiable-constructs."))
-
-
+;;; ItemIdAssociationC
(defmethod delete-construct :before ((construct ItemIdAssociationC))
(delete-1-n-association construct 'parent-construct))
-(defpclass PointerAssociationC (VersionedAssociationC)
- ((identifier :initarg :identifier
- :accessor identifier
- :inherit t
- :initform (error "From VersionedAssociationC(): identifier must be set")
- :associate PointerC
- :documentation "The actual data that is associated with
- the pointer-association's parent."))
- (:documentation "An abstract base class for all versioned
- pointer-associations."))
-
-
+;;; PointerAssociationC
(defmethod delete-construct :before ((construct PointerAssociationC))
"Deletes the association-construct and the pointer if it is not used
as an idengtiffier of any other object."
@@ -1214,31 +1302,7 @@
(delete-construct id))))
-(defpclass VersionedAssociationC()
- ()
- (:documentation "An abstract base class for all versioned associations."))
-
-
-;;; RoleC + AssociationC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
- ((roles :associate (RoleAssociationC association)
- :documentation "Contains all association-objects of all roles this
- association contains.")
- (in-topicmaps :associate (TopicMapC associations)
- :many-to-many t
- :documentation "List of all topic maps this association is
- part of"))
- (:index t)
- (:documentation "Association in a Topic Map"))
-
-
-(defpclass RoleC(ReifiableConstructC TypableC)
- ((parent :associate (RoleAssociationC role)
- :documentation "Associates this object with a role-association.")
- (player :associate (PlayerAssociationC parent-construct)
- :documentation "Associates this object with a player-association.")))
-
-
+;;; AssociationC
(defmethod delete-construct :before ((construct AssociationC))
"Removes all elephant-associations and deleted all roles that are not
associated by another associations."
@@ -1295,6 +1359,7 @@
(filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
+;;; RoleC
(defmethod delete-construct :before ((construct RoleC))
"Deletes all association-objects."
(dolist (assoc (slot-p construct 'parent))
@@ -1341,7 +1406,7 @@
&key (revision (error "From delete-parent(): revision must be set")))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
- when (eql (association parent-assoc) parent-construct)
+ when (eql (parent-construct parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision))
@@ -1399,18 +1464,7 @@
construct)))
-;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass ReifiableConstructC(TopicMapConstructC)
- ((item-identifiers :associate (ItemIdAssociationC identified-construct)
- :inherit t
- :documentation "A relation to all item-identifiers of
- this construct.")
- (reifier :associate (ReifierAssociationC reified-construct)
- :inherit t
- :documentation "A relation to a reifier-topic."))
- (:documentation "Reifiable constructs as per TMDM."))
-
-
+;;; ReifiableConstructC
(defgeneric item-identifiers (construct &key revision)
(:documentation "Returns the ItemIdentifierC-objects that correspond
with the passed construct and the passed version.")
@@ -1463,11 +1517,11 @@
:revision revision)
construct))
(t
- (make-construct 'ItemIdAssociationC
- :start-revision revision
- :parent-construct construct
- :identifier item-identifier)
- construct)))))
+ (make-instance 'ItemIdAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier item-identifier)))
+ construct)))
(defgeneric delete-item-identifier (construct item-identifier &key revision)
@@ -1509,10 +1563,10 @@
(all-constructs
(merge-constructs (first all-constructs) construct))
(t
- (make-construct 'ReifierAssociationC
- :start-revision revision
- :reifiable-construct construct
- :reifier-topic merged-reifier-topic)
+ (make-instance 'ReifierAssociationC
+ :start-revision revision
+ :reifiable-construct construct
+ :reifier-topic merged-reifier-topic)
construct))))))
@@ -1529,22 +1583,7 @@
construct)))
-;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass TopicMapConstructC()
- ()
- (:documentation "An abstract base class for all classes that describes
- Topic Maps data."))
-
-
-;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass ScopableC()
- ((themes :associate (ScopeAssociationC scopable-construct)
- :inherit t
- :documentation "Contains all association-objects that contain the
- actual scope-topics."))
- (:documentation "An abstract base class for all constructs that are scoped."))
-
-
+;;; ScopableC
(defmethod delete-construct :before ((construct ScopableC))
"Deletes all ScopeAssociationCs that are associated with the given object."
(dolist (theme (slot-p construct 'themes))
@@ -1595,15 +1634,7 @@
construct)))
-;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass TypableC()
- ((instance-of :associate (TypeAssociationC type-topic)
- :inherit t
- :documentation "Contains all association-objects that contain
- the actual type-topic."))
- (:documentation "An abstract base class for all typed constructcs."))
-
-
+;;; TypableC
(defmethod delete-construct :before ((construct TypableC))
"Deletes all TypeAssociationCs that are associated with this object."
(dolist (type (slot-p construct 'instance-of))
@@ -1663,18 +1694,6 @@
construct)))
-;;; DatatypableC
-(defpclass DatatypableC()
- ((datatype :accessor datatype
- :initarg :datatype
- :initform constants:*xml-string*
- :documentation "The XML Schema datatype of the occurrencevalue
- (optional, always IRI for resourceRef)."))
- (:index t)
- (:documentation "An abstract base class for characteristics that own
- an xml-datatype."))
-
-
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 Feb 20 09:49:30 2010
@@ -16,7 +16,8 @@
:unittests-constants)
(:export :run-datamodel-tests
:test-VersionInfoC
- :test-VersionedConstructC))
+ :test-VersionedConstructC
+ :test-ItemIdentifierC))
(declaim (optimize (debug 3)))
@@ -91,11 +92,28 @@
(is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 0))
(is (= (length
(elephant:get-instances-by-class 'd::VersionedConstructC)) 0)))))
-
-
+(test test-ItemIdentifierC ()
+ "Tests various functions of the VersionedCoinstructC class."
+ (with-fixture with-empty-db (*db-dir*)
+ (setf d:*TM-REVISION* 100)
+ (let ((ii-1 (make-instance 'd:ItemIdentifierC
+ :uri "ii-1"))
+ (ii-2 (make-instance 'd:ItemIdentifierC
+ :uri "ii-2"))
+ (topic (make-instance 'd:TopicC)))
+ (is-false (d:identified-construct ii-1))
+ (signals error (make-instance 'd:ItemIdentifierC))
+ (is-false (item-identifiers topic))
+ (d:add-item-identifier topic ii-1)
+ (format t ">>> ~a~%" (d::parent-construct ii-1))
+ (is (= (length (d:item-identifiers topic)) 1))
+ )))
+
+
(defun run-datamodel-tests()
(it.bese.fiveam:run! 'test-VersionInfoC)
(it.bese.fiveam:run! 'test-VersionedConstructC)
+ (it.bese.fiveam:run! 'test-ItemIdentifierC)
)
\ No newline at end of file
1
0
19 Feb '10
Author: lgiessmann
Date: Fri Feb 19 13:34:28 2010
New Revision: 197
Log:
new-datamodel: added the class DatatypableC as abstract base class for variants and occurrences; fixed some problems; updates the uml-schema
Modified:
branches/new-datamodel/docs/isidorus_data_model.pdf
branches/new-datamodel/docs/isidorus_data_model.vsd
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Fri Feb 19 13:34:28 2010 differ
Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Fri Feb 19 13:34:28 2010
@@ -26,11 +26,11 @@
;;methods and functions
:xtm-id
:uri
- :identifieid-construct
+ :identified-construct
:item-identifiers
- :reifier
:add-item-identifier
:delete-item-identifier
+ :reifier
:add-reifier
:delete-reifier
:find-item-by-revision
@@ -40,14 +40,12 @@
:instance-of
:add-type
:delete-type
+ :parent
:add-parent
:delete-parent
:variants
:add-variant
:delete-variant
- :association
- :add-tm-association
- :delete-tm-association
:player
:add-player
:delete-player
@@ -73,16 +71,23 @@
:delete-occurrence
:player-in-roles
:used-as-type
- :ased-as-theme
+ :used-as-theme
+ :datatype
:reified-construct
:mark-as-deleted
+ :mark-as-deleted-p
:in-topicmaps
+ :delete-construct
;;globals
:*TM-REVISION*))
(in-package :datamodel)
+
+;;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
;;TODO: use some exceptions --> more than one type,
;; identifier, not-mergable merges, ...
;;TODO: implement make-construct -> symbol
@@ -423,12 +428,9 @@
(:documentation "Represents a TM topic."))
-(defpclass OccurrenceC(CharacteristicC)
- ((datatype :accessor datatype
- :initarg :datatype
- :initform nil
- :documentation "The XML Schema datatype of the occurrencevalue
- (optional, always IRI for resourceRef).")))
+(defpclass OccurrenceC(CharacteristicC DatatypableC)
+ ()
+ (:documentation "Represents a TM occurrence."))
(defpclass NameC(CharacteristicC)
@@ -437,12 +439,9 @@
(:documentation "Scoped name of a topic."))
-(defpclass VariantC(CharacteristicC)
- ((datatype :accessor datatype
- :initarg :datatype
- :initform nil
- :documentation "The XML Schema datatype of the occurrencevalue
- (optional, always IRI for resourceRef).")))
+(defpclass VariantC(CharacteristicC DatatypableC)
+ ()
+ (:documentation "Represents a TM variant."))
(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
@@ -1234,8 +1233,8 @@
(defpclass RoleC(ReifiableConstructC TypableC)
- ((assocation :associate (RoleAssociationC role)
- :documentation "Associates this object with a role-association.")
+ ((parent :associate (RoleAssociationC role)
+ :documentation "Associates this object with a role-association.")
(player :associate (PlayerAssociationC parent-construct)
:documentation "Associates this object with a player-association.")))
@@ -1298,34 +1297,33 @@
(defmethod delete-construct :before ((construct RoleC))
"Deletes all association-objects."
- (dolist (assoc (slot-p construct 'association))
+ (dolist (assoc (slot-p construct 'parent))
(delete-construct assoc))
(dolist (assoc (slot-p construct 'player))
(delete-construct assoc)))
-(defgeneric association (construct &key revision)
- (:documentation "Returns the construct's parent corresponding to
- the given revision.")
- (:method ((construct RoleC) &key (revision *TM-REVISION*))
- (let ((valid-associations
- (filter-slot-value-by-revision construct 'association
- :start-revision revision)))
- (when valid-associations
- (parent-construct (first valid-associations))))))
-
+(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*))
+ "Returns the construct's parent corresponding to the given revision."
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'parent
+ :start-revision revision)))
+ (when valid-associations
+ (parent-construct (first valid-associations)))))
+
-(defmethod add-tm-association ((construct RoleC) (parent-construct AssociationC)
+(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
&key (revision *TM-REVISION*))
(let ((already-set-parent
- (map 'list #'association
- (filter-slot-value-by-revision construct 'association
+ (map 'list #'parent
+ (filter-slot-value-by-revision construct 'parent
:start-revision revision))))
(cond ((and already-set-parent
(eql (first already-set-parent) parent-construct))
(let ((parent-assoc
- (loop for parent-assoc in (slot-p construct 'association)
- when (eql parent-construct (association parent-assoc))
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct
+ (parent-construct parent-assoc))
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
((not already-set-parent)
@@ -1339,10 +1337,10 @@
construct))
-(defmethod delete-tm-association ((construct RoleC) (parent-construct AssociationC)
+(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
&key (revision (error "From delete-parent(): revision must be set")))
(let ((assoc-to-delete
- (loop for parent-assoc in (slot-p construct 'assocaition)
+ (loop for parent-assoc in (slot-p construct 'parent)
when (eql (association parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
@@ -1665,7 +1663,16 @@
construct)))
-
+;;; DatatypableC
+(defpclass DatatypableC()
+ ((datatype :accessor datatype
+ :initarg :datatype
+ :initform constants:*xml-string*
+ :documentation "The XML Schema datatype of the occurrencevalue
+ (optional, always IRI for resourceRef)."))
+ (:index t)
+ (:documentation "An abstract base class for characteristics that own
+ an xml-datatype."))
1
0
Author: lgiessmann
Date: Thu Feb 18 15:36:34 2010
New Revision: 196
Log:
new-datamodel: added some accessors and helpers to TopicC
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Feb 18 15:36:34 2010
@@ -56,6 +56,25 @@
:delete-role
:associations
:topics
+ :psis
+ :add-psi
+ :delete-psi
+ :topic-identifiers
+ :add-topic-identifier
+ :delete-topic-identifier
+ :locators
+ :add-locator
+ :delete-locator
+ :names
+ :add-name
+ :delete-name
+ :occurrences
+ :add-occurrence
+ :delete-occurrence
+ :player-in-roles
+ :used-as-type
+ :ased-as-theme
+ :reified-construct
:mark-as-deleted
:in-topicmaps
@@ -290,6 +309,81 @@
(:documentation "Represnets a topic map."))
+;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; SubjectLocatorC
+;;; PersistentIdC
+;;; ItemIdentifierC
+;;; IdentifierC
+;;; TopicIdentificationC
+;;; PointerC
+(defpclass SubjectLocatorC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-locator that contains an uri-value and an
+ association to SubjectLocatorAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "A subject-identifier that contains an uri-value and an
+ association to PersistentIdAssociationC's which are in
+ turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+ ()
+ (:index t)
+ (:documentation "An item-identifier that contains an uri-value and an
+ association to ItemIdAssociationC's which are in turn
+ associated with RiefiableConstructC's."))
+
+
+(defpclass IdentifierC(PointerC)
+ ()
+ (:documentation "An abstract base class for all TM-Identifiers."))
+
+
+(defpclass TopicIdentificationC(PointerC)
+ ((xtm-id :initarg :xtm-id
+ :accessor xtm-id
+ :type string
+ :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+ :index t
+ :documentation "ID of the TM this identification came from."))
+ (:index t)
+ (:documentation "Identify topic items through generalized topic-ids.
+ A topic may have many original topicids, the class
+ representing one of them."))
+
+
+(defpclass PointerC(TopicMapConstructC)
+ ((uri :initarg :uri
+ :accessor uri
+ :inherit t
+ :type string
+ :initform (error "From PointerC(): uri must be set for a pointer")
+ :index t
+ :documentation "The actual value of a pointer, i.e. uri or ID.")
+ (identified-construct :initarg :identified-construct
+ :associate (PointerAssociationC identifier)
+ :inherit t))
+ (:documentation "An abstract base class for all pointers."))
+
+
+(defgeneric identified-construct (construct &key revision)
+ (:documentation "Returns the identified-construct -> ReifiableConstructC or
+ TopicC that corresponds with the passed revision.")
+ (:method ((construct PointerC) &key (revision *TM-REVISION*))
+ (let ((assocs
+ (map 'list #'parent-construct
+ (filter-slot-value-by-revision construct 'identified-construct
+ :start-revision revision))))
+ (when assocs ;result must be nil or a list with one item
+ (first assocs)))))
+
+
;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpclass TopicC (ReifiableConstructC)
((topic-identifiers :associate (TopicIdAssociationC parent-construct)
@@ -329,12 +423,6 @@
(:documentation "Represents a TM topic."))
-;;TODO: delete-construct, topic-identifiers, add-topic-identifier,
-;; delete-topic-identifier, psis, add-psi, delete-psi, locators,
-;; add-locator, delete-locator, names, add-name, delete-name,
-;; occurrences, add-occurrence, delete-occurrence, player-in-roles
-;; used-as-type, used-as-theme, reified-construct, in-topicmaps
-
(defpclass OccurrenceC(CharacteristicC)
((datatype :accessor datatype
:initarg :datatype
@@ -373,6 +461,319 @@
as an abstract class)."))
+(defmethod delete-construct :before ((construct TopicC))
+ "Deletes all association objects of the passed construct."
+ (dolist (assoc (append (slot-p construct 'topic-identifiers)
+ (slot-p construct 'psis)
+ (slot-p construct 'locators)
+ (slot-p construct 'names)
+ (slot-p construct 'occurrences)
+ (slot-p construct 'player-in-roles)
+ (slot-p construct 'used-as-type)
+ (slot-p construct 'used-as-theme)
+ (slot-p construct 'reified-construct)))
+ (delete-construct assoc))
+ (dolist (assoc (slot-p construct 'in-topicmaps))
+ (remove-association construct 'in-topicmaps assoc)))
+
+
+(defgeneric topic-identifiers (construct &key revision)
+ (:documentation "Returns the TopicIdentificationC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'topic-identifiers :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric add-topic-identifier (construct topic-identifier &key revision)
+ (:documentation "Adds the passed topic-identifier to the passed topic.
+ If the topic-identifier is already related with the passed
+ topic a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier
+ (remove-if #'marked-as-deleted-p
+ (slot-p construct 'topic-identifiers)))))
+ (cond ((find topic-identifier all-ids)
+ (let ((ti-assoc (loop for ti-assoc in (slot-p construct
+ 'topic-identifiers)
+ when (eql (identifier ti-assoc)
+ topic-identifier)
+ return ti-assoc)))
+ (add-to-version-history ti-assoc :start-revision revision)))
+ (all-ids
+ (merge-constructs (identified-construct (first all-ids)
+ :revision revision)
+ construct))
+ (t
+ (make-construct 'TopicIdAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier topic-identifier)
+ construct)))))
+
+
+(defgeneric delete-topic-identifier (construct topic-identifier &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+ &key (revision (error "From delete-topic-identifier(): revision must be set")))
+ (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers)
+ when (eql (identifier ti-assoc) topic-identifier)
+ return ti-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct)))
+
+
+(defgeneric psis (construct &key revision)
+ (:documentation "Returns the PersistentIdC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'psis :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric add-psi (construct psi &key revision)
+ (:documentation "Adds the passed psi to the passed topic.
+ If the psi is already related with the passed
+ topic a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct TopicC) (psi PersistentIdC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier
+ (remove-if #'marked-as-deleted-p
+ (slot-p construct 'psis)))))
+ (cond ((find psi all-ids)
+ (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
+ when (eql (identifier psi-assoc) psi)
+ return psi-assoc)))
+ (add-to-version-history psi-assoc :start-revision revision)))
+ (all-ids
+ (merge-constructs (identified-construct (first all-ids)
+ :revision revision)
+ construct))
+ (t
+ (make-construct 'PersistentIdAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier psi)
+ construct)))))
+
+
+(defgeneric delete-psi (construct psi &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (psi PersistentIdC)
+ &key (revision (error "From delete-psi(): revision must be set")))
+ (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis)
+ when (eql (identifier psi-assoc) psi)
+ return psi-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct)))
+
+
+(defgeneric locators (construct &key revision)
+ (:documentation "Returns the SubjectLocatorC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'locators :start-revision revision)))
+ (map 'list #'identifier assocs))))
+
+
+(defgeneric add-locator (construct locator &key revision)
+ (:documentation "Adds the passed locator to the passed topic.
+ If the locator is already related with the passed
+ topic a new revision is added.
+ If the passed identifer already identifies another object
+ the identified-constructs are merged.")
+ (:method ((construct TopicC) (locator SubjectLocatorC)
+ &key (revision *TM-REVISION*))
+ (let ((all-ids
+ (map 'list #'identifier
+ (remove-if #'marked-as-deleted-p
+ (slot-p construct 'locators)))))
+ (cond ((find locator all-ids)
+ (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators)
+ when (eql (identifier loc-assoc) locator)
+ return loc-assoc)))
+ (add-to-version-history loc-assoc :start-revision revision)))
+ (all-ids
+ (merge-constructs (identified-construct (first all-ids)
+ :revision revision)
+ construct))
+ (t
+ (make-construct 'SubjectLocatorAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :identifier locator)
+ construct)))))
+
+
+(defgeneric delete-locator (construct locator &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (locator SubjectLocatorC)
+ &key (revision (error "From delete-locator(): revision must be set")))
+ (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators)
+ when (eql (identifier loc-assoc) locator)
+ return loc-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct)))
+
+
+(defgeneric names (construct &key revision)
+ (:documentation "Returns the NameC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'names :start-revision revision)))
+ (map 'list #'characteristic assocs))))
+
+
+(defgeneric add-name (construct name &key revision)
+ (:documentation "Adds the passed name to the passed topic.
+ If the name is already related with the passed
+ topic a new revision is added.
+ If the passed name already owns another object
+ an error is thrown.")
+ (:method ((construct TopicC) (name NameC)
+ &key (revision *TM-REVISION*))
+ (when (not (eql (parent name) construct))
+ (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ name construct (parent name)))
+ (let ((all-names
+ (map 'list #'characteristic
+ (remove-if #'marked-as-deleted-p
+ (slot-p construct 'names)))))
+ (if (find name all-names)
+ (let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
+ when (eql (parent-construct name-assoc) name)
+ return name-assoc)))
+ (add-to-version-history name-assoc :start-revision revision))
+ (make-construct 'NameAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :characteristic name))
+ construct)))
+
+
+(defgeneric delete-name (construct name &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (name NameC)
+ &key (revision (error "From delete-name(): revision must be set")))
+ (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
+ when (eql (parent-construct name-assoc) name)
+ return name-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct)))
+
+
+(defgeneric occurrences (construct &key revision)
+ (:documentation "Returns the OccurrenceC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'occurences :start-revision revision)))
+ (map 'list #'characteristic assocs))))
+
+
+(defgeneric add-occurrence (construct occurrence &key revision)
+ (:documentation "Adds the passed occurrence to the passed topic.
+ If the occurrence is already related with the passed
+ topic a new revision is added.
+ If the passed occurrence already owns another object
+ an error is thrown.")
+ (:method ((construct TopicC) (occurrence OccurrenceC)
+ &key (revision *TM-REVISION*))
+ (when (not (eql (parent occurrence) construct))
+ (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ occurrence construct (parent occurrence)))
+ (let ((all-occurrences
+ (map 'list #'characteristic
+ (remove-if #'marked-as-deleted-p
+ (slot-p construct 'occurrences)))))
+ (if (find occurrence all-occurrences)
+ (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
+ when (eql (parent-construct occ-assoc) occurrence)
+ return occ-assoc)))
+ (add-to-version-history occ-assoc :start-revision revision))
+ (make-construct 'OccurrenceAssociationC
+ :start-revision revision
+ :parent-construct construct
+ :characteristic occurrence))
+ construct)))
+
+
+(defgeneric delete-occurrence (construct occurrence &key revision)
+ (:documentation "Sets the association object between the passed constructs
+ as mark-as-deleted.")
+ (:method ((construct TopicC) (occurrence OccurrenceC)
+ &key (revision (error "From delete-occurrence(): revision must be set")))
+ (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
+ when (eql (parent-construct occ-assoc) occurrence)
+ return occ-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct)))
+
+
+(defgeneric player-in-roles (construct &key revision)
+ (:documentation "Returns the RoleC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'player-in-roles :start-revision revision)))
+ (map 'list #'parent-construct assocs))))
+
+
+(defgeneric used-as-type (construct &key revision)
+ (:documentation "Returns the TypableC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'used-as-type :start-revision revision)))
+ (map 'list #'typable-construct assocs))))
+
+
+(defgeneric used-as-theme (construct &key revision)
+ (:documentation "Returns the ScopableC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'used-as-theme :start-revision revision)))
+ (map 'list #'scopable-construct assocs))))
+
+
+(defgeneric reified-construct (construct &key revision)
+ (:documentation "Returns the ReifiableConstructC-objects that correspond
+ with the passed construct and the passed version.")
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
+ (let ((assocs (filter-slot-value-by-revision
+ construct 'reified-construct :start-revision revision)))
+ (map 'list #'reifiable-construct assocs))))
+
+
+(defgeneric in-topicmaps (construct &key revision)
+ (:documentation "Returns all TopicMapS-obejcts where the constrict is
+ contained in."))
+
+(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*))
+ (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
+
+
(defgeneric variants (construct &key revision)
(:documentation "Returns all variants that correspond with the given revision
and that are associated with the passed construct.")
@@ -388,6 +789,9 @@
scopable-construct.")
(:method ((construct ScopableC) (variant VariantC)
&key (revision *TM-REVISION*))
+ (when (not (eql (parent variant) construct))
+ (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
+ variant construct (parent variant)))
(let ((all-variants
(map 'list #'characteristic
(remove-if #'marked-as-deleted-p
@@ -425,6 +829,12 @@
(delete-construct parent-assoc)))
+(defmethod delete-construct :before ((construct NameC))
+ "Deletes all association-obejcts."
+ (dolist (variant-assoc (slot-p construct 'variants))
+ (delete-construct variant-assoc)))
+
+
(defgeneric parent (construct &key revision)
(:documentation "Returns the parent construct of the passed object that
corresponds with the given revision. The returned construct
@@ -434,10 +844,7 @@
(filter-slot-value-by-revision construct 'parent
:start-revision revision)))
(when valid-associations
- (let ((valid-assoc (first valid-associations)))
- (if (typep valid-assoc 'VariantAssociationC)
- (name valid-assoc)
- (topic valid-assoc)))))))
+ (parent-construct (first valid-associations))))))
(defgeneric add-parent (construct parent-construct &key revision)
@@ -448,14 +855,15 @@
(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
&key (revision *TM-REVISION*))
(let ((already-set-topic
- (map 'list #'topic
+ (map 'list #'parent-construct
(filter-slot-value-by-revision construct 'parent
:start-revision revision))))
(cond ((and already-set-topic
(eql (first already-set-topic) parent-construct))
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
- when (eql parent-construct (topic parent-assoc))
+ when (eql parent-construct (parent-construct
+ parent-assoc))
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
((not already-set-topic)
@@ -474,14 +882,14 @@
(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
&key (revision *TM-REVISION*))
(let ((already-set-name
- (map 'list #'name
+ (map 'list #'characteristic
(filter-slot-value-by-revision construct 'parent
:start-revision revision))))
(cond ((and already-set-name
(eql (first already-set-name) parent-construct))
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
- when (eql parent-construct (name parent-assoc))
+ when (eql parent-construct (characteristic parent-assoc))
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
((not already-set-name)
@@ -504,7 +912,7 @@
&key (revision (error "From delete-parent(): revision must be set")))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
- when (eql (topic parent-assoc) parent-construct)
+ when (eql (parent-construct parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision))
@@ -515,7 +923,7 @@
&key (revision (error "From delete-parent(): revision must be set")))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
- when (eql (name parent-assoc) parent-construct)
+ when (eql (characteristic parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision))
@@ -993,81 +1401,6 @@
construct)))
-;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; SubjectLocatorC
-;;; PersistentIdC
-;;; ItemIdentifierC
-;;; IdentifierC
-;;; TopicIdentificationC
-;;; PointerC
-(defpclass SubjectLocatorC(IdentifierC)
- ()
- (:index t)
- (:documentation "A subject-locator that contains an uri-value and an
- association to SubjectLocatorAssociationC's which are in
- turn associated with TopicC's."))
-
-
-(defpclass PersistentIdC(IdentifierC)
- ()
- (:index t)
- (:documentation "A subject-identifier that contains an uri-value and an
- association to PersistentIdAssociationC's which are in
- turn associated with TopicC's."))
-
-
-(defpclass ItemIdentifierC(IdentifierC)
- ()
- (:index t)
- (:documentation "An item-identifier that contains an uri-value and an
- association to ItemIdAssociationC's which are in turn
- associated with RiefiableConstructC's."))
-
-
-(defpclass IdentifierC(PointerC)
- ()
- (:documentation "An abstract base class for all TM-Identifiers."))
-
-
-(defpclass TopicIdentificationC(PointerC)
- ((xtm-id :initarg :xtm-id
- :accessor xtm-id
- :type string
- :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
- :index t
- :documentation "ID of the TM this identification came from."))
- (:index t)
- (:documentation "Identify topic items through generalized topic-ids.
- A topic may have many original topicids, the class
- representing one of them."))
-
-
-(defpclass PointerC(TopicMapConstructC)
- ((uri :initarg :uri
- :accessor uri
- :inherit t
- :type string
- :initform (error "From PointerC(): uri must be set for a pointer")
- :index t
- :documentation "The actual value of a pointer, i.e. uri or ID.")
- (identified-construct :initarg :identified-construct
- :associate (PointerAssociationC identifier)
- :inherit t))
- (:documentation "An abstract base class for all pointers."))
-
-
-(defgeneric identified-construct (construct &key revision)
- (:documentation "Returns the identified-construct -> ReifiableConstructC or
- TopicC that corresponds with the passed revision.")
- (:method ((construct PointerC) &key (revision *TM-REVISION*))
- (let ((assocs
- (map 'list #'parent-construct
- (filter-slot-value-by-revision construct 'identified-construct
- :start-revision revision))))
- (when assocs ;result must be nil or a list with one item
- (first assocs)))))
-
-
;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpclass ReifiableConstructC(TopicMapConstructC)
((item-identifiers :associate (ItemIdAssociationC identified-construct)
1
0
17 Feb '10
Author: lgiessmann
Date: Wed Feb 17 16:39:10 2010
New Revision: 195
Log:
new-datamodel: updated the uml-schema; started to implement TopiC; implemented TopicMapC
Modified:
branches/new-datamodel/docs/isidorus_data_model.pdf
branches/new-datamodel/docs/isidorus_data_model.vsd
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Wed Feb 17 16:39:10 2010 differ
Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Wed Feb 17 16:39:10 2010
@@ -11,6 +11,7 @@
(:use :cl :elephant :constants)
(:nicknames :d)
(:export ;;classes
+ :TopicMapC
:AssociationC
:RoleC
:OccurrenceC
@@ -53,6 +54,8 @@
:roles
:add-role
:delete-role
+ :associations
+ :topics
:mark-as-deleted
:in-topicmaps
@@ -72,31 +75,6 @@
;; one revision-infos
-
-;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;
-(defpclass TopicC (TopicMapConstructC)
- ()
- (:documentation "A temporary emtpy class to avoid compiler-errors."))
-
-
-(defgeneric merge-constructs(construc-1 construct-2 &key revision)
- (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
- &key (revision *TM-REVISION*))
- (or construct-1 construct-2 revision)))
-
-
-(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
- (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*))
- (or class-symbol start-revision)))
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-
-
-
-
-
;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *TM-REVISION* 0)
@@ -301,7 +279,62 @@
(setf (end-revision last-version) revision))))
-;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(elephant:defpclass TopicMapC (ReifiableConstructC)
+ ((topics :accessor topics
+ :associate (TopicC in-topicmaps)
+ :documentation "List of topics that explicitly belong to this TM.")
+ (associations :accessor associations
+ :associate (AssociationC in-topicmaps)
+ :documentation "List of associations that belong to this TM."))
+ (:documentation "Represnets a topic map."))
+
+
+;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass TopicC (ReifiableConstructC)
+ ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
+ :documentation "Contains all association objects that
+ relate a topic with its actual
+ topic-identifiers.")
+ (psis :associate (PersistentIdAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a topic
+ with its actual psis.")
+ (locators :associate (PersistentIdAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a
+ topic with its actual subject-lcoators.")
+ (names :associate (NameAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a topic
+ with its actual names.")
+ (occurrences :associate (OccurrenceAssociationC parent-construct)
+ :documentation "Contains all association objects that relate a
+ topic with its actual occurrences.")
+ (player-in-roles :associate (PlayerAssociationC player-topic)
+ :documentation "Contains all association objects that relate
+ a topic that is a player with its role.")
+ (used-as-type :associate (TypeAssociationC type-topic)
+ :documentation "Contains all association objects that relate a
+ topic that is a type with its typable obejct.")
+ (used-as-theme :associate (ScopeAssociationC theme-topic)
+ :documentation "Contains all association objects that relate a
+ topic that is a theme with its scoppable
+ object.")
+ (reified-construct :associate (ReifiedAssociationC reifier-topic)
+ :documentation "Contains all association objects that
+ relate a topic that is a reifier with
+ its reified object.")
+ (in-topicmaps :associate (TopicMapC topics)
+ :many-to-many t
+ :documentation "List of all topic maps this topic is part of."))
+ (:index t)
+ (:documentation "Represents a TM topic."))
+
+
+;;TODO: delete-construct, topic-identifiers, add-topic-identifier,
+;; delete-topic-identifier, psis, add-psi, delete-psi, locators,
+;; add-locator, delete-locator, names, add-name, delete-name,
+;; occurrences, add-occurrence, delete-occurrence, player-in-roles
+;; used-as-type, used-as-theme, reified-construct, in-topicmaps
+
(defpclass OccurrenceC(CharacteristicC)
((datatype :accessor datatype
:initarg :datatype
@@ -311,7 +344,7 @@
(defpclass NameC(CharacteristicC)
- ((variants :associate (VariantAssociationC name)
+ ((variants :associate (VariantAssociationC parent-construct)
:documentation "Associates this obejct with varian-associations."))
(:documentation "Scoped name of a topic."))
@@ -329,13 +362,13 @@
:inherit t
:documentation "Assocates the characterist obejct with the
parent-association.")
- (charavalue :initarg :charvalue
- :accessor charvalue
- :type string
- :inherit t
- :initform ""
- :index t
- :documentation "Contains the actual data of this object."))
+ (charvalue :initarg :charvalue
+ :accessor charvalue
+ :type string
+ :inherit t
+ :initform ""
+ :index t
+ :documentation "Contains the actual data of this object."))
(:documentation "Scoped characteristic of a topic (meant to be used
as an abstract class)."))
@@ -368,7 +401,7 @@
(make-instance 'VariantAssociationC
:start-revision revision
:characteristic variant
- :name construct)))
+ :parent-construct construct)))
construct))
@@ -430,7 +463,7 @@
'OccurrenceAssociationC
'NameAssociationC)
:start-revision revision
- :topic parent-construct
+ :parent-construct parent-construct
:characteristic construct))
(t
(error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
@@ -454,7 +487,7 @@
((not already-set-name)
(make-instance 'VariantAssociationC
:start-revision revision
- :name parent-construct
+ :parent-construct parent-construct
:characteristic construct))
(t
(error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
@@ -512,11 +545,11 @@
:initform (error "From PlayerAssociationC(): player-topic must be set")
:documentation "Associates this object with a topic that is
a player.")
- (role :initarg :role
- :accessor role
- :associate RoleC
- :initform (error "From PlayerAssociationC(): role must be set")
- :documentation "Associates this object with the parent-association."))
+ (parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :associate RoleC
+ :initform (error "From PlayerAssociationC(): parent-construct must be set")
+ :documentation "Associates this object with the parent-association."))
(:documentation "This class associates roles and their player in given
revisions."))
@@ -524,7 +557,7 @@
(defmethod delete-construct :before ((construct PlayerAssociationC))
"Deletes all elephant-associations."
(delete-1-n-association construct 'player-topic)
- (delete-1-n-association construct 'role))
+ (delete-1-n-association construct 'parent-construct))
(defpclass RoleAssociationC(VersionedAssociationC)
@@ -536,7 +569,7 @@
(parent-construct :initarg :parent-construct
:accessor parent-construct
:associate AssociationC
- :initform (error "From RoleAssociationC(): association must be set")
+ :initform (error "From RoleAssociationC(): parent-construct must be set")
:documentation "Assocates thius object with an
association-object."))
(:documentation "Associates roles with assoications and adds some
@@ -554,45 +587,45 @@
(defpclass VariantAssociationC(CharateristicAssociationC)
- ((name :initarg :name
- :accessor name
- :initform (error "From VariantAssociationC(): name must be set")
- :associate NameC
- :documentation "Associates this object with a name."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From VariantAssociationC(): parent-construct must be set")
+ :associate NameC
+ :documentation "Associates this object with a name."))
(:documentation "Associates variant objects with name obejcts.
Additionally version-infos are stored."))
(defmethod delete-construct :before ((construct VariantAssociationC))
- (delete-1-n-association construct 'name))
+ (delete-1-n-association construct 'parent-construct))
(defpclass NameAssociationC(CharacteristicAssociationC)
- ((topic :initarg :topic
- :accessor topic
- :initform (error "From NameAssociationC(): topic must be set")
- :associate TopicC
- :documentation "Associates this object with a topic."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From NameAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "Associates this object with a topic."))
(:documentation "Associates name objects with their parent topics.
Additionally version-infos are stored."))
(defmethod delete-construct :before ((construct NameAssociationC))
- (delete-1-n-association construct 'topic))
+ (delete-1-n-association construct 'parent-construct))
(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
- ((topic :initarg :topic
- :accessor topic
- :initform (error "From OccurrenceAssociationC(): topic must be set")
- :associate TopicC
- :documentation "Associates this object with a topic."))
+ ((parent-construct :initarg :parent-construct
+ :accessor parent-construct
+ :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+ :associate TopicC
+ :documentation "Associates this object with a topic."))
(:documentation "Associates occurrence objects with their parent topics.
Additionally version-infos are stored."))
(defmethod delete-construct :before ((construct OccurrenceAssociationC))
- (delete-1-n-association construct 'topic))
+ (delete-1-n-association construct 'parent-construct))
(defpclass CharacteristicAssociationC(VersionedAssociationC)
@@ -795,7 +828,7 @@
(defpclass RoleC(ReifiableConstructC TypableC)
((assocation :associate (RoleAssociationC role)
:documentation "Associates this object with a role-association.")
- (player :associate (PlayerAssociationC parent-role)
+ (player :associate (PlayerAssociationC parent-construct)
:documentation "Associates this object with a player-association.")))
@@ -938,7 +971,7 @@
((not already-set-player)
(make-instance 'PlayerAssociationC
:start-revision revision
- :role construct
+ :parent-construct construct
:player-topic player-topic))
(t
(error "From add-player(): ~a can't be a player of ~a since it has already the player ~a"
@@ -1037,13 +1070,11 @@
;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpclass ReifiableConstructC(TopicMapConstructC)
- ((item-identifiers :initarg :item-identifiers
- :associate (ItemIdAssociationC identified-construct)
+ ((item-identifiers :associate (ItemIdAssociationC identified-construct)
:inherit t
:documentation "A relation to all item-identifiers of
this construct.")
- (reifier :initarg :reifier
- :associate (ReifierAssociationC reified-construct)
+ (reifier :associate (ReifierAssociationC reified-construct)
:inherit t
:documentation "A relation to a reifier-topic."))
(:documentation "Reifiable constructs as per TMDM."))
@@ -1298,4 +1329,31 @@
return type-assoc)))
(when assoc-to-delete
(mark-as-deleted assoc-to-delete :revision revision))
- construct)))
\ No newline at end of file
+ construct)))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric merge-constructs(construc-1 construct-2 &key revision)
+ (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+ &key (revision *TM-REVISION*))
+ (or construct-1 construct-2 revision)))
+
+
+(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
+ (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*))
+ (or class-symbol start-revision)))
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
1
0